Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/set.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;!emacs
2 ;;
3 ;; FILE: set.el
4 ;; SUMMARY: Provide general mathematical operators on unordered sets.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: extensions, tools
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Brown U.
10 ;;
11 ;; ORIG-DATE: 26-Sep-91 at 19:24:19
12 ;; LAST-MOD: 14-Apr-95 at 16:17:03 by Bob Weiner
13 ;;
14 ;; This file is part of Hyperbole.
15 ;; Available for use and distribution under the same terms as GNU Emacs.
16 ;;
17 ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
18 ;; Developed with support from Motorola Inc.
19 ;;
20 ;; DESCRIPTION:
21 ;;
22 ;; All set operations herein work with sets of arbitrary Lisp objects,
23 ;; including strings. By default, they use 'equal' for comparisons
24 ;; but this may be overidden by changing the function bound to
25 ;; the 'set:equal-op' variable.
26 ;;
27 ;; DESCRIP-END.
28
29 ;; ************************************************************************
30 ;; Other required Elisp libraries
31 ;; ************************************************************************
32
33 ;; ************************************************************************
34 ;; Public variables
35 ;; ************************************************************************
36
37 (defvar set:equal-op 'equal
38 "Comparison function used by set operators.
39 It must be a function of two arguments which returns non-nil only when
40 the arguments are equivalent.")
41
42 ;; ************************************************************************
43 ;; Public functions
44 ;; ************************************************************************
45
46 (defmacro set:add (elt set)
47 "Adds element ELT to SET and then returns SET.
48 Uses 'set:equal-op' for comparison.
49 Use (setq set (set:add elt set)) to assure set is always properly modified."
50 (` (cond ((set:member (, elt) (, set)) (, set))
51 ((, set) (setq (, set) (cons (, elt) (, set))))
52 (t (list (, elt))))))
53
54 (defun set:combinations (set &optional arity)
55 "Returns all possible combinations (subsets) of SET.
56 Assumes SET is a valid set. With optional ARITY, returns only subsets with
57 ARITY members."
58 (cond ((null arity)
59 (setq arity 0)
60 (cons nil (apply 'nconc (mapcar (function
61 (lambda (elt)
62 (setq arity (1+ arity))
63 (set:combinations set arity)))
64 set))))
65 ((= arity 1) set)
66 ((<= arity 0) '(nil))
67 (t (let ((rest) (ctr 1))
68 (apply
69 'nconc
70 (mapcar (function
71 (lambda (first)
72 (setq rest (nthcdr ctr set)
73 ctr (1+ ctr))
74 (mapcar (function
75 (lambda (elt)
76 (if (listp elt) (cons first elt)
77 (list first elt))))
78 (set:combinations rest (1- arity)))))
79 set))))))
80
81 (defun set:create (&rest elements)
82 "Returns a new set created from any number of ELEMENTS or a list of ELEMENTS.
83 Uses 'set:equal-op' for comparison."
84 (let ((set))
85 (mapcar (function
86 (lambda (elt) (or (set:member elt set)
87 (setq set (cons elt set)))))
88 (if (or (null (car elements)) (not (listp (car elements))))
89 elements
90 (car elements)))
91 set))
92
93 (fset 'set:delete 'set:remove)
94 (defun set:difference (&rest sets)
95 "Returns difference of any number of SETS.
96 Difference is the set of elements in the first set that are not in any of the
97 other sets. Uses 'set:equal-op' for comparison."
98 (let ((rtn-set (set:members (car sets))))
99 (mapcar
100 (function
101 (lambda (set)
102 (mapcar (function
103 (lambda (elt) (set:remove elt rtn-set)))
104 set)))
105 (cdr sets))
106 rtn-set))
107
108 (defun set:equal (set1 set2)
109 "Returns t iff SET1 contains the same members as SET2. Both must be sets.
110 Uses 'set:equal-op' for comparison."
111 (and (listp set1) (listp set2)
112 (= (set:size set1) (set:size set2))
113 (set:subset set1 set2)))
114
115 (defun set:get (key set)
116 "Returns the value associated with KEY in SET or nil.
117 Elements of SET should be of the form (key . value)."
118 (cdr (car (let ((set:equal-op
119 (function (lambda (key elt)
120 (equal key (car elt))))))
121 (set:member key set)))))
122
123 (defun set:intersection (&rest sets)
124 "Returns intersection of all SETS given as arguments.
125 Uses 'set:equal-op' for comparison."
126 (let ((rtn-set))
127 (mapcar
128 (function
129 (lambda (elt)
130 (or (memq nil (mapcar (function
131 (lambda (set) (set:member elt set)))
132 (cdr sets)))
133 (setq rtn-set (cons elt rtn-set)))))
134 (car sets))
135 rtn-set))
136
137 (defun set:is (obj)
138 "Returns t if OBJ is a set (a list with no repeated elements).
139 Uses 'set:equal-op' for comparison."
140 (and (listp obj)
141 (let ((lst obj))
142 (while (and (not (set:member (car lst) (cdr lst)))
143 (setq lst (cdr lst))))
144 (null lst))))
145
146 (fset 'set:map 'mapcar)
147
148 (defun set:member (elt set)
149 "Returns non-nil if ELT is an element of SET.
150 The value is actually the tail of SET whose car is ELT.
151 Uses 'set:equal-op' for comparison."
152 (while (and set (not (funcall set:equal-op elt (car set))))
153 (setq set (cdr set)))
154 set)
155
156 (defun set:members (list)
157 "Returns set of unique elements of LIST.
158 Uses 'set:equal-op' for comparison. See also 'set:create'."
159 (let ((set))
160 (mapcar (function
161 (lambda (elt) (or (set:member elt set) (setq set (cons elt set)))))
162 list)
163 set))
164
165 (defmacro set:remove (elt set)
166 "Removes element ELT from SET and returns new set.
167 Assumes SET is a valid set. Uses 'set:equal-op' for comparison.
168 Use (setq set (set:remove elt set)) to assure set is always properly modified."
169 (` (let ((rest (set:member (, elt) (, set)))
170 (rtn (, set)))
171 (if rest
172 (cond ((= (length rtn) 1) (setq rtn nil))
173 ((= (length rest) 1)
174 (setcdr (nthcdr (- (length rtn) 2) rtn) nil))
175 (t (setcar rest (car (cdr rest)))
176 (setcdr rest (cdr (cdr rest))))))
177 rtn)))
178
179 (defun set:replace (key value set)
180 "Replaces or adds element whose car matches KEY with element (KEY . VALUE) in SET.
181 Returns set if modified, else nil.
182 Use (setq set (set:replace elt set)) to assure set is always properly modified.
183
184 Uses 'set:equal-op' to match against KEY. Assumes each element in the set
185 has a car and a cdr."
186 (let ((elt-set (set:member key set)))
187 (if elt-set
188 ;; replace element
189 (progn (setcar elt-set (cons key value))
190 set)
191 ;; add new element
192 (cons (cons key value) set))))
193
194 (fset 'set:size 'length)
195
196 (defun set:subset (sub set)
197 "Returns t iff set SUB is a subset of SET.
198 Uses 'set:equal-op' for comparison."
199 (let ((is t))
200 (mapcar (function (lambda (elt) (if is (setq is (set:member elt set))))) sub)
201 (and is t)))
202
203 (defun set:union (&rest sets)
204 "Returns union of all SETS given as arguments.
205 Uses 'set:equal-op' for comparison."
206 (let ((rtn-set))
207 (mapcar
208 (function
209 (lambda (set) (mapcar (function
210 (lambda (elt)
211 (setq rtn-set (set:add elt rtn-set))))
212 set)))
213 sets)
214 rtn-set))
215
216 ;; ************************************************************************
217 ;; Private variables
218 ;; ************************************************************************
219
220 (provide 'set)