cgit.sxemacs.org Git - packages/blob - xemacs-packages/tm/tl-list.el

   1 ;;; tl-list.el --- utility functions about list
   2
   3 ;; Copyright (C) 1987 .. 1996 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1997 MORIOKA Tomohiko
   5
   6 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;;         Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   8 ;;         Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
   9 ;; Version: $Id: tl-list.el,v 1.1.1.1 1998-01-14 06:27:57 steve Exp $
  10 ;; Keywords: list
  11
  12 ;; This file is part of XEmacs.
  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 (require 'alist)
 296
 297 (defun assoc-value (item alist)
 298   "Return value of <ITEM> from <ALIST>. [tl-list.el]"
 299   (cdr (assoc item alist))
 300   )
 301
 302
 303 ;;; @ poly-apply
 304 ;;;
 305
 306 (defun poly-funcall (functions arg)
 307   (while functions
 308     (setq arg (funcall (car functions) arg)
 309           functions (cdr functions))
 310     )
 311   arg)
 312
 313
 314 ;;; @ end
 315 ;;;
 316
 317 (provide 'tl-list)
 318
 319 (require 'tl-seq)
 320 (require 'tl-atype)
 321
 322 ;;; tl-list.el ends here