From 5145dd3aa0c02c9fc496d1432fc4410674206e1d Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:31 -0800
Subject: Import Upstream version 3a2

---
 srfi-1.scm | 382 +++++++++++++++++++++++++++++++++++++++++++++----------------
 1 file changed, 284 insertions(+), 98 deletions(-)

(limited to 'srfi-1.scm')

diff --git a/srfi-1.scm b/srfi-1.scm
index d0f436f..c479491 100644
--- a/srfi-1.scm
+++ b/srfi-1.scm
@@ -1,6 +1,7 @@
 ;;; "srfi-1.scm" SRFI-1 list-processing library		-*-scheme-*-
 ;; Copyright 2001 Aubrey Jaffer
 ;; Copyright 2003 Sven Hartrumpf
+;; Copyright 2003-2004 Lars Buitinck
 ;
 ;Permission to copy this software, to modify it, to redistribute it,
 ;to distribute modified versions, and to use it for any purpose is
@@ -38,11 +39,13 @@
 
 ;;@subheading Constructors
 
-;;@body @code{(define (xcons d a) (cons a d))}.
+;;@body
+;; @code{(define (xcons d a) (cons a d))}.
 (define (xcons d a) (cons a d))
 
-;;@body Returns a list of length @1.  Element @var{i} is @code{(@2
-;;@var{i})} for 0 <= @var{i} < @1.
+;;@body
+;; Returns a list of length @1.  Element @var{i} is
+;;@code{(@2 @var{i})} for 0 <= @var{i} < @1.
 (define (list-tabulate len proc)
   (do ((i (- len 1) (- i 1))
        (ans '() (cons (proc i) ans)))
@@ -122,23 +125,24 @@
 (define third  caddr)
 ;;@args pair
 (define fourth cadddr)
-;;@args pair
-(define (fifth   obj) (car    (cddddr obj)))
-(define (sixth   obj) (cadr   (cddddr obj)))
-(define (seventh obj) (caddr  (cddddr obj)))
-(define (eighth  obj) (cadddr (cddddr obj)))
-(define (ninth   obj) (car  (cddddr (cddddr obj))))
-(define (tenth   obj) (cadr (cddddr (cddddr obj))))
+;;@body
+(define (fifth   pair) (car    (cddddr pair)))
+(define (sixth   pair) (cadr   (cddddr pair)))
+(define (seventh pair) (caddr  (cddddr pair)))
+(define (eighth  pair) (cadddr (cddddr pair)))
+(define (ninth   pair) (car  (cddddr (cddddr pair))))
+(define (tenth   pair) (cadr (cddddr (cddddr pair))))
 
 ;;@body
 (define (car+cdr pair) (values (car pair) (cdr pair)))
 
-;;@body
+;;@args lst k
 (define (drop lst k) (nthcdr k lst))
 (define (take lst k) (butnthcdr k lst))
-;;@args lst k
-(define take! take)
-
+(define (take! lst k)
+  (if (or (null? lst) (<= k 0))
+    '()
+    (begin (set-cdr! (drop (- k 1) lst) '()) lst)))
 ;;@args lst k
 (define take-right last)
 ;;@args lst k
@@ -146,13 +150,21 @@
 ;;@args lst k
 (define drop-right! drop-right)
 
-;;@args lst k
-(define (split-at lst k) (values (take lst k) (drop lst k)))
-;;@args lst k
-(define split-at! split-at)
+;;@body
+(define (split-at lst k)
+  (let loop ((l '()) (r lst) (k k))
+    (if (or (null? r) (= k 0))
+      (values (reverse! l) r)
+      (loop (cons (car r) l) (cdr r) (- k 1)))))
+(define (split-at! lst k)
+  (if (= k 0)
+    (values '() lst)
+    (let* ((half (drop lst (- k 1)))
+	   (r (cdr half)))
+      (set-cdr! half '())
+      (values lst r))))
 
-;;@args lst
-;;(car (last-pair lst))
+;;@body
 (define (last lst . k)
   (if (null? k)
       (car (last-pair lst))
@@ -161,7 +173,7 @@
 ;;@subheading Miscellaneous
 
 ;;@body
-(define (length+ obj) (and (list? obj) (length obj)))
+(define (length+ clist) (and (list? clist) (length clist)))
 
 ;;Append and append! are provided by R4RS and rev2-procedures.
 
@@ -214,42 +226,83 @@
 
 ;;@subheading Fold and Unfold
 
+;;@args kons knil clist1 clist2 ...
+(define (fold f z l1 . l)
+  (set! l (cons l1 l))
+  (if (any null? l)
+      z
+      (apply fold (cons* f (apply f (append! (map car l) (list z)))
+			 (map cdr l)))))
+;;@args kons knil clist1 clist2 ...
+(define (fold-right f z l1 . l)
+  (set! l (cons l1 l))
+  (if (any null? l)
+      z
+      (apply f (append! (map car l)
+			(list (apply fold-right (cons* f z (map cdr l))))))))
+;;@args kons knil clist1 clist2 ...
+(define (pair-fold f z l)		;XXX should be multi-arg
+  (if (null? l)
+      z
+      (let ((tail (cdr l)))
+	(pair-fold f (f l z) tail))))
+;;@args kons knil clist1 clist2 ...
+(define (pair-fold-right f z l)		;XXX should be multi-arg
+  (if (null? l)
+      z
+      (f l (pair-fold-right f z (cdr l)))))
 
-;;; We stop when LIS1 runs out, not when any list runs out.
-;;@args f list1 clist2 ...
-(define (map! f lis1 . lists)
+;;@body
+(define (reduce f ridentity list)
+  (if (null? list) ridentity (fold f (car list) (cdr list))))
+(define (reduce-right f ridentity list)
+  (if (null? list)
+      ridentity
+      (let red ((l (cdr list)) (ridentity (car list)))
+	(if (null? list)
+	    ridentity
+	    (f ridentity (red (cdr list) (car list)))))))
+
+;;; We stop when CLIST1 runs out, not when any list runs out.
+;;@args f clist1 clist2 ...
+(define (map! f clist1 . lists)
   (if (pair? lists)
-      (let lp ((lis1 lis1) (lists lists))
-	(if (not (null-list? lis1))
+      (let lp ((clist1 clist1) (lists lists))
+	(if (not (null-list? clist1))
 	    (call-with-values ; expanded a receive call
               (lambda () (%cars+cdrs/no-test lists))
               (lambda (heads tails)
-                (set-car! lis1 (apply f (car lis1) heads))
-                (lp (cdr lis1) tails)))))
-
+                (set-car! clist1 (apply f (car clist1) heads))
+                (lp (cdr clist1) tails)))))
       ;; Fast path.
-      (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
-  lis1)
-
+      (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) clist1))
+  clist1)
 ;;@args f clist1 clist2 ...
-(define (pair-for-each proc lis1 . lists)
+(define (pair-for-each proc clist1 . lists)
   (if (pair? lists)
-      (let lp ((lists (cons lis1 lists)))
+      (let lp ((lists (cons clist1 lists)))
 	(let ((tails (%cdrs lists)))
 	  (if (pair? tails)
 	      (begin (apply proc lists)
 		     (lp tails)))))
       ;; Fast path.
-      (let lp ((lis lis1))
+      (let lp ((lis clist1))
 	(if (not (null-list? lis))
 	    (let ((tail (cdr lis)))	; Grab the cdr now,
 	      (proc lis)		; in case PROC SET-CDR!s LIS.
 	      (lp tail))))))
 
+(define (filter-map f l1 . l)
+  (let loop ((l (cons l1 l)) (r '()))
+    (if (any null? l)
+      (reverse! r)
+      (let ((x (apply f (map car l))))
+	(loop (map! cdr l) (if x (cons x r) r))))))
+
 
 ;;@subheading Filtering and Partitioning
 
-;;@body
+;;@args pred list
 (define (filter pred lis)			; Sleazing with EQ? makes this one faster.
   (let recur ((lis lis))
     (if (null-list? lis) lis			; Use NOT-PAIR? to handle dotted lists.
@@ -260,32 +313,10 @@
 		(if (eq? tail new-tail) lis
 		    (cons head new-tail)))
 	      (recur tail))))))			; this one can be a tail call.
-;;@body
-(define (filter! pred l)
-  (if (null? l)
-      l
-      (let ((l2 l)
-	    (l3 (cdr l)))
-	(do ((end #f)
-	     (result '()))
-	    (end result)
-	  (cond ((pred (car l2))	; keep the first element of l2
-		 (cond ((null? result)
-			(set! result l2))) ; first pair of remaining elements
-		 (cond ((pair? l3)
-			(set! l2 l3)
-			(set! l3 (cdr l2)))
-		       (else
-			(set! end #t))))
-		(else		      ; remove the first element of l2
-		 (cond ((pair? l3)
-			(set-car! l2 (car l3))
-			(set! l3 (cdr l3))
-			(set-cdr! l2 l3))
-		       (else
-			(cond ((pair? result)
-			       (list-remove-last! result)))
-			(set! end #t)))))))))
+;;@args pred list
+(define (filter! p? l)
+  (call-with-values (lambda () (partition! p? l))
+		    (lambda (x y) x)))
 
 ;;@args pred list
 (define (partition pred lis)
@@ -300,24 +331,61 @@
                 (values (if (pair? out) (cons elt in) lis) out)
                 (values in (if (pair? in) (cons elt out) lis)))))))))
 
-;;@subheading Searching
-
 ;;@args pred list
-(define find find-if)
-
-;;@args pred list
-(define find-tail member-if)
-
-;;@body
 (define remove
   (let ((comlist:remove remove))
     (lambda (pred l)
       (if (procedure? pred)
 	  (filter (lambda (x) (not (pred x))) l)
 	  (comlist:remove pred l))))) ; 'remove' has incompatible semantics in comlist of SLIB!
-;;@body
+
+;;@args pred list
+(define (partition! p? l)
+  (if (null? l)
+    (values l l)
+    (let ((p-ptr (cons '*unused* l)) (not-ptr (cons '*unused* l)))
+      (let loop ((l l) (p-prev p-ptr) (not-prev not-ptr))
+	(cond ((null? l)	(values (cdr p-ptr) (cdr not-ptr)))
+	      ((p? (car l))	(begin (set-cdr! not-prev (cdr l))
+				       (loop (cdr l) l not-prev)))
+	      (else		(begin (set-cdr! p-prev (cdr l))
+				       (loop (cdr l) p-prev l))))))))
+
+;;@args pred list
 (define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
 
+
+;;@subheading Searching
+
+;;@args pred clist
+(define find find-if)
+;;@args pred clist
+(define find-tail member-if)
+
+;;@args pred list
+(define (span pred lis)
+  (let recur ((lis lis))
+    (if (null-list? lis) (values '() '())
+	(let ((x (car lis)))
+	  (if (pred x)
+	      (call-with-values ; eliminated a receive call
+                (lambda () (recur (cdr lis)))
+                (lambda (prefix suffix)
+                  (values (cons x prefix) suffix)))
+	      (values '() lis))))))
+
+;;@args pred list
+(define (span! p? lst)
+  (let loop ((l lst) (prev (cons '*unused* lst)))
+    (cond ((null? l)	(values lst '()))
+	  ((p? (car l))	(loop (cdr l) l))
+	  (else		(begin (set-cdr! prev '()) (values lst l))))))
+
+;;@args pred list
+(define (break p? l) (span (lambda (x) (not (p? x))) l))
+;;@args pred list
+(define (break! p? l) (span! (lambda (x) (not (p? x))) l))
+
 ;;@args pred clist1 clist2 ...
 (define (any pred lis1 . lists)
   (if (pair? lists)
@@ -339,7 +407,6 @@
 	     (if (null-list? tail)
 		 (pred head)		; Last PRED app is tail call.
 		 (or (pred head) (lp (car tail) (cdr tail))))))))
-
 ;;@args pred clist1 clist2 ...
 (define (list-index pred lis1 . lists)
   (if (pair? lists)
@@ -356,27 +423,8 @@
 	(and (not (null-list? lis))
 	     (if (pred (car lis)) n (lp (cdr lis) (+ n 1)))))))
 
-;;@args pred list
-(define (span pred lis)
-  (let recur ((lis lis))
-    (if (null-list? lis) (values '() '())
-	(let ((x (car lis)))
-	  (if (pred x)
-	      (call-with-values ; eliminated a receive call
-                (lambda () (recur (cdr lis)))
-                (lambda (prefix suffix)
-                  (values (cons x prefix) suffix)))
-	      (values '() lis))))))
-
-;;@args obj list pred
+;;@args obj list =
 ;;@args obj list
-;;
-;;@0 returns the first sublist of @2 whose car is @1, where the sublists
-;;of @2 are the non-empty lists returned by @t{(list-tail @2 @var{k})}
-;;for @var{k} less than the length of @2.  If @1 does not occur in @2,
-;;then @t{#f} (not the empty list) is returned.  The procedure @3 is
-;;used for testing equality.  If @3 is not provided, @samp{equal?} is
-;;used.
 (define member
   (let ((old-member member))
     (lambda (obj list . pred)
@@ -387,16 +435,22 @@
 
 ;;@subheading Deleting
 
+;;@args x list =
+;;@args x list
+(define (delete-duplicates l =?)
+  (let loop ((l l) (r '()))
+    (if (null? l)
+      (reverse! r)
+      (loop (cdr l)
+	    (if (member (car l) r =?) r (cons (car l) r))))))
+;;@args x list =
+;;@args x list
+(define delete-duplicates! delete-duplicates)
+
 ;;@subheading Association lists
 
 ;;@args obj alist pred
 ;;@args obj alist
-;;
-;;@2 (for ``association list'') must be a list of pairs.  These
-;;procedures find the first pair in @2 whose car field is @1, and
-;;returns that pair.  If no pair in @2 has @1 as its car, then @t{#f}
-;;(not the empty list) is returned.  The procedure @3 is used for
-;;testing equality.  If @3 is not provided, @samp{equal?} is used.
 (define assoc
   (let ((old-assoc assoc))
     (lambda (obj alist . pred)
@@ -405,8 +459,140 @@
 	  (let ((pred (car pred)))
 	    (find (lambda (pair) (pred obj (car pair))) alist))))))
 
+;; XXX maybe define the following in alist and require that module here?
+
+;;@args key datum alist
+(define (alist-cons k d l) (cons (cons k d) l))
+
+;;@args alist
+(define (alist-copy l)
+  (map (lambda (x) (cons (car x) (cdr x))) l))
+
+;;@args key alist =
+;;@args key alist
+(define (alist-delete k l . opt)
+  (let ((key=? (if (pair? opt) (car opt) equal?)))
+    (remove (lambda (x) (key=? (car x) k)) l)))
+;;@args key alist =
+;;@args key alist
+(define (alist-delete! k l . opt)
+  (let ((key=? (if (pair? opt) (car opt) equal?)))
+    (remove! (lambda (x) (key=? (car x) k)) l)))
+
 ;;@subheading Set operations
 
+;;@args = list1 @dots{}
+;;Determine if a  transitive subset relation exists between the lists @2
+;;@dots{}, using @1 to determine equality of list members.
+(define (lset<= =? . l)
+  (or (null? l)
+      (letrec ((subset? (lambda (l1 l2)
+			  (or (eq? l1 l2)
+			      (every (lambda (x) (member x l2)) l1)))))
+	(let loop ((l1 (car l)) (l (cdr l)))
+	  (or (null? l)
+	      (let ((l2 (car l)))
+		(and (subset? l1 l2)
+		     (loop l2 (cdr l)))))))))
+
+;;@args = list1 list2 @dots{}
+(define (lset= =? . l)
+  (or (null? l)
+      (let loop ((l1 (car l)) (l (cdr l)))
+	(or (null? l)
+	    (let ((l2 (car l)))
+	      (and (lset<= =? l1 l2)
+		   (lset<= =? l2 l1)
+		   (loop (if (< (length l1) (length l2)) l1 l2)
+			 (cdr l))))))))
+
+;;@args list elt1 @dots{}
+(define (lset-adjoin =? l1 . l2)
+  (let ((adjoin (lambda (x l)
+		  (if (member x l =?) l (cons x l)))))
+    (fold adjoin l1 l2)))
+
+;;@args = list1 @dots{}
+(define (lset-union =? . l)
+  (let ((union (lambda (l1 l2)
+		 (if (or (null? l2) (eq? l1 l2))
+		   l1
+		   (apply lset-adjoin (cons* =? l2 l1))))))
+    (fold union '() l)))
+
+;;@args = list1 list2 @dots{}
+(define (lset-intersection =? l1 . l)
+  (let loop ((l l) (r l1))
+    (cond ((null? l)		r)
+	  ((null? (car l))	'())
+	  (else (loop (cdr l)
+		      (filter (lambda (x) (member x (car l) =?)) r))))))
+
+;;@args = list1 list2 ...
+(define (lset-difference =? l1 . l)
+  (call-with-current-continuation
+   (lambda (return)
+     (let ((diff (lambda (l1 l2)
+		   (cond ((null? l2)	(return '()))
+			 ((null? l1)	l2)
+			 (else		(remove (lambda (x) (member x l1 =?))
+						l2))))))
+       (fold diff l1 l)))))
+
+;; Alternatively definition of lset-difference, for large numbers of sets.
+;(define (lset-difference =? l1 . l)
+;  (set! l (cdr (delete-duplicates! (cons l1 l) eq?)))
+;  (case (length l)
+;    ((0)	l1)
+;    ((1)	(remove (lambda (x) (member x l1 =?)) (car l)))
+;    (else	(apply (lset-difference! (cons* =? (list-copy l1) l))))))
+
+;;@args = list1 ...
+(define (lset-xor =? . l)
+  (let ((xor (lambda (l1 l2) (lset-union =? (lset-difference =? l1 l2)
+					    (lset-difference =? l2 l1)))))
+    (fold xor '() l)))
+
+;;@args = list1 list2 ...
+(define (lset-diff+intersection =? l1 . l)
+  (let ((u (apply lset-union (cons =? l))))
+    (values (lset-difference   =? l1 u)
+	    (lset-intersection =? l1 u))))
+
+;;@noindent
+;;These are linear-update variants.  They are allowed, but not
+;;required, to use the cons cells in their first list parameter to
+;;construct their answer.  @code{lset-union!} is permitted to recycle
+;;cons cells from any of its list arguments.
+
+;;@args = list1 list2 ...
+(define lset-intersection! lset-intersection)
+;;@args = list1 list2 ...
+(define (lset-difference! =? l1 . l)
+  (let loop ((l l) (d l1))
+    (if (or (null? l) (null? d))
+      d
+      (loop (cdr l)
+	    (let ((l1 (car l)))
+	      (if (null? l1) d (remove! (lambda (x) (member x l1 =?)) d)))))))
+
+;;@args = list1 ...
+(define (lset-union! =? . l)
+  (let loop ((l l) (u '()))
+    (if (null? l)
+      u
+      (loop (cdr l)
+	    (cond ((null? (car l))	u)
+		  ((eq? (car l) u)	u)
+		  ((null? u)		(car l))
+		  (else (append-reverse! (lset-difference! =? (car l) u)
+					 u)))))))
+;;@args = list1 ...
+(define lset-xor!		lset-xor)
+
+;;@args = list1 list2 ...
+(define lset-diff+intersection!	lset-diff+intersection)
+
 
 ;;;; helper functions from the reference implementation:
 
-- 
cgit v1.2.3