;; data/sets.scm - set implementation
;;
;; Copyright (C) 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
;;
;; This 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, or (at your option)
;; any later version.
;; 
;; This software 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 package; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.  

;; Quantifiers  ======================================================

(define (both pred)
  (lambda (arg1 arg2)
    (and (pred arg1) (pred arg2))))

(define (neither pred)
  (lambda (arg1 arg2)
    (not (or (pred arg1) (pred arg2)))))

(define (at-least-one pred)
  (lambda (arg1 arg2)
    (or (pred arg1) (pred arg2))))

;; Set operations  ===================================================

(define (make-set . args)
  (letrec
      ((list-make-set
	(lambda (args-list)
	  (if (null? args-list)
	      the-empty-set
	      (adjoin (car args-list) (list-make-set (cdr args-list)))))))
    (list-make-set args)))

(define (none pred)
  (letrec
      ((test
	(lambda (s)
	  (or (empty-set? s)
	      (let ((elem (pick s)))
		(and (not (pred elem))
		     (test ((residue elem) s))))))))
    test))

(define (there-exists pred)
  (compose not (none pred)))

(define (for-all pred)
  (none (compose not pred)))

(define (set-equal obj1)
  (lambda (obj2)
    (or (and ((neither set?) obj1 obj2)
	     (equal? obj1 obj2))
	(and ((both set?) obj1 obj2)
	     ((subset obj1) obj2)
	     ((subset obj2) obj1)))))

(define element (compose there-exists set-equal))

(define (contains set)
  (lambda (e)
    ((element e) set)))

(define (superset s1)
  (lambda (s2)
    ((for-all (contains s1)) s2)))

(define (subset s1)
  (lambda (s2)
    ((superset s2) s1)))

(define (cardinal s)
  (if (empty-set? s)
      0
      (let ((elem (pick s)))
	(+ (cardinal ((residue elem) s)) 1))))

(define (intersection s1 s2)
  (letrec
      ((helper
	(lambda (s1)
	  (if (empty-set? s1)
	      the-empty-set
	      (let ((elem (pick s1)))
		(if ((contains s2) elem)
		    (adjoin elem (helper ((residue elem) s1)))
		    (helper ((residue elem) s1))))))))
    (helper s1)))

(define (union s1 s2)
  (letrec
      ((helper
	(lambda (s1)
	  (if (empty-set? s1)
	      s2
	      (let ((elem (pick s1)))
		(if (not ((contains s2) elem))
		    (adjoin elem (helper ((residue elem) s1)))
		    (helper ((residue elem) s1))))))))
    (helper s1)))

(define (difference s1 s2)
  (letrec
      ((helper
	(lambda (s1)
	  (if (empty-set? s1)
	      the-empty-set
	      (let ((elem (pick s1)))
		(if (not ((contains s2) elem))
		    (adjoin elem (helper ((residue elem) s1)))
		    (helper ((residue elem) s1))))))))
    (helper s1)))

(define (set-builder pred base-set)
  (letrec
      ((helper
	(lambda (s)
	  (if (empty-set? s)
	      base-set
	      (let ((elem (pick s)))
		(if (pred elem)
		    (adjoin elem (helper ((residue elem) s)))
		    (helper ((residue elem) s))))))))
    (helper)))

;(define (intersection s1 s2)
;  ((set-builder (contains s2) the-empty-set) s1))

;(define (union s1 s2)
;  ((set-builder (compose not (contains s2)) s2) s1))

;(define (difference s1 s2)
;  ((set-builder (compose not (contains s2)) the-empty-set) s1))


(define (family-union s)
  (if (empty-set? s)
      the-empty-set
      (let ((elem (pick s)))
	(union elem (family-union ((residue elem) s))))))

(define (family-intersection s)
  (if (empty-set? s)
      the-empty-set
      (letrec
	  ((fam-int
	    (lambda (s)
	      (let ((elem (pick s)))
		(let ((rest ((residue elem) s)))
		  (if (empty-set? rest)
		      elem
		      (intersection elem (fam-int rest))))))))
	(fam-int s))))


(define (set-map proc s)
  (if (empty-set? s)
      the-empty-set
      (let ((elem (pick s)))
	(adjoin (proc elem)
		(set-map proc ((residue elem) s))))))

(define (list->set ls)
  (apply make-set ls))


(define (set->list s)
  (if (empty-set? s)
      '()
      (let ((elem (pick s)))
	(cons elem (set->list ((residue elem) s))))))

;; Set implementation  ===============================================

(define set-tag "set")

(define the-empty-set (cons set-tag '()))

(define (empty-set? s)
  (eq? s the-empty-set))

(define (set? arg)
  (and (pair? arg) (eq? (car arg) set-tag)))

(define (pick s)
  (let ((ls (cdr s)))
    (if (null? ls)
	(error "pick: the set is empty")
	(list-ref ls 0))))

;; Original definition:
;(define (pick s)
;  (let ((ls (cdr s)))
;    (if (null? ls)
;	(error "pick: the set is empty")
;	(list-ref ls (random (length ls))))))


(define (adjoin elem s)
  (cons set-tag (cons elem (cdr s))))

(define (residue elem)
  (lambda (s)
    (let ((ls (remove elem (cdr s))))
      (cond ((null? ls) the-empty-set)
	    (else (cons set-tag ls))))))
