;
; theorem prover, v.1
;
;
(defun prove (stmnt dbase)        ; top-level call to theorem prover
  (defvar stmnt nil)
  (defvar dbase nil)
  (or 
    (and (prover stmnt dbase)
         (success-message stmnt)) 
    (failure-message stmnt))
  (format t "END OF PROOF~%~%")
)
;
;
; prover for production
(defun prover (stmnt dbase)
  (findassert dbase))
;
;
; test each member of the database against the statement to be proved
(defun findassert (rest) ; rest = cdr of dbase
  (cond
    ((null rest) nil)
    ((or (provesit (car rest))
         (findassert (cdr rest))))
))
;
;
; there are two "cases" that might yield a "proof"
(defun provesit (assrt) ; assrt = a single element of the database
  (or
  ; case 1: the statement matches with a known "fact"
    (equal stmnt assrt)
  ; case 2: the statement matches with a consequent theorem
    (and
      (equal 'CONSE (car assrt))
      (equal (car stmnt) (caadr assrt))
      (goal-bind stmnt (cadr assrt))
      (prove-goal assrt dbase)
    ) ; end or
)) ; end provesit
;
;
; before proving a consequent's goal, bind the variables in the 
; consequent to the arguments of the statement
(defun goal-bind (stmnt assrt)
  (cond
    ((eq 2 (length assrt)) ; i.e. assrt=(MALE ?x)
      (set (cadr assrt) (cadr stmnt))) ; end pair
    ((eq 3 (length assrt)) ; i.e. assrt=(CHILD ?x ?y)
      (set (cadr assrt) (cadr stmnt))
      (set (caddr assrt) (caddr stmnt))) ; end pair
  ) ; end cond
t) ; end goal-bind
;
; two cases of goals to prove are handled
(defun prove-goal (goal dbase)
  (prog (return-val conse-part goal-part)
    (setq conse-part (cadr goal))        ; use locals to "get hold" of 
    (setq goal-part (cadr (caddr goal))) ; consequent and goals
    ;
    (cond
      ((goal-p (mapcar 'eval (cdr conse-part)))
         (setq return-val  ; all elements will have been bound already
               (prove-candidate
                 (cons (car goal-part)
                       (mapcar 'eval (cdr goal-part)))))
      ) ; end pair
      (t
        (setq return-val  ; all elements will have been bound already
              (prover         ; in this case, by "goal-bind"
                (cons (car goal-part)
                      (make-arg-list (cdr goal-part))
                ) ; end cons
                dbase)
        ) ; end setq
       ) ; end pair
     ) ; end inner cond
    (return return-val)
))
;
;
(defun prove-candidate (assrt)
  (prog (return-val)
    ; it could be that all the variables are bound because this is a
    ; second call to prove-candidate -- that is, some binding has
    ; worked on the first part of a consequent and should be tested on
    ; latter parts. This first test checks for this condition
    ;
    (if (all-literal-p (cdr assrt))
        (return (prover assrt dbase))
    )
    ;
    ; otherwise grind through a list of candidate bindings
    ;
    (setq return-val
      (do ((cndtlst (return-candidates conse-part dbase)
                    (cdr cndtlst))
           (cnddt nil)
           (retval nil))
          ((or (null cndtlst) retval) retval)
        (cond
          ((null cnddt)
            (if (and (var-p (cadr assrt))
                     (null (eval (cadr assrt))))
              (set (cadr assrt) (car cndtlst))
            ; else
              (set (caddr assrt) (car cndtlst)))
            (setq cnddt (car cndtlst)))
          (t
            (if (and (var-p (cadr assrt))
                     (equal cnddt (eval (cadr assrt))))
              (set (cadr assrt) (car cndtlst))
            ; else
              (set (caddr assrt) (car cndtlst)))
            (setq cnddt (car cndtlst)))
        ) ; end cond
        ;
        (setq retval
          (prover
            (cons (car assrt)
                  (make-arg-list (cdr assrt))
            ) ; end cons
            dbase)
        ) ; end setq retval
      ) ; end do
    ) ; end setq return-val
    (return return-val)
  ) ; end prog
)
;
;
(defun make-arg-list (varlist)
  (mapcar
    #'(lambda (vrbl)
      (cond
        ((not (var-p vrbl)) vrbl)
        ((and (var-p vrbl) (null (eval vrbl))) vrbl)
        ((and (var-p vrbl) (eval vrbl))
          (if (and (var-p (eval vrbl)) (eval (eval vrbl)))
            (eval (eval vrbl))
          ; else
            (eval vrbl)))
      ) ; end cond
    ) ; end lambda
    varlist
  ) ; end mapcar
) ; end make-arg-list
;
;
; predicate testing whether an element is a variable
(defun var-p (elm)
  (and
    (atom elm)
    (string-equal "?" (elt (symbol-name elm) 0))))
;
;
(defun return-candidates (goalist dbase)
  (prog (bnd cndlst)
    ; find which goal variable is already bound
    (setq bnd
      (mapcar
        #'(lambda (elt) (if (var-p elt) (eval elt) elt))
        (cdr goalist)))
    ; and search for other candidates
    (setq cndlst
      (candidate-search bnd dbase))
    ; remove noise from the list of candidates
    (return (remove-dupes (remove 'nil cndlst)))
))
;
; get every member of the database except the one(s) passed
(defun candidate-search (itmlst dbase)
  (do ((dlist dbase (cdr dlist))
       (clist nil))
      ((null dlist) clist)
    (cond
      ((equal 'CONSE (caar dlist)) )
      (t (mapc
           #'(lambda (elt)
               (if (not (member elt itmlst))
                 (setq clist (cons elt clist)))) ; end lambda
           (cdar dlist)))) ; end cond
))
;
;
; a generalized version of this is "built-in" to Common Lisp
(defun remove-dupes (lst)
  (cond ((null lst) nil)
        ((member (car lst) (cdr lst))
          (remove-dupes (cdr lst)))
        (t (cons (car lst) (remove-dupes (cdr lst))))
))
;
;
; predicate testing whether statement contains a variable
(defun goal-p (stmnt)
  (eval (cons 'or
    (mapcar
      #'(lambda (elm)
        (and
          (atom elm)
          (string-equal "?" (elt (symbol-name elm) 0))))
      stmnt))))
;
;
; debugging
(defun trace-all ()
  (trace
    restore-vars save-vars remove-dupes update 
    all-bound-p goal-bound-p goal-p
    candidate-search return-candidates 
    prove-goal goal-bind prove-candidate
    provesit findassert prove prover))
;
(defun untrace-all ()
  (untrace
    restore-vars save-vars remove-dupes update 
    all-bound-p goal-bound-p goal-p
    candidate-search return-candidates 
    prove-goal goal-bind prove-candidate
    provesit findassert prove prover))
;
;

(defun success-message (stmnt)
  (cond
    ((eq 2 (length stmnt))
      (prog () (format t "TRUE: ~s is " (cadr stmnt))
               (format t "~s ~%" (car stmnt))(return t)))
    ((eq 3 (length stmnt))
      (prog () (format t "TRUE: ~s is the " (cadr stmnt))
               (format t "~s of " (car stmnt))
               (format t "~s ~%" (caddr stmnt))(return t)))
   ))
;
(defun failure-message (stmnt)
  (cond
    ((eq 2 (length stmnt))
      (prog () (format t "CANNOT PROVE: ~s is " (cadr stmnt))
               (format t "~s ~%" (car stmnt))(return t)))
    ((eq 3 (length stmnt))
      (prog () (format t "CANNOT PROVE: ~s is the " (cadr stmnt))
               (format t "~s of " (car stmnt))
               (format t "~s ~%" (caddr stmnt))(return t)))
   ))
;
;
(setq dbaseII '(
  (HUMAN Socrates)
  (CONSE (MORTAL ?X) (GOAL (HUMAN ?X)))
       ))
;
;
(format t "Proving Socrates is Human~%")
;
(prove '(Human Socrates) dbaseII)
;
(format t "Proving Socrates is Mortal~%")
;
(prove '(Mortal Socrates) dbaseII)
;
(format t "Proving Socrates is Brilliant~%")
;
(prove '(Brilliant Socrates) dbaseII)
;