;;!emacs
;;
;; FILE:         set.el
;; SUMMARY:      Provide general mathematical operators on unordered sets.
;; USAGE:        GNU Emacs Lisp Library
;;
;; AUTHOR:       Bob Weiner
;; ORG:          Brown U.
;;
;; ORIG-DATE:    26-Sep-91 at 19:24:19
;; LAST-MOD:     24-Jan-92 at 10:43:55 by Bob Weiner
;;
;; This file is part of Hyperbole.
;; 
;; Copyright (C) 1991, Brown University, Providence, RI
;; Developed with support from Motorola Inc.
;; 
;; Permission to use, modify and redistribute this software and its
;; documentation for any purpose other than its incorporation into a
;; commercial product is hereby granted without fee.  A distribution fee
;; may be charged with any redistribution.  Any distribution requires
;; that the above copyright notice appear in all copies, that both that
;; copyright notice and this permission notice appear in supporting
;; documentation, and that neither the name of Brown University nor the
;; author's name be used in advertising or publicity pertaining to
;; distribution of the software without specific, written prior permission.
;; 
;; Brown University makes no representations about the suitability of this
;; software for any purpose.  It is provided "as is" without express or
;; implied warranty.
;;
;;
;; DESCRIPTION:  
;;
;;   All set operations herein work with sets of arbitrary Lisp objects,
;;   including strings.  By default, they use 'equal' for comparisons
;;   but this may be overidden by changing the function bound to
;;   the 'set:equal-op' variable.
;;
;; DESCRIP-END.

;; ************************************************************************
;; Other required Elisp libraries
;; ************************************************************************

;; ************************************************************************
;; Public variables
;; ************************************************************************

(defvar set:equal-op 'equal
  "Comparison function used by set operators.
It must be a function of two arguments which returns non-nil only when
the arguments are equivalent.")

;; ************************************************************************
;; Public functions
;; ************************************************************************

(defmacro set:add (elt set)
  "Adds element ELT to SET and then returns SET.
Uses 'set:equal-op' for comparison.
Use (setq set (set:add elt set)) to assure set is always properly modified."
  (` (cond ((set:member (, elt) (, set)) (, set))
	   ((, set) (setq (, set) (cons (, elt) (, set))))
	   (t (list (, elt))))))

(defun set:combinations (set &optional arity)
  "Returns all possible combinations (subsets) of SET.
Assumes SET is a valid set.  With optional ARITY, returns only subsets with
ARITY members."
  (cond ((null arity) 
	 (setq arity 0)
	 (cons nil (apply 'nconc (mapcar '(lambda (elt)
					    (setq arity (1+ arity))
					    (set:combinations set arity))
					 set))))
	((= arity 1) set)
	((<= arity 0) '(nil))
	(t (let ((rest) (ctr 1))
	     (apply
	      'nconc
	      (mapcar '(lambda (first)
			 (setq rest (nthcdr ctr set)
			       ctr (1+ ctr))
			 (mapcar '(lambda (elt)
				    (if (listp elt) (cons first elt)
				      (list first elt)))
				 (set:combinations rest (1- arity))))
		      set))))))

(defun set:create (&rest elements)
  "Returns a new set created from any number of ELEMENTS or a list of ELEMENTS.
Uses 'set:equal-op' for comparison."
  (let ((set))
    (mapcar '(lambda (elt) (or (set:member elt set)
			       (setq set (cons elt set))))
	    (if (or (null (car elements)) (not (listp (car elements))))
		elements
	      (car elements)))
    set))

(fset 'set:delete 'set:remove)
(defun set:difference (&rest sets)
  "Returns difference of any number of SETS.
Difference is the set of elements in the first set that are not in any of the
other sets.  Uses 'set:equal-op' for comparison."
  (let ((rtn-set (set:members (car sets))))
    (mapcar
     '(lambda (set)
        (mapcar '(lambda (elt) (set:remove elt rtn-set)) set))
     (cdr sets))
    rtn-set))

(defun set:equal (set1 set2)
  "Returns t iff SET1 contains the same members as SET2.  Both must be sets.
Uses 'set:equal-op' for comparison."
  (and (listp set1) (listp set2)
       (= (set:size set1) (set:size set2))
       (set:subset set1 set2)))

(defun set:intersection (&rest sets)
  "Returns intersection of all SETS given as arguments.
Uses 'set:equal-op' for comparison."
  (let ((rtn-set))
    (mapcar
     '(lambda (elt)
	(or (memq nil (mapcar '(lambda (set) (set:member elt set)) (cdr sets)))
	    (setq rtn-set (cons elt rtn-set))))
     (car sets))
    rtn-set))

(defun set:is (obj)
  "Returns t if OBJ is a set (a list with no repeated elements).
Uses 'set:equal-op' for comparison."
  (and (listp obj)
       (let ((lst obj))
	 (while (and (not (set:member (car lst) (cdr lst)))
		     (setq lst (cdr lst))))
	 (null lst))))

(fset 'set:map 'mapcar)

(defun set:member (elt set)
  "Returns non-nil if ELT is an element of SET.
The value is actually the tail of SET whose car is ELT.
Uses 'set:equal-op' for comparison."
  (while (and set (not (funcall set:equal-op (car set) elt)))
    (setq set (cdr set)))
  set)

(defun set:members (list)
  "Returns set of unique elements of LIST.
Uses 'set:equal-op' for comparison.  See also 'set:create'."
  (let ((set))
    (mapcar '(lambda (elt) (or (set:member elt set) (setq set (cons elt set))))
	    list)
    set))

(defmacro set:remove (elt set)
  "Removes element ELT from SET and returns new set.
Assumes SET is a valid set.  Uses 'set:equal-op' for comparison.
Use (setq set (set:remove elt set)) to assure set is always properly modified."
  (` (let ((rest (set:member (, elt) (, set)))
	   (rtn (, set)))
       (if rest
	   (cond ((= (length rtn) 1) (setq rtn nil))
		 ((= (length rest) 1)
		  (setcdr (nthcdr (- (length rtn) 2) rtn) nil))
		 (t (setcar rest (car (cdr rest)))
		    (setcdr rest (cdr (cdr rest))))))
       rtn)))

(fset 'set:size 'length)

(defun set:subset (sub set)
  "Returns t iff set SUB is a subset of SET.
Uses 'set:equal-op' for comparison."
  (let ((is t))
    (mapcar '(lambda (elt) (if is (setq is (set:member elt set)))) sub)
    (and is t)))

(defun set:union (&rest sets)
  "Returns union of all SETS given as arguments.
Uses 'set:equal-op' for comparison."
  (let ((rtn-set))
    (mapcar '(lambda (elt) (cons elt rtn-set)) (set:members (car sets)))
    (mapcar
     '(lambda (set) (mapcar '(lambda (elt) (set:add elt rtn-set)) set))
     (cdr sets))
    rtn-set))

;; ************************************************************************
;; Private functions
;; ************************************************************************

;; ************************************************************************
;; Private variables
;; ************************************************************************

(provide 'set)