+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+;;;; XSET
+;;;;
+;;;; A somewhat effcient set implementation that can store arbitrary
+;;;; objects. For small sets the data is stored in a list, but when
+;;;; the amount of elements grows beyond +XSET-LIST-SIZE-LIMIT+, we
+;;;; switch to a hash-table instead.
+;;;;
+;;;; ALLOC-XSET allocates an empty XSET. ADD-TO-XSET adds an element
+;;;; to an XSET: it should be used only on freshly allocated XSETs.
+;;;;
+;;;; XSET-EMPTY-P, XSET-INTERSECTION, XSET-SUBSET-P, and XSET-MEMBER-P
+;;;; do the obvious things. MAP-XSET maps over the element, but
+;;;; requires a function as the first argument -- not a function
+;;;; designator.
+;;;;
+;;;; XSET-LIST-SIZE is true only for XSETs whose data is stored into a
+;;;; list -- XSET-COUNT returns the real value.
+
+(in-package "SB!KERNEL")
+
+#!-sb-fluid
+(declaim (inline alloc-xset xset-data (setf xset-data) xset-list-size (setf xset-list-size)))
+(defstruct (xset (:constructor alloc-xset) (:copier nil) (:predicate nil))
+ (list-size 0 :type index)
+ (data nil :type (or list hash-table)))
+
+(defun xset-count (xset)
+ (let ((data (xset-data xset)))
+ (if (listp data)
+ (xset-list-size xset)
+ (hash-table-count data))))
+
+(defun map-xset (function xset)
+ (declare (function function))
+ (let ((data (xset-data xset)))
+ (if (listp data)
+ (dolist (elt data)
+ (funcall function elt))
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (funcall function k))
+ data)))
+ nil)
+
+(defconstant +xset-list-size-limit+ 12)
+
+;;; Checks that the element is not in the set yet.
+(defun add-to-xset (elt xset)
+ (let ((data (xset-data xset))
+ (size (xset-list-size xset)))
+ (if (listp data)
+ (if (< size +xset-list-size-limit+)
+ (unless (member elt data :test #'eq)
+ (setf (xset-list-size xset) (1+ size)
+ (xset-data xset) (cons elt data)))
+ (let ((table (make-hash-table :size (* 2 size) :test #'eq)))
+ (setf (gethash elt table) t)
+ (dolist (x data)
+ (setf (gethash x table) t))
+ (setf (xset-data xset) table)))
+ (setf (gethash elt data) t))))
+
+(defun xset-union (a b)
+ (let ((xset (alloc-xset)))
+ (map-xset (lambda (x)
+ (add-to-xset x xset))
+ a)
+ (map-xset (lambda (y)
+ (add-to-xset y xset))
+ b)
+ xset))
+
+(defun xset-member-p (elt xset)
+ (let ((data (xset-data xset)))
+ (if (listp data)
+ (member elt data :test #'eq)
+ (gethash elt data))))
+
+(defun xset-members (xset)
+ (let ((data (xset-data xset)))
+ (if (listp data)
+ data
+ (let (members)
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (push k members))
+ data)
+ members))))
+
+(defun xset-intersection (a b)
+ (let ((intersection (alloc-xset)))
+ (multiple-value-bind (source lookup)
+ (if (< (xset-list-size a) (xset-list-size b))
+ (values b a)
+ (values a b))
+ (let ((data (xset-data lookup)))
+ (map-xset (if (listp data)
+ (lambda (elt)
+ (when (member elt data :test #'eq)
+ (add-to-xset elt intersection)))
+ (lambda (elt)
+ (when (gethash elt data)
+ (add-to-xset elt intersection))))
+ source)))
+ intersection))
+
+(defun xset-subset-p (xset1 xset2)
+ (when (<= (xset-count xset1) (xset-count xset2))
+ (let ((data (xset-data xset2)))
+ (map-xset
+ (if (listp data)
+ (lambda (elt)
+ (unless (member elt data :test #'eq)
+ (return-from xset-subset-p nil)))
+ (lambda (elt)
+ (unless (gethash elt data)
+ (return-from xset-subset-p nil))))
+ xset1))
+ t))
+
+#!-sb-fluid (declaim (inline xset-empty-p))
+(defun xset-empty-p (xset)
+ (not (xset-data xset)))