--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/hyperbole/set.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,220 @@
+;;!emacs
+;;
+;; FILE:         set.el
+;; SUMMARY:      Provide general mathematical operators on unordered sets.
+;; USAGE:        GNU Emacs Lisp Library
+;; KEYWORDS:     extensions, tools
+;;
+;; AUTHOR:       Bob Weiner
+;; ORG:          Brown U.
+;;
+;; ORIG-DATE:    26-Sep-91 at 19:24:19
+;; LAST-MOD:     14-Apr-95 at 16:17:03 by Bob Weiner
+;;
+;; This file is part of Hyperbole.
+;; Available for use and distribution under the same terms as GNU Emacs.
+;;
+;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
+;; Developed with support from Motorola Inc.
+;;
+;; 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 (function
+					   (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 (function
+			 (lambda (first)
+			   (setq rest (nthcdr ctr set)
+				 ctr (1+ ctr))
+			   (mapcar (function
+				     (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 (function
+	      (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
+      (function
+	(lambda (set)
+	  (mapcar (function
+		    (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:get (key set)
+  "Returns the value associated with KEY in SET or nil.
+Elements of SET should be of the form (key . value)."
+  (cdr (car (let ((set:equal-op
+		   (function (lambda (key elt)
+			       (equal key (car elt))))))
+	      (set:member key set)))))
+
+(defun set:intersection (&rest sets)
+  "Returns intersection of all SETS given as arguments.
+Uses 'set:equal-op' for comparison."
+  (let ((rtn-set))
+    (mapcar
+      (function
+	(lambda (elt)
+	  (or (memq nil (mapcar (function
+				  (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 elt (car set))))
+    (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 (function
+	      (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)))
+
+(defun set:replace (key value set)
+  "Replaces or adds element whose car matches KEY with element (KEY . VALUE) in SET.
+Returns set if modified, else nil.
+Use (setq set (set:replace elt set)) to assure set is always properly modified.
+
+Uses 'set:equal-op' to match against KEY.  Assumes each element in the set
+has a car and a cdr."
+  (let ((elt-set (set:member key set)))
+    (if elt-set
+	;; replace element
+	(progn (setcar elt-set (cons key value))
+	       set)
+      ;; add new element
+      (cons (cons key value) set))))
+
+(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 (function (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
+      (function
+	(lambda (set) (mapcar (function
+				(lambda (elt)
+				  (setq rtn-set (set:add elt rtn-set))))
+			      set)))
+      sets)
+    rtn-set))
+
+;; ************************************************************************
+;; Private variables
+;; ************************************************************************
+
+(provide 'set)