;;;
;;; $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)
  "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]"
  (if (assoc item alist)
      (progn
	(rplacd (assoc item alist) value)
	alist)
    (cons (cons item value) alist)
    ))

(defun del-alist (item 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)
    (let ((pr alist)
	  (r (cdr alist))
	  )
      (catch 'tag
	(while (not (null r))
	  (if (equal item (car (car r)))
	      (progn
		(rplacd pr (cdr r))
		(throw 'tag alist)))
	  (setq pr r)
	  (setq r (cdr r))
	  )
	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)
  )

(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)))
	))))