guile/module/srfi/srfi-1.scm

;;; srfi-1.scm --- List Library

;; 	Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2014, 2020, 2021 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Some parts from the reference implementation, which is
;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
;;; this code as long as you do not remove this copyright notice or
;;; hold me liable for its use.

;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
;;; Date: 2001-06-06

;;; Commentary:

;; This is an implementation of SRFI-1 (List Library).
;;
;; All procedures defined in SRFI-1, which are not already defined in
;; the Guile core library, are exported.  The procedures in this
;; implementation work, but they have not been tuned for speed or
;; memory usage.
;;
;; This module is fully documented in the Guile Reference Manual.

;;; Code:

(define-module (srfi srfi-1)
  :export (
;;; Constructors
 ;; cons				<= in the core
 ;; list				<= in the core
 xcons
 ;; cons*				<= in the core
 ;; make-list				<= in the core
 list-tabulate
 list-copy
 circular-list
 ;; iota				<= in the core

;;; Predicates
 proper-list?
 circular-list?
 dotted-list?
 ;; pair?				<= in the core
 ;; null?				<= in the core
 null-list?
 not-pair?
 list=

;;; Selectors
 ;; car					<= in the core
 ;; cdr					<= in the core
 ;; caar				<= in the core
 ;; cadr				<= in the core
 ;; cdar				<= in the core
 ;; cddr				<= in the core
 ;; caaar				<= in the core
 ;; caadr				<= in the core
 ;; cadar				<= in the core
 ;; caddr				<= in the core
 ;; cdaar				<= in the core
 ;; cdadr				<= in the core
 ;; cddar				<= in the core
 ;; cdddr				<= in the core
 ;; caaaar				<= in the core
 ;; caaadr				<= in the core
 ;; caadar				<= in the core
 ;; caaddr				<= in the core
 ;; cadaar				<= in the core
 ;; cadadr				<= in the core
 ;; caddar				<= in the core
 ;; cadddr				<= in the core
 ;; cdaaar				<= in the core
 ;; cdaadr				<= in the core
 ;; cdadar				<= in the core
 ;; cdaddr				<= in the core
 ;; cddaar				<= in the core
 ;; cddadr				<= in the core
 ;; cdddar				<= in the core
 ;; cddddr				<= in the core
 ;; list-ref				<= in the core
 first
 second
 third
 fourth
 fifth
 sixth
 seventh
 eighth
 ninth
 tenth
 car+cdr
 take
 drop
 take-right
 drop-right
 take!
 drop-right!
 split-at
 split-at!
 last
 ;; last-pair				<= in the core

;;; Miscelleneous: length, append, concatenate, reverse, zip & count
 ;; length				<= in the core
 length+
 ;; append				<= in the core
 ;; append!				<= in the core
 concatenate
 concatenate!
 ;; reverse				<= in the core
 ;; reverse!				<= in the core
 append-reverse
 append-reverse!
 zip
 unzip1
 unzip2
 unzip3
 unzip4
 unzip5
 count

;;; Fold, unfold & map
 fold
 fold-right
 pair-fold
 pair-fold-right
 reduce
 reduce-right
 unfold
 unfold-right
 ;; map					; Extended.
 ;; for-each				; Extended.
 append-map
 append-map!
 map!
 ;; map-in-order			; Extended.
 pair-for-each
 filter-map

;;; Filtering & partitioning
 ;; filter				<= in the core
 partition
 remove
 ;; filter!				<= in the core
 partition!
 remove!

;;; Searching
 find
 find-tail
 take-while
 take-while!
 drop-while
 span
 span!
 break
 break!
 any
 every
 ;; list-index				; Extended.
 ;; member				; Extended.
 ;; memq				<= in the core
 ;; memv				<= in the core

;;; Deletion
 ;; delete				; Extended.
 ;; delete!				; Extended.
 delete-duplicates
 delete-duplicates!

;;; Association lists
 ;; assoc				; Extended.
 ;; assq				<= in the core
 ;; assv				<= in the core
 alist-cons
 alist-copy
 alist-delete
 alist-delete!

;;; Set operations on lists
 lset<=
 lset=
 lset-adjoin
 lset-union
 lset-intersection
 lset-difference
 lset-xor
 lset-diff+intersection
 lset-union!
 lset-intersection!
 lset-difference!
 lset-xor!
 lset-diff+intersection!

;;; Primitive side-effects
 ;; set-car!				<= in the core
 ;; set-cdr!				<= in the core
 )
  :re-export (cons list cons* make-list pair? null?
	      car cdr caar cadr cdar cddr
	      caaar caadr cadar caddr cdaar cdadr cddar cdddr
	      caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
	      cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
	      list-ref last-pair length append append! reverse reverse!
	      filter filter! memq memv assq assv set-car! set-cdr!
              iota)
  :replace (map for-each map-in-order list-copy list-index member
	    delete delete! assoc)
  )

(cond-expand-provide (current-module) '(srfi-1))


;;; Constructors

(define (xcons d a)
  "Like `cons', but with interchanged arguments.  Useful mostly when passed to
higher-order procedures."
  (cons a d))

(define (wrong-type-arg caller arg)
  (scm-error 'wrong-type-arg (symbol->string caller)
             "Wrong type argument: ~S" (list arg) '()))

(define-syntax-rule (check-arg pred arg caller)
  (if (not (pred arg))
      (wrong-type-arg 'caller arg)))

(define (out-of-range proc arg)
  (scm-error 'out-of-range proc
             "Value out of range: ~A" (list arg) (list arg)))

;; the srfi spec doesn't seem to forbid inexact integers.
(define (non-negative-integer? x) (and (integer? x) (>= x 0)))

(define (list-tabulate n init-proc)
  "Return an N-element list, where each list element is produced by applying the
procedure INIT-PROC to the corresponding list index.  The order in which
INIT-PROC is applied to the indices is not specified."
  (check-arg non-negative-integer? n list-tabulate)
  (let lp ((n n) (acc '()))
    (if (<= n 0)
        acc
        (lp (- n 1) (cons (init-proc (- n 1)) acc)))))

(define (list-copy lst)
  "Return a copy of the given list @var{lst}.
@var{lst} can be a proper or improper list.  And if @var{lst} is not a
pair then it's treated as the final tail of an improper list and simply
returned."
  ;; This routine differs from the core list-copy in allowing improper
  ;; lists.  Maybe the core could allow them too.
  (if (not (pair? lst))
      lst
      (let ((result (cons (car lst) (cdr lst))))
        (let lp ((tail result))
          (let ((next (cdr tail)))
            (if (pair? next)
                (begin
                  (set-cdr! tail (cons (car next) (cdr next)))
                  (lp next))
                result))))))

(define (circular-list elt1 . elts)
  (set! elts (cons elt1 elts))
  (set-cdr! (last-pair elts) elts)
  elts)

;;; Predicates

(define (proper-list? x)
  (list? x))

(define (circular-list? x)
  (if (not-pair? x)
    #f
    (let lp ((hare (cdr x)) (tortoise x))
      (if (not-pair? hare)
	#f
	(let ((hare (cdr hare)))
	  (if (not-pair? hare)
	    #f
	    (if (eq? hare tortoise)
	      #t
	      (lp (cdr hare) (cdr tortoise)))))))))

(define (dotted-list? x)
  (cond
    ((null? x) #f)
    ((not-pair? x) #t)
    (else
     (let lp ((hare (cdr x)) (tortoise x))
       (cond
	 ((null? hare) #f)
	 ((not-pair? hare) #t)
	 (else
	  (let ((hare (cdr hare)))
	    (cond
	      ((null? hare) #f)
	      ((not-pair? hare) #t)
	      ((eq? hare tortoise) #f)
	      (else
	       (lp (cdr hare) (cdr tortoise)))))))))))

(define (null-list? x)
  (cond
    ((proper-list? x)
     (null? x))
    ((circular-list? x)
     #f)
    (else
     (error "not a proper list in null-list?"))))

(define (not-pair? x)
  "Return #t if X is not a pair, #f otherwise.

This is shorthand notation `(not (pair? X))' and is supposed to be used for
end-of-list checking in contexts where dotted lists are allowed."
  (not (pair? x)))

(define (list= elt= . rest)
  (define (lists-equal a b)
    (let lp ((a a) (b b))
      (cond ((null? a)
	     (null? b))
	    ((null? b)
	     #f)
	    (else
	     (and (elt= (car a) (car b))
		  (lp (cdr a) (cdr b)))))))

  (check-arg procedure? elt= list=)
  (or (null? rest)
      (let lp ((lists rest))
	(or (null? (cdr lists))
	    (and (lists-equal (car lists) (cadr lists))
		 (lp (cdr lists)))))))

;;; Selectors

(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define (fifth x) (car (cddddr x)))
(define (sixth x) (cadr (cddddr x)))
(define (seventh x) (caddr (cddddr x)))
(define (eighth x) (cadddr (cddddr x)))
(define (ninth x) (car (cddddr (cddddr x))))
(define (tenth x) (cadr (cddddr (cddddr x))))

(define (car+cdr x)
  "Return two values, the `car' and the `cdr' of PAIR."
  (values (car x) (cdr x)))

(define take list-head)
(define drop list-tail)

;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list,
;;; off by K, then chasing down the list until the lead pointer falls off
;;; the end.  Note that they diverge for circular lists.

(define (take-right lis k)
  (let lp ((lag lis)  (lead (drop lis k)))
    (if (pair? lead)
	(lp (cdr lag) (cdr lead))
	lag)))

(define (drop-right lis k)
  (let recur ((lag lis) (lead (drop lis k)))
    (if (pair? lead)
	(cons (car lag) (recur (cdr lag) (cdr lead)))
	'())))

(define (take! lst i)
  "Linear-update variant of `take'."
  (if (= i 0)
      '()
      (let ((tail (drop lst (- i 1))))
        (set-cdr! tail '())
        lst)))

(define (drop-right! lst i)
  "Linear-update variant of `drop-right'."
  (let ((tail (drop lst i)))
    (if (null? tail)
        '()
        (let loop ((prev lst)
                   (tail (cdr tail)))
          (if (null? tail)
              (if (pair? prev)
                  (begin
                    (set-cdr! prev '())
                    lst)
                  lst)
              (loop (cdr prev)
                    (cdr tail)))))))

(define (split-at lst i)
  "Return two values, a list of the elements before index I in LST, and
a list of those after."
  (if (< i 0)
      (out-of-range 'split-at i)
      (let lp ((l lst) (n i) (acc '()))
        (if (<= n 0)
            (values (reverse! acc) l)
            (lp (cdr l) (- n 1) (cons (car l) acc))))))

(define (split-at! lst i)
  "Linear-update variant of `split-at'."
  (cond ((< i 0)
         (out-of-range 'split-at! i))
        ((= i 0)
         (values '() lst))
        (else
         (let lp ((l lst) (n (- i 1)))
           (if (<= n 0)
               (let ((tmp (cdr l)))
                 (set-cdr! l '())
                 (values lst tmp))
               (lp (cdr l) (- n 1)))))))

(define (last pair)
  "Return the last element of the non-empty, finite list PAIR."
  (car (last-pair pair)))

;;; Miscelleneous: length, append, concatenate, reverse, zip & count

(define (length+ lst)
  "Return the length of @var{lst}, or @code{#f} if @var{lst} is circular."
  (let lp ((tortoise lst)
           (hare lst)
           (i 0))
    (if (not-pair? hare)
        (if (null? hare)
            i
            (scm-error 'wrong-type-arg "length+"
                       "Argument not a proper or circular list: ~s"
                       (list lst) (list lst)))
        (let ((hare (cdr hare)))
          (if (not-pair? hare)
              (if (null? hare)
                  (1+ i)
                  (scm-error 'wrong-type-arg "length+"
                             "Argument not a proper or circular list: ~s"
                             (list lst) (list lst)))
              (let ((tortoise (cdr tortoise))
                    (hare (cdr hare)))
                (if (eq? hare tortoise)
                    #f
                    (lp tortoise hare (+ i 2)))))))))

(define (concatenate lists)
  "Construct a list by appending all lists in @var{lists}.

@code{concatenate} is the same as @code{(apply append @var{lists})}.
It exists because some Scheme implementations have a limit on the number
of arguments a function takes, which the @code{apply} might exceed.  In
Guile there is no such limit."
  (apply append lists))

(define (concatenate! lists)
  "Construct a list by appending all lists in @var{lists}.  Those
lists may be modified to produce the result.

@code{concatenate!} is the same as @code{(apply append!  @var{lists})}.
It exists because some Scheme implementations have a limit on the number
of arguments a function takes, which the @code{apply} might exceed.  In
Guile there is no such limit."
  (apply append! lists))

(define (append-reverse rev-head tail)
  "Reverse @var{rev-head}, append @var{tail} to it, and return the
result.  This is equivalent to @code{(append (reverse @var{rev-head})
@var{tail})}, but its implementation is more efficient.

@example
(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)
@end example"
  (let lp ((rh rev-head)
           (result tail))
    (if (pair? rh)
        (lp (cdr rh) (cons (car rh) result))
        (begin
          (unless (null? rh)
            (wrong-type-arg 'append-reverse rev-head))
          result))))

(define (append-reverse! rev-head tail)
  "Reverse @var{rev-head}, append @var{tail} to it, and return the
result.  This is equivalent to @code{(append! (reverse!  @var{rev-head})
@var{tail})}, but its implementation is more efficient.

@example
(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)
@end example

@var{rev-head} may be modified in order to produce the result."
  (let lp ((rh rev-head)
           (result tail))
    (if (pair? rh)
        (let ((next rh)
              (rh (cdr rh)))
          (set-cdr! next result)
          (lp rh next))
        (begin
          (unless (null? rh)
            (wrong-type-arg 'append-reverse! rev-head))
          result))))

(define (zip clist1 . rest)
  (let lp ((l (cons clist1 rest)) (acc '()))
    (if (any null? l)
      (reverse! acc)
      (lp (map cdr l) (cons (map car l) acc)))))


(define (unzip1 l)
  (map first l))
(define (unzip2 l)
  (values (map first l) (map second l)))
(define (unzip3 l)
  (values (map first l) (map second l) (map third l)))
(define (unzip4 l)
  (values (map first l) (map second l) (map third l) (map fourth l)))
(define (unzip5 l)
  (values (map first l) (map second l) (map third l) (map fourth l)
	  (map fifth l)))

(define count
  (case-lambda
    ((pred lst)
     (let lp ((lst lst) (c 0))
       (if (null? lst)
           c
           (lp (cdr lst) (if (pred (car lst)) (1+ c) c)))))
    ((pred l1 l2)
     (let lp ((l1 l1) (l2 l2) (c 0))
       (if (or (null? l1) (null? l2))
           c
           (lp (cdr l1) (cdr l2)
               (if (pred (car l1) (car l2)) (1+ c) c)))))
    ((pred lst . lists)
     (let lp ((lst lst) (lists lists) (c 0))
       (if (or (null? lst) (any null? lists))
           c
           (lp (cdr lst)
               (map cdr lists)
               (if (apply pred (car lst) (map car lists)) (1+ c) c)))))))

;;; Fold, unfold & map

(define fold
  (case-lambda
    "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
that result.  See the manual for details."
    ((kons knil list1)
     (check-arg procedure? kons fold)
     (check-arg list? list1 fold)
     (let fold1 ((knil knil) (list1 list1))
       (if (pair? list1)
           (fold1 (kons (car list1) knil) (cdr list1))
           knil)))
    ((kons knil list1 list2)
     (check-arg procedure? kons fold)
     (let* ((len1 (length+ list1))
            (len2 (length+ list2))
            (len (if (and len1 len2)
                     (min len1 len2)
                     (or len1 len2))))
       (unless len
         (scm-error 'wrong-type-arg "fold"
                    "Args do not contain a proper (finite) list: ~S"
                    (list (list list1 list2)) #f))
       (let fold2 ((knil knil) (list1 list1) (list2 list2) (len len))
         (if (zero? len)
             knil
             (fold2 (kons (car list1) (car list2) knil)
                    (cdr list1) (cdr list2) (1- len))))))
    ((kons knil list1 . rest)
     (check-arg procedure? kons fold)
     (let foldn ((knil knil) (lists (cons list1 rest)))
       (if (any null? lists)
           knil
           (let ((cars (map car lists))
                 (cdrs (map cdr lists)))
             (foldn (apply kons (append! cars (list knil))) cdrs)))))))

(define (fold-right kons knil clist1 . rest)
  (check-arg procedure? kons fold-right)
  (if (null? rest)
      (let loop ((lst    (reverse clist1))
                 (result knil))
        (if (null? lst)
            result
            (loop (cdr lst)
                  (kons (car lst) result))))
      (let loop ((lists  (map reverse (cons clist1 rest)))
                 (result knil))
        (if (any1 null? lists)
            result
            (loop (map cdr lists)
                  (apply kons (append! (map car lists) (list result))))))))

(define (pair-fold kons knil clist1 . rest)
  (check-arg procedure? kons pair-fold)
  (if (null? rest)
      (let f ((knil knil) (list1 clist1))
	(if (null? list1)
	    knil
	    (let ((tail (cdr list1)))
	    (f (kons list1 knil) tail))))
      (let f ((knil knil) (lists (cons clist1 rest)))
	(if (any null? lists)
	    knil
	    (let ((tails (map cdr lists)))
	      (f (apply kons (append! lists (list knil))) tails))))))


(define (pair-fold-right kons knil clist1 . rest)
  (check-arg procedure? kons pair-fold-right)
  (if (null? rest)
    (let f ((list1 clist1))
      (if (null? list1)
	knil
	(kons list1 (f (cdr list1)))))
    (let f ((lists (cons clist1 rest)))
      (if (any null? lists)
	knil
	(apply kons (append! lists (list (f (map cdr lists)))))))))

(define* (unfold p f g seed #:optional (tail-gen (lambda (x) '())))
  (define (reverse+tail lst seed)
    (let loop ((lst    lst)
               (result (tail-gen seed)))
      (if (null? lst)
          result
          (loop (cdr lst)
                (cons (car lst) result)))))

  (check-arg procedure? p unfold)
  (check-arg procedure? f unfold)
  (check-arg procedure? g unfold)
  (check-arg procedure? tail-gen unfold)
  (let loop ((seed   seed)
             (result '()))
    (if (p seed)
        (reverse+tail result seed)
        (loop (g seed)
              (cons (f seed) result)))))

(define* (unfold-right p f g seed #:optional (tail '()))
  (check-arg procedure? p unfold-right)
  (check-arg procedure? f unfold-right)
  (check-arg procedure? g unfold-right)
  (let uf ((seed seed) (lis tail))
    (if (p seed)
        lis
        (uf (g seed) (cons (f seed) lis)))))

(define (reduce f ridentity lst)
  "`reduce' is a variant of `fold', where the first call to F is on two
elements from LST, rather than one element and a given initial value.
If LST is empty, RIDENTITY is returned.  If LST has just one element
then that's the return value."
  (check-arg procedure? f reduce)
  (if (null? lst)
      ridentity
      (fold f (car lst) (cdr lst))))

(define (reduce-right f ridentity lst)
  "`reduce-right' is a variant of `fold-right', where the first call to
F is on two elements from LST, rather than one element and a given
initial value.  If LST is empty, RIDENTITY is returned.  If LST
has just one element then that's the return value."
  (check-arg procedure? f reduce)
  (if (null? lst)
      ridentity
      (fold-right f (last lst) (drop-right lst 1))))

(define map
  (case-lambda
    ((f l)
     (check-arg procedure? f map)
     (check-arg list? l map)
     (let map1 ((l l))
       (if (pair? l)
           (cons (f (car l)) (map1 (cdr l)))
           '())))

    ((f l1 l2)
     (check-arg procedure? f map)
     (let* ((len1 (length+ l1))
            (len2 (length+ l2))
            (len (if (and len1 len2)
                     (min len1 len2)
                     (or len1 len2))))
       (unless len
         (scm-error 'wrong-type-arg "map"
                    "Args do not contain a proper (finite) list: ~S"
                    (list (list l1 l2)) #f))
       (let map2 ((l1 l1) (l2 l2) (len len))
         (if (zero? len)
             '()
             (cons (f (car l1) (car l2))
                   (map2 (cdr l1) (cdr l2) (1- len)))))))

    ((f l1 . rest)
     (check-arg procedure? f map)
     (let ((len (fold (lambda (ls len)
                        (let ((ls-len (length+ ls)))
                          (if len
                              (if ls-len (min ls-len len) len)
                              ls-len)))
                      (length+ l1)
                      rest)))
       (if (not len)
           (scm-error 'wrong-type-arg "map"
                      "Args do not contain a proper (finite) list: ~S"
                      (list (cons l1 rest)) #f))
       (let mapn ((l1 l1) (rest rest) (len len))
         (if (zero? len)
             '()
             (cons (apply f (car l1) (map car rest))
                   (mapn (cdr l1) (map cdr rest) (1- len)))))))))

(define map-in-order map)

(define for-each
  (case-lambda
    ((f l)
     (check-arg procedure? f for-each)
     (check-arg list? l for-each)
     (let for-each1 ((l l))
       (unless (null? l)
         (f (car l))
         (for-each1 (cdr l)))))

    ((f l1 l2)
     (check-arg procedure? f for-each)
     (let* ((len1 (length+ l1))
            (len2 (length+ l2))
            (len (if (and len1 len2)
                     (min len1 len2)
                     (or len1 len2))))
       (unless len
         (scm-error 'wrong-type-arg "for-each"
                    "Args do not contain a proper (finite) list: ~S"
                    (list (list l1 l2)) #f))
       (let for-each2 ((l1 l1) (l2 l2) (len len))
         (unless (zero? len)
           (f (car l1) (car l2))
           (for-each2 (cdr l1) (cdr l2) (1- len))))))

    ((f l1 . rest)
     (check-arg procedure? f for-each)
     (let ((len (fold (lambda (ls len)
                        (let ((ls-len (length+ ls)))
                          (if len
                              (if ls-len (min ls-len len) len)
                              ls-len)))
                      (length+ l1)
                      rest)))
       (if (not len)
           (scm-error 'wrong-type-arg "for-each"
                      "Args do not contain a proper (finite) list: ~S"
                      (list (cons l1 rest)) #f))
       (let for-eachn ((l1 l1) (rest rest) (len len))
         (if (> len 0)
             (begin
               (apply f (car l1) (map car rest))
               (for-eachn (cdr l1) (map cdr rest) (1- len)))))))))

(define (append-map f clist1 . rest)
  (concatenate (apply map f clist1 rest)))

(define (append-map! f clist1 . rest)
  (concatenate! (apply map f clist1 rest)))

;; OPTIMIZE-ME: Re-use cons cells of list1
(define map! map)

(define (filter-map proc list1 . rest)
  "Apply PROC to the elements of LIST1... and return a list of the
results as per SRFI-1 `map', except that any #f results are omitted from
the list returned."
  (check-arg procedure? proc filter-map)
  (if (null? rest)
      (let lp ((l list1)
               (rl '()))
        (if (null? l)
            (reverse! rl)
            (let ((res (proc (car l))))
              (if res
                  (lp (cdr l) (cons res rl))
                  (lp (cdr l) rl)))))
      (let lp ((l (cons list1 rest))
               (rl '()))
        (if (any1 null? l)
            (reverse! rl)
            (let ((res (apply proc (map car l))))
              (if res
                  (lp (map cdr l) (cons res rl))
                  (lp (map cdr l) rl)))))))

(define (pair-for-each f clist1 . rest)
  (check-arg procedure? f pair-for-each)
  (if (null? rest)
    (let lp ((l clist1))
      (if (null? l)
	(if #f #f)
	(begin
	  (f l)
	  (lp (cdr l)))))
    (let lp ((l (cons clist1 rest)))
      (if (any1 null? l)
	(if #f #f)
	(begin
	  (apply f l)
	  (lp (map cdr l)))))))


;;; Filtering & partitioning

(define (partition pred lst)
  "Partition the elements of @var{list} with predicate @var{pred}.
Return two values: the list of elements satisfying @var{pred} and the
list of elements @emph{not} satisfying @var{pred}.  The order of the
output lists follows the order of @var{list}.  @var{list} is not
mutated.  One of the output lists may share memory with @var{list}."
  (let ((matches (list #f))
        (mismatches (list #f)))
    (let lp ((lst lst)
             (matches-end matches)
             (mismatches-end mismatches))
      (if (null? lst)
          (values (cdr matches) (cdr mismatches))
          (let ((x (car lst)))
            (if (pred x)
                (begin
                  (set-cdr! matches-end (list x))
                  (lp (cdr lst) (cdr matches-end) mismatches-end))
                (begin
                  (set-cdr! mismatches-end (list x))
                  (lp (cdr lst) matches-end (cdr mismatches-end)))))))))

(define (list-prefix-and-tail lst stop)
  (when (eq? lst stop)
    (error "Prefix cannot be empty"))
  (let ((rl (list (car lst))))
    (let lp ((lst (cdr lst)) (tail rl))
      (if (eq? lst stop)
          (values rl tail)
          (let ((new-tail (list (car lst))))
            (set-cdr! tail new-tail)
            (lp (cdr lst) new-tail))))))

(define (remove pred lst)
  "Return a list containing all elements from @var{list} which do not
satisfy the predicate @var{pred}.  The elements in the result list have
the same order as in @var{list}.  The order in which @var{pred} is
applied to the list elements is not specified, and the result may share
a common tail with @{list}."
  ;; Traverse the lst, keeping the tail of it, in which we have yet to
  ;; find a duplicate, in last-kept.  Share that tail with the result
  ;; (possibly the entire original lst).  Build the result by
  ;; destructively appending unique values to its tail, and henever we
  ;; find a duplicate, copy the pending last-kept prefix into the result
  ;; and move last-kept forward to the current position in lst.
  (if (null? lst)
      lst
      (let ((result (list #f)))
        (let lp ((lst lst)
                 (last-kept lst)
                 (tail result))
          (if (null? lst)
              (begin
                (set-cdr! tail last-kept)
                (cdr result))
              (let ((item (car lst)))
                (if (pred item)
                    (if (eq? last-kept lst)
                        (lp (cdr lst) (cdr lst) tail)
                        (call-with-values
                            (lambda () (list-prefix-and-tail last-kept lst))
                          (lambda (prefix new-tail)
                            (set-cdr! tail prefix)
                            (lp (cdr lst) (cdr lst) new-tail))))
                    (lp (cdr lst) last-kept tail))))))))

(define (partition! pred lst)
  "Partition the elements of @var{list} with predicate @var{pred}.
Return two values: the list of elements satisfying @var{pred} and the
list of elements @emph{not} satisfying @var{pred}.  The order of the
output lists follows the order of @var{list}.  @var{list} is not
mutated.  @var{lst} may be modified to construct the return lists."
  (let ((matches (cons #f lst))
        (mismatches (list #f)))
    (let lp ((matches-next matches)
             (mismatches-end mismatches))
      (let ((next (cdr matches-next)))
        (if (null? next)
            (values (cdr matches) (cdr mismatches))
            (let ((x (car next)))
              (if (pred x)
                  (lp (cdr matches-next) mismatches-end)
                  (begin
                    (set-cdr! matches-next (cdr next))
                    (set-cdr! mismatches-end (list x))
                    (lp matches-next (cdr mismatches-end))))))))))

(define (remove! pred lst)
  "Return a list containing all elements from @var{list} which do not
satisfy the predicate @var{pred}.  The elements in the result list have
the same order as in @var{list}.  The order in which @var{pred} is
applied to the list elements is not specified. @var{list} may be
modified to build the return list."
  (cond
   ((null? lst) lst)
   ((pred (car lst)) (remove! pred (cdr lst)))
   (else
    (let lp ((prev lst))
      (let ((next (cdr prev)))
        (if (null? next)
            lst
            (let ((x (car next)))
              (if (pred x)
                  (begin
                    (set-cdr! prev (cdr next))
                    (lp prev))
                  (lp next)))))))))


;;; Searching

(define (find pred lst)
  "Return the first element of @var{lst} that satisfies the predicate
@var{pred}, or return @code{#f} if no such element is found."
  (check-arg procedure? pred find)
  (let loop ((lst lst))
    (and (not (null? lst))
         (let ((head (car lst)))
           (if (pred head)
               head
               (loop (cdr lst)))))))

(define (find-tail pred lst)
  "Return the first pair of @var{lst} whose @sc{car} satisfies the
predicate @var{pred}, or return @code{#f} if no such element is found."
  (check-arg procedure? pred find-tail)
  (let loop ((lst lst))
    (and (not (null? lst))
         (let ((head (car lst)))
           (if (pred head)
               lst
               (loop (cdr lst)))))))

(define (take-while pred ls)
  "Return a new list which is the longest initial prefix of LS whose
elements all satisfy the predicate PRED."
  (check-arg procedure? pred take-while)
  (cond ((null? ls) '())
        ((not (pred (car ls))) '())
        (else
         (let ((result (list (car ls))))
           (let lp ((ls (cdr ls)) (p result))
             (cond ((null? ls) result)
                   ((not (pred (car ls))) result)
                   (else
                    (set-cdr! p (list (car ls)))
                    (lp (cdr ls) (cdr p)))))))))

(define (take-while! pred lst)
  "Linear-update variant of `take-while'."
  (check-arg procedure? pred take-while!)
  (let loop ((prev #f)
             (rest lst))
    (cond ((null? rest)
           lst)
          ((pred (car rest))
           (loop rest (cdr rest)))
          (else
           (if (pair? prev)
               (begin
                 (set-cdr! prev '())
                 lst)
               '())))))

(define (drop-while pred lst)
  "Drop the longest initial prefix of LST whose elements all satisfy the
predicate PRED."
  (check-arg procedure? pred drop-while)
  (let loop ((lst lst))
    (cond ((null? lst)
           '())
          ((pred (car lst))
           (loop (cdr lst)))
          (else lst))))

(define (span pred lst)
  "Return two values, the longest initial prefix of LST whose elements
all satisfy the predicate PRED, and the remainder of LST."
  (check-arg procedure? pred span)
  (let lp ((lst lst) (rl '()))
    (if (and (not (null? lst))
             (pred (car lst)))
        (lp (cdr lst) (cons (car lst) rl))
        (values (reverse! rl) lst))))

(define (span! pred list)
  "Linear-update variant of `span'."
  (check-arg procedure? pred span!)
  (let loop ((prev #f)
             (rest list))
    (cond ((null? rest)
           (values list '()))
          ((pred (car rest))
           (loop rest (cdr rest)))
          (else
           (if (pair? prev)
               (begin
                 (set-cdr! prev '())
                 (values list rest))
               (values '() list))))))

(define (break pred clist)
  "Return two values, the longest initial prefix of LST whose elements
all fail the predicate PRED, and the remainder of LST."
  (check-arg procedure? pred break)
  (let lp ((clist clist) (rl '()))
    (if (or (null? clist)
	    (pred (car clist)))
	(values (reverse! rl) clist)
	(lp (cdr clist) (cons (car clist) rl)))))

(define (break! pred list)
  "Linear-update variant of `break'."
  (check-arg procedure? pred break!)
  (let loop ((l    list)
             (prev #f))
    (cond ((null? l)
           (values list '()))
          ((pred (car l))
           (if (pair? prev)
               (begin
                 (set-cdr! prev '())
                 (values list l))
               (values '() list)))
          (else
           (loop (cdr l) l)))))

(define (any pred ls . lists)
  (check-arg procedure? pred any)
  (if (null? lists)
      (any1 pred ls)
      (let lp ((lists (cons ls lists)))
	(cond ((any1 null? lists)
	       #f)
	      ((any1 null? (map cdr lists))
	       (apply pred (map car lists)))
	      (else
	       (or (apply pred (map car lists)) (lp (map cdr lists))))))))

(define (any1 pred ls)
  (let lp ((ls ls))
    (cond ((null? ls)
	   #f)
	  ((null? (cdr ls))
	   (pred (car ls)))
	  (else
	   (or (pred (car ls)) (lp (cdr ls)))))))

(define (every pred ls . lists)
  (check-arg procedure? pred every)
  (if (null? lists)
      (every1 pred ls)
      (let lp ((lists (cons ls lists)))
	(cond ((any1 null? lists)
	       #t)
	      ((any1 null? (map cdr lists))
	       (apply pred (map car lists)))
	      (else
	       (and (apply pred (map car lists)) (lp (map cdr lists))))))))

(define (every1 pred ls)
  (let lp ((ls ls))
    (cond ((null? ls)
	   #t)
	  ((null? (cdr ls))
	   (pred (car ls)))
	  (else
	   (and (pred (car ls)) (lp (cdr ls)))))))

(define (list-index pred clist1 . rest)
  "Return the index of the first set of elements, one from each of
CLIST1 ... CLISTN, that satisfies PRED."
  (check-arg procedure? pred list-index)
  (if (null? rest)
    (let lp ((l clist1) (i 0))
      (if (null? l)
	#f
	(if (pred (car l))
	  i
	  (lp (cdr l) (+ i 1)))))
    (let lp ((lists (cons clist1 rest)) (i 0))
      (cond ((any1 null? lists)
	     #f)
	    ((apply pred (map car lists)) i)
	    (else
	     (lp (map cdr lists) (+ i 1)))))))

;;; Deletion

(define* (delete x lst #:optional (pred equal?))
  "Return a list containing the elements of @var{lst} but with
those equal to @var{x} deleted.  The returned elements will be in the
same order as they were in @var{lst}.

Equality is determined by @var{pred}, or @code{equal?} if not given.  An
equality call is made just once for each element, but the order in which
the calls are made on the elements is unspecified.

The equality calls are always @code{(pred x elem)}, ie.@: the given
@var{x} is first.  This means for instance elements greater than 5 can
be deleted with @code{(delete 5 lst <)}.

@var{lst} is not modified, but the returned list might share a common
tail with @var{lst}."
  (remove (lambda (elem) (pred x elem)) lst))

(define (member-before x lst stop =)
  (cond
   ((null? lst) #f)
   ((eq? lst stop) #f)
   ((= (car lst) x) #t)
   (else (member-before x (cdr lst) stop =))))

(define* (delete! x lst #:optional (pred equal?))
  "Return a list containing the elements of @var{lst} but with
those equal to @var{x} deleted.  The returned elements will be in the
same order as they were in @var{lst}.

Equality is determined by @var{pred}, or @code{equal?} if not given.  An
equality call is made just once for each element, but the order in which
the calls are made on the elements is unspecified.

The equality calls are always @code{(pred x elem)}, ie.@: the given
@var{x} is first.  This means for instance elements greater than 5 can
be deleted with @code{(delete 5 lst <)}.

@var{lst} may be modified to construct the returned list."
  (remove! (lambda (elem) (pred x elem)) lst))

(define* (delete-duplicates lst #:optional (= equal?))
  "Return a list containing the elements of @var{lst} but without
duplicates.

When elements are equal, only the first in @var{lst} is retained.  Equal
elements can be anywhere in @var{lst}, they don't have to be adjacent.
The returned list will have the retained elements in the same order as
they were in @var{lst}.

Equality is determined by @var{pred}, or @code{equal?} if not given.
Calls @code{(pred x y)} are made with element @var{x} being before
@var{y} in @var{lst}.  A call is made at most once for each combination,
but the sequence of the calls across the elements is unspecified.

@var{lst} is not modified, but the return might share a common tail with
@var{lst}.

In the worst case, this is an @math{O(N^2)} algorithm because it must
check each element against all those preceding it.  For long lists it is
more efficient to sort and then compare only adjacent elements."
  ;; Same implementation as remove (see comments there), except that the
  ;; predicate checks for duplicates in both last-seen and the pending
  ;; result.
  (if (null? lst)
      lst
      (let ((result (list #f)))
        (let lp ((lst lst)
                 (last-kept lst)
                 (tail result))
          (if (null? lst)
              (begin
                (set-cdr! tail last-kept)
                (cdr result))
              (let ((item (car lst)))
                (if (or (member item (cdr result) (lambda (x y) (= y x)))
                        (member-before item last-kept lst =))
                    (if (eq? last-kept lst)
                        (lp (cdr lst) (cdr lst) tail)
                        (call-with-values
                            (lambda () (list-prefix-and-tail last-kept lst))
                          (lambda (prefix new-tail)
                            (set-cdr! tail prefix)
                            (lp (cdr lst) (cdr lst) new-tail))))
                    ;; unique, keep
                    (lp (cdr lst) last-kept tail))))))))

(define* (delete-duplicates! lst #:optional (= equal?))
  "Return a list containing the elements of @var{lst} but without
duplicates.

When elements are equal, only the first in @var{lst} is retained.  Equal
elements can be anywhere in @var{lst}, they don't have to be adjacent.
The returned list will have the retained elements in the same order as
they were in @var{lst}.

Equality is determined by @var{=}, or @code{equal?} if not given.
Calls @code{(= x y)} are made with element @var{x} being before
@var{y} in @var{lst}.  A call is made at most once for each combination,
but the sequence of the calls across the elements is unspecified.

@var{lst} is not modified, but the return might share a common tail with
@var{lst}.

In the worst case, this is an @math{O(N^2)} algorithm because it must
check each element against all those preceding it.  For long lists it is
more efficient to sort and then compare only adjacent elements."
  (if (null? lst)
      lst
      (let lp ((tail lst))
        (let ((next (cdr tail)))
          (if (null? next)
              lst
              (if (member-before (car next) lst next =)
                  (begin
                    (set-cdr! tail (cdr next))
                    (lp tail))
                  (lp next)))))))

;;; Association lists

(define alist-cons acons)

(define (alist-copy alist)
  "Return a copy of ALIST, copying both the pairs comprising the list
and those making the associations."
  (let lp ((a  alist)
           (rl '()))
    (if (null? a)
        (reverse! rl)
        (lp (cdr a) (alist-cons (caar a) (cdar a) rl)))))

(define* (alist-delete key alist #:optional (k= equal?))
  (check-arg procedure? k= alist-delete)
  (let lp ((a alist) (rl '()))
    (if (null? a)
	(reverse! rl)
	(if (k= key (caar a))
            (lp (cdr a) rl)
            (lp (cdr a) (cons (car a) rl))))))

(define* (alist-delete! key alist #:optional (k= equal?))
  (alist-delete key alist k=))	; XXX:optimize

;;; Delete / assoc / member

(define* (assoc key alist #:optional (= equal?))
  "Behaves like @code{assq} but uses third argument @var{pred} for key
comparison.  If @var{pred} is not supplied, @code{equal?} is
used.  (Extended from R5RS.)"
  (cond
   ((eq? = eq?) (assq key alist))
   ((eq? = eqv?) (assv key alist))
   (else
    (check-arg procedure? = assoc)
    (let loop ((alist alist))
      (and (pair? alist)
           (let ((item (car alist)))
             (check-arg pair? item assoc)
             (if (= key (car item))
                 item
                 (loop (cdr alist)))))))))

(define* (member x ls #:optional (= equal?))
  (cond
   ;; This might be performance-sensitive, so punt on the check here,
   ;; relying on memq/memv to check that = is a procedure.
   ((eq? = eq?) (memq x ls))
   ((eq? = eqv?) (memv x ls))
   (else
    (check-arg procedure? = member)
    (find-tail (lambda (y) (= x y)) ls))))

;;; Set operations on lists

(define (lset<= = . rest)
  (check-arg procedure? = lset<=)
  (if (null? rest)
      #t
      (let lp ((f (car rest)) (r (cdr rest)))
        (or (null? r)
            (and (every (lambda (el) (member el (car r) =)) f)
                 (lp (car r) (cdr r)))))))

(define (lset= = . rest)
  (check-arg procedure? = lset<=)
  (if (null? rest)
    #t
    (let lp ((f (car rest)) (r (cdr rest)))
      (or (null? r)
	  (and (every (lambda (el) (member el (car r) =)) f)
	       (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r))
	       (lp (car r) (cdr r)))))))

;; It's not quite clear if duplicates among the `rest' elements are meant to
;; be cast out.  The spec says `=' is called as (= lstelem restelem),
;; suggesting perhaps not, but the reference implementation shows the "list"
;; at each stage as including those elements already added.  The latter
;; corresponds to what's described for lset-union, so that's what's done.
;;
(define (lset-adjoin = list . rest)
  "Add to LIST any of the elements of REST not already in the list.
These elements are `cons'ed onto the start of LIST (so the return shares
a common tail with LIST), but the order they're added is unspecified.

The given `=' procedure is used for comparing elements, called
as `(@var{=} listelem elem)', i.e., the second argument is one of the
given REST parameters."
  ;; If `=' is `eq?' or `eqv?', users won't be able to tell which arg is
  ;; first, so we can pass the raw procedure through to `member',
  ;; allowing `memq' / `memv' to be selected.
  (define pred
    (if (or (eq? = eq?) (eq? = eqv?))
        =
        (begin
          (check-arg procedure? = lset-adjoin)
          (lambda (x y) (= y x)))))

  (let lp ((ans list) (rest rest))
    (if (null? rest)
        ans
        (lp (if (member (car rest) ans pred)
                ans
                (cons (car rest) ans))
            (cdr rest)))))

(define (lset-union = . rest)
  ;; Likewise, allow memq / memv to be used if possible.
  (define pred
    (if (or (eq? = eq?) (eq? = eqv?))
        =
        (begin
          (check-arg procedure? = lset-union)
          (lambda (x y) (= y x)))))

  (fold (lambda (lis ans)		; Compute ANS + LIS.
          (cond ((null? lis) ans)	; Don't copy any lists
                ((null? ans) lis) 	; if we don't have to.
                ((eq? lis ans) ans)
                (else
                 (fold (lambda (elt ans)
                         (if (member elt ans pred)
                             ans
                             (cons elt ans)))
                       ans lis))))
        '()
        rest))

(define (lset-intersection = list1 . rest)
  (check-arg procedure? = lset-intersection)
  (let lp ((l list1) (acc '()))
    (if (null? l)
      (reverse! acc)
      (if (every (lambda (ll) (member (car l) ll =)) rest)
	(lp (cdr l) (cons (car l) acc))
	(lp (cdr l) acc)))))

(define (lset-difference = lset . removals)
  "Return @var{lst} with any elements in the lists in @var{removals}
removed (ie.@: subtracted).  For only one @var{lst} argument, just that
list is returned.

The given @var{equal} procedure is used for comparing elements, called
as @code{(@var{equal} elem1 elemN)}.  The first argument is from
@var{lst} and the second from one of the subsequent lists.  But exactly
which calls are made and in what order is unspecified.

@example
(lset-difference eqv? (list 'x 'y))           @result{} (x y)
(lset-difference eqv? (list 1 2 3) '(3 1))    @result{} (2)
(lset-difference eqv? (list 1 2 3) '(3) '(2)) @result{} (1)
@end example

The result may share a common tail with @var{lset}."
  ;; REVIEW: if we think they're actually going to be sets, i.e. no
  ;; duplicates, then might it be better to just reduce via per-set
  ;; delete -- more transient allocation but maybe a lot less work?
  (check-arg procedure? = lset-difference)
  (cond
   ((null? lset) lset)
   ((null? removals) lset)
   (else (remove (lambda (x) (any (lambda (s) (member x s =)) removals))
                 lset))))

(define (lset-xor = . rest)
  (check-arg procedure? = lset-xor)
  (fold (lambda (lst res)
	  (let lp ((l lst) (acc '()))
	    (if (null? l)
	      (let lp0 ((r res) (acc acc))
		(if (null? r)
		  (reverse! acc)
		  (if (member (car r) lst =)
		    (lp0 (cdr r) acc)
		    (lp0 (cdr r) (cons (car r) acc)))))
	      (if (member (car l) res =)
		(lp (cdr l) acc)
		(lp (cdr l) (cons (car l) acc))))))
	'()
	rest))

(define (lset-diff+intersection = list1 . rest)
  (check-arg procedure? = lset-diff+intersection)
  (let lp ((l list1) (accd '()) (acci '()))
    (if (null? l)
      (values (reverse! accd) (reverse! acci))
      (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
	(if appears
	  (lp (cdr l) accd (cons (car l) acci))
	  (lp (cdr l) (cons (car l) accd) acci))))))


(define (lset-union! = . rest)
  (check-arg procedure? = lset-union!)
  (apply lset-union = rest))		; XXX:optimize

(define (lset-intersection! = list1 . rest)
  (check-arg procedure? = lset-intersection!)
  (apply lset-intersection = list1 rest)) ; XXX:optimize

(define (lset-difference! = lset . removals)
  "Return @var{lst} with any elements in the lists in @var{removals}
removed (ie.@: subtracted).  For only one @var{lst} argument, just that
list is returned.

The given @var{equal} procedure is used for comparing elements, called
as @code{(@var{equal} elem1 elemN)}.  The first argument is from
@var{lst} and the second from one of the subsequent lists.  But exactly
which calls are made and in what order is unspecified.

@example
(lset-difference! eqv? (list 'x 'y))           @result{} (x y)
(lset-difference! eqv? (list 1 2 3) '(3 1))    @result{} (2)
(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)
@end example

@code{lset-difference!} may modify @var{lst} to form its result."
  (check-arg procedure? = lset-intersection!)
  (cond
   ((null? lset) lset)
   ((null? removals) lset)
   (else (remove! (lambda (x) (any (lambda (s) (member x s =)) removals))
                  lset))))

(define (lset-xor! = . rest)
  (check-arg procedure? = lset-xor!)
  (apply lset-xor = rest))		; XXX:optimize

(define (lset-diff+intersection! = list1 . rest)
  (check-arg procedure? = lset-diff+intersection!)
  (apply lset-diff+intersection = list1 rest)) ; XXX:optimize

;;; srfi-1.scm ends here