;; Wang's algorithms for verifying propositional formulas
;; As given in Tanimoto  (new edition)

(defun prover ()
	(let (s)
	    (loop (format t "~%Enter proposition or help or return.~%")
	          (setf s (read))
                  (cond ((eql s 'help) (format t "Example: ")
                           (format t "((a and (not b)) implies a) ~%"))
	                ((eql s 'return) (return))
	                ((setf s (catch 'syntax-error (reformat s)))
                             (if (valid nil (list s))
				 (format t " is valid. ~%")
				 (format t " is not valid. ~%")))
			(t (format t ": Syntax error ~%"))))))

(defun valid (l r)
   "Returns T if the conjunction of the formulas in l implies any of
    the formulas in r"
    (let (b)
       (cond 
	; Test for axiom
	     ((intersection l r) t)
	; NOT on the left
	     ((setf b (match '((* x) (not-wff y) (* z)) l))
                 (valid (append (val 'x b) (val 'y b))
                        (append r (rest (val 'y b)))))
	; NOT on the right
             ((setf b (match '((* x) (not-wff y) (* z)) r))
                 (valid (append l (rest (val 'y b)))
                        (append (val 'x b) (val 'z b))))
	; OR on the right
             ((setf b (match '((* x) (or-wff y) (* z)) r))
                 (valid l 
			(append (val 'x b)
			(list (first (val 'y b)))
			(rest (rest (val 'y b)))
			(val 'z b))))
	; AND on the left
             ((setf b (match '((* x) (and-wff y) (* z)) l))
                 (valid (append (val 'x b)
			(list (first (val 'y b)))
			(rest (rest (val 'y b)))
			(val 'z b))
                     r))
	; OR on the left
             ((setf b (match '((* x) (or-wff y) (* z)) l))
                 (and (valid (append (val 'x b)
			(list (first (val 'y b)))
			(val 'z b))
                        r)
                      (valid (append (val 'x b)
			(rest (rest (val 'y b)))
			(val 'z b))
                     r)))
	; AND on the right
             ((setf b (match '((* x) (and-wff y) (* z)) r))
                 (and (valid l
			    (append (val 'x b)
			          (list (first (val 'y b)))
			          (val 'z b)))
                      (valid l
			    (append (val 'x b)
			    (rest (rest (val 'y b)))
			(val 'z b))))))))

(defun or-wff (x)
    "Returns T if X is of the form (f1 or f2)."
	(cond ((atom x) nil)
	      (t (eql (second x) 'or))))

(defun and-wff (x)
    "Returns T if X is of the form (f1 and f2)."
	(cond ((atom x) nil)
	      (t (eql (second x) 'and))))

(defun not-wff (x)
    "Returns T if X is of the form (not f1)."
	(cond ((atom x) nil)
	      (t (eql (first x) 'not))))

(defun wff (x)
    "Returns T if X is a wff."
	(cond ((atom x) t)
	      ((match '(not (wff dum)) x) t)
	      ((match '((wff dum) (op dum) (wff dum)) x) t)
	      (t nil)))

(defun op (x)
    "Returns T if X is a recognized logical operator."
	(member x '(and or implies)))

(defun reformat (x)
    "Checks the syntax, and elliminates IMPLIES."
	(cond ((atom x) x)
	      ((null (wff x)) (throw 'syntax-error nil))
	      ((not-wff x) (list 'not (reformat (second x))))
	      ((equal (second x) 'implies)
		   (list (list 'not (reformat (first x))) 
                         'or
                         (reformat (third x))))
              (t (list (reformat (first x))
                       (second x)
		       (reformat (third x))))))

;; Here is the MATCH funtion (MATCH6 from Tanimoto)

(defun match (p s)
    "Attempts to find a corespondence b/n P and S. Returns a list of
     bindings if successful."
	(cond 
	   ((handle-both-null p s))
	   ((handle-normal-recursion p s))
	   ((atom (first p)) nil)
	   ((handle-? p s))
	   ((handle-* p s))
	   ((handle-restrict-pred p s))
	   (t nil)))

(defun handle-both-null (p s)
	(if (and (null p) (null s))
            '((:yes . :yes))))

(defun handle-normal-recursion (p s)
	(if (atom (first p))
            (if (eql (first p) (first s))
                (match (rest p) (rest s)))))

(defun handle-? (p s)
	(if s
	    (if (eql (1st-pattern-op p) '?)
		(let ((rest-match
                        (match (rest p) (rest s))))
                   (if rest-match
			(acons
			   (1st-pattern-variable p)
			   (first s))
                            rest-match)))))

(defun handle-* (p s)
	(if (eql (1st-pattern-op p) '*)
	    (let ((pattern-variable
                     (1st-pattern-variable p))
		   (rest-match nil))
		(cond
		    ((and s
			  (setf rest-match
				(match (rest p)
				       (rest s))))
		     (acons pattern-variable
                        (list (first s))
			rest-match))
		     ((setf rest-match (match (rest p) s))
		      (acons pattern-variable
                             nil
			     rest-match))
		     ((and s
			  (setf rest-match
				(match  p
				       (rest s))))
		     (acons pattern-variable
			    (cons (first s)
				  (val pattern-variable rest-match))
                       	    (rest rest-match)))
		     (t nil)))))

(defun handle-restrict-pred (p s)
	(if s
	    (if (member (1st-pattern-op p)
		        '(? *))
                nil
               (if (apply (1st-pattern-op p)
                          (list (first s)))
                   (let ((rest-match
                           (match (rest p) (rest s)))
                         (pattern-variable
			   (1st-pattern-variable p)))
		     (if rest-match
			(acons pattern-variable
                               (first s)
			       rest-match)))))))

;; Additional functions follow

(defun val (variable alist)
	(rest (assoc variable alist)))

(defun 1st-pattern-op (p)
	(first (first p)))

(defun 1st-pattern-variable (p)
	(first (rest (first p))))