[Small-cl-src] sparse-set.lisp

[Nathan Froyd]

;;;; sparse-set.lisp -- yet another set abstraction
;;;
;;; Written by Nathan Froyd <froydnj at 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)))
          , at 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