; $Id: mpc.scm 2156 2008-01-25 13:25:12Z schimans $

; mpc-context contains all object and assumption variables available
; in a given proof state

(define MPC-CONTEXT '())

(define (mpc-add-context-item context-item)
  (set! MPC-CONTEXT (cons context-item MPC-CONTEXT)))

; The block stack keeps track of block nestings

(define MPC-BLOCK-STACK '())
; each entry has the form '(context context-item), where
; context-item is an object or assumption variable.
; context is the context at the beginning of the block.
; Access to the stack is done by the following two functions:

(define (mpc-push context-item)
  (set! MPC-BLOCK-STACK
	(cons (list MPC-CONTEXT context-item) MPC-BLOCK-STACK)))

(define (mpc-pop)
  (if (null? MPC-BLOCK-STACK)
      (myerror "mpc-pop: too many closing blocks")
      (let ((top-of-stack (car MPC-BLOCK-STACK)))
        (set! MPC-BLOCK-STACK (cdr MPC-BLOCK-STACK))
        (set! MPC-CONTEXT (car top-of-stack))
        (cadr top-of-stack))))

(define (mpc-indent)
  (make-string (* 2 (length MPC-BLOCK-STACK)) #\space))


; Functions called by the parser:


(define MPC-CLASSICAL-LOGIC #f)
(define MPC-INTUITIONISTIC-LOGIC #f)

(define (mpc-start intuitionistic classic)
; do whatever needs to be done to initialize mpc
  (if classic 
      (display "CLASSIC ")
      (if intuitionistic
	  (display "INTUITIONISTIC ")))
  (display "PROOF;") (comment "initializing mpc")
  (set! COMMENT-STRING (list->string '(tab #\/ #\/ #\space)))
  (set! MPC-INTUITIONISTIC-LOGIC intuitionistic)
  (set! MPC-CLASSICAL-LOGIC classic)
  (set! MPC-CONTEXT '())
  (set! MAXAVARINDEX INITIAL-MAXAVARINDEX) ;added 02-01-08
  (set! MAXVARINDEX 1) ;added 02-01-08
  (set! MPC-BLOCK-STACK '()))

(define (mpc-stop)
; do whatever needs to be done for terminating mpc
  (display "END;") (comment "terminating mpc")
  (if (not (equal? MPC-BLOCK-STACK '()))
      (myerror "mpc-stop: END found within block"))
  (set! MPC-CONTEXT '())
  (set! MPC-BLOCK-STACK '()))


(define MPC-LOADED-FILES '())

(define (mpc-command-load filename)
; read the given file as scheme code/minlog code
; it would be nice if the file could be loaded from a system library
; directory in case it does not exist in the current directory
  (display "LOAD ")
  (write filename) 
  (display ";")
  (let* ((libname (string-append minlogpath "/lib/" filename))
         (name
          (cond
            ((file-exists? filename) filename)
            ((file-exists? libname) libname)
            (else #f))))
    (if name
        (if (member name  MPC-LOADED-FILES)
          (comment "already loaded")
          (begin 
            (newline)
            (set!  MPC-LOADED-FILES (cons name MPC-LOADED-FILES))
            (load name)))
        (myerror "file not found"))))

(define MPC-INCLUDED-FILES '())

(define (mpc-command-include filename)
; read the given file as mcp commands
  (display "INCLUDE ")
  (write filename) 
  (display ";")
  (let* ((libname (string-append minlogpath "/lib/" filename))
         (name
          (cond
            ((file-exists? filename) filename)
            ((file-exists? libname) libname)
            (else #f))))
    (if name
        (if (member name  MPC-INCLUDED-FILES)
          (comment "already included")
          (begin 
            (newline)
            (set!  MPC-INCLUDED-FILES (cons name MPC-INCLUDED-FILES))
            (parse-file name)))
        (myerror "file not found"))))

(define (mpc-command-scheme codestring)
; execute the given string as scheme code
  (display "SCHEME ")
  (write codestring ) 
  (display ";")
  (newline)
  (eval (read (open-input-string codestring))))

(define (mpc-claim formula) ;to be rewritten
; prove the given formula from available assumptions
  (display (mpc-indent))
  (display (formula-to-string formula))
  (display ";")
  (let* ((check-result (mpc-proof-check formula MPC-CONTEXT))
	 (new-avar (formula-to-new-avar formula))
	 (new-index (avar-to-index new-avar)))
    (if check-result
	(comment "ok, " new-index " proved " check-result)
	(let ((search-result (mpc-search mult-default formula MPC-CONTEXT)))
	  (if search-result
	      (comment "Warning: " new-index
			    " provable using proof search only.")
	      (comment "ERROR: " new-index
			    " assumed.  Proof not found."))))
    (mpc-add-context-item new-avar)))

(define (mpc-assume formula)
; add the given formula to the available assumptions
  (display (mpc-indent))
  (display (formula-to-string formula))
  (display ".")
  (let* ((new-avar (formula-to-new-avar formula))
	 (new-index (avar-to-index new-avar)))
    (comment new-index " assumed.")
    (mpc-add-context-item new-avar)))

(define (mpc-block-start parser-formula)
; start a new block
; inspect the parser-formula.
; it might be a simple variable then assume the variable
; it might be a formula, then add the given parser-formula to the 
; available assumptions
  (display (mpc-indent)) (display "{ ")
  (if (and (eq? (car parser-formula) 'atom)
	   (eq? (caadr parser-formula) 'term-in-var-form))
      (let* ((var (car (cddadr parser-formula)))
	     (free
		(do ((l MPC-CONTEXT (cdr l))
		     (res
		      '()
		      (let ((x (car l)))
			(case (tag x)
			  ((var) res)
			  ((avar) (union (formula-to-free (avar-to-formula x))
					 res))
			  (else (myerror
				 "mpc-block-start: var or avar expected"
				 x))))))
		    ((null? l) res))))
	(display (var-to-string var)) (display ".")
	(comment (var-to-string var) " assumed."
		 (if (member var free)
		     "  ERROR: Variable condition fails."
		     ""))
	(mpc-push var)
	(mpc-add-context-item var))
      (let* ((new-avar (formula-to-new-avar parser-formula))
	     (new-index (avar-to-index new-avar)))
	(display (formula-to-string parser-formula)) (display ".")
	(comment new-index " assumed.")
	(mpc-push new-avar)
	(mpc-add-context-item new-avar))))

(define (mpc-block-stop)
; reset the list of proven formulas to the position of the block start
; add the conclusion of the block to the proven formulas
  (let* ((kernel (avar-to-formula (car MPC-CONTEXT)))
	 (head (mpc-pop))
	 (formula (if (var-form? head)
		      (mk-all head kernel)
		      (mk-imp (avar-to-formula head) kernel)))
	 (new-avar (formula-to-new-avar formula))
	 (new-index (avar-to-index new-avar)))
    (display (mpc-indent)) (display "}")
    (comment "ok, " new-index " " (formula-to-string formula) " proved.")
    (mpc-add-context-item new-avar)))

(define (mpc-declare-type tokenlist)
; add the tokens in the list as new type variables
  (display tokenlist)  (display "TYPE .")
  (for-each (lambda (name) (display " ") (display name)) tokenlist)
  (display ";")
  (newline)
  (for-each add-tvar-name tokenlist))

(define (mpc-declare-var type tokenlist)
; add the tokens in the list as new variable names for the given type
  (display (type-to-string type))
  (display " .")
  (for-each (lambda (name) (display " ") (display name)) tokenlist)
  (display ";") (newline)
  (for-each (lambda (name) (add-var-name name type)) tokenlist))

(define (mpc-declare-pred arity names)
; add the tokens in the list as new predicate names with given arity
  (display "PRED ") 
  (let ((types (arity-to-types arity)))
    (if (pair? types)
        (for-each (lambda (type) 
		    (display (type-to-string type))
		    (display " ")) types)))
  (display ".") 
  (for-each (lambda (name) (display " ") (display name)) names)
  (display ";") (newline)
  (apply add-predconst-name (append names (list arity))))

(define (mpc-declare-algebra-header names arity)
	 (let ((old-algebras ALGEBRAS))
	   (for-each (lambda (name)
		       (set! ALGEBRAS
			     (cons 
			      (list name names 'alg) 
			      ALGEBRAS)))
		     names)
	   (map (lambda (name)
		  (add-token name 'alg name))
		names)
	   (cons old-algebras (cons names arity))))

(define (mpc-declare-algebra old-algebras names arity constructors)
; define a new algebra
; algebra-name is a string, the name of the new algebra
; constructors is a list with one item per constructor each item has the form
; '(algebra-name constructor-name parameter-types)
; parameter-types is a list of types
  (let ((constructors-with-strings
	 (map (lambda (x) 
		(list (car x) (type-to-string (cadr x))))
	      constructors)))
    (set! ALGEBRAS old-algebras)
    (map remove-token names)
    (apply add-param-algs (cons  names
				 (cons (if (> arity 0) 'alg-typeop 'alg)
				       (cons arity
					     constructors-with-strings))))))

(define (mpc-declare-function token typelist type t-deg)
  (display-more (if (zero? t-deg) "PARTIAL " "")
		"FUNCTION "
		(type-to-string type)
		" . "
		token (map type-to-string typelist) )
  (add-program-constant token 
			(apply mk-arrow (append typelist (list type))) 
			t-deg 'const 
			(length typelist)))

(define (mpc-function)
  (display ";") (newline))


(define (mpc-function-rules-start)
  (display "{ "))

(define (mpc-function-rules-stop)
  (display "}"))

(define (mpc-computation-rule term1 term2)
  (for-each display (list 
		     "          "
		     (term-to-string term1)
		     " -> " 
		     (term-to-string term2)
		     ";"))
  (add-computation-rule term1 term2))

(define (mpc-rewrite-rule term1 term2)
  (for-each display (list 
		     "  REWRITE "
		     (term-to-string term1)
		     " -> " 
		     (term-to-string term2)
		     ";"))
  (add-rewrite-rule term1 term2))



(define (mpc-declare-syntax name tokentype tokenname arity term)
; define a new syntax
  (display-more "SYNTAX " name " " tokenname " " (term-to-string term) ";")
  (case arity
    ((0)
     (let ((token (is-token? name)))
     	(if token
	   (if (equal? tokentype (car token))
	       (begin
		 (remove-token name)
		 (add-token name tokentype term))
	       (myerror "attempt to redefine token " 
			name " / " (symbol->string (car token))
			" with a different token type."))
	   (add-token name tokentype term))	
       (add-display (term-to-type term)
		    (lambda (x)
		     (if (term=? x term)
		         (list tokentype name)
			 #f)))))
    ((1)
     (let* ((type (term-to-type term))
	    (valtype (if (arrow-form? type)
			 (arrow-form-to-val-type type)
			 (myerror "arrow type expected" 
				  (type-to-string type))))
	    (argtype (arrow-form-to-arg-type type))
	    (token (is-token? name)))
       (if token
	   (if (equal? tokentype (car token))
	       (begin
		 (remove-token name)
		 (add-token 
		  name tokentype
		  (lambda (x)
		    (let ((subst (type-match argtype (term-to-type x))))
; 		    (let ((subst (type-match-final
; 				  argtype 
; 				  (term-to-type x) '()
; 				  empty-subst)))
		      (if subst
			  (mk-term-in-app-form 
			   (term-substitute term subst) x)
			  ((cdr token) x))))))
	       (myerror "attempt to redefine token " 
			name " / " (symbol->string (car token))
			" with a different token type."))
	   (add-token name tokentype
		      (lambda (x)
			(let ((subst (type-match argtype (term-to-type x))))
; 			(let ((subst (type-match-final
; 				      argtype 
; 				      (term-to-type x) '()
; 				      empty-subst)))
			  (if subst
			      (mk-term-in-app-form 
			       (term-substitute term subst) x)
			      (myerror "can't apply operator "
				       name " to " (term-to-string x)))))))
       (add-display valtype
		    (lambda (x)
		      (if (not (term-in-app-form? x))
			  #f
			  (let* ((op (term-in-app-form-to-op x))
				 (arg (term-in-app-form-to-arg x))
				 (subst (type-match (term-to-type term)
						    (term-to-type op))))
			    (if subst
				(let ((inst-term (term-substitute term subst)))
				  (if (term=? op inst-term)
				      (list tokentype name
					    (term-to-token-tree arg))
				      #f))
				  #f)))))))
    ((2)
     (let* ((type (term-to-type term))
	    (valtype (if (arrow-form? type)
			 (arrow-form-to-val-type type)
			 (myerror "arrow type expected"
				  (type-to-string type))))
	    (arg1type (arrow-form-to-arg-type type))
	    (valvaltype (if (arrow-form? valtype)
			 (arrow-form-to-val-type valtype)
			 (myerror "double arrow type expected"
				  (type-to-string type))))
	    (arg2type (arrow-form-to-arg-type valtype))
	    (token (is-token? name)))
       (if token
	   (if (equal? tokentype (car token))
	       (begin
		 (remove-token name)
		 (add-token 
		  name tokentype
		  (lambda (x y)
		    (let ((subst (type-match-list
				  (list arg1type arg2type)
				  (list (term-to-type x) (term-to-type y)))))
; 		    (let ((subst (type-match-final
; 				  arg1type 
; 				  (term-to-type x)
; 				  (list (list arg2type (term-to-type y)))
; 				  empty-subst)))
		      (if subst
			  (mk-term-in-app-form 
			   (term-substitute term subst) x y)
			  ((cdr token) x y))))))
	       (myerror "attempt to redefine token " 
			name " / " (symbol->string (car token))
			" with a different token type."))
	   (add-token name tokentype
		  (lambda (x y)
		    (let ((subst (type-match-list
				  (list arg1type arg2type)
				  (list (term-to-type x) (term-to-type y)))))
; 		    (let ((subst (type-match-final
; 				  arg1type 
; 				  (term-to-type x)
; 				  (list (list arg2type (term-to-type y)))
; 				  empty-subst)))
		      (if subst
			  (mk-term-in-app-form 
			   (term-substitute term subst) x y)
			  (myerror "can't apply operator "
				   name " to " (term-to-string x)
				   " and " (term-to-string y)))))))
       (add-display 
	valvaltype
	(lambda (x)
	  (if (not (term-in-app-form? x))
	      #f
	      (let ((op (term-in-app-form-to-op x))
		    (arg (term-in-app-form-to-arg x)))
		(if (not (term-in-app-form? op))
		    #f
		    (let* ((opop (term-in-app-form-to-op op))
			   (oparg (term-in-app-form-to-arg op))
			   (subst (type-match (term-to-type term)
					     (term-to-type opop))))
		      (if subst
			  (let ((inst-term (term-substitute term subst)))
			    (if (term=? opop inst-term)
				(list tokentype name
				      (term-to-token-tree oparg)
				      (term-to-token-tree arg))
				#f))
			  #f)))))))))
    (else (myerror "SYNTAX needs arity 1 or 2"))))

; Functions realizing the proof checker:

(define (mpc-proof-check goal-formula context)
  (or (mpc-trivial-check goal-formula) 
      (mpc-identity-check goal-formula context)
      (mpc-all-elim-check goal-formula context)
      (mpc-imp-elim-check goal-formula context)
      (mpc-and-elim-check goal-formula context)
      (mpc-and-intro-check goal-formula context)
      (mpc-ex-intro-check goal-formula context)
      (mpc-ex-elim-check goal-formula context)
      (mpc-cases-check goal-formula context)
      (mpc-bool-cases-check goal-formula context)
      (mpc-ind-check goal-formula context)
      (mpc-efq-check goal-formula context)
      (mpc-stab-check goal-formula context)))

(define (mpc-trivial-check goal-formula)
  (if (classical-formula=? truth goal-formula)
      "trivially"
      #f))

(define (search-for-formula context test)
; Traverse the context testing each formula with test.
; If test returns true, the index of the formula is 
; cons'd with the return value of the test and returned.
; Otherwise the search continues.
; If no test succeeds, #f is returned
  (if (null? context)
      #f
      (if (avar-form? (car context))
	  (let ((answer (test (avar-to-formula (car context)))))
	    (if answer
		(cons (avar-to-index (car context)) answer)
		(search-for-formula (cdr context) test)))
	  (search-for-formula (cdr context) test))))

(define (mpc-efq-check goal-formula context)
  (if MPC-INTUITIONISTIC-LOGIC
      (let ((index (search-for-formula 
		    context
		    (lambda (formula)
		      (or (classical-formula=? formula falsity-log)
			  (classical-formula=? formula falsity))))))
	(if index
	    (string-append "by EFQ from " (number-to-string (car index)))
	    #f))
      #f))

(define (mpc-stab-check goal-formula context)
  (if MPC-CLASSICAL-LOGIC
      (let* ((log-not-not-goal
	      (make-negation-log (make-negation-log goal-formula)))
	     (not-not-goal (make-negation (make-negation goal-formula)))
	     (index (search-for-formula 
		     context
		     (lambda (formula)
		       (or (classical-formula=? formula not-not-goal)
			   (classical-formula=? formula log-not-not-goal))))))
	(if index
	    (string-append "by Stability from " (number-to-string (car index)))
	    #f))
      #f))

(define (mpc-identity-check goal-formula context)
  (let ((index
	 (search-for-formula 
	  context
	  (lambda (formula) (classical-formula=? formula goal-formula)))))
    (if index
	(string-append "by " (number-to-string (car index)))
	#f)))

(define (mpc-imp-elim-check goal-formula context)
  (let ((indices (search-for-formula 
		  context
		  (lambda (implication)
		    (and (imp-form? implication)
			 (classical-formula=? 
			  (imp-form-to-conclusion implication)
			  goal-formula)
			 (search-for-formula 
			  context
			  (lambda (premise)
			    (classical-formula=? 
			     (imp-form-to-premise implication) premise))))))))
    (if indices
	(string-append "by imp-elim from "
		       (number-to-string (car indices))
		       " and "
		       (number-to-string (cadr indices)))
	#f)))

(define (mpc-and-intro-check goal-formula context)
  (if (and-form? goal-formula)
      (let* ((left (and-form-to-left goal-formula))
	     (leftindex  (search-for-formula 
			  context
			  (lambda (formula) 
			    (classical-formula=? formula left)))))
	(if leftindex
	    (let* ((right (and-form-to-right goal-formula))
		   (rightindex  (search-for-formula 
				 context
				 (lambda (formula) 
				   (classical-formula=? formula right)))))
	      (if rightindex
		  (string-append "by and-intro from "
				 (number-to-string (car leftindex))
				 " and "
				 (number-to-string (car rightindex)))
		  #f))
	    #f))
      #f))

(define (mpc-and-elim-check goal-formula context)
  (let ((index (search-for-formula 
		context
		(lambda (formula) 
		  (and (and-form? formula)
		       (if (classical-formula=? (and-form-to-left formula)
						goal-formula)
			   "left"
			   (if (classical-formula=? (and-form-to-right formula)
						    goal-formula)
			       "right"
			       #f)))))))
    (if index
	(string-append "by and-elim-" (cdr index) " from "
		       (number-to-string (car index)))
	#f)))

(define (mpc-all-elim-check goal-formula context)
  (let ((index (search-for-formula 
		context
		(lambda (formula)
		  (and (all-form? formula)
		       (let* ((kernel (all-form-to-kernel formula))
			      (match-result
			       (match kernel goal-formula)))
			 (if match-result
			     (let ((var (all-form-to-var formula)))
			       (if (equal? (map car match-result) (list var))
				   (cadr (assoc var match-result))
                                   (if (null? match-result)
                                       '()
				       #f)))
			     #f)))))))
    (if index
	(string-append "by all-elim from "
		       (number-to-string (car index))
		       (if (null? (cdr index)) 
                           ""
                           (string-append
			    " using "
			    (term-to-string (cdr index)))))
	#f)))

(define (mpc-ex-intro-check goal-formula context)
  (if (ex-form? goal-formula)
      (let* ((var (ex-form-to-var goal-formula))
	     (kernel (ex-form-to-kernel goal-formula))
	     (index (search-for-formula 
		     context
		     (lambda (formula)
		       (let ((match-result (match kernel formula)))
			 (if match-result
			     (if (equal? (map car match-result) (list var))
			         (cadr (assoc var match-result))
                                 (if (null? match-result)
                                     '()
                                     #f))
			     #f))))))
	(if index
	    (string-append "by ex-intro from "
			   (number-to-string (car index))
                           (if (null? (cdr index))
                               ""
                               (string-append
				" using "
				(term-to-string (cdr index)))))
	    #f))
      #f))

(define (mpc-ex-elim-check goal-formula context)
  (let ((indices
	 (search-for-formula 
	  context
	  (lambda (allformula)
	    (and
	     (all-form? allformula)
	     (let ((kernel (all-form-to-kernel allformula)))
	       (and
		(imp-form? kernel)
		(let ((concl (imp-form-to-conclusion kernel)))
		  (and
		   (classical-formula=? concl goal-formula)
		   (let ((allvar (all-form-to-var allformula)))
		     (and
		      (not (member allvar (formula-to-free concl)))
		      (search-for-formula 
		       context
		       (lambda (exformula) 
			 (and (ex-form? exformula)
			      (let ((type (var-to-type allvar))
				    (exvar (ex-form-to-var exformula)))
				(and (equal? (var-to-type exvar) type)
				     (let ((new-varterm
					    (make-term-in-var-form
					     (type-to-new-var type))))
				       (classical-formula=?
					(formula-subst 
					 (ex-form-to-kernel exformula)
					 exvar new-varterm)
					(formula-subst 
					 (imp-form-to-premise kernel)
					 allvar new-varterm)))))))))))))))))))
    (if indices
	(string-append "by ex-elim from "
		       (number-to-string (car indices))
		       " and "
		       (number-to-string (cadr indices)))
	#f)))

(define (mpc-ind-check goal-formula context)
  (if
   (all-form? goal-formula)
   (let* ((var (all-form-to-var goal-formula))
	  (kernel (all-form-to-kernel goal-formula))
	  (t-deg (var-to-t-deg var)))
     (if
      (and (< 0 t-deg) (alg-form? (var-to-type var)))
      (let* ((type (var-to-type var))
	     (alg-name (alg-form-to-name type))
	     (ind-aconst (all-formulas-to-ind-aconst goal-formula))
	     (ind-axiom (aconst-to-formula ind-aconst))
             (ind-formula 
	      (do ((terms (map make-term-in-var-form 
			       (formula-to-free goal-formula)) (cdr terms))
		   (ind-formula ind-axiom))
		  ((null? terms) ind-formula)
		(let ((var (all-form-to-var ind-formula))
		      (kernel (all-form-to-kernel ind-formula)))
		  (set! ind-formula (formula-subst kernel var (car terms))))))
	     (step-formulas (imp-form-to-premises ind-formula))
	     (indices (context-and-formulas-to-indices context step-formulas)))
	(if indices
	    (apply string-append
		   (cons "by ind from"
			 (map (lambda (x)
				(string-append " " (number-to-string x)))
			      indices)))
	    #f))
      #f))
   #f))

(define (mpc-cases-check goal-formula context)
  (if
   (all-form? goal-formula)
   (let* ((var (all-form-to-var goal-formula))
	  (kernel (all-form-to-kernel goal-formula))
	  (t-deg (var-to-t-deg var)))
     (if
      (and (< 0 t-deg) (alg-form? (var-to-type var)))
      (let* ((type (var-to-type var))
	     (alg-name (alg-form-to-name type))
	     (cases-aconst (all-formula-to-cases-aconst goal-formula))
	     (cases-axiom (aconst-to-formula cases-aconst))
             (cases-formula 
                (do ((terms (map make-term-in-var-form 
				 (formula-to-free goal-formula)) (cdr terms))
                     (case-formula cases-axiom))
                ((null? terms) case-formula)
		(let ((var (all-form-to-var case-formula))
		      (kernel (all-form-to-kernel case-formula)))
		  (set! case-formula (formula-subst kernel var (car terms))))))
	     (step-formulas (imp-form-to-premises cases-formula))
	     (indices (context-and-formulas-to-indices context step-formulas)))
	(if indices 
	    (apply string-append
		   (cons "by cases from"
			 (map (lambda (x)
				(string-append " " (number-to-string x)))
			      indices)))
	    #f))
      #f))
   #f))

; (define (mpc-cases-check goal-formula context)
;   (if
;    (all-form? goal-formula)
;    (let* ((var (all-form-to-var goal-formula))
; 	  (kernel (all-form-to-kernel goal-formula))
; 	  (t-deg (var-to-t-deg var)))
;      (if
;       (and (< 0 t-deg) (alg-form? (var-to-type var)))
;       (let* ((type (var-to-type var))
; 	     (alg-name (alg-form-to-name type))
; 	     (cases-aconst (all-formulas-to-cases-aconst goal-formula))
; 	     (cases-axiom (aconst-to-formula cases-aconst))
;              (cases-formula 
;                 (do ((terms (map make-term-in-var-form 
; 				 (formula-to-free goal-formula)) (cdr terms))
;                      (case-formula cases-axiom))
;                 ((null? terms) case-formula)
; 		(let ((var (all-form-to-var case-formula))
; 		      (kernel (all-form-to-kernel case-formula)))
; 		  (set! case-formula (formula-subst kernel var (car terms))))))
; 	     (step-formulas (imp-form-to-premises cases-formula))
; 	     (indices (context-and-formulas-to-indices context step-formulas)))
; 	(if indices 
; 	    (apply string-append
; 		   (cons "by cases from"
; 			 (map (lambda (x)
; 				(string-append " " (number-to-string x)))
; 			      indices)))
; 	    #f))
;       #f))
;    #f))

(define (mpc-bool-cases-check goal-formula context)
  (let* ((booletype (make-alg "boole"))
	 (indices 
	  (search-for-formula 
	   context
	   (lambda (implication)
	     (and (imp-form? implication)
		  (classical-formula=? 
		   (imp-form-to-conclusion implication)
		   goal-formula)
	     (let ((premise (imp-form-to-premise implication)))
	     (and (atom-form? premise)
	       	  (equal? (term-to-type (atom-form-to-kernel premise))
			  booletype)
             (let ((target (make-imp (make-negation premise)
				     goal-formula)))
	          (search-for-formula 
		   context
		   (lambda (formula)
		     (classical-formula=? target formula)))))))))))
    (if indices
	(string-append "by boolean cases from "
		       (number-to-string (car indices))
		       " and "
		       (number-to-string (cadr indices)))
	#f)))

; returns #f or a list of indices
(define (context-and-formulas-to-indices context formulas)
  (let ((result (cons 0 0))) ;the real result is (cdr result) the extra cons is
                             ;needed to pass around a pointer to the result
    (let outer-loop ((r result)
                     (f formulas))
      (if (null? f)
	  (begin 
	    (set-cdr! r '()) 
	    (cdr result)) 		;exit with (cdr result)
	  (let inner-loop ((c context))
	    (cond
	     ((null? c) #f) 		;exit immediately with false
	     ((not (avar-form? (car c)))
	      (inner-loop (cdr c)))			
	     ((classical-formula=? (avar-to-formula (car c)) (car f))
	      (set-cdr! r (cons (avar-to-index (car c)) 0))
	      (outer-loop (cdr r) (cdr f)))
	     (else (inner-loop (cdr c)))))))))
		 
; (mpc-search m goal-formula context) expects for m a default value
; for multiplicity, i.e. how `often' hypotheses are to be used.  What we
; mean by this is how often they are used in each branch of the search
; tree.  For example, in A -> A & A and also in A -> (A -> A -> B) -> B
; the assumption A is used only once in our sense, and in (all x.P x ->
; P(f x)) -> P y -> P(f(f y)) the first assumption is used twice.

(define orig-mult-default 2)
(define orig-maxavarindex INITIAL-MAXAVARINDEX)

(define (mpc-search m goal-formula context)
  (set! ELIM-SEARCH-COUNTER ELIM-SEARCH-BOUND)
  (set! orig-mult-default mult-default)
  (set! mult-default m)
  (set! orig-maxavarindex MAXAVARINDEX)
  (let* ((avars (context-to-avars context))
	 (sig-vars (context-to-vars context)) ;signature variables
	 (leaves-with-mult
	  (map (lambda (avar)
		 (list (make-proof-in-avar-form avar) m))
	       avars))
	 (clause-formulas (map proof-to-formula
			       (map car leaves-with-mult)))
	 (pos-ex-list
	  (remove-duplicates-wrt
	   classical-formula=?
	   (apply append
		  (cons (formula-to-positive-existential-subformulas
			 goal-formula)
			(map formula-to-negative-existential-subformulas
			     clause-formulas)))))
	 (neg-ex-list
	  (remove-duplicates-wrt
	   classical-formula=?
	   (apply append
		  (cons (formula-to-negative-existential-subformulas
			 goal-formula)
			(map formula-to-positive-existential-subformulas
			     clause-formulas)))))
	 (ex-list (remove-duplicates-wrt classical-formula=?
					 (append pos-ex-list neg-ex-list)))
	 (ex? (pair? ex-list))
	 (ex-intro-leaves-with-mult
	  (map (lambda (f) (list (make-proof-in-aconst-form
				  (ex-formula-to-ex-intro-aconst f))
				 m))
	       pos-ex-list))
	 (ex-elim-leaves-with-mult
	  (do ((l (reverse neg-ex-list) (cdr l))
	       (res
		'()
		(append
		 (map
		  (lambda (f)
		    (list (make-proof-in-aconst-form
			   (ex-formula-and-concl-to-ex-elim-aconst (car l) f))
			  m))
		  (remove-wrt classical-formula=? (car l) ex-list))
		 res)))
	      ((null? l) res)))
	 (clauses
	  (apply append
		 (map (lambda (lwm) (leaf-with-mult-to-clauses lwm))
		      (append leaves-with-mult
			      ex-intro-leaves-with-mult
			      ex-elim-leaves-with-mult))))
	 (prev (intro-search
		(normalize-formula goal-formula)
; 		(unfold-formula (normalize-formula goal-formula))
; 		(unfold-formula goal-formula)
		clauses
		'() ;no sequents initially
		sig-vars
		'() ;no flex-vars initially
		'() ;no forb-vars initially
		ex?
		0)))
    (set! mult-default orig-mult-default)      
    (set! MAXAVARINDEX orig-maxavarindex)      
    (if prev
	(cadr prev)
	#f)))

; Before 02-01-14 we restricted the existenec axioms to:

; If the goal-formula is existential, i.e. of form ex x A, then the
; Ex-Intro axiom all x.A -> ex x A is added to the context.  Also for
; every existential context formula ex x A we add the Ex-Elim axiom
; ex x A -> (all x.A -> G) -> G to the context (G is the goal formula).

; (define (mpc-search m goal-formula context)
;   (set! orig-mult-default mult-default)
;   (set! mult-default m)
;   (let* ((avars (context-to-avars context))
; 	 (sig-vars (context-to-vars context)) ;signature variables
; 	 (leaves-with-mult
; 	  (map (lambda (avar)
; 		 (list (make-proof-in-avar-form avar) m))
; 	       avars))
; 	 (clause-formulas (map proof-to-formula
; 			       (map car leaves-with-mult)))
; 	 (ex-intro-leaves-with-mult
; 	  (if (ex-form? goal-formula)
; 	      (list (list (make-proof-in-aconst-form
; 			   (ex-formula-to-ex-intro-aconst goal-formula))
; 			  m))
; 	      '()))
; 	 (ex-elim-leaves-with-mult
; 	  (map
; 	   (lambda (fla)
; 	     (list (make-proof-in-aconst-form
; 		    (ex-formula-and-concl-to-ex-elim-aconst
; 		     fla goal-formula))
; 		   m))
; 	   (list-transform-positive clause-formulas ex-form?)))
; 	 (clauses
; 	  (apply append
; 		 (map (lambda (lwm) (leaf-with-mult-to-clauses lwm))
; 		      (append leaves-with-mult
; 			      ex-intro-leaves-with-mult
; 			      ex-elim-leaves-with-mult))))
; 	 (intro-search-result
; 	  (intro-search (unfold-formula goal-formula)
; 			clauses
; 			'() ;no sequents initially
; 			sig-vars
; 			'() ;no flex-vars initially
; 			'() ;no forb-vars initially
; 			#t
; 			0)))
;     (set! mult-default orig-mult-default)      
;     (if intro-search-result
; 	(cadr intro-search-result)
; 	#f)))
