#| -*-Scheme-*-

$Id: eqv-sets.scm 7252 2007-11-27 02:03:33Z cph $

Copyright (C) 2006,2007 Massachusetts Institute of Technology

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

This program 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
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; EQV set implementation

(declare (usual-integrations))

(define (eqv-set? object)
  (and (list? object)
       (let loop ((items object))
	 (if (pair? items)
	     (if (memv (car items) (cdr items))
		 #f
		 (loop (cdr items)))
	     #t))))

(define-guarantee eqv-set "EQV set")

(define (eqv-subset? s1 s2)
  (for-all? s1
    (lambda (item)
      (memv item s2))))

(define (eqv-set=? s1 s2)
  (and (eqv-subset? s1 s2)
       (eqv-subset? s2 s1)))

(define (eqv-proper-subset? s1 s2)
  (and (eqv-subset? s1 s2)
       (not (eqv-subset? s2 s1))))

(define (eqv-sets-intersect? s1 s2)
  (any (lambda (e) (memv e s2))
       s1))

(define (eqv-sets-disjoint? s1 s2)
  (not (eqv-sets-intersect? s1 s2)))

(define (eqv-diff s1 s2)
  (cond ((not (pair? s1)) '())
	((not (pair? s2)) s1)
	((memv (car s1) s2) (eqv-diff (cdr s1) s2))
	(else (cons (car s1) (eqv-diff (cdr s1) s2)))))

(define (eqv-union . lists)
  (eqv-union* lists))

(define (eqv-union* lists)
  (fold-right %eqv-union-2 '() lists))

(define (%eqv-union-2 s1 s2)
  (if (pair? s1)
      (if (memv (car s1) s2)
	  (%eqv-union-2 (cdr s1) s2)
	  (cons (car s1) (%eqv-union-2 (cdr s1) s2)))
      s2))

(define (eqv-intersection . lists)
  (eqv-intersection* lists))

(define (eqv-intersection* lists)
  (reduce-right %eqv-intersection-2 '() lists))

(define (%eqv-intersection-2 s1 s2)
  (if (pair? s1)
      (if (memv (car s1) s2)
	  (cons (car s1) (%eqv-intersection-2 (cdr s1) s2))
	  (%eqv-intersection-2 (cdr s1) s2))
      '()))