; $Id: pproof.scm,v 1.185 2009-11-13 23:05:43 logik Exp $
; 11. Partial proofs
; ==================

; A partial proof is a proof with holes, i.e. special assumption
; variables (called goal variables) v, v_1, v_2,... whose formulas must
; be closed.  We assume that every goal variable v has a single
; occurrence in the proof.  We then select a (not necessarily maximal)
; subproof v x_1 ... x_n with distinct object or assumption variables
; x_1...x_n.  Such a subproof is called a goal.  When interactively
; developing a partial proof, a goal v x_1...x_n is replaced by another
; partial proof, whose context may contain (1) items from x_1...x_n
; (i.e., the context of the goal with v removed), (2) object variables
; newly introduced at this moment and (3) new goal variables.

; To gain some flexibility when working on our goals, we do not at each
; step of an interactive proof development traverse the partial proof
; searching for the remaining goals, but rather keep a list of all open
; goals together with their numbers as we go along.  We maintain a
; global variable PPROOF-STATE, which holds a list of three elements:
; - num-goals: an alist of entries (number goal drop-info hypname-info) 
; - proof
; - maxgoal

; For efficiency reasons we include the context and the cvars in goals.

(define (make-goal-in-avar-form avar)
  (list 'proof-in-avar-form (avar-to-formula avar) avar (list avar)))

(define (make-goal-in-all-elim-form goal uservar)
  (let* ((formula (proof-to-formula goal))
	 (var (all-form-to-var formula))
	 (kernel (all-form-to-kernel formula))
	 (uservar-term (make-term-in-var-form uservar)))
    (list 'proof-in-all-elim-form
	  (if (equal? var (term-in-var-form-to-var uservar-term))
	      kernel	      
	      (formula-subst kernel var uservar-term))
	  goal
	  uservar-term
	  (append (proof-with-context-to-context goal) (list uservar)))))

(define (make-goal-in-allnc-elim-form goal uservar)
  (let* ((formula (proof-to-formula goal))
	 (var (allnc-form-to-var formula))
	 (kernel (allnc-form-to-kernel formula))
	 (uservar-term (make-term-in-var-form uservar)))
    (list 'proof-in-allnc-elim-form
	  (if (equal? var (term-in-var-form-to-var uservar-term))
	      kernel	      
	      (formula-subst kernel var uservar-term))
	  goal
	  uservar-term
	  (append (proof-with-context-to-context goal) (list uservar)))))

(define (make-goal-in-imp-elim-form goal avar)
  (list 'proof-in-imp-elim-form 
	(imp-form-to-conclusion (proof-to-formula goal))
	goal
	(make-proof-in-avar-form avar)
	(append (proof-with-context-to-context goal) (list avar))))

(define (make-goal-in-impnc-elim-form goal avar)
  (list 'proof-in-impnc-elim-form 
	(impnc-form-to-conclusion (proof-to-formula goal))
	goal
	(make-proof-in-avar-form avar)
	(append (proof-with-context-to-context goal) (list avar))))

(define (mk-goal-in-elim-form goal . elim-items)
  (if
   (null? elim-items)
   goal
   (let ((formula (unfold-formula (proof-to-formula goal))))
     (case (tag formula)
       ((atom predicate ex exnc)
	(myerror "mk-goal-in-elim-form" "applicable formula expected" formula))
       ((imp)
	(apply mk-goal-in-elim-form
	       (cons (make-goal-in-imp-elim-form goal (car elim-items))
		     (cdr elim-items))))
       ((impnc)
	(apply mk-goal-in-elim-form
	       (cons (make-goal-in-impnc-elim-form goal (car elim-items))
		     (cdr elim-items))))
       ((all)
	(apply mk-goal-in-elim-form
	       (cons (make-goal-in-all-elim-form goal (car elim-items))
		     (cdr elim-items))))
       ((allnc)
	(apply mk-goal-in-elim-form
	       (cons (make-goal-in-allnc-elim-form goal (car elim-items))
		     (cdr elim-items))))
       (else (myerror "mk-goal-in-elim-form" "formula expected" formula))))))

(define (goal-to-goalvar goal)
  (car (proof-with-context-to-context goal)))

(define (goal-to-context goal)
  (cdr (proof-with-context-to-context goal)))

(define (goal-to-formula goal) (proof-to-formula goal))

; For interactively building proofs we will need goal=? and goal-subst

(define (goal=? proof goal)
  (and
   (or (proof-in-avar-form? proof)
       (proof-in-imp-elim-form? proof)
       (proof-in-impnc-elim-form? proof)
       (proof-in-all-elim-form? proof)
       (proof-in-allnc-elim-form? proof))
   (let ((op (proof-in-elim-form-to-final-op proof)))
     (and
      (proof-in-avar-form? op)
      (let ((goalvar (goal-to-goalvar goal)))
	(and
	 (avar=? (proof-in-avar-form-to-avar op) goalvar)
	 (let ((args (proof-in-elim-form-to-args proof))
	       (context (goal-to-context goal)))
	   (and
	    (= (length args) (length context))
	    (do ((l1 args (cdr l1))
		 (l2 context (cdr l2))
		 (res
		  #t
		  (and res
		       (or (and (proof-in-avar-form? (car l1))
				(avar=? (proof-in-avar-form-to-avar (car l1))
					(car l2)))
			   (and (term-in-var-form? (car l1))
				(equal? (term-in-var-form-to-var (car l1))
					(car l2)))))))
		((null? l1) res))))))))))

(define (goal-subst proof goal proof1)
  (case (tag proof)
    ((proof-in-avar-form)
     (if (goal=? proof goal) ;then proof1 with the original formula of proof
	 (append (list (tag proof1)
		       (proof-to-formula proof))
		 (cddr proof1))
	 proof))
    ((proof-in-aconst-form) proof)
    ((proof-in-imp-intro-form)
     (list 'proof-in-imp-intro-form
	   (proof-to-formula proof)
	   (proof-in-imp-intro-form-to-avar proof)
	   (goal-subst (proof-in-imp-intro-form-to-kernel proof) goal proof1)))
    ((proof-in-imp-elim-form)
     (if (goal=? proof goal)
	 (append (list (tag proof1)
		       (proof-to-formula proof))
		 (cddr proof1))
	 (list
	  'proof-in-imp-elim-form
	  (proof-to-formula proof)
	  (goal-subst (proof-in-imp-elim-form-to-op proof) goal proof1)
	  (goal-subst (proof-in-imp-elim-form-to-arg proof) goal proof1))))
    ((proof-in-impnc-intro-form)
     (list 'proof-in-impnc-intro-form
	   (proof-to-formula proof)
	   (proof-in-impnc-intro-form-to-avar proof)
	   (goal-subst
	    (proof-in-impnc-intro-form-to-kernel proof) goal proof1)))
    ((proof-in-impnc-elim-form)
     (if (goal=? proof goal)
	 (append (list (tag proof1)
		       (proof-to-formula proof))
		 (cddr proof1))
	 (list
	  'proof-in-impnc-elim-form
	  (proof-to-formula proof)
	  (goal-subst (proof-in-impnc-elim-form-to-op proof) goal proof1)
	  (goal-subst (proof-in-impnc-elim-form-to-arg proof) goal proof1))))
    ((proof-in-and-intro-form)
     (list 'proof-in-and-intro-form
	   (proof-to-formula proof)
	   (goal-subst (proof-in-and-intro-form-to-left proof) goal proof1)
	   (goal-subst (proof-in-and-intro-form-to-right proof) goal proof1)))
    ((proof-in-and-elim-left-form)
     (list 'proof-in-and-elim-left-form
	   (proof-to-formula proof)
	   (goal-subst
	    (proof-in-and-elim-left-form-to-kernel proof) goal proof1)))
    ((proof-in-and-elim-right-form)
     (list 'proof-in-and-elim-right-form
	   (proof-to-formula proof)
	   (goal-subst
	    (proof-in-and-elim-right-form-to-kernel proof) goal proof1)))
    ((proof-in-all-intro-form)
     (list 'proof-in-all-intro-form
	   (proof-to-formula proof)
	   (proof-in-all-intro-form-to-var proof)
	   (goal-subst (proof-in-all-intro-form-to-kernel proof) goal proof1)))
    ((proof-in-all-elim-form)
     (if (goal=? proof goal)
	 (append (list (tag proof1)
		       (proof-to-formula proof))
		 (cddr proof1))
	 (list 'proof-in-all-elim-form
	       (proof-to-formula proof)
	       (goal-subst (proof-in-all-elim-form-to-op proof) goal proof1)
	       (proof-in-all-elim-form-to-arg proof))))
    ((proof-in-allnc-intro-form)
     (list 'proof-in-allnc-intro-form
	   (proof-to-formula proof)
	   (proof-in-allnc-intro-form-to-var proof)
	   (goal-subst
	    (proof-in-allnc-intro-form-to-kernel proof) goal proof1)))
    ((proof-in-allnc-elim-form)
     (if (goal=? proof goal)
	 (append (list (tag proof1)
		       (proof-to-formula proof))
		 (cddr proof1))
	 (list 'proof-in-allnc-elim-form
	       (proof-to-formula proof)
	       (goal-subst (proof-in-allnc-elim-form-to-op proof) goal proof1)
	       (proof-in-allnc-elim-form-to-arg proof))))
    (else (myerror "goal-subst" "proof expected" proof))))

; Initialization of global variables:

(define (make-pproof-state num-goals proof maxgoal)
  (list num-goals proof maxgoal))

(define PPROOF-STATE (make-pproof-state '() '() 1))
(define PPROOF-STATE-HISTORY '())
(define PPROOF-STATE-HISTORY-LENGTH 0)

(define (pproof-state-to-num-goals . x)
  (if (null? x) (car PPROOF-STATE) (car (car x))))

(define (pproof-state-to-proof . x)
  (if (null? x) (cadr PPROOF-STATE) (cadr (car x))))

(define (pproof-state-to-maxgoal . x)
  (if (null? x) (caddr PPROOF-STATE) (caddr (car x))))

(define (pproof-state-to-formula . x)
  (proof-to-formula (apply pproof-state-to-proof x)))

(define (current-proof) (cadr PPROOF-STATE))

(define (current-goal)
  (let ((num-goals (car PPROOF-STATE)))
    (if (null? num-goals)
	(begin (display-comment "Proof finished.")
	       (if COMMENT-STRING (newline)))
	(num-goal-to-goal (car num-goals)))))

(define (pproof-state-history-clear)
  (set! PPROOF-STATE-HISTORY '())
  (set! PPROOF-STATE-HISTORY-LENGTH 0))

(define (pproof-state-history-push state)
  (set! PPROOF-STATE-HISTORY (cons state PPROOF-STATE-HISTORY))
  (set! PPROOF-STATE-HISTORY-LENGTH (+ PPROOF-STATE-HISTORY-LENGTH 1)))

(define (pproof-state-history-head)
  (car PPROOF-STATE-HISTORY))

(define (pproof-state-history-pop n)
  (set! PPROOF-STATE-HISTORY (list-tail PPROOF-STATE-HISTORY n))
  (set! PPROOF-STATE-HISTORY-LENGTH
	(max (- PPROOF-STATE-HISTORY-LENGTH n) 0)))

; An interactive proof begins with setting an initial goal.  If the
; formula is not closed, the free variables are generalized.

(define (make-num-goal number goal drop-info hypname-info)
  (list number goal drop-info hypname-info))

(define num-goal-to-number car)
(define num-goal-to-goal cadr)
(define num-goal-to-drop-info caddr)
(define num-goal-to-hypname-info cadddr)

(define empty-drop-info '())
(define empty-hypname-info '())

(define (set-goal string-or-formula)
  (let ((formula (if (string? string-or-formula)
		     (pf string-or-formula)
		     string-or-formula)))
    (if (not (formula-form? formula))
	(myerror "set-goal" "formula expected" formula))
    (let* ((unfolded-formula (unfold-formula formula))
	   (free (formula-to-free unfolded-formula))
	   (closed-formula
	    (apply mk-all (append free (list unfolded-formula))))
	   (avar (formula-to-new-avar closed-formula DEFAULT-AVAR-NAME))
	   (goal (make-goal-in-avar-form avar))
	   (init-num-goal
	    (make-num-goal 1 goal empty-drop-info empty-hypname-info)))
      (if (formula-with-illegal-tensor? unfolded-formula)
	  (myerror "tensor ! should be used with excl or exca only"
		   formula))
      (set! PPROOF-STATE (make-pproof-state (list init-num-goal) goal 1))
      (pproof-state-history-clear)
      (pproof-state-history-push PPROOF-STATE)
      (display-num-goal init-num-goal))))

; An abbreviation for (set-goal (pf .)).  (sg .) expects as argument a
; list of strings.  This list will be concatenated and given
; (set-goal (pf .)) as argument.

(define (sg . formulastringlist)
  (letrec
      ((formel
        (lambda (fm)
          (cond ((= (length fm) 0) "F")
                ((= (length fm) 1) (car fm))
                (else (formel
		       (append
			(list (string-append (car fm) (cadr fm)))
			(cddr fm))))))))
    (set-goal (pf (formel formulastringlist)))))

; We initially supply our axioms as theorems, and also 
; Atom-True: all boole(boole -> boole=true)
; Atom-False: all boole((boole -> F) -> boole=false)
; Efq-Atom: all boole.F -> boole 
; Stab-Atom: all boole(((boole -> F) -> F) -> boole)

(define atom-true-proof
  (let ((var (type-to-new-var (py "boole"))))
    (make-proof-in-all-intro-form
     var
     (mk-proof-in-elim-form
      (make-proof-in-aconst-form
       (all-formula-to-cases-aconst
        (pf "all boole(boole -> boole=True)")))
      (make-term-in-var-form var)
      (let ((u1 (formula-to-new-avar (pf "T") "u")))
        (mk-proof-in-intro-form u1 (make-proof-in-avar-form u1)))
      (let ((u1 (formula-to-new-avar (pf "F") "u")))
        (mk-proof-in-intro-form u1 (make-proof-in-avar-form u1)))))))

(define atom-true-aconst
  (make-aconst "Atom-True" 'theorem
	       (pf "all boole(boole -> boole=True)")
	       empty-subst))  

(define atom-false-proof
  (let ((var (type-to-new-var (py "boole"))))
    (make-proof-in-all-intro-form
     var
     (mk-proof-in-elim-form
      (make-proof-in-aconst-form
       (all-formula-to-cases-aconst
        (pf "all boole((boole -> F) -> boole=False)")))
      (make-term-in-var-form var)
      (let ((u1 (formula-to-new-avar (pf "T -> F") "u")))
        (mk-proof-in-intro-form
         u1 (mk-proof-in-elim-form 
             (make-proof-in-avar-form u1)
             (make-proof-in-aconst-form truth-aconst))))
      (let ((u1 (formula-to-new-avar (pf "F -> F") "u")))
        (mk-proof-in-intro-form
	 u1 (make-proof-in-aconst-form truth-aconst)))))))

(define atom-false-aconst
  (make-aconst "Atom-False" 'theorem
	       (pf "all boole((boole -> F) -> boole=False)")
	       empty-subst))  

(define efq-atom-proof
  (let ((var (type-to-new-var (py "boole"))))
    (make-proof-in-all-intro-form
     var
     (mk-proof-in-elim-form
      (make-proof-in-aconst-form
       (all-formula-to-cases-aconst (pf "all boole(F -> boole)")))
      (make-term-in-var-form var)
      (let ((u1 (formula-to-new-avar (pf "F") "u")))
        (mk-proof-in-intro-form
         u1 (make-proof-in-aconst-form truth-aconst)))
      (let ((u1 (formula-to-new-avar (pf "F") "u")))
        (mk-proof-in-intro-form u1 (make-proof-in-avar-form u1)))))))

(define efq-atom-aconst
  (make-aconst "Efq-Atom" 'theorem
	       (pf "all boole(F -> boole)")
	       empty-subst))

(define stab-atom-proof
  (let ((var (type-to-new-var (py "boole"))))
    (mk-proof-in-elim-form
     (make-proof-in-aconst-form
      (all-formula-to-cases-aconst
       (pf "all boole(((boole -> F) -> F) -> boole)")))
     (make-term-in-var-form var)
     (let ((u1 (formula-to-new-avar (pf "(T -> F) -> F") "u")))
       (mk-proof-in-intro-form
        u1 (make-proof-in-aconst-form truth-aconst)))
     (let ((u1 (formula-to-new-avar (pf "(F -> F) -> F") "u"))
           (u2 (formula-to-new-avar (pf "F") "u")))
       (mk-proof-in-intro-form
        u1 (mk-proof-in-elim-form
            (make-proof-in-avar-form u1)
            (mk-proof-in-intro-form u2 (make-proof-in-avar-form u2))))))))

(define stab-atom-aconst
  (make-aconst "Stab-Atom" 'theorem
	       (pf "all boole(((boole -> F) -> F) -> boole)")
	       empty-subst))  

(define eq-compat-rev-proof
  (let* ((tvar (make-tvar -1 DEFAULT-TVAR-NAME))
	 (name (default-var-name tvar))
	 (var1 (make-var tvar 1 0 name))
	 (var2 (make-var tvar 2 0 name))
	 (varterm1 (make-term-in-var-form var1))
	 (varterm2 (make-term-in-var-form var2))
	 (pvar (make-pvar (make-arity tvar) -1 0 0 ""))
	 (eq-fla (make-eq varterm1 varterm2))
	 (fla2 (make-predicate-formula pvar varterm2))
	 (u1 (formula-to-new-avar eq-fla "u"))
	 (u2 (formula-to-new-avar fla2 "u")))    
  (mk-proof-in-nc-intro-form
   var1 var2
   (mk-proof-in-intro-form
    u1 u2
    (mk-proof-in-elim-form
     (make-proof-in-aconst-form eq-compat-aconst)
     varterm2 varterm1
     (mk-proof-in-elim-form
      (make-proof-in-aconst-form eq-symm-aconst)
      varterm1 varterm2 (make-proof-in-avar-form u1))
     (make-proof-in-avar-form u2))))))

(define eq-compat-rev-aconst
  (make-aconst "Eq-Compat-Rev" 'theorem
	       (proof-to-formula eq-compat-rev-proof)
	       empty-subst))  

(set!
 INITIAL-THEOREMS
 (list
  (list "Atom-True" atom-true-aconst atom-true-proof)
  (list "Atom-False" atom-false-aconst atom-false-proof)
  (list "Efq-Atom" efq-atom-aconst efq-atom-proof)
  (list "Stab-Atom" stab-atom-aconst stab-atom-proof)
  (list "Eq-Compat-Rev" eq-compat-rev-aconst eq-compat-rev-proof)
  (list "Truth-Axiom" truth-aconst (make-proof-in-aconst-form truth-aconst))
  (list "Eq-Refl" eq-refl-aconst (make-proof-in-aconst-form eq-refl-aconst))
  (list "Eq-Symm" eq-symm-aconst (make-proof-in-aconst-form eq-symm-aconst))
  (list "Eq-Trans" eq-trans-aconst
	(make-proof-in-aconst-form eq-trans-aconst))
  (list "Eq-Ext" ext-aconst (make-proof-in-aconst-form ext-aconst))
  (list "Eq-Compat" eq-compat-aconst
	(make-proof-in-aconst-form eq-compat-aconst))
  (list "Total" total-aconst (make-proof-in-aconst-form total-aconst))
  (list "Stotal" stotal-aconst (make-proof-in-aconst-form stotal-aconst))
  (list "InhabTotal" totalinhab-aconst
	(make-proof-in-aconst-form totalinhab-aconst))
  (list "Total-Pair" total-pair-aconst
	(make-proof-in-aconst-form total-pair-aconst))
  (list "Total-Proj" total-proj-aconst
	(make-proof-in-aconst-form total-proj-aconst))
  (list "All-AllPartial" all-allpartial-aconst
	(make-proof-in-aconst-form all-allpartial-aconst))
  (list "AllPartial-All" allpartial-all-aconst
	(make-proof-in-aconst-form allpartial-all-aconst))
  (list "Ex-ExPartial" ex-expartial-aconst
	(make-proof-in-aconst-form ex-expartial-aconst))
  (list "ExPartial-Ex" expartial-ex-aconst
	(make-proof-in-aconst-form expartial-ex-aconst))))

; The name STotal must be avoided, since it will be used to state that
; a constant S is total.


(set! THEOREMS INITIAL-THEOREMS)

; For reset we have to make sure that the predefined tokens remain intact.

(define (reset)
  (set! GENERIC-APPLICATION-TABLE
	INITIAL-GENERIC-APPLICATION-TABLE)
  (set! GENERIC-APPLICATION-SYNTAX-TABLE
	INITIAL-GENERIC-APPLICATION-SYNTAX-TABLE)
  (set! COMMENT-STRING         INITIAL-COMMENT-STRING)
  (set! COMMENT-FLAG           INITIAL-COMMENT-FLAG)
  (set! OLD-COMMENT-FLAG       INITIAL-OLD-COMMENT-FLAG)
  (set! COQ-GOAL-DISPLAY       INITIAL-COQ-GOAL-DISPLAY)
  (do ((l (map car TYPE-VARIABLES) (cdr l)))
      ((null? l))
    (if (not (string=? (car l) "alpha")) (remove-token (car l))))
  (set! TYPE-VARIABLES         INITIAL-TYPE-VARIABLES)
  (set! MAXTVARINDEX           INITIAL-MAXTVARINDEX)
  (set! TYPE-CONSTANTS         INITIAL-TYPE-CONSTANTS)
  (for-each remove-token (map car ALGEBRAS))
  (set! ALGEBRAS               INITIAL-ALGEBRAS)
  (set! OLD-ALGEBRAS           INITIAL-OLD-ALGEBRAS)
;   (set! TYPES-WITH-CANONICAL-INHABITANTS
; 	INITIAL-TYPES-WITH-CANONICAL-INHABITANTS)
  (set! INCREASING-ALGEBRAS-TO-COERCION-ALIST
	INITIAL-INCREASING-ALGEBRAS-TO-COERCION-ALIST)
  (set! DEFAULT-VAR-NAMES      INITIAL-DEFAULT-VAR-NAMES)
  (for-each remove-token (map car VARIABLES))
  (set! VARIABLES              INITIAL-VARIABLES)
  (set! VARIABLE-NAMES '())
  (set! MAXVARINDEX            INITIAL-MAXVARINDEX)
  (for-each remove-token (map car CONSTRUCTORS))
  (set! CONSTRUCTORS           INITIAL-CONSTRUCTORS)
  (for-each remove-token (map car PROGRAM-CONSTANTS))
  (set! PROGRAM-CONSTANTS      INITIAL-PROGRAM-CONSTANTS)
  (set! UNFOLDING-FLAG         INITIAL-UNFOLDING-FLAG)
  (set! DEFAULT-PVAR-NAMES     INITIAL-DEFAULT-PVAR-NAMES)
  (do ((l (map car PVAR-NAMES) (cdr l)))
      ((null? l))
    (if (not (string=? (car l) "bot")) (remove-token (car l))))
  (set! PVAR-NAMES             INITIAL-PVAR-NAMES)
  (set! MAXPVARINDEX           INITIAL-MAXPVARINDEX)
  (do ((l (map car PREDCONST-NAMES) (cdr l)))
      ((null? l))
    (if (and (not (string=? (car l) "Equal"))
	     (not (string=? (car l) "Total"))
	     (not (string=? (car l) "STotal")))
	(remove-token (car l))))
  (set! PREDCONST-NAMES        INITIAL-PREDCONST-NAMES)
  (set! PREDCONST-DISPLAY      INITIAL-PREDCONST-DISPLAY)
  (set! IDPREDCONST-DISPLAY    INITIAL-IDPREDCONST-DISPLAY)
  (for-each remove-token (map car IDS))
  (set! IDS                    INITIAL-IDS)
  (set! DISPLAY-FUNCTIONS      INITIAL-DISPLAY-FUNCTIONS)
  (set! MATCH-TREE-BOUND       INITIAL-MATCH-TREE-BOUND)
  (set! THEOREMS               INITIAL-THEOREMS)
  (set! GLOBAL-ASSUMPTIONS     INITIAL-GLOBAL-ASSUMPTIONS)
  (set! MAXAVARINDEX           INITIAL-MAXAVARINDEX)
  (set! ELIM-SEARCH-BOUND      INITIAL-ELIM-SEARCH-BOUND)
  (set! VERBOSE-SEARCH         INITIAL-VERBOSE-SEARCH)
  (set! PVAR-TO-TVAR-ALIST     INITIAL-PVAR-TO-TVAR-ALIST)
  (add-global-assumption
   "Efq-Log" (make-imp
	      (make-predicate-formula (make-pvar (make-arity) -1 1 1 "bot"))
	      (make-predicate-formula (make-pvar (make-arity) -1 0 0 ""))))
  (add-global-assumption
   "Stab-Log"
   (let ((bot (make-predicate-formula (make-pvar (make-arity) -1 1 1 "bot")))
	 (p (make-predicate-formula (make-pvar (make-arity) -1 0 0 ""))))
     (make-imp (make-imp (make-imp p bot) bot) p)))
  (add-alg "unit" '("Dummy" "unit"))
  (add-alg "boole" '("True" "boole") '("False" "boole"))
  (add-new-application
   (lambda (type) (equal? type (make-alg "boole")))
   (lambda (test alt1)
     (let* ((type (term-to-type alt1))
	    (var (type-to-new-var type)))
       (make-term-in-abst-form
	var (make-term-in-if-form
	     test (list alt1 (make-term-in-var-form var)))))))
  (add-display
   (py "boole")
   (lambda (term)
     (let ((op (term-in-app-form-to-final-op term))
	   (args (term-in-app-form-to-args term)))
       (if (and (term-in-const-form? op)
		(string=? "=" (const-to-name (term-in-const-form-to-const op)))
		(= 2 (length args)))
	   (list 'rel-op "="
		 (term-to-token-tree (car args))
		 (term-to-token-tree (cadr args)))
	   #f))))
  (add-display
   (py "boole")
   (lambda (term)
     (let ((op (term-in-app-form-to-final-op term))
	   (args (term-in-app-form-to-args term)))
       (if (and (term-in-const-form? op)
		(string=? "E" (const-to-name (term-in-const-form-to-const op)))
		(= 1 (length args)))
	   (list 'prefix-op "E" (term-to-token-tree (car args)))
	   #f))))
  (add-global-assumption
   "Efq" (make-imp
	  (make-atomic-formula
	   (make-term-in-const-form (constr-name-to-constr "False")))
	  (make-predicate-formula (make-pvar (make-arity) -1 0 0 ""))))
  (add-global-assumption
   "Stab"
   (let ((f (make-atomic-formula
	     (make-term-in-const-form (constr-name-to-constr "False"))))
	 (p (make-predicate-formula (make-pvar (make-arity) -1 0 0 ""))))
     (make-imp (make-imp (make-imp p f) f) p)))
  *the-non-printing-object*)

; To display a numbered goal we use display-num-goal.

(define DEFAULT-GOAL-NAME "?")

; For display purposes a num-goal has additional entries drop-info and
; hypname-info.  

; Format of drop-info: list of indices of hypotheses to be dropped
; Format of hypname-info: association list index - name

(define (add-hypname-info i string hypname-info)
  (if (is-used? string '() '())
      (myerror "add-hypname-info" "new string expected" string)
      (if (assoc string (map reverse hypname-info))
	  (myerror "add-hypname-info" "already a hypname" string)
	  (cons (list i string) hypname-info))))

(define (index-and-hypname-info-to-name i hypname-info)
  (let ((info (assoc i hypname-info)))
    (if info
	(cadr info)
	(myerror "index-and-hypname-info-to-name" "no name provided for "
		 i " in " hypname-info))))

(define (name-and-hypname-info-to-index string hypname-info)
  (let ((info (assoc string (map reverse hypname-info))))
    (if info
	(cadr info)
	(myerror "name-and-hypname-info-to-index" "no index provided for "
		 string " in " hypname-info))))

(define (hypname-info-to-indices hypname-info) (map car hypname-info))
(define (hypname-info-to-names hypname-info) (map cadr hypname-info))

; display-num-goal takes an optional argument as display function.
; The default is fold-formula.

(define (display-num-goal num-goal . x)
  (let ((f (if (null? x) 
	       fold-formula
	       (car x))))
    (display-num-goal-aux num-goal f)))

(define INITIAL-COQ-GOAL-DISPLAY #f)
(define COQ-GOAL-DISPLAY INITIAL-COQ-GOAL-DISPLAY)

(define (display-num-goal-aux num-goal f)
  (if
   COMMENT-FLAG
   (let* ((number (num-goal-to-number num-goal))
	  (goal (num-goal-to-goal num-goal))
	  (drop-info (num-goal-to-drop-info num-goal))
	  (hypname-info (num-goal-to-hypname-info num-goal))
	  (indices (hypname-info-to-indices hypname-info))
	  (context (goal-to-context goal))
	  (ncvars (goal-to-ncvars goal))
	  (formula (goal-to-formula goal))
	  (goal-name (string-append DEFAULT-GOAL-NAME "_"
				    (number-to-string number)))
	  (prefix (string-append goal-name ": ")))
     (if (not COQ-GOAL-DISPLAY)
	 (begin
	   (display-comment
	    prefix
	    (pretty-print-string (string-length prefix) 
				 (- pp-width (string-length COMMENT-STRING)) 
				 (f formula)))
	   (if (not (null? context))
	       (display " from"))		   
	   (newline)))
     (do ((c context (cdr c))
	  (i 1 (if (avar-form? (car c)) (+ 1 i) i))
	  (line "" line))
	 ((null? c) (if (> (string-length line) 0) 
			(begin (display-comment line) (newline))))
       (if (avar-form? (car c))
	   (if (not (member i drop-info))
	       (let* ((info (member i indices))
		      (string
		       (if info
			   (index-and-hypname-info-to-name
			    i hypname-info)
			   (number-to-string i))))
		 (set! line (string-append line "  " string ":"))
		 (if (> (* 3 (string-length line)) pp-width)
		     (begin
		       (display-comment line)
		       (newline)
		       (set! line "    ")))
		 (set! line (string-append 
			     line 
			     (pretty-print-string
			      (string-length line)
			      (- pp-width (string-length COMMENT-STRING))
			      (f (avar-to-formula (car c))))))
		 (if (pair? (cdr c))
		     (begin (display-comment line) (newline)
			    (set! line "")))))
	   (let* ((var (car c))
		  (varstring (var-to-string var))
		  (cv? (not (member var ncvars)))
		  (mod-varstring
		   (if cv?
		       varstring
		       (string-append "{" varstring "}"))))
	     (set! line (string-append line "  " mod-varstring)))))
     (if COQ-GOAL-DISPLAY
	 (begin
	   (display-comment
	    "-------------------------------------------------- " goal-name)
	   (newline)
	   (display-comment
            (string-append goal-name ":"
                           (pretty-print-string
			    (+ (string-length goal-name) 1)
			    (- pp-width (string-length COMMENT-STRING)) 
			    (f formula))))
	   (newline))))))

(define (display-current-goal)
  (if COMMENT-FLAG
      (if (null? (pproof-state-to-num-goals))
	  (begin (display-comment "Proof finished.") (newline))
	  (begin (display-comment "The current goal is ") (newline)
		 (display-num-goal (car (pproof-state-to-num-goals)))))))

(define (display-current-goal-with-normalized-formulas)
  (if COMMENT-FLAG
      (if (null? (pproof-state-to-num-goals))
	  (begin (display-comment "Proof finished.") (newline))
	  (begin 
	    (display-comment "The current goal with normalized formulas is ")
	    (newline)
	    (display-num-goal (car (pproof-state-to-num-goals))
			      normalize-formula)))))

(define dcg display-current-goal)
(define dcgnf display-current-goal-with-normalized-formulas)
      
(define (display-current-pproof-state . x)
  (if COMMENT-FLAG
      (let ((num-goals (apply pproof-state-to-num-goals x))
	    (formula (apply pproof-state-to-formula x)))
	(do ((c (reverse num-goals) (cdr c)))
	    ((null? c)
	     (display-comment (make-string 76 #\-)) (newline)
	     (display-comment) (dff formula) (newline))
	  (display-num-goal (car c))))))

(define (display-new-goals num-goals number)
  (if COMMENT-FLAG
      (let* ((l1 (length num-goals))
	     (l2 (length (pproof-state-to-num-goals)))
	     (new-num-goals
	      (list-head (pproof-state-to-num-goals) (- (+ l2 1) l1))))
	(if (pair? new-num-goals)
	    (begin (display-comment "ok, " DEFAULT-GOAL-NAME "_"
				    (number-to-string number)
				    " can be obtained from")
		   (for-each (lambda (g) (newline) (display-num-goal g))
			     (reverse new-num-goals)))
	    (begin
	      (display-comment "ok, " DEFAULT-GOAL-NAME "_"
			       (number-to-string number) " is proved.")
	      (if (null? (pproof-state-to-num-goals))
		  (begin (display "  Proof finished.") (newline))
		  (begin (display "  The active goal now is") (newline)
			 (display-num-goal
			  (car (pproof-state-to-num-goals))))))))))

; normalize-goal takes optional arguments.  If there are none, the
; goal formula and all hypotheses are normalized.  Otherwise exactly
; those among the hypotheses and the goal formula are normalized whose
; numbers (or names, or just #t for the goal formula) are listed as
; additional arguments.

; normalization of a goal is split into an internal and an external
; procedure.  The internal one receives the parts of a pproof-state
; and returns a new pproof-state.  The external one reads off these
; parts from PPROOF-STATE, and updates PPROOF-STATE as well as
; PPROOF-STATE-HISTORY.

(define (normalize-goal . ng-info)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal)))
    (set! PPROOF-STATE
	  (apply normalize-goal-intern
		 (append (list num-goals proof maxgoal) ng-info)))
    (pproof-state-history-push PPROOF-STATE)
    (display-comment "ok, the normalized goal is")
    (if COMMENT-FLAG (newline))
    (display-num-goal (car (pproof-state-to-num-goals)))))

(define (normalize-goal-intern num-goals proof maxgoal . ng-info)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (drop-info (num-goal-to-drop-info num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (indices (hypname-info-to-indices hypname-info))
	 (names (hypname-info-to-names hypname-info))
	 (goalvar (goal-to-goalvar goal))
	 (context (goal-to-context goal))
	 (normalized-context
	  (do ((l context (cdr l))
	       (i 1 (if (avar-form? (car l)) (+ 1 i) i))
	       (res '() (if (and
			     (avar-form? (car l))
			     (or (null? ng-info)
				 (member i ng-info)
				 (and (member i indices)
				      (member (index-and-hypname-info-to-name
					       i hypname-info)
					      ng-info))))
			    (cons (normalize-avar (car l)) res)
			    (cons (car l) res))))
	      ((null? l) (reverse res))))
	 (new-goal
	  (apply mk-goal-in-elim-form
		 (cons (make-goal-in-avar-form
			(if
			 (or (null? ng-info)
			     (pair? (intersection ng-info (list number #t))))
			 (normalize-avar goalvar)
			 goalvar))
		       normalized-context)))
	 (new-num-goal
	  (make-num-goal (+ 1 maxgoal) new-goal drop-info hypname-info)))
    (make-pproof-state (cons new-num-goal (cdr num-goals))
		       proof
		       (+ 1 maxgoal))))

(define ng normalize-goal)

; With (assume x1 ...) we can move universally quantified variables and
; hypotheses into the context.  The variables must be given names (known
; to the parser as valid variable names for the given type), and the
; hypotheses should be identified by numbers or strings.

; Internally, assume extends the partial proof under construction by
; intros.  To every quantifier all x (resp. allnc y) in the present goal
; corresponds an application of all-intro (resp. allnc-intro) rule.  To
; meet the variable condition for allnc-intro rules, the allnc-variable
; y in the assumed context is not admitted as a computational variable
; in a future proof of the present goal.  Therefore it is displayed in
; braces, as {y}.

(define (assume . x-list)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal)))
    (set! PPROOF-STATE (apply assume-intern
			      (append (list num-goals proof maxgoal) x-list)))
    (pproof-state-history-push PPROOF-STATE)
    (display-comment "ok, we now have the new goal ")
    (if COMMENT-FLAG (newline))
    (display-num-goal (car (pproof-state-to-num-goals)))))

(define (assume-intern num-goals proof maxgoal . x-list)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (drop-info (num-goal-to-drop-info num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (formula (goal-to-formula goal)))
    (do ((l x-list (cdr l))
	 (nc-and-np-and-ng-and-nh
	  (list '() goal goal hypname-info)
	  (let* ((x1 (car l))
		 (nc (car nc-and-np-and-ng-and-nh)) ;new context
		 (np (cadr nc-and-np-and-ng-and-nh)) ;new proof
		 (ng (caddr nc-and-np-and-ng-and-nh)) ;new goal
		 (nh (cadddr nc-and-np-and-ng-and-nh)) ;new hypname-info
		 (nf (proof-to-formula ng)))
	    (case (tag nf)
	      ((all)
	       (let* ((var (all-form-to-var nf))
		      (type (var-to-type var))
		      (t-deg (var-to-t-deg var))
		      (userstring
		       (if (string? x1) x1
			   (myerror "assume" "string expected" x1)))
		      (userterm (pt x1))
		      (uservar (if (term-in-var-form? userterm)
				   (term-in-var-form-to-var userterm)
				   (myerror "assume" "variable expected"
					    x1)))
		      (usertype (var-to-type uservar))
		      (user-t-deg (var-to-t-deg uservar)))
		 (cond
		  ((not (equal? type usertype))
		   (myerror "assume" "variables of the same type expected"
			    uservar var))
		  ((not (equal? t-deg user-t-deg))
		   (myerror "assume" "variables of the same t-deg expected"
			    uservar var))
		  ((or (member uservar (context-to-vars context))
		       (member uservar (context-to-vars nc)))
		   (myerror "assume" "new variable expected" uservar))
		  ((not (equal? uservar var)) ;then rename
		   (let ((ng1 (make-goal-in-all-elim-form ng uservar)))
		     (list
		      (cons uservar nc)
		      (goal-subst np ng (make-proof-in-all-intro-form 
					 uservar ng1))
		      ng1 nh)))
		  (else
		   (let ((ng1 (make-goal-in-all-elim-form ng var)))
		     (list
		      (cons var nc)
		      (goal-subst np ng (make-proof-in-all-intro-form var ng1))
		      ng1 nh))))))
	      ((allnc)
	       (let* ((var (allnc-form-to-var nf))
		      (type (var-to-type var))
		      (t-deg (var-to-t-deg var))
		      (userstring
		       (if (string? x1) x1
			   (myerror "assume" "string expected" x1)))
		      (userterm (pt x1))
		      (uservar (if (term-in-var-form? userterm)
				   (term-in-var-form-to-var userterm)
				   (myerror "assume" "variable expected" x1)))
		      (usertype (var-to-type uservar))
		      (user-t-deg (var-to-t-deg uservar)))
		 (cond
		  ((not (equal? type usertype))
		   (myerror "assume" "variables of the same type expected"
			    uservar var))
		  ((not (equal? t-deg user-t-deg))
		   (myerror "assume" "variables of the same t-deg expected"
			    uservar var))
		  ((or (member uservar (context-to-vars context))
		       (member uservar (context-to-vars nc)))
		   (myerror "assume" "new variable expected" uservar))
		  ((not (equal? uservar var)) ;then rename
		   (let ((ng1 (make-goal-in-allnc-elim-form ng uservar)))
		     (list
		      (cons uservar nc)
		      (goal-subst np ng (make-proof-in-allnc-intro-form 
					 uservar ng1))
		      ng1 nh)))
		  (else
		   (let ((ng1 (make-goal-in-allnc-elim-form ng var)))
		     (list
		      (cons var nc)
		      (goal-subst
		       np ng (make-proof-in-allnc-intro-form var ng1))
		      ng1 nh))))))
	      ((imp)
	       (let* ((premise (imp-form-to-premise nf))
		      (name (if (string? x1) x1 DEFAULT-AVAR-NAME))
		      (avar (formula-to-new-avar premise name))
		      (ng1 (make-goal-in-imp-elim-form ng avar))
		      (hypnumber (+ (length (context-to-avars context))
				    (length (context-to-avars nc))))
		      (nh1 (if (string? x1)
			       (add-hypname-info (+ 1 hypnumber) x1 nh)
			       nh)))
		 (list
		  (cons avar nc)
		  (goal-subst np ng (make-proof-in-imp-intro-form avar ng1))
		  ng1 nh1)))
	      ((impnc)
	       (let* ((premise (impnc-form-to-premise nf))
		      (name (if (string? x1) x1 DEFAULT-AVAR-NAME))
		      (avar (formula-to-new-avar premise name))
		      (ng1 (make-goal-in-impnc-elim-form ng avar))
		      (hypnumber (+ (length (context-to-avars context))
				    (length (context-to-avars nc))))
		      (nh1 (if (string? x1)
			       (add-hypname-info (+ 1 hypnumber) x1 nh)
			       nh)))
		 (list
		  (cons avar nc)
		  (goal-subst np ng (make-proof-in-impnc-intro-form avar ng1))
		  ng1 nh1)))
	      ((exca)
	       (let* ((vars (exca-form-to-vars nf))
		      (kernel (exca-form-to-kernel nf))
		      (premise
		       (apply mk-all
			      (append vars
				      (list
				       (apply mk-imp
					      (append
					       (tensor-form-to-parts
						kernel)
					       (list falsity)))))))
		      (name (if (string? x1) x1 DEFAULT-AVAR-NAME))
		      (avar (formula-to-new-avar premise name))
		      (ng1 (make-goal-in-imp-elim-form ng avar))
		      (hypnumber (+ (length (context-to-avars context))
				    (length (context-to-avars nc))))
		      (nh1 (if (string? x1)
			       (add-hypname-info (+ 1 hypnumber) x1 nh)
			       nh)))
		 (list
		  (cons avar nc)
		  (goal-subst np ng (make-proof-in-imp-intro-form avar ng1))
		  ng1 nh1)))
	      ((excl)
	       (let* ((vars (excl-form-to-vars nf))
		      (kernel (excl-form-to-kernel nf))
		      (premise
		       (apply mk-all
			      (append vars
				      (list
				       (apply mk-imp
					      (append
					       (tensor-form-to-parts
						kernel)
					       (list falsity-log)))))))
		      (name (if (string? x1) x1 DEFAULT-AVAR-NAME))
		      (avar (formula-to-new-avar premise name))
		      (ng1 (make-goal-in-imp-elim-form ng avar))
		      (hypnumber (+ (length (context-to-avars context))
				    (length (context-to-avars nc))))
		      (nh1 (if (string? x1)
			       (add-hypname-info (+ 1 hypnumber) x1 nh)
			       nh)))
		 (list
		  (cons avar nc)
		  (goal-subst np ng (make-proof-in-imp-intro-form avar ng1))
		  ng1 nh1)))
	      ((atom)
	       (cond
		((term=?
		  (make-term-in-const-form
		   (pconst-name-to-pconst "ImpConst"))
		  (term-in-app-form-to-final-op (atom-form-to-kernel nf)))
		 (let* ((kernel (atom-form-to-kernel nf))
			(args (term-in-app-form-to-args kernel))
			(arg1 (if (= 2 (length args))
				  (car args)
				  (myerror "two args expected")))
			(arg2 (cadr args))
			(prem (make-atomic-formula arg1))
			(concl (make-atomic-formula arg2))
			(name (if (string? x1) x1 DEFAULT-AVAR-NAME))
			(avar (formula-to-new-avar prem name))
			(hypnumber (+ (length (context-to-avars context))
				      (length (context-to-avars nc))))
			(nh1 (if (string? x1)
				 (add-hypname-info (+ 1 hypnumber) x1 nh)
				 nh))
			(context (goal-to-context ng))
			(cvars (goal-to-cvars ng))
			(new-goalformula
			 (context-and-cvars-and-formula-to-formula
			  (append context (list avar)) cvars concl))
			(new-goalvar (formula-to-new-avar
				      new-goalformula DEFAULT-AVAR-NAME))
			(ng1 (apply mk-goal-in-elim-form
				    (append (list (make-goal-in-avar-form
						   new-goalvar))
					    context
					    (list avar)))))
		   (list
		    (cons avar nc)
		    (goal-subst np ng (mk-proof-in-elim-form
				       imp-to-atom-proof
				       arg1 arg2 (make-proof-in-imp-intro-form
						  avar ng1)))
		    ng1 nh1)))
		(else (myerror "assume" "unexpected atom" nf))))
	      (else (myerror "assume" "formula"
			     nf
			     "not of the appropriate form to assume"
			     x1))))))
	((null? l)
	 (let* ((np (cadr nc-and-np-and-ng-and-nh))
		(ng (caddr nc-and-np-and-ng-and-nh))
		(nh (cadddr nc-and-np-and-ng-and-nh))
		(new-num-goal (make-num-goal (+ 1 maxgoal) ng drop-info nh)))
	   (make-pproof-state (cons new-num-goal (cdr num-goals))
			      (goal-subst proof goal np)
			      (+ 1 maxgoal)))))))

; We prove "(boole1 -> boole2) -> boole1 impb boole2" from cases axioms

; "(all boole2.(T -> boole2) -> True impb boole2) -> 
;  (all boole2.(F -> boole2) -> False impb boole2) -> 
;  all boole10,boole2.(boole10 -> boole2) -> boole10 impb boole2"

(define imp-to-atom-proof
  (let ((var1 (type-to-new-var (py "boole")))
        (var2 (type-to-new-var (py "boole")))
        (var3 (type-to-new-var (py "boole"))))
    (make-proof-in-all-intro-form
     var1
     (mk-proof-in-elim-form
      (make-proof-in-aconst-form
       (all-formula-to-cases-aconst
        (pf
	 "all boole1,boole2((boole1 -> boole2) -> ImpConst boole1 boole2)")))
      (make-term-in-var-form var1)
      (make-proof-in-all-intro-form
       var2
       (mk-proof-in-elim-form
        (make-proof-in-aconst-form
         (all-formula-to-cases-aconst
          (pf "all boole2((T -> boole2) -> ImpConst True boole2)")))
        (make-term-in-var-form var2)
        (mk-proof-in-intro-form
         (formula-to-new-avar (pf "T -> T")) 
         (make-proof-in-aconst-form truth-aconst))
        (let ((u (formula-to-new-avar (pf "T -> F"))))
          (mk-proof-in-intro-form
           u (make-proof-in-imp-elim-form
              (make-proof-in-avar-form u)
              (make-proof-in-aconst-form truth-aconst))))))
      (make-proof-in-all-intro-form
       var3
       (mk-proof-in-elim-form
	(make-proof-in-aconst-form
	 (all-formula-to-cases-aconst
	  (pf "all boole2((F -> boole2) -> ImpConst False boole2)")))
	(make-term-in-var-form var3)
	(mk-proof-in-intro-form
	 (formula-to-new-avar (pf "F -> T")) 
	 (make-proof-in-aconst-form truth-aconst))
	(mk-proof-in-intro-form
	 (formula-to-new-avar (pf "F -> F")) 
	 (make-proof-in-aconst-form truth-aconst))))))))

; In the following definition of use x is one of the following.
; - A number or string identifying a hypothesis form the context.
; - The name of a theorem or global assumption.
; - A closed proof.
; - A formula with free variables from the context, generating a new goal.
; It is checked whether some final part of this used formula has the
; form of the goal, in the sense of first order matching and - if this
; fails - second order matching.  Substitution for the pvar bot from
; falsity-log is excluded.  elab-path-and-terms is a list consisting
; of symbols left or right, giving directions in case the used formula
; contains conjunctions, and of terms/cterms to be substituted for the
; variables that cannot be instantiated by matching.

(define (use x . elab-path-and-terms)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply use-intern (append (list num-goals proof maxgoal x)
				    elab-path-and-terms)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (use-intern num-goals proof maxgoal x . elab-path-and-terms)
  (let* ((num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (context (goal-to-context goal))
	 (cvars (goal-to-cvars goal))
	 (goal-formula (goal-to-formula goal))
	 (leaf (if (formula-form? x)
		   (context-and-cvars-and-formula-to-new-goal
		    context cvars x)
		   (hyp-info-to-leaf num-goal x)))
 	 (used-formula
	  (unfold-formula (if (formula-form? x) x (proof-to-formula leaf))))
	 (sig-vars (context-to-vars context))
	 (sig-tvars-and-sig-vars
	  (if (or (and (string? x) (assoc x THEOREMS))
		  (and (string? x) (assoc x GLOBAL-ASSUMPTIONS))
		  (proof-form? x))
	      sig-vars
	      (append (formula-to-tvars used-formula) sig-vars)))
	 (elab-path (do ((l elab-path-and-terms (cdr l))
			 (res '() (if (memq (car l) '(left right))
				      (cons (car l) res)
				      res)))
			((null? l) (reverse res))))
	 (tvars (formula-to-tvars used-formula))
	 (goal-tvars (formula-to-tvars goal-formula))
	 (clash-of-tvars?
	  (and (or (and (string? x) (assoc x THEOREMS))
		   (and (string? x) (assoc x GLOBAL-ASSUMPTIONS))
		   (proof-form? x))
	       (pair? (intersection tvars goal-tvars))))
	 (new-x ;to let match work correctly in case of clash of tvars
	  (if
	   clash-of-tvars? ;else x
	   (let* ((proof (if (proof-form? x) x (thm-or-ga-name-to-proof x)))
		  (new-tvars (map (lambda (x) (new-tvar)) tvars))
		  (renaming-tsubst
		   (map (lambda (x y) (list x y)) tvars new-tvars)))
	     (proof-substitute proof renaming-tsubst))
	   x))
	 (new-used-formula (if clash-of-tvars?
			       (proof-to-formula new-x)
			       used-formula))
	 (x-list-and-vars-and-alist-and-toinst1
	  (apply fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data
		 (append
		  (list new-used-formula sig-tvars-and-sig-vars goal-formula)
		  elab-path)))
	 (nfla-and-ngoal
	  (if x-list-and-vars-and-alist-and-toinst1
	      #f ;no normalization needed
	      (list (normalize-formula new-used-formula)
		    (normalize-formula goal-formula))))
	 (x-list-and-vars-and-alist-and-toinst
	  (or x-list-and-vars-and-alist-and-toinst1
	      (apply
	       fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data
	       (append (list (car nfla-and-ngoal)
			     sig-tvars-and-sig-vars
			     (cadr nfla-and-ngoal))
		       elab-path)))))
    (if
     x-list-and-vars-and-alist-and-toinst ;succeed with first-order-match
     (let* ((x-list (car x-list-and-vars-and-alist-and-toinst))
	    (uninst-vars (cadr x-list-and-vars-and-alist-and-toinst))
	    (uninst-to-renamed-old-vars-alist ;for error messages only
	     (caddr x-list-and-vars-and-alist-and-toinst))
	    (toinst (cadddr x-list-and-vars-and-alist-and-toinst))
	    (uninst-to-old-vars-alist ;for error messages only
	     (if clash-of-tvars? ;else uninst-to-renamed-old-vars-alist
		 (map (lambda (p)
			(let* ((uninst-var (car p))
			       (renamed-old-var (cadr p))
			       (info (assoc renamed-old-var 
					    (alpha-equal-formulas-to-renaming
					     new-used-formula used-formula))))
			  (list uninst-var
				(if info
				    (cadr info)
				    renamed-old-var))))
		      uninst-to-renamed-old-vars-alist)
		 uninst-to-renamed-old-vars-alist))
	    (terms (list-transform-positive elab-path-and-terms
		     term-form?))
	    (subst (if (<= (length uninst-vars) (length terms))
		       (map (lambda (x y) (list x y))
			    uninst-vars (list-head terms (length uninst-vars)))
		       empty-subst))
	    (subst-x-list (map (lambda (x) (if (term-form? x)
					       (term-substitute x subst)
					       x))
			       x-list))
	    (types
	     (let ((tsubst (list-transform-positive toinst
			     (lambda (x) (tvar-form? (car x))))))
	       (if (and (or (and (string? new-x)
				 (assoc new-x THEOREMS))
			    (and (string? new-x)
				 (assoc new-x GLOBAL-ASSUMPTIONS))
			    (proof-form? new-x))
			(pair? tsubst)) ;else '()
		   (let* ((proof (if (proof-form? new-x) new-x
				     (thm-or-ga-name-to-proof new-x)))
			  (fla (proof-to-formula proof))
			  (tvars (formula-to-tvars fla)))
		     (map (lambda (tvar) (type-substitute tvar tsubst))
			  tvars))
		   '()))))
       (if (> (length uninst-vars) (length terms))
	   (apply
	    myerror
	    (append (list
		     "use" "more terms expected, to be substituted for")
		    (map
		     (lambda (x)
		       (cadr (assoc x uninst-to-old-vars-alist)))
		     (list-tail uninst-vars (length terms))))))
       (if (and COMMENT-FLAG (< (length uninst-vars) (length terms)))
	   (begin
	     (comment "warning: superfluous terms")
	     (for-each comment
		       (map term-to-string
			    (list-tail terms (length uninst-vars))))))
       (apply use-with-intern
	      (append
	       (list num-goals proof maxgoal new-x) types subst-x-list)))
					;else try 2nd order matching
     (apply use2-intern
	    (append (list num-goals proof maxgoal x goal-formula used-formula
			  sig-vars nfla-and-ngoal)
		    elab-path-and-terms)))))

; fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data is #f if the
; used-formula is not a pattern for the goal formula.  Otherwise the
; following data are returned: (1) the arguments x-list for the
; hypothesis x, that produce via instantiation the goal formula, (2)
; vars (from x-list) whose instantiations cannot be inferred, hence
; need to be provided by the user, (3) an association list storing the
; renaming of vars done, and (4) a type substitution plus object
; instantiation, that turns the used-formula into the goal formula.

(define (fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data
	 used-formula sig-tvars-and-sig-vars goal-formula . elab-path)
  (let ((match-res (apply match (cons used-formula
				      (cons goal-formula
					    sig-tvars-and-sig-vars)))))
    (if
     match-res
     (list '() '() '() match-res)
     (cond
      ((or (prime-predicate-form? used-formula)
	   (ex-form? used-formula)
	   (exnc-form? used-formula)
	   (exd-form? used-formula)
	   (exl-form? used-formula)
	   (exr-form? used-formula)
	   (exu-form? used-formula)
	   (exdt-form? used-formula) 
	   (exlt-form? used-formula)
	   (exrt-form? used-formula)
	   (exut-form? used-formula)) #f)
      ((or (imp-form? used-formula) (impnc-form? used-formula))
       (let* ((concl (bicon-form-to-right used-formula))
	      (prev (apply
		     fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data
		     (append (list concl sig-tvars-and-sig-vars goal-formula)
			     elab-path))))
	 (if (not prev)
	     #f
	     (let* ((x-list (car prev))
		    (vars (cadr prev))
		    (vars-to-old-vars-alist (caddr prev))
		    (toinst (cadddr prev)))
	       (list (cons DEFAULT-GOAL-NAME x-list) vars
		     vars-to-old-vars-alist toinst)))))
      ((or (all-form? used-formula) (allnc-form? used-formula))
       (let* ((var (car (quant-form-to-vars used-formula)))
	      (kernel (quant-form-to-kernel used-formula))
	      (new-var (var-to-new-var var))
	      (new-kernel
	       (formula-subst kernel var (make-term-in-var-form new-var)))
	      (prev
	       (apply
		fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data
		(append (list new-kernel sig-tvars-and-sig-vars goal-formula)
			elab-path))))
	 (if (not prev)
	     #f
	     (let* ((x-list (car prev))
		    (vars (cadr prev))
		    (vars-to-old-vars-alist (caddr prev))
		    (toinst (cadddr prev))
		    (info (assoc new-var toinst)))
	       (if 
		info ;instance found by matching
		(list ;insert instance into x-list
		 (cons (cadr info) x-list)
		 vars
		 (cons (list new-var var) vars-to-old-vars-alist)
		 toinst)
		(list ;else insert new-var into x-list, and new-var to vars
		 (cons (make-term-in-var-form new-var) x-list)
		 (cons new-var vars)
		 (cons (list new-var var) vars-to-old-vars-alist)
		 toinst))))))
      ((and (bicon-form? used-formula)
	    (memq (bicon-form-to-bicon used-formula)
		  '(and andd andl andr andu)))
       (let ((left-conjunct (bicon-form-to-left used-formula))
	     (right-conjunct (bicon-form-to-right used-formula)))
	 (if
	  (pair? elab-path)
	  (let* ((direction (car elab-path))
		 (conjunct (cond ((eq? 'left direction) left-conjunct)
				 ((eq? 'right direction) right-conjunct)
				 (else (myerror "left or right expected"
						direction))))
		 (prev
		  (apply
		   fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data
		   (append (list conjunct sig-tvars-and-sig-vars goal-formula)
			   (cdr elab-path)))))
	    (if (not prev)
		#f
		(let* ((x-list (car prev))
		       (vars (cadr prev))
		       (vars-to-old-vars-alist (caddr prev))
		       (toinst (cadddr prev)))
		  (list (cons direction x-list) vars
			vars-to-old-vars-alist toinst))))
	  (let ((prev1
		 (fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data
		  left-conjunct sig-tvars-and-sig-vars goal-formula)))
	    (if
	     prev1
	     (let* ((x-list (car prev1))
		    (vars (cadr prev1))
		    (vars-to-old-vars-alist (caddr prev1))
		    (toinst (cadddr prev1)))
	       (list (cons 'left x-list) vars
		     vars-to-old-vars-alist toinst))
	     (let ((prev2
		    (fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data
		     right-conjunct sig-tvars-and-sig-vars goal-formula)))
	       (if prev2
		   (let* ((x-list (car prev2))
			  (vars (cadr prev2))
			  (vars-to-old-vars-alist (caddr prev2))
			  (toinst (cadddr prev2)))
		     (list (cons 'right x-list) vars
			   vars-to-old-vars-alist toinst))
		   #f)))))))
      ((atom-form? used-formula)
       (cond
	((term=?
	  (make-term-in-const-form
	   (pconst-name-to-pconst "ImpConst"))
	  (term-in-app-form-to-final-op (atom-form-to-kernel
					 used-formula)))
	 (let* ((kernel (atom-form-to-kernel used-formula))
		(args (term-in-app-form-to-args kernel))
		(arg1
		 (if (= 2 (length args))
		     (car args)
		     (myerror
		      "fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data"
		      "two args expected")))
		(arg2 (cadr args))
		(prem (make-atomic-formula arg1))
		(concl (make-atomic-formula arg2))
		(prev
		 (apply
		  fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data
		  (append (list concl sig-tvars-and-sig-vars goal-formula)
			  elab-path))))
	   (if (not prev)
	       #f
	       (let* ((x-list (car prev))
		      (vars (cadr prev))
		      (vars-to-old-vars-alist (caddr prev))
		      (toinst (cadddr prev)))
		 (list (cons DEFAULT-GOAL-NAME x-list) vars
		       vars-to-old-vars-alist toinst)))))
	((term=?
	  (make-term-in-const-form
	   (pconst-name-to-pconst "AndConst"))
	  (term-in-app-form-to-final-op (atom-form-to-kernel
					 used-formula)))
	 (let* ((kernel (atom-form-to-kernel used-formula))
		(args (term-in-app-form-to-args kernel))
		(left-arg (if (= 2 (length args))
			      (car args)
			      (myerror "two args expected")))
		(right-arg (cadr args))
		(left-conjunct (make-atomic-formula left-arg))
		(right-conjunct (make-atomic-formula right-arg)))
	   (if
	    (pair? elab-path)
	    (let* ((direction (car elab-path))
		   (conjunct (cond ((eq? 'left direction) left-conjunct)
				   ((eq? 'right direction) right-conjunct)
				   (else (myerror "left or right expected"
						  direction))))
		   (prev (apply
			  fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data
			  (append
			   (list conjunct sig-tvars-and-sig-vars goal-formula)
			   (cdr elab-path)))))
	      (if (not prev)
		  #f
		  (let* ((x-list (car prev))
			 (vars (cadr prev))
			 (vars-to-old-vars-alist (caddr prev))
			 (toinst (cadddr prev)))
		    (list (cons direction x-list) vars
			  vars-to-old-vars-alist toinst))))
	    (let ((prev1
		   (fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data
		    left-conjunct sig-tvars-and-sig-vars goal-formula)))
	      (if
	       prev1
	       (let* ((x-list (car prev1))
		      (vars (cadr prev1))
		      (vars-to-old-vars-alist (caddr prev1))
		      (toinst (cadddr prev1)))
		 (list (cons 'left x-list) vars
		       vars-to-old-vars-alist toinst))
	       (let ((prev2
		      (fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data
		       right-conjunct sig-tvars-and-sig-vars goal-formula)))
		 (if prev2
		     (let* ((x-list (car prev2))
			    (vars (cadr prev2))
			    (vars-to-old-vars-alist (caddr prev2))
			    (toinst (cadddr prev2)))
		       (list (cons 'right x-list) vars
			     vars-to-old-vars-alist toinst))
		     #f)))))))
	(else #f)))
      (else (myerror "fla-and-sig-tvars-and-vars-and-goal-fla-to-use-data"
		     "formula expected"
		     used-formula))))))

; In the following definition of use2 x is one of the following.
; - A number or string identifying a hypothesis form the context.
; - The name of a theorem or global assumption.  If it is a global 
;   assumption whose final conclusion is a nullary predicate variable 
;   distinct from bot (e.g. Efq-Log or Stab-Log), this predicate variable 
;   is substituted by the goal formula.
; - A closed proof.
; - A formula with free variables from the context, generating a new goal.

; Moreover elab-path-and-terms is a list consisting of symbols left or
; right, and of terms/cterms to be substituted for the vars/pvars that
; cannot be instantiated by matching (e.g. using all x(P x -> bot) for
; goal bot.  (use2 x . elab-path-and-terms) is defined via use-with.

(define (use2 x . elab-path-and-terms)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals)))
	 (num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (context (goal-to-context goal))
	 (cvars (goal-to-cvars goal))
	 (goal-formula (goal-to-formula goal))
	 (leaf (if (formula-form? x)
		   (context-and-cvars-and-formula-to-new-goal
		    context cvars x)
		   (hyp-info-to-leaf num-goal x)))
 	 (used-formula
	  (unfold-formula (if (formula-form? x) x (proof-to-formula leaf))))
	 (sig-vars (context-to-vars context))
	 (nfla-and-ngoal #f)) ;no normalization, since use-intern omitted
    (set! PPROOF-STATE
	  (apply use2-intern
		 (append (list num-goals proof maxgoal x
			       goal-formula used-formula
			       sig-vars nfla-and-ngoal)
			 elab-path-and-terms)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (use2-intern num-goals proof maxgoal x goal-formula used-formula
		     sig-vars nfla-and-ngoal . elab-path-and-terms)
  (let* ((pvars (formula-to-pvars used-formula))
	 (goal-pvars (formula-to-pvars goal-formula))
	 (tvars (formula-to-tvars used-formula))
	 (goal-tvars (formula-to-tvars goal-formula))
	 (clash-of-pvars?
	  (and (or (and (string? x) (assoc x THEOREMS))
		   (and (string? x) (assoc x GLOBAL-ASSUMPTIONS))
		   (proof-form? x))
	       (pair? (intersection pvars goal-pvars))))
	 (sig-topvars
	  (if (or (proof-form? x)
		  (assoc x (append THEOREMS GLOBAL-ASSUMPTIONS)))
	      (append sig-vars
		      (list (predicate-form-to-predicate falsity-log)))
	      (append tvars sig-vars pvars)))
	 (elab-path (do ((l elab-path-and-terms (cdr l))
			 (res '() (if (memq (car l) '(left right))
				      (cons (car l) res)
				      res)))
			((null? l) (reverse res))))
	 (new-x-and-pvars ;to let match2 work correctly if clash of pvars
	  (if
	   clash-of-pvars? ;else x
	   (let* ((proof (if (proof-form? x) x (thm-or-ga-name-to-proof x)))
		  (new-pvars (map pvar-to-new-pvar pvars))
		  (renaming-psubst
		   (map (lambda (pvar new-pvar)
			  (list pvar (predicate-to-cterm new-pvar)))
			pvars new-pvars)))
	     (list (proof-substitute proof renaming-psubst)
		   new-pvars))
	   (list x pvars)))
	 (new-x (car new-x-and-pvars))
	 (new-used-formula (if clash-of-pvars?
			       (proof-to-formula new-x)
			       used-formula))
	 (x-list-and-vars-and-alist-and-topinst1
	  (apply fla-and-sig-topvars-and-goal-fla-to-use2-data
		 (append (list new-used-formula sig-topvars goal-formula)
			 elab-path)))
	 (new-nfla-and-ngoal 
	  (if x-list-and-vars-and-alist-and-topinst1
	      #f ;if no normalization needed 
	      (if (and (not clash-of-pvars?) nfla-and-ngoal)
		  nfla-and-ngoal
		  (list (normalize-formula new-used-formula)
			(normalize-formula goal-formula)))))
	 (x-list-and-vars-and-alist-and-topinst
	  (or x-list-and-vars-and-alist-and-topinst1
	      (let* ((normalized-new-used-formula
		      (if new-nfla-and-ngoal (car new-nfla-and-ngoal)
			  (normalize-formula new-used-formula)))
		     (normalized-goal-formula
		      (if new-nfla-and-ngoal (cadr new-nfla-and-ngoal)
			  (normalize-formula goal-formula))))
		(apply fla-and-sig-topvars-and-goal-fla-to-use2-data
		       (append (list normalized-new-used-formula sig-topvars
				     normalized-goal-formula)
			       elab-path))))))
    (if
     x-list-and-vars-and-alist-and-topinst
     (let* ((x-list (car x-list-and-vars-and-alist-and-topinst))
	    (uninst-vars (cadr x-list-and-vars-and-alist-and-topinst))
	    (uninst-to-old-vars-alist
	     (caddr x-list-and-vars-and-alist-and-topinst))
	    (topinst (cadddr x-list-and-vars-and-alist-and-topinst))
	    (new-pvars (cadr new-x-and-pvars))
	    (uninst-pvars
	     (list-transform-positive new-pvars
	       (lambda (pvar) (not (assoc pvar topinst)))))
	    (new-to-old-pvars-alist
	     (map (lambda (x y) (list x y)) new-pvars pvars))
	    (user-terms
	     (list-transform-positive elab-path-and-terms term-form?))
	    (user-cterms
	     (list-transform-positive elab-path-and-terms cterm-form?))
	    (subst (if (<= (length uninst-vars) (length user-terms))
		       (map (lambda (x y) (list x y))
			    uninst-vars
			    (list-head user-terms (length uninst-vars)))
		       empty-subst))
	    (subst-x-list (map (lambda (x) (if (term-form? x)
					       (term-substitute x subst)
					       x))
			       x-list))
	    (types
	     (let ((tsubst (list-transform-positive topinst
			     (lambda (x) (tvar-form? (car x))))))
	       (if (and (or (and (string? new-x)
				 (assoc new-x THEOREMS))
			    (and (string? new-x)
				 (assoc new-x GLOBAL-ASSUMPTIONS))
			    (proof-form? new-x))
			(pair? tsubst)) ;else '()
		   (let* ((proof (if (proof-form? new-x) new-x
				     (thm-or-ga-name-to-proof new-x)))
			  (fla (proof-to-formula proof))
			  (tvars (formula-to-tvars fla)))
		     (map (lambda (tvar) (type-substitute tvar tsubst))
			  tvars))
		   '())))
	    (cterms
	     (let* ((user-pinst-length
		     (min (length uninst-pvars) (length user-cterms)))
		    (user-pinst
		     (map (lambda (x y) (list x y))
			  (list-head uninst-pvars user-pinst-length)
			  (list-head user-cterms user-pinst-length)))
		    (pinst-and-user-pinst
		     (append (list-transform-positive topinst
			       (lambda (x) (pvar-form? (car x))))
			     user-pinst)))
	       (if (and (or (and (string? new-x)
				 (assoc new-x THEOREMS))
			    (and (string? new-x)
				 (assoc new-x GLOBAL-ASSUMPTIONS))
			    (proof-form? new-x))
			(pair? pinst-and-user-pinst)) ;else '()
		   (let* ((proof (if (proof-form? new-x) new-x
				     (thm-or-ga-name-to-proof new-x)))
			  (fla (proof-to-formula proof))
			  (pvars (formula-to-pvars fla)))
		     (map (lambda (pvar)
			    (let ((info (assoc pvar pinst-and-user-pinst)))
			      (if info (cadr info)
				  (predicate-to-cterm pvar))))
			  pvars))
		   '()))))
       (if (> (length uninst-pvars) (length user-cterms))
	   (apply
	    myerror
	    (append (list "use2-intern"
			  "more cterms expected, to be substituted for")
		    (map (lambda (pvar)
			   (let ((info (assoc pvar new-to-old-pvars-alist)))
			     (if info
				 (pvar-to-string (cadr info))
				 (pvar-to-string pvar))))
			 (list-tail uninst-pvars (length user-cterms))))))
       (if (> (length uninst-vars) (length user-terms))
	   (apply
	    myerror
	    (append (list "use2-intern"
			  "more terms expected, to be substituted for")
		    (map
		     (lambda (var)
		       (let ((info (assoc var uninst-to-old-vars-alist)))
			 (if info (cadr info) var)))
		     (list-tail uninst-vars (length user-terms))))))
       (if (and COMMENT-FLAG (< (length uninst-pvars) (length user-cterms)))
	   (begin
	     (comment "warning: superfluous cterms")
	     (for-each
	      comment
	      (map cterm-to-string
		   (list-tail user-cterms (length uninst-pvars))))))
       (if (and COMMENT-FLAG (< (length uninst-vars) (length user-terms)))
	   (begin
	     (comment "warning: superfluous terms")
	     (for-each comment
		       (map term-to-string
			    (list-tail user-terms (length uninst-vars))))))
       (apply use-with-intern
	      (append (list num-goals proof maxgoal new-x)
		      types cterms subst-x-list))) ;else give up
     (let ((normalized-goal-formula
	    (if new-nfla-and-ngoal (cadr new-nfla-and-ngoal)
		(normalize-formula goal-formula))))
       (if (formula=? goal-formula normalized-goal-formula)  
	   (myerror "use-intern/use2-intern" "unusable formula"
		    new-used-formula
		    "for goal formula"
		    goal-formula)
	   (myerror "use-intern/use2-intern" "unusable formula"
		    new-used-formula
		    "for goal formula"
		    goal-formula
		    "as well as normalized goal formula"
		    normalized-goal-formula))))))

; fla-and-sig-topvars-and-goal-fla-to-use2-data is #f if the
; used-formula is not a pattern for the goal formula.  Otherwise the
; following data are returned: (1) the arguments x-list for the
; hypothesis x, that produce via instantiation the goal formula, (2)
; vars (from x-list) whose instantiations cannot be inferred, hence
; need to be provided by the user, (3) an association list storing the
; renaming of vars done, and (4) a type substitution plus object
; instantiation plus pvar-instantiation, that turns the used-formula
; into the goal formula.  Notice that we only build an association
; list for object vars.  For pvars this is done in use2-intern.

(define (fla-and-sig-topvars-and-goal-fla-to-use2-data
	 used-formula sig-topvars goal-formula . elab-path)
  (let ((match2-res (apply match2 (append (list used-formula
						goal-formula
						#f) ;for ignore-deco-flag
					  sig-topvars))))
    (if
     match2-res
     (list '() '() '() match2-res)
     (case (tag used-formula)
       ((predicate ex) #f)
       ((imp)
	(let* ((concl (imp-form-to-conclusion used-formula))
	       (prev (apply
		      fla-and-sig-topvars-and-goal-fla-to-use2-data
		      (append (list concl sig-topvars goal-formula)
			      elab-path))))
	  (if (not prev)
	      #f
	      (let* ((x-list (car prev))
		     (vars (cadr prev))
		     (vars-to-old-vars-alist (caddr prev))
		     (topinst (cadddr prev)))
		(list (cons DEFAULT-GOAL-NAME x-list) vars
		      vars-to-old-vars-alist topinst)))))
       ((impnc)
	(let* ((concl (impnc-form-to-conclusion used-formula))
	       (prev (apply
		      fla-and-sig-topvars-and-goal-fla-to-use2-data
		      (append (list concl sig-topvars goal-formula)
			      elab-path))))
	  (if (not prev)
	      #f
	      (let* ((x-list (car prev))
		     (vars (cadr prev))
		     (vars-to-old-vars-alist (caddr prev))
		     (topinst (cadddr prev)))
		(list (cons DEFAULT-GOAL-NAME x-list) vars
		      vars-to-old-vars-alist topinst)))))
       ((all)
	(let* ((var (all-form-to-var used-formula))
	       (kernel (all-form-to-kernel used-formula))
	       (new-var (var-to-new-var var))
	       (new-kernel
		(formula-subst kernel var (make-term-in-var-form new-var)))
	       (prev (apply
		      fla-and-sig-topvars-and-goal-fla-to-use2-data
		      (append (list new-kernel sig-topvars goal-formula)
			      elab-path))))
	  (if (not prev)
	      #f
	      (let* ((x-list (car prev))
		     (vars (cadr prev))
		     (vars-to-old-vars-alist (caddr prev))
		     (topinst (cadddr prev))
		     (info (assoc new-var topinst)))
		(if 
		 info ;instance found by matching
		 (list ;insert instance into x-list
		  (cons (cadr info) x-list)
		  vars
		  (cons (list new-var var) vars-to-old-vars-alist)
		  topinst)
		 (list ;else insert new-var into x-list, and new-var to vars
		  (cons (make-term-in-var-form new-var) x-list)
		  (cons new-var vars)
		  (cons (list new-var var) vars-to-old-vars-alist)
		  topinst))))))
       ((allnc)
	(let* ((var (allnc-form-to-var used-formula))
	       (kernel (allnc-form-to-kernel used-formula))
	       (new-var (var-to-new-var var))
	       (new-kernel
		(formula-subst kernel var (make-term-in-var-form new-var)))
	       (prev
		(apply
		 fla-and-sig-topvars-and-goal-fla-to-use2-data
		 (append (list new-kernel sig-topvars goal-formula)
			 elab-path))))
	  (if (not prev)
	      #f
	      (let* ((x-list (car prev))
		     (vars (cadr prev))
		     (vars-to-old-vars-alist (caddr prev))
		     (topinst (cadddr prev))
		     (info (assoc new-var topinst)))
		(if 
		 info ;instance found by matching
		 (list ;insert instance into x-list
		  (cons (cadr info) x-list)
		  vars
		  (cons (list new-var var) vars-to-old-vars-alist)
		  topinst)
		 (list ;else insert new-var into x-list, and new-var to vars
		  (cons (make-term-in-var-form new-var) x-list)
		  (cons new-var vars)
		  (cons (list new-var var) vars-to-old-vars-alist)
		  topinst))))))
       ((and)
	(let ((left-conjunct (and-form-to-left used-formula))
	      (right-conjunct (and-form-to-right used-formula)))
	  (if
	   (pair? elab-path)
	   (let* ((direction (car elab-path))
		  (conjunct (cond ((eq? 'left direction) left-conjunct)
				  ((eq? 'right direction) right-conjunct)
				  (else (myerror "left or right expected"
						 direction))))
		  (prev (apply
			 fla-and-sig-topvars-and-goal-fla-to-use2-data
			 (append (list conjunct sig-topvars goal-formula)
				 (cdr elab-path)))))
	     (if (not prev)
		 #f
		 (let* ((x-list (car prev))
			(vars (cadr prev))
			(vars-to-old-vars-alist (caddr prev))
			(topinst (cadddr prev)))
		   (list (cons direction x-list) vars
			 vars-to-old-vars-alist topinst))))
	   (let ((prev1 (fla-and-sig-topvars-and-goal-fla-to-use2-data
			 left-conjunct sig-topvars goal-formula)))
	     (if
	      prev1
	      (let* ((x-list (car prev1))
		     (vars (cadr prev1))
		     (vars-to-old-vars-alist (caddr prev1))
		     (topinst (cadddr prev1)))
		(list (cons 'left x-list) vars
		      vars-to-old-vars-alist topinst))
	      (let ((prev2 (fla-and-sig-topvars-and-goal-fla-to-use2-data
			    right-conjunct sig-topvars goal-formula)))
		(if prev2
		    (let* ((x-list (car prev2))
			   (vars (cadr prev2))
			   (vars-to-old-vars-alist (caddr prev2))
			   (topinst (cadddr prev2)))
		      (list (cons 'right x-list) vars
			    vars-to-old-vars-alist topinst))
		    #f)))))))
       ((atom)
	(cond
	 ((term=? (make-term-in-const-form
		   (pconst-name-to-pconst "ImpConst"))
		  (term-in-app-form-to-final-op (atom-form-to-kernel
						 used-formula)))
	  (let* ((kernel (atom-form-to-kernel used-formula))
		 (args (term-in-app-form-to-args kernel))
		 (arg1 (if (= 2 (length args))
			   (car args)
			   (myerror "two args expected")))
		 (arg2 (cadr args))
		 (prem (make-atomic-formula arg1))
		 (concl (make-atomic-formula arg2))
		 (prev (apply
			fla-and-sig-topvars-and-goal-fla-to-use2-data
			(append (list concl sig-topvars goal-formula)
				elab-path))))
	    (if (not prev)
		#f
		(let* ((x-list (car prev))
		       (vars (cadr prev))
		       (vars-to-old-vars-alist (caddr prev))
		       (topinst (cadddr prev)))
		  (list (cons DEFAULT-GOAL-NAME x-list) vars
			vars-to-old-vars-alist topinst)))))
	 ((term=?
	   (make-term-in-const-form
	    (pconst-name-to-pconst "AndConst"))
	   (term-in-app-form-to-final-op (atom-form-to-kernel
					  used-formula)))
	  (let* ((kernel (atom-form-to-kernel used-formula))
		 (args (term-in-app-form-to-args kernel))
		 (left-arg (if (= 2 (length args))
			       (car args)
			       (myerror "two args expected")))
		 (right-arg (cadr args))
		 (left-conjunct (make-atomic-formula left-arg))
		 (right-conjunct (make-atomic-formula right-arg)))
	    (if
	     (pair? elab-path)
	     (let* ((direction (car elab-path))
		    (conjunct (cond ((eq? 'left direction) left-conjunct)
				    ((eq? 'right direction) right-conjunct)
				    (else (myerror "left or right expected"
						   direction))))
		    (prev (apply
			   fla-and-sig-topvars-and-goal-fla-to-use2-data
			   (append
			    (list conjunct sig-topvars goal-formula)
			    (cdr elab-path)))))
	       (if (not prev)
		   #f
		   (let* ((x-list (car prev))
			  (vars (cadr prev))
			  (vars-to-old-vars-alist (caddr prev))
			  (topinst (cadddr prev)))
		     (list (cons direction x-list) vars
			   vars-to-old-vars-alist topinst))))
	     (let ((prev1 (fla-and-sig-topvars-and-goal-fla-to-use2-data
			   left-conjunct sig-topvars goal-formula)))
	       (if
		prev1
		(let* ((x-list (car prev1))
		       (vars (cadr prev1))
		       (vars-to-old-vars-alist (caddr prev1))
		       (topinst (cadddr prev1)))
		  (list (cons 'left x-list) vars
			vars-to-old-vars-alist topinst))
		(let ((prev2 (fla-and-sig-topvars-and-goal-fla-to-use2-data
			      right-conjunct sig-topvars goal-formula)))
		  (if prev2
		      (let* ((x-list (car prev2))
			     (vars (cadr prev2))
			     (vars-to-old-vars-alist (caddr prev2))
			     (topinst (cadddr prev2)))
			(list (cons 'right x-list) vars
			      vars-to-old-vars-alist topinst))
		      #f)))))))
	 (else #f)))
       (else (myerror "fla-and-sig-topvars-and-goal-fla-to-use2-data"
		      "formula expected"
		      used-formula))))))

; use-with is a more verbose form of use, where the terms are not
; inferred via unification, but have to be given explicitely.  Also,
; for the instantiated premises one can indicate how they are to come
; about.  In the following definition of use-with x is one of the
; following.

; - A number or string identifying a hypothesis form the context.
; - The name of a theorem or global assumption.  If it is a global 
;   assumption whose final conclusion is a nullary predicate variable 
;   distinct from bot (e.g. Efq-Log or Stab-Log), this predicate variable 
;   is substituted by the goal formula.
; - A closed proof.
; - A formula with free variables from the context, generating a new goal.
; Moreover x-list is a list consisting of
; - a number or string identifying a hypothesis form the context,
; - the name of a theorem or global assumption,
; - a closed proof,
; - the string "?" (value of DEFAULT-GOAL-NAME), generating a new goal,
; - a symbol left or right,
; - a term, whose free variables are added to the context,
; - a type, which is substituted for the 1st tvar,
; - a comprehension term, which is substituted for the 1st pvar.

; Notice that new free variables not in the ordered context can be
; introduced in use-with.  They will be present in the newly generated
; num-goals.  The reason is that proofs should be allowed to contain free
; variables.  This is necessary to allow logic in ground types where no
; contant is available (e.g. to prove all x Px -> all x ~ Px -> F).

(define (use-with x . x-list)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply use-with-intern
		 (append (list num-goals proof maxgoal x) x-list)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (use-with-intern num-goals proof maxgoal x . x-list)
  (let* ((num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (goal-formula (goal-to-formula goal))
	 (proof-and-new-num-goals-and-maxgoal
	  (apply x-and-x-list-to-proof-and-new-num-goals-and-maxgoal
		 (append (list num-goal maxgoal x) x-list)))
	 (new-proof (car proof-and-new-num-goals-and-maxgoal))
	 (new-num-goals (cadr proof-and-new-num-goals-and-maxgoal))
	 (new-maxgoal (caddr proof-and-new-num-goals-and-maxgoal)))
    (if (not (classical-formula=? (proof-to-formula new-proof) goal-formula))
	(myerror "use-with-intern" "equal formulas expected"
		 (fold-formula (proof-to-formula new-proof))
		 goal-formula))
    (let ((final-proof (goal-subst proof goal new-proof)))
      (if
       COMMENT-FLAG
       (let ((nc-viols (nc-violations final-proof)))
	 (if (pair? nc-viols)
	     (begin
	       (comment "Warning: nc-intro with cvar(s)")
	       (for-each comment (map (lambda (x)
					(if (var-form? x)
					    (var-to-string x)
					    (avar-to-string x)))
				      nc-viols))))))
      (make-pproof-state
       (append (reverse new-num-goals) (cdr num-goals))
       final-proof
       new-maxgoal))))

; When creating new num-goals in the given context we will need

(define (context-and-cvars-and-formula-to-formula context cvars formula)
  (if (null? context)
      formula
      (let* ((x (car context))
	     (prev (context-and-cvars-and-formula-to-formula
		    (cdr context) cvars formula)))
	(cond ((var-form? x)
	       (if (member x cvars) (make-all x prev) (make-allnc x prev)))
	      ((avar-form? x) (make-imp (avar-to-formula x) prev))
	      (else (myerror "context-and-cvars-and-formula-to-formula"
			     "var or avar expected"
			     x))))))

(define (context-to-proofargs context)
  (map (lambda (x) (cond ((var-form? x) (make-term-in-var-form x))
			 ((avar-form? x) (make-proof-in-avar-form x))
			 (else (myerror
				"context-to-proofargs" "var or avar expected"
				x))))
       context))

(define (context-and-cvars-and-formula-to-new-goal context cvars formula)
  (let* ((goalvarformula
	  (context-and-cvars-and-formula-to-formula context cvars formula))
	 (goalvar
	  (if (null? (formula-to-free goalvarformula))
	      (formula-to-new-avar goalvarformula DEFAULT-AVAR-NAME)
	      (apply myerror (cons "unexpected free variables"
				   (formula-to-free goalvarformula))))))
    (apply mk-goal-in-elim-form
	   (cons (make-goal-in-avar-form goalvar) context))))

(define (hyp-info-to-leaf num-goal x)
  (let* ((goal (num-goal-to-goal num-goal))
	 (goal-formula (goal-to-formula goal))
	 (drop-info (num-goal-to-drop-info num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (avars (context-to-avars context))
	 (maxhyp (length avars)))
    (cond
     ((and (integer? x) (positive? x))
      (if (<= x maxhyp)
	  (make-proof-in-avar-form (list-ref avars (- x 1)))
	  (myerror "hyp-info-to-leaf" "assumption number expected" x)))
     ((and (string? x)
	   (member x (hypname-info-to-names hypname-info)))
      (let ((i (name-and-hypname-info-to-index x hypname-info)))
	(if (<= i maxhyp)
	    (make-proof-in-avar-form (list-ref avars (- i 1)))
	    (myerror "hyp-info-to-leaf" "assumption number expected" i))))
     ((string? x)
      (let ((info (assoc x (append THEOREMS GLOBAL-ASSUMPTIONS))))
	(if (not info)
	    (myerror "hyp-info-to-leaf" "illegal first argument" x))
	(let ((aconst (cadr info)))
	  (make-proof-in-aconst-form aconst))))
     ((proof-form? x) x)
     (else (myerror "hyp-info-to-leaf" "illegal first argument" x)))))

(define (hyp-info-to-formula num-goal x)
  (let* ((goal (num-goal-to-goal num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (avars (context-to-avars context))
	 (maxhyp (length avars)))
    (cond
     ((and (integer? x) (positive? x))
      (if (<= x maxhyp)
	  (avar-to-formula (list-ref avars (- x 1)))
	  (myerror "hyp-info-to-formula" "assumption number expected" x)))
     ((and (string? x)
	   (member x (hypname-info-to-names hypname-info)))
      (let ((i (name-and-hypname-info-to-index x hypname-info)))
	(if (<= i maxhyp)
	    (avar-to-formula (list-ref avars (- i 1)))
	    (myerror "hyp-info-to-formula" "assumption number expected" i))))
     ((string? x)
      (let ((info (assoc x (append THEOREMS GLOBAL-ASSUMPTIONS))))
	(if info
	    (aconst-to-formula (cadr info))
	    (myerror "hyp-info-to-formula" "illegal first argument" x))))
     ((proof-form? x) (proof-to-formula x))
     (else (myerror "hyp-info-to-formula" "illegal first argument" x)))))

(define and-atom-to-left-proof
  (mk-proof-in-intro-form
   (pv "boole1")
   (mk-proof-in-elim-form
    (make-proof-in-aconst-form
     (all-formula-to-cases-aconst
      (pf "all boole1,boole2(AndConst boole1 boole2 -> boole1)")))
    (pt "boole1")
    (mk-proof-in-intro-form
     (pv "boole2")
     (formula-to-new-avar (pf "boole2"))
     (make-proof-in-aconst-form truth-aconst))
    (let ((u (formula-to-new-avar (pf "F"))))
      (mk-proof-in-intro-form
       (pv "boole2") u (make-proof-in-avar-form u))))))

(define and-atom-to-right-proof
  (let ((var1 (pv "boole1"))
        (var2 (pv "boole2")))
    (mk-proof-in-intro-form
     var1
     var2
     (mk-proof-in-elim-form
      (make-proof-in-aconst-form
       (all-formula-to-cases-aconst
	(pf "all boole2(AndConst boole1 boole2 -> boole2)")))
      (make-term-in-var-form var1)
      (make-term-in-var-form var2)        
      (mk-proof-in-intro-form
       (formula-to-new-avar (pf "AndConst boole1 True"))
       (make-proof-in-aconst-form truth-aconst))
      (mk-proof-in-elim-form
       (make-proof-in-aconst-form
	(all-formula-to-cases-aconst
	 (pf "all boole1(AndConst boole1 False -> F)")))
       (make-term-in-var-form var1)
       (let ((u (formula-to-new-avar (pf "F"))))
	 (mk-proof-in-intro-form u (make-proof-in-avar-form u)))
       (let ((u (formula-to-new-avar (pf "F"))))
	 (mk-proof-in-intro-form u (make-proof-in-avar-form u))))))))

(define atom-to-imp-proof
  (let ((var1 (pv "boole1"))
        (var2 (pv "boole2")))
    (mk-proof-in-intro-form
     var1
     (mk-proof-in-elim-form
      (make-proof-in-aconst-form
       (all-formula-to-cases-aconst
        (pf "all boole1,boole2(ImpConst boole1 boole2 -> boole1 -> boole2)")))
      (make-term-in-var-form var1)
      (mk-proof-in-intro-form
       var2
       (mk-proof-in-elim-form
        (make-proof-in-aconst-form
         (all-formula-to-cases-aconst
          (pf "all boole2(ImpConst True boole2 -> T -> boole2)")))
        (make-term-in-var-form var2)
        (mk-proof-in-intro-form
         (formula-to-new-avar (pf "T")) 
         (formula-to-new-avar (pf "T")) 
         (make-proof-in-aconst-form truth-aconst))
        (let ((u (formula-to-new-avar (pf "F"))))
          (mk-proof-in-intro-form
           u (formula-to-new-avar (pf "T"))
           (make-proof-in-avar-form u)))))
      (mk-proof-in-intro-form
       var2
       (mk-proof-in-elim-form
        (make-proof-in-aconst-form
         (all-formula-to-cases-aconst
          (pf "all boole2(ImpConst False boole2 -> F -> boole2)")))
        (make-term-in-var-form var2)
        (mk-proof-in-intro-form
         (formula-to-new-avar (pf "T")) 
	 (formula-to-new-avar (pf "F")) 
	 (make-proof-in-aconst-form truth-aconst))
	(let ((u (formula-to-new-avar (pf "F"))))
	  (mk-proof-in-intro-form
	   (formula-to-new-avar (pf "T")) u
	   (make-proof-in-avar-form u)))))))))

(define (x-and-x-list-to-proof-and-new-num-goals-and-maxgoal
	 num-goal maxgoal x . x-list)
  (let* ((number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (drop-info (num-goal-to-drop-info num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (cvars (goal-to-cvars goal))
	 (avars (context-to-avars context))
	 (maxhyp (length avars))
	 (types (list-transform-positive x-list type-form?))
	 (cterms (list-transform-positive x-list cterm-form?))
	 (rest-x-list (list-transform-positive x-list
			(lambda (y) (and (not (type-form? y))
					 (not (cterm-form? y))))))
	 (x-for-types
	  (if
	   (pair? types) ;else x
	   (let* ((proof (if (proof-form? x) x (thm-or-ga-name-to-proof x)))
		  (tvars (formula-to-tvars (proof-to-formula proof)))
		  (l (min (length tvars) (length types)))
		  (tsubst (map (lambda (x y) (list x y))
			       (list-head tvars l) (list-head types l))))
	     (if (and COMMENT-FLAG (< (length tvars) (length types)))
		 (begin
		   (comment "warning: superfluous types")
		   (for-each
		    comment
		    (map type-to-string (list-tail types (length tvars))))))
	     (proof-substitute proof tsubst))
	   x))
	 (x-for-types-and-cterms
	  (if
	   (pair? cterms) ;else x-for-types
	   (let* ((proof (if (proof-form? x-for-types) x-for-types
			     (thm-or-ga-name-to-proof x-for-types)))
		  (pvars (formula-to-pvars (proof-to-formula proof)))
		  (l (min (length pvars) (length cterms)))
		  (psubst (map (lambda (x y) (list x y))
			       (list-head pvars l) (list-head cterms l))))
	     (if (and COMMENT-FLAG (< (length pvars) (length cterms)))
		 (begin
		   (comment "warning: superfluous cterms")
		   (for-each
		    comment
		    (map cterm-to-string (list-tail cterms (length pvars))))))
	     (for-each
	      (lambda (pvar cterm)
		(let ((arity (apply make-arity
				    (map var-to-type (cterm-to-vars cterm)))))
		  (if (not (equal? (pvar-to-arity pvar) arity))
		      (myerror
		       "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
		       "equal arities expected"
		       "predicate variable"
		       (pvar-to-string pvar)
		       "comprehension term"
		       cterm))))
	      (list-head pvars l) (list-head cterms l))
	     (proof-substitute proof psubst))
	   x-for-types))
	 (leaf (if (formula-form? x-for-types-and-cterms)
		   (context-and-cvars-and-formula-to-new-goal
		    context cvars x-for-types-and-cterms)
		   (hyp-info-to-leaf num-goal x-for-types-and-cterms)))
	 (new-num-goals
	  (if
	   (formula-form? x-for-types-and-cterms) ;then a new goal is created
	   (list (make-num-goal (+ 1 maxgoal) leaf drop-info hypname-info))
	   '()))
	 (leaf-and-new-num-goals-and-maxgoal
	  (list leaf new-num-goals (if (formula-form? x-for-types-and-cterms)
				       (+ 1 maxgoal)
				       maxgoal)))
	 (x-list-test
	  (if (null? x-list)
	      #t
	      (do ((l1 x-list (cdr l1))
		   (l2 (cdr x-list) (cdr l2))
		   (res #t (let ((fst (car l1))
				 (snd (car l2)))
			     (and res (cond
				       ((type-form? fst) #t)
				       ((cterm-form? fst)
					(not (type-form? snd)))
				       (else (not (or (type-form? snd)
						      (cterm-form? snd)))))))))
		  ((null? l2) res)))))
    (if (and COMMENT-FLAG (not x-list-test))
	(comment
	 "warning: expected order of arguments is types - cterms - rest"))
    (do ((l rest-x-list (cdr l))
	 (proof-and-new-num-goals-and-maxgoal
	  leaf-and-new-num-goals-and-maxgoal
	  (let* ((proof (car proof-and-new-num-goals-and-maxgoal))
		 (used-formula (unfold-formula (proof-to-formula proof)))
		 (new-num-goals (cadr proof-and-new-num-goals-and-maxgoal))
		 (maxgoal (caddr proof-and-new-num-goals-and-maxgoal))
		 (x1 (car l)))
	    (cond
	     ((or (imp-form? used-formula) (impnc-form? used-formula))
	      (if
	       (equal? x1 DEFAULT-GOAL-NAME) ;then a new goal is created
	       (let* ((prem (bicon-form-to-left used-formula))
		      (newvars (set-minus (formula-to-free prem)
					  (context-to-vars context)))
		      (goalvarformula
		       (context-and-cvars-and-formula-to-formula
			context cvars
			(apply mk-all (append newvars (list prem)))))
		      (goalvar (formula-to-new-avar goalvarformula
						    DEFAULT-AVAR-NAME))
		      (goal (apply mk-goal-in-elim-form
				   (cons (make-goal-in-avar-form goalvar)
					 (append context newvars))))
		      (new-num-goal
		       (make-num-goal
			(+ 1 maxgoal) goal drop-info hypname-info)))
		 (list (if (imp-form? used-formula)
			   (make-proof-in-imp-elim-form proof goal)
			   (make-proof-in-impnc-elim-form proof goal))
		       (cons new-num-goal new-num-goals)
		       (+ 1 maxgoal)))
	       (let
		   ((arg
		     (cond
		      ((and (integer? x1) (positive? x1))
		       (if
			(<= x1 maxhyp)
			(make-proof-in-avar-form
			 (list-ref avars (- x1 1)))
			(myerror
			 "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
			 "assumption number expected" x1)))
		      ((and (string? x1)
			    (member x1 (hypname-info-to-names
					hypname-info)))
		       (let ((i (name-and-hypname-info-to-index
				 x1 hypname-info)))
			 (if
			  (<= i maxhyp)
			  (make-proof-in-avar-form
			   (list-ref avars (- i 1)))
			  (myerror
			   "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
			   "assumption number expected" i))))
		      ((and (string? x1) (assoc x1 THEOREMS))
		       (make-proof-in-aconst-form
			(cadr (assoc x1 THEOREMS))))
		      ((and (string? x1) (assoc x1 GLOBAL-ASSUMPTIONS))
		       (make-proof-in-aconst-form
			(cadr (assoc x1 GLOBAL-ASSUMPTIONS))))
		      ((proof-form? x1) x1)
		      (else
		       (myerror
			"x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
			"unexpected argument" x1)))))
		 (if (classical-formula=? (bicon-form-to-left used-formula)
					  (proof-to-formula arg))
		     (list (if (imp-form? used-formula)
			       (make-proof-in-imp-elim-form proof arg)
			       (make-proof-in-impnc-elim-form proof arg))
			   new-num-goals maxgoal)
		     (myerror
		      "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
		      "formulas do not fit"
		      used-formula
		      (proof-to-formula arg))))))
	     ((and-form? used-formula)
	      (cond
	       ((eq? x1 'left)
		(list (make-proof-in-and-elim-left-form proof)
		      new-num-goals maxgoal))
	       ((eq? x1 'right)
		(list (make-proof-in-and-elim-right-form proof)
		      new-num-goals maxgoal))
	       (else (myerror
		      "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
		      "left or right expected" x1))))
	     ((and (bicon-form? used-formula)
		   (memq (bicon-form-to-bicon used-formula)
			 '(andd andl andr andu)))
	      (let ((left-conjunct (bicon-form-to-left used-formula))
		    (right-conjunct (bicon-form-to-right used-formula)))
		(myerror
		 "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
		 "not implemented for"
		 used-formula)))
	     ((or (all-form? used-formula) (allnc-form? used-formula))
	      (if
	       (term-form? x1)
	       (let* ((var (car (quant-form-to-vars used-formula)))
		      (type1 (var-to-type var))
		      (t-deg1 (var-to-t-deg var))
		      (type2 (term-to-type x1)))
		 (if
		  (equal? type1 type2)
		  (if
		   (not (and (t-deg-one? t-deg1)
			     (not (synt-total? x1))))
		   (list (if (all-form? used-formula)
			     (make-proof-in-all-elim-form proof x1)
			     (make-proof-in-allnc-elim-form proof x1))
			 new-num-goals maxgoal)
		   (myerror
		    "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
		    "attempt to apply all-elim to non-total term" x1))
		  (myerror
		   "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
		   "types don't fit for all-elim" type1 type2
		   "originating from all-formula" used-formula
		   "and use-with argument" x1)))
	       (myerror
		"x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
		"term expected" x1)))
	     ((and (atom-form? used-formula)
		   (synt-total? (atom-form-to-kernel used-formula)))
	      (cond
	       ((term=?
		 (make-term-in-const-form
		  (pconst-name-to-pconst "ImpConst"))
		 (term-in-app-form-to-final-op (atom-form-to-kernel
						used-formula)))
		(let*
		    ((kernel (atom-form-to-kernel used-formula))
		     (args (term-in-app-form-to-args kernel))
		     (arg1
		      (if
		       (= 2 (length args))
		       (car args)
		       (myerror
			"x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
			"two args expected")))
		     (arg2 (cadr args))
		     (prem (make-atomic-formula arg1)))
		  (if
		   (equal? x1 DEFAULT-GOAL-NAME) ;then a new goal is created
		   (let* ((newvars (set-minus (formula-to-free prem)
					      (context-to-vars context)))
			  (goalvarformula
			   (context-and-cvars-and-formula-to-formula
			    context cvars
			    (apply mk-all (append newvars (list prem)))))
			  (goalvar (formula-to-new-avar goalvarformula
							DEFAULT-AVAR-NAME))
			  (goal
			   (apply mk-goal-in-elim-form
				  (cons (make-goal-in-avar-form goalvar)
					(append context newvars))))
			  (new-num-goal
			   (make-num-goal
			    (+ 1 maxgoal) goal drop-info hypname-info)))
		     (list (mk-proof-in-elim-form
			    atom-to-imp-proof arg1 arg2 proof goal)
			   (cons new-num-goal new-num-goals)
			   (+ 1 maxgoal)))
		   (let ((arg
			  (cond
			   ((and (integer? x1) (positive? x1))
			    (if
			     (<= x1 maxhyp)
			     (make-proof-in-avar-form
			      (list-ref avars (- x1 1)))
			     (myerror
			      "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
			      "assumption number expected" x1)))
			   ((and (string? x1)
				 (member x1 (hypname-info-to-names
					     hypname-info)))
			    (let ((i (name-and-hypname-info-to-index
				      x1 hypname-info)))
			      (if
			       (<= i maxhyp)
			       (make-proof-in-avar-form
				(list-ref avars (- i 1)))
			       (myerror
				"x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
				"assumption number expected" i))))
			   ((and (string? x1) (assoc x1 THEOREMS))
			    (make-proof-in-aconst-form
			     (cadr (assoc x1 THEOREMS))))
			   ((and (string? x1) (assoc x1 GLOBAL-ASSUMPTIONS))
			    (make-proof-in-aconst-form
			     (cadr (assoc x1 GLOBAL-ASSUMPTIONS))))
			   ((proof-form? x1) x1)
			   (else
			    (myerror
			     "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
			     "unexpected argument" x1)))))
		     (if
		      (classical-formula=? prem (proof-to-formula arg))
		      (list (mk-proof-in-elim-form
			     atom-to-imp-proof arg1 arg2 proof arg)
			    new-num-goals maxgoal)
		      (myerror
		       "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
		       "formulas do not fit"
		       used-formula
		       (proof-to-formula arg)))))))
	       ((term=?
		 (make-term-in-const-form
		  (pconst-name-to-pconst "AndConst"))
		 (term-in-app-form-to-final-op (atom-form-to-kernel
						used-formula)))
		(let*
		    ((kernel (atom-form-to-kernel used-formula))
		     (args (term-in-app-form-to-args kernel))
		     (left-arg
		      (if
		       (= 2 (length args))
		       (car args)
		       (myerror
			"x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
			"two args expected")))
		     (right-arg (cadr args)))
		  (cond
		   ((eq? x1 'left)
		    (list (mk-proof-in-elim-form
			   and-atom-to-left-proof
			   left-arg right-arg proof)
			  new-num-goals maxgoal))
		   ((eq? x1 'right)
		    (list (mk-proof-in-elim-form
			   and-atom-to-right-proof
			   left-arg right-arg proof)
			  new-num-goals maxgoal))
		   (else
		    (myerror
		     "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
		     "left or right expected" x1)))))
	       (else (myerror
		      "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
		      "unexpected atom" used-formula))))
	     (else (myerror
		    "x-and-x-list-to-proof-and-new-num-goals-and-maxgoal"
		    "unexpected formula" used-formula))))))
	((null? l) proof-and-new-num-goals-and-maxgoal))))

; In a goal v x1 ... xn the object variables in the context x1 ... xn
; can be split in those available as computational variables in the
; proof to be built, and the rest.  The ones not available as
; computational variables are displayed in braces.

(define (goal-to-cvars goal)
  (case (tag goal)
    ((proof-in-avar-form proof-in-aconst-form) '())
    ((proof-in-imp-elim-form)
     (goal-to-cvars (proof-in-imp-elim-form-to-op goal)))
    ((proof-in-impnc-elim-form)
     (goal-to-cvars (proof-in-impnc-elim-form-to-op goal)))
    ((proof-in-and-elim-left-form)
     (goal-to-cvars (proof-in-and-elim-left-form-to-kernel goal)))
    ((proof-in-and-elim-right-form)
     (goal-to-cvars (proof-in-and-elim-right-form-to-kernel goal)))
    ((proof-in-all-elim-form)
     (let* ((op (proof-in-all-elim-form-to-op goal))
	    (arg (proof-in-all-elim-form-to-arg goal))
	    (prev (goal-to-cvars op)))
       (if (term-in-var-form? arg)
	   (adjoin (term-in-var-form-to-var arg) prev)
	   (myerror "goal-to-cvars" "variable expected" arg))))
    ((proof-in-allnc-elim-form)
     (goal-to-cvars (proof-in-all-elim-form-to-op goal)))
    (else (myerror "goal-to-cvars" "unexpected goal with tag" goal))))

(define (goal-to-ncvars goal)
  (case (tag goal)
    ((proof-in-avar-form proof-in-aconst-form) '())
    ((proof-in-imp-elim-form)
     (goal-to-ncvars (proof-in-imp-elim-form-to-op goal)))
    ((proof-in-impnc-elim-form)
     (goal-to-ncvars (proof-in-impnc-elim-form-to-op goal)))
    ((proof-in-and-elim-left-form)
     (goal-to-ncvars (proof-in-and-elim-left-form-to-kernel goal)))
    ((proof-in-and-elim-right-form)
     (goal-to-ncvars (proof-in-and-elim-right-form-to-kernel goal)))
    ((proof-in-all-elim-form)
     (goal-to-ncvars (proof-in-all-elim-form-to-op goal)))
    ((proof-in-allnc-elim-form)
     (let* ((op (proof-in-allnc-elim-form-to-op goal))
	    (arg (proof-in-allnc-elim-form-to-arg goal))
	    (prev (goal-to-ncvars op)))
       (if (term-in-var-form? arg)
	   (adjoin (term-in-var-form-to-var arg) prev)
	   (myerror "goal-to-ncvars" "variable expected" arg))))
    (else (myerror "goal-to-ncvars" "unexpected goal with tag"
		   (tag goal)))))

; inst-with does for forward chaining the same as use-with for backward
; chaining.  It replaces the present goal by a new one, with one
; additional hypothesis obtained by instantiating a previous one.  Notice
; that this effect could also be obtained by cut.  In the following
; definition of inst-with x is one of the following.
; - A number or string identifying a hypothesis form the context.
; - The name of a theorem or global assumption.  
; - A closed proof.
; - A formula with free variables from the context, generating a new goal.
; Moreover x-list is a list consisting of
; - a number or string identifying a hypothesis form the context,
; - the name of a theorem or global assumption,
; - a closed proof,
; - the string "?" (value of DEFAULT-GOAL-NAME), generating a new goal,
; - a symbol left or right,
; - a term, whose free variables are added to the context,
; - a type, which is substituted for the 1st tvar,
; - a comprehension term, which is substituted for the 1st pvar.

(define (inst-with x . x-list)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply inst-with-intern
		 (append (list num-goals proof maxgoal x) x-list)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (inst-with-intern num-goals proof maxgoal x . x-list)
  (let* ((num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (drop-info (num-goal-to-drop-info num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (cvars (goal-to-cvars goal))
	 (goal-formula (goal-to-formula goal))
	 (proof-and-new-num-goals-and-maxgoal
	  (apply x-and-x-list-to-proof-and-new-num-goals-and-maxgoal
		 (append (list num-goal maxgoal x) x-list)))
	 (proof-of-inst (car proof-and-new-num-goals-and-maxgoal))
	 (new-num-goals (cadr proof-and-new-num-goals-and-maxgoal))
	 (new-maxgoal (caddr proof-and-new-num-goals-and-maxgoal))
	 (inst-formula (proof-to-formula proof-of-inst))
	 (new-avar (formula-to-new-avar inst-formula DEFAULT-AVAR-NAME))
	 (new-goalformula
	  (context-and-cvars-and-formula-to-formula
	   (append context (list new-avar)) cvars goal-formula))
	 (new-goalvar (formula-to-new-avar new-goalformula DEFAULT-AVAR-NAME))
	 (new-goal (apply mk-goal-in-elim-form
			  (append (list (make-goal-in-avar-form new-goalvar))
				  context
				  (list new-avar))))
	 (new-proof (make-proof-in-imp-elim-form
		     (make-proof-in-imp-intro-form new-avar new-goal)
		     proof-of-inst))
	 (new-num-goal
	  (begin (set! maxgoal (+ 1 new-maxgoal))
		 (make-num-goal maxgoal new-goal drop-info hypname-info))))
    (if COMMENT-FLAG
	(let ((test (intersection (proof-to-cvars new-proof)
				  (goal-to-ncvars goal))))
	  (if (pair? test)
	      (begin (display-comment "warning: allnc-intro with cvars")
		     (for-each (lambda (string) (display " ") (display string))
			       (map var-to-string test))
		     (newline)))))
    (make-pproof-state
     (append (cons new-num-goal (reverse new-num-goals))
	     (cdr num-goals))
     (goal-subst proof goal new-proof)
     maxgoal)))

; inst-with-to expects a string as its last argument, which is used (via
; name-hyp) to name the newly introduced instantiated hypothesis.

(define (inst-with-to x . x-list-and-name)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply inst-with-to-intern
		 (append (list num-goals proof maxgoal x) x-list-and-name)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (inst-with-to-intern num-goals proof maxgoal x . x-list-and-name)
  (if (null? x-list-and-name)
      (myerror "inst-with-to" "more arguments expected"))
  (if (member DEFAULT-GOAL-NAME x-list-and-name)
      (myerror "? illegal for inst-with-to; use inst-with instead"))
  (let ((name (car (last-pair x-list-and-name)))
	(x-and-x-list (cons x (list-head x-list-and-name
					 (- (length x-list-and-name) 1)))))
    (if (not (string? name))
	(myerror "inst-with-to" "string expected" name))
    (let* ((pproof-state1
	    (apply inst-with-intern
		   (append (list num-goals proof maxgoal) x-and-x-list)))
	   (num-goals (pproof-state-to-num-goals pproof-state1))
	   (num-goal (car num-goals))
	   (goal (num-goal-to-goal num-goal))
	   (context (goal-to-context goal))
	   (avars (context-to-avars context))
	   (maxhyp (length avars)))
      (apply name-hyp-intern
	     (append pproof-state1 (list maxhyp name))))))

; Given a goal B, (cut A) generates the two new goals A -> B and A,
; with A -> B to be proved first.

(define (cut side-premise-formula)
  (if (string? side-premise-formula)
      (myerror "cut" "use pf (parse-formula) to produce a formula from string"
       side-premise-formula))
  (if (formula-with-illegal-tensor? (unfold-formula side-premise-formula))
      (myerror "tensor ! should be used with excl or exca only"
	       side-premise-formula))
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (cut-intern num-goals proof maxgoal side-premise-formula))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (cut-intern num-goals proof maxgoal side-premise-formula)
  (let* ((num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (formula (goal-to-formula goal)))
    (use-with-intern num-goals proof maxgoal
		     (make-imp (unfold-formula side-premise-formula) formula)
		     DEFAULT-GOAL-NAME)))

; Given a goal B, (assert A) generates the two new goals A and A -> B,
; with A to be proved first.

(define (assert formula)
  (if (string? formula)
      (myerror
       "assert" "use pf (parse-formula) to produce a formula from string"
       formula))
  (if (formula-with-illegal-tensor? (unfold-formula formula))
      (myerror "tensor ! should be used with excl or exca only" formula))
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE (assert-intern num-goals proof maxgoal formula))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))
  
(define (assert-intern num-goals proof maxgoal formula)
  (let* ((num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (goal-formula (goal-to-formula goal))
	 (pproof-state1 (use-with-intern
			 num-goals proof maxgoal
			 (make-imp (unfold-formula formula) goal-formula)
			 DEFAULT-GOAL-NAME))
	 (num-goals1 (pproof-state-to-num-goals pproof-state1))
	 (reordered-num-goals
	  (append (list (cadr num-goals1) (car num-goals1))
		  (cddr num-goals1))))
    (make-pproof-state
     reordered-num-goals
     (pproof-state-to-proof pproof-state1)
     (pproof-state-to-maxgoal pproof-state1))))

; To move (all or n) universally quantified variables and hypotheses of
; the current goal into the context, we use (strip) or (strip n).

(define (strip . x)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal)))
    (set! PPROOF-STATE (apply strip-intern
			      (append (list num-goals proof maxgoal) x)))
    (pproof-state-history-push PPROOF-STATE)
    (display-comment "ok, we now have the new goal ")
    (if COMMENT-FLAG (newline))
    (display-num-goal (car (pproof-state-to-num-goals)))))

(define (strip-intern num-goals proof maxgoal . x)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (drop-info (num-goal-to-drop-info num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (formula (goal-to-formula goal)))
    (do ((nc-and-ncv-and-np-and-ng
	  (list '() '() goal goal)
	  (let* ((nc (car nc-and-ncv-and-np-and-ng))
		 (ncv (cadr nc-and-ncv-and-np-and-ng))
		 (np (caddr nc-and-ncv-and-np-and-ng))
		 (ng (cadddr nc-and-ncv-and-np-and-ng))
		 (nf (proof-to-formula ng)))
	    (case (tag nf)
	      ((all)
	       (let ((var (all-form-to-var nf)))
		 (if ;quantified var already occurs: rename
		  (or (member var (context-to-vars context))
		      (member var (context-to-vars nc)))
		  (let* ((newvar (var-to-new-var var))
			 (ng1 (make-goal-in-all-elim-form ng newvar)))
		    (list (cons newvar nc)
			  (if (formula-of-nulltype? (goal-to-formula ng))
			      ncv
			      (cons newvar ncv))
			  (goal-subst np ng (make-proof-in-all-intro-form 
					      newvar ng1))
			  ng1))
		  (let ((ng1 (make-goal-in-all-elim-form ng var)))
		    (list (cons var nc)
			  (if (formula-of-nulltype? (goal-to-formula ng))
			      ncv
			      (cons var ncv))
			  (goal-subst
			   np ng (make-proof-in-all-intro-form var ng1))
			  ng1)))))
	      ((allnc)
	       (let ((var (allnc-form-to-var nf)))
		 (if ;quantified var already occurs: rename
		  (or (member var (context-to-vars context))
		      (member var (context-to-vars nc)))
		  (let* ((newvar (var-to-new-var var))
			 (ng1 (make-goal-in-allnc-elim-form ng newvar)))
		    (list (cons newvar nc)
			  ncv
			  (goal-subst np ng (make-proof-in-allnc-intro-form 
					     newvar ng1))
			  ng1))
		  (let ((ng1 (make-goal-in-allnc-elim-form ng var)))
		    (list (cons var nc)
			  ncv
			  (goal-subst
			   np ng (make-proof-in-allnc-intro-form var ng1))
			  ng1)))))
	      ((imp)
	       (let* ((premise (imp-form-to-premise nf))
		      (avar (formula-to-new-avar premise DEFAULT-AVAR-NAME))
		      (ng1 (make-goal-in-imp-elim-form ng avar)))
		 (list
		  (cons avar nc)
		  ncv
		  (goal-subst np ng (make-proof-in-imp-intro-form avar ng1))
		  ng1)))
	      ((impnc)
	       (let* ((premise (impnc-form-to-premise nf))
		      (avar (formula-to-new-avar premise DEFAULT-AVAR-NAME))
		      (ng1 (make-goal-in-impnc-elim-form ng avar)))
		 (list
		  (cons avar nc)
		  ncv
		  (goal-subst np ng (make-proof-in-impnc-intro-form avar ng1))
		  ng1)))
	      ((exca)
	       (let* ((vars (exca-form-to-vars nf))
		      (kernel (exca-form-to-kernel nf))
		      (premise
		       (apply mk-all
			      (append vars
				      (list
				       (apply mk-imp
					      (append
					       (tensor-form-to-parts kernel)
					       (list falsity)))))))
		      (avar (formula-to-new-avar premise DEFAULT-AVAR-NAME))
		      (ng1 (make-goal-in-imp-elim-form ng avar)))
		 (list
		  (cons avar nc)
		  ncv
		  (goal-subst np ng (make-proof-in-imp-intro-form avar ng1))
		  ng1)))
	      ((excl)
	       (let* ((vars (excl-form-to-vars nf))
		      (kernel (excl-form-to-kernel nf))
		      (premise
		       (apply mk-all
			      (append vars
				      (list
				       (apply mk-imp
					      (append
					       (tensor-form-to-parts kernel)
					       (list falsity-log)))))))
		      (avar (formula-to-new-avar premise DEFAULT-AVAR-NAME))
		      (ng1 (make-goal-in-imp-elim-form ng avar)))
		 (list
		  (cons avar nc)
		  ncv
		  (goal-subst np ng (make-proof-in-imp-intro-form avar ng1))
		  ng1)))
	      (else (myerror "strip" "unexpected formula" nf)))))
	 (n (cond ((null? x)
		   (string-length (formula-to-string formula)))
		  ((and (integer? (car x)) (positive? (car x))) (car x))
		  (else
		   (myerror "strip" "positive integer expected" (car x))))
	    (- n 1)))
	((or (zero? n) (let* ((ng (cadddr nc-and-ncv-and-np-and-ng))
			      (nf (proof-to-formula ng)))
			 (or (prime-form? nf) (and-form? nf)
			     (ex-form? nf) (exnc-form? nf))))
	 (let* ((np (caddr nc-and-ncv-and-np-and-ng))
		(ng (cadddr nc-and-ncv-and-np-and-ng))
		(new-num-goal
		 (make-num-goal (+ 1 maxgoal) ng drop-info hypname-info)))
	   (make-pproof-state (cons new-num-goal (cdr num-goals))
			      (goal-subst (pproof-state-to-proof) goal np)
			      (+ 1 maxgoal)))))))

; In (drop . x-list), x-list is a list of numbers or strings identifying
; hypotheses from the context.  A new goal is created, which differs
; from the previous one only in display aspects: the listed hypotheses
; are hidden (but still present).  If x-list is empty, all hypotheses
; are hidden.

(define (drop . x-list)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal)))
    (set! PPROOF-STATE (apply drop-intern
			      (append (list num-goals proof maxgoal) x-list)))
    (pproof-state-history-push PPROOF-STATE)
    (display-comment "ok, we now have the new goal ")
    (if COMMENT-FLAG (newline))
    (display-num-goal (car (pproof-state-to-num-goals)))))

(define (drop-intern num-goals proof maxgoal . x-list)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (drop-info (num-goal-to-drop-info num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (names (hypname-info-to-names hypname-info))
	 (i-list
	  (map (lambda (x)
		 (cond ((number? x) x)
		       ((string? x)
			(if (member x names)
			    (name-and-hypname-info-to-index x hypname-info)
			    (myerror "drop" "hypname expected" x)))
		       (else (myerror "drop" "index or hypname expected" x))))
	       x-list))
	 (dropped-indices (if (null? x-list)
			      (let ((avars (context-to-avars context)))
				(do ((l avars (cdr l))
				     (i 1 (+ 1 i))
				     (res '() (cons i res)))
				    ((null? l) (reverse res))))
			      i-list))
	 (new-drop-info (union drop-info dropped-indices))
	 (new-num-goal
	  (make-num-goal (+ 1 maxgoal) goal new-drop-info hypname-info)))
    (make-pproof-state (cons new-num-goal (cdr num-goals))
		       proof
		       (+ 1 maxgoal))))

; In (name-hyp i string) a new goal is created, which differs from the
; previous one only in display aspects: the list (i string) is added to
; hypname-info.

(define (name-hyp i string)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal)))
    (set! PPROOF-STATE (name-hyp-intern num-goals proof maxgoal i string))
    (pproof-state-history-push PPROOF-STATE)
    (display-comment "ok, we now have the new goal ")
    (if COMMENT-FLAG (newline))
    (display-num-goal (car (pproof-state-to-num-goals)))))

(define (name-hyp-intern num-goals proof maxgoal i string)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (drop-info (num-goal-to-drop-info num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (names (hypname-info-to-names hypname-info))
	 (new-hypname-info
	  (cond ((is-used? string '() '())
		 (myerror "name-hyp" "already used" string))
		((member string names)
		 (myerror "name-hyp" "already a hypname" string))
		(else (add-hypname-info i string hypname-info))))
	 (new-num-goal
	  (make-num-goal (+ 1 maxgoal) goal drop-info new-hypname-info)))
    (make-pproof-state (cons new-num-goal (cdr num-goals))
		       proof
		       (+ 1 maxgoal))))

; (split) expects as goal a conjunction or an AndConst-atom, and
; splits it into two sub-goals.

(define (split)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal)))
    (set! PPROOF-STATE (split-intern num-goals proof maxgoal))
    (pproof-state-history-push PPROOF-STATE)
    (display-comment "ok, we now have the new goals ")
    (if COMMENT-FLAG (newline))
    (display-num-goal (cadr (pproof-state-to-num-goals)))
    (if COMMENT-FLAG (newline))
    (display-num-goal (car (pproof-state-to-num-goals)))))

(define (split-intern num-goals proof maxgoal)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (drop-info (num-goal-to-drop-info num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (cvars (goal-to-cvars goal))
	 (goal-formula (goal-to-formula goal)))
    (cond
     ((and-form? goal-formula)
      (let* ((left-conjunct (and-form-to-left goal-formula))
	     (right-conjunct (and-form-to-right goal-formula))
	     (goalvar-left-formula
	      (context-and-cvars-and-formula-to-formula
	       context cvars left-conjunct))
	     (goalvar-right-formula
	      (context-and-cvars-and-formula-to-formula
	       context cvars right-conjunct))
	     (goalvar-left (formula-to-new-avar goalvar-left-formula
						DEFAULT-AVAR-NAME))
	     (goalvar-right (formula-to-new-avar goalvar-right-formula
						 DEFAULT-AVAR-NAME))
	     (ngleft (apply mk-goal-in-elim-form
			    (cons (make-goal-in-avar-form goalvar-left)
				  context)))
	     (ngright (apply mk-goal-in-elim-form
			     (cons (make-goal-in-avar-form goalvar-right)
				   context)))	       
	     (np (make-proof-in-and-intro-form ngleft ngright))
	     (new-num-leftgoal
	      (make-num-goal (+ 1 maxgoal) ngleft drop-info hypname-info))
	     (new-num-rightgoal
	      (make-num-goal (+ 2 maxgoal) ngright drop-info hypname-info)))
	(make-pproof-state (cons new-num-leftgoal
				 (cons new-num-rightgoal (cdr num-goals)))
			   (goal-subst (pproof-state-to-proof) goal np)
			   (+ 2 maxgoal))))
     ((and (atom-form? goal-formula)
	   (term=?
	    (make-term-in-const-form (pconst-name-to-pconst "AndConst"))
	    (term-in-app-form-to-final-op (atom-form-to-kernel goal-formula))))
      (let* ((kernel (atom-form-to-kernel goal-formula))
	     (args (term-in-app-form-to-args kernel))
	     (left-arg (if (= 2 (length args))
			   (car args)
			   (myerror "split" "two args expected")))
	     (right-arg (cadr args))
	     (left-conjunct (make-atomic-formula left-arg))
	     (right-conjunct (make-atomic-formula right-arg))
	     (goalvar-left-formula
	      (context-and-cvars-and-formula-to-formula
	       context cvars left-conjunct))
	     (goalvar-right-formula
	      (context-and-cvars-and-formula-to-formula
	       context cvars right-conjunct))
	     (goalvar-left (formula-to-new-avar goalvar-left-formula
						DEFAULT-AVAR-NAME))
	     (goalvar-right (formula-to-new-avar goalvar-right-formula
						 DEFAULT-AVAR-NAME))
	     (ngleft (apply mk-goal-in-elim-form
			    (cons (make-goal-in-avar-form goalvar-left)
				  context)))
	     (ngright (apply mk-goal-in-elim-form
			     (cons (make-goal-in-avar-form goalvar-right)
				   context)))
	     (np (mk-proof-in-elim-form
		  atoms-to-and-atom-proof
		  left-arg right-arg ngleft ngright))
	     (new-num-leftgoal
	      (make-num-goal (+ 1 maxgoal) ngleft drop-info hypname-info))
	     (new-num-rightgoal
	      (make-num-goal (+ 2 maxgoal) ngright drop-info hypname-info)))
	(make-pproof-state (cons new-num-leftgoal
				 (cons new-num-rightgoal (cdr num-goals)))
			   (goal-subst (pproof-state-to-proof) goal np)
			   (+ 2 maxgoal))))
     (else (myerror "split" "conjunction or AndConst atom expected"
		    goal-formula)))))

(define atoms-to-and-atom-proof
  (let ((var1 (pv "boole1"))
        (var2 (pv "boole2")))
    (mk-proof-in-intro-form
     var1
     (mk-proof-in-elim-form
      (make-proof-in-aconst-form
       (all-formula-to-cases-aconst
        (pf "all boole1,boole2(boole1 -> boole2 -> AndConst boole1 boole2)")))
      (make-term-in-var-form var1)
      (mk-proof-in-intro-form
       var2
       (mk-proof-in-elim-form
        (make-proof-in-aconst-form
         (all-formula-to-cases-aconst
          (pf "all boole2(T -> boole2 -> AndConst True boole2)")))
        (make-term-in-var-form var2)
        (mk-proof-in-intro-form
         (formula-to-new-avar (pf "T"))
         (mk-proof-in-intro-form
          (formula-to-new-avar (pf "T"))
          (make-proof-in-aconst-form truth-aconst)))
        (let ((u (formula-to-new-avar (pf "F"))))
          (mk-proof-in-intro-form
           (formula-to-new-avar (pf "T"))
           (mk-proof-in-intro-form
            u (make-proof-in-avar-form u))))))
      (mk-proof-in-intro-form
       var2
       (mk-proof-in-elim-form
        (make-proof-in-aconst-form
         (all-formula-to-cases-aconst
          (pf "all boole2(F -> boole2 -> AndConst False boole2)")))
        (make-term-in-var-form var2)
        (let ((u (formula-to-new-avar (pf "F"))))
          (mk-proof-in-intro-form
           u (mk-proof-in-intro-form
              (formula-to-new-avar (pf "T"))
              (make-proof-in-avar-form u))))
        (let ((u (formula-to-new-avar (pf "F"))))
          (mk-proof-in-intro-form
           u (mk-proof-in-intro-form
              (formula-to-new-avar (pf "F"))
              (make-proof-in-avar-form u))))))))))

; We allow multiple split over a conjunctive formula (all conjuncts
; connected through & which are at the same level are split at once).

(define (msplit)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal)))
    (set! PPROOF-STATE (split-intern num-goals proof maxgoal))
    (pproof-state-history-push PPROOF-STATE)
    (display-comment "ok, we now have the new goals ")
    (if COMMENT-FLAG (newline))
    (display-num-goal (cadr (pproof-state-to-num-goals)))
    (if COMMENT-FLAG (newline))
    (display-num-goal (car (pproof-state-to-num-goals)))
    (cond
     ((and-form? 
       (goal-to-formula (num-goal-to-goal (car (pproof-state-to-num-goals)))))
      (split)))))

; To be able to work on a goal different from that on top of the stack,
; we have to move it up using get:

(define (get goal-number)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal)))
    (set! PPROOF-STATE (get-intern num-goals proof maxgoal goal-number) )
    (pproof-state-history-push PPROOF-STATE)
    (display-comment "ok, now the active goal is")
    (if COMMENT-FLAG (newline))
    (display-num-goal (car (pproof-state-to-num-goals)))))

(define (get-intern num-goals proof maxgoal goal-number)
  (let* ((info (assoc goal-number num-goals))
         (num-goal (if info info (myerror "get" "goal number expected"
					  goal-number)))
	 (rest-num-goals
	  (list-transform-positive num-goals
	    (lambda (ng) (not (= (car ng) goal-number))))))
    (make-pproof-state (cons num-goal rest-num-goals) proof maxgoal)))

; The last n steps of an interactive proof can be made undone using
; (undo n).  (undo) has the same effect as (undo 1).

(define (undo . x)
  (let ((n (if (null? x) 1 (car x)))
	(l PPROOF-STATE-HISTORY-LENGTH))
    (cond
     ((not (and (integer? n) (positive? n)))
      (myerror "undo" "positive integer expected" n))
     ((< n l)
      (pproof-state-history-pop n)
      (set! PPROOF-STATE (pproof-state-history-head))
      (display-comment "ok, we are back to goal")
      (if COMMENT-FLAG (newline))
      (display-num-goal (car (pproof-state-to-num-goals))))
     (else (myerror "undo" "have not done that many steps" n)))))

; (undoto n) allows to go back to a previous pproof state whose (top)
; goal had number n

(define (undoto . x)
  (if (null? x) (myerror "undoto" "no argument given"))
  (let ((n (car x)))
    (if (not (and (integer? n) (positive? n)))
	(myerror "undoto" "positive integer expected" n))
    (do ((hist PPROOF-STATE-HISTORY (cdr hist))
	 (i 0 (+ 1 i)))
	((or (null? hist)
	     (= n (num-goal-to-number
		   (car (pproof-state-to-num-goals (car hist))))))
	 (if (null? hist)
	     (myerror "undoto"
		      "number never denoted a top goal" n)
	     (begin
	       (pproof-state-history-pop i)
	       (set! PPROOF-STATE (pproof-state-history-head))
	       (display-comment "ok, we are back to goal")
	       (if COMMENT-FLAG (newline))
	       (display-num-goal (car (pproof-state-to-num-goals)))))))))

; As special case of simind we first treat the case when we have a free
; algebra which is not simultaneously defined.  Then we do not have to
; provide the all-formula, but rather can take it form to present goal.

; (ind) expects a goal all x A with x total and of alg type, or a goal
; all x^(STotal x^ -> A) with x^ partial.  Let c1 ... cn be the
; constructors of the algebra.  In the first case, n new goals all
; xs_i(A[x_1i] -> ... -> A[x_ki] -> A[c_i xs_i]) are generated.  In
; the second case, for every non-parameter variable x^_ji the new goal
; has an additional assumption STotal x^_ji.

; (ind t) expects a goal A(t).  It computes the algebra rho as type of
; the term t.  Then again the n new goals above are generated.  If t
; is partial, another new goal STotal t is generated.

(define (ind . opt-term)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply ind-intern (append (list num-goals proof maxgoal) opt-term)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (ind-intern num-goals proof maxgoal . opt-term) 
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (context (goal-to-context goal))
	 (formula (goal-to-formula goal))
	 (all-formula
          (if (null? opt-term)
              (if (all-form? formula)
                  formula
                  (myerror "ind" "all formula expected" formula))
              (let* ((term (car opt-term))
                     (type (if (term-form? term)
			       (term-to-type term)
			       (myerror "ind" "term expected" term)))
                     (t-deg (term-to-t-deg term))
                     (var (if (t-deg-one? t-deg)
                              (type-to-new-var type)
                              (type-to-new-partial-var type)))
                     (varterm (make-term-in-var-form var))
                     (kernel-formula
                      (if (t-deg-one? t-deg)
                          (formula-gen-subst formula term varterm)
                          (make-imp
			   (make-stotal varterm)
			   (formula-gen-subst formula term varterm)))))
                (make-all var kernel-formula))))
	 (ind-aconst (all-formulas-to-ind-aconst all-formula)) ;includes check
	 (var (all-form-to-var all-formula))
	 (kernel (all-form-to-kernel all-formula))
	 (newvar (var-to-new-var var)) ;makes var usable in the step proofs
	 (partial-flag (t-deg-zero? (var-to-t-deg var)))
	 (type (var-to-type var))
	 (alg-name (if (alg-form? type)
		       (alg-form-to-name type)
		       (myerror "ind" "variable of algebra type expected"
				var)))
	 (k (length (alg-name-to-typed-constr-names alg-name)))
	 (avar (if partial-flag
		   (let* ((term (if (null? opt-term)
				    (make-term-in-var-form newvar)
				    (car opt-term)))
			  (stotal-prem (make-stotal term)))
		     (formula-to-new-avar stotal-prem))))
	 (auxpproof (if (null? opt-term)
			(pproof-all-intro
			 (make-pproof-state num-goals proof maxgoal) newvar)
			(make-pproof-state num-goals proof maxgoal)))
	 (pproof (if (and partial-flag (null? opt-term))
                     (pproof-imp-intro auxpproof avar)
                     auxpproof))
	 (stotal-proof-or-defgoal
	  (if partial-flag
	      (if (pair? opt-term)
		  DEFAULT-GOAL-NAME
		  (make-proof-in-avar-form avar)))))
    (apply
     use-with-intern
     (append pproof
             (list (make-proof-in-aconst-form ind-aconst))
	     (map make-term-in-var-form (formula-to-free all-formula))
             (if (null? opt-term)
                 (list (make-term-in-var-form newvar))
                 opt-term)
             (if partial-flag
		 (list stotal-proof-or-defgoal)
		 '())
	     (vector->list (make-vector k DEFAULT-GOAL-NAME))))))

(define (stotal-imp-formula? formula term)
  (and
   (imp-form? formula)
   (let ((prem (imp-form-to-premise formula)))
     (formula=? prem (make-stotal term)))))

(define (stotal-or-se-imp-formula? formula term)
  (and
   (imp-form? formula)
   (let ((prem (imp-form-to-premise formula)))
     (or (formula=? prem (make-se term))
         (formula=? prem (make-stotal term))))))

(define (stotal-or-se-or-e-imp-formula? formula term)
  (and
   (imp-form? formula)
   (let ((prem (imp-form-to-premise formula)))
     (or (formula=? prem (make-stotal term))
	 (formula=? prem (make-se term))
         (formula=? prem (make-e term))))))

(define (all-partial-stotal-imp-formula? all-formula)
  (let ((var (all-form-to-var all-formula))
	(kernel (all-form-to-kernel all-formula)))
    (and (t-deg-zero? (var-to-t-deg var))
	 (imp-form? kernel)
	 (let ((prem (imp-form-to-premise kernel)))
	   (and (predicate-form? prem)
		(let ((pred (predicate-form-to-predicate prem))
		      (args (predicate-form-to-args prem)))
		  (and (predconst-form? pred)
		       (= 1 (length args))
		       (let ((name (predconst-to-name pred)))
			 (and (string=? name "STotal")
			      (equal? (make-term-in-var-form var)
				      (car args)))))))))))

; pproof-all-intro does an all-intro without changing the maxgoal
; number

(define (pproof-all-intro pproof var)
  (let* ((num-goals (pproof-state-to-num-goals pproof))
         (proof (pproof-state-to-proof pproof))
         (maxgoal (pproof-state-to-maxgoal pproof))
         (num-goal (car num-goals))
         (goal (num-goal-to-goal num-goal))
         (hypname-info (num-goal-to-hypname-info num-goal))
         (drop-info (num-goal-to-drop-info num-goal))
         (ng (make-goal-in-all-elim-form goal var))
         (new-num-goal (make-num-goal maxgoal ng drop-info hypname-info)))
    (make-pproof-state (cons new-num-goal (cdr num-goals))
                       (goal-subst proof goal
                                   (make-proof-in-all-intro-form var ng))
                       maxgoal)))

(define (pproof-all-intros pproof . vars)
  (if (null? vars)
      pproof
      (apply pproof-all-intros
             (cons (pproof-all-intro pproof (car vars))
                   (cdr vars)))))

; pproof-imp-intro does an imp-intro without changing the maxgoal
; number

(define (pproof-imp-intro pproof avar)
  (let* ((num-goals (pproof-state-to-num-goals pproof))
         (proof (pproof-state-to-proof pproof))
         (maxgoal (pproof-state-to-maxgoal pproof))
         (num-goal (car num-goals))
         (goal (num-goal-to-goal num-goal))
         (hypname-info (num-goal-to-hypname-info num-goal))
         (drop-info (num-goal-to-drop-info num-goal))
         (ng (make-goal-in-imp-elim-form goal avar))
         (new-num-goal (make-num-goal maxgoal ng drop-info hypname-info)))
    (make-pproof-state (cons new-num-goal (cdr num-goals))
                       (goal-subst proof goal
                                   (make-proof-in-imp-intro-form avar ng))
                       maxgoal)))

; (simind) expects a goal all x A with x total and of alg type, or a
; goal all x^(STotal x^ -> A) with x^ partial.  We have to provide the
; other all formulas to be proved simultaneously with the goal.

(define (simind . all-formulas)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply simind-intern
		 (append (list num-goals proof maxgoal) all-formulas)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (simind-intern num-goals proof maxgoal . all-formulas)
  (let* ((num-goal (car num-goals))
         (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (all-formula (goal-to-formula goal))
	 (var (all-form-to-var all-formula))
         (newvar (var-to-new-var var))
	 (partial-flag (t-deg-zero? (var-to-t-deg var)))
	 (type (var-to-type var))
         (all-formula-and-all-formulas (cons all-formula all-formulas))
	 (aconst (apply all-formulas-to-ind-aconst
			all-formula-and-all-formulas))
	 (alg-names
	  (do ((l all-formula-and-all-formulas (cdr l))
	       (res '() (if (all-form? (car l))
			    (let* ((var (all-form-to-var (car l)))
				   (type (var-to-type var)))
			      (if (alg-form? type)
				  (cons (alg-form-to-name type) res)
				  (myerror
				   "simind" "variable of algebra type expected"
				   var)))
			    (myerror "simind" "all formula expected"
				     (car l)))))
	      ((null? l) (reverse res))))
	 (alg-name (car alg-names))
	 (simalg-names (alg-name-to-simalg-names alg-name))
         (avar
	  (if partial-flag
	      (if (apply
		   and-op
		   (map (lambda (kernel var)
			  (stotal-imp-formula?
			   kernel (make-term-in-var-form var)))
			(map all-form-to-kernel all-formula-and-all-formulas)
			(map all-form-to-var all-formula-and-all-formulas)))
		  (let* ((term (make-term-in-var-form newvar))
			 (stotal-prem (make-stotal term)))
		    (formula-to-new-avar stotal-prem))
		  (apply myerror
			 (cons "simind-intern"
			       (cons "all formulas should be partial"
				     all-formula-and-all-formulas))))))
	 (auxpproof (pproof-all-intro
                     (make-pproof-state num-goals proof maxgoal) newvar))
         (pproof (if partial-flag
                     (pproof-imp-intro auxpproof avar)
                     auxpproof)))
    (if ;var total, but not all of all-formulas total
     (and (not partial-flag)
	  (not (apply and-op (map (lambda (x)
				    (t-deg-one?
				     (var-to-t-deg
				      (all-form-to-var x))))
				  all-formulas))))
     (apply myerror (cons "simind-intern"
                          (cons "all formulas should be total" all-formulas))))
    (if (not (equal? alg-names (remove-duplicates alg-names)))
	(apply myerror (cons "simind-intern"
                             (cons "distinct algebras expected" alg-names))))
    (if (pair? (set-minus simalg-names alg-names))
	(myerror "simind-intern" "formulas missing for"
		 (set-minus simalg-names alg-names)))
    (if (pair? (set-minus alg-names simalg-names))
	(myerror "simind-intern" "too many alg names"
		 (set-minus alg-names simalg-names)))
    (let* ((typed-constr-names
	    (apply append (map alg-name-to-typed-constr-names alg-names)))
	   (k (length typed-constr-names))
	   (free (apply union (map formula-to-free all-formulas))))
      (apply use-with-intern
	     (append pproof
		     (list (make-proof-in-aconst-form aconst))
		     (map make-term-in-var-form free)
                     (list (make-term-in-var-form newvar))
                     (if partial-flag
                         (list (make-proof-in-avar-form avar))
                         '())
		     (vector->list (make-vector k DEFAULT-GOAL-NAME)))))))

; (gind h) expects a goal of the form "all xs A(xs)" and generates a
; new goal Prog_h {xs | A(xs)} where h is a term of type rhos=>nat,
; x_i has type rho_i and Prog_h {xs | A (xs)} = 
; all xs(all ys(h ys<h xs -> A(ys)) -> A(xs)).

; (gind h t1 .. tn) expects a goal A(ts) and generates the same goal
; as for (gind h) with the formula all xs A(xs).

(define (gind term . opt-terms)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply gind-intern
                 (append (list num-goals proof maxgoal term) opt-terms)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (gind-intern num-goals proof maxgoal measure . opt-terms)
  (let* ((num-goal (car num-goals))
         (goal (num-goal-to-goal num-goal))
         (formula (goal-to-formula goal))
         (types (if (not (term-form? measure))
                    (myerror "gind" "measure term expected" measure)
                    (arrow-form-to-arg-types (term-to-type measure))))
         (m (length types)) ;|rhos|
         (all-formula
          (if (null? opt-terms)
              formula
              (let* ((vars (map (lambda (t)
                                  (if (t-deg-one? (term-to-t-deg t))
                                      (type-to-new-var (term-to-type t))
                                      (myerror "gind" "total terms expected"
                                               t)))
                                opt-terms))
                     (gen-subst (map (lambda (x y)
                                       (list x (make-term-in-var-form y)))
                                     opt-terms vars))
                     (kernel (formula-gen-substitute formula gen-subst)))
                (apply mk-all (append vars (list kernel))))))
         (vars (all-form-to-vars all-formula m))
         (newvars (map var-to-new-var vars)) ;for usability we use fresh vars
         (partial-flag (apply or-op (map (lambda (x)
                                           (t-deg-zero? (var-to-t-deg x)))
                                         vars)))
         (pproof (if partial-flag
                     (myerror "gind" "total variables expected" vars)
                     (apply
                      pproof-all-intros
                      (cons (make-pproof-state num-goals proof maxgoal)
                            (list-tail newvars (length opt-terms)))))))
    (cond ((not (equal? (arrow-form-to-final-val-type (term-to-type measure))
                        (py "nat")))
           (myerror "gind"
                    "the expected value type of the measure term is nat, not"
                    (arrow-form-to-final-val-type (term-to-type measure))))
          ((not (equal? types
                        (map var-to-type
                             (all-form-to-vars all-formula m)))) 
           (myerror "gind" types
                    "are the expected types of the variables in"
                    all-formula))
          (else
           (apply
            use-with-intern
            (append pproof
                    (list (make-proof-in-aconst-form
                           (all-formula-to-gind-aconst all-formula m)))
                    (map make-term-in-var-form (formula-to-free all-formula))
                    (cons measure
                          (if (pair? opt-terms)
                              opt-terms
                              '()))
                    (map make-term-in-var-form
                         (list-tail newvars (length opt-terms)))
                    (list DEFAULT-GOAL-NAME)
                    (list (pt "True")
                          (make-proof-in-aconst-form truth-aconst))))))))

; Introduction for inductively defined predicates

(define (intro i . terms)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply intro-intern
		 (append (list num-goals proof maxgoal i) terms)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (intro-intern num-goals proof maxgoal i . terms)
  (let* ((num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (formula (goal-to-formula goal))
	 (idpredconst
	  (if (predicate-form? formula)
	      (let ((pred (predicate-form-to-predicate formula)))
		(if (idpredconst-form? pred)
		    pred
		    (myerror "intro" "idpredconst expected" pred)))
	      (myerror "intro" "predicate expected" formula)))
	 (intro-aconst (number-and-idpredconst-to-intro-aconst i idpredconst)))
    (apply use-intern
	   (append (list num-goals proof maxgoal)
		   (cons (make-proof-in-aconst-form intro-aconst) terms)))))

(define (intro-with i . x-list)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply intro-with-intern
		 (append (list num-goals proof maxgoal i) x-list)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (intro-with-intern num-goals proof maxgoal i . x-list)
  (let* ((num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (formula (goal-to-formula goal))
	 (idpredconst
	  (if (predicate-form? formula)
	      (let ((pred (predicate-form-to-predicate formula)))
		(if (idpredconst-form? pred)
		    pred
		    (myerror "intro-with" "idpredconst expected" pred)))
	      (myerror "intro-with" "predicate expected" formula)))
	 (intro-aconst (number-and-idpredconst-to-intro-aconst i idpredconst)))
    (apply use-with-intern
	   (append (list num-goals proof maxgoal)
		   (cons (make-proof-in-aconst-form intro-aconst) x-list)))))

; Recall that I rs provides
; - a type substitution,
; - a predicate instantiation, and
; - the list rs of argument terms.

; In (elim idhyp) idhyp is, with an inductively defined predicate I,
; - a number or string identifying a hypothesis I rs form the context
; - the name of a global assumption or theorem I rs;
; - a closed proof of a formula I rs;
; - a formula I rs with free variables from the context, generating a
;   new goal.
; Then the (strengthened) elimination axiom is used with rs for xs and
; idhyp for I rs to prove the goal A(rs), leaving the instantiated
; (with {xs|A(xs)}) clauses as new goals.

; (elim) expects an inst-imp-formula I rs -> A(rs) as goal.  Then the
; (strengthened) instantiated (with {xs|A(xs)}) clauses are new goals.

; In case of simultaneously inductively defined predicate constants we
; can provide other imp-formulas to be proved simultaneously with the
; given one.  Then the (strengthened) simplified clauses are generated
; as new goals.

(define (elim . opt-idhyp-and-imp-formulas)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply elim-intern (append (list num-goals proof maxgoal)
				     opt-idhyp-and-imp-formulas)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (elim-intern num-goals proof maxgoal . opt-idhyp-and-imp-formulas)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (avars (context-to-avars context))
	 (l (length avars))
	 (goal-formula (goal-to-formula goal))
	 (opt-idhyp
	  (if (and (pair? opt-idhyp-and-imp-formulas)
		   (not (imp-form? (car opt-idhyp-and-imp-formulas))))
	      (list (car opt-idhyp-and-imp-formulas))
	      '()))
	 (imp-formulas
	  (if (and (pair? opt-idhyp-and-imp-formulas)
		   (not (imp-form? (car opt-idhyp-and-imp-formulas))))
	      (cdr opt-idhyp-and-imp-formulas)
	      opt-idhyp-and-imp-formulas))
	 (id-formula-and-idhyp1
	  (if
	   (null? opt-idhyp)
	   (list (if (imp-form? goal-formula)
		     (imp-form-to-premise goal-formula)
		     (myerror "elim" "implication expected" goal-formula))
		 #f)
	   (let ((idhyp (car opt-idhyp)))
	     (cond
	      ((and (integer? idhyp) (positive? idhyp))
	       (if (<= idhyp l)
		   (let* ((avar (list-ref avars (- idhyp 1)))
			  (formula (avar-to-formula avar)))
		     (list formula (make-proof-in-avar-form avar)))
		   (myerror "elim" "assumption number expected" idhyp)))
	      ((and (string? idhyp)
		    (member idhyp (hypname-info-to-names hypname-info)))
	       (let ((i (name-and-hypname-info-to-index idhyp hypname-info)))
		 (if (<= i l)
		     (let* ((avar (list-ref avars (- i 1)))
			    (formula (avar-to-formula avar)))
		       (list formula (make-proof-in-avar-form avar)))
		     (myerror "elim" "assumption number expected" i))))
	      ((and (string? idhyp) (assoc idhyp THEOREMS))
	       (let* ((aconst (theorem-name-to-aconst idhyp))
		      (formula (aconst-to-formula aconst)))
		 (list formula (make-proof-in-aconst-form aconst))))
	      ((and (string? idhyp) (assoc idhyp GLOBAL-ASSUMPTIONS))
	       (let* ((aconst (global-assumption-name-to-aconst idhyp))
		      (formula (aconst-to-formula aconst)))
		 (list formula (make-proof-in-aconst-form aconst))))
	      ((proof-form? idhyp) (list (proof-to-formula idhyp) idhyp))
	      ((formula-form? idhyp) ;then a new goal is created
	       (list idhyp DEFAULT-GOAL-NAME))
	      (else (myerror "elim" "illegal argument" idhyp))))))
	 (id-formula (car id-formula-and-idhyp1))
	 (idhyp1 (cadr id-formula-and-idhyp1))
	 (inst-imp-formula (if (null? opt-idhyp)
			       goal-formula
			       (make-imp id-formula goal-formula)))
	 (idpredconst
	  (if (and (predicate-form? id-formula)
		   (idpredconst-form?
		    (predicate-form-to-predicate id-formula)))
	      (predicate-form-to-predicate id-formula)
	      (myerror "elim" "inductively defined prime formula expected"
		       id-formula)))
	 (arity (idpredconst-to-arity idpredconst))
	 (args (predicate-form-to-args id-formula))
	 (types (arity-to-types arity))
	 (vars (map type-to-new-partial-var types))
	 (varterms (map make-term-in-var-form vars))
	 (imp-formula
	  (formula-gen-substitute
	   inst-imp-formula
	   (map (lambda (x y) (list x y)) args varterms)))
	 (inst-imp-formula-test
	  (if (not (classical-formula=?
		    inst-imp-formula
		    (formula-substitute
		     imp-formula
		     (map (lambda (x y) (list x y)) vars args))))
	      (myerror "elim" "elim-aconst not computable from"
		       inst-imp-formula)))
	 (elim-aconst (apply imp-formulas-to-elim-aconst
			     (cons imp-formula imp-formulas)))
	 (inst-elim-formula ;Ij xs^ -> K1(Is,Cs) ->..-> Kk(Is,Cs) -> Cj rs
	  (aconst-to-inst-formula elim-aconst))
	 (free (formula-to-free inst-elim-formula))
	 (new-arg-vars (map term-in-var-form-to-var
			    (predicate-form-to-args
			     (imp-form-to-premise inst-elim-formula))))
	 (idpc-vars (set-minus (formula-to-free
				(imp-form-to-premise inst-elim-formula))
			       new-arg-vars))
	 (rest-vars (set-minus free (append idpc-vars new-arg-vars)))
	 (k (- (length (imp-form-to-premises
			(aconst-to-uninst-formula elim-aconst)))
	       1)))
    (if
     (null? opt-idhyp)
     (let* ((avar (formula-to-new-avar id-formula))
	    (pproof (pproof-imp-intro
		     (make-pproof-state num-goals proof maxgoal)
		     avar)))
       (apply use-with-intern
	      (append pproof
		      (list (make-proof-in-aconst-form elim-aconst))
		      (map make-term-in-var-form idpc-vars)
		      args
		      (map make-term-in-var-form rest-vars)
		      (list (make-proof-in-avar-form avar))
		      (vector->list (make-vector k DEFAULT-GOAL-NAME)))))
     (apply use-with-intern
	    (append (list num-goals proof maxgoal
			  (make-proof-in-aconst-form elim-aconst))
		    (map make-term-in-var-form idpc-vars)
		    args
		    (map make-term-in-var-form rest-vars)
		    (list idhyp1)
		    (vector->list (make-vector k DEFAULT-GOAL-NAME)))))))

; In the following definition of inversion, x is one of the following.
; - A number or string identifying a hypothesis I rs form the context.
; - The name of a theorem or global assumption stating I rs
; - A closed proof of I rs
; - A formula I rs with free vars from the context, generating a new goal.

; imp-formulas have the form J ss -> B.  Here I,J are inductively
; defined predicates, with clauses K1 ... Kn.  One uses the elim-aconst
; for I xs -> xs=rs -> goal and the additional implications J(ys) ->
; ys=ss -> B, with ? ... ?  for the clauses, rs for xs and proofs for
; rs=rs, to obtain the goal.  Then many of the generated goals for the
; clauses will contain false premises, coming from substituted
; equations xs=rs, and are proved automatically.  

; imp-formulas not provided are taken as J xs -> J xs.  Generated
; clauses for such J are proved automatically from the intro axioms
; (the rec-prems are not needed).

; For simultaneous inductively defined predicates simplified-inversion
; does not add imp-formulas J xs -> J xs to form the elim-aconst.
; Then the (new) imp-formulas-to-uninst-elim-formulas-etc generates
; simplified clauses.  In some special cases this suffices.

(define (inversion x . imp-formulas)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply inversion-intern
		 (append (list num-goals proof maxgoal x)
			 imp-formulas)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (inversion-intern num-goals proof maxgoal x . imp-formulas)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (goal-formula (goal-to-formula goal))
	 (prem (if (formula-form? x) x (hyp-info-to-formula num-goal x)))
	 (imp-formula (make-imp prem goal-formula))
	 (imp-formula-and-imp-formulas (cons imp-formula imp-formulas))
	 (prems (map (lambda (formula)
		       (if (imp-form? formula)
			   (imp-form-to-premise formula)
			   (myerror "inversion"
				    "implication expected" formula)))
		     imp-formula-and-imp-formulas))
	 (concls (map imp-form-to-conclusion imp-formula-and-imp-formulas))
	 (preds (map (lambda (prem)
		       (if (predicate-form? prem)
			   (predicate-form-to-predicate prem)
			   (myerror "inversion" "predicate expected" prem)))
		     prems))
	 (idpredconsts
	  (map (lambda (pred prem)
		 (if (idpredconst-form? pred) pred
		     (myerror "inversion"
			      "inductively defined predicate expected"
			      prem)))
	       preds prems))
	 (names (map idpredconst-to-name idpredconsts))
	 (name (car names))
	 (simidpc-names (idpredconst-name-to-simidpc-names name))
	 (added-names (set-minus simidpc-names names))
	 (types (idpredconst-to-types (car preds)))
	 (cterms (idpredconst-to-cterms (car preds)))
	 (added-idpcs (map (lambda (name)
			     (make-idpredconst name types cterms))
			   added-names))
	 (added-arities (map (lambda (idpc) (idpredconst-to-arity idpc))
			     added-idpcs))
	 (added-type-lists (map arity-to-types added-arities))
	 (added-var-lists (map (lambda (types)
				 (map type-to-new-partial-var types))
			       added-type-lists))
	 (added-varterm-lists (map (lambda (vars)
				     (map make-term-in-var-form vars))
				   added-var-lists))
	 (added-imp-formulas
	  (map (lambda (pred varterms)
		 (let ((predicate-formula (apply make-predicate-formula
						 (cons pred varterms))))
		   (make-imp predicate-formula predicate-formula)))
	       added-idpcs added-varterm-lists))
	 (arg-lists (map predicate-form-to-args prems))
	 (type-lists (map (lambda (args) (map term-to-type args))
			  arg-lists))
	 (var-lists (map (lambda (types) (map type-to-new-partial-var types))
			 type-lists))
	 (varterm-lists (map (lambda (vars) (map make-term-in-var-form vars))
			     var-lists))
	 (eq-lists (map (lambda (varterms args types)
			  (map (lambda (varterm arg type)
				 (if (finalg? type)
				     (make-= arg varterm)
				     (make-eq arg varterm)))
			       varterms args types))
			varterm-lists arg-lists type-lists))
	 (new-imp-formulas
	  (map (lambda (pred varterms eqs concl)
		 (apply mk-imp (cons (apply make-predicate-formula
					    (cons pred varterms))
				     (append eqs (list concl)))))
	       preds varterm-lists eq-lists concls))
	 (elim-aconst (apply imp-formulas-to-elim-aconst
			     (append new-imp-formulas added-imp-formulas)))
	 (free (formula-to-free (aconst-to-inst-formula elim-aconst)))
	 (args (car arg-lists))
	 (rest-of-free (list-tail free (length args)))
	 (instantiated-elim-proof
	  (apply mk-proof-in-elim-form
		 (cons (make-proof-in-aconst-form elim-aconst)
		       (append args (map make-term-in-var-form
					 rest-of-free)))))
	 (k (length (apply append (map idpredconst-name-to-clauses
				       simidpc-names))))
	 (strengthened-clauses (cdr (imp-form-to-premises
                                     (proof-to-formula
                                      instantiated-elim-proof) (+ k 1))))
	 (eq-proofs
	  (map (lambda (arg type)
		 (if (finalg? type)
		     (make-proof-in-aconst-form truth-aconst)
		     (mk-proof-in-elim-form
		      (proof-subst
		       (make-proof-in-aconst-form eq-refl-aconst)
		       (car (formula-to-tvars
			     (aconst-to-uninst-formula eq-refl-aconst)))
		       type)
		      arg)))
	       (car arg-lists) (car type-lists)))
	 (scl-lists ;one for each of simidpc-names
	  (do ((names simidpc-names (cdr names))
	       (res-and-l
		(list '() strengthened-clauses)
		(let* ((name (car names))
		       (number-of-clauses
			(length (idpredconst-name-to-clauses name)))
		       (res (car res-and-l))
		       (l (cadr res-and-l)))
		  (list (cons (list-head l number-of-clauses) res)
			(list-tail l number-of-clauses)))))
	      ((null? names) (reverse (car res-and-l)))))
	 (clause-proofs
	  (apply append
		 (map (lambda (name scls)
			(if (member name added-names)
			    (let ((idpc (make-idpredconst name types cterms)))
			      (do ((i 0 (+ 1 i))
				   (l scls (cdr l))
				   (res '() (cons (added-scl-etc-to-proof
						   (car l) i idpc) res)))
				  ((null? l) (reverse res))))
			    (map (lambda (scl)
				   (let ((test (formula-to-efq-proof scl)))
				     (if test test DEFAULT-GOAL-NAME)))
				 scls)))
		      simidpc-names scl-lists))))
    (if (not (equal? names (remove-duplicates names)))
	(apply myerror (append (list "inversion" "distinct names expected")
			       names)))
    (if (pair? (set-minus names simidpc-names))
	(apply myerror (append (list "inversion" "superfluous formulas for")
			       (set-minus names simidpc-names))))
    (apply use-with-intern
	   (append (list num-goals proof maxgoal instantiated-elim-proof x)
		   clause-proofs
		   eq-proofs))))

(define (simplified-inversion x . imp-formulas)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply simplified-inversion-intern
		 (append (list num-goals proof maxgoal x)
			 imp-formulas)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (simplified-inversion-intern num-goals proof maxgoal x . imp-formulas)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (goal-formula (goal-to-formula goal))
	 (prem (if (formula-form? x) x (hyp-info-to-formula num-goal x)))
	 (imp-formula (make-imp prem goal-formula))
	 (imp-formula-and-imp-formulas (cons imp-formula imp-formulas))
	 (prems (map (lambda (formula)
		       (if (imp-form? formula)
			   (imp-form-to-premise formula)
			   (myerror "simplified-inversion"
				    "implication expected" formula)))
		     imp-formula-and-imp-formulas))
	 (concls (map imp-form-to-conclusion imp-formula-and-imp-formulas))
	 (preds (map (lambda (prem)
		       (if (predicate-form? prem)
			   (predicate-form-to-predicate prem)
			   (myerror "simplified-inversion"
				    "predicate expected" prem)))
		     prems))
	 (idpredconsts
	  (map (lambda (pred prem)
		 (if (idpredconst-form? pred) pred
		     (myerror "simplified-inversion"
			      "inductively defined predicate expected"
			      prem)))
	       preds prems))
	 (names (map idpredconst-to-name idpredconsts))
	 (name (car names))
	 (simidpc-names (idpredconst-name-to-simidpc-names name))
	 (types (idpredconst-to-types (car preds)))
	 (cterms (idpredconst-to-cterms (car preds)))
	 (arg-lists (map predicate-form-to-args prems))
	 (type-lists (map (lambda (args) (map term-to-type args))
			  arg-lists))
	 (var-lists (map (lambda (types) (map type-to-new-partial-var types))
			 type-lists))
	 (varterm-lists (map (lambda (vars) (map make-term-in-var-form vars))
			     var-lists))
	 (eq-lists (map (lambda (varterms args types)
			  (map (lambda (varterm arg type)
				 (if (finalg? type)
				     (make-= arg varterm)
				     (make-eq arg varterm)))
			       varterms args types))
			varterm-lists arg-lists type-lists))
	 (new-imp-formulas
	  (map (lambda (pred varterms eqs concl)
		 (apply mk-imp (cons (apply make-predicate-formula
					    (cons pred varterms))
				     (append eqs (list concl)))))
	       preds varterm-lists eq-lists concls))
	 (elim-aconst (apply imp-formulas-to-elim-aconst new-imp-formulas))
	 (free (formula-to-free (aconst-to-inst-formula elim-aconst)))
	 (args (car arg-lists))
	 (rest-of-free (list-tail free (length args)))
	 (inst-elim-proof
	  (apply mk-proof-in-elim-form
		 (cons (make-proof-in-aconst-form elim-aconst)
		       (append args (map make-term-in-var-form
					 rest-of-free)))))
	 (k (- (length (imp-form-to-premises
			(aconst-to-uninst-formula elim-aconst)))
	       1))
	 (clauses (cdr (imp-form-to-premises
			(proof-to-formula inst-elim-proof) (+ k 1))))
	 (eq-proofs
	  (map (lambda (arg type)
		 (if (finalg? type)
		     (make-proof-in-aconst-form truth-aconst)
		     (mk-proof-in-elim-form
		      (proof-subst
		       (make-proof-in-aconst-form eq-refl-aconst)
		       (car (formula-to-tvars
			     (aconst-to-uninst-formula eq-refl-aconst)))
		       type)
		      arg)))
	       (car arg-lists) (car type-lists)))
	 (clause-proofs (map (lambda (clause)
			       (let ((test (formula-to-efq-proof clause)))
				 (if test test DEFAULT-GOAL-NAME)))
			     clauses)))
    (if (not (equal? names (remove-duplicates names)))
	(apply myerror (append (list "simplified-inversion"
				     "distinct names expected")
			       names)))
    (if (pair? (set-minus names simidpc-names))
	(apply myerror (append (list "simplified-inversion"
				     "superfluous formulas for")
			       (set-minus names simidpc-names))))
    (apply use-with-intern
	   (append (list num-goals proof maxgoal inst-elim-proof x)
		   clause-proofs
		   eq-proofs))))

(define (added-scl-etc-to-proof scl i idpc)
  (let* ((intro-aconst (number-and-idpredconst-to-intro-aconst i idpc))
	 (uninst-clause (aconst-to-uninst-formula intro-aconst))
	 (orig-kernel (all-allnc-form-to-final-kernel uninst-clause))
	 (number-of-orig-nc-prems
	  (length (impnc-form-to-premises orig-kernel)))
	 (number-of-orig-prems
	  (length (imp-form-to-premises (impnc-form-to-final-conclusion
					 orig-kernel))))
	 (ncvars (allnc-form-to-vars scl))
	 (vars (all-form-to-vars (allnc-form-to-final-kernel scl)))
	 (scl-total-prems (imp-form-to-premises
			   (all-form-to-final-kernel
			    (allnc-form-to-final-kernel scl))))
	 (scl-nc-prems (list-head scl-total-prems number-of-orig-nc-prems))
	 (scl-prems (list-head
		     (list-tail scl-total-prems number-of-orig-nc-prems)
		     number-of-orig-prems))
	 (rec-scl-prems (list-tail scl-total-prems
				   (+ number-of-orig-nc-prems
				      number-of-orig-prems)))
	 (scl-nc-prem-avars (map formula-to-new-avar scl-nc-prems))
	 (scl-prem-avars (map formula-to-new-avar scl-prems))
	 (rec-scl-prem-avars (map formula-to-new-avar rec-scl-prems))
	 (concl-proof
	  (apply mk-proof-in-elim-form
		 (cons (make-proof-in-aconst-form intro-aconst)
		       (append
			(map make-term-in-var-form ncvars)
			(map make-term-in-var-form vars)
			(map make-proof-in-avar-form scl-nc-prem-avars)
			(map make-proof-in-avar-form scl-prem-avars))))))
    (apply
     mk-proof-in-nc-intro-form
     (append
      ncvars
      (list (apply
	     mk-proof-in-intro-form
	     (append
	      vars
	      (list (apply
		     mk-proof-in-nc-intro-form
		     (append
		      scl-nc-prem-avars
		      (list (apply
			     mk-proof-in-intro-form
			     (append				 
			      scl-prem-avars rec-scl-prem-avars
			      (list concl-proof))))))))))))))

; ex-intro and ex-elim can be used in interactive proofs.

(define (ex-intro term)
  (if (string? term)
      (myerror "ex-intro" "use pt (parse-term) to produce a term from string"
	       term))
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE (ex-intro-intern num-goals proof maxgoal term))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (ex-intro-intern num-goals proof maxgoal term)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (context (goal-to-context goal))
	 (formula (goal-to-formula goal))
	 (free (if (ex-form? formula)
                   (formula-to-free formula)
                   (myerror "ex-intro" "existential goal expected"))))
    (apply use-with-intern
	   (append (list num-goals proof maxgoal)
		   (cons (make-proof-in-aconst-form
			  (ex-formula-to-ex-intro-aconst formula))
			 (append (map make-term-in-var-form free)
				 (list term DEFAULT-GOAL-NAME)))))))

; In the following definition of ex-elim x is
; - a number or string identifying an existential hypothesis form the context,
; - the name of an existential global assumption or theorem,
; - a closed proof of an existential formula (closed ones suffice),
; - an existential formula with free variables from the context, 
;   generating a new goal.

(define (ex-elim x)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE (ex-elim-intern num-goals proof maxgoal x))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (ex-elim-intern num-goals proof maxgoal x)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (avars (context-to-avars context))
	 (l (length avars))
	 (goal-formula (goal-to-formula goal))
	 (ex-formula-and-x1
	  (cond
	   ((and (integer? x) (positive? x))
	    (if (<= x l)
		(let* ((avar (list-ref avars (- x 1)))
		       (formula (avar-to-formula avar)))
		  (list formula (make-proof-in-avar-form avar)))
		(myerror "ex-elim" "assumption number expected" x)))
	   ((and (string? x)
		 (member x (hypname-info-to-names hypname-info)))
	    (let ((i (name-and-hypname-info-to-index x hypname-info)))
	      (if (<= i l)
		  (let* ((avar (list-ref avars (- i 1)))
			 (formula (avar-to-formula avar)))
		    (list formula (make-proof-in-avar-form avar)))
		  (myerror "ex-elim" "assumption number expected" i))))
	   ((and (string? x) (assoc x THEOREMS))
	    (let* ((aconst (theorem-name-to-aconst x))
		   (formula (aconst-to-formula aconst)))
	      (list formula (make-proof-in-aconst-form aconst))))
	   ((and (string? x) (assoc x GLOBAL-ASSUMPTIONS))
	    (let* ((aconst (global-assumption-name-to-aconst x))
		   (formula (aconst-to-formula aconst)))
	      (list formula (make-proof-in-aconst-form aconst))))
	   ((proof-form? x) (list (proof-to-formula x) x))
	   ((formula-form? x) ;then a new goal is created
	    (list x DEFAULT-GOAL-NAME))
	   (else (myerror "ex-elim" "illegal argument" x))))
         (ex-formula (car ex-formula-and-x1))
         (x1 (cadr ex-formula-and-x1))
         (free1 (if (ex-form? ex-formula)
                    (formula-to-free ex-formula)
                    (myerror "ex-elim" "ex formula expected" ex-formula)))
         (free2 (formula-to-free goal-formula))
         (free (union free1 free2)))
    (apply use-with-intern
	   (append (list num-goals proof maxgoal
			 (make-proof-in-aconst-form
			  (ex-formula-and-concl-to-ex-elim-aconst
			   ex-formula goal-formula)))
		   (map make-term-in-var-form free)
		   (list x1 DEFAULT-GOAL-NAME)))))

; Suppose we prove a goal G from an existential hypothesis ex x A,
; exnc x A or exc x1,..,xn.A1!..!Am.  The natural way to use this
; hypothesis is to say "by exhyp assume we have an x satisfying A" or
; "by exhyp assume we have x1,..,xn satisfying A1...,Am".
; Correspondingly we provide

(define (by-assume exhyp . varnames-and-hyps)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE (apply by-assume-intern
			      (append (list num-goals proof maxgoal exhyp)
				      varnames-and-hyps)))
    (pproof-state-history-push PPROOF-STATE)
    (display-comment "ok, we now have the new goal ")
    (if COMMENT-FLAG (newline))
    (display-num-goal (car (pproof-state-to-num-goals)))))

(define (by-assume-intern
	 num-goals proof maxgoal exhyp . varnames-and-hyps)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (avars (context-to-avars context))
	 (l (length avars))	 
	 (ex-fla-and-x1
	  (cond
	   ((and (integer? exhyp) (positive? exhyp))
	    (if (<= exhyp l)
		(let* ((avar (list-ref avars (- exhyp 1)))
		       (formula (avar-to-formula avar)))
		  (list formula (make-proof-in-avar-form avar)))
		(myerror "by-assume" "assumption number expected" exhyp)))
	   ((and (string? exhyp)
		 (member exhyp (hypname-info-to-names hypname-info)))
	    (let ((i (name-and-hypname-info-to-index exhyp hypname-info)))
	      (if (<= i l)
		  (let* ((avar (list-ref avars (- i 1)))
			 (formula (avar-to-formula avar)))
		    (list formula (make-proof-in-avar-form avar)))
		  (myerror "by-assume" "assumption number expected" i))))
	   ((and (string? exhyp) (assoc exhyp THEOREMS))
	    (let* ((aconst (theorem-name-to-aconst exhyp))
		   (formula (aconst-to-formula aconst)))
	      (list formula (make-proof-in-aconst-form aconst))))
	   ((and (string? exhyp) (assoc exhyp GLOBAL-ASSUMPTIONS))
	    (let* ((aconst (global-assumption-name-to-aconst exhyp))
		   (formula (aconst-to-formula aconst)))
	      (list formula (make-proof-in-aconst-form aconst))))
	   ((proof-form? exhyp) (list (proof-to-formula exhyp) exhyp))
	   ((formula-form? exhyp) ;then a new goal is created
	    (list exhyp DEFAULT-GOAL-NAME))
	   (else (myerror "by-assume" "illegal argument" exhyp))))
	 (ex-fla (fold-formula (car ex-fla-and-x1)))
	 (x1 (cadr ex-fla-and-x1))
	 (n-and-m (cond ((or (ex-form? ex-fla) (exnc-form? ex-fla))
			 (list 1 1))
			((excl-form? ex-fla)
			 (list (length (excl-form-to-vars ex-fla))
			       (length (tensor-form-to-parts
					(excl-form-to-kernel ex-fla)))))
			((exca-form? ex-fla)
			 (list (length (exca-form-to-vars ex-fla))
			       (length (tensor-form-to-parts
					(exca-form-to-kernel ex-fla)))))
			(else (myerror "ex-form expected" ex-fla))))
	 (n (car n-and-m))
	 (m (cadr n-and-m))
	 (varnames
	  (if (= (+ n m) (length varnames-and-hyps))
	      (list-head varnames-and-hyps n)
	      (myerror (+ n m) "arguments expected in addition to exhyp")))
	 (vars (map pv varnames))
	 (hyps (list-tail varnames-and-hyps n)))
    (if (not (apply and-op (map (lambda (x) (and (string? x) (var? (pv x))))
				varnames)))
	(myerror "variable names expected" varnames))
    (if (not (apply and-op (map (lambda (hyp)
				  (or (string? hyp) (integer? hyp)))
				hyps)))
	(myerror "names or numbers for hypotheses expected" hyps))
    (let ((pproof-state1
	   (cond ((ex-form? ex-fla)
		  (ex-elim-intern num-goals proof maxgoal exhyp))
		 ((exnc-form? ex-fla)
		  (exnc-elim-intern num-goals proof maxgoal exhyp))
		 ((or (excl-form? ex-fla) (exca-form? ex-fla))
		  (exc-elim-intern num-goals proof maxgoal exhyp))
		 (else (myerror "ex-formula expected" ex-fla)))))
      (cond
       ((or ;hypothesis
	 (and (integer? exhyp) (positive? exhyp))
	 (and (string? exhyp)
	      (member exhyp (hypname-info-to-names hypname-info))))
	(let ((pproof-state2
	       (apply assume-intern (append pproof-state1 varnames hyps))))
	  (apply drop-intern (append pproof-state2 (list exhyp)))))
       ((or ;theorem/global assumption/proof
	 (and (string? exhyp) (assoc exhyp THEOREMS))
	 (and (string? exhyp) (assoc exhyp GLOBAL-ASSUMPTIONS))
	 (proof-form? exhyp))
	(apply assume-intern (append pproof-state1 varnames hyps)))
       ((formula-form? exhyp) ;then a new goal is created
	(let ((pproof-state2
	       (apply get-intern
		      (append pproof-state1
			      (list (pproof-state-to-maxgoal
				     pproof-state1))))))
	  (apply assume-intern (append pproof-state2 varnames hyps))))
       (else (myerror "by-assume-intern" "unexpected exhyp" exhyp))))))

; For backward compatibility
(define by-assume-with-intern by-assume-intern)
(define by-assume-with by-assume)

(define (exnc-intro term)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE (exnc-intro-intern num-goals proof maxgoal term))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (exnc-intro-intern num-goals proof maxgoal term)
  (let* ((num-goal (car num-goals))
         (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (context (goal-to-context goal))
	 (formula (goal-to-formula goal))
	 (free (if (exnc-form? formula)
                   (formula-to-free formula)
                   (myerror "exnc-intro" "exnc goal expected"))))
    (apply use-with-intern
	   (append (list num-goals proof maxgoal)
		   (cons (make-proof-in-aconst-form
			  (exnc-formula-to-exnc-intro-aconst formula))
			 (append (map make-term-in-var-form free)
				 (list term DEFAULT-GOAL-NAME)))))))

; In the following definition of exnc-elim x is
; - a number or string identifying an exnc hypothesis form the context,
; - the name of an exnc global assumption or theorem
; - a closed proof on an exnc formula (closed ones suffice),
; - an exnc formula with free variables from the context, 
;   generating a new goal.

(define (exnc-elim x)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE (exnc-elim-intern num-goals proof maxgoal x))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (exnc-elim-intern num-goals proof maxgoal x)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (avars (context-to-avars context))
	 (l (length avars))
	 (goal-formula (goal-to-formula goal))
	 (exnc-formula-and-x1
	  (cond
	   ((and (integer? x) (positive? x))
	    (if (<= x l)
		(let* ((avar (list-ref avars (- x 1)))
		       (formula (avar-to-formula avar)))
		  (list formula (make-proof-in-avar-form avar)))
		(myerror "exnc-elim" "assumption number expected" x)))
	   ((and (string? x)
		 (member x (hypname-info-to-names hypname-info)))
	    (let ((i (name-and-hypname-info-to-index x hypname-info)))
	      (if (<= i l)
		  (let* ((avar (list-ref avars (- i 1)))
			 (formula (avar-to-formula avar)))
		    (list formula (make-proof-in-avar-form avar)))
		  (myerror "exnc-elim" "assumption number expected" i))))
	   ((and (string? x) (assoc x THEOREMS))
	    (let* ((aconst (theorem-name-to-aconst x))
		   (formula (aconst-to-formula aconst)))
	      (list formula (make-proof-in-aconst-form aconst))))
	   ((and (string? x) (assoc x GLOBAL-ASSUMPTIONS))
	    (let* ((aconst (global-assumption-name-to-aconst x))
		   (formula (aconst-to-formula aconst)))
	      (list formula (make-proof-in-aconst-form aconst))))
	   ((proof-form? x) (list (proof-to-formula x) x))
	   ((formula-form? x) ;then a new goal is created
	    (list x DEFAULT-GOAL-NAME))
	   (else (myerror "exnc-elim" "illegal argument" x))))
         (exnc-formula (car exnc-formula-and-x1))
         (x1 (cadr exnc-formula-and-x1))
         (free1 (if (exnc-form? exnc-formula)
                    (formula-to-free exnc-formula)
                    (myerror "exnc-elim" "exnc formula expected"
			     exnc-formula)))
         (free2 (formula-to-free goal-formula))
         (free (union free1 free2)))
    (apply use-with-intern
	   (append (list num-goals proof maxgoal
			 (make-proof-in-aconst-form
			  (exnc-formula-and-concl-to-exnc-elim-aconst
			   exnc-formula goal-formula)))
		   (map make-term-in-var-form free)
		   (list x1 DEFAULT-GOAL-NAME)))))

; Suppose we are proving a goal G from an existential hypothesis ExHyp:
; exnc x A.  Then the natural way to use this hypothesis is to say `by
; ExHyp assume we have an x satisfying A'.  Correspondingly we provide

(define (by-exnc-assume-with exhyp var kernel)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE (by-exnc-assume-with-intern
			num-goals proof maxgoal exhyp var kernel))
    (set! PPROOF-STATE-HISTORY (cons PPROOF-STATE PPROOF-STATE-HISTORY))
    (display-comment "ok, we now have the new goal ")
    (if COMMENT-FLAG (newline))
    (display-num-goal (car (pproof-state-to-num-goals)))))

(define (by-exnc-assume-with-intern num-goals proof maxgoal exhyp var kernel)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal)))
    (cond
     ((or ;hypothesis
       (and (integer? exhyp) (positive? exhyp))
       (and (string? exhyp)
	    (member exhyp (hypname-info-to-names hypname-info))))
      (let* ((pproof-state1 (exnc-elim-intern num-goals proof maxgoal exhyp))
	     (pproof-state2
	      (apply assume-intern (append pproof-state1 (list var kernel)))))
	(apply drop-intern (append pproof-state2 (list exhyp)))))
     ((or ;theorem/global assumption/proof
       (and (string? exhyp) (assoc exhyp THEOREMS))
       (and (string? exhyp) (assoc exhyp GLOBAL-ASSUMPTIONS))
       (proof-form? exhyp))
      (let ((pproof-state1 (exnc-elim-intern num-goals proof maxgoal exhyp)))
	(apply assume-intern (append pproof-state1 (list var kernel)))))
     ((formula-form? exhyp) ;then a new goal is created
      (let* ((pproof-state1 (exnc-elim-intern num-goals proof maxgoal exhyp))
	     (pproof-state2
	      (apply get-intern
		     (append pproof-state1
			     (list (pproof-state-to-maxgoal pproof-state1))))))
	(apply assume-intern (append pproof-state2 (list var kernel)))))
     (else (myerror "by-exnc-assume-with-intern" "unexpected exhyp" exhyp)))))

; (cases) expects a goal all x A with x total and of alg type, or a
; goal all x^(STotal x^ -> A) with x^ partial.  Let c1 ... cn be the
; constructors of the algebra.  In the first case, n new goals all
; xs_i A[c_i xs_i] are generated.  In the second case, for every
; non-parameter variable x^_ji the new goal has an additional
; assumption STotal x^_ji.

; (cases test) expects a goal A(test).  
; If test is a total boolean term, the goal A is replaced by two new goals:
;   (atom test) -> A(True)
;   ((atom test) -> F) -> A(False)
; and if test is not total also
;   STotal test

; If test is a total non-boolean term, cases is called with the
; all-formula all x(x=test -> A(x)).

; If test is a non-total non-boolean term, cases is called with the
; all-formula all x^(STotal x^ -> x^ =test -> A(x^)).

; (cases 'auto) expects an atomic goal and checks whether its boolean
; kernel contains an if-term whose test is neither an if-term nor
; contains bound variables.  With the first such test (cases test) is
; called.

(define (cases . x)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply cases-intern (append (list num-goals proof maxgoal) x)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (cases-intern num-goals proof maxgoal . x)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (context (goal-to-context goal))
	 (formula (goal-to-formula goal)))
    (cond
     ((and (pair? x)
	   (term-form? (car x))
	   (equal? (make-alg "boole") (term-to-type (car x))))
      (casedist-intern num-goals proof maxgoal (car x)))
     ((and (pair? x) (eq? 'auto (car x)))
      (let ((boolean-kernel (if (atom-form? formula)
				(atom-form-to-kernel formula)
				(myerror "cases" "atomic goal expected"
					 formula))))
	(cases-intern num-goals proof maxgoal
		      (first-if-term-in boolean-kernel))))
     (else
      (let* ((all-formula
	      (if
	       (null? x)
	       (if (all-form? formula)
                   formula
		   (myerror "cases" "all formula expected" formula))
	       (let* ((term (car x))
		      (type (if (term-form? term)
				(term-to-type term)
				(myerror "cases" "term expected" term)))
		      (t-deg (term-to-t-deg term))
		      (var (if (t-deg-one? t-deg)
			       (type-to-new-var type)
			       (type-to-new-partial-var type)))
		      (varterm (make-term-in-var-form var))
		      (substformula (formula-gen-subst formula term varterm))
		      (kernel-formula
		       (if (t-deg-one? t-deg)
			   (make-imp (if (finalg? type)
					 (make-= term varterm)
					 (make-eq term varterm))
				     substformula)
                           (mk-imp (make-stotal varterm)
                                   (make-eq term varterm)
                                   substformula))))
		 (make-all var kernel-formula))))
	     (aconst (all-formula-to-cases-aconst all-formula))
             (var (all-form-to-var all-formula))
             (kernel (all-form-to-kernel all-formula))
             (newvar (var-to-new-var var))
	     (partial-flag (t-deg-zero? (var-to-t-deg var)))
	     (type (var-to-type var))
	     (alg-name (if (alg-form? type)
			   (alg-form-to-name type)
			   (myerror "cases" "variable of algebra type expected"
				    var)))
	     (k (length (alg-name-to-typed-constr-names alg-name)))
             (avar
	      (if partial-flag
		  (if (stotal-imp-formula? kernel (make-term-in-var-form var))
		      (let* ((term (if (null? x)
				       (make-term-in-var-form newvar)
				       (car x)))
			     (stotal-prem (make-stotal term)))
			(formula-to-new-avar stotal-prem))
		      (myerror
		       "cases" "all-formula with STotal premise expected"
		       all-formula))))
             (auxpproof (if (null? x)
			    (pproof-all-intro
			     (make-pproof-state num-goals proof maxgoal)
			     newvar)
			    (make-pproof-state num-goals proof maxgoal)))
             (pproof (if (and partial-flag (null? x))
			 (pproof-imp-intro auxpproof avar)
			 auxpproof))
             (stotal-proof-or-defgoal
              (if partial-flag
                  (if (null? x)
		      (make-proof-in-avar-form avar)
                      DEFAULT-GOAL-NAME))))
        (apply
         use-with-intern
         (append
          pproof
          (list (make-proof-in-aconst-form aconst))
          (map make-term-in-var-form (formula-to-free all-formula))
          (if (null? x)
              (list (make-term-in-var-form newvar))
              x)
          (if partial-flag
              (list stotal-proof-or-defgoal)
              '())
          (vector->list (make-vector k DEFAULT-GOAL-NAME))
          (if (pair? x)
              (list (if (and (finalg? type) (not partial-flag))
			(make-proof-in-aconst-form truth-aconst)
			(mk-proof-in-elim-form
                         (proof-subst
			  (make-proof-in-aconst-form eq-refl-aconst)
			  (car (formula-to-tvars
				(aconst-to-uninst-formula eq-refl-aconst)))
			  type)
			 (car x))))
	      '()))))))))

; (casedist test) replaces the goal A(test) by two new goals
;   (atom test) -> A(True)
;   ((atom test) -> F) -> A(False)
; and if test is not total also
;   STotal test

(define (casedist-intern num-goals proof maxgoal test)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (context (goal-to-context goal))
	 (formula (goal-to-formula goal))
	 (vars (context-to-vars context))
	 (info (if (term-form? test)
		   (set-minus (term-to-free test) vars)
		   (myerror "casedist" "term expected" test)))
         (total-flag (synt-total? test)))
    (if (pair? info)
	(myerror "casedist" "test has free variables not in context"
		 (map var-to-string info)))
    (if (not (equal? (make-alg "boole") (term-to-type test)))
	(myerror "casedist" "boolean term extected" test))
    (let* ((var (type-to-new-partial-var (make-alg "boole")))
	   (varterm (make-term-in-var-form var))
	   (kernel-formula (formula-gen-subst formula test varterm))
	   (cterm (make-cterm var kernel-formula))
	   (pvar (predicate-form-to-predicate
		  (imp-form-to-final-conclusion
		   (all-form-to-kernel (proof-to-formula dec-cases-proof)))))
           (dec-proof
            (if total-flag
                dec-cases-proof
                dec-stotal-cases-proof))
	   (subst-dec-cases-proof
	     ;of all p((p -> A(True)) -> (~p -> A(False)) -> A(p))
             ;or all p^(STotal p^ -> (p^ -> A(True)) ->
             ;                       (~p^ -> A(False)) -> A(p^))
	    (proof-subst dec-proof pvar cterm)))
      (apply
       use-with-intern
       (append (list num-goals proof maxgoal)
	       (list subst-dec-cases-proof test)
               (if total-flag
                   (list)
                   (list DEFAULT-GOAL-NAME))
               (list DEFAULT-GOAL-NAME DEFAULT-GOAL-NAME))))))

(define dec-cases-proof
  (let ((var (pv "boole")))
    (mk-proof-in-intro-form
     var
     (mk-proof-in-elim-form
      (make-proof-in-aconst-form
       (all-formula-to-cases-aconst
        (pf "all boole((boole -> (Pvar boole)True) -> 
                    ((boole -> F) -> (Pvar boole)False) -> 
                    (Pvar boole)boole)")))
      (make-term-in-var-form var)
      (let ((u1 (formula-to-new-avar
                 (pf "T -> (Pvar boole)True") DEFAULT-AVAR-NAME))
            (u2 (formula-to-new-avar
                 (pf "(T -> F) -> (Pvar boole)False")
                 DEFAULT-AVAR-NAME)))
        (mk-proof-in-intro-form
         u1 u2
         (mk-proof-in-elim-form
          (make-proof-in-avar-form u1)
          (make-proof-in-aconst-form truth-aconst))))
      (let ((u1 (formula-to-new-avar
                 (pf "F -> (Pvar boole)True") DEFAULT-AVAR-NAME))
            (u2 (formula-to-new-avar
                 (pf "(F -> F) -> (Pvar boole)False")
                 DEFAULT-AVAR-NAME))
            (u3 (formula-to-new-avar (pf "F") DEFAULT-AVAR-NAME)))
        (mk-proof-in-intro-form
         u1 u2
         (mk-proof-in-elim-form
          (make-proof-in-avar-form u2)
          (make-proof-in-imp-intro-form
           u3 (make-proof-in-avar-form u3)))))))))

(define dec-stotal-cases-proof
  (let* ((var (pv "boole^"))
         (avar (formula-to-new-avar (pf "STotal boole^") DEFAULT-AVAR-NAME)))
    (mk-proof-in-intro-form
     var
     avar
     (mk-proof-in-elim-form
      (make-proof-in-aconst-form
       (all-formula-to-cases-aconst
        (pf "all boole^(STotal boole^ ->
                    (boole^ -> (Pvar boole)True) -> 
                    ((boole^ -> F) -> (Pvar boole)False) -> 
                    (Pvar boole)boole^)")))
      (make-term-in-var-form var)
      (make-proof-in-avar-form avar)
      (let ((u1 (formula-to-new-avar (pf "T -> (Pvar boole)True")
                                     DEFAULT-AVAR-NAME))
            (u2 (formula-to-new-avar (pf "(T -> F) -> (Pvar boole)False")
                                     DEFAULT-AVAR-NAME)))
        (mk-proof-in-intro-form
         u1 u2
         (mk-proof-in-elim-form
          (make-proof-in-avar-form u1)
          (make-proof-in-aconst-form truth-aconst))))
      (let ((u1 (formula-to-new-avar (pf "F -> (Pvar boole)True")
                                     DEFAULT-AVAR-NAME))
            (u2 (formula-to-new-avar (pf "(F -> F) -> (Pvar boole)False")
                                     DEFAULT-AVAR-NAME))
            (u3 (formula-to-new-avar (pf "F")
				     DEFAULT-AVAR-NAME)))
        (mk-proof-in-intro-form
         u1 u2
         (mk-proof-in-elim-form
          (make-proof-in-avar-form u2)
          (mk-proof-in-intro-form
           u3 (make-proof-in-avar-form u3)))))))))

(define (term-to-if-tests term)
  (case (tag term)
    ((term-in-var-form term-in-const-form) '())
    ((term-in-abst-form)
     (let* ((var (term-in-abst-form-to-var term))
	    (kernel (term-in-abst-form-to-kernel term))
	    (if-tests (term-to-if-tests kernel)))
       (list-transform-positive if-tests
	 (lambda (x) (not (member var (term-to-free x)))))))
    ((term-in-app-form)
     (let ((if-tests1
	    (term-to-if-tests (term-in-app-form-to-op term)))
	   (if-tests2
	    (term-to-if-tests (term-in-app-form-to-arg term))))
       (union-wrt term=? if-tests1 if-tests2)))
    ((term-in-pair-form)
     (union-wrt term=?
		(term-to-if-tests (term-in-pair-form-to-left term))
		(term-to-if-tests (term-in-pair-form-to-right term))))
    ((term-in-lcomp-form)
     (term-to-if-tests (term-in-lcomp-form-to-kernel term)))
    ((term-in-rcomp-form)
     (term-to-if-tests (term-in-rcomp-form-to-kernel term)))
    ((term-in-if-form)
     (let* ((test (term-in-if-form-to-test term))
	    (alts (term-in-if-form-to-alts term))
	    (type (term-to-type test)))
       (if
	(and (equal? (make-alg "boole") type)
	     (not (term-in-if-form? test)))
	(apply union-wrt
	       (append (list term=? (list test))
		       (map term-to-if-tests alts)))
	(apply union-wrt
	       (append (list term=?)
		       (map term-to-if-tests (cons test alts)))))))
    (else (myerror "term-to-if-tests" "term expected" term))))

(define (first-if-term-in term)
  (let ((tests (term-to-if-tests term)))
    (if (pair? tests)
	(car tests)
	(myerror "first-if-term-in" "no if-term found"))))

; In the following definition of simp-with x is one of the following.
; - A number or string identifying a hypothesis form the context.
; - The name of a theorem or global assumption, but not one whose final
;   conclusion is a predicate variable.
; - A closed proof.
; - A formula with free variables from the context, generating a new goal.
; Moreover xs is a list consisting of
; - a number or string identifying a hypothesis form the context,
; - the name of a theorem or global assumption,
; - a closed proof,
; - the string "?" (value of DEFAULT-GOAL-NAME), generating a new goal,
; - a symbol left or right,
; - a term, whose free variables are added to the context,
; - a type, which is substituted for the 1st tvar,
; - a comprehension term, which is substituted for the 1st pvar.
; This generates a used formula, which is to be an atom, a negated
; atom or (Equal lhs rhs) or (lhs eqd rhs).  If it as a (negated)
; atom, check whether the kernel or its normal form is present in the
; goal.  If so, replace it by True (False).  If it is (lhs = rhs) or
; (Equal lhs rhs) or (lhs eqd rhs) with lhs or its normal form present
; in the goal, replace lhs by rhs.  In case "<-" exchange lhs by rhs.

(define (simp-with opt-dir . rest)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply simp-with-intern
		 (append (list num-goals proof maxgoal opt-dir) rest)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (simp-with-intern num-goals proof maxgoal . opt-dir-and-xs)
  (let* ((opt-dir (if (null? opt-dir-and-xs)
		      (myerror "simp-with-intern" "more arguments expected")
		      (car opt-dir-and-xs)))
	 (left-to-right (not (and (string? opt-dir) (string=? "<-" opt-dir))))
	 (x-and-x-list (if left-to-right
			   opt-dir-and-xs
			   (cdr opt-dir-and-xs)))
	 (x (if (null? x-and-x-list)
		(myerror "simp-with-intern" "more arguments expected")
		(car x-and-x-list)))
	 (x-list (cdr x-and-x-list))
	 (num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (drop-info (num-goal-to-drop-info num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (cvars (goal-to-cvars goal))
	 (proof-and-new-num-goals-and-maxgoal
	  (if (and (string? x)
		   (let ((info (assoc x (append THEOREMS GLOBAL-ASSUMPTIONS))))
		     (and info
			  (let* ((aconst (cadr info))
				 (aconst-formula (aconst-to-formula aconst))
				 (final-concl
				  (imp-impnc-all-allnc-form-to-final-conclusion
				   aconst-formula)))
			    (and (predicate-form? final-concl)
				 (pvar? (predicate-form-to-predicate
					 final-concl)))))))
	      (myerror "simp-with-intern" "unexpected aconst name" x)
	      (apply x-and-x-list-to-proof-and-new-num-goals-and-maxgoal
		     (append (list num-goal (+ 1 maxgoal) x) x-list))))
	 (negatom-or-eq-proof (car proof-and-new-num-goals-and-maxgoal))
	 (new-num-goals (cadr proof-and-new-num-goals-and-maxgoal))
	 (new-maxgoal (caddr proof-and-new-num-goals-and-maxgoal))
	 (goal-formula (goal-to-formula goal))
	 (used-formula (proof-to-formula negatom-or-eq-proof))
	 (used-prime-formula
	  (cond ((prime-form? used-formula) used-formula)
		((and (imp-impnc-form? used-formula)
		      (atom-form? (imp-impnc-form-to-premise used-formula))
		      (classical-formula=?
		       falsity (imp-impnc-form-to-conclusion used-formula)))
		 (imp-impnc-form-to-premise used-formula))
		(else (myerror "simp-with-intern"
			       "negated atom or prime formula expected"
			       used-formula))))
	 (used-nprime-formula (normalize-formula used-prime-formula))
	 (bvar (type-to-new-var (make-alg "boole")))
	 (bvarterm (make-term-in-var-form bvar))
	 (used-kernel (if (atom-form? used-prime-formula)
			  (atom-form-to-kernel used-prime-formula)
			  bvarterm)) ;anything would do
; not needed:	  
; 	  (cond
; 	   ((atom-form? used-prime-formula)
; 	    (atom-form-to-kernel used-prime-formula))
; 	   ((and
; 	     (predicate-form? used-prime-formula)
; 	     (let ((predicate (predicate-form-to-predicate used-prime-formula))
; 		   (args (predicate-form-to-args used-prime-formula)))
; 	       (and
; 		(idpredconst-form? predicate)
; 		(string=? "EqD" (idpredconst-to-name predicate))
; 		(term=? (cadr args) (make-term-in-const-form true-const)))))
; 	    (car args))
; 	   (else bvarterm))) ;anything would do
	 (used-nkernel (nt used-kernel))
	 (op (term-in-app-form-to-final-op used-kernel))
	 (nop (term-in-app-form-to-final-op used-nkernel))
	 (goal-formula-without-kernel
	  (if (atom-form? used-prime-formula)
	      (formula-gen-subst goal-formula used-kernel bvarterm)
	      goal-formula))
	 (ngoal-formula-without-nkernel
	  (if (atom-form? used-prime-formula)
	      (formula-gen-subst (nf goal-formula) used-nkernel bvarterm)
	      goal-formula))
	 (kernel-present? (not (classical-formula=?
				goal-formula-without-kernel
				goal-formula)))
	 (nkernel-present? (not (classical-formula=?
				 ngoal-formula-without-nkernel
				 goal-formula))))
    (cond
     ((and kernel-present?
	   (not (term=? used-kernel (make-term-in-const-form true-const)))
	   (not (term=? used-kernel (make-term-in-const-form false-const)))
	   (or (atom-form? used-formula) (synt-total? used-kernel)))
      (simp-with-kernel-aux num-goals proof maxgoal
			    negatom-or-eq-proof new-num-goals new-maxgoal
			    used-kernel bvar goal-formula-without-kernel))
     ((and nkernel-present?
	   (not (term=? used-nkernel (make-term-in-const-form true-const)))
	   (not (term=? used-nkernel (make-term-in-const-form false-const)))
	   (or (atom-form? used-formula) (synt-total? used-nkernel)))
      (simp-with-kernel-aux num-goals proof maxgoal
			    negatom-or-eq-proof new-num-goals new-maxgoal
			    used-nkernel bvar ngoal-formula-without-nkernel))
     ((and (term-in-const-form? op)
	   (string=? "=" (const-to-name (term-in-const-form-to-const op)))
	   (let* ((args (term-in-app-form-to-args used-kernel))
		  (lhs (car args))
		  (rhs (cadr args))
		  (type (term-to-type lhs))
		  (var (type-to-new-var type))
		  (varterm (make-term-in-var-form var))
		  (simp-formula
		   (if left-to-right
		       (formula-gen-subst goal-formula lhs varterm)
		       (formula-gen-subst goal-formula rhs varterm))))
	     (not (classical-formula=? simp-formula goal-formula))))
      (let* ((args (term-in-app-form-to-args used-kernel))
	     (lhs (car args))
	     (rhs (cadr args))
	     (type (term-to-type lhs))
	     (var (type-to-new-var type))
	     (varterm (make-term-in-var-form var))
	     (simp-formula
	      (if left-to-right
		  (formula-gen-subst goal-formula lhs varterm)
		  (formula-gen-subst goal-formula rhs varterm)))
	     (all-formula (mk-all var simp-formula))
	     (new-goal ;A(rhs) or A(lhs)
	      (context-and-cvars-and-formula-to-new-goal
	       context cvars
	       (formula-subst simp-formula var
			      (if left-to-right rhs lhs))))
	     (new-num-goal
	      (make-num-goal
	       (+ 1 maxgoal) new-goal drop-info hypname-info))
	     (new-proof ;of A(lhs) or A(rhs)
	      (mk-proof-in-elim-form
	       (if
		left-to-right
		(compat-rev-at all-formula) ;allnc n,m(n=m -> A(m) -> A(n))
		(compat-at all-formula))    ;allnc n,m(n=m -> A(n) -> A(m))
	       lhs rhs negatom-or-eq-proof new-goal)))
	(make-pproof-state
	 (append (list new-num-goal) new-num-goals (cdr num-goals))
	 (goal-subst proof goal new-proof)
	 new-maxgoal)))
     ((and (term-in-const-form? nop)
	   (string=? "=" (const-to-name (term-in-const-form-to-const nop)))
	   (let* ((args (term-in-app-form-to-args used-nkernel))
		  (lhs (car args))
		  (rhs (cadr args))
		  (type (term-to-type lhs))
		  (var (type-to-new-var type))
		  (varterm (make-term-in-var-form var))
		  (simp-formula
		   (if left-to-right
		       (formula-gen-subst goal-formula lhs varterm)
		       (formula-gen-subst goal-formula rhs varterm))))
	     (not (classical-formula=? simp-formula goal-formula))))
      (let* ((args (term-in-app-form-to-args used-nkernel))
	     (lhs (car args))
	     (rhs (cadr args))
	     (type (term-to-type lhs))
	     (var (type-to-new-var type))
	     (varterm (make-term-in-var-form var))
	     (simp-formula
	      (if left-to-right
		  (formula-gen-subst goal-formula lhs varterm)
		  (formula-gen-subst goal-formula rhs varterm)))
	     (all-formula (mk-all var simp-formula))
	     (new-goal ;A(rhs) or A(lhs)
	      (context-and-cvars-and-formula-to-new-goal
	       context cvars
	       (formula-subst simp-formula var
			      (if left-to-right rhs lhs))))
	     (new-num-goal
	      (make-num-goal
	       (+ 1 maxgoal) new-goal drop-info hypname-info))
	     (new-proof ;of A(lhs) or A(rhs)
	      (mk-proof-in-elim-form
	       (if
		left-to-right
		(compat-rev-at all-formula) ;allnc n,m(n=m -> A(m) -> A(n))
		(compat-at all-formula))    ;allnc n,m(n=m -> A(n) -> A(m))
	       lhs rhs negatom-or-eq-proof new-goal)))
	(make-pproof-state
	 (append (list new-num-goal) new-num-goals (cdr num-goals))
	 (goal-subst proof goal new-proof)
	 new-maxgoal)))
     ((and (predicate-form? used-prime-formula)
	   (string=? "Equal" (predconst-to-name
			      (predicate-form-to-predicate
			       used-prime-formula)))
	   (let* ((args (predicate-form-to-args used-prime-formula))
		  (lhs (car args))
		  (rhs (cadr args))
		  (type (term-to-type lhs))
		  (var (type-to-new-var type))
		  (varterm (make-term-in-var-form var))
		  (simp-formula
		   (if left-to-right
		       (formula-gen-subst goal-formula lhs varterm)
		       (formula-gen-subst goal-formula rhs varterm))))
	     (not (classical-formula=? simp-formula goal-formula))))
      (let* ((args (predicate-form-to-args used-prime-formula))
	     (lhs (car args))
	     (rhs (cadr args))
	     (type (term-to-type lhs))
	     (var (type-to-new-var type))
	     (varterm (make-term-in-var-form var))
	     (simp-formula
	      (if left-to-right
		  (formula-gen-subst goal-formula lhs varterm)
		  (formula-gen-subst goal-formula rhs varterm)))
	     (all-formula (mk-all var simp-formula))
	     (new-goal ;A(rhs) or A(lhs)
	      (context-and-cvars-and-formula-to-new-goal
	       context cvars
	       (formula-subst simp-formula var
			      (if left-to-right rhs lhs))))
	     (new-num-goal
	      (make-num-goal
	       (+ 1 maxgoal) new-goal drop-info hypname-info))
	     (new-proof ;of A(lhs) or A(rhs)
	      (mk-proof-in-elim-form
	       (if
		left-to-right
		(eq-compat-rev-at all-formula) ;allnc n,m(n=m -> A(m) -> A(n))
		(eq-compat-at all-formula))    ;allnc n,m(n=m -> A(n) -> A(m))
	       lhs rhs negatom-or-eq-proof new-goal)))
	(make-pproof-state
	 (append (list new-num-goal) new-num-goals (cdr num-goals))
	 (goal-subst proof goal new-proof)
	 new-maxgoal)))
     ((and (predicate-form? used-nprime-formula)
	   (string=? "Equal" (predconst-to-name
			      (predicate-form-to-predicate
			       used-nprime-formula)))
	   (let* ((args (predicate-form-to-args used-nprime-formula))
		  (lhs (car args))
		  (rhs (cadr args))
		  (type (term-to-type lhs))
		  (var (type-to-new-var type))
		  (varterm (make-term-in-var-form var))
		  (simp-formula
		   (if left-to-right
		       (formula-gen-subst goal-formula lhs varterm)
		       (formula-gen-subst goal-formula rhs varterm))))
	     (not (classical-formula=? simp-formula goal-formula))))
      (let* ((args (predicate-form-to-args used-nprime-formula))
	     (lhs (car args))
	     (rhs (cadr args))
	     (type (term-to-type lhs))
	     (var (type-to-new-var type))
	     (varterm (make-term-in-var-form var))
	     (simp-formula
	      (if left-to-right
		  (formula-gen-subst goal-formula lhs varterm)
		  (formula-gen-subst goal-formula rhs varterm)))
	     (all-formula (mk-all var simp-formula))
	     (new-goal ;A(rhs) or A(lhs)
	      (context-and-cvars-and-formula-to-new-goal
	       context cvars
	       (formula-subst simp-formula var
			      (if left-to-right rhs lhs))))
	     (new-num-goal
	      (make-num-goal
	       (+ 1 maxgoal) new-goal drop-info hypname-info))
	     (new-proof ;of A(lhs) or A(rhs)
	      (mk-proof-in-elim-form
	       (if
		left-to-right
		(eq-compat-rev-at all-formula) ;allnc n,m(n=m -> A(m) -> A(n))
		(eq-compat-at all-formula))    ;allnc n,m(n=m -> A(n) -> A(m))
	       lhs rhs negatom-or-eq-proof new-goal)))
	(make-pproof-state
	 (append (list new-num-goal) new-num-goals (cdr num-goals))
	 (goal-subst proof goal new-proof)
	 new-maxgoal)))
     ((and (predicate-form? used-prime-formula)
	   (let ((predicate (predicate-form-to-predicate used-prime-formula)))
	     (and (idpredconst-form? predicate)
		  (string=? "EqD" (idpredconst-to-name predicate))
		  (let* ((args (predicate-form-to-args used-prime-formula))
			 (lhs (car args))
			 (rhs (cadr args))
			 (type (term-to-type lhs))
			 (var (type-to-new-var type))
			 (varterm (make-term-in-var-form var))
			 (simp-formula
			  (if left-to-right
			      (formula-gen-subst goal-formula lhs varterm)
			      (formula-gen-subst goal-formula rhs varterm))))
		    (not (classical-formula=? simp-formula goal-formula))))))
      (let* ((args (predicate-form-to-args used-prime-formula))
	     (lhs (car args))
	     (rhs (cadr args))
	     (type (term-to-type lhs))
	     (var (type-to-new-var type))
	     (varterm (make-term-in-var-form var))
	     (simp-formula
	      (if left-to-right
		  (formula-gen-subst goal-formula lhs varterm)
		  (formula-gen-subst goal-formula rhs varterm)))
	     (all-formula (mk-all var simp-formula))
	     (new-goal ;A(rhs) or A(lhs)
	      (context-and-cvars-and-formula-to-new-goal
	       context cvars
	       (formula-subst simp-formula var
			      (if left-to-right rhs lhs))))
	     (new-num-goal
	      (make-num-goal
	       (+ 1 maxgoal) new-goal drop-info hypname-info))
	     (new-proof ;of A(lhs) or A(rhs)
	      (mk-proof-in-elim-form
	       (if
		left-to-right
		(eqd-compat-rev-at all-formula) ;allnc n,m(n=m -> A(m) -> A(n))
		(eqd-compat-at all-formula))    ;allnc n,m(n=m -> A(n) -> A(m))
	       lhs rhs negatom-or-eq-proof new-goal)))
	(make-pproof-state
	 (append (list new-num-goal) new-num-goals (cdr num-goals))
	 (goal-subst proof goal new-proof)
	 new-maxgoal)))
     ((and (predicate-form? used-nprime-formula)
	   (let ((predicate (predicate-form-to-predicate used-nprime-formula)))
	     (and (idpredconst-form? predicate)
		  (string=? "EqD" (idpredconst-to-name predicate))
		  (let* ((args (predicate-form-to-args used-nprime-formula))
			 (lhs (car args))
			 (rhs (cadr args))
			 (type (term-to-type lhs))
			 (var (type-to-new-var type))
			 (varterm (make-term-in-var-form var))
			 (simp-formula
			  (if left-to-right
			      (formula-gen-subst goal-formula lhs varterm)
			      (formula-gen-subst goal-formula rhs varterm))))
		    (not (classical-formula=? simp-formula goal-formula))))))
      (let* ((args (predicate-form-to-args used-nprime-formula))
	     (lhs (car args))
	     (rhs (cadr args))
	     (type (term-to-type lhs))
	     (var (type-to-new-var type))
	     (varterm (make-term-in-var-form var))
	     (simp-formula
	      (if left-to-right
		  (formula-gen-subst goal-formula lhs varterm)
		  (formula-gen-subst goal-formula rhs varterm)))
	     (all-formula (mk-all var simp-formula))
	     (new-goal ;A(rhs) or A(lhs)
	      (context-and-cvars-and-formula-to-new-goal
	       context cvars
	       (formula-subst simp-formula var
			      (if left-to-right rhs lhs))))
	     (new-num-goal
	      (make-num-goal
	       (+ 1 maxgoal) new-goal drop-info hypname-info))
	     (new-proof ;of A(lhs) or A(rhs)
	      (mk-proof-in-elim-form
	       (if
		left-to-right
		(eqd-compat-rev-at all-formula) ;allnc n,m(n=m -> A(m) -> A(n))
		(eqd-compat-at all-formula))    ;allnc n,m(n=m -> A(n) -> A(m))
	       lhs rhs negatom-or-eq-proof new-goal)))
	(make-pproof-state
	 (append (list new-num-goal) new-num-goals (cdr num-goals))
	 (goal-subst proof goal new-proof)
	 new-maxgoal)))
     (else (myerror "simp-with-intern" "goal cannot be simplified with"
		    used-formula)))))

(define (simp-with-kernel-aux num-goals proof maxgoal
			      negatom-or-eq-proof new-num-goals new-maxgoal
			      used-kernel bvar goal-formula-without-kernel)
  (let* ((num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (drop-info (num-goal-to-drop-info num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (cvars (goal-to-cvars goal))
	 (used-formula (proof-to-formula negatom-or-eq-proof))
	 (all-formula (mk-all bvar goal-formula-without-kernel)))
    (if
     (atom-form? used-formula)
     (let* ((new-goal ;A(True)
	     (context-and-cvars-and-formula-to-new-goal
	      context cvars
	      (formula-subst goal-formula-without-kernel bvar
			     (make-term-in-const-form true-const))))
	    (new-num-goal
	     (make-num-goal
	      (+ 1 maxgoal) new-goal drop-info hypname-info))
	    (new-proof ;of A(r)
	     (mk-proof-in-elim-form
	      (compat-rev-at all-formula) ;allnc p^,q^(p^=q^ -> A(q^) -> A(p^))
	      used-kernel ;r
	      (make-term-in-const-form true-const)
	      (mk-proof-in-elim-form ;of r=True
	       (make-proof-in-aconst-form ;of all p(atom(p) -> p=True)
		atom-true-aconst)
	       used-kernel ;r
	       negatom-or-eq-proof) ;of atom(r)
	      new-goal))) ;A(True)
       (make-pproof-state
	(append (list new-num-goal) new-num-goals (cdr num-goals))
	(goal-subst proof goal new-proof)
	new-maxgoal))
     (let* ((info (assoc "Atom-False" THEOREMS))
	    (atomfalse-aconst
	     (if info (cadr info)
		 (myerror "simp-with-intern" "Atom-False missing:"
			  "all boole((boole -> F) -> boole=False)")))
	    (new-goal ;A(False)
	     (context-and-cvars-and-formula-to-new-goal
	      context cvars
	      (formula-subst goal-formula-without-kernel bvar
			     (make-term-in-const-form false-const))))
	    (new-num-goal
	     (make-num-goal
	      (+ 1 maxgoal) new-goal drop-info hypname-info))
	    (new-proof ;of A(r)
	     (mk-proof-in-elim-form
	      (compat-rev-at all-formula) ;allnc p,q(p=q -> A(q) -> A(p))
	      used-kernel ;r
	      (make-term-in-const-form false-const)
	      (mk-proof-in-elim-form ;of r=False
	       (make-proof-in-aconst-form ;of all p(~p -> p=False)
		atomfalse-aconst)
	       used-kernel ;r
	       negatom-or-eq-proof) ;of ~r
	      new-goal))) ;A(False)
       (make-pproof-state
	(append
	 (list new-num-goal) new-num-goals (cdr num-goals))
	(goal-subst proof goal new-proof)
	new-maxgoal)))))

(define (simp opt-dir . rest)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals)))
	 (simp-result
	  (apply simp-intern
		 (append (list num-goals proof maxgoal opt-dir) rest))))
    (if (not simp-result)
	(begin (display-comment "no simplification possible")
	       (if COMMENT-FLAG (newline)))
	(begin
	  (set! PPROOF-STATE simp-result)
	  (pproof-state-history-push PPROOF-STATE)
	  (display-new-goals num-goals number)))))

(define (simp-intern num-goals proof
		     maxgoal . opt-dir-and-x-and-elab-path-and-terms)
  (let* ((opt-dir (if (null? opt-dir-and-x-and-elab-path-and-terms)
		      (myerror "simp-intern" "more arguments expected")
		      (car opt-dir-and-x-and-elab-path-and-terms)))
	 (left-to-right (not (and (string? opt-dir) (string=? "<-" opt-dir))))
	 (x-and-elab-path-and-terms
	  (if left-to-right
	      opt-dir-and-x-and-elab-path-and-terms
	      (cdr opt-dir-and-x-and-elab-path-and-terms)))
	 (x (if (null? x-and-elab-path-and-terms)
		(myerror "simp-intern" "more arguments expected")
		(car x-and-elab-path-and-terms)))
	 (elab-path-and-terms (cdr x-and-elab-path-and-terms))
	 (num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (cvars (goal-to-cvars goal))
	 (avars (context-to-avars context))
	 (maxhyp (length avars))
	 (goal-formula (goal-to-formula goal))
	 (leaf (if (formula-form? x)
		   (context-and-cvars-and-formula-to-new-goal
		    context cvars x)
		   (hyp-info-to-leaf num-goal x)))
	 (used-formula
	  (unfold-formula (if (formula-form? x) x (proof-to-formula leaf))))
	 (sig-vars (context-to-vars context))
	 (sig-tvars-and-sig-vars
	  (if (assoc x (append THEOREMS GLOBAL-ASSUMPTIONS))
	      sig-vars
	      (append (formula-to-tvars used-formula) sig-vars)))
	 (elab-path (do ((l elab-path-and-terms (cdr l))
			 (res '() (if (memq (car l) '(left right))
				      (cons (car l) res)
				      res)))
			((null? l) (reverse res))))
	 (xs-and-vars-and-toinst1
	  (apply
	   fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data
	   (append (list used-formula sig-tvars-and-sig-vars
			 goal-formula left-to-right)
		   elab-path)))
	 (xs-and-vars-and-toinst
	  (if xs-and-vars-and-toinst1
	      xs-and-vars-and-toinst1
	      (apply
	       fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data
	       (append (list (normalize-formula used-formula)
			     sig-tvars-and-sig-vars
			     (normalize-formula goal-formula)
			     left-to-right)	 
		       elab-path)))))
    (if
     (not xs-and-vars-and-toinst)
     #f
     (let* ((xs (car xs-and-vars-and-toinst))
	    (vars (cadr xs-and-vars-and-toinst))
	    (toinst (caddr xs-and-vars-and-toinst))
	    (terms (do ((l elab-path-and-terms (cdr l))
			(res '() (if (memq (car l) '(left right))
				     res
				     (cons (car l) res))))
		       ((null? l) (reverse res))))
	    (subst (if (<= (length vars) (length terms))
		    (map (lambda (x y) (list x y))
			 vars (list-head terms (length vars)))
		    empty-subst))
	    (subst-xs (map (lambda (x) (if (term-form? x)
					   (term-substitute x subst)
					   x))
			   xs))
	    (types (let ((info1 (assoc x THEOREMS))
			 (info2 (assoc x GLOBAL-ASSUMPTIONS))
			 (tsubst (list-transform-positive toinst
				   (lambda (x) (tvar-form? (car x))))))
		     (if
		      (and (or info1 info2) (pair? tsubst)) ;else '()
		      (let* ((aconst (if info1
					 (theorem-name-to-aconst x)
					 (global-assumption-name-to-aconst x)))
			     (fla (aconst-to-formula aconst))
			     (tvars (formula-to-tvars fla)))
			(map (lambda (tvar) (type-substitute tvar tsubst))
			     tvars))
		      '()))))
       (if (> (length vars) (length terms))
	   (apply myerror
		  (cons (list "simp"
			      "more terms expected, to be substituted for")
			(list-tail vars (length terms)))))
       (if (and COMMENT-FLAG (< (length vars) (length terms)))
	(begin
	  (comment "warning: superfluous terms")
	  (for-each comment
		    (map term-to-string (list-tail terms (length vars))))))
       (apply simp-with-intern
	      (if left-to-right
		  (append (list num-goals proof maxgoal x)
			  (append types subst-xs))
		  (append (list num-goals proof maxgoal "<-" x)
			  (append types subst-xs))))))))

; fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data is #f if
; (a) no atomic or negated atomic head of formula and also (b) no lhs
; (resp. rhs) of an equality head of formula is a pattern in the goal
; formula.  Otherwise the following data are returned: (1) the
; arguments xs for the hypothesis x that produce the instance, (2)
; vars (from xs) whose instantiations cannot be inferred, hence need
; to be provided, (3) a type substitution plus object instantiation
; that produces the instance.

(define (fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data
	 used-formula sig-tvars-and-sig-vars goal-formula
	 left-to-right . elab-path)
  (let ((match-res
	 (or (and (imp-form? used-formula)
		  (let ((prem (imp-form-to-premise used-formula))
			(concl (imp-form-to-conclusion used-formula)))
		    (and (atom-form? prem)
			 (classical-formula=? falsity concl)
			 (let ((kernel (atom-form-to-kernel prem)))
			   (first-match sig-tvars-and-sig-vars
					kernel goal-formula)))))
	     (and (impnc-form? used-formula)
		  (let ((prem (impnc-form-to-premise used-formula))
			(concl (impnc-form-to-conclusion used-formula)))
		    (and (atom-form? prem)
			 (classical-formula=? falsity concl)
			 (let ((kernel (atom-form-to-kernel prem)))
			   (first-match sig-tvars-and-sig-vars
					kernel goal-formula)))))
	     (and (atom-form? used-formula)
		  (let ((kernel (atom-form-to-kernel used-formula)))
		    (first-match sig-tvars-and-sig-vars
				 kernel goal-formula)))
	     (and (atom-form? used-formula)
		  (let* ((kernel (atom-form-to-kernel used-formula))
			 (op (term-in-app-form-to-final-op kernel)))
		    (and (term-in-const-form? op)
			 (string=? "=" (const-to-name
					(term-in-const-form-to-const op)))
			 (let* ((args (term-in-app-form-to-args kernel))
				(lhs (car args))
				(rhs (cadr args)))
			   (if left-to-right
			       (first-match sig-tvars-and-sig-vars
					    lhs goal-formula)
			       (first-match sig-tvars-and-sig-vars
					    rhs goal-formula))))))
	     (and (predicate-form? used-formula)
		  (let ((predicate (predicate-form-to-predicate
				    used-formula)))
		    (and
		     (predconst-form? predicate)
		     (string=? "Equal" (predconst-to-name predicate))
		     (let* ((args (predicate-form-to-args used-formula))
			    (lhs (car args))
			    (rhs (cadr args)))
		       (if left-to-right
			   (first-match sig-tvars-and-sig-vars
					lhs goal-formula)
			   (first-match sig-tvars-and-sig-vars
					rhs goal-formula)))))))))
    (if
     match-res
     (list '() '() match-res)
     (case (tag used-formula)
       ((atom predicate ex) #f)
       ((imp)
	(let* ((concl (imp-form-to-conclusion used-formula))
	       (prev
		(apply
		 fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data
		 (append (list concl sig-tvars-and-sig-vars
			       goal-formula left-to-right)
			 elab-path))))
	  (if (not prev)
	      #f
	      (let* ((xs (car prev))
		     (vars (cadr prev))
		     (toinst (caddr prev)))
		(list (cons DEFAULT-GOAL-NAME xs) vars toinst)))))
       ((impnc)
	(let* ((concl (impnc-form-to-conclusion used-formula))
	       (prev
		(apply
		 fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data
		 (append (list concl sig-tvars-and-sig-vars
			       goal-formula left-to-right)
			 elab-path))))
	  (if (not prev)
	      #f
	      (let* ((xs (car prev))
		     (vars (cadr prev))
		     (toinst (caddr prev)))
		(list (cons DEFAULT-GOAL-NAME xs) vars toinst)))))
       ((all)
	(let* ((var (all-form-to-var used-formula))
	       (kernel (all-form-to-kernel used-formula))
	       (new-var (var-to-new-var var))
	       (new-kernel
		(formula-subst kernel var (make-term-in-var-form new-var)))
	       (prev
		(apply
		 fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data
		 (append (list new-kernel sig-tvars-and-sig-vars
			       goal-formula left-to-right)
			 elab-path))))
	  (if (not prev)
	      #f
	      (let* ((xs (car prev))
		     (vars (cadr prev))
		     (toinst (caddr prev))
		     (info (assoc new-var toinst)))
		(if
		 info ;instance found by matching
		 (list ;insert instance into xs
		  (cons (cadr info) xs) vars toinst)
		 (list ;else insert new-var into xs, and new-var to vars
		  (cons (make-term-in-var-form new-var) xs)
		  (cons new-var vars)
		  toinst))))))
       ((allnc)
	(let* ((var (allnc-form-to-var used-formula))
	       (kernel (allnc-form-to-kernel used-formula))
	       (new-var (var-to-new-var var))
	       (new-kernel
		(formula-subst kernel var (make-term-in-var-form new-var)))
	       (prev
		(apply
		 fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data
		 (append (list new-kernel sig-tvars-and-sig-vars
			       goal-formula left-to-right)
			 elab-path))))
	  (if (not prev)
	      #f
	      (let* ((xs (car prev))
		     (vars (cadr prev))
		     (toinst (caddr prev))
		     (info (assoc new-var toinst)))
		(if
		 info ;instance found by matching
		 (list ;insert instance into xs
		  (cons (cadr info) xs) vars toinst)
		 (list ;else insert new-var into xs, and new-var to vars
		  (cons (make-term-in-var-form new-var) xs)
		  (cons new-var vars)
		  toinst))))))
       ((and)
	(let ((left-conjunct (and-form-to-left used-formula))
	      (right-conjunct (and-form-to-right used-formula)))
	  (if
	   (pair? elab-path)
	   (let* ((direction (car elab-path))
		  (conjunct (cond ((eq? 'left direction) left-conjunct)
				  ((eq? 'right direction) right-conjunct)
				  (else (myerror "left or right expected"
						 direction))))
		  (prev
		   (apply
		    fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data
		    (append (list conjunct sig-tvars-and-sig-vars
				  goal-formula left-to-right)
			    (cdr elab-path)))))
	     (if (not prev)
		 #f
		 (let* ((xs (car prev))
			(vars (cadr prev))
			(toinst (caddr prev)))
		   (list (cons direction xs) vars toinst))))
	   (let ((prev1
		  (fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data
		   left-conjunct sig-tvars-and-sig-vars
		   goal-formula left-to-right)))
	     (if
	      prev1
	      (let* ((xs (car prev1))
		     (vars (cadr prev1))
		     (toinst (caddr prev1)))
		(list (cons 'left xs) vars toinst))
	      (let ((prev2
		     (fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data
		      right-conjunct sig-tvars-and-sig-vars
		      goal-formula left-to-right)))
		(if prev2
		    (let* ((xs (car prev2))
			   (vars (cadr prev2))
			   (toinst (caddr prev2)))
		      (list (cons 'right xs) vars toinst))
		    #f)))))))
       (else (myerror
	      "fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data"
	      "formula expected"
	      used-formula))))))

(define (compat-at all-formula)
  (let* ((var (all-form-to-var all-formula))
	 (kernel (all-form-to-kernel all-formula))
	 (free (formula-to-free all-formula))
	 (type-of-var (var-to-type var))
	 (type-of-var-is-finalg? (finalg? type-of-var))
	 (type (if type-of-var-is-finalg? type-of-var
		   (myerror "compat-at" "finitary algebra expected"
			    type-of-var)))
	 (eq-compat-fla (aconst-to-uninst-formula eq-compat-aconst))
	 (eq-compat-tvar (car (formula-to-tvars eq-compat-fla)))
	 (eq-compat-pvar (car (formula-to-pvars eq-compat-fla)))
	 (partial? (t-deg-zero? (var-to-t-deg var)))
	 (new-var (if partial? var (var-to-new-partial-var var)))
	 (new-kernel
	  (if partial? kernel
	      (formula-subst kernel var (make-term-in-var-form new-var))))
	 (inst-eq-compat-aconst
	  (make-aconst "Eq-Compat" 'axiom eq-compat-fla
		       (list (list eq-compat-tvar type)
			     (list eq-compat-pvar
				   (make-cterm new-var new-kernel)))))
	 (vars (list-tail (allnc-form-to-vars
			   (aconst-to-formula inst-eq-compat-aconst))
			  (length free)))
	 (var1 (car vars))
	 (var2 (cadr vars))
	 (=-to-eq-aconst (finalg-to-=-to-eq-aconst type))
	 (avar (formula-to-new-avar (make-= (make-term-in-var-form var1)
					    (make-term-in-var-form var2)))))
    (mk-proof-in-nc-intro-form
     var1 var2
     (make-proof-in-imp-intro-form
      avar (apply
	    mk-proof-in-elim-form
	    (append
	     (list (make-proof-in-aconst-form inst-eq-compat-aconst))
	     (map make-term-in-var-form free)
	     (list
	      (make-term-in-var-form var1)
	      (make-term-in-var-form var2)
	      (mk-proof-in-elim-form
	       (make-proof-in-aconst-form =-to-eq-aconst)
	       (make-term-in-var-form var1)
	       (make-term-in-var-form var2)
	       (make-proof-in-avar-form avar)))))))))

(define (compat-rev-at all-formula)
  (let* ((var (all-form-to-var all-formula))
	 (kernel (all-form-to-kernel all-formula))
	 (free (formula-to-free all-formula))
	 (type-of-var (var-to-type var))
	 (type-of-var-is-finalg? (finalg? type-of-var))
	 (type (if type-of-var-is-finalg? type-of-var
		   (myerror "compat-rev-at" "finitary algebra expected"
			    type-of-var)))
	 (eq-compat-fla (aconst-to-uninst-formula eq-compat-aconst))
	 (eq-compat-tvar (car (formula-to-tvars eq-compat-fla)))
	 (eq-compat-pvar (car (formula-to-pvars eq-compat-fla)))
	 (partial? (t-deg-zero? (var-to-t-deg var)))
	 (new-var (if partial? var (var-to-new-partial-var var)))
	 (new-kernel
	  (if partial? kernel
	      (formula-subst kernel var (make-term-in-var-form new-var))))
	 (inst-eq-compat-aconst
	  (make-aconst "Eq-Compat" 'axiom eq-compat-fla
		       (list (list eq-compat-tvar type)
			     (list eq-compat-pvar
				   (make-cterm new-var new-kernel)))))
	 (eq-symm-fla (aconst-to-uninst-formula eq-symm-aconst))
	 (eq-symm-tvar (car (formula-to-tvars eq-symm-fla)))
	 (inst-eq-symm-aconst
	  (make-aconst "Eq-Symm" 'axiom eq-symm-fla
		       (list (list eq-symm-tvar type))))
	 (vars (list-tail (allnc-form-to-vars
			   (aconst-to-formula inst-eq-compat-aconst))
			  (length free)))
	 (var1 (car vars))
	 (var2 (cadr vars))
	 (=-to-eq-aconst (finalg-to-=-to-eq-aconst type))
	 (avar (formula-to-new-avar (make-= (make-term-in-var-form var1)
					    (make-term-in-var-form var2)))))
    (mk-proof-in-nc-intro-form
     var1 var2
     (make-proof-in-imp-intro-form
      avar (apply
	    mk-proof-in-elim-form
	    (append
	     (list (make-proof-in-aconst-form inst-eq-compat-aconst))
	     (map make-term-in-var-form free)
	     (list
	      (make-term-in-var-form var2)
	      (make-term-in-var-form var1)
	      (mk-proof-in-elim-form
	       (make-proof-in-aconst-form inst-eq-symm-aconst)
	       (make-term-in-var-form var1)
	       (make-term-in-var-form var2)
	       (mk-proof-in-elim-form
		(make-proof-in-aconst-form =-to-eq-aconst)
		(make-term-in-var-form var1)
		(make-term-in-var-form var2)
		(make-proof-in-avar-form avar))))))))))

(define (eq-compat-at all-formula)
  (let* ((var (all-form-to-var all-formula))
	 (kernel (all-form-to-kernel all-formula))
	 (type (var-to-type var))
	 (partial? (t-deg-zero? (var-to-t-deg var)))
	 (new-var (if partial? var (var-to-new-partial-var var)))
	 (new-kernel
	  (if partial? kernel
	      (formula-subst kernel var (make-term-in-var-form new-var))))
	 (cterm (make-cterm new-var new-kernel)))
    (if
     (finalg? type)
     (let* ((aconst
	     (let* ((typename (type-to-space-free-string type))
		    (aconstname (string-append "Eq-Compat-" typename))
		    (info1 (assoc aconstname THEOREMS))
		    (info2 (assoc aconstname GLOBAL-ASSUMPTIONS)))
	       (cond
		(info1 (theorem-name-to-aconst aconstname))
		(info2 (global-assumption-name-to-aconst aconstname))
		(else
		 (let* ((name (default-var-name type))
			(var1 (make-var type 1 0 name))
			(var2 (make-var type 2 0 name))
			(varterm1 (make-term-in-var-form var1))
			(varterm2 (make-term-in-var-form var2))
			(eq-fla (make-eq varterm1 varterm2))
			(pvar (make-pvar (make-arity type) -1 0 0 ""))
			(fla1 (make-predicate-formula pvar varterm1))
			(fla2 (make-predicate-formula pvar varterm2))
			(fla (mk-allnc var1 var2 (mk-imp eq-fla fla1 fla2))))
		   (add-global-assumption aconstname fla)
		   (global-assumption-name-to-aconst aconstname))))))
	    (uninst-formula (aconst-to-uninst-formula aconst))
	    (final-conclusion
	     (imp-impnc-all-allnc-form-to-final-conclusion uninst-formula))
	    (pvar (predicate-form-to-predicate final-conclusion)))
       (proof-subst (make-proof-in-aconst-form aconst) pvar cterm))
     (let* ((aconst eq-compat-aconst)
	    (uninst-formula (aconst-to-uninst-formula aconst))
	    (tvar (var-to-type (allnc-form-to-var uninst-formula)))
	    (final-conclusion
	     (imp-impnc-all-allnc-form-to-final-conclusion uninst-formula))
	    (pvar (predicate-form-to-predicate final-conclusion))
	    (tsubst (make-subst tvar type))
	    (pinst (make-subst-wrt pvar-cterm-equal? pvar cterm))
	    (free (formula-to-free all-formula)))
       (apply
	mk-proof-in-elim-form
	(cons (make-proof-in-aconst-form
	       (make-aconst
		(aconst-to-name aconst) ;"Eq-Compat"
		(aconst-to-kind aconst) ;'axiom
		uninst-formula
		(append tsubst pinst)))
	      (map make-term-in-var-form free)))))))

(define (eq-compat-rev-at all-formula)
  (let* ((var (all-form-to-var all-formula))
	 (kernel (all-form-to-kernel all-formula))
	 (type (var-to-type var))
	 (partial? (t-deg-zero? (var-to-t-deg var)))
	 (new-var (if partial? var (var-to-new-partial-var var)))
	 (new-kernel
	  (if partial? kernel
	      (formula-subst kernel var (make-term-in-var-form new-var))))
	 (cterm (make-cterm new-var new-kernel)))
    (if
     (finalg? type)
     (let* ((aconst
	     (let* ((typename (type-to-space-free-string type))
		    (aconstname (string-append "Eq-Compat-Rev-" typename))
		    (info1 (assoc aconstname THEOREMS))
		    (info2 (assoc aconstname GLOBAL-ASSUMPTIONS)))
	       (cond
		(info1 (theorem-name-to-aconst aconstname))
		(info2 (global-assumption-name-to-aconst aconstname))
		(else
		 (let* ((name (default-var-name type))
			(var1 (make-var type 1 0 name))
			(var2 (make-var type 2 0 name))
			(varterm1 (make-term-in-var-form var1))
			(varterm2 (make-term-in-var-form var2))
			(eq-fla (make-eq varterm1 varterm2))
			(pvar (make-pvar (make-arity type) -1 0 0 ""))
			(fla1 (make-predicate-formula pvar varterm1))
			(fla2 (make-predicate-formula pvar varterm2))
			(fla (mk-allnc var1 var2 (mk-imp eq-fla fla2 fla1))))
		   (add-global-assumption aconstname fla)
		   (global-assumption-name-to-aconst aconstname))))))
	    (uninst-formula (aconst-to-uninst-formula aconst))
	    (final-conclusion
	     (imp-impnc-all-allnc-form-to-final-conclusion uninst-formula))
	    (pvar (predicate-form-to-predicate final-conclusion)))
       (proof-subst (make-proof-in-aconst-form aconst) pvar cterm))
     (let* ((aconst eq-compat-rev-aconst)
	    (uninst-formula (aconst-to-uninst-formula aconst))
	    (tvar (var-to-type (allnc-form-to-var uninst-formula)))
	    (final-conclusion
	     (imp-impnc-all-allnc-form-to-final-conclusion uninst-formula))
	    (pvar (predicate-form-to-predicate final-conclusion))
	    (tsubst (make-subst tvar type))
	    (pinst (make-subst-wrt pvar-cterm-equal? pvar cterm))
	    (free (formula-to-free all-formula)))
       (apply
	mk-proof-in-elim-form
	(cons (make-proof-in-aconst-form
	       (make-aconst
		(aconst-to-name aconst) ;"Eq-Compat-Rev"
		(aconst-to-kind aconst) ;'theorem
		uninst-formula
		(append tsubst pinst)))
	      (map make-term-in-var-form free)))))))

(define (eqd-compat-at all-formula)
  (let* ((var (all-form-to-var all-formula))
	 (kernel (all-form-to-kernel all-formula))
	 (type (var-to-type var))
	 (partial? (t-deg-zero? (var-to-t-deg var)))
	 (new-var (if partial? var (var-to-new-partial-var var)))
	 (new-kernel
	  (if partial? kernel
	      (formula-subst kernel var (make-term-in-var-form new-var))))
	 (cterm (make-cterm new-var new-kernel))
	 (aconst (theorem-name-to-aconst "EqDCompat"))
	 (uninst-formula (aconst-to-uninst-formula aconst))
	 (tvar (var-to-type (allnc-form-to-var uninst-formula)))
	 (final-conclusion
	  (imp-impnc-all-allnc-form-to-final-conclusion uninst-formula))
	 (pvar (predicate-form-to-predicate final-conclusion))
	 (tsubst (make-subst tvar type))
	 (pinst (make-subst-wrt pvar-cterm-equal? pvar cterm))
	 (free (formula-to-free all-formula)))
    (apply mk-proof-in-elim-form
	   (cons (make-proof-in-aconst-form
		  (make-aconst (aconst-to-name aconst) ;"EqDCompat"
			       (aconst-to-kind aconst) ;'theorem
			       uninst-formula
			       (append tsubst pinst)))
		 (map make-term-in-var-form free)))))

(define (eqd-compat-rev-at all-formula)
  (let* ((var (all-form-to-var all-formula))
	 (kernel (all-form-to-kernel all-formula))
	 (type (var-to-type var))
	 (partial? (t-deg-zero? (var-to-t-deg var)))
	 (new-var (if partial? var (var-to-new-partial-var var)))
	 (new-kernel
	  (if partial? kernel
	      (formula-subst kernel var (make-term-in-var-form new-var))))
	 (cterm (make-cterm new-var new-kernel))
	 (aconst (theorem-name-to-aconst "EqDCompatRev"))
	 (uninst-formula (aconst-to-uninst-formula aconst))
	 (tvar (var-to-type (allnc-form-to-var uninst-formula)))
	 (final-conclusion
	  (imp-impnc-all-allnc-form-to-final-conclusion uninst-formula))
	 (pvar (predicate-form-to-predicate final-conclusion))
	 (tsubst (make-subst tvar type))
	 (pinst (make-subst-wrt pvar-cterm-equal? pvar cterm))
	 (free (formula-to-free all-formula)))
    (apply mk-proof-in-elim-form
	   (cons (make-proof-in-aconst-form
		  (make-aconst (aconst-to-name aconst) ;"EqDCompatRev"
			       (aconst-to-kind aconst) ;'theorem
			       uninst-formula
			       (append tsubst pinst)))
		 (map make-term-in-var-form free)))))

; simphyp-with does for forward chaining the same as simp-with for
; backward chaining.  It replaces the present goal by a new one, with
; one additional hypothesis obtained by simplifying a previous one.
; Notice that this effect could also be obtained by cut or assert.  In
; the definition below of simphyp-with hyp is one of the following.
; - A number or string identifying a hypothesis form the context.
; - The name of a theorem or global assumption, but not one whose final
;   conclusion is a predicate variable.
; - A closed proof.
; - A formula with free variables from the context, generating a new goal.
; Moreover xs is a list consisting of
; - a number or string identifying a hypothesis form the context,
; - the name of a theorem or global assumption,
; - a closed proof,
; - the string "?" (value of DEFAULT-GOAL-NAME), generating a new goal,
; - a symbol left or right,
; - a term, whose free variables are added to the context,
; - a type, which is substituted for the 1st tvar,
; - a comprehension term, which is substituted for the 1st pvar.

; This generates a used formula, which is to be an atom, a negated
; atom or (Equal lhs rhs) or (lhs eqd rhs).  If it as a (negated)
; atom, check whether the kernel or its normal form is present in the
; hyp.  If so, replace it by True (False).  If it is an equality (lhs
; = rhs) or (Equal lhs rhs) or (lhs eqd rhs) with lhs or its normal
; form present in the hyp, replace lhs by rhs.  In case "<-" exchange
; lhs by rhs.

(define (simphyp-with hyp opt-dir . rest)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply simphyp-with-intern
		 (append (list num-goals proof maxgoal hyp opt-dir) rest)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (simphyp-with-intern num-goals proof maxgoal hyp . opt-dir-and-xs)
  (let* ((opt-dir (if (null? opt-dir-and-xs)
		      (myerror "simphyp-with-intern" "more arguments expected")
		      (car opt-dir-and-xs)))
	 (left-to-right (not (and (string? opt-dir) (string=? "<-" opt-dir))))
	 (x-and-x-list (if left-to-right
			   opt-dir-and-xs
			   (cdr opt-dir-and-xs)))
	 (x (if (null? x-and-x-list)
		(myerror "simphyp-with-intern" "more arguments expected")
		(car x-and-x-list)))
	 (x-list (cdr x-and-x-list))
	 (num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (drop-info (num-goal-to-drop-info num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (cvars (goal-to-cvars goal))
	 (leaf (if (formula-form? hyp)
		   (context-and-cvars-and-formula-to-new-goal
		    context cvars hyp)
		   (hyp-info-to-leaf num-goal hyp)))
	 (new-num-goals-hyp
	  (if (formula-form? hyp) ;then a new goal is created
	      (list (make-num-goal (+ 1 maxgoal) leaf drop-info hypname-info))
	      '()))
	 (new-maxgoal-hyp (if (formula-form? hyp) (+ 1 maxgoal) maxgoal))
	 (proof-and-new-num-goals-and-maxgoal
	  (if (and (string? x)
		   (let ((info (assoc x (append THEOREMS GLOBAL-ASSUMPTIONS))))
		     (and info
			  (let* ((aconst (cadr info))
				 (aconst-formula (aconst-to-formula aconst))
				 (final-concl
				  (imp-impnc-all-allnc-form-to-final-conclusion
				   aconst-formula)))
			    (and (predicate-form? final-concl)
				 (pvar? (predicate-form-to-predicate
					 final-concl)))))))
	      (myerror "simphyp-with-intern" "unexpected aconst name" x)
	      (apply x-and-x-list-to-proof-and-new-num-goals-and-maxgoal
		     (append (list num-goal (+ 1 new-maxgoal-hyp) x) x-list))))
	 (negatom-or-eq-proof (car proof-and-new-num-goals-and-maxgoal))
	 (new-num-goals (append new-num-goals-hyp
				(cadr proof-and-new-num-goals-and-maxgoal)))
	 (new-maxgoal (caddr proof-and-new-num-goals-and-maxgoal))
	 (goal-formula (goal-to-formula goal))
	 (leaf-formula (proof-to-formula leaf))
	 (used-formula (proof-to-formula negatom-or-eq-proof))
	 (used-prime-formula
	  (cond ((prime-form? used-formula) used-formula)
		((and (imp-impnc-form? used-formula)
		      (atom-form? (imp--impnc-form-to-premise used-formula))
		      (classical-formula=?
		       falsity (imp-impnc-form-to-conclusion used-formula)))
		 (imp-form-to-premise used-formula))
		(else (myerror "simphyp-with-intern"
			       "negated atom or prime formula expected"
			       used-formula))))
	 (used-nprime-formula (normalize-formula used-prime-formula))
	 (bvar (type-to-new-var (make-alg "boole")))
	 (bvarterm (make-term-in-var-form bvar))
	 (used-kernel (if (atom-form? used-prime-formula)
			  (atom-form-to-kernel used-prime-formula)
			  bvarterm)) ;anything would do
	 (used-nkernel (nt used-kernel))
	 (op (term-in-app-form-to-final-op used-kernel))
	 (nop (term-in-app-form-to-final-op used-nkernel))
	 (leaf-formula-without-kernel
	  (if (atom-form? used-prime-formula)
	      (formula-gen-subst leaf-formula used-kernel bvarterm)
	      leaf-formula))
	 (nleaf-formula-without-nkernel
	  (if (atom-form? used-prime-formula)
	      (formula-gen-subst (nf leaf-formula) used-nkernel bvarterm)
	      leaf-formula))
	 (kernel-present? (not (classical-formula=?
				leaf-formula-without-kernel
				leaf-formula)))
	 (nkernel-present? (not (classical-formula=?
				 nleaf-formula-without-nkernel
				 leaf-formula))))
    (cond
     ((and kernel-present?
	   (not (term=? used-kernel (make-term-in-const-form true-const)))
	   (not (term=? used-kernel (make-term-in-const-form false-const)))
	   (or (atom-form? used-formula) (synt-total? used-kernel)))
      (simphyp-with-kernel-aux
       num-goals proof maxgoal negatom-or-eq-proof new-num-goals new-maxgoal
       used-kernel bvar leaf-formula-without-kernel leaf))
     ((and nkernel-present?
	   (not (term=? used-nkernel (make-term-in-const-form true-const)))
	   (not (term=? used-nkernel (make-term-in-const-form false-const)))
	   (or (atom-form? used-formula) (synt-total? used-nkernel)))
      (simphyp-with-kernel-aux
       num-goals proof maxgoal negatom-or-eq-proof new-num-goals new-maxgoal
       used-nkernel bvar nleaf-formula-without-nkernel leaf))
     ((and (term-in-const-form? op)
	   (string=? "=" (const-to-name (term-in-const-form-to-const op)))
	   (let* ((args (term-in-app-form-to-args used-kernel))
		  (lhs (car args))
		  (rhs (cadr args))
		  (type (term-to-type lhs))
		  (var (type-to-new-var type))
		  (varterm (make-term-in-var-form var))
		  (simphyp-formula
		   (if left-to-right
		       (formula-gen-subst leaf-formula lhs varterm)
		       (formula-gen-subst leaf-formula rhs varterm))))
	     (not (classical-formula=? simphyp-formula leaf-formula))))
      (let* ((args (term-in-app-form-to-args used-kernel))
	     (lhs (car args))
	     (rhs (cadr args))
	     (type (term-to-type lhs))
	     (var (type-to-new-var type))
	     (varterm (make-term-in-var-form var))
	     (simphyp-formula
	      (if left-to-right
		  (formula-gen-subst leaf-formula lhs varterm)
		  (formula-gen-subst leaf-formula rhs varterm)))
	     (all-formula (mk-all var simphyp-formula))
	     (proof-of-simphyp
	      (mk-proof-in-elim-form
	       (if
		left-to-right
		(compat-at all-formula)      ;allnc n,m(n=m -> A(n) -> A(m))
		(compat-rev-at all-formula)) ;allnc n,m(n=m -> A(m) -> A(n))
	       lhs rhs negatom-or-eq-proof leaf))
	     (simphyp-formula (proof-to-formula proof-of-simphyp))
	     (new-avar (formula-to-new-avar simphyp-formula DEFAULT-AVAR-NAME))
	     (new-goalformula
	      (context-and-cvars-and-formula-to-formula
	       (append context (list new-avar)) cvars goal-formula))
	     (new-goalvar (formula-to-new-avar new-goalformula
					       DEFAULT-AVAR-NAME))
	     (new-goal
	      (apply mk-goal-in-elim-form
		     (append (list (make-goal-in-avar-form new-goalvar))
			     context
			     (list new-avar))))
	     (new-proof (make-proof-in-imp-elim-form
			 (make-proof-in-imp-intro-form new-avar new-goal)
			 proof-of-simphyp))
	     (new-num-goal (make-num-goal
			    (+ 1 maxgoal) new-goal drop-info hypname-info)))
	(make-pproof-state
	 (append (list new-num-goal) new-num-goals (cdr num-goals))
	 (goal-subst proof goal new-proof)
	 new-maxgoal)))
     ((and (term-in-const-form? nop)
	   (string=? "=" (const-to-name (term-in-const-form-to-const nop)))
	   (let* ((args (term-in-app-form-to-args used-nkernel))
		  (lhs (car args))
		  (rhs (cadr args))
		  (type (term-to-type lhs))
		  (var (type-to-new-var type))
		  (varterm (make-term-in-var-form var))
		  (simphyp-formula
		   (if left-to-right
		       (formula-gen-subst leaf-formula lhs varterm)
		       (formula-gen-subst leaf-formula rhs varterm))))
	     (not (classical-formula=? simphyp-formula leaf-formula))))
      (let* ((args (term-in-app-form-to-args used-nkernel))
	     (lhs (car args))
	     (rhs (cadr args))
	     (type (term-to-type lhs))
	     (var (type-to-new-var type))
	     (varterm (make-term-in-var-form var))
	     (simphyp-formula
	      (if left-to-right
		  (formula-gen-subst leaf-formula lhs varterm)
		  (formula-gen-subst leaf-formula rhs varterm)))
	     (all-formula (mk-all var simphyp-formula))
	     (proof-of-simphyp
	      (mk-proof-in-elim-form
	       (if
		left-to-right
		(compat-at all-formula)      ;allnc n,m(n=m -> A(n) -> A(m))
		(compat-rev-at all-formula)) ;allnc n,m(n=m -> A(m) -> A(n))
	       lhs rhs negatom-or-eq-proof leaf))
	     (simphyp-formula (proof-to-formula proof-of-simphyp))
	     (new-avar (formula-to-new-avar simphyp-formula DEFAULT-AVAR-NAME))
	     (new-goalformula
	      (context-and-cvars-and-formula-to-formula
	       (append context (list new-avar)) cvars goal-formula))
	     (new-goalvar (formula-to-new-avar new-goalformula
					       DEFAULT-AVAR-NAME))
	     (new-goal
	      (apply mk-goal-in-elim-form
		     (append (list (make-goal-in-avar-form new-goalvar))
			     context
			     (list new-avar))))
	     (new-proof (make-proof-in-imp-elim-form
			 (make-proof-in-imp-intro-form new-avar new-goal)
			 proof-of-simphyp))
	     (new-num-goal (make-num-goal
			    (+ 1 maxgoal) new-goal drop-info hypname-info)))
	(make-pproof-state
	 (append (list new-num-goal) new-num-goals (cdr num-goals))
	 (goal-subst proof goal new-proof)
	 new-maxgoal)))
     ((and (predicate-form? used-prime-formula)
	   (string=? "Equal" (predconst-to-name
			      (predicate-form-to-predicate
			       used-prime-formula)))
	   (let* ((args (predicate-form-to-args used-prime-formula))
		  (lhs (car args))
		  (rhs (cadr args))
		  (type (term-to-type lhs))
		  (var (type-to-new-var type))
		  (varterm (make-term-in-var-form var))
		  (simphyp-formula
		   (if left-to-right
		       (formula-gen-subst leaf-formula lhs varterm)
		       (formula-gen-subst leaf-formula rhs varterm))))
	     (not (classical-formula=? simphyp-formula leaf-formula))))
      (let* ((args (predicate-form-to-args used-prime-formula))
	     (lhs (car args))
	     (rhs (cadr args))
	     (type (term-to-type lhs))
	     (var (type-to-new-var type))
	     (varterm (make-term-in-var-form var))
	     (simphyp-formula
	      (if left-to-right
		  (formula-gen-subst leaf-formula lhs varterm)
		  (formula-gen-subst leaf-formula rhs varterm)))
	     (all-formula (mk-all var simphyp-formula))
	     (proof-of-simphyp
	      (mk-proof-in-elim-form
	       (if
		left-to-right
		(eq-compat-at all-formula)      ;allnc n,m(n=m -> A(n) -> A(m))
		(eq-compat-rev-at all-formula)) ;allnc n,m(n=m -> A(m) -> A(n))
	       lhs rhs negatom-or-eq-proof leaf))
	     (simphyp-formula (proof-to-formula proof-of-simphyp))
	     (new-avar (formula-to-new-avar simphyp-formula DEFAULT-AVAR-NAME))
	     (new-goalformula
	      (context-and-cvars-and-formula-to-formula
	       (append context (list new-avar)) cvars goal-formula))
	     (new-goalvar (formula-to-new-avar new-goalformula
					       DEFAULT-AVAR-NAME))
	     (new-goal
	      (apply mk-goal-in-elim-form
		     (append (list (make-goal-in-avar-form new-goalvar))
			     context
			     (list new-avar))))
	     (new-proof (make-proof-in-imp-elim-form
			 (make-proof-in-imp-intro-form new-avar new-goal)
			 proof-of-simphyp))
	     (new-num-goal (make-num-goal
			    (+ 1 maxgoal) new-goal drop-info hypname-info)))
	(make-pproof-state
	 (append (list new-num-goal) new-num-goals (cdr num-goals))
	 (goal-subst proof goal new-proof)
	 new-maxgoal)))
     ((and (predicate-form? used-nprime-formula)
	   (string=? "Equal" (predconst-to-name
			      (predicate-form-to-predicate
			       used-nprime-formula)))
	   (let* ((args (predicate-form-to-args used-nprime-formula))
		  (lhs (car args))
		  (rhs (cadr args))
		  (type (term-to-type lhs))
		  (var (type-to-new-var type))
		  (varterm (make-term-in-var-form var))
		  (simphyp-formula
		   (if left-to-right
		       (formula-gen-subst leaf-formula lhs varterm)
		       (formula-gen-subst leaf-formula rhs varterm))))
	     (not (classical-formula=? simphyp-formula leaf-formula))))
      (let* ((args (predicate-form-to-args used-nprime-formula))
	     (lhs (car args))
	     (rhs (cadr args))
	     (type (term-to-type lhs))
	     (var (type-to-new-var type))
	     (varterm (make-term-in-var-form var))
	     (simphyp-formula
	      (if left-to-right
		  (formula-gen-subst leaf-formula lhs varterm)
		  (formula-gen-subst leaf-formula rhs varterm)))
	     (all-formula (mk-all var simphyp-formula))
	     (proof-of-simphyp
	      (mk-proof-in-elim-form
	       (if
		left-to-right
		(eq-compat-at all-formula)      ;allnc n,m(n=m -> A(n) -> A(m))
		(eq-compat-rev-at all-formula)) ;allnc n,m(n=m -> A(m) -> A(n))
	       lhs rhs negatom-or-eq-proof leaf))
	     (simphyp-formula (proof-to-formula proof-of-simphyp))
	     (new-avar (formula-to-new-avar simphyp-formula DEFAULT-AVAR-NAME))
	     (new-goalformula
	      (context-and-cvars-and-formula-to-formula
	       (append context (list new-avar)) cvars goal-formula))
	     (new-goalvar (formula-to-new-avar new-goalformula
					       DEFAULT-AVAR-NAME))
	     (new-goal
	      (apply mk-goal-in-elim-form
		     (append (list (make-goal-in-avar-form new-goalvar))
			     context
			     (list new-avar))))
	     (new-proof (make-proof-in-imp-elim-form
			 (make-proof-in-imp-intro-form new-avar new-goal)
			 proof-of-simphyp))
	     (new-num-goal (make-num-goal
			    (+ 1 maxgoal) new-goal drop-info hypname-info)))
	(make-pproof-state
	 (append (list new-num-goal) new-num-goals (cdr num-goals))
	 (goal-subst proof goal new-proof)
	 new-maxgoal)))
     ((and
       (predicate-form? used-prime-formula)
       (let ((predicate (predicate-form-to-predicate used-prime-formula)))
	 (and (idpredconst-form? predicate)
	      (string=? "EqD" (idpredconst-to-name predicate))
	      (let* ((args (predicate-form-to-args used-prime-formula))
		     (lhs (car args))
		     (rhs (cadr args))
		     (type (term-to-type lhs))
		     (var (type-to-new-var type))
		     (varterm (make-term-in-var-form var))
		     (simphyp-formula
		      (if left-to-right
			  (formula-gen-subst leaf-formula lhs varterm)
			  (formula-gen-subst leaf-formula rhs varterm))))
		(not (classical-formula=? simphyp-formula leaf-formula))))))
      (let* ((args (predicate-form-to-args used-prime-formula))
	     (lhs (car args))
	     (rhs (cadr args))
	     (type (term-to-type lhs))
	     (var (type-to-new-var type))
	     (varterm (make-term-in-var-form var))
	     (simphyp-formula
	      (if left-to-right
		  (formula-gen-subst leaf-formula lhs varterm)
		  (formula-gen-subst leaf-formula rhs varterm)))
	     (all-formula (mk-all var simphyp-formula))
	     (proof-of-simphyp
	      (mk-proof-in-elim-form
	       (if
		left-to-right
		(eqd-compat-at all-formula)     ;allnc n,m(n=m -> A(n) -> A(m))
		(eqd-compat-rev-at all-formula));allnc n,m(n=m -> A(m) -> A(n))
	       lhs rhs negatom-or-eq-proof leaf))
	     (simphyp-formula (proof-to-formula proof-of-simphyp))
	     (new-avar (formula-to-new-avar simphyp-formula DEFAULT-AVAR-NAME))
	     (new-goalformula
	      (context-and-cvars-and-formula-to-formula
	       (append context (list new-avar)) cvars goal-formula))
	     (new-goalvar (formula-to-new-avar new-goalformula
					       DEFAULT-AVAR-NAME))
	     (new-goal
	      (apply mk-goal-in-elim-form
		     (append (list (make-goal-in-avar-form new-goalvar))
			     context
			     (list new-avar))))
	     (new-proof (make-proof-in-imp-elim-form
			 (make-proof-in-imp-intro-form new-avar new-goal)
			 proof-of-simphyp))
	     (new-num-goal (make-num-goal
			    (+ 1 maxgoal) new-goal drop-info hypname-info)))
	(make-pproof-state
	 (append (list new-num-goal) new-num-goals (cdr num-goals))
	 (goal-subst proof goal new-proof)
	 new-maxgoal)))
     ((and
       (predicate-form? used-nprime-formula)
       (let ((predicate (predicate-form-to-predicate used-nprime-formula)))
	 (and (idpredconst-form? predicate)
	      (string=? "EqD" (idpredconst-to-name predicate))
	      (let* ((args (predicate-form-to-args used-nprime-formula))
		     (lhs (car args))
		     (rhs (cadr args))
		     (type (term-to-type lhs))
		     (var (type-to-new-var type))
		     (varterm (make-term-in-var-form var))
		     (simphyp-formula
		      (if left-to-right
			  (formula-gen-subst leaf-formula lhs varterm)
			  (formula-gen-subst leaf-formula rhs varterm))))
		(not (classical-formula=? simphyp-formula leaf-formula))))))
      (let* ((args (predicate-form-to-args used-nprime-formula))
	     (lhs (car args))
	     (rhs (cadr args))
	     (type (term-to-type lhs))
	     (var (type-to-new-var type))
	     (varterm (make-term-in-var-form var))
	     (simphyp-formula
	      (if left-to-right
		  (formula-gen-subst leaf-formula lhs varterm)
		  (formula-gen-subst leaf-formula rhs varterm)))
	     (all-formula (mk-all var simphyp-formula))
	     (proof-of-simphyp
	      (mk-proof-in-elim-form
	       (if
		left-to-right
		(eqd-compat-at all-formula)     ;allnc n,m(n=m -> A(n) -> A(m))
		(eqd-compat-rev-at all-formula));allnc n,m(n=m -> A(m) -> A(n))
	       lhs rhs negatom-or-eq-proof leaf))
	     (simphyp-formula (proof-to-formula proof-of-simphyp))
	     (new-avar (formula-to-new-avar simphyp-formula DEFAULT-AVAR-NAME))
	     (new-goalformula
	      (context-and-cvars-and-formula-to-formula
	       (append context (list new-avar)) cvars goal-formula))
	     (new-goalvar (formula-to-new-avar new-goalformula
					       DEFAULT-AVAR-NAME))
	     (new-goal
	      (apply mk-goal-in-elim-form
		     (append (list (make-goal-in-avar-form new-goalvar))
			     context
			     (list new-avar))))
	     (new-proof (make-proof-in-imp-elim-form
			 (make-proof-in-imp-intro-form new-avar new-goal)
			 proof-of-simphyp))
	     (new-num-goal (make-num-goal
			    (+ 1 maxgoal) new-goal drop-info hypname-info)))
	(make-pproof-state
	 (append (list new-num-goal) new-num-goals (cdr num-goals))
	 (goal-subst proof goal new-proof)
	 new-maxgoal)))
     (else (myerror "simphyp-with-intern"
		    "hypothesis cannot be simplified with"
		    used-formula)))))

(define (simphyp-with-kernel-aux
	 num-goals proof maxgoal negatom-or-eq-proof new-num-goals new-maxgoal
	 used-kernel bvar leaf-formula-without-kernel leaf)
  (let* ((num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (goal-formula (goal-to-formula goal))
	 (drop-info (num-goal-to-drop-info num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (cvars (goal-to-cvars goal))
	 (used-formula (proof-to-formula negatom-or-eq-proof))
	 (all-formula (mk-all bvar leaf-formula-without-kernel)))
    (if
     (atom-form? used-formula)
     (let* ((proof-of-simphyp ;of A(True)
	     (mk-proof-in-elim-form
	      (compat-at all-formula) ;allnc p^,q^(p^=q^ -> A(p^) -> A(q^))
	      used-kernel ;r
	      (make-term-in-const-form true-const)
	      (mk-proof-in-elim-form ;of r=True
	       (make-proof-in-aconst-form ;of all p.atom(p) -> p=True
		atom-true-aconst)
	       used-kernel ;r
	       negatom-or-eq-proof) ;of atom(r)
	      leaf)) ;of A(r)
	    (simphyp-formula (proof-to-formula proof-of-simphyp))
	    (new-avar (formula-to-new-avar simphyp-formula DEFAULT-AVAR-NAME))
	    (new-goalformula
	     (context-and-cvars-and-formula-to-formula
	      (append context (list new-avar)) cvars goal-formula))
	    (new-goalvar (formula-to-new-avar new-goalformula
					      DEFAULT-AVAR-NAME))
	    (new-goal
	     (apply mk-goal-in-elim-form
		    (append (list (make-goal-in-avar-form new-goalvar))
			    context
			    (list new-avar))))
	    (new-proof (make-proof-in-imp-elim-form
			(make-proof-in-imp-intro-form new-avar new-goal)
			proof-of-simphyp))
	    (new-num-goal (make-num-goal
			   (+ 1 maxgoal) new-goal drop-info hypname-info)))
       (make-pproof-state
	(append (list new-num-goal) new-num-goals (cdr num-goals))
	(goal-subst proof goal new-proof)
	new-maxgoal))
     (let* ((info (assoc "Atom-False" THEOREMS))
	    (atom-false-aconst
	     (if info (cadr info)
		 (myerror "simphyp-with-intern" "Atom-False missing"
			  "all boole.(boole -> F) -> boole=False")))
	    (proof-of-simphyp ;of A(False)
	     (mk-proof-in-elim-form
	      (compat-at all-formula) ;allnc p^,q^(p^=q^ -> A(p^) -> A(q^))
	      used-kernel ;r
	      (make-term-in-const-form false-const)
	      (mk-proof-in-elim-form ;of r=False
	       (make-proof-in-aconst-form ;of all p(~p -> p=False)
		atom-false-aconst)
	       used-kernel ;r
	       negatom-or-eq-proof) ;of ~r
	      leaf)) ;of A(r)
	    (simphyp-formula (proof-to-formula proof-of-simphyp))
	    (new-avar (formula-to-new-avar simphyp-formula DEFAULT-AVAR-NAME))
	    (new-goalformula
	     (context-and-cvars-and-formula-to-formula
	      (append context (list new-avar)) cvars goal-formula))
	    (new-goalvar (formula-to-new-avar new-goalformula
					      DEFAULT-AVAR-NAME))
	    (new-goal
	     (apply mk-goal-in-elim-form
		    (append (list (make-goal-in-avar-form new-goalvar))
			    context
			    (list new-avar))))
	    (new-proof (make-proof-in-imp-elim-form
			(make-proof-in-imp-intro-form new-avar new-goal)
			proof-of-simphyp))
	    (new-num-goal (make-num-goal
			   (+ 1 maxgoal) new-goal drop-info hypname-info)))
       (make-pproof-state
	(append (list new-num-goal) new-num-goals (cdr num-goals))
	(goal-subst proof goal new-proof)
	new-maxgoal)))))

; simphyp-with-to expects a string as its last argument, which is used (via
; name-hyp) to name the newly introduced simplified hypothesis.

(define (simphyp-with-to hyp . opt-dir-and-xs-and-name)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply simphyp-with-to-intern
		 (append (list num-goals proof maxgoal hyp)
			 opt-dir-and-xs-and-name)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (simphyp-with-to-intern num-goals proof maxgoal
				hyp . opt-dir-and-xs-and-name)
  (if (null? (cdr opt-dir-and-xs-and-name))
      (myerror "simp-with-to" "more arguments expected"))
  (if (member DEFAULT-GOAL-NAME opt-dir-and-xs-and-name)
      (myerror "? illegal for simp-with-to; use simp-with instead"))
  (let* ((opt-dir (car opt-dir-and-xs-and-name))
	 (name (car (last-pair opt-dir-and-xs-and-name)))
	 (left-to-right (not (and (string? opt-dir) (string=? "<-" opt-dir))))
	 (opt-dir-and-xs (list-head opt-dir-and-xs-and-name
				    (- (length opt-dir-and-xs-and-name) 1)))
	 (x-and-x-list (if left-to-right
			   opt-dir-and-xs
			   (cdr opt-dir-and-xs)))
	 (x (if (null? x-and-x-list)
		(myerror "simphyp-with-to-intern" "more arguments expected")
		(car x-and-x-list)))
	 (x-list (cdr x-and-x-list)))
    (if (not (string? name))
	(myerror "simphyp-with-to" "string expected" name))
    (let* ((pproof-state1
	    (apply simphyp-with-intern
		   (append (list num-goals proof maxgoal hyp) opt-dir-and-xs)))
	   (num-goals (pproof-state-to-num-goals pproof-state1))
	   (num-goal (car num-goals))
	   (goal (num-goal-to-goal num-goal))
	   (context (goal-to-context goal))
	   (avars (context-to-avars context))
	   (maxhyp (length avars)))
      (apply name-hyp-intern
	     (append pproof-state1 (list maxhyp name))))))

; For backwards compatibility we also have simphyp

(define (simphyp hyp opt-dir . rest)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals)))
	 (simphyp-result
	  (apply simphyp-intern
		 (append (list num-goals proof maxgoal hyp opt-dir) rest))))
    (if (not simphyp-result)
	(begin (display-comment "no simplification possible")
	       (if COMMENT-FLAG (newline)))
	(begin
	  (set! PPROOF-STATE simphyp-result)
	  (pproof-state-history-push PPROOF-STATE)
	  (display-new-goals num-goals number)))))

(define (simphyp-intern num-goals proof
			maxgoal hyp . opt-dir-and-x-and-elab-path-and-terms)
  (let* ((opt-dir (if (null? opt-dir-and-x-and-elab-path-and-terms)
		      (myerror "simphyp-intern" "more arguments expected")
		      (car opt-dir-and-x-and-elab-path-and-terms)))
	 (left-to-right (not (and (string? opt-dir) (string=? "<-" opt-dir))))
	 (x-and-elab-path-and-terms
	  (if left-to-right
	      opt-dir-and-x-and-elab-path-and-terms
	      (cdr opt-dir-and-x-and-elab-path-and-terms)))
	 (x (if (null? x-and-elab-path-and-terms)
		(myerror "simphyp-intern" "more arguments expected")
		(car x-and-elab-path-and-terms)))
	 (elab-path-and-terms (cdr x-and-elab-path-and-terms))
	 (num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (cvars (goal-to-cvars goal))
	 (avars (context-to-avars context))
	 (maxhyp (length avars))
	 (goal-formula (goal-to-formula goal))
	 (leaf (if (formula-form? hyp)
		   (context-and-cvars-and-formula-to-new-goal
		    context cvars hyp)
		   (hyp-info-to-leaf num-goal hyp)))
	 (used-leaf (if (formula-form? x)
			(context-and-cvars-and-formula-to-new-goal
			 context cvars x)
			(hyp-info-to-leaf num-goal x)))
	 (leaf-formula (proof-to-formula leaf))
	 (used-formula
	  (unfold-formula
	   (if (formula-form? x) x (proof-to-formula used-leaf))))
	 (sig-vars (context-to-vars context))
	 (sig-tvars-and-sig-vars
	  (if (assoc x (append THEOREMS GLOBAL-ASSUMPTIONS))
	      sig-vars
	      (append (formula-to-tvars used-formula) sig-vars)))
	 (elab-path (do ((l elab-path-and-terms (cdr l))
			 (res '() (if (memq (car l) '(left right))
				      (cons (car l) res)
				      res)))
			((null? l) (reverse res))))
	 (xs-and-vars-and-toinst1
	  (apply
	   fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data
	   (append (list used-formula sig-tvars-and-sig-vars
			 leaf-formula left-to-right)
		   elab-path)))
	 (xs-and-vars-and-toinst
	  (if xs-and-vars-and-toinst1
	      xs-and-vars-and-toinst1
	      (apply
	       fla-and-sig-tvars-and-vars-and-goal-fla-to-fst-match-data
	       (append (list (normalize-formula used-formula)
			     sig-tvars-and-sig-vars
			     (normalize-formula leaf-formula)
			     left-to-right)	 
		       elab-path)))))
    (if
     (not xs-and-vars-and-toinst)
     #f
     (let* ((xs (car xs-and-vars-and-toinst))
	    (vars (cadr xs-and-vars-and-toinst))
	    (toinst (caddr xs-and-vars-and-toinst))
	    (terms (do ((l elab-path-and-terms (cdr l))
			(res '() (if (memq (car l) '(left right))
				     res
				     (cons (car l) res))))
		       ((null? l) (reverse res))))
	    (subst (if (<= (length vars) (length terms))
		    (map (lambda (x y) (list x y))
			 vars (list-head terms (length vars)))
		    empty-subst))
	    (subst-xs (map (lambda (x) (if (term-form? x)
					   (term-substitute x subst)
					   x))
			   xs))
	    (types (let ((info1 (assoc x THEOREMS))
			 (info2 (assoc x GLOBAL-ASSUMPTIONS))
			 (tsubst (list-transform-positive toinst
				   (lambda (x) (tvar-form? (car x))))))
		     (if
		      (and (or info1 info2) (pair? tsubst)) ;else '()
		      (let* ((aconst (if info1
					 (theorem-name-to-aconst x)
					 (global-assumption-name-to-aconst x)))
			     (fla (aconst-to-formula aconst))
			     (tvars (formula-to-tvars fla)))
			(map (lambda (tvar) (type-substitute tvar tsubst))
			     tvars))
		      '()))))
       (if (> (length vars) (length terms))
	   (apply myerror
		  (cons (list "simphyp"
			      "more terms expected, to be substituted for")
			(list-tail vars (length terms)))))
       (if (and COMMENT-FLAG (< (length vars) (length terms)))
	(begin
	  (comment "warning: superfluous terms")
	  (for-each comment
		    (map term-to-string (list-tail terms (length vars))))))
       (apply simphyp-with-intern
	      (if left-to-right
		  (append (list num-goals proof maxgoal hyp x)
			  (append types subst-xs))
		  (append (list num-goals proof maxgoal hyp "<-" x)
			  (append types subst-xs))))))))

; Now we provide some tactics to generate classical proofs.

; In the following definition of min-pr x is
; - a number or string identifying a classical existential hypothesis 
;   from the context,
; - the name of a classical existential global assumption or theorem
; - a closed proof on a classical existential formula (closed ones suffice),
; - a classical existential formula with free variables from the context, 
;   generating a new goal.

; The result is a new implicational goal, whose premise provides the
; (classical) existence of instances with least measure.

(define (min-pr x measure)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE (min-pr-intern num-goals proof maxgoal x measure))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (min-pr-intern num-goals proof maxgoal x measure)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (avars (context-to-avars context))
	 (l (length avars))
	 (goal-formula (goal-to-formula goal))
	 (exc-formula-and-x1
	  (cond
	   ((and (integer? x) (positive? x))
	    (if (<= x l)
		(let* ((avar (list-ref avars (- x 1)))
		       (formula (avar-to-formula avar)))
		  (list formula (make-proof-in-avar-form avar)))
		(myerror "min-pr" "assumption number expected" x)))
	   ((and (string? x)
		 (member x (hypname-info-to-names hypname-info)))
	    (let ((i (name-and-hypname-info-to-index x hypname-info)))
	      (if (<= i l)
		  (let* ((avar (list-ref avars (- i 1)))
			 (formula (avar-to-formula avar)))
		    (list formula (make-proof-in-avar-form avar)))
		  (myerror "min-pr" "assumption number expected" i))))
	   ((and (string? x) (assoc x THEOREMS))
	    (let* ((aconst (theorem-name-to-aconst x))
		   (formula (aconst-to-formula aconst)))
	      (list formula (make-proof-in-aconst-form aconst))))
	   ((and (string? x) (assoc x GLOBAL-ASSUMPTIONS))
	    (let* ((aconst (global-assumption-name-to-aconst x))
		   (formula (aconst-to-formula aconst)))
	      (list formula (make-proof-in-aconst-form aconst))))
	   ((proof-form? x) (list (proof-to-formula x) x))
	   ((formula-form? x) ;then a new goal is created
	    (list x DEFAULT-GOAL-NAME))
	   (else (myerror "min-pr" "illegal argument" x))))
	 (formula (car exc-formula-and-x1))
         (exc-formula (if (exc-form? formula)
                          formula
                          (if (or (foldable-excl-form? formula)
                                  (foldable-exca-form? formula))
                              (fold-formula formula)
                              (myerror "min-pr-intern"
                                       "exc-formula expected"
                                       formula))))
         (x1 (cadr exc-formula-and-x1))
	 (free (formula-to-free exc-formula))
	 (min-pr-proof (exc-formula-to-min-pr-proof exc-formula)))
    (apply inst-with-intern
	   (append (list num-goals proof maxgoal
			 min-pr-proof)
		   (map make-term-in-var-form free)
		   (list measure x1)))))

; exc-formula-to-min-pr-proof computes first a gind-aconst (an axiom or
; a theorem) and from this a proof of the minimum principle.

;  Recall gind: all h,x(all x(all y(hy<hx -> Ry) -> Rx) -> all p(p -> Rx))

;                      gind  h  x  prog:all x(all y(hy<hx -> Ry) -> Rx) True T
;                      -------------------------------------------------------
;                                                Rx
;                                             --------
;      exc-avar:all x Rx -> bot               all x Rx
;      -----------------------------------------------
;                           bot
; ------------------------------------------------------------------
; all h((all x Rx -> bot) -> all x(all y(hy<hx -> Ry) -> Rx) -> bot)

(define (exc-formula-to-min-pr-proof exc-formula . opt-gindthmname)
  (let* ((vars (quant-form-to-vars exc-formula))
         (n (length vars))
         (unfolded-formula (unfold-formula exc-formula))
         (all-formula (imp-form-to-premise unfolded-formula))
         (kernel-formula (all-form-to-final-kernel all-formula n))
         (gind-aconst (apply all-formula-to-gind-aconst
			     (append (list all-formula n) opt-gindthmname)))
         (inst-gind-formula (aconst-to-inst-formula gind-aconst))
         (measure-var (all-form-to-var inst-gind-formula))
         (free (formula-to-free all-formula))
         (prog-formula (imp-form-to-premise
			(all-form-to-final-kernel inst-gind-formula)))
         (prog-avar (formula-to-new-avar prog-formula))
         (exc-avar (formula-to-new-avar unfolded-formula))
         (bot-proof
          (make-proof-in-imp-elim-form
           (make-proof-in-avar-form exc-avar)
           (apply mk-proof-in-intro-form
                  (append
                   vars
                   (list (apply
			  mk-proof-in-elim-form
			  (cons (make-proof-in-aconst-form gind-aconst)
				(append
				 (map make-term-in-var-form
				      (append free (list measure-var) vars))
				 (list (make-proof-in-avar-form prog-avar)
				       (pt "True")
				       (make-proof-in-aconst-form
					truth-aconst)))))))))))
    (apply mk-proof-in-nc-intro-form
           (append
            free
            (list (apply mk-proof-in-intro-form
			 (list measure-var exc-avar prog-avar bot-proof)))))))
  
; Suppose we are proving a goal G from a classical existential
; hypothesis ExcHyp: exc x1..xn(A1 !..! Am).  Then by the minimum
; principle we can assume that we have x1..xn which are minimal
; w.r.t. a measure h such that A1..Am are satified.  Correspondingly
; we provide

(define (by-assume-minimal-wrt
	 exc-hyp . varnames-and-measure-and-minhyp-and-hyps)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE
	  (apply by-assume-minimal-wrt-intern
		 (append (list num-goals proof maxgoal exc-hyp)
			 varnames-and-measure-and-minhyp-and-hyps)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (by-assume-minimal-wrt-intern
	 num-goals proof maxgoal exc-hyp .
	 varnames-and-measure-and-minhyp-and-hyps-and-opt-gindthmname)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (avars (context-to-avars context))
	 (l (length avars))	 
	 (exc-formula-and-x1
	  (cond
	   ((and (integer? exc-hyp) (positive? exc-hyp))
	    (if (<= exc-hyp l)
		(let* ((avar (list-ref avars (- exc-hyp 1)))
		       (formula (avar-to-formula avar)))
		  (list formula (make-proof-in-avar-form avar)))
		(myerror "by-assume-minimal-wrt-intern"
			 "assumption number expected" exc-hyp)))
	   ((and (string? exc-hyp)
		 (member exc-hyp (hypname-info-to-names hypname-info)))
	    (let ((i (name-and-hypname-info-to-index exc-hyp hypname-info)))
	      (if (<= i l)
		  (let* ((avar (list-ref avars (- i 1)))
			 (formula (avar-to-formula avar)))
		    (list formula (make-proof-in-avar-form avar)))
		  (myerror "by-assume-minimal-wrt-intern"
			   "assumption number expected" i))))
	   ((and (string? exc-hyp) (assoc exc-hyp THEOREMS))
	    (let* ((aconst (theorem-name-to-aconst exc-hyp))
		   (formula (aconst-to-formula aconst)))
	      (list formula (make-proof-in-aconst-form aconst))))
	   ((and (string? exc-hyp) (assoc exc-hyp GLOBAL-ASSUMPTIONS))
	    (let* ((aconst (global-assumption-name-to-aconst exc-hyp))
		   (formula (aconst-to-formula aconst)))
	      (list formula (make-proof-in-aconst-form aconst))))
	   ((proof-form? exc-hyp) (list (proof-to-formula exc-hyp) exc-hyp))
	   ((formula-form? exc-hyp) ;then a new goal is created
	    (list exc-hyp DEFAULT-GOAL-NAME))
	   (else (myerror "by-assume-minimal-wrt-intern"
			  "illegal argument" exc-hyp))))
	 (exc-formula (fold-formula (car exc-formula-and-x1)))
	 (x1 (cadr exc-formula-and-x1))
	 (n (cond ((excl-form? exc-formula)
		   (length (excl-form-to-vars exc-formula)))
		  ((exca-form? exc-formula)
		   (length (exca-form-to-vars exc-formula)))
		  (else (myerror "exc-form expected" exc-formula))))
	 (l-test (excl-form? exc-formula))
	 (m (length (tensor-form-to-parts
		     (if l-test
			 (excl-form-to-kernel exc-formula)
			 (exca-form-to-kernel exc-formula)))))
	 (lh (length
	      varnames-and-measure-and-minhyp-and-hyps-and-opt-gindthmname))
	 (varnames
	  (if (<= (+ n 2 m) lh)
	      (list-head
	       varnames-and-measure-and-minhyp-and-hyps-and-opt-gindthmname n)
	      (myerror (+ n 2 m) "arguments expected in addition to exc-hyp")))
	 (vars (map pv varnames))
	 (tail
	  (list-tail
	   varnames-and-measure-and-minhyp-and-hyps-and-opt-gindthmname n))
	 (measure (car tail))
	 (minhyp (cadr tail))
	 (hyps (list-head (cddr tail) m))
	 (opt-gindthmname (list-tail (cddr tail) m)))
    (if (not (apply and-op (map (lambda (x) (and (string? x) (var? (pv x))))
				varnames)))
	(myerror "variable names expected" varnames))
    (if (not (term-form? measure)) (myerror "measure term expected" measure))
    (if (not (equal? (term-to-type measure)
		     (apply mk-arrow (append (map var-to-type vars)
					     (list (py "nat"))))))
	(myerror (apply mk-arrow (append (map var-to-type vars)
					 (list (py "nat"))))
		 "is the expected type of the measure term, not"
		 (term-to-type measure)))
    (if (not (string? minhyp))
	(myerror "name for the minimality hypothesis expected" minhyp))
    (if (not (apply and-op (map string? hyps)))
	(myerror "names for hypotheses expected" hyps))
    (let* ((free (formula-to-free exc-formula))
           (min-pr-proof (apply exc-formula-to-min-pr-proof
				(cons exc-formula opt-gindthmname)))
	   (all-h-formula (allnc-form-to-final-kernel
			   (proof-to-formula min-pr-proof)
			   (length free)))
	   (h (all-form-to-var all-h-formula))
	   (exc-min-formula
	    (formula-subst (imp-form-to-conclusion
			    (all-form-to-kernel all-h-formula))
			   h measure))
	   (pproof-state1
	    (exc-elim-intern num-goals proof maxgoal exc-min-formula)))
      (cond
       ((or ;hypothesis
	 (and (integer? exc-hyp) (positive? exc-hyp))
	 (and (string? exc-hyp)
	      (member exc-hyp (hypname-info-to-names hypname-info))))
	(let* ((pproof-state2
		(apply use-with-intern
		       (append pproof-state1
			       (list min-pr-proof)
			       (map make-term-in-var-form free)
			       (list measure exc-hyp))))
	       (pproof-state3
		(apply assume-intern
		       (append pproof-state2
			       (append varnames (list minhyp) hyps)))))
	  (apply drop-intern (append pproof-state3 (list exc-hyp)))))
       ((or ;theorem/global assumption/proof
	 (and (string? exc-hyp) (assoc exc-hyp THEOREMS))
	 (and (string? exc-hyp) (assoc exc-hyp GLOBAL-ASSUMPTIONS))
	 (proof-form? exc-hyp))
	(let* ((pproof-state2
		(apply use-with-intern
		       (append pproof-state1
			       (list min-pr-proof)
			       (map make-term-in-var-form free)
			       (list measure exc-hyp)))))
	  (apply assume-intern (append pproof-state2
				       (append varnames (list minhyp) hyps)))))
       ((formula-form? exc-hyp) ;then a new goal is created
	(let* ((pproof-state2
		(apply use-with-intern
		       (append pproof-state1
                               (list min-pr-proof)
			       (map make-term-in-var-form free)
			       (list measure DEFAULT-GOAL-NAME))))
	       (pproof-state3
		(apply get-intern
		       (append pproof-state2
			       (list (- (pproof-state-to-maxgoal pproof-state2)
					1)))))
	       (pproof-state4
		(apply assume-intern 
		       (append pproof-state3
			       (append varnames (list minhyp) hyps)))))
	  (apply get-intern
		 (append pproof-state4
			 (list (- (pproof-state-to-maxgoal pproof-state4)
				  1))))))
       (else (myerror "by-assume-minimal-wrt-intern"
		      "unexpected exc-hyp" exc-hyp))))))

; We need procedures to generate aconsts - depending on a number n of
; variables and a number m of formulas - for GInd, ExclElim,
; ExclIntro, MinPr.  This will involve certain fixed variables, terms
; and formulas, which are provided first.  k works as a counter

(define (make-fixed-tvars n) 
  (do ((i (- n 1) (- i 1))
       (res (list (make-tvar n DEFAULT-TVAR-NAME))
	    (cons (make-tvar i DEFAULT-TVAR-NAME) res)))
      ((zero? i) res)))

; make-fixed-pvar is a function generating a predicate variable taking
; n arguments of type alpha1 to alphan.  Its index is 0, and it has
; computational content.

(define (make-fixed-pvar n)
  (let* ((fixed-tvars (make-fixed-tvars n))
	 (fixed-arity (apply make-arity fixed-tvars)))
    (make-pvar fixed-arity 0 0 0 "")))

; make-fixed-pvars is a function generating m predicate variables.
; Each predicate takes n arguments of type alpha1 to alphan.  Their
; indices rum from 1 to m, and all have computational content.

(define (make-fixed-pvars m n)
  (let* ((fixed-tvars (make-fixed-tvars n))
	 (fixed-arity (apply make-arity fixed-tvars)))
    (do ((j (- m 1) (- j 1))
	 (res (list (make-pvar fixed-arity m 0 0 ""))
	      (cons (make-pvar fixed-arity j 0 0 "") res)))
	((zero? j) res))))

; make-fixed-measure-var returns a variable of the type of the measure
; function, i.e., alpha1 => ... => alphan => nat.

(define (make-fixed-measure-var n)
  (let* ((fixed-tvars (make-fixed-tvars n))
	 (measure-function-type
	  (apply mk-arrow (append fixed-tvars (list (py "nat"))))))
    (make-var measure-function-type -1 1 "")))

; make-fixed-vars is a function generating (alpha1)_((k-1)*n+1)
; ... (alphan)_((k-1)*n+n), i.e., the kth set of n fresh variables of
; types alpha1 to alphan.

(define (make-fixed-vars k n)
  (do ((i (- n 1) (- i 1))
       (res (list (make-var (make-tvar n DEFAULT-TVAR-NAME) 
			    (+ (* (- k 1) n) n) 1 ""))
	    (cons (make-var (make-tvar i DEFAULT-TVAR-NAME) 
			    (+ (* (- k 1) n) i) 1 "")
		  res)))
      ((zero? i) res)))

; make-gind-aconst takes a positive integer n and returns an assumption
; constant for general induction w.r.t. a measure function of type
; alpha1 => ... => alphan => nat.

;                                    NatLtLtSuccTrans hy hx k v:hy<hx w:hx<Sk
;                                    ----------------------------------------
;                           IH  y                            hy<k
;                           -------------------------------------
;                                                   Ry
;                                      ---------------------------
;          Efq:bot->Rx u:hx<0          Prog^h  x  all y(hy<hx->Ry)
;          ------------------          ---------------------------
;                    Rx                           Rx
;             ---------------    ----------------------------------------
; Ind h S(hx) all x(hx<0->Rx)    all k(all x(hx<k->Rx)->all x(hx<Sk->Rx))
; -----------------------------------------------------------------------
;                          all x(hx<S(hx)->Rx)                             x T
;                          ---------------------------------------------------
;                                                     Rx
;                                            ---------------------
;                                            all h,x(Prog^h -> Rx)

(define (make-gind-aconst n)
  (let* ((gind-name (string-append "GInd" (number-to-alphabetic-string n)))
	 (info (assoc gind-name THEOREMS)))
    (if
     info
     (theorem-name-to-aconst gind-name)
     (let* ((h (make-fixed-measure-var n))
	    (x (make-fixed-vars 1 n))
	    (y (make-fixed-vars 2 n))
	    (R (make-fixed-pvar n))
	    (Rx (apply make-predicate-formula
		       (cons R (map make-term-in-var-form x))))
	    (Ry (apply make-predicate-formula
		       (cons R (map make-term-in-var-form y))))
	    (hx (apply mk-term-in-app-form
		       (cons (make-term-in-var-form h)
			     (map make-term-in-var-form x))))
	    (hy (apply mk-term-in-app-form
		       (cons (make-term-in-var-form h)
			     (map make-term-in-var-form y))))
	    (k (make-var (py "nat") -1 1 ""))
	    (hx<0 (make-atomic-formula
		   (mk-term-in-app-form (make-term-in-const-form
					 (pconst-name-to-pconst "NatLt"))
					hx (pt "Zero"))))
	    (hx<k (make-atomic-formula
		   (mk-term-in-app-form (make-term-in-const-form
					 (pconst-name-to-pconst "NatLt"))
					hx (make-term-in-var-form k))))
	    (hy<hx (make-atomic-formula
		    (mk-term-in-app-form (make-term-in-const-form
					  (pconst-name-to-pconst "NatLt"))
					 hy hx)))
	    (hx<Sk (make-atomic-formula
		    (mk-term-in-app-form (make-term-in-const-form
					  (pconst-name-to-pconst "NatLt"))
					 hx (make-term-in-app-form
					     (pt "Succ")
					     (make-term-in-var-form k)))))
	    (IH-fla ;all x(hx<k->Rx)
	     (apply mk-all (append x (list (make-imp hx<k Rx)))))
	    (prog-fla ;all x((all y(hy<hx) -> Ry) -> Rx)
	     (apply
	      mk-all
	      (append
	       x (list (make-imp
			(apply mk-all (append y (list (make-imp hy<hx Ry))))
			Rx)))))
	    (ind-fla (make-all k IH-fla))
	    (u (formula-to-new-avar hx<0))
	    (v (formula-to-new-avar hy<hx))
	    (w (formula-to-new-avar hx<Sk))
	    (IH (formula-to-new-avar IH-fla))
	    (prog (formula-to-new-avar prog-fla))
	    (efq (proof-of-efq-at Rx))
	    (proof
	     (apply
	      mk-proof-in-intro-form
	      (append
	       (list h)
	       x
	       (list
		prog
		(apply
		 mk-proof-in-elim-form
		 (append
		  (list
		   (make-proof-in-aconst-form
		    (all-formulas-to-ind-aconst ind-fla))
		   (make-term-in-var-form h)
		   (make-term-in-app-form (pt "Succ") hx)
		   (apply ;base
		    mk-proof-in-intro-form
		    (append
		     x (list u (mk-proof-in-elim-form
				efq (make-proof-in-avar-form u)))))
		   (apply ;step
		    mk-proof-in-intro-form
		    (append
		     (list k IH)
		     x (list
			w (apply
			   mk-proof-in-elim-form
			   (append
			    (list (make-proof-in-avar-form prog))
			    (map make-term-in-var-form x)
			    (list
			     (apply
			      mk-proof-in-intro-form
			      (append
			       y (list
				  v (apply
				     mk-proof-in-elim-form
				     (append
				      (list (make-proof-in-avar-form IH))
				      (map make-term-in-var-form y)
				      (list
				       (mk-proof-in-elim-form
					(make-proof-in-aconst-form
					 (theorem-name-to-aconst
					  "NatLtLtSuccTrans"))
					hy hx
					(make-term-in-var-form k)
					(make-proof-in-avar-form v)
					(make-proof-in-avar-form
					 w)))))))))))))))
		  (map make-term-in-var-form x)
		  (list (make-proof-in-aconst-form truth-aconst)))))))))
       (set! OLD-COMMENT-FLAG COMMENT-FLAG)
       (set! COMMENT-FLAG #f)
       (add-theorem gind-name proof)
       (set! COMMENT-FLAG OLD-COMMENT-FLAG)
       (theorem-name-to-aconst gind-name)))))

; make-min-pr-aconst takes positive integers m,n and returns an
; assumption constant for the minimum principle w.r.t. a measure
; function h of type alpha1 => ... => alphan => nat.  Let x=x1...xn.

; all h(exc x(Q1x ! ... ! Qmx) ->
;       exc x(all y(hy<hx -> Q1y -> ... -> Qmy -> bot) ! Q1x ! ... ! Qmx))

; In unfolded form, with Rx := Q1x -> ... -> Qmx -> bot

; all h((all x Rx -> bot) -> all x(all y(hy<hx -> Ry) -> Rx) -> bot)

; Recall gind: all h,x(all x(all y(hy<hx -> Ry) -> Rx) -> Rx)

;                           gind  h  x  prog:all x(all y(hy<hx -> Ry) -> Rx)
;                           ----------------------------------------------
;                                                Rx
;                                             --------
;      u:all x Rx -> bot                      all x Rx
;      ------------------------------------------------
;                           bot
; -------------------------------------------------------------------
; all h.(all x Rx -> bot) -> all x((all y.hy<hx -> Ry) -> Rx) -> bot

(define (make-min-pr-aconst l-test m n)
  (let* ((min-pr-name (string-append "MinPr" (if l-test "l" "a")
				     (number-to-alphabetic-string m)
				     (number-to-alphabetic-string n)))
	 (info (assoc min-pr-name THEOREMS)))
    (if
     info
     (theorem-name-to-aconst min-pr-name)
     (let* ((gind-aconst (make-gind-aconst n))
	    (gind-uninst-fla (aconst-to-uninst-formula gind-aconst))
	    (h (all-form-to-var gind-uninst-fla))
	    (Rx (imp-all-allnc-form-to-final-conclusion gind-uninst-fla))
	    (pvar (predicate-form-to-predicate Rx))
	    (x (map term-in-var-form-to-var (predicate-form-to-args Rx)))
	    (arity (apply make-arity (map var-to-type x)))
	    (Qs ;pvars indexed 1..m of the same arity as R
	     (do ((j (- m 1) (- j 1))
		  (res (list (make-pvar arity m 0 0 ""))
		       (cons (make-pvar arity j 0 0 "") res)))
		 ((zero? j) res)))
	    (bot (if l-test falsity-log falsity))
	    (parts (map (lambda (Q)
			  (apply make-predicate-formula
				 (cons Q (map make-term-in-var-form x))))
			Qs))
	    (cterm (apply
		    make-cterm
		    (append
		     x (list (apply mk-imp (append parts (list bot)))))))
	    (inst-gind-aconst
	     (make-aconst (aconst-to-name gind-aconst)
			  (aconst-to-kind gind-aconst)
			  (aconst-to-uninst-formula gind-aconst)
			  (list (list pvar cterm))))
	    (gind-fla (aconst-to-formula inst-gind-aconst))
	    (prog-fla
	     (imp-form-to-premise (all-form-to-final-kernel gind-fla)))
	    (all-fla ;all x Rx
	     (apply
	      mk-all
	      (append
	       x (list (imp-form-to-conclusion
			(all-form-to-final-kernel gind-fla))))))
	    (u (formula-to-new-avar (make-imp all-fla bot)))
	    (prog (formula-to-new-avar prog-fla))
	    (proof
	     (mk-proof-in-intro-form
	      h u prog
	      (make-proof-in-imp-elim-form
	       (make-proof-in-avar-form u)
	       (apply
		mk-proof-in-intro-form
		(append
		 x (list (apply
			  mk-proof-in-elim-form
			  (append
			   (list (make-proof-in-aconst-form inst-gind-aconst)
				 (make-term-in-var-form h))
			   (predicate-form-to-args Rx)
			   (list (make-proof-in-avar-form prog)))))))))))
       (set! OLD-COMMENT-FLAG COMMENT-FLAG)
       (set! COMMENT-FLAG #f)
       (add-theorem min-pr-name proof)
       (set! COMMENT-FLAG OLD-COMMENT-FLAG)
       (theorem-name-to-aconst min-pr-name)))))

; exc-intro and exc-elim can be used in interactive proofs.

(define (exc-intro . terms)
  (for-each
   (lambda (x)
     (if
      (string? x)
      (myerror "exc-intro" "use pt (parse-term) to produce a term from string" 
	       x)))
   terms)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE (apply exc-intro-intern
			      (append (list num-goals proof maxgoal) terms)))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (exc-intro-intern num-goals proof maxgoal . terms)
  (let* ((num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (context (goal-to-context goal))
	 (goal-formula (fold-formula (goal-to-formula goal)))
	 (quant (cond ((excl-form? goal-formula) 'excl)
		      ((exca-form? goal-formula) 'exca)
		      (else (myerror "exc-intro" "exc goal expected"))))
	 (vars (quant-form-to-vars goal-formula))
	 (kernel (quant-form-to-kernel goal-formula))
	 (free (formula-to-free goal-formula))
	 (parts (tensor-form-to-parts kernel)))
    (if (not (= (length vars) (length terms)))
	(myerror "exc-intro" "vars and terms of equal length expected"
		 (map var-to-string vars)
		 (map term-to-string terms)))
    (apply
     use-with-intern
     (append (list num-goals proof maxgoal
		   (make-proof-in-aconst-form
		    (exc-formula-to-exc-intro-aconst goal-formula)))
	     (map make-term-in-var-form free)
	     terms
	     (vector->list
	      (make-vector (length parts) DEFAULT-GOAL-NAME))))))

; make-exc-intro-aconst takes positive integers m,n and returns an
; assumption constant for exc-introduction w.r.t. n variables of type
; alpha1 to alphan.  Let x=x1...xn

; all x.Q1x -> ... -> Qmx -> exc x.Q1x ! ... ! Qmx

; In unfolded form

; all x.Q1x -> ... -> Qmx -> (all x.Q1x -> ... -> Qmx -> bot) -> bot

;           v: all x.Q1x -> ... -> Qmx -> bot  x  u1:Q1x ... um:Qmx	     
;           -------------------------------------------------------
;                                             bot

(define (make-exc-intro-aconst l-test m n)
  (let* ((exc-intro-name (string-append "Exc" (if l-test "l" "a") "Intro"
					(number-to-alphabetic-string m)
					(number-to-alphabetic-string n)))
	 (info (assoc exc-intro-name THEOREMS)))
    (if
     info
     (theorem-name-to-aconst exc-intro-name)
     (let* ((x (make-fixed-vars 1 n))
	    (Qs (make-fixed-pvars m n))
	    (bot (if l-test falsity-log falsity))
	    (parts (map (lambda (Q)
			  (apply make-predicate-formula
				 (cons Q (map make-term-in-var-form x))))
			Qs))
	    (all-fla ;all x.Q1x -> ... -> Qmx -> bot
	     (apply
	      mk-all
	      (append x (list (apply mk-imp (append parts (list bot)))))))
	    (us (map formula-to-new-avar parts))
	    (v (formula-to-new-avar all-fla))
	    (proof (apply
		    mk-proof-in-intro-form
		    (append
		     x us (list v)
		     (list (apply mk-proof-in-elim-form
				  (append
				   (list (make-proof-in-avar-form v))
				   (map make-term-in-var-form x)
				   (map make-proof-in-avar-form us))))))))
       (set! OLD-COMMENT-FLAG COMMENT-FLAG)
       (set! COMMENT-FLAG #f)
       (add-theorem exc-intro-name proof)
       (set! COMMENT-FLAG OLD-COMMENT-FLAG)
       (theorem-name-to-aconst exc-intro-name)))))

; make-exc-elim-aconst takes positive integers m,n and returns an
; assumption constant for exc-elimination w.r.t. n variables of type
; alpha1 to alphan.  Let x=x1...xn

; (exc x.Q1x ! ... ! Qmx) -> (all x.Q1x -> ... -> Qmx -> P) -> P

; In unfolded form

; ((all x.Q1x -> ... -> Qmx -> bot) -> bot) -> 
;  (all x.Q1x -> ... -> Qmx -> P) -> P

; We write ~Qx for Q1x -> ... -> Qmx -> bot

;                   v: all x.Q1x -> ... -> Qmx -> P  x  w21:Q1x ... w2m:Qmx
;                   -------------------------------------------------------
;           w1: ~P                                P
;           ---------------------------------------
;                            bot
;                            --- ->+ w2
;                            ~Qx
;                         ---------
;   u:all x ~Qx -> bot    all x ~Qx
;   -------------------------------
;                            bot
;                            --- ->+ w1
;   Stab:~~P->P              ~~P
;   ----------------------------
;                    P

(define (make-exc-elim-aconst l-test m n)
  (let* ((exc-elim-name (string-append "Exc" (if l-test "l" "a") "Elim"
					(number-to-alphabetic-string m)
					(number-to-alphabetic-string n)))
	 (info (assoc exc-elim-name THEOREMS)))
    (if
     info
     (theorem-name-to-aconst exc-elim-name)
     (let* ((x (make-fixed-vars 1 n))
	    (Qs (make-fixed-pvars m n))
	    (parts (map (lambda (Q)
			  (apply make-predicate-formula
				 (cons Q (map make-term-in-var-form x))))
			Qs))
	    (P (make-predicate-formula (make-pvar (make-arity)1 0 0 "")))
	    (stab (if l-test (proof-of-stab-log-at P) (proof-of-stab-at P)))
	    (bot (if l-test falsity-log falsity))
	    (w1 (formula-to-new-avar (make-imp P bot)))
	    (w2s (map formula-to-new-avar parts))
	    (u (formula-to-new-avar
		(make-imp
		 (apply mk-all
			(append x (list (apply mk-imp
					       (append parts (list bot))))))
		 bot)))
	    (v (formula-to-new-avar
		(apply mk-all
		       (append
			x (list (apply mk-imp (append parts (list P))))))))
	    (proof
	     (mk-proof-in-intro-form
	      u v (make-proof-in-imp-elim-form
		   stab
		   (make-proof-in-imp-intro-form
		    w1 (make-proof-in-imp-elim-form
			(make-proof-in-avar-form u)
			(apply
			 mk-proof-in-intro-form
			 (append
			  x w2s
			  (list
			   (make-proof-in-imp-elim-form
			    (make-proof-in-avar-form w1)
			    (apply mk-proof-in-elim-form
				   (append
				    (list (make-proof-in-avar-form v))
				    (map make-term-in-var-form x)
				    (map make-proof-in-avar-form
					 w2s)))))))))))))
       (set! OLD-COMMENT-FLAG COMMENT-FLAG)
       (set! COMMENT-FLAG #f)
       (add-theorem exc-elim-name proof)
       (set! COMMENT-FLAG OLD-COMMENT-FLAG)
       (theorem-name-to-aconst exc-elim-name)))))

(define (exc-formula-to-exc-intro-aconst exc-formula)
  (let* ((l-test (excl-form? exc-formula))
	 (vars (quant-form-to-vars exc-formula))
	 (kernel (quant-form-to-kernel exc-formula))
	 (parts (tensor-form-to-parts kernel))
	 (n (length vars))
	 (m (length parts))
	 (exc-intro-aconst (make-exc-intro-aconst l-test m n))
	 (types (map var-to-type vars))
	 (cterms (map (lambda (part)
			(apply make-cterm (append vars (list part))))
		      parts))
	 (exc-intro-uninst-fla (aconst-to-uninst-formula exc-intro-aconst))
	 (pvars (list-head (formula-to-pvars exc-intro-uninst-fla)
			   (length parts)))
	 (tvars (formula-to-tvars exc-intro-uninst-fla))
	 (tsubst (make-substitution tvars types))
	 (pinst (map (lambda (pvar cterm) (list pvar cterm))
		     pvars cterms)))
    (make-aconst (aconst-to-name exc-intro-aconst)
		 (aconst-to-kind exc-intro-aconst)
		 (aconst-to-uninst-formula exc-intro-aconst)
		 (append tsubst pinst))))

; In the following definition of exc-elim x is
; - a number or string identifying an existential hypothesis form the context,
; - the name of an existential global assumption or theorem
; - a closed proof on an existential formula (closed ones suffice),
; - an existential formula with free variables from the context, 
;   generating a new goal.

(define (exc-elim x)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE (exc-elim-intern num-goals proof maxgoal x))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (exc-elim-intern num-goals proof maxgoal x)
  (let* ((num-goal (car num-goals))
         (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (hypname-info (num-goal-to-hypname-info num-goal))
	 (context (goal-to-context goal))
	 (avars (context-to-avars context))
	 (l (length avars))
	 (goal-formula (goal-to-formula goal))
         (exc-formula-and-x1
	  (cond
	   ((and (integer? x) (positive? x))
	    (if (<= x l)
		(let* ((avar (list-ref avars (- x 1)))
		       (formula (avar-to-formula avar)))
		  (list formula (make-proof-in-avar-form avar)))
		(myerror "exc-elim" "assumption number expected" x)))
	   ((and (string? x)
		 (member x (hypname-info-to-names hypname-info)))
	    (let ((i (name-and-hypname-info-to-index x hypname-info)))
	      (if (<= i l)
		  (let* ((avar (list-ref avars (- i 1)))
			 (formula (avar-to-formula avar)))
		    (list formula (make-proof-in-avar-form avar)))
		  (myerror "exc-elim" "assumption number expected" i))))
	   ((and (string? x) (assoc x THEOREMS))
	    (let* ((aconst (theorem-name-to-aconst x))
		   (formula (aconst-to-formula aconst)))
	      (list formula (make-proof-in-aconst-form aconst))))
	   ((and (string? x) (assoc x GLOBAL-ASSUMPTIONS))
	    (let* ((aconst (global-assumption-name-to-aconst x))
		   (formula (aconst-to-formula aconst)))
	      (list formula (make-proof-in-aconst-form aconst))))
	   ((proof-form? x) (list (proof-to-formula x) x))
	   ((formula-form? x) ;then a new goal is created
	    (list x DEFAULT-GOAL-NAME))
	   (else (myerror "exc-elim" "illegal argument" x))))
         (exc-formula (fold-formula (car exc-formula-and-x1)))
         (x1 (cadr exc-formula-and-x1))
         (quant (cond ((excl-form? exc-formula) 'excl)
		      ((exca-form? exc-formula) 'exca)
		      (else (myerror "exc-elim" "exc formula expected"))))
	 (vars (quant-form-to-vars exc-formula))
	 (kernel (quant-form-to-kernel exc-formula))
	 (free1 (formula-to-free exc-formula))
	 (parts (tensor-form-to-parts kernel))
	 (free2 (formula-to-free goal-formula))
         (free (union free1 free2)))
    (apply use-with-intern
	   (append (list num-goals proof maxgoal
			 (make-proof-in-aconst-form
			  (exc-formula-and-concl-to-exc-elim-aconst
			   exc-formula goal-formula)))
		   (map make-term-in-var-form free)
		   (list x1 DEFAULT-GOAL-NAME)))))

; We define a procedure that takes a classical existential formula and a
; conclusion, and returns the corresponding existence elimination theorem
; all ys(exc xs As ->(all xs.As -> B) -> B).

(define (exc-formula-and-concl-to-exc-elim-aconst exc-formula concl)
  (let* ((l-test (excl-form? exc-formula))
	 (vars (quant-form-to-vars exc-formula))
	 (kernel (quant-form-to-kernel exc-formula))
	 (parts (tensor-form-to-parts kernel))
	 (n (length vars))
	 (m (length parts))
	 (exc-elim-aconst (make-exc-elim-aconst l-test m n))
	 (types (map var-to-type vars))
	 (cterms (map (lambda (part)
			(apply make-cterm (append vars (list part))))
		      parts))
	 (cterm (make-cterm concl))
	 (exc-elim-uninst-fla (aconst-to-uninst-formula exc-elim-aconst))
	 (pvars-with-bot (formula-to-pvars exc-elim-uninst-fla))
	 (pvars (list-head pvars-with-bot (length parts)))
	 (pvar (car (last-pair pvars-with-bot)))
	 (tvars (formula-to-tvars exc-elim-uninst-fla))
	 (tsubst (make-substitution tvars types))
	 (pinst (map (lambda (pv ct) (list pv ct))
		     (cons pvar pvars) (cons cterm cterms))))
    (make-aconst (aconst-to-name exc-elim-aconst)
		 (aconst-to-kind exc-elim-aconst)
		 (aconst-to-uninst-formula exc-elim-aconst)
		 (append tsubst pinst))))

; We want to use (pair-elim) in interactive proofs, which replaces a
; goal  all i Q i  by  all n,m Q(n@m)

(define (pair-elim)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE (pair-intern num-goals proof maxgoal))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (pair-elim-intern num-goals proof maxgoal)
  (let* ((num-goal (car num-goals))
         (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (goal-formula (goal-to-formula goal))
	 (free (formula-to-free goal-formula)))
    (if (not (and (all-form? goal-formula)
		  (star-form? (var-to-type (all-form-to-var goal-formula)))))
	(myerror "all form with a variable of pair type expected"
		 goal-formula))
    (apply use-with-intern
	   (append (list num-goals proof maxgoal
			 (make-proof-in-aconst-form
			  (all-pair-formula-to-pair-elim-aconst goal-formula)))
		   (map make-term-in-var-form free)
		   (list DEFAULT-GOAL-NAME)))))

; (admit) accepts the present goal, by turning it into a global
; assumption.

(define (admit)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals))))
    (set! PPROOF-STATE (admit-intern num-goals proof maxgoal))
    (pproof-state-history-push PPROOF-STATE)
    (display-new-goals num-goals number)))

(define (admit-intern num-goals proof maxgoal)
  (let* ((num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (context (goal-to-context goal))
	 (cvars (goal-to-cvars goal))
	 (goal-formula (goal-to-formula goal))
	 (new-goal-formula (context-and-cvars-and-formula-to-formula
			    context cvars goal-formula))
	 (name (new-global-assumption-name "AdmitGA")))
    (add-global-assumption name new-goal-formula)
    (apply use-with-intern (append (list num-goals proof maxgoal name)
				   (context-to-proofargs context)))))



; search
; ======

; Following Miller (J. Logic Computat. Vol 1, 1991) and Berger, work with
; lists of sequents instead of single sequents; they all are Q-sequents
; for the same prefix Q.  One then searches for a Q-substitution phi and
; proofs of the phi-substituted sequents.  Intro-search takes the first
; sequent and extends Q by all x1... .  It then calls select, which
; selects (using or) a fitting clause.  If one is found, a new prefix Q'
; (from raised-new-flex-vars) is formed, and the n (>= 0) new goals with
; their clauses (and also all remaining sequents) are substituted with
; raise o rho, where rho is the mgu.  For this constellation
; intro-search is called again.  In case of success, one obtains a
; Q'-substitution phi' and proofs on the phi' o raise o rho -substituted
; new sequents.  Let phi := (raise o rho o phi') restricted Q_exists, and
; take the first n proofs of these to build a proof of the phi-substituted
; (first) sequent originally considered by intro-search.

; Change to Miller and Berger: work with all ex all -prefixes instead of
; using arbitrary prefixes.

; Terminology:
; elab-path   list of symbols 'left or 'right
; elab-list   list of formulas, variables and symbols 'left or 'right
; elim-list   list of formulas, terms and symbols 'left or 'right
; elim-items  list of proofs, terms and symbols 'left or 'right
; elims       either elim-list or elim-items

; elab-paths are needed for search in case conjunctions are present.

(define (formula-to-elab-paths formula)
  (case (tag formula)
    ((atom predicate ex exnc) '(()))
    ((imp) (formula-to-elab-paths (imp-form-to-conclusion formula)))
    ((impnc) (formula-to-elab-paths (impnc-form-to-conclusion formula)))
    ((and) (append (map (lambda (l) (cons 'left l))
			(formula-to-elab-paths (and-form-to-left formula)))
		   (map (lambda (l) (cons 'right l))
			(formula-to-elab-paths (and-form-to-right formula)))))
    ((all) (formula-to-elab-paths (all-form-to-kernel formula)))
    ((allnc) (formula-to-elab-paths (allnc-form-to-kernel formula)))
    (else (myerror "formula-to-elab-paths" "formula expected" formula))))

(define (elab-list-to-free elab-list)
  (if (null? elab-list)
      '()
      (let ((x (car elab-list)))
	(cond
	 ((formula-form? x)
	  (union (formula-to-free x) (elab-list-to-free (cdr elab-list))))
	 ((var-form? x) (remove x (elab-list-to-free (cdr elab-list))))
	 ((eq? 'left x) (elab-list-to-free (cdr elab-list)))
	 ((eq? 'right x) (elab-list-to-free (cdr elab-list)))
	 (else (myerror "elab-list-to-free" "elab-list item expected" x))))))

; elim-list is used to construct a proof; it is obtained by substituting
; in all variables and formulas, and leaving out the last (goal-)
; formula

(define (elab-list-to-elim-list elab-list subst)
  (do ((l elab-list (cdr l))
       (res
	'()
	(let ((x (car l)))
	  (cond
	   ((formula-form? x)
	    (cons (formula-substitute-and-beta0-nf x subst) res))
	   ((var-form? x)
	    (cons (term-substitute (make-term-in-var-form x) subst) res))
	   ((eq? 'left x) (cons 'left res))
	   ((eq? 'right x) (cons 'right res))
	   (else (myerror
		  "elab-list-to-elim-list" "elab-list item expected" x))))))
      ((null? (cdr l)) (reverse res))))

(define (elim-list-to-formulas elim-list)
  (do ((l elim-list (cdr l))
       (res '() (if (formula-form? (car l)) (cons (car l) res) res)))
      ((null? l) (reverse res))))

(define (formula-and-elims-to-t-deg-ok? formula . elims)
  (or
   (null? elims)
   (let ((first (car elims))
	 (rest (cdr elims)))
     (case (tag formula)
       ((atom predicate ex exnc) #t)
       ((imp)
	(if (or (formula-form? first) (proof-form? first))
	    (apply formula-and-elims-to-t-deg-ok?
		   (cons (imp-form-to-conclusion formula) rest))
	    (myerror 
	     "formula-and-elims-to-t-deg-ok?" "formula or proof expected"
	     first)))
       ((impnc)
	(if (or (formula-form? first) (proof-form? first))
	    (apply formula-and-elims-to-t-deg-ok?
		   (cons (impnc-form-to-conclusion formula) rest))
	    (myerror 
	     "formula-and-elims-to-t-deg-ok?" "formula or proof expected"
	     first)))
       ((and)
	(cond ((eq? 'left first)
	       (apply formula-and-elims-to-t-deg-ok?
		      (cons (and-form-to-left formula) rest)))
	      ((eq? 'right first)
	       (apply formula-and-elims-to-t-deg-ok?
		      (cons (and-form-to-right formula) rest)))
	      (else
	       (myerror
		"formula-and-elims-to-t-deg-ok?" "left or right expected"
		first))))
       ((all)
	(let ((var (all-form-to-var formula))
	      (kernel (all-form-to-kernel formula)))
	  (if (term-form? first)
	      (and
	       (not (and (t-deg-one? (var-to-t-deg var))
			 (not (synt-total? first))))
	       (apply formula-and-elims-to-t-deg-ok? (cons kernel rest)))
	      (myerror "formula-and-elims-to-t-deg-ok?" "term expected"
		       first))))
       ((allnc)
	(let ((var (allnc-form-to-var formula))
	      (kernel (allnc-form-to-kernel formula)))
	  (if (term-form? first)
	      (and
	       (not (and (t-deg-one? (var-to-t-deg var))
			 (not (synt-total? first))))
	       (apply formula-and-elims-to-t-deg-ok? (cons kernel rest)))
	      (myerror "formula-and-elims-to-t-deg-ok?" "term expected"
		       first))))
       (else (myerror "formula-and-elims-to-t-deg-ok?" "formula expected"
		      formula))))))

(define (formula-and-elab-path-to-renamed-elab-list
	 formula elab-path used-vars)
  (case (tag formula)
    ((atom predicate ex exnc) (list formula))
    ((imp)
     (cons (imp-form-to-premise formula)
	   (formula-and-elab-path-to-renamed-elab-list
	    (imp-form-to-conclusion formula)
	    elab-path used-vars)))
    ((impnc)
     (cons (impnc-form-to-premise formula)
	   (formula-and-elab-path-to-renamed-elab-list
	    (impnc-form-to-conclusion formula)
	    elab-path used-vars)))
    ((and)
     (if
      (pair? elab-path)
      (cond
       ((eq? 'left (car elab-path))
	(cons 'left (formula-and-elab-path-to-renamed-elab-list
		     (and-form-to-left formula)
		     (cdr elab-path) used-vars)))
       ((eq? 'right (car elab-path))
	(cons 'right (formula-and-elab-path-to-renamed-elab-list
		      (and-form-to-right formula)
		      (cdr elab-path) used-vars)))
       (else
	(myerror
	 "formula-and-elab-path-to-renamed-elab-list" "elab-path item expected"
	 (car elab-path))))
      (myerror
       "formula-and-elab-path-to-renamed-elab-list" "elab-path empty for"
       formula)))
    ((all)
     (let* ((var (all-form-to-var formula))
	    (kernel (all-form-to-kernel formula))
	    (info (member var used-vars))
	    (new-var (if info (var-to-new-var var) var))
	    (new-kernel 
	     (if info
		 (formula-subst kernel var (make-term-in-var-form new-var))
		 kernel)))
       (cons new-var (formula-and-elab-path-to-renamed-elab-list
		      new-kernel elab-path (cons new-var used-vars)))))
    ((allnc)
     (let* ((var (allnc-form-to-var formula))
	    (kernel (allnc-form-to-kernel formula))
	    (info (member var used-vars))
	    (new-var (if info (var-to-new-var var) var))
	    (new-kernel 
	     (if info
		 (formula-subst kernel var (make-term-in-var-form new-var))
		 kernel)))
       (cons new-var (formula-and-elab-path-to-renamed-elab-list
		      new-kernel elab-path (cons new-var used-vars)))))
    (else (myerror
	   "formula-and-elab-path-to-renamed-elab-list" "formula expected"
	   formula))))

(define (elab-list-to-vars elab-list)
  (do ((l elab-list (cdr l))
       (res '() (if (var-form? (car l)) (cons (car l) res) res)))
      ((null? l) (reverse res))))

(define (elab-list-item-to-string x)
  (cond
   ((var-form? x) (var-to-string x))
   ((formula-form? x) (formula-to-string x))
   ((eq? 'left x) "left")
   ((eq? 'right x) "right")
   (else (myerror "elab-list-to-string" "elab-list item expected" x))))

(define (elab-list-to-string elab-list)
  (do ((l (cdr elab-list) (cdr l))
       (res (elab-list-item-to-string (car elab-list))
	    (string-append res ", " (elab-list-item-to-string (car l)))))
      ((null? l) (string-append "(" res ")"))))
	    
(define (elim-list-item-to-string x)
  (cond
   ((term-form? x) (term-to-string x))
   ((formula-form? x) (formula-to-string x))
   ((eq? 'left x) "left")
   ((eq? 'right x) "right")
   (else
    (myerror "elim-list-to-string" "elim-list item expected" x))))

(define (elim-list-to-string elim-list)
  (do ((l (cdr elim-list) (cdr l))
       (res (elim-list-item-to-string (car elim-list))
	    (string-append res ", " (elim-list-item-to-string
				     (car l)))))
      ((null? l) (string-append "(" res ")"))))
	    
; A clause has the form (leaf elab-path m), where elab-path is a list
; of symbols left or right, giving the direction in case the formula
; of leaf is a conjunction.  m is the multiplicity for using this clause.

(define (make-clause leaf elab-path m)
  (list leaf elab-path m))

(define clause-to-leaf car)
(define clause-to-elab-path cadr)
(define clause-to-mult caddr)

(define (display-clause clause n i)
  (display-comment (make-string n #\.)) (display "Clause ")
  (display i) (display ": ") (df (proof-to-formula (clause-to-leaf clause)))
  (display " (") (display (clause-to-mult clause)) (display " times)")
  (newline))

(define (display-clauses clauses n)
  (do ((l clauses (cdr l))
       (i 1 (+ 1 i)))
      ((null? l))
    (display-clause (car l) n i)))

(define (clause-substitute clause subst)
  (make-clause (proof-substitute (clause-to-leaf clause) subst)
	       (clause-to-elab-path clause)
	       (clause-to-mult clause)))

(define (clauses-substitute clauses subst)
  (map (lambda (clause) (clause-substitute clause subst)) clauses))

(define (clause-substitute-and-beta0-nf clause subst)
  (make-clause (proof-substitute-and-beta0-nf (clause-to-leaf clause) subst)
	       (clause-to-elab-path clause)
	       (clause-to-mult clause)))

(define (clauses-substitute-and-beta0-nf clauses subst)
  (map (lambda (clause) (clause-substitute-and-beta0-nf clause subst))
       clauses))

(define (leaf-with-mult-to-clauses leaf-with-mult)
  (let* ((leaf (car leaf-with-mult))
	 (mult (cadr leaf-with-mult))
	 (formula (unfold-formula (normalize-formula (proof-to-formula leaf))))
; 	 (formula (unfold-formula (proof-to-formula leaf)))
	 (elab-paths (formula-to-elab-paths formula)))
    (map (lambda (elab-path) (make-clause leaf elab-path mult)) elab-paths)))

; A sequent has the form (goal clause1 ...).

(define (make-sequent goal . clauses)
  (cons goal clauses))

(define sequent-to-goal car)
(define sequent-to-clauses cdr)

(define (display-sequent sequent n i)
  (display-comment (make-string n #\.)) (display "Sequent ")
  (display i) (display ": ") (df (sequent-to-goal sequent))
  (display " from ") (newline)
  (display-clauses (sequent-to-clauses sequent) (+ n 11)))

(define (display-sequents sequents n)
  (do ((l sequents (cdr l))
       (i 1 (+ 1 i)))
      ((null? l))
    (display-sequent (car l) n i)))

(define (sequent-substitute sequent subst)
  (apply make-sequent
	 (cons (formula-substitute (sequent-to-goal sequent) subst)
	       (clauses-substitute (sequent-to-clauses sequent) subst))))

(define (sequents-substitute sequents subst)
  (map (lambda (sequent) (sequent-substitute sequent subst)) sequents))

(define (sequent-substitute-and-beta0-nf sequent subst)
  (apply make-sequent
	 (cons (formula-substitute-and-beta0-nf
		(sequent-to-goal sequent) subst)
	       (clauses-substitute-and-beta0-nf
		(sequent-to-clauses sequent) subst))))

(define (sequents-substitute-and-beta0-nf sequents subst)
  (map (lambda (sequent) (sequent-substitute-and-beta0-nf sequent subst))
       sequents))

; (search m '(name1 m1) '(name2 m2) ...) expects for m a default value
; for multiplicity (i.e. how often assumptions are to be used), for
; name1 ...
; - numbers of hypotheses from the present context or
; - names for theorems or global assumptions,
; and for m1 m2 ... a multiplicity (positive integer for global
; assumptions or theorems).  A search is started for a proof of the goal
; formula from the given hypotheses with the given multiplicities and in
; addition from the other hypotheses (but not any other global
; assumptions or theorems) with m or mult-default.  To exclude a
; hypothesis from being tried, list it with multiplicity 0.

; In case existential quantifiers are present, we add appropriate
; existence introduction and elimination axioms as additional clauses.
; Then non-termination may occur; we therefore in this case bound the
; number of applications of elim-search.  We use a flag ex? to indicate
; whether the counter needs to be used.

(define ELIM-SEARCH-BOUND 100)
(define INITIAL-ELIM-SEARCH-BOUND ELIM-SEARCH-BOUND)

(define ELIM-SEARCH-COUNTER 0)

; auto does iterated search automatically.  Its arguments (possibly
; empty) consist of a multiplicity and theorem or global assumption
; names, each with its individual multiplicity (a positive integer).
; From these and the local context clauses are determined, and with
; these intro-search is called.  If it returns #f, the automated
; search terminates and the unsolved goal is displayed.  If it returns
; a true value, a new search is started, with the same multiplicity
; and given leaves.

(define (mult-and-given-leaves-with-mult-to-ex-flag-and-search-result
	 num-goals proof maxgoal . x)
  (set! ELIM-SEARCH-COUNTER ELIM-SEARCH-BOUND)
  (let* ((m (if (null? x) mult-default
		(let ((first (car x)))
		  (if (and (integer? first) (positive? first)) first
		      (myerror "search" "positive integer expected" first)))))
	 (rest (if (null? x)
		   '()
		   (cdr x)))
	 (num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
	 (context (goal-to-context goal))
	 (avars (context-to-avars context))
	 (sig-vars (context-to-vars context)) ;signature variables
	 (given-leaves-with-mult
	  (do ((l rest (cdr l))
	       (res
		'()
		(let ((z (car l)))
		  (if
		   (and (list? z) (= 2 (length z)))
		   (let ((entry (car z))
			 (mult (cadr z)))
		     (if
		      (and (integer? mult) (not (negative? mult)))
		      (cons
		       (list (cond
			      ((and (integer? entry) (positive? entry))
			       (make-proof-in-avar-form
				(list-ref avars (- entry 1))))
			      ((and (string? entry)
				    (assoc entry (append GLOBAL-ASSUMPTIONS
							 THEOREMS)))
			       (if
				(zero? mult)
				(myerror "search"
					 "positive multiplicity expected for"
					 entry)
				(make-proof-in-aconst-form
				 (cadr (assoc entry (append GLOBAL-ASSUMPTIONS
							    THEOREMS))))))
			      (else
			       (myerror
				"search" "hyp-number or aconst-name expected"
				entry)))
			     mult)
		       res)
		      (myerror "search" "non-negative integer expected" mult)))
		   (myerror "search" "list (name mult) expected" z)))))
	      ((null? l) (reverse res))))
	 (leaves-with-mult
	  (do ((l avars (cdr l))
	       (i 1 (+ i 1))
	       (res
		(reverse given-leaves-with-mult)
		(let* ((avar (car l))
		       (info (assoc i rest)))
		  (if info
		      res
		      (cons (list (make-proof-in-avar-form avar) m) res)))))
	      ((null? l) (reverse res))))
	 (goal-formula (goal-to-formula goal))
	 (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)
	     (cond
	      ((ex-form? f) (list (make-proof-in-aconst-form
				   (ex-formula-to-ex-intro-aconst f))
				  m))
	      ((exnc-form? f) (list (make-proof-in-aconst-form
				     (exnc-formula-to-exnc-intro-aconst f))
				    m))
	      ((and (quant-form? f)
		    (memq (quant-form-to-quant f)
			  '(exd exl exr exu exdt exlt exrt exut)))
	       (list (make-proof-in-aconst-form
		      (number-and-idpredconst-to-intro-aconst
		       0 (predicate-form-to-predicate f)))
		     m))
	      (else
	       (myerror
		"mult-and-given-leaves-with-mult-to-ex-flag-and-search-result"
		"existential formula expected" f))))
	   pos-ex-list))
	 (ex-elim-leaves-with-mult
	  (do ((l (reverse neg-ex-list) (cdr l))
	       (res
		'()
		(append
		 (map
		  (lambda (f)
		    (cond
		     ((ex-form? (car l))
		      (list (make-proof-in-aconst-form
			     (ex-formula-and-concl-to-ex-elim-aconst
			      (car l) f))
			    m))
		     ((exnc-form? (car l))
		      (list (make-proof-in-aconst-form
			     (exnc-formula-and-concl-to-exnc-elim-aconst
			      (car l) f))
			    m))
		     ((and (quant-form? (car l))
			   (memq (quant-form-to-quant (car l))
				 '(exd exl exr exu exdt exlt exrt exut)))
		      (list (make-proof-in-aconst-form
			     (imp-formulas-to-elim-aconst
			      (make-imp (car l) f)))
			    m))
		     (else
		      (myerror
		       "mult-and-given-leaves-with-mult-to-ex-flag-and-search-result"
		       "existential formula expected" (car l)))))
		  (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)))))
    (list ex? (intro-search m
			    (normalize-formula goal-formula)
			    clauses
			    '() ;no sequents initially
			    sig-vars
			    '() ;no flex-vars initially
			    '() ;no forb-vars initially
			    ex?
			    0))))

(define (search . mult-and-aconst-names-with-mult)
  (check-mult-and-aconst-names-with-mult mult-and-aconst-names-with-mult)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals)))
	 (search-result (apply search-intern
			       (append (list num-goals proof maxgoal)
				       mult-and-aconst-names-with-mult))))
    (if (not search-result)
	(begin (display-comment "no proof found")
	       (if COMMENT-FLAG (newline)))
	(begin
	  (set! PPROOF-STATE search-result)
	  (pproof-state-history-push PPROOF-STATE)
	  (if
	   COMMENT-FLAG
	   (begin
	     (display-comment "ok, " DEFAULT-GOAL-NAME "_"
			      (number-to-string number)
			      " is proved by minimal quantifier logic.")
	     (if (null? (pproof-state-to-num-goals))
		 (begin (display "  Proof finished.") (newline))
		 (begin (display "  The active goal now is") (newline)
			(display-num-goal
			 (car (pproof-state-to-num-goals)))))))))))

(define (search-intern
	 num-goals proof maxgoal . mult-and-aconst-names-with-mult)
  (let* ((num-goal (car num-goals))
	 (goal (num-goal-to-goal num-goal))
 	 (ex-flag-and-search-result
	  (apply mult-and-given-leaves-with-mult-to-ex-flag-and-search-result
		 (append (list num-goals proof maxgoal)
			 mult-and-aconst-names-with-mult)))
	 (ex? (car ex-flag-and-search-result))
	 (prev (cadr ex-flag-and-search-result)))
    (if (not prev)
	#f
	(let* ((subst (car prev))
	       (proofs (cdr prev))
	       (proof1 (car proofs)))
	  (make-pproof-state (cdr num-goals)
			     (goal-subst proof goal proof1)
			     maxgoal)))))

(define (check-mult-and-aconst-names-with-mult mult-and-aconst-names-with-mult)
  (or
   (null? mult-and-aconst-names-with-mult)
   (let ((first (car mult-and-aconst-names-with-mult))
	 (rest (cdr mult-and-aconst-names-with-mult)))
     (if (not (and (integer? first) (positive? first)))
	 (myerror "positive integer (multiplicity) expected" first))
     (for-each (lambda (z)
		 (if (not (and (list? z) (= 2 (length z))))
		     (myerror "list of length 2 expected" z))
		 (let ((entry (car z))
		       (mult (cadr z)))
		   (if (not (and (string? entry)
				 (assoc entry (append GLOBAL-ASSUMPTIONS
						      THEOREMS))))
		       (myerror "aconst-name expected" entry))
		   (if (not (and (integer? mult) (positive? mult)))
		       (myerror "positive multiplicity expected" mult))))
	       rest))))

(define (auto . mult-and-aconst-names-with-mult)
  (check-mult-and-aconst-names-with-mult mult-and-aconst-names-with-mult)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (auto-result (apply auto-intern
			     (append (list num-goals proof maxgoal)
				     mult-and-aconst-names-with-mult))))
    (set! PPROOF-STATE auto-result)
    (pproof-state-history-push PPROOF-STATE)
    (if
     COMMENT-FLAG
     (if (null? (pproof-state-to-num-goals))
	 (begin (display-comment "Proof finished.") (newline))
	 (begin (display-comment "  The active goal now is") (newline)
		(display-num-goal (car (pproof-state-to-num-goals))))))))

(define (auto-intern num-goals proof maxgoal . mult-and-aconst-names-with-mult)
  (do ((prev-res (list num-goals proof maxgoal) res)
       (res (apply search-intern (append (list num-goals proof maxgoal)
					 mult-and-aconst-names-with-mult))
	    (apply search-intern (append res
					 mult-and-aconst-names-with-mult))))
      ((or (not res) (null? (pproof-state-to-num-goals res)))
       (display-comment)
       (if (not res)
	   prev-res
	   res))))

; Goal: preprocess formulas to remove existential quantifiers as far
; as possible, before employing proof search.  This is done by 
; searchex, involving the procedures formula-to-ex-red-formula
; and formula-to-proof-of-ex-red-formula-imp-formula.

; Experience with toy examples: searchex is no better than search.
; Moreover, the proofs found by search are much shorter and clearer
; than those found by searchex.  This remains true after normalization,
; which does not work well when ex-elim axioms are used.
; But more experience is needed.

(define (searchex . mult-and-aconst-names-with-mult)
  (check-mult-and-aconst-names-with-mult mult-and-aconst-names-with-mult)
  (set! ELIM-SEARCH-COUNTER ELIM-SEARCH-BOUND)
  (let* ((num-goals (pproof-state-to-num-goals))
	 (proof (pproof-state-to-proof))
	 (maxgoal (pproof-state-to-maxgoal))
	 (number (num-goal-to-number (car num-goals)))
	 (search-result (apply searchex-intern
			       (append (list num-goals proof maxgoal)
				       mult-and-aconst-names-with-mult))))
    (if (not search-result)
	(begin (display-comment "no proof found")
	       (if COMMENT-FLAG (newline)))
	(begin
	  (set! PPROOF-STATE search-result)
	  (pproof-state-history-push PPROOF-STATE)
	  (if
	   COMMENT-FLAG
	   (begin
	     (display-comment "ok, " DEFAULT-GOAL-NAME "_"
			      (number-to-string number)
			      " is proved by minimal quantifier logic.")
	     (if (null? (pproof-state-to-num-goals))
		 (begin (display "  Proof finished.") (newline))
		 (begin (display "  The active goal now is") (newline)
			(display-num-goal
			 (car (pproof-state-to-num-goals)))))))))))

(define (searchex-intern
	 num-goals proof maxgoal . mult-and-aconst-names-with-mult)
  (set! ELIM-SEARCH-COUNTER ELIM-SEARCH-BOUND)
  (let* ((m (if (null? mult-and-aconst-names-with-mult) mult-default
		(let ((first (car mult-and-aconst-names-with-mult)))
		  (if (and (integer? first) (positive? first)) first
		      (myerror
		       "searchex" "positive integer expected" first)))))
	 (rest (if (null? mult-and-aconst-names-with-mult) '()
		   (cdr mult-and-aconst-names-with-mult)))
	 (num-goal (car num-goals))
	 (number (num-goal-to-number num-goal))
	 (goal (num-goal-to-goal num-goal))
	 (context (goal-to-context goal))
	 (avars (context-to-avars context))
	 (sig-vars (context-to-vars context)) ;signature variables
	 (given-leaves-with-mult ;given as arguments to searchex
	  (do ((l rest (cdr l))
	       (res
		'()
		(let ((z (car l)))
		  (if
		   (and (list? z) (= 2 (length z)))
		   (let ((entry (car z))
			 (mult (cadr z)))
		     (if
		      (and (integer? mult) (not (negative? mult)))
		      (cons
		       (list (cond
			      ((and (integer? entry) (positive? entry))
			       (make-proof-in-avar-form
				(list-ref avars (- entry 1))))
			      ((and (string? entry)
				    (assoc entry (append GLOBAL-ASSUMPTIONS
							 THEOREMS)))
			       (if
				(zero? mult)
				(myerror "search"
					 "positive multiplicity expected for"
					 entry)
				(make-proof-in-aconst-form
				 (cadr (assoc entry (append GLOBAL-ASSUMPTIONS
							    THEOREMS))))))
			      (else
			       (myerror
				"searchex" "hyp-number or aconst-name expected"
				entry)))
			     mult)
		       res)
		      (myerror
		       "searchex" "non-negative integer expected" mult)))
		   (myerror "searchex" "list (name mult) expected" z)))))
	      ((null? l) (reverse res))))
	 (leaves-with-mult ;add avars not explicitely given
	  (do ((l avars (cdr l))
	       (i 1 (+ i 1))
	       (res
		(reverse given-leaves-with-mult)
		(let* ((avar (car l))
		       (info (assoc i rest)))
		  (if info
		      res
		      (cons (list (make-proof-in-avar-form avar) m) res)))))
	      ((null? l) (reverse res))))
	 (goal-formula (goal-to-formula goal))
	 (clause-formulas (map proof-to-formula (map car leaves-with-mult)))
	 (ex-red-goal-formula (formula-to-ex-red-formula goal-formula))
	 (ex-red-clause-formulas
	  (map formula-to-ex-red-formula clause-formulas))
	 (vars-and-kernel-list
	  (map ex-form-to-vars-and-final-kernel ex-red-clause-formulas))
	 (varss (map car vars-and-kernel-list))
	 (kernels (map cadr vars-and-kernel-list))
	 (test (and (pair? ex-red-clause-formulas)
		    (or (pair? (apply intersection varss))
			(pair? (intersection
				(apply append varss)
				(formula-to-free goal-formula))))))
	 (new-varss 
	  (if test
	      (map (lambda (vars) (map var-to-new-var vars)) varss)
	      varss))
	 (new-kernels
	  (if test
	      (do ((l1 varss (cdr l1))
		   (l2 kernels (cdr l2))
		   (l3 new-varss (cdr l3))
		   (res '() (let* ((vars (car l1))
				   (kernel (car l2))
				   (new-vars (car l3))
				   (subst (map (lambda (x y) (list x y))
					       vars
					       (map make-term-in-var-form
						    new-vars))))
			      (cons (formula-substitute kernel subst) res))))
		  ((null? l1) (reverse res)))
	      kernels))
	 (ex-red-leaves-with-mult
	  (map (lambda (kernel lwm)
		 (list (make-proof-in-avar-form
			(formula-to-new-avar kernel DEFAULT-AVAR-NAME))
		       (cadr lwm)))
	       new-kernels leaves-with-mult))
	 (pos-ex-list
	  (remove-duplicates-wrt
	   classical-formula=?
	   (apply append
		  (cons (formula-to-positive-existential-subformulas
			 ex-red-goal-formula)
			(map formula-to-negative-existential-subformulas
			     new-kernels)))))
	 (neg-ex-list
	  (remove-duplicates-wrt
	   classical-formula=?
	   (apply append
		  (cons (formula-to-negative-existential-subformulas
			 ex-red-goal-formula)
			(map formula-to-positive-existential-subformulas
			     new-kernels)))))
	 (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 ex-red-leaves-with-mult
			      ex-intro-leaves-with-mult
			      ex-elim-leaves-with-mult))))
	 (prev (intro-search
		m
		(normalize-formula ex-red-goal-formula)
		clauses
		'() ;no sequents initially
		sig-vars
		'() ;no flex-vars initially
		'() ;no forb-vars initially
		ex?
		0)))
    (if
     (not prev) #f
     (let* ((found-proof1 (cadr prev))
	    (proof1 ;of G
	     (make-proof-in-imp-elim-form
	      (formula-to-proof-of-ex-red-formula-imp-formula goal-formula)
	      (apply
	       mk-proof-in-elim-form
	       (cons
		(apply
		 ex-formulas-and-concl-to-ex-elim-proof
		 (append
		  ex-red-clause-formulas (list ex-red-goal-formula)))
		(append
		 (map (lambda (fla lwm)
			(make-proof-in-imp-elim-form
			 (formula-to-proof-of-formula-imp-ex-red-formula fla)
			 (car lwm)))
		      clause-formulas leaves-with-mult)
		 (list
		  (apply
		   mk-proof-in-intro-form
		   (append
		    (apply append new-varss)
		    (map (lambda (lwm) (proof-in-avar-form-to-avar (car lwm)))
			 ex-red-leaves-with-mult)
		    (list found-proof1))))))))))
       (make-pproof-state (cdr num-goals)
			  (goal-subst proof goal proof1)
			  maxgoal)))))

(define mult-default 2)

(define VERBOSE-SEARCH #f)
(define INITIAL-VERBOSE-SEARCH VERBOSE-SEARCH)

(define (display-prefix sig-vars flex-vars forb-vars)
  (if (pair? (append sig-vars flex-vars forb-vars))
      (begin (display " under")
	     (if (pair? sig-vars)
		 (begin (display " all ")
			(display (vars-to-comma-string sig-vars))))
	     (if (pair? flex-vars)
		 (begin (display " ex ")
			(display (vars-to-comma-string flex-vars))))
	     (if (pair? forb-vars)
		 (begin (display " all ")
			(display (vars-to-comma-string forb-vars)))))))
		 
; intro-search yields either #f, indicating that not all of (clauses ->
; goal, sequents) can be proved, or else a substitution phi and proofs
; of all of (clauses -> goal, sequents) under phi.

; Note that sig-vars is needed, for renaming of universal quantifiers in goals.

(define (intro-search
	 m goal clauses sequents sig-vars flex-vars forb-vars ex? n)
  (case (tag goal)
    ((atom)
     (if VERBOSE-SEARCH
	 (begin (display-comment (make-string n #\.))
		(display "Goal ") (df goal)
		(display-prefix sig-vars flex-vars forb-vars)
		(newline)))
     (if
      (classical-formula=? truth (normalize-formula goal)) ;04-01-08 norm added
      (if (null? sequents)
	  (cons empty-subst
		(list (make-proof-in-aconst-form truth-aconst)))
	  (let* ((first-sequent (car sequents))
		 (new-goal (sequent-to-goal first-sequent))
		 (new-clauses (sequent-to-clauses first-sequent))
		 (prev (intro-search
			m new-goal new-clauses (cdr sequents)
			sig-vars flex-vars forb-vars ex? (+ n 1))))
	    (if
	     (not prev)
	     (begin (if VERBOSE-SEARCH
			(begin (display-comment (make-string n #\.))
			       (display "Failed") (newline)))
		    #f)
	     (cons (car prev)
		   (cons (make-proof-in-aconst-form truth-aconst)
			 (cdr prev))))))
      (select clauses '() (normalize-formula goal) ;normalize-formula added
	      sequents sig-vars flex-vars forb-vars ex? n)))
    ((predicate ex exnc)
     (if VERBOSE-SEARCH
	 (begin (display-comment (make-string n #\.))
		(display "Goal ") (df goal)
		(display-prefix sig-vars flex-vars forb-vars)
		(newline)))
     (select clauses '() (normalize-formula goal) ;normalize-formula added
	     sequents sig-vars flex-vars forb-vars ex? n))
    ((imp)
     (let* ((formula (imp-form-to-premise goal))
	    (avar (formula-to-new-avar formula DEFAULT-AVAR-NAME))
	    (leaf (make-proof-in-avar-form avar))
	    (elab-paths (formula-to-elab-paths formula))
	    (new-clauses
	     (map (lambda (path) (list leaf path m)) elab-paths))
	    (prev 
	     (intro-search m (imp-form-to-conclusion goal)
			   (append new-clauses clauses) 
			   sequents sig-vars flex-vars forb-vars ex? n)))
       (if
	(not prev)
	#f
	(let* ((subst (car prev))
	       (proofs (cdr prev))
	       (proof (car proofs))
	       (new-proof (make-proof-in-imp-intro-form
			   (proof-in-avar-form-to-avar
			    (proof-substitute-and-beta0-nf
			     (make-proof-in-avar-form avar) subst))
			   proof)))
	  (cons subst (cons new-proof (cdr proofs)))))))
    ((impnc)
     (let* ((formula (impnc-form-to-premise goal))
	    (avar (formula-to-new-avar formula DEFAULT-AVAR-NAME))
	    (leaf (make-proof-in-avar-form avar))
	    (elab-paths (formula-to-elab-paths formula))
	    (new-clauses
	     (map (lambda (path) (list leaf path m)) elab-paths))
	    (prev 
	     (intro-search m (impnc-form-to-conclusion goal)
			   (append new-clauses clauses) 
			   sequents sig-vars flex-vars forb-vars ex? n)))
       (if
	(not prev)
	#f
	(let* ((subst (car prev))
	       (proofs (cdr prev))
	       (proof (car proofs))
	       (new-proof (make-proof-in-impnc-intro-form
			   (proof-in-avar-form-to-avar
			    (proof-substitute-and-beta0-nf
			     (make-proof-in-avar-form avar) subst))
			   proof)))
	  (cons subst (cons new-proof (cdr proofs)))))))
    ((and)
     (let* ((right-sequent
	     (apply make-sequent (cons (and-form-to-right goal) clauses)))
	    (prev (intro-search m (and-form-to-left goal)
				clauses (cons right-sequent sequents)
				sig-vars flex-vars forb-vars ex? n)))
       (if
	(not prev)
	#f
	(let* ((subst (car prev))
	       (proofs (cdr prev))
	       (left-proof (car proofs))
	       (right-proof (cadr proofs))
	       (new-proof (make-proof-in-and-intro-form
			   left-proof right-proof)))
	  (cons subst (cons new-proof (cddr proofs)))))))
    ((all)
     (let* ((var (all-form-to-var goal))
	    (kernel (all-form-to-kernel goal))
	    (info (member var (append sig-vars flex-vars forb-vars)))
	    (new-var (if info (var-to-new-var var) var))
	    (new-kernel
	     (if info
		 (formula-subst kernel var (make-term-in-var-form new-var))
		 kernel))
	    (prev
	     (if (null? flex-vars)
		 (intro-search
		  m new-kernel clauses sequents
		  (append sig-vars (list new-var)) '() forb-vars ex? n)
		 (intro-search
		  m new-kernel clauses sequents
		  sig-vars flex-vars (append forb-vars (list new-var))
		  ex? n))))
       (if
	(not prev)
	#f
	(let* ((subst (car prev))
	       (proofs (cdr prev))
	       (proof (car proofs))
	       (new-proof (make-proof-in-all-intro-form new-var proof)))
	  (cons subst (cons new-proof (cdr proofs)))))))
    ((allnc)
     (let* ((var (allnc-form-to-var goal))
	    (kernel (allnc-form-to-kernel goal))
	    (info (member var (append sig-vars flex-vars forb-vars)))
	    (new-var (if info (var-to-new-var var) var))
	    (new-kernel
	     (if info
		 (formula-subst kernel var (make-term-in-var-form new-var))
		 kernel))
	    (prev
	     (if (null? flex-vars)
		 (intro-search
		  m new-kernel clauses sequents
		  (append sig-vars (list new-var)) '() forb-vars ex? n)
		 (intro-search
		  m new-kernel clauses sequents
		  sig-vars flex-vars (append forb-vars (list new-var))
		  ex? n))))
       (if
	(not prev)
	#f
	(let* ((subst (car prev))
	       (proofs (cdr prev))
	       (proof (car proofs))
	       (new-proof (make-proof-in-allnc-intro-form new-var proof)))
	  (cons subst (cons new-proof (cdr proofs)))))))
    (else (myerror "intro-search" "formula expected" goal))))

(define (select clauses done prime-or-ex-goal sequents
		sig-vars flex-vars forb-vars ex? n)
  (if
   (null? clauses)
   #f
   (let* ((clause (car clauses))
	  (rest (cdr clauses))
	  (leaf (clause-to-leaf clause))
	  (elab-path (clause-to-elab-path clause))
	  (renamed-elab-list (formula-and-elab-path-to-renamed-elab-list
			      (unfold-formula
			       (normalize-formula (proof-to-formula leaf)))
			      elab-path (append sig-vars flex-vars forb-vars)))
	  (m (clause-to-mult clause))
	  (head (car (last-pair renamed-elab-list))))
     (or ;elim-search, provided mgu rho exists
      (if
       (not (or (and (atom-form? head) (atom-form? prime-or-ex-goal))
		(and (ex-form? head) (ex-form? prime-or-ex-goal))
		(and (exnc-form? head) (exnc-form? prime-or-ex-goal))
		(and (predicate-form? head) (predicate-form? prime-or-ex-goal)
		     (predicate-equal?
		      (predicate-form-to-predicate head)
		      (predicate-form-to-predicate prime-or-ex-goal)))))
       #f
       (let* ((new-flex-vars (elab-list-to-vars renamed-elab-list))
	      (raised-new-flex-vars
	       (map (lambda (x)
		      (if (pair? forb-vars) ;then the type must be raised
			  (let* ((type (var-to-type x))
				 (t-deg (var-to-t-deg x))
				 (types (map var-to-type forb-vars))
				 (t-degs (map var-to-t-deg forb-vars))
				 (new-type
				  (apply mk-arrow
					 (append types (list type)))))
			    (if (zero? t-deg)
				(type-to-new-partial-var new-type)
				(if (< 0 (apply min t-degs))
				    (type-to-new-var new-type)
				    (myerror
				     "select" "partial variable expected"
				     x))))
			  x))
		    new-flex-vars))
	      (new-app-terms
	       (map (lambda (x) (apply mk-term-in-app-form
				       (cons (make-term-in-var-form x)
					     (map make-term-in-var-form
						  forb-vars))))
		    raised-new-flex-vars))
	      (star (if (pair? forb-vars)
			(map (lambda (x y) (list x y))
			     new-flex-vars new-app-terms)
			empty-subst))
	      (raised-head
	       (if (pair? forb-vars)
		   (formula-substitute-and-beta0-nf head star)
		   head))
	      (unif-results ;minimal commitment such that selected clause fits
	       (if (and (pattern? raised-head
				  (append flex-vars raised-new-flex-vars)
				  forb-vars)
			(pattern? prime-or-ex-goal
				  (append flex-vars raised-new-flex-vars)
				  forb-vars))
		   (let ((pattern-unify-result
			  (pattern-unify
			   sig-vars
			   (append flex-vars raised-new-flex-vars)
			   forb-vars
			   (list raised-head prime-or-ex-goal))))
		     (if pattern-unify-result
			 (list pattern-unify-result)
			 '()))
		   (begin
		     (if VERBOSE-SEARCH
			 (begin
			   (display-comment (make-string n #\.))
			   (display "Non-pattern encountered: ")
			   (if
			    (pattern? raised-head
				      (append flex-vars raised-new-flex-vars)
				      forb-vars)
			    (display (formula-to-string prime-or-ex-goal))
			    (display (formula-to-string raised-head)))
			   (newline)
			   (display-comment (make-string n #\.))
			   (display "under flex-vars ")
			   (display (vars-to-comma-string
				     (append flex-vars raised-new-flex-vars)))
			   (display " and forb-vars ")
			   (display (vars-to-comma-string forb-vars))
			   (newline)))
		     (huet-unifiers sig-vars
				    (append flex-vars raised-new-flex-vars)
				    forb-vars
				    (list raised-head prime-or-ex-goal))))))
	 (if VERBOSE-SEARCH
	     (begin (display-comment (make-string n #\.))
		    (display "Select ")
		    (df (proof-to-formula leaf))
		    (display " with elab-list ")
		    (display (elab-list-to-string renamed-elab-list))
		    (newline)))
	 (if VERBOSE-SEARCH
	     (if (pair? new-flex-vars)
		 (begin
		   (display-comment (make-string n #\.))
		   (if (pair? forb-vars)
		       (display "Raised new flex-vars ")
		       (display "New flex-vars "))
		   (display (vars-to-comma-string raised-new-flex-vars))
		   (newline))))
	 (select-unif unif-results done m leaf clause rest star
		      renamed-elab-list flex-vars sequents ex? n)))
      (select rest (append done (list clause)) prime-or-ex-goal
	      sequents sig-vars flex-vars forb-vars ex? n)))))

(define (select-unif unif-results done m leaf clause rest star
		     renamed-elab-list flex-vars sequents ex? n)
  (if
   (null? unif-results)
   (begin (if VERBOSE-SEARCH
	      (begin (display-comment (make-string n #\.))
		     (display "Unification fails") (newline)))
	  #f)
   (let* ((unif-res (car unif-results))
	  (rho (car unif-res))
	  (new-prefix (cdr unif-res))
	  (new-sig-vars (car new-prefix))
	  (new-flex-vars (cadr new-prefix))
	  (new-forb-vars (caddr new-prefix)))
     (if (and VERBOSE-SEARCH (not (equal? empty-subst rho)))
	 (begin (display-comment (make-string n #\.))
		(display "Unifier: ")
		(display (substitution-to-string rho))
		(apply display-prefix new-prefix)
		(newline)))
     (let* ((new-clauses (append
			  done
			  (if (< 1 m)
			      (cons (make-clause leaf
						 (clause-to-elab-path clause)
						 (- m 1))
				    rest)
			      rest)))
	    (star_o_rho (compose-substitutions-and-beta0-nf star rho))
	    (elim-list (elab-list-to-elim-list renamed-elab-list star_o_rho)))
       (if VERBOSE-SEARCH
	   (begin (if (pair? star_o_rho)
		      (begin
			(display-comment (make-string n #\.))
			(display "Star_o_rho: ")
			(display (substitution-to-string star_o_rho))
			(newline)))))
       (if
	(not (apply formula-and-elims-to-t-deg-ok?
		    (cons (unfold-formula
			   (proof-to-formula leaf)) elim-list)))
	(begin (if VERBOSE-SEARCH
		   (begin (display-comment (make-string n #\.))
			  (display "Failed: t-degs do not fit")
			  (newline)))
	       (select-unif
		(cdr unif-results) done m leaf clause rest star
		renamed-elab-list flex-vars sequents ex? n))
	(let ((prev
	       (elim-search
		rho flex-vars m
		(proof-substitute-and-beta0-nf leaf rho) elim-list
		(clauses-substitute-and-beta0-nf new-clauses star_o_rho)
		(sequents-substitute-and-beta0-nf sequents rho)
		star_o_rho new-sig-vars new-flex-vars new-forb-vars ex? n)))
	  (if (not prev)
	      (select-unif
	       (cdr unif-results) done m leaf clause rest star
	       renamed-elab-list flex-vars sequents ex? n)
	      (cons (restrict-substitution-to-args (car prev) flex-vars)
		    (cdr prev)))))))))

(define (elim-search rho flex-vars m leaf elim-list clauses sequents
		     star_o_rho sig-vars new-flex-vars forb-vars ex? n)
  (if
   (zero? ELIM-SEARCH-COUNTER)
   #f
   (let* ((formulas (elim-list-to-formulas elim-list))
	  (new-sequents
	   (append (map (lambda (g) (apply make-sequent (cons g clauses)))
			formulas)
		   sequents)))
     (if ex? (set! ELIM-SEARCH-COUNTER (- ELIM-SEARCH-COUNTER 1)))
     (if
      (null? new-sequents)
      (cons star_o_rho
	    (list (apply mk-proof-in-elim-form (cons leaf elim-list))))
      (let* ((first-new-sequent (car new-sequents))
	     (goal (sequent-to-goal first-new-sequent))
	     (new-clauses (sequent-to-clauses first-new-sequent))
	     (prev (intro-search
		    m goal new-clauses (cdr new-sequents)
		    sig-vars new-flex-vars forb-vars ex? (+ n 1))))
	(if
	 (not prev)
	 (begin (if VERBOSE-SEARCH
		    (begin (display-comment (make-string n #\.))
			   (display "Failed") (newline)))
		#f)
	 (let* ((phiprime (car prev))
		(rho_o_phiprime
		 (compose-substitutions-and-beta0-nf rho phiprime))
		(phi (restrict-substitution-to-args rho_o_phiprime flex-vars))
		(new-leaf (proof-substitute-and-beta0-nf leaf phi))
		(proofs (cdr prev))
		(star_o_rho_o_phiprime
		 (compose-substitutions-and-beta0-nf star_o_rho phiprime))
		(elim-items-and-sequent-proofs
		 (do ((l elim-list (cdr l))
		      (l1 proofs (if (formula-form? (car l)) (cdr l1) l1))
		      (res '() (cond
				((formula? (car l)) (cons (car l1) res))
				((term-form? (car l))
				 (cons (term-substitute-and-beta0-nf
					(car l) star_o_rho_o_phiprime)
				       res))
				((or (eq? 'left (car l)) (eq? 'right (car l)))
				 (cons (car l) res))
				(else (myerror
				       "elim-search" "elim list item expected"
				       (car l))))))
		     ((null? l) (list (reverse res) l1))))
		(elim-items (car elim-items-and-sequent-proofs)))
	   (if (not (apply formula-and-elims-to-t-deg-ok?
			   (cons (unfold-formula
				  (proof-to-formula new-leaf)) elim-items)))
	       (begin (if VERBOSE-SEARCH
			  (begin (display-comment (make-string n #\.))
				 (display "Failed: t-degs do not fit")
				 (newline)))
		      #f)
	       (let* ((new-proof (apply mk-proof-in-elim-form
					(cons new-leaf elim-items)))
		      (sequent-proofs (cadr elim-items-and-sequent-proofs)))
		 (cons star_o_rho_o_phiprime
		       (cons new-proof sequent-proofs)))))))))))
