;;;
-;;; $Id: tl-list.el,v 0.6 1994/08/28 17:10:12 morioka Exp $
+;;; $Id: tl-list.el,v 2.5 1994/12/27 01:49:41 morioka Exp $
;;;
(provide 'tl-list)
+(require 'tl-str)
+
+
;;; @ list
;;;
x))))
+(defun nth-prev (n ls)
+ "Return elements of LS until N - 1 th. [tl-list.el]"
+ (butlast ls (- (length ls) n))
+ )
+
+(defun except-nth (n ls)
+ "Return elements of LS except N th. [tl-list.el]"
+ (append (nth-prev n ls) (nthcdr (+ 1 n) ls))
+ )
+
+(defun last-element (ls)
+ "Return last element. [tl-list.el]"
+ (car (last ls))
+ )
+
+
+;;; @ set
+;;;
+(fset 'is-member 'member)
+
+
;;; @ alist
;;;
)
alist))))
+(defun set-alist (sym item value)
+ (if (not (boundp sym))
+ (set sym nil)
+ )
+ (set sym (put-alist item value (eval sym)))
+ )
+
;;; @ field
;;;
(defun fetch-field (key alist)
- (assoc key alist))
+ (assoc key alist)
+ )
+
+(defun fetch-field-value (key alist)
+ (cdr (assoc key alist))
+ )
(fset 'put-field 'put-alist)
(fset 'delete-field 'del-alist)
+
+(defun put-fields (tp c)
+ (catch 'tag
+ (let ((r tp) f ret)
+ (while r
+ (setq f (car r))
+ (if (not (if (setq ret (fetch-field (car f) c))
+ (equal (cdr ret)(cdr f))
+ (setq c (cons f c))
+ ))
+ (throw 'tag 'error))
+ (setq r (cdr r))
+ ))
+ c))
+
+
+;;; @ field unifier
+;;;
+
+(defun field-unifier-for-default (a b)
+ (let ((ret
+ (cond ((equal a b) a)
+ ((null (cdr b)) a)
+ ((null (cdr a)) b)
+ )))
+ (if ret
+ (list nil ret nil)
+ )))
+
+(defun field-unify (a b)
+ (let ((sym (symbol-concat "field-unifier-for-" (car a))))
+ (if (not (fboundp sym))
+ (setq sym (function field-unifier-for-default))
+ )
+ (funcall sym a b)
+ ))
+
+
+;;; @ type unifier
+;;;
+
+(defun assoc-unify (class instance)
+ (catch 'tag
+ (let ((cla (copy-alist class))
+ (ins (copy-alist instance))
+ (r class)
+ cell aret ret prev rest)
+ (while r
+ (setq cell (car r))
+ (setq aret (fetch-field (car cell) ins))
+ (if aret
+ (if (setq ret (field-unify cell aret))
+ (progn
+ (if (car ret)
+ (setq prev (put-field (car (car ret))
+ (cdr (car ret))
+ prev))
+ )
+ (if (nth 2 ret)
+ (setq rest (put-field (car (nth 2 ret))
+ (cdr (nth 2 ret))
+ rest))
+ )
+ (setq cla (put-field (car cell)(cdr (nth 1 ret)) cla))
+ (setq ins (delete-field (car cell) ins))
+ )
+ (throw 'tag nil)
+ ))
+ (setq r (cdr r))
+ )
+ (setq r (copy-alist ins))
+ (while r
+ (setq cell (car r))
+ (setq aret (fetch-field (car cell) cla))
+ (if aret
+ (if (setq ret (field-unify cell aret))
+ (progn
+ (if (car ret)
+ (setq prev (put-field (car (car ret))
+ (cdr (car ret))
+ prev))
+ )
+ (if (nth 2 ret)
+ (setq rest (put-field (car (nth 2 ret))
+ (cdr (nth 2 ret))
+ rest))
+ )
+ (setq cla (delete-field (car cell) cla))
+ (setq ins (put-field (car cell)(cdr (nth 1 ret)) ins))
+ )
+ (throw 'tag nil)
+ ))
+ (setq r (cdr r))
+ )
+ (list prev (append cla ins) rest)
+ )))
+
+(defun get-unified-alist (db al)
+ (let ((r db) ret)
+ (catch 'tag
+ (while r
+ (if (setq ret (nth 1 (assoc-unify (car r) al)))
+ (throw 'tag ret)
+ )
+ (setq r (cdr r))
+ ))))
+
+(defun set-atype (sym al)
+ (if (null (boundp sym))
+ (set sym al)
+ (let ((ret (get-unified-alist (eval sym) al)))
+ (if (not (equal ret al))
+ (set sym (cons al (eval sym)))
+ ))))