home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / hyperbole / set.el < prev    next >
Encoding:
Text File  |  1995-04-17  |  6.8 KB  |  221 lines
  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)
  221.