;;;
;;;  Production System
;;;
(defun extra*conditions (l)
  (cond ((null l)
         nil)
        ((eq '-> (car l)) nil)
        (t (cons (car l)
                 (extra*conditions (cdr l))))))

(defun all*satisfied (conditions bindlist)
  (let ((condition nil))
(setq *environment* bindlist)
(cond
   ((null conditions)
    t)
   (t (setq condition (car conditions))
      (cond ((iffunction (car condition))
    	     (pred*satisfied condition bindlist conditions))
   	    (t 
	     (pat*satisfied condition *wms* bindlist conditions)))))))

(defun pat*satisfied (pat wm binds conditions)
  (cond
   ((null wm)
    nil)
   ((and (match pat (car wm) binds)
	 (all*satisfied (cdr conditions)
			*binds*))
     t)
   (t (pat*satisfied pat
		     (cdr wm)
		     binds conditions))))

(defun pred*satisfied (pred binds conditions)
  (cond ((eval (eval*able pred)
	       )
	 (all*satisfied (cdr conditions)
		*binds*))
	(t nil)))

(defun match (pat1 pat2 binds)
  (cond ((null pat1)
	 (null pat2))
	((atom pat1)
	 (cond ((eq pat1 pat2)
		t)
	       ((ifvariable pat1)
		(consistent (cons pat1 pat2) binds))
	       (t nil)))
	((atom pat2)
	 nil)
	(t (setq *binds* binds)
	   (and (match (car pat1)
		       (car pat2) 
		       binds)
		(match (cdr pat1)
		       (cdr pat2) 
		       binds)))))

(defun consistent (pair binds)
  (cond ((member pair binds)
	 t)
	((assoc (car pair)
		binds)
	 nil)
	(t (setq *binds* (cons pair binds)))))

(defun eval*able (x)
  (cond ((null x)
	 nil)
	((atom (car x))
	 (cond ((iffunction (car x))
		(cons (car x)
		      (eval*able (cdr x))))
	       ((ifvariable (car x))
		(set (car x) (cdr (assoc (car x) *environment*)))
		(cons (car x)
		      (eval*able (cdr x))))
	       (t (cons (list 'quote
			      (car x))
			(eval*able (cdr x))))))
	(t (cons (cond ((iffunction (caar x))
			(eval*able (car x)))
		       (t (cons 'list
				(eval*able (car x)))))
		 (eval*able (cdr x))))))

(defun iffunction (x)
  (cond ((numberp x) nil)
	((and (atom x)
         (equal (subseq (symbol-name x) 0 1)
	   "*")))))

(defun ifvariable (x)
  (cond ((numberp x) nil)
        ((and (atom x)
         (equal (subseq (symbol-name x) 0 1)
	      "=")))))

(defun extra*actions (l)
  (cond ((eq '->
	     (car l))
	 (cdr l))
	(t (extra*actions (cdr l)))))
 
(defun execute*actions (actions)
  (cond ((null actions)
         nil)
	(t (eval (eval*able (car actions)))
	   (execute*actions (cdr actions)))))

(defun *deposit (pat)
  (setq *wms* (cons pat (*remove pat *wms*))))

(defun *delete (pat)
  (setq *wms* (*remove pat *wms*)))

(defun *remove (l from)
  (cond ((null from)
	 nil)
	((equal(car from)
		l)
	 (cdr from))
	(t (cons (car from)
		 (*remove l (cdr from))))))

(defun *halt nil
  (setq *haltflag* t))

(defun execute (pds dis-flag)
  (let ((production nil)
	(condition nil)
	(action nil)
        (production-number nil))
(cond ((null pds)
	 nil)
      (t (setq production (cdar pds))
	 (setq production-number (caar pds))
         (setq condition (extra*conditions production))
	 (cond 	((all*satisfied condition nil)
	         (setq action (extra*actions production))
	         (case dis-flag
		  (1 (terpri)
		     (prin1 '***fire*)
		     (prin1 production-number)
	             (terpri)
	             (execute*actions action)
	             (terpri)
	             (print *wms*)
	             (terpri))
		  (2 (terpri)
		     (prin1 '***fire*)
	             (prin1 production-number)
	 	     (terpri)
		     (execute*actions action))
		  (t (execute*actions action)))
		  t)
	        (t (execute (cdr pds) dis-flag)))))))

(defun start-ps (x)
(let ((displayflag nil))
  (setq *haltflag* nil)
  (princ '|======  select display mode  |)
  (terpri)
  (terpri)
  (princ '|        1. rule-number  & working memory| )
  (terpri)
  (princ '|        2. rule-number |)
  (terpri)
  (princ '|        3. answers only |)
  (terpri)
  (setq displayflag (read))
  (start*production x displayflag)
))

(defun start*production (x displayflag)
  (cond (*haltflag* (return-from start*production '****halt))
	((execute *productions* displayflag)
	 (start*production x displayflag))
  	(t (return-from start*production '****no-production))))



