1 ;;; gnus-range.el --- range and sequence functions for Gnus
2 ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
28 (eval-when-compile (require 'cl
))
30 (eval-when-compile (require 'cl
))
32 ;;; List and range functions
34 (defun gnus-last-element (list)
35 "Return last element of LIST."
37 (setq list
(cdr list
)))
40 (defun gnus-copy-sequence (list)
41 "Do a complete, total copy of a list."
44 (if (consp (car list
))
45 (push (gnus-copy-sequence (pop list
)) out
)
46 (push (pop list
) out
)))
48 (nconc (nreverse out
) list
)
51 (defun gnus-set-difference (list1 list2
)
52 "Return a list of elements of LIST1 that do not appear in LIST2."
53 (let ((list1 (copy-sequence list1
)))
55 (setq list1
(delq (car list2
) list1
))
56 (setq list2
(cdr list2
)))
59 (defun gnus-sorted-complement (list1 list2
)
60 "Return a list of elements that are in LIST1 or LIST2 but not both.
61 Both lists have to be sorted over <."
63 (if (or (null list1
) (null list2
))
65 (while (and list1 list2
)
66 (cond ((= (car list1
) (car list2
))
67 (setq list1
(cdr list1
)
69 ((< (car list1
) (car list2
))
70 (setq out
(cons (car list1
) out
))
71 (setq list1
(cdr list1
)))
73 (setq out
(cons (car list2
) out
))
74 (setq list2
(cdr list2
)))))
75 (nconc (nreverse out
) (or list1 list2
)))))
77 (defun gnus-intersection (list1 list2
)
80 (when (memq (car list2
) list1
)
81 (setq result
(cons (car list2
) result
)))
82 (setq list2
(cdr list2
)))
85 (defun gnus-sorted-intersection (list1 list2
)
86 ;; LIST1 and LIST2 have to be sorted over <.
88 (while (and list1 list2
)
89 (cond ((= (car list1
) (car list2
))
90 (setq out
(cons (car list1
) out
)
93 ((< (car list1
) (car list2
))
94 (setq list1
(cdr list1
)))
96 (setq list2
(cdr list2
)))))
99 (defun gnus-set-sorted-intersection (list1 list2
)
100 ;; LIST1 and LIST2 have to be sorted over <.
101 ;; This function modifies LIST1.
102 (let* ((top (cons nil list1
))
104 (while (and list1 list2
)
105 (cond ((= (car list1
) (car list2
))
109 ((< (car list1
) (car list2
))
110 (setcdr prev
(cdr list1
))
111 (setq list1
(cdr list1
)))
113 (setq list2
(cdr list2
)))))
117 (defun gnus-compress-sequence (numbers &optional always-list
)
118 "Convert list of numbers to a list of ranges or a single range.
119 If ALWAYS-LIST is non-nil, this function will always release a list of
121 (let* ((first (car numbers
))
126 (if (not (listp (cdr numbers
)))
129 (cond ((= last
(car numbers
)) nil
) ;Omit duplicated number
130 ((= (1+ last
) (car numbers
)) ;Still in sequence
131 (setq last
(car numbers
)))
132 (t ;End of one sequence
134 (cons (if (= first last
) first
137 (setq first
(car numbers
))
138 (setq last
(car numbers
))))
139 (setq numbers
(cdr numbers
)))
140 (if (and (not always-list
) (null result
))
141 (if (= first last
) (list first
) (cons first last
))
142 (nreverse (cons (if (= first last
) first
(cons first last
))
145 (defalias 'gnus-uncompress-sequence
'gnus-uncompress-range
)
146 (defun gnus-uncompress-range (ranges)
147 "Expand a list of ranges into a list of numbers.
148 RANGES is either a single range on the form `(num . num)' or a list of
150 (let (first last result
)
154 ((not (listp (cdr ranges
)))
155 (setq first
(car ranges
))
156 (setq last
(cdr ranges
))
157 (while (<= first last
)
158 (setq result
(cons first result
))
159 (setq first
(1+ first
)))
163 (if (atom (car ranges
))
164 (when (numberp (car ranges
))
165 (setq result
(cons (car ranges
) result
)))
166 (setq first
(caar ranges
))
167 (setq last
(cdar ranges
))
168 (while (<= first last
)
169 (setq result
(cons first result
))
170 (setq first
(1+ first
))))
171 (setq ranges
(cdr ranges
)))
172 (nreverse result
)))))
174 (defun gnus-add-to-range (ranges list
)
175 "Return a list of ranges that has all articles from both RANGES and LIST.
176 Note: LIST has to be sorted over `<'."
178 (gnus-compress-sequence list t
)
179 (setq list
(copy-sequence list
))
180 (unless (listp (cdr ranges
))
181 (setq ranges
(list ranges
)))
183 ilist lowest highest temp
)
184 (while (and ranges list
)
186 (setq lowest
(or (and (atom (car ranges
)) (car ranges
))
188 (while (and list
(cdr list
) (< (cadr list
) lowest
))
189 (setq list
(cdr list
)))
190 (when (< (car ilist
) lowest
)
192 (setq list
(cdr list
))
194 (setq out
(nconc (gnus-compress-sequence ilist t
) out
)))
195 (setq highest
(or (and (atom (car ranges
)) (car ranges
))
197 (while (and list
(<= (car list
) highest
))
198 (setq list
(cdr list
)))
199 (setq ranges
(cdr ranges
)))
201 (setq out
(nconc (gnus-compress-sequence list t
) out
)))
202 (setq out
(sort out
(lambda (r1 r2
)
203 (< (or (and (atom r1
) r1
) (car r1
))
204 (or (and (atom r2
) r2
) (car r2
))))))
207 (if (atom (car ranges
))
209 (if (atom (cadr ranges
))
210 (when (= (1+ (car ranges
)) (cadr ranges
))
211 (setcar ranges
(cons (car ranges
)
213 (setcdr ranges
(cddr ranges
)))
214 (when (= (1+ (car ranges
)) (caadr ranges
))
215 (setcar (cadr ranges
) (car ranges
))
216 (setcar ranges
(cadr ranges
))
217 (setcdr ranges
(cddr ranges
)))))
219 (if (atom (cadr ranges
))
220 (when (= (1+ (cdar ranges
)) (cadr ranges
))
221 (setcdr (car ranges
) (cadr ranges
))
222 (setcdr ranges
(cddr ranges
)))
223 (when (= (1+ (cdar ranges
)) (caadr ranges
))
224 (setcdr (car ranges
) (cdadr ranges
))
225 (setcdr ranges
(cddr ranges
))))))
226 (setq ranges
(cdr ranges
)))
229 (defun gnus-remove-from-range (ranges list
)
230 "Return a list of ranges that has all articles from LIST removed from RANGES.
231 Note: LIST has to be sorted over `<'."
232 ;; !!! This function shouldn't look like this, but I've got a headache.
233 (gnus-compress-sequence
234 (gnus-sorted-complement
235 (gnus-uncompress-range ranges
) list
)))
237 (defun gnus-member-of-range (number ranges
)
238 (if (not (listp (cdr ranges
)))
239 (and (>= number
(car ranges
))
240 (<= number
(cdr ranges
)))
243 (if (numberp (car ranges
))
244 (>= number
(car ranges
))
245 (>= number
(caar ranges
)))
247 (when (if (numberp (car ranges
))
248 (= number
(car ranges
))
249 (and (>= number
(caar ranges
))
250 (<= number
(cdar ranges
))))
252 (setq ranges
(cdr ranges
)))
255 (defun gnus-range-length (range)
256 "Return the length RANGE would have if uncompressed."
257 (length (gnus-uncompress-range range
)))
259 (defun gnus-sublist-p (list sublist
)
260 "Test whether all elements in SUBLIST are members of LIST."
263 (unless (memq (pop sublist
) list
)
268 (defun gnus-range-add (range1 range2
)
269 "Add RANGE2 to RANGE1 destructively."
271 ;; If either are nil, then the job is quite easy.
272 ((or (null range1
) (null range2
))
275 ;; I don't like thinking.
276 (gnus-compress-sequence
279 (gnus-uncompress-range range1
)
280 (gnus-uncompress-range range2
))
283 (provide 'gnus-range
)
285 ;;; gnus-range.el ends here