tl-list.el

   1 ;;;
   2 ;;; $Id: tl-list.el,v 2.5 1994/12/27 01:49:41 morioka Exp $
   3 ;;;
   4
   5 (provide 'tl-list)
   6
   7 (require 'tl-str)
   8
   9
  10 ;;; @ list
  11 ;;;
  12
  13 (defun last (list)
  14   "Returns the last element in the list <LIST>.
  15 [mol's Common Lisp emulating function]"
  16   (nthcdr (- (length list) 1) list)
  17   )
  18
  19 (defun butlast (x &optional n)
  20   "Returns a copy of LIST with the last N elements removed.
  21 [tl-list.el: imported from cl.el]"
  22   (if (and n (<= n 0)) x
  23     (nbutlast (copy-sequence x) n)))
  24
  25 (defun nbutlast (x &optional n)
  26   "Modifies LIST to remove the last N elements.
  27 [tl-list.el: imported from cl.el]"
  28   (let ((m (length x)))
  29     (or n (setq n 1))
  30     (and (< n m)
  31          (progn
  32            (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
  33            x))))
  34
  35
  36 (defun nth-prev (n ls)
  37   "Return elements of LS until N - 1 th. [tl-list.el]"
  38   (butlast ls (- (length ls) n))
  39   )
  40
  41 (defun except-nth (n ls)
  42   "Return elements of LS except N th. [tl-list.el]"
  43   (append (nth-prev n ls) (nthcdr (+ 1 n) ls))
  44   )
  45
  46 (defun last-element (ls)
  47   "Return last element. [tl-list.el]"
  48   (car (last ls))
  49   )
  50
  51
  52 ;;; @ set
  53 ;;;
  54 (fset 'is-member 'member)
  55
  56
  57 ;;; @ alist
  58 ;;;
  59
  60 (defun put-alist (item value alist)
  61   "If there is a pair whose car is <ITEM>, replace its cdr by <VALUE>.
  62 If there is not such pair, create new pair (<ITEM> . <VALUE>) and
  63 return new alist whose car is the new pair and cdr is <ALIST>.
  64 [mol's ELIS emulating function]"
  65   (if (assoc item alist)
  66       (progn
  67         (rplacd (assoc item alist) value)
  68         alist)
  69     (cons (cons item value) alist)
  70     ))
  71
  72 (defun del-alist (item alist)
  73   "If there is a pair whose key is <ITEM>, delete it from <ALIST>.
  74 [mol's ELIS emulating function]"
  75   (if (equal item (car (car alist)))
  76       (cdr alist)
  77     (let ((pr alist)
  78           (r (cdr alist))
  79           )
  80       (catch 'tag
  81         (while (not (null r))
  82           (if (equal item (car (car r)))
  83               (progn
  84                 (rplacd pr (cdr r))
  85                 (throw 'tag alist)))
  86           (setq pr r)
  87           (setq r (cdr r))
  88           )
  89         alist))))
  90
  91 (defun set-alist (sym item value)
  92   (if (not (boundp sym))
  93       (set sym nil)
  94     )
  95   (set sym (put-alist item value (eval sym)))
  96   )
  97
  98
  99 ;;; @ field
 100 ;;;
 101
 102 (defun fetch-field (key alist)
 103   (assoc key alist)
 104   )
 105
 106 (defun fetch-field-value (key alist)
 107   (cdr (assoc key alist))
 108   )
 109
 110 (fset 'put-field 'put-alist)
 111 (fset 'delete-field 'del-alist)
 112
 113 (defun put-fields (tp c)
 114   (catch 'tag
 115     (let ((r tp) f ret)
 116       (while r
 117         (setq f (car r))
 118         (if (not (if (setq ret (fetch-field (car f) c))
 119                      (equal (cdr ret)(cdr f))
 120                    (setq c (cons f c))
 121                    ))
 122             (throw 'tag 'error))
 123         (setq r (cdr r))
 124         ))
 125     c))
 126
 127
 128 ;;; @ field unifier
 129 ;;;
 130
 131 (defun field-unifier-for-default (a b)
 132   (let ((ret
 133          (cond ((equal a b)    a)
 134                ((null (cdr b)) a)
 135                ((null (cdr a)) b)
 136                )))
 137     (if ret
 138         (list nil ret nil)
 139       )))
 140
 141 (defun field-unify (a b)
 142   (let ((sym (symbol-concat "field-unifier-for-" (car a))))
 143     (if (not (fboundp sym))
 144         (setq sym (function field-unifier-for-default))
 145       )
 146     (funcall sym a b)
 147     ))
 148
 149
 150 ;;; @ type unifier
 151 ;;;
 152
 153 (defun assoc-unify (class instance)
 154   (catch 'tag
 155     (let ((cla (copy-alist class))
 156           (ins (copy-alist instance))
 157           (r class)
 158           cell aret ret prev rest)
 159       (while r
 160         (setq cell (car r))
 161         (setq aret (fetch-field (car cell) ins))
 162         (if aret
 163             (if (setq ret (field-unify cell aret))
 164                 (progn
 165                   (if (car ret)
 166                       (setq prev (put-field (car (car ret))
 167                                             (cdr (car ret))
 168                                             prev))
 169                     )
 170                   (if (nth 2 ret)
 171                       (setq rest (put-field (car (nth 2 ret))
 172                                             (cdr (nth 2 ret))
 173                                             rest))
 174                     )
 175                   (setq cla (put-field (car cell)(cdr (nth 1 ret)) cla))
 176                   (setq ins (delete-field (car cell) ins))
 177                   )
 178               (throw 'tag nil)
 179               ))
 180         (setq r (cdr r))
 181         )
 182       (setq r (copy-alist ins))
 183       (while r
 184         (setq cell (car r))
 185         (setq aret (fetch-field (car cell) cla))
 186         (if aret
 187             (if (setq ret (field-unify cell aret))
 188                 (progn
 189                   (if (car ret)
 190                       (setq prev (put-field (car (car ret))
 191                                             (cdr (car ret))
 192                                             prev))
 193                     )
 194                   (if (nth 2 ret)
 195                       (setq rest (put-field (car (nth 2 ret))
 196                                             (cdr (nth 2 ret))
 197                                             rest))
 198                     )
 199                   (setq cla (delete-field (car cell) cla))
 200                   (setq ins (put-field (car cell)(cdr (nth 1 ret)) ins))
 201                   )
 202               (throw 'tag nil)
 203               ))
 204         (setq r (cdr r))
 205         )
 206       (list prev (append cla ins) rest)
 207       )))
 208
 209 (defun get-unified-alist (db al)
 210   (let ((r db) ret)
 211     (catch 'tag
 212       (while r
 213         (if (setq ret (nth 1 (assoc-unify (car r) al)))
 214             (throw 'tag ret)
 215           )
 216         (setq r (cdr r))
 217         ))))
 218
 219 (defun set-atype (sym al)
 220   (if (null (boundp sym))
 221       (set sym al)
 222     (let ((ret (get-unified-alist (eval sym) al)))
 223       (if (not (equal ret al))
 224           (set sym (cons al (eval sym)))
 225         ))))