|
4
|
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
|
