X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=tl-list.el;h=4c2a538693fa5d354675231d44ca72b79c7ef1e8;hb=ce5017c15f724ff6eb7d906504d3a495dbe21f9a;hp=8f3c781cba9e866ea5c314f27099e258bf81bcac;hpb=c8d67b7f628b6e02157bbee9018bcf0ef9b4f16d;p=elisp%2Ftm.git

diff --git a/tl-list.el b/tl-list.el
index 8f3c781..4c2a538 100644
--- a/tl-list.el
+++ b/tl-list.el
@@ -1,15 +1,64 @@
 ;;;
-;;; $Id: tl-list.el,v 0.3 1994/07/16 04:08:52 morioka Exp morioka $
+;;; $Id: tl-list.el,v 2.5 1994/12/27 01:49:41 morioka Exp $
 ;;;
 
 (provide 'tl-list)
 
+(require 'tl-str)
+
+
+;;; @ list
+;;;
+
+(defun last (list)
+  "Returns the last element in the list <LIST>.
+[mol's Common Lisp emulating function]"
+  (nthcdr (- (length list) 1) list)
+  )
+
+(defun butlast (x &optional n)
+  "Returns a copy of LIST with the last N elements removed.
+[tl-list.el: imported from cl.el]"
+  (if (and n (<= n 0)) x
+    (nbutlast (copy-sequence x) n)))
+
+(defun nbutlast (x &optional n)
+  "Modifies LIST to remove the last N elements.
+[tl-list.el: imported from cl.el]"
+  (let ((m (length x)))
+    (or n (setq n 1))
+    (and (< n m)
+	 (progn
+	   (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
+	   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
 ;;;
 
 (defun put-alist (item value alist)
-  "\t(put-alist <ITEM> <VALUE> <ALIST>)\n
-If there is a pair whose car is <ITEM>, replace its cdr by <VALUE>.
+  "If there is a pair whose car is <ITEM>, replace its cdr by <VALUE>.
 If there is not such pair, create new pair (<ITEM> . <VALUE>) and
 return new alist whose car is the new pair and cdr is <ALIST>.
 [mol's ELIS emulating function]"
@@ -21,8 +70,7 @@ return new alist whose car is the new pair and cdr is <ALIST>.
     ))
 
 (defun del-alist (item alist)
-  "\t(del-alist <ITEM> <ALIST>)\n
-If there is a pair whose key is <ITEM>, delete it from <ALIST>.
+  "If there is a pair whose key is <ITEM>, delete it from <ALIST>.
 [mol's ELIS emulating function]"
   (if (equal item (car (car alist)))
       (cdr alist)
@@ -40,12 +88,138 @@ If there is a pair whose key is <ITEM>, delete it from <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)))
+	))))