Mercurial > hg > xemacs-beta

comparison lisp/tl/tl-list.el @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents
children 4b173ad71786
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
1 ;;; tl-list.el --- utility functions about list
2
3 ;; Copyright (C) 1987 .. 1996 Free Software Foundation, Inc.
4
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
7 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
8 ;; Version:
9 ;; $Id: tl-list.el,v 1.1.1.1 1996/12/18 03:55:31 steve Exp $
10 ;; Keywords: list
11
12 ;; This file is part of tl (Tiny Library).
13
14 ;; This program is free software; you can redistribute it and/or
15 ;; modify it under the terms of the GNU General Public License as
16 ;; published by the Free Software Foundation; either version 2, or (at
17 ;; your option) any later version.
18
19 ;; This program is distributed in the hope that it will be useful, but
20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
22 ;; General Public License for more details.
23
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with This program; see the file COPYING. If not, write to
26 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
27 ;; Boston, MA 02111-1307, USA.
28
29 ;;; Code:
30
31 (require 'file-detect)
32
33 (cond ((file-installed-p "cl-seq.elc")
34 (require 'cless)
35 )
36 (t
37 ;; New cl is not exist (Don't use old cl.el)
38
39 (defun last (ls &optional n)
40 "Returns the last element in list LS.
41 With optional argument N, returns Nth-to-last link (default 1).
42 \[tl-list.el; tomo's Common Lisp emulating function]"
43 (nthcdr (- (length ls) (or n 1)) ls)
44 )
45
46 ;; imported from cl.el
47 (defun list* (arg &rest rest)
48 "Return a new list with specified args as elements, cons'd to last arg.
49 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
50 `(cons A (cons B (cons C D)))'."
51 (cond ((not rest) arg)
52 ((not (cdr rest)) (cons arg (car rest)))
53 (t (let* ((n (length rest))
54 (copy (copy-sequence rest))
55 (last (nthcdr (- n 2) copy)))
56 (setcdr last (car (cdr last)))
57 (cons arg copy)))))
58
59 (defconst :test ':test)
60
61 (defun MEMBER (elt list &rest keywords)
62 (let ((test
63 (or
64 (let ((ret (memq ':test keywords)))
65 (car (cdr ret))
66 )
67 'eq)))
68 (cond ((eq test 'eq)
69 (memq elt list)
70 )
71 ((eq test 'equal)
72 (member elt list)
73 )
74 (t
75 (catch 'tag
76 (while list
77 (let* ((cell (car list))
78 (ret (funcall test elt cell))
79 )
80 (if ret
81 (throw 'tag list)
82 ))
83 (setq list (cdr list))
84 ))))))
85
86 (defun ASSOC (key alist &rest keywords)
87 (let ((test
88 (or
89 (let ((ret (memq ':test keywords)))
90 (car (cdr ret))
91 )
92 'eq)))
93 (cond ((eq test 'eq)
94 (assq key alist)
95 )
96 ((eq test 'equal)
97 (assoc key alist)
98 )
99 (t
100 (catch 'tag
101 (while alist
102 (let* ((cell (car alist))
103 (ret (funcall test key (car cell)))
104 )
105 (if ret
106 (throw 'tag cell)
107 ))
108 (setq alist (cdr alist))
109 ))))))
110 ))
111
112 (autoload 'compress-sorted-numbers "range")
113 (autoload 'expand-range "range")
114 (autoload 'member-of-range "range")
115
116
117 ;;; @ list
118 ;;;
119
120 (defun nnth-prev (n ls)
121 "Modify list LS to remove elements after N th. [tl-list.el]"
122 (and (> n 0)
123 (let ((cell (nthcdr (1- n) ls)))
124 (if (consp cell)
125 (setcdr cell nil)
126 )
127 ls)))
128
129 (defun nth-prev (n ls)
130 "Return the first N elements. [tl-list.el]"
131 (let (dest)
132 (while (and (> n 0) ls)
133 (setq dest (cons (car ls) dest))
134 (setq ls (cdr ls)
135 n (1- n))
136 )
137 (nreverse dest)
138 ))
139
140 (defun nexcept-nth (n ls)
141 "Modify list LS to remove N th element. [tl-list.el]"
142 (cond ((< n 0) ls)
143 ((= n 0) (cdr ls))
144 (t
145 (let ((cell (nthcdr (1- n) ls)))
146 (if (consp cell)
147 (setcdr cell (cdr (cdr cell)))
148 ))
149 ls)))
150
151 (defun except-nth (n ls)
152 "Return elements of LS except N th. [tl-list.el]"
153 (if (< n 0)
154 ls
155 (let (dest)
156 (while (and (> n 0) ls)
157 (setq dest (cons (car ls) dest))
158 (setq ls (cdr ls)
159 n (1- n))
160 )
161 (setq ls (cdr ls))
162 (while dest
163 (setq ls (cons (car dest) ls))
164 (setq dest (cdr dest))
165 )
166 ls)))
167
168 (defun last-element (ls)
169 "Return last element. [tl-list.el]"
170 (car (last ls))
171 )
172
173 (defun cons-element (elt ls)
174 "Cons ELT to LS if ELT is not nil. [tl-list.el]"
175 (if elt
176 (cons elt ls)
177 ls))
178
179 (defun cons-if (elt ls)
180 "Cons ELT to LS if LS is not nil, otherwise return nil. [tl-list.el]"
181 (if ls
182 (cons elt ls)
183 ))
184
185 (defun append-element (ls elt)
186 "Append ELT to last of LS if ELT is not nil. [tl-list.el]"
187 (if elt
188 (append ls (list elt))
189 ls))
190
191
192 ;;; @ permutation and combination
193 ;;;
194
195 (defun every-combination (prev &rest rest)
196 "Every arguments are OR list,
197 and return list of all possible sequence. [tl-list.el]"
198 (if (null prev)
199 (setq prev '(nil))
200 )
201 (cond ((null rest)
202 (mapcar 'list prev)
203 )
204 (t (let (dest
205 (pr prev)
206 (rest-mixed (apply 'every-combination rest))
207 )
208 (while pr
209 (let ((rr rest-mixed))
210 (while rr
211 (setq dest (cons (cons (car pr)(car rr)) dest))
212 (setq rr (cdr rr))
213 ))
214 (setq pr (cdr pr))
215 )
216 (nreverse dest)
217 ))
218 ))
219
220 (defun permute (&rest ls)
221 "Return permutation of arguments as list. [tl-list.el]"
222 (let ((len (length ls)))
223 (if (<= len 1)
224 (list ls)
225 (let (prev
226 (rest ls)
227 c dest)
228 (while rest
229 (setq c (car rest))
230 (setq rest (cdr rest))
231 (setq dest
232 (nconc dest
233 (mapcar (function
234 (lambda (s)
235 (cons c s)
236 ))
237 (apply (function permute)
238 (append prev rest))
239 )))
240 (setq prev (nconc prev (list c)))
241 )
242 dest)
243 )))
244
245
246 ;;; @ index
247 ;;;
248
249 (defun index (start end &optional inc)
250 "Return list of numbers from START to END.
251 Element of the list increases by INC (default value is 1).
252 \[tl-list.el; ELIS compatible function]"
253 (or inc
254 (setq inc 1)
255 )
256 (let ((pred (if (>= inc 0)
257 (function <=)
258 (function >=)
259 ))
260 (i start)
261 dest)
262 (while (funcall pred i end)
263 (setq dest (cons i dest))
264 (setq i (+ i inc))
265 )
266 (nreverse dest)
267 ))
268
269
270 ;;; @ set
271 ;;;
272
273 (defun map-union (func ls)
274 "Apply FUNC to each element of LS.
275 And return union of each result returned by FUNC. [tl-list.el]"
276 (let ((r ls) ret rc dest)
277 (while r
278 (setq ret (funcall func (car r)))
279 (while ret
280 (setq rc (car ret))
281 (or (member rc dest)
282 (setq dest (cons rc dest))
283 )
284 (setq ret (cdr ret))
285 )
286 (setq r (cdr r))
287 )
288 (nreverse dest)
289 ))
290
291
292 ;;; @ alist
293 ;;;
294
295 (defun put-alist (item value alist)
296 "Modify ALIST to set VALUE to ITEM.
297 If there is a pair whose car is ITEM, replace its cdr by VALUE.
298 If there is not such pair, create new pair (ITEM . VALUE) and
299 return new alist whose car is the new pair and cdr is ALIST.
300 \[tl-list.el; tomo's ELIS like function]"
301 (let ((pair (assoc item alist)))
302 (if pair
303 (progn
304 (setcdr pair value)
305 alist)
306 (cons (cons item value) alist)
307 )))
308
309 (defun del-alist (item alist)
310 "If there is a pair whose key is <ITEM>, delete it from <ALIST>.
311 \[tl-list.el; mol's ELIS emulating function]"
312 (if (equal item (car (car alist)))
313 (cdr alist)
314 (let ((pr alist)
315 (r (cdr alist))
316 )
317 (catch 'tag
318 (while (not (null r))
319 (if (equal item (car (car r)))
320 (progn
321 (rplacd pr (cdr r))
322 (throw 'tag alist)))
323 (setq pr r)
324 (setq r (cdr r))
325 )
326 alist))))
327
328 (defun assoc-value (item alist)
329 "Return value of <ITEM> from <ALIST>. [tl-list.el]"
330 (cdr (assoc item alist))
331 )
332
333 (defun set-alist (symbol item value)
334 "Modify a alist indicated by SYMBOL to set VALUE to ITEM. [tl-list.el]"
335 (or (boundp symbol)
336 (set symbol nil)
337 )
338 (set symbol (put-alist item value (symbol-value symbol)))
339 )
340
341 (defun remove-alist (symbol item)
342 "Remove ITEM from the alist indicated by SYMBOL. [tl-list.el]"
343 (and (boundp symbol)
344 (set symbol (del-alist item (symbol-value symbol)))
345 ))
346
347 (defun modify-alist (modifier default)
348 "Modify alist DEFAULT into alist MODIFIER. [tl-list.el]"
349 (mapcar (function
350 (lambda (as)
351 (setq default (put-alist (car as)(cdr as) default))
352 ))
353 modifier)
354 default)
355
356 (defun set-modified-alist (sym modifier)
357 "Modify a value of a symbol SYM into alist MODIFIER.
358 The symbol SYM should be alist. If it is not bound,
359 its value regard as nil. [tl-list.el]"
360 (if (not (boundp sym))
361 (set sym nil)
362 )
363 (set sym (modify-alist modifier (eval sym)))
364 )
365
366
367 ;;; @ poly-apply
368 ;;;
369
370 (defun poly-funcall (functions arg)
371 (while functions
372 (setq arg (funcall (car functions) arg)
373 functions (cdr functions))
374 )
375 arg)
376
377
378 ;;; @ end
379 ;;;
380
381 (provide 'tl-list)
382
383 (require 'tl-seq)
384 (require 'tl-atype)
385
386 ;;; tl-list.el ends here