1 ;;; set.el --- Provide general mathematical operators on unordered sets.
3 ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
4 ;; Developed with support from Motorola Inc.
6 ;; Author: Bob Weiner, Brown U.
7 ;; Maintainer: Mats Lidell <matsl@contactor.se>
8 ;; Keywords: extensions, tools
10 ;; This file is part of GNU Hyperbole.
12 ;; GNU Hyperbole is free software; you can redistribute it and/or
13 ;; modify it under the terms of the GNU General Public License as
14 ;; published by the Free Software Foundation; either version 3, or (at
15 ;; your option) any later version.
17 ;; GNU Hyperbole is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details.
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25 ;; Boston, MA 02110-1301, USA.
29 ;; All set operations herein work with sets of arbitrary Lisp objects,
30 ;; including strings. By default, they use 'equal' for comparisons
31 ;; but this may be overidden by changing the function bound to
32 ;; the 'set:equal-op' variable.
38 ;; Other required Elisp libraries
45 (defvar set:equal-op 'equal
46 "Comparison function used by set operators.
47 It must be a function of two arguments which returns non-nil only when
48 the arguments are equivalent.")
54 (defmacro set:add (elt set)
55 "Adds element ELT to SET and then returns SET.
56 Uses 'set:equal-op' for comparison.
57 Use (setq set (set:add elt set)) to assure set is always properly modified."
58 (` (cond ((set:member (, elt) (, set)) (, set))
59 ((, set) (setq (, set) (cons (, elt) (, set))))
62 (defun set:combinations (set &optional arity)
63 "Returns all possible combinations (subsets) of SET.
64 Assumes SET is a valid set. With optional ARITY, returns only subsets with
68 (cons nil (apply 'nconc (mapcar (function
70 (setq arity (1+ arity))
71 (set:combinations set arity)))
75 (t (let ((rest) (ctr 1))
80 (setq rest (nthcdr ctr set)
84 (if (listp elt) (cons first elt)
86 (set:combinations rest (1- arity)))))
89 (defun set:create (&rest elements)
90 "Returns a new set created from any number of ELEMENTS or a list of ELEMENTS.
91 Uses 'set:equal-op' for comparison."
94 (lambda (elt) (or (set:member elt set)
95 (setq set (cons elt set)))))
96 (if (or (null (car elements)) (not (listp (car elements))))
101 (fset 'set:delete 'set:remove)
102 (defun set:difference (&rest sets)
103 "Returns difference of any number of SETS.
104 Difference is the set of elements in the first set that are not in any of the
105 other sets. Uses 'set:equal-op' for comparison."
106 (let ((rtn-set (set:members (car sets))))
111 (lambda (elt) (set:remove elt rtn-set)))
116 (defun set:equal (set1 set2)
117 "Returns t iff SET1 contains the same members as SET2. Both must be sets.
118 Uses 'set:equal-op' for comparison."
119 (and (listp set1) (listp set2)
120 (= (set:size set1) (set:size set2))
121 (set:subset set1 set2)))
123 (defun set:get (key set)
124 "Returns the value associated with KEY in SET or nil.
125 Elements of SET should be of the form (key . value)."
126 (cdr (car (let ((set:equal-op
127 (function (lambda (key elt)
128 (equal key (car elt))))))
129 (set:member key set)))))
131 (defun set:intersection (&rest sets)
132 "Returns intersection of all SETS given as arguments.
133 Uses 'set:equal-op' for comparison."
138 (or (memq nil (mapcar (function
139 (lambda (set) (set:member elt set)))
141 (setq rtn-set (cons elt rtn-set)))))
146 "Returns t if OBJ is a set (a list with no repeated elements).
147 Uses 'set:equal-op' for comparison."
150 (while (and (not (set:member (car lst) (cdr lst)))
151 (setq lst (cdr lst))))
154 (fset 'set:map 'mapcar)
156 (defun set:member (elt set)
157 "Returns non-nil if ELT is an element of SET.
158 The value is actually the tail of SET whose car is ELT.
159 Uses 'set:equal-op' for comparison."
160 (while (and set (not (funcall set:equal-op elt (car set))))
161 (setq set (cdr set)))
164 (defun set:members (list)
165 "Returns set of unique elements of LIST.
166 Uses 'set:equal-op' for comparison. See also 'set:create'."
169 (lambda (elt) (or (set:member elt set) (setq set (cons elt set)))))
173 (defmacro set:remove (elt set)
174 "Removes element ELT from SET and returns new set.
175 Assumes SET is a valid set. Uses 'set:equal-op' for comparison.
176 Use (setq set (set:remove elt set)) to assure set is always properly modified."
177 (` (let ((rest (set:member (, elt) (, set)))
180 (cond ((= (length rtn) 1) (setq rtn nil))
182 (setcdr (nthcdr (- (length rtn) 2) rtn) nil))
183 (t (setcar rest (car (cdr rest)))
184 (setcdr rest (cdr (cdr rest))))))
187 (defun set:replace (key value set)
188 "Replaces or adds element whose car matches KEY with element (KEY . VALUE) in SET.
189 Returns set if modified, else nil.
190 Use (setq set (set:replace elt set)) to assure set is always properly modified.
192 Uses 'set:equal-op' to match against KEY. Assumes each element in the set
193 has a car and a cdr."
194 (let ((elt-set (set:member key set)))
197 (progn (setcar elt-set (cons key value))
200 (cons (cons key value) set))))
202 (fset 'set:size 'length)
204 (defun set:subset (sub set)
205 "Returns t iff set SUB is a subset of SET.
206 Uses 'set:equal-op' for comparison."
208 (mapcar (function (lambda (elt) (if is (setq is (set:member elt set))))) sub)
211 (defun set:union (&rest sets)
212 "Returns union of all SETS given as arguments.
213 Uses 'set:equal-op' for comparison."
217 (lambda (set) (mapcar (function
219 (setq rtn-set (set:add elt rtn-set))))