;;;; sparse-set.lisp -- yet another set abstraction ;;; ;;; Written by Nathan Froyd froydnj@cs.rice.edu. ;;; ;;; Sparse sets handle sets of integers over the universe { 0, 1, ... , ;;; N-1 } where N is specified when the set is created. "Great," you ;;; say, "why not use bit vectors?" Many common set operations on bit ;;; vectors are O(N), whereas common set operations on sparse sets are ;;; O(n), where n is the number of elements actually in the set, rather ;;; than the size of the universe. In particular, iterating over the ;;; elements of a sparse set is O(n). In addition, several useful ;;; operations only take constant time, such as clearing the set, ;;; determining whether an element is a member of the set, adding and ;;; deleting members, and choosing an arbitrary element from the set. ;;; ;;; The one downside is that sparse sets are heavyweight objects, ;;; requiring O(N) space per set--the constant is fairly large, eight ;;; bytes or so. ;;; ;;; This implementation is based off of the paper "An Efficient ;;; Representation for Sparse Sets" by Preston Briggs and Linda Torczon. ;;; The maximum number of elements allowed in a sparse set is ;;; MOST-POSITIVE-FIXNUM.

(defpackage #:sparse-set (:use :cl) (:export #:make-sset #:dosset #:memberp #:add-member #:delete-member #:clear #:copy #:pick #:size #:union #:intersection #:difference #:complement) (:shadow cl:intersection cl:union cl:complement))

(in-package #:sparse-set)

(deftype sparse-set-element () '(integer 0 #.most-positive-fixnum)) (deftype sparse-set-array () '(simple-array sparse-set-element (*)))

(defstruct (sset (:constructor %make-sset (universe-size sparse dense)) (:print-function %print-sset)) (sparse (error "A required argument was not provided.") :type sparse-set-array :read-only t) (dense (error "A required argument was not provided.") :type sparse-set-array :read-only t) (universe-size (error "A required argument was not provided.") :type sparse-set-element :read-only t) (size 0 :type sparse-set-element))

(defun %print-sset (sset stream depth) (declare (ignore depth)) (print-unreadable-object (sset stream) (format stream "Sparse-Set ~A/~A" (sset-size sset) (sset-universe-size sset))))

(defun make-sset (size) "Creates a new, empy sparse set holding SIZE elements." (declare (type sparse-set-element size)) (let ((sparse (make-array size :element-type 'sparse-set-element)) (dense (make-array size :element-type 'sparse-set-element))) (%make-sset size sparse dense)))

(eval-when (:load-toplevel :compile-toplevel :execute) (defmacro dosset ((elem sset &optional result) &body body) (let ((index (gensym)) (dense (gensym)) (set (gensym))) `(let* ((,set ,sset) (,dense (sset-dense ,set))) (declare (type sparse-set-array ,dense)) (dotimes (,index (sset-size ,set) ,result) (declare (type fixnum ,index)) (let ((,elem (aref ,dense ,index))) ,@body))))) ) ; EVAL-WHEN

;;; consistency checks (defun check-inside-universe (sset k) (unless (<= 0 k (1- (sset-universe-size sset))) (error 'type-error :datum k :expected-type `(integer 0 ,(1- (sset-universe-size sset))))))

(defun check-compatible-universes (sset1 sset2) (unless (= (sset-universe-size sset1) (sset-universe-size sset2)) (error "~A and ~A do not have the same universe size." sset1 sset2)))

;;; the safe exported versions (defun memberp (sset k) "Determines whether K is a member of SSET." (check-inside-universe sset k) (%memberp sset k))

(defun add-member (sset k) "Adds K to SSET." (check-inside-universe sset k) (%add-member sset k))

(defun delete-member (sset k) "Deletes K from SSET." (check-inside-universe sset k) (%delete-member sset k))

;;; unsafe internal functions without argument checking (defun %memberp (sset k) (let ((a (aref (sset-sparse sset) k))) (and (< a (sset-size sset)) (= (aref (sset-dense sset) a) k))))

(defun %add-member (sset k) (let ((a (aref (sset-sparse sset) k)) (n (sset-size sset))) (when (or (>= a n) (not (= (aref (sset-dense sset) a) k))) (setf (aref (sset-sparse sset) k) n (aref (sset-dense sset) n) k (sset-size sset) (1+ n)))))

(defun %delete-member (sset k) (let ((a (aref (sset-sparse sset) k)) (n (1- (sset-size sset)))) (when (and (<= a n) (= (aref (sset-dense sset) a) k)) (let ((e (aref (sset-dense sset) n))) (setf (sset-size sset) n (aref (sset-dense sset) a) e (aref (sset-sparse sset) e) a)))))

(defun clear (sset) "Removes all elements from SSET." (setf (sset-size sset) 0))

(defun size (sset) "Returns the number of elements in SSET." (sset-size sset))

(defun pick (sset) "Returns an arbitrary member of the set, NIL if the set has no members." (if (zerop (sset-size sset)) nil (aref (sset-dense sset) 0)))

(defun copy (sset) "Creates a duplicate of the given SSET." (let ((sset-copy (%make-sset (sset-universe-size sset) (copy-seq (sset-sparse sset)) (copy-seq (sset-dense sset))))) (setf (sset-size sset-copy) (sset-size sset)) sset-copy))

;;; set operations (defun union (sset1 sset2 &optional sset3) (cond ((eq sset3 t) (sset-union sset1 sset2 sset1)) ((eq sset3 nil) (sset-union sset1 sset2 (make-sset (sset-universe-size sset1)))) (t (sset-union sset1 sset2 sset3))))

(defun sset-union (sset1 sset2 sset-dst) (check-compatible-universes sset1 sset-dst) (check-compatible-universes sset2 sset-dst) (when (and (not (eq sset1 sset-dst)) (not (eq sset2 sset-dst))) (clear sset-dst)) (unless (eq sset1 sset-dst) (dosset (x sset1) (%add-member sset-dst x))) (unless (eq sset2 sset-dst) (dosset (x sset2) (%add-member sset-dst x))) sset-dst)

(defun intersection (sset1 sset2 &optional sset3) (cond ((eq sset3 t) (sset-intersection sset1 sset2 sset1)) ((eq sset3 nil) (sset-intersection sset1 sset2 (make-sset (sset-universe-size sset1)))) (t (sset-intersection sset1 sset2 sset3))))

(defun sset-intersection (sset1 sset2 sset-dst) (check-compatible-universes sset1 sset-dst) (check-compatible-universes sset2 sset-dst) (cond ((eq sset1 sset-dst) (dosset (x sset2 sset-dst) (unless (%memberp sset-dst x) (%delete-member sset-dst x)))) ((eq sset2 sset-dst) (dosset (x sset1 sset-dst) (unless (%memberp sset-dst x) (%delete-member sset-dst x)))) (t (clear sset-dst) (dosset (x sset1 sset-dst) (when (%memberp sset2 x) (%add-member sset-dst x))))))

(defun difference (sset1 sset2 &optional sset3) (cond ((eq sset3 t) (sset-difference sset1 sset2 sset1)) ((eq sset3 nil) (sset-difference sset1 sset2 (make-sset (sset-universe-size sset1)))) (t (sset-difference sset1 sset2 sset3))))

(defun sset-difference (sset1 sset2 sset-dst) (check-compatible-universes sset1 sset-dst) (check-compatible-universes sset2 sset-dst) (cond ((eq sset1 sset-dst) (dosset (x sset2 sset-dst) (when (%memberp sset-dst x) (%delete-member sset-dst x)))) ((eq sset2 sset-dst) ;; kinda ugly, but to maintain reasonable time bounds, this is ;; necessary. generational GC should handle this nicely (let ((temp-set (copy sset-dst))) (sset-difference sset1 temp-set sset2))) (t (clear sset-dst) (dosset (x sset1 sset-dst) (unless (%memberp sset2 x) (%add-member sset-dst x))))))

(defun complement (sset1 &optional sset2) (cond ((eq sset2 t) (sset-complement sset1 sset1)) ((eq sset2 nil) (sset-complement sset1 (make-sset (sset-universe-size sset1)))) (t (sset-complement sset1 sset2))))

(defun sset-complement (sset1 sset2) (check-compatible-universes sset1 sset2) (if (eq sset1 sset2) (dotimes (i (sset-universe-size sset1) sset2) (if (%memberp sset1 i) (%delete-member sset1 i) (%add-member sset1 i))) (dotimes (i (sset-universe-size sset1) sset2) (unless (%memberp sset1 i) (%add-member sset2 i)))))

;;; not sure what to call this function when exported (defun sset-equal (sset1 sset2) (and (= (sset-universe-size sset1) (sset-universe-size sset2)) (= (sset-size sset1) (sset-size sset2)) (dosset (x sset1 t) (unless (%memberp sset2 x) (return-from nil nil)))))