X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-range.el;h=2e0a9880a0adb717c760400f0794a685d9f72b44;hb=ebdecdf203f300217a9a7f533dcf43fec5d427b4;hp=89780a6bb7c513ab5fb60fd856facbf539ecd493;hpb=82300762c3419b73fc2e994b14e3d520fe88b0a9;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-range.el b/lisp/gnus-range.el index 89780a6..2e0a988 100644 --- a/lisp/gnus-range.el +++ b/lisp/gnus-range.el @@ -1,5 +1,7 @@ ;;; gnus-range.el --- range and sequence functions for Gnus -;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. + +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -29,6 +31,11 @@ ;;; List and range functions +(defsubst gnus-range-normalize (range) + "Normalize RANGE. +If RANGE is a single range, return (RANGE). Otherwise, return RANGE." + (if (listp (cdr-safe range)) range (list range))) + (defun gnus-last-element (list) "Return last element of LIST." (while (cdr list) @@ -54,6 +61,85 @@ (setq list2 (cdr list2))) list1)) +(defun gnus-range-difference (range1 range2) + "Return the range of elements in RANGE1 that do not appear in RANGE2. +Both ranges must be in ascending order." + (setq range1 (gnus-range-normalize range1)) + (setq range2 (gnus-range-normalize range2)) + (let* ((new-range (cons nil (copy-sequence range1))) + (r new-range) + (safe t)) + (while (cdr r) + (let* ((r1 (cadr r)) + (r2 (car range2)) + (min1 (if (numberp r1) r1 (car r1))) + (max1 (if (numberp r1) r1 (cdr r1))) + (min2 (if (numberp r2) r2 (car r2))) + (max2 (if (numberp r2) r2 (cdr r2)))) + + (cond ((> min1 max1) + ;; Invalid range: may result from overlap condition (below) + ;; remove Invalid range + (setcdr r (cddr r))) + ((and (= min1 max1) + (listp r1)) + ;; Inefficient representation: may result from overlap condition (below) + (setcar (cdr r) min1)) + ((not min2) + ;; All done with range2 + (setq r nil)) + ((< max1 min2) + ;; No overlap: range1 preceeds range2 + (pop r)) + ((< max2 min1) + ;; No overlap: range2 preceeds range1 + (pop range2)) + ((and (<= min2 min1) (<= max1 max2)) + ;; Complete overlap: range1 removed + (setcdr r (cddr r))) + (t + (setcdr r (nconc (list (cons min1 (1- min2)) (cons (1+ max2) max1)) (cddr r))))))) + (cdr new-range))) + + + +;;;###autoload +(defun gnus-sorted-difference (list1 list2) + "Return a list of elements of LIST1 that do not appear in LIST2. +Both lists have to be sorted over <. +The tail of LIST1 is not copied." + (let (out) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setq list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setq out (cons (car list1) out)) + (setq list1 (cdr list1))) + (t + (setq list2 (cdr list2))))) + (nconc (nreverse out) list1))) + +;;;###autoload +(defun gnus-sorted-ndifference (list1 list2) + "Return a list of elements of LIST1 that do not appear in LIST2. +Both lists have to be sorted over <. +LIST1 is modified." + (let* ((top (cons nil list1)) + (prev top)) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setcdr prev (cdr list1)) + (setq list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setq prev list1 + list1 (cdr list1))) + (t + (setq list2 (cdr list2))))) + (cdr top))) + +;;;###autoload (defun gnus-sorted-complement (list1 list2) "Return a list of elements that are in LIST1 or LIST2 but not both. Both lists have to be sorted over <." @@ -72,6 +158,7 @@ Both lists have to be sorted over <." (setq list2 (cdr list2))))) (nconc (nreverse out) (or list1 list2))))) +;;;###autoload (defun gnus-intersection (list1 list2) (let ((result nil)) (while list2 @@ -80,8 +167,10 @@ Both lists have to be sorted over <." (setq list2 (cdr list2))) result)) +;;;###autoload (defun gnus-sorted-intersection (list1 list2) - ;; LIST1 and LIST2 have to be sorted over <. + "Return intersection of LIST1 and LIST2. +LIST1 and LIST2 have to be sorted over <." (let (out) (while (and list1 list2) (cond ((= (car list1) (car list2)) @@ -94,9 +183,13 @@ Both lists have to be sorted over <." (setq list2 (cdr list2))))) (nreverse out))) -(defun gnus-set-sorted-intersection (list1 list2) - ;; LIST1 and LIST2 have to be sorted over <. - ;; This function modifies LIST1. +;;;###autoload +(defalias 'gnus-set-sorted-intersection 'gnus-sorted-nintersection) + +;;;###autoload +(defun gnus-sorted-nintersection (list1 list2) + "Return intersection of LIST1 and LIST2 by modifying cdr pointers of LIST1. +LIST1 and LIST2 have to be sorted over <." (let* ((top (cons nil list1)) (prev top)) (while (and list1 list2) @@ -112,6 +205,55 @@ Both lists have to be sorted over <." (setcdr prev nil) (cdr top))) +;;;###autoload +(defun gnus-sorted-union (list1 list2) + "Return union of LIST1 and LIST2. +LIST1 and LIST2 have to be sorted over <." + (let (out) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setq out (cons (car list1) out) + list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setq out (cons (car list1) out) + list1 (cdr list1))) + (t + (setq out (cons (car list2) out) + list2 (cdr list2))))) + (while list1 + (setq out (cons (car list1) out) + list1 (cdr list1))) + (while list2 + (setq out (cons (car list2) out) + list2 (cdr list2))) + (nreverse out))) + +;;;###autoload +(defun gnus-sorted-nunion (list1 list2) + "Return union of LIST1 and LIST2 by modifying cdr pointers of LIST1. +LIST1 and LIST2 have to be sorted over <." + (let* ((top (cons nil list1)) + (prev top)) + (while (and list1 list2) + (cond ((= (car list1) (car list2)) + (setq prev list1 + list1 (cdr list1) + list2 (cdr list2))) + ((< (car list1) (car list2)) + (setq prev list1 + list1 (cdr list1))) + (t + (setcdr prev (list (car list2))) + (setq prev (cdr prev) + list2 (cdr list2)) + (setcdr prev list1)))) + (while list2 + (setcdr prev (list (car list2))) + (setq prev (cdr prev) + list2 (cdr list2))) + (cdr top))) + (defun gnus-compress-sequence (numbers &optional always-list) "Convert list of numbers to a list of ranges or a single range. If ALWAYS-LIST is non-nil, this function will always release a list of @@ -225,21 +367,27 @@ Note: LIST has to be sorted over `<'." out))) (defun gnus-remove-from-range (range1 range2) - "Return a range that has all articles from RANGE2 removed from -RANGE1. The returned range is always a list." + "Return a range that has all articles from RANGE2 removed from RANGE1. +The returned range is always a list. RANGE2 can also be a unsorted +list of articles. RANGE1 is modified by side effects, RANGE2 is not +modified." (if (or (null range1) (null range2)) range1 - (let (out r1 r2 r1_min r1_max r2_min r2_max) + (let (out r1 r2 r1_min r1_max r2_min r2_max + (range2 (gnus-copy-sequence range2))) (setq range1 (if (listp (cdr range1)) range1 (list range1)) - range2 (if (listp (cdr range2)) range2 (list range2)) + range2 (sort (if (listp (cdr range2)) range2 (list range2)) + (lambda (e1 e2) + (< (if (consp e1) (car e1) e1) + (if (consp e2) (car e2) e2)))) r1 (car range1) - r2 (car range2) + r2 (car range2) r1_min (if (consp r1) (car r1) r1) r1_max (if (consp r1) (cdr r1) r1) r2_min (if (consp r2) (car r2) r2) r2_max (if (consp r2) (cdr r2) r2)) (while (and range1 range2) - (cond ((< r2_max r1_min) ; r2 < r1 + (cond ((< r2_max r1_min) ; r2 < r1 (pop range2) (setq r2 (car range2) r2_min (if (consp r2) (car r2) r2) @@ -260,7 +408,7 @@ RANGE1. The returned range is always a list." (push r1_min out) (push (cons r1_min (1- r2_min)) out)) (pop range2) - (if (< r2_max r1_max) ; finished with r1? + (if (< r2_max r1_max) ; finished with r1? (setq r1_min (1+ r2_max)) (pop range1) (setq r1 (car range1) @@ -277,7 +425,7 @@ RANGE1. The returned range is always a list." (setq r1 (car range1) r1_min (if (consp r1) (car r1) r1) r1_max (if (consp r1) (cdr r1) r1))) - ((< r1_max r2_min) ; r2 > r1 + ((< r1_max r2_min) ; r2 > r1 (pop range1) (if (eq r1_min r1_max) (push r1_min out) @@ -291,7 +439,7 @@ RANGE1. The returned range is always a list." (push (cons r1_min r1_max) out)) (pop range1)) (while range1 - (push (pop range1) out)) + (push (pop range1) out)) (nreverse out)))) (defun gnus-member-of-range (number ranges) @@ -312,9 +460,58 @@ RANGE1. The returned range is always a list." (setq ranges (cdr ranges))) (not not-stop)))) +(defun gnus-list-range-intersection (list ranges) + "Return a list of numbers in LIST that are members of RANGES. +LIST is a sorted list." + (setq ranges (gnus-range-normalize ranges)) + (let (number result) + (while (setq number (pop list)) + (while (and ranges + (if (numberp (car ranges)) + (< (car ranges) number) + (< (cdar ranges) number))) + (setq ranges (cdr ranges))) + (when (and ranges + (if (numberp (car ranges)) + (= (car ranges) number) + ;; (caar ranges) <= number <= (cdar ranges) + (>= number (caar ranges)))) + (push number result))) + (nreverse result))) + +(defalias 'gnus-inverse-list-range-intersection 'gnus-list-range-difference) + +(defun gnus-list-range-difference (list ranges) + "Return a list of numbers in LIST that are not members of RANGES. +LIST is a sorted list." + (setq ranges (gnus-range-normalize ranges)) + (let (number result) + (while (setq number (pop list)) + (while (and ranges + (if (numberp (car ranges)) + (< (car ranges) number) + (< (cdar ranges) number))) + (setq ranges (cdr ranges))) + (when (or (not ranges) + (if (numberp (car ranges)) + (not (= (car ranges) number)) + ;; not ((caar ranges) <= number <= (cdar ranges)) + (< number (caar ranges)))) + (push number result))) + (nreverse result))) + (defun gnus-range-length (range) "Return the length RANGE would have if uncompressed." - (length (gnus-uncompress-range range))) + (cond + ((null range) + 0) + ((not (listp (cdr range))) + (- (cdr range) (car range) -1)) + (t + (let ((sum 0)) + (dolist (x range sum) + (setq sum + (+ sum (if (consp x) (- (cdr x) (car x) -1) 1)))))))) (defun gnus-sublist-p (list sublist) "Test whether all elements in SUBLIST are members of LIST." @@ -326,19 +523,71 @@ RANGE1. The returned range is always a list." sublistp)) (defun gnus-range-add (range1 range2) - "Add RANGE2 to RANGE1 destructively." - (cond - ;; If either are nil, then the job is quite easy. - ((or (null range1) (null range2)) - (or range1 range2)) - (t - ;; I don't like thinking. - (gnus-compress-sequence - (sort - (nconc - (gnus-uncompress-range range1) - (gnus-uncompress-range range2)) - '<))))) + "Add RANGE2 to RANGE1 (nondestructively)." + (unless (listp (cdr range1)) + (setq range1 (list range1))) + (unless (listp (cdr range2)) + (setq range2 (list range2))) + (let ((item1 (pop range1)) + (item2 (pop range2)) + range item selector) + (while (or item1 item2) + (setq selector + (cond + ((null item1) nil) + ((null item2) t) + ((and (numberp item1) (numberp item2)) (< item1 item2)) + ((numberp item1) (< item1 (car item2))) + ((numberp item2) (< (car item1) item2)) + (t (< (car item1) (car item2))))) + (setq item + (or + (let ((tmp1 item) (tmp2 (if selector item1 item2))) + (cond + ((null tmp1) tmp2) + ((null tmp2) tmp1) + ((and (numberp tmp1) (numberp tmp2)) + (cond + ((eq tmp1 tmp2) tmp1) + ((eq (1+ tmp1) tmp2) (cons tmp1 tmp2)) + ((eq (1+ tmp2) tmp1) (cons tmp2 tmp1)) + (t nil))) + ((numberp tmp1) + (cond + ((and (>= tmp1 (car tmp2)) (<= tmp1 (cdr tmp2))) tmp2) + ((eq (1+ tmp1) (car tmp2)) (cons tmp1 (cdr tmp2))) + ((eq (1- tmp1) (cdr tmp2)) (cons (car tmp2) tmp1)) + (t nil))) + ((numberp tmp2) + (cond + ((and (>= tmp2 (car tmp1)) (<= tmp2 (cdr tmp1))) tmp1) + ((eq (1+ tmp2) (car tmp1)) (cons tmp2 (cdr tmp1))) + ((eq (1- tmp2) (cdr tmp1)) (cons (car tmp1) tmp2)) + (t nil))) + ((< (1+ (cdr tmp1)) (car tmp2)) nil) + ((< (1+ (cdr tmp2)) (car tmp1)) nil) + (t (cons (min (car tmp1) (car tmp2)) + (max (cdr tmp1) (cdr tmp2)))))) + (progn + (if item (push item range)) + (if selector item1 item2)))) + (if selector + (setq item1 (pop range1)) + (setq item2 (pop range2)))) + (if item (push item range)) + (reverse range))) + +;;;###autoload +(defun gnus-add-to-sorted-list (list num) + "Add NUM into sorted LIST by side effect." + (let* ((top (cons nil list)) + (prev top)) + (while (and list (< (car list) num)) + (setq prev list + list (cdr list))) + (unless (eq (car list) num) + (setcdr prev (cons num list))) + (cdr top))) (provide 'gnus-range)