;;; SSET-ELEMENT structure. We allow an initial value of NIL to mean
;;; that no ordering has been assigned yet (although an ordering must
;;; be assigned before doing set operations.)
-(defstruct (sset-element (:constructor nil)
- (:copier nil))
+(def!struct (sset-element (:constructor nil)
+ (:copier nil))
(number nil :type (or index null)))
(defstruct (sset (:copier nil))
;;; Destructively add ELEMENT to SET. If ELEMENT was not in the set,
;;; then we return true, otherwise we return false.
-(declaim (ftype (function (sset-element sset) boolean) sset-adjoin))
+(declaim (ftype (sfunction (sset-element sset) boolean) sset-adjoin))
(defun sset-adjoin (element set)
(let ((number (sset-element-number element))
- (elements (sset-elements set)))
+ (elements (sset-elements set)))
(do ((prev elements current)
- (current (cdr elements) (cdr current)))
- ((null current)
- (setf (cdr prev) (list element))
- t)
+ (current (cdr elements) (cdr current)))
+ ((null current)
+ (setf (cdr prev) (list element))
+ t)
(let ((el (car current)))
- (when (>= (sset-element-number el) number)
- (when (eq el element)
- (return nil))
- (setf (cdr prev) (cons element current))
- (return t))))))
+ (when (>= (sset-element-number el) number)
+ (when (eq el element)
+ (return nil))
+ (setf (cdr prev) (cons element current))
+ (return t))))))
;;; Destructively remove ELEMENT from SET. If element was in the set,
;;; then return true, otherwise return false.
-(declaim (ftype (function (sset-element sset) boolean) sset-delete))
+(declaim (ftype (sfunction (sset-element sset) boolean) sset-delete))
(defun sset-delete (element set)
(let ((elements (sset-elements set)))
(do ((prev elements current)
- (current (cdr elements) (cdr current)))
- ((null current) nil)
+ (current (cdr elements) (cdr current)))
+ ((null current) nil)
(when (eq (car current) element)
- (setf (cdr prev) (cdr current))
- (return t)))))
+ (setf (cdr prev) (cdr current))
+ (return t)))))
;;; Return true if ELEMENT is in SET, false otherwise.
-(declaim (ftype (function (sset-element sset) boolean) sset-member))
+(declaim (ftype (sfunction (sset-element sset) boolean) sset-member))
(defun sset-member (element set)
(declare (inline member))
(not (null (member element (cdr (sset-elements set)) :test #'eq))))
-(declaim (ftype (function (sset sset) boolean) sset=))
+(declaim (ftype (sfunction (sset sset) boolean) sset=))
(defun sset= (set1 set2)
(equal (sset-elements set1) (sset-elements set2)))
;;; Return true if SET contains no elements, false otherwise.
-(declaim (ftype (function (sset) boolean) sset-empty))
+(declaim (ftype (sfunction (sset) boolean) sset-empty))
(defun sset-empty (set)
(null (cdr (sset-elements set))))
;;; Return a new copy of SET.
-(declaim (ftype (function (sset) sset) copy-sset))
+(declaim (ftype (sfunction (sset) sset) copy-sset))
(defun copy-sset (set)
(make-sset :elements (copy-list (sset-elements set))))
;;; Perform the appropriate set operation on SET1 and SET2 by
;;; destructively modifying SET1. We return true if SET1 was modified,
;;; false otherwise.
-(declaim (ftype (function (sset sset) boolean) sset-union sset-intersection
- sset-difference))
+(declaim (ftype (sfunction (sset sset) boolean) sset-union sset-intersection
+ sset-difference))
(defun sset-union (set1 set2)
(let* ((prev-el1 (sset-elements set1))
- (el1 (cdr prev-el1))
- (changed nil))
+ (el1 (cdr prev-el1))
+ (changed nil))
(do ((el2 (cdr (sset-elements set2)) (cdr el2)))
- ((null el2) changed)
+ ((null el2) changed)
(let* ((e (car el2))
- (num2 (sset-element-number e)))
- (loop
- (when (null el1)
- (setf (cdr prev-el1) (copy-list el2))
- (return-from sset-union t))
- (let ((num1 (sset-element-number (car el1))))
- (when (>= num1 num2)
- (if (> num1 num2)
- (let ((new (cons e el1)))
- (setf (cdr prev-el1) new)
- (setq prev-el1 new
- changed t))
- (shiftf prev-el1 el1 (cdr el1)))
- (return))
- (shiftf prev-el1 el1 (cdr el1))))))))
+ (num2 (sset-element-number e)))
+ (loop
+ (when (null el1)
+ (setf (cdr prev-el1) (copy-list el2))
+ (return-from sset-union t))
+ (let ((num1 (sset-element-number (car el1))))
+ (when (>= num1 num2)
+ (if (> num1 num2)
+ (let ((new (cons e el1)))
+ (setf (cdr prev-el1) new)
+ (setq prev-el1 new
+ changed t))
+ (shiftf prev-el1 el1 (cdr el1)))
+ (return))
+ (shiftf prev-el1 el1 (cdr el1))))))))
(defun sset-intersection (set1 set2)
(let* ((prev-el1 (sset-elements set1))
- (el1 (cdr prev-el1))
- (changed nil))
+ (el1 (cdr prev-el1))
+ (changed nil))
(do ((el2 (cdr (sset-elements set2)) (cdr el2)))
- ((null el2)
- (cond (el1
- (setf (cdr prev-el1) nil)
- t)
- (t changed)))
+ ((null el2)
+ (cond (el1
+ (setf (cdr prev-el1) nil)
+ t)
+ (t changed)))
(let ((num2 (sset-element-number (car el2))))
- (loop
- (when (null el1)
- (return-from sset-intersection changed))
- (let ((num1 (sset-element-number (car el1))))
- (when (>= num1 num2)
- (when (= num1 num2)
- (shiftf prev-el1 el1 (cdr el1)))
- (return))
- (pop el1)
- (setf (cdr prev-el1) el1)
- (setq changed t)))))))
+ (loop
+ (when (null el1)
+ (return-from sset-intersection changed))
+ (let ((num1 (sset-element-number (car el1))))
+ (when (>= num1 num2)
+ (when (= num1 num2)
+ (shiftf prev-el1 el1 (cdr el1)))
+ (return))
+ (pop el1)
+ (setf (cdr prev-el1) el1)
+ (setq changed t)))))))
(defun sset-difference (set1 set2)
(let* ((prev-el1 (sset-elements set1))
- (el1 (cdr prev-el1))
- (changed nil))
+ (el1 (cdr prev-el1))
+ (changed nil))
(do ((el2 (cdr (sset-elements set2)) (cdr el2)))
- ((null el2) changed)
+ ((null el2) changed)
(let ((num2 (sset-element-number (car el2))))
- (loop
- (when (null el1)
- (return-from sset-difference changed))
- (let ((num1 (sset-element-number (car el1))))
- (when (>= num1 num2)
- (when (= num1 num2)
- (pop el1)
- (setf (cdr prev-el1) el1)
- (setq changed t))
- (return))
- (shiftf prev-el1 el1 (cdr el1))))))))
+ (loop
+ (when (null el1)
+ (return-from sset-difference changed))
+ (let ((num1 (sset-element-number (car el1))))
+ (when (>= num1 num2)
+ (when (= num1 num2)
+ (pop el1)
+ (setf (cdr prev-el1) el1)
+ (setq changed t))
+ (return))
+ (shiftf prev-el1 el1 (cdr el1))))))))
;;; Destructively modify SET1 to include its union with the difference
;;; of SET2 and SET3. We return true if SET1 was modified, false
;;; otherwise.
-(declaim (ftype (function (sset sset sset) boolean) sset-union-of-difference))
+(declaim (ftype (sfunction (sset sset sset) boolean) sset-union-of-difference))
(defun sset-union-of-difference (set1 set2 set3)
(let* ((prev-el1 (sset-elements set1))
- (el1 (cdr prev-el1))
- (el3 (cdr (sset-elements set3)))
- (changed nil))
+ (el1 (cdr prev-el1))
+ (el3 (cdr (sset-elements set3)))
+ (changed nil))
(do ((el2 (cdr (sset-elements set2)) (cdr el2)))
- ((null el2) changed)
+ ((null el2) changed)
(let* ((e (car el2))
- (num2 (sset-element-number e)))
- (loop
- (when (null el3)
- (loop
- (when (null el1)
- (setf (cdr prev-el1) (copy-list el2))
- (return-from sset-union-of-difference t))
- (let ((num1 (sset-element-number (car el1))))
- (when (>= num1 num2)
- (if (> num1 num2)
- (let ((new (cons e el1)))
- (setf (cdr prev-el1) new)
- (setq prev-el1 new changed t))
- (shiftf prev-el1 el1 (cdr el1)))
- (return))
- (shiftf prev-el1 el1 (cdr el1))))
- (return))
- (let ((num3 (sset-element-number (car el3))))
- (when (<= num2 num3)
- (unless (= num2 num3)
- (loop
- (when (null el1)
- (do ((el2 el2 (cdr el2)))
- ((null el2)
- (return-from sset-union-of-difference changed))
- (let* ((e (car el2))
- (num2 (sset-element-number e)))
- (loop
- (when (null el3)
- (setf (cdr prev-el1) (copy-list el2))
- (return-from sset-union-of-difference t))
- (setq num3 (sset-element-number (car el3)))
- (when (<= num2 num3)
- (unless (= num2 num3)
- (let ((new (cons e el1)))
- (setf (cdr prev-el1) new)
- (setq prev-el1 new changed t)))
- (return))
- (pop el3)))))
- (let ((num1 (sset-element-number (car el1))))
- (when (>= num1 num2)
- (if (> num1 num2)
- (let ((new (cons e el1)))
- (setf (cdr prev-el1) new)
- (setq prev-el1 new changed t))
- (shiftf prev-el1 el1 (cdr el1)))
- (return))
- (shiftf prev-el1 el1 (cdr el1)))))
- (return)))
- (pop el3))))))
+ (num2 (sset-element-number e)))
+ (loop
+ (when (null el3)
+ (loop
+ (when (null el1)
+ (setf (cdr prev-el1) (copy-list el2))
+ (return-from sset-union-of-difference t))
+ (let ((num1 (sset-element-number (car el1))))
+ (when (>= num1 num2)
+ (if (> num1 num2)
+ (let ((new (cons e el1)))
+ (setf (cdr prev-el1) new)
+ (setq prev-el1 new changed t))
+ (shiftf prev-el1 el1 (cdr el1)))
+ (return))
+ (shiftf prev-el1 el1 (cdr el1))))
+ (return))
+ (let ((num3 (sset-element-number (car el3))))
+ (when (<= num2 num3)
+ (unless (= num2 num3)
+ (loop
+ (when (null el1)
+ (do ((el2 el2 (cdr el2)))
+ ((null el2)
+ (return-from sset-union-of-difference changed))
+ (let* ((e (car el2))
+ (num2 (sset-element-number e)))
+ (loop
+ (when (null el3)
+ (setf (cdr prev-el1) (copy-list el2))
+ (return-from sset-union-of-difference t))
+ (setq num3 (sset-element-number (car el3)))
+ (when (<= num2 num3)
+ (unless (= num2 num3)
+ (let ((new (cons e el1)))
+ (setf (cdr prev-el1) new)
+ (setq prev-el1 new changed t)))
+ (return))
+ (pop el3)))))
+ (let ((num1 (sset-element-number (car el1))))
+ (when (>= num1 num2)
+ (if (> num1 num2)
+ (let ((new (cons e el1)))
+ (setf (cdr prev-el1) new)
+ (setq prev-el1 new changed t))
+ (shiftf prev-el1 el1 (cdr el1)))
+ (return))
+ (shiftf prev-el1 el1 (cdr el1)))))
+ (return)))
+ (pop el3))))))
projects / sbcl.git / blobdiff