cgit.sxemacs.org Git - packages/blob - xemacs-packages/hyperbole/set.el

   1 ;;; set.el --- Provide general mathematical operators on unordered sets.
   2
   3 ;; Copyright (C) 1991-1995, Free Software Foundation, Inc.
   4 ;; Developed with support from Motorola Inc.
   5
   6 ;; Author: Bob Weiner, Brown U.
   7 ;; Maintainer: Mats Lidell <matsl@contactor.se>
   8 ;; Keywords: extensions, tools
   9
  10 ;; This file is part of GNU Hyperbole.
  11
  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.
  16
  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.
  21
  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.
  26
  27 ;;; Commentary:
  28 ;;
  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.
  33 ;;
  34
  35 ;;; Code:
  36
  37 ;;
  38 ;; Other required Elisp libraries
  39 ;;
  40
  41 ;;
  42 ;; Public variables
  43 ;;
  44
  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.")
  49
  50 ;;
  51 ;; Public functions
  52 ;;
  53
  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))))
  60            (t (list (, elt))))))
  61
  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
  65 ARITY members."
  66   (cond ((null arity)
  67          (setq arity 0)
  68          (cons nil (apply 'nconc (mapcar (function
  69                                            (lambda (elt)
  70                                              (setq arity (1+ arity))
  71                                              (set:combinations set arity)))
  72                                          set))))
  73         ((= arity 1) set)
  74         ((<= arity 0) '(nil))
  75         (t (let ((rest) (ctr 1))
  76              (apply
  77                'nconc
  78                (mapcar (function
  79                          (lambda (first)
  80                            (setq rest (nthcdr ctr set)
  81                                  ctr (1+ ctr))
  82                            (mapcar (function
  83                                      (lambda (elt)
  84                                        (if (listp elt) (cons first elt)
  85                                          (list first elt))))
  86                                    (set:combinations rest (1- arity)))))
  87                        set))))))
  88
  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."
  92   (let ((set))
  93     (mapcar (function
  94               (lambda (elt) (or (set:member elt set)
  95                                 (setq set (cons elt set)))))
  96             (if (or (null (car elements)) (not (listp (car elements))))
  97                 elements
  98               (car elements)))
  99     set))
 100
 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))))
 107     (mapcar
 108       (function
 109         (lambda (set)
 110           (mapcar (function
 111                     (lambda (elt) (set:remove elt rtn-set)))
 112                   set)))
 113       (cdr sets))
 114     rtn-set))
 115
 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)))
 122
 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)))))
 130
 131 (defun set:intersection (&rest sets)
 132   "Returns intersection of all SETS given as arguments.
 133 Uses 'set:equal-op' for comparison."
 134   (let ((rtn-set))
 135     (mapcar
 136       (function
 137         (lambda (elt)
 138           (or (memq nil (mapcar (function
 139                                   (lambda (set) (set:member elt set)))
 140                                 (cdr sets)))
 141               (setq rtn-set (cons elt rtn-set)))))
 142       (car sets))
 143     rtn-set))
 144
 145 (defun set:is (obj)
 146   "Returns t if OBJ is a set (a list with no repeated elements).
 147 Uses 'set:equal-op' for comparison."
 148   (and (listp obj)
 149        (let ((lst obj))
 150          (while (and (not (set:member (car lst) (cdr lst)))
 151                      (setq lst (cdr lst))))
 152          (null lst))))
 153
 154 (fset 'set:map 'mapcar)
 155
 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)))
 162   set)
 163
 164 (defun set:members (list)
 165   "Returns set of unique elements of LIST.
 166 Uses 'set:equal-op' for comparison.  See also 'set:create'."
 167   (let ((set))
 168     (mapcar (function
 169               (lambda (elt) (or (set:member elt set) (setq set (cons elt set)))))
 170             list)
 171     set))
 172
 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)))
 178            (rtn (, set)))
 179        (if rest
 180            (cond ((= (length rtn) 1) (setq rtn nil))
 181                  ((= (length rest) 1)
 182                   (setcdr (nthcdr (- (length rtn) 2) rtn) nil))
 183                  (t (setcar rest (car (cdr rest)))
 184                     (setcdr rest (cdr (cdr rest))))))
 185        rtn)))
 186
 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.
 191
 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)))
 195     (if elt-set
 196         ;; replace element
 197         (progn (setcar elt-set (cons key value))
 198                set)
 199       ;; add new element
 200       (cons (cons key value) set))))
 201
 202 (fset 'set:size 'length)
 203
 204 (defun set:subset (sub set)
 205   "Returns t iff set SUB is a subset of SET.
 206 Uses 'set:equal-op' for comparison."
 207   (let ((is t))
 208     (mapcar (function (lambda (elt) (if is (setq is (set:member elt set))))) sub)
 209     (and is t)))
 210
 211 (defun set:union (&rest sets)
 212   "Returns union of all SETS given as arguments.
 213 Uses 'set:equal-op' for comparison."
 214   (let ((rtn-set))
 215     (mapcar
 216       (function
 217         (lambda (set) (mapcar (function
 218                                 (lambda (elt)
 219                                   (setq rtn-set (set:add elt rtn-set))))
 220                               set)))
 221       sets)
 222     rtn-set))
 223
 224 ;;
 225 ;; Private variables
 226 ;;
 227
 228 (provide 'set)
 229
 230 ;;; set.el ends here