1 ;;;; This software is part of the SBCL system. See the README file for
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.
12 ;;;; A somewhat efficient 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.
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.
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
25 ;;;; XSET-LIST-SIZE is true only for XSETs whose data is stored into a
26 ;;;; list -- XSET-COUNT returns the real value.
28 (in-package "SB!KERNEL")
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
)))
36 (defun xset-count (xset)
37 (let ((data (xset-data xset
)))
40 (hash-table-count data
))))
42 (defun map-xset (function xset
)
43 (declare (function function
))
44 (let ((data (xset-data xset
)))
47 (funcall function elt
))
48 (maphash (lambda (k v
)
54 (defconstant +xset-list-size-limit
+ 24)
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
)))
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
)
68 (setf (gethash x table
) t
))
69 (setf (xset-data xset
) table
)))
70 (setf (gethash elt data
) t
))))
72 ;; items must be canonical - no duplicates - and few in number.
73 (defun xset-from-list (items)
74 (let ((n (length items
)))
75 (aver (<= n
+xset-list-size-limit
+))
76 (let ((xset (alloc-xset)))
77 (setf (xset-list-size xset
) n
(xset-data xset
) items
)
80 (defun xset-union (a b
)
81 (let ((xset (alloc-xset)))
90 (defun xset-member-p (elt xset
)
91 (let ((data (xset-data xset
)))
93 (member elt data
:test
#'eql
)
96 (defun xset-members (xset)
97 (let ((data (xset-data xset
)))
101 (maphash (lambda (k v
)
107 (defun xset-intersection (a b
)
108 (let ((intersection (alloc-xset)))
109 (multiple-value-bind (source lookup
)
110 (if (< (xset-list-size a
) (xset-list-size b
))
113 (let ((data (xset-data lookup
)))
114 (map-xset (if (listp data
)
116 (when (member elt data
:test
#'eql
)
117 (add-to-xset elt intersection
)))
119 (when (gethash elt data
)
120 (add-to-xset elt intersection
))))
124 (defun xset-subset-p (xset1 xset2
)
125 (when (<= (xset-count xset1
) (xset-count xset2
))
126 (let ((data (xset-data xset2
)))
130 (unless (member elt data
:test
#'eql
)
131 (return-from xset-subset-p nil
)))
133 (unless (gethash elt data
)
134 (return-from xset-subset-p nil
))))
138 #!-sb-fluid
(declaim (inline xset-empty-p
))
139 (defun xset-empty-p (xset)
140 (not (xset-data xset
)))