src/code/xset.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 ;;;; XSET
  11 ;;;;
  12 ;;;; A somewhat effcient set implementation that can store arbitrary
  13 ;;;; objects. For small sets the data is stored in a list, but when
  14 ;;;; the amount of elements grows beyond +XSET-LIST-SIZE-LIMIT+, we
  15 ;;;; switch to a hash-table instead.
  16 ;;;;
  17 ;;;; ALLOC-XSET allocates an empty XSET. ADD-TO-XSET adds an element
  18 ;;;; to an XSET: it should be used only on freshly allocated XSETs.
  19 ;;;;
  20 ;;;; XSET-EMPTY-P, XSET-INTERSECTION, XSET-SUBSET-P, and XSET-MEMBER-P
  21 ;;;; do the obvious things. MAP-XSET maps over the element, but
  22 ;;;; requires a function as the first argument -- not a function
  23 ;;;; designator.
  24 ;;;;
  25 ;;;; XSET-LIST-SIZE is true only for XSETs whose data is stored into a
  26 ;;;; list -- XSET-COUNT returns the real value.
  27
  28 (in-package "SB!KERNEL")
  29
  30 #!-sb-fluid
  31 (declaim (inline alloc-xset xset-data (setf xset-data) xset-list-size (setf xset-list-size)))
  32 (defstruct (xset (:constructor alloc-xset) (:copier nil) (:predicate nil))
  33   (list-size 0 :type index)
  34   (data nil :type (or list hash-table)))
  35
  36 (defun xset-count (xset)
  37   (let ((data (xset-data xset)))
  38     (if (listp data)
  39         (xset-list-size xset)
  40         (hash-table-count data))))
  41
  42 (defun map-xset (function xset)
  43   (declare (function function))
  44   (let ((data (xset-data xset)))
  45     (if (listp data)
  46         (dolist (elt data)
  47           (funcall function elt))
  48         (maphash (lambda (k v)
  49                    (declare (ignore v))
  50                    (funcall function k))
  51                  data)))
  52   nil)
  53
  54 (defconstant +xset-list-size-limit+ 24)
  55
  56 ;;; Checks that the element is not in the set yet.
  57 (defun add-to-xset (elt xset)
  58   (let ((data (xset-data xset))
  59         (size (xset-list-size xset)))
  60     (if (listp data)
  61         (if (< size +xset-list-size-limit+)
  62             (unless (member elt data :test #'eql)
  63               (setf (xset-list-size xset) (1+ size)
  64                     (xset-data xset) (cons elt data)))
  65             (let ((table (make-hash-table :size (* 2 size) :test #'eql)))
  66               (setf (gethash elt table) t)
  67               (dolist (x data)
  68                 (setf (gethash x table) t))
  69               (setf (xset-data xset) table)))
  70         (setf (gethash elt data) t))))
  71
  72 (defun xset-union (a b)
  73   (let ((xset (alloc-xset)))
  74     (map-xset (lambda (x)
  75                 (add-to-xset x xset))
  76               a)
  77     (map-xset (lambda (y)
  78                 (add-to-xset y xset))
  79               b)
  80     xset))
  81
  82 (defun xset-member-p (elt xset)
  83   (let ((data (xset-data xset)))
  84     (if (listp data)
  85         (member elt data :test #'eql)
  86         (gethash elt data))))
  87
  88 (defun xset-members (xset)
  89   (let ((data (xset-data xset)))
  90     (if (listp data)
  91         data
  92         (let (members)
  93           (maphash (lambda (k v)
  94                      (declare (ignore v))
  95                      (push k members))
  96                    data)
  97           members))))
  98
  99 (defun xset-intersection (a b)
 100   (let ((intersection (alloc-xset)))
 101     (multiple-value-bind (source lookup)
 102         (if (< (xset-list-size a) (xset-list-size b))
 103             (values b a)
 104             (values a b))
 105       (let ((data (xset-data lookup)))
 106         (map-xset (if (listp data)
 107                       (lambda (elt)
 108                         (when (member elt data :test #'eql)
 109                           (add-to-xset elt intersection)))
 110                       (lambda (elt)
 111                         (when (gethash elt data)
 112                           (add-to-xset elt intersection))))
 113                  source)))
 114     intersection))
 115
 116 (defun xset-subset-p (xset1 xset2)
 117   (when (<= (xset-count xset1) (xset-count xset2))
 118     (let ((data (xset-data xset2)))
 119       (map-xset
 120        (if (listp data)
 121            (lambda (elt)
 122              (unless (member elt data :test #'eql)
 123                (return-from xset-subset-p nil)))
 124            (lambda (elt)
 125              (unless (gethash elt data)
 126                (return-from xset-subset-p nil))))
 127        xset1))
 128     t))
 129
 130 #!-sb-fluid (declaim (inline xset-empty-p))
 131 (defun xset-empty-p (xset)
 132   (not (xset-data xset)))