1 ;;;; This file implements a sparse set abstraction, represented as a
2 ;;;; sorted linked list. We don't use bit-vectors to represent sets in
3 ;;;; flow analysis, since the universe may be quite large but the
4 ;;;; average number of elements is small. We keep the list sorted so
5 ;;;; that we can do union and intersection in linear time.
7 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; This software is derived from the CMU CL system, which was
11 ;;;; written at Carnegie Mellon University and released into the
12 ;;;; public domain. The software is in the public domain and is
13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
14 ;;;; files for more information.
18 ;;; Each structure that may be placed in a SSet must include the
19 ;;; SSet-Element structure. We allow an initial value of NIL to mean
20 ;;; that no ordering has been assigned yet (although an ordering must
21 ;;; be assigned before doing set operations.)
22 (defstruct (sset-element (:constructor nil)
24 (number nil :type (or index null)))
26 (defstruct (sset (:constructor make-sset ()))
27 (elements (list nil) :type list))
29 (elements :prin1 (cdr elements)))
31 ;;; Iterate over the elements in SSET, binding VAR to each element in
33 (defmacro do-sset-elements ((var sset &optional result) &body body)
34 `(dolist (,var (cdr (sset-elements ,sset)) ,result) ,@body))
36 ;;; Destructively add Element to Set. If Element was not in the set,
37 ;;; then we return true, otherwise we return false.
38 (declaim (ftype (function (sset-element sset) boolean) sset-adjoin))
39 (defun sset-adjoin (element set)
40 (let ((number (sset-element-number element))
41 (elements (sset-elements set)))
42 (do ((prev elements current)
43 (current (cdr elements) (cdr current)))
45 (setf (cdr prev) (list element))
47 (let ((el (car current)))
48 (when (>= (sset-element-number el) number)
51 (setf (cdr prev) (cons element current))
54 ;;; Destructively remove Element from Set. If element was in the set,
55 ;;; then return true, otherwise return false.
56 (declaim (ftype (function (sset-element sset) boolean) sset-delete))
57 (defun sset-delete (element set)
58 (let ((elements (sset-elements set)))
59 (do ((prev elements current)
60 (current (cdr elements) (cdr current)))
62 (when (eq (car current) element)
63 (setf (cdr prev) (cdr current))
66 ;;; Return true if Element is in Set, false otherwise.
67 (declaim (ftype (function (sset-element sset) boolean) sset-member))
68 (defun sset-member (element set)
69 (declare (inline member))
70 (not (null (member element (cdr (sset-elements set)) :test #'eq))))
72 ;;; Return true if SET contains no elements, false otherwise.
73 (declaim (ftype (function (sset) boolean) sset-empty))
74 (defun sset-empty (set)
75 (null (cdr (sset-elements set))))
77 ;;; Return a new copy of SET.
78 (declaim (ftype (function (sset) sset) copy-sset))
79 (defun copy-sset (set)
80 (let ((res (make-sset)))
81 (setf (sset-elements res) (copy-list (sset-elements set)))
84 ;;; Perform the appropriate set operation on SET1 and SET2 by destructively
85 ;;; modifying SET1. We return true if SET1 was modified, false otherwise.
86 (declaim (ftype (function (sset sset) boolean) sset-union sset-intersection
88 (defun sset-union (set1 set2)
89 (let* ((prev-el1 (sset-elements set1))
92 (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
95 (num2 (sset-element-number e)))
98 (setf (cdr prev-el1) (copy-list el2))
99 (return-from sset-union t))
100 (let ((num1 (sset-element-number (car el1))))
103 (let ((new (cons e el1)))
104 (setf (cdr prev-el1) new)
105 (setq prev-el1 new changed t))
106 (shiftf prev-el1 el1 (cdr el1)))
108 (shiftf prev-el1 el1 (cdr el1))))))))
109 (defun sset-intersection (set1 set2)
110 (let* ((prev-el1 (sset-elements set1))
113 (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
116 (setf (cdr prev-el1) nil)
119 (let ((num2 (sset-element-number (car el2))))
122 (return-from sset-intersection changed))
123 (let ((num1 (sset-element-number (car el1))))
126 (shiftf prev-el1 el1 (cdr el1)))
129 (setf (cdr prev-el1) el1)
130 (setq changed t)))))))
131 (defun sset-difference (set1 set2)
132 (let* ((prev-el1 (sset-elements set1))
135 (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
137 (let ((num2 (sset-element-number (car el2))))
140 (return-from sset-difference changed))
141 (let ((num1 (sset-element-number (car el1))))
145 (setf (cdr prev-el1) el1)
148 (shiftf prev-el1 el1 (cdr el1))))))))
150 ;;; Destructively modify Set1 to include its union with the difference
151 ;;; of Set2 and Set3. We return true if Set1 was modified, false
153 (declaim (ftype (function (sset sset sset) boolean) sset-union-of-difference))
154 (defun sset-union-of-difference (set1 set2 set3)
155 (let* ((prev-el1 (sset-elements set1))
157 (el3 (cdr (sset-elements set3)))
159 (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
162 (num2 (sset-element-number e)))
167 (setf (cdr prev-el1) (copy-list el2))
168 (return-from sset-union-of-difference t))
169 (let ((num1 (sset-element-number (car el1))))
172 (let ((new (cons e el1)))
173 (setf (cdr prev-el1) new)
174 (setq prev-el1 new changed t))
175 (shiftf prev-el1 el1 (cdr el1)))
177 (shiftf prev-el1 el1 (cdr el1))))
179 (let ((num3 (sset-element-number (car el3))))
181 (unless (= num2 num3)
184 (do ((el2 el2 (cdr el2)))
186 (return-from sset-union-of-difference changed))
188 (num2 (sset-element-number e)))
191 (setf (cdr prev-el1) (copy-list el2))
192 (return-from sset-union-of-difference t))
193 (setq num3 (sset-element-number (car el3)))
195 (unless (= num2 num3)
196 (let ((new (cons e el1)))
197 (setf (cdr prev-el1) new)
198 (setq prev-el1 new changed t)))
201 (let ((num1 (sset-element-number (car el1))))
204 (let ((new (cons e el1)))
205 (setf (cdr prev-el1) new)
206 (setq prev-el1 new changed t))
207 (shiftf prev-el1 el1 (cdr el1)))
209 (shiftf prev-el1 el1 (cdr el1)))))