(library (rnrs lists (6))
  (export find for-all exists 
	  filter partition 
	  fold-left fold-right
	  remp remove remv remq
	  memp member memv memq 
	  assp assoc  assv assq
	  cons*)

  (import (rnrs base)
	  (only (rnrs control) case-lambda))

  (define (find f list)
    (assert (procedure? f))
    (let loop ((l list))
      (if (null? l)
	  #f
	  (and
	   (assert (pair? l))
	   (let ((a (car l)))
	     (if (f a) a (loop (cdr l))))))))

  ;; Simple one list variants of forall and exists, respectively.

  (define (andmap f l)
    (or (null? l)
	(and (f (car l))
	     (andmap f (cdr l)))))
  
  (define (ormap f l)
    (and (not (null? l))
	 (or (f (car l))
	     (ormap f (cdr l)))))

  (define-syntax define-quantifier
    (syntax-rules ()
      ((define-quantifier name base combine)
       (define (name f . lists)
	 (assert (procedure? f))
	 (let loop ((lists lists))
	   (if (andmap null? lists)
	       base
	       (let ()
		 (assert (andmap pair? lists))
		 (let ((cdrs (map cdr lists)))
		   (if (andmap null? cdrs)
		       (apply f (map car lists))
		       (combine (apply f (map car lists))
				(loop cdrs)))))))))))

  (define-quantifier for-all #t and)
  (define-quantifier exists #f or)

  (define (filter f list)
    (call-with-values
      (lambda ()
	(partition f list))
      (lambda (take leave) take)))

  (define (partition f list)
    (if (null? list)
	(values '() '())
	(call-with-values
	  (lambda ()
	    (partition f (cdr list)))
	  (lambda (take leave)
	    (if (f (car list))
		(values (cons (car list) take) leave)
		(values take (cons (car list) leave)))))))

  (define (mapadd f l last)
    (let loop ((l l))
      (if (null? l)
        (list last)
        (cons (f (car l)) (loop (cdr l))))))

  (define fold-left
    (case-lambda
     ((f init l)
      (let loop ((init init) (l l))
	(if (null? l) init (loop (f (car l) init) (cdr l)))))
     ((f init l . ls)
      (let loop ((init init) (ls (cons l ls)))
	(cond ((andmap pair? ls)
	       (loop (apply f (mapadd car ls init)) (map cdr ls)))
	      ((ormap pair? ls)
	       (error 'fold-left "received non-equal length input lists"))
	      (else init))))))
 
  (define fold-right
    (case-lambda
     ((f init l)
      (let loop ((init init) (l l))
	(if (null? l)
	    init
	    (f (car l) (loop init (cdr l))))))
     ((f init l . ls)
      (let loop ((ls (cons l ls)))
	(cond ((andmap pair? ls)
	       (apply f (mapadd car ls (loop (map cdr ls)))))
	      ((ormap pair? ls)
	       (error 'foldr "received non-equal length input lists"))
	      (else init))))))

  (define (remp proc list)
    (assert (list? list))
    (let loop ((list list))
      (if (null? list)
	  '()
	  (if (proc (car list))
	      (cons (car list)
		    (loop (cdr list)))
	      (loop (cdr list))))))    

  (define (remove obj list)
    (remp (lambda (x) (equal? x obj)) list))

  (define (remv obj list)
    (remp (lambda (x) (eqv? x obj)) list))

  (define (remq obj list)
    (remp (lambda (x) (eq? x obj)) list))

  (define (memp proc list)
    (let loop ((list list))
      (if (null? list)
          #f
          (and (assert (pair? list))
               (if (proc (car list))
                   list
                   (loop (cdr list)))))))

  (define (member obj list)
    (memp (lambda (x) (equal? obj x)) list))

  (define (memv obj list)
    (memp (lambda (x) (eqv? obj x)) list))
  
  (define (memq obj list)
    (memp (lambda (x) (eq? obj x)) list))

  (define (assp proc alist)
    (let loop ((alist alist))
      (if (null? alist)
	  #f
	  (and (assert (and (pair? alist)
			    (pair? (car alist))))
	       (if (proc (caar alist))
		   (car alist)
		   (loop (cdr alist)))))))
  
  (define (assoc obj alist)
    (assp (lambda (x) (equal? obj x)) alist))

  (define (assv obj alist)
    (assp (lambda (x) (eqv? obj x)) alist))
  
  (define (assq obj alist)
    (assp (lambda (x) (eq? obj x)) alist))

  (define cons*
    (case-lambda
     ((obj) obj)
     ((obj . objs)
      (cons obj (apply cons* objs)))))

) ; end of rnrs lists