;;;; sparse-set.lisp -- yet another set abstraction
;;;
;;; Written by Nathan Froyd <froydnj(a)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)))))
--
Nathan | From Man's effeminate slackness it begins. --Paradise Lost
