; $Id: ets.scm,v 1.69 2009-12-10 23:05:17 logik Exp $
; 16. Extracted terms
; ===================

(define (make-arrow-et type1 type2)
  (if (nulltype? type1)
      type2
      (if (nulltype? type2)
          (make-tconst "nulltype")
          (make-arrow type1 type2))))

(define (mk-arrow-et x . rest)
  (if (null? rest)
      x
      (make-arrow-et x (apply mk-arrow-et rest))))

(define (make-star-et type1 type2)
  (if (nulltype? type1)
      type2
      (if (nulltype? type2)
          type1
          (make-star type1 type2)))) 

; When we want to execute the program, we have to replace cL by the
; extracted program of its proof, and cGA by an assumed extracted term
; to be provided by the user.  This can be achieved by adding
; computation rules for cL and cGA.  We can be rather flexible here and
; enable/block rewriting by using animate/deanimate as desired.

; Notice that the type of the extracted term provided for a cGA must be
; the et-type of the assumed formula.  When predicate variables are
; present, one must use the type variables assigned to them in
; PVAR-TO-TVAR-ALIST.

(define (animate thm-or-ga-name . opt-eterm)
  (let* ((pconst-name
	  (theorem-or-global-assumption-name-to-pconst-name thm-or-ga-name))
	 (pconst (pconst-name-to-pconst pconst-name))
	 (info1 (assoc thm-or-ga-name THEOREMS)))
    (if
     info1
     (let* ((proof (theorem-name-to-proof thm-or-ga-name))
	    (eterm (proof-to-extracted-term proof))
	    (neterm (nt eterm)))
       (add-computation-rule (make-term-in-const-form pconst) neterm))
     (let ((info2 (assoc thm-or-ga-name GLOBAL-ASSUMPTIONS)))
       (if
	info2
	(let* ((eterm (if (pair? opt-eterm)
			  (car opt-eterm)
			  (myerror "animate" "eterm expected for"
				   thm-or-ga-name)))
	       (et-type (formula-to-et-type
			 (aconst-to-uninst-formula
			  (global-assumption-name-to-aconst
			   thm-or-ga-name)))))
	  (if (not (equal? (term-to-type eterm) et-type))
	      (myerror "animate" "equal types expected"
		       (term-to-type eterm)
		       et-type))
	  (add-computation-rule (make-term-in-const-form pconst) eterm)))))))

(define (deanimate thm-or-ga-name)
  (let* ((pconst-name
	  (theorem-or-global-assumption-name-to-pconst-name thm-or-ga-name))
	 (pconst (pconst-name-to-pconst pconst-name))
	 (term (make-term-in-const-form pconst)))
    (remove-computation-rules-for term)))

(define (formula-to-et-type formula)
  (case (tag formula)
    ((atom) (make-tconst "nulltype"))
    ((predicate)
     (let ((pred (predicate-form-to-predicate formula)))
       (cond ((pvar-form? pred)
	      (if (pvar-with-positive-content? pred)
		  (PVAR-TO-TVAR pred)
		  (make-tconst "nulltype")))
	     ((predconst-form? pred) (make-tconst "nulltype"))
	     ((idpredconst-form? pred) (idpredconst-to-et-type pred))
	     (else (myerror
		    "formula-to-et-type" "predicate expected" pred)))))
    ((imp)
     (make-arrow-et (formula-to-et-type (imp-form-to-premise formula))
		    (formula-to-et-type (imp-form-to-conclusion formula))))
    ((impnc) (formula-to-et-type (impnc-form-to-conclusion formula)))
    ((and) (make-star-et (formula-to-et-type (and-form-to-left formula))
			 (formula-to-et-type (and-form-to-right formula))))
    ((all) (make-arrow-et (var-to-type (all-form-to-var formula))
			  (formula-to-et-type (all-form-to-kernel formula))))
    ((ex) (make-star-et (var-to-type (ex-form-to-var formula))
			(formula-to-et-type (ex-form-to-kernel formula))))
    ((allnc) (formula-to-et-type (allnc-form-to-kernel formula)))
    ((exnc) (formula-to-et-type (exnc-form-to-kernel formula)))
    ((exca excl excu) (formula-to-et-type (unfold-formula formula)))
    (else (myerror "formula-to-et-type" "formula expected" formula))))

(define (idpredconst-to-et-type idpc)
  (let* ((name (idpredconst-to-name idpc))
	 (opt-alg-name (idpredconst-name-to-opt-alg-name name)))
    (if
     (null? opt-alg-name)
     (make-tconst "nulltype")
     (let* ((alg-name (car opt-alg-name))
	    (types (idpredconst-to-types idpc))
	    (cterms (idpredconst-to-cterms idpc))
	    (tvars (idpredconst-name-to-tvars name))
	    (new-pvars (idpredconst-name-to-pvars name))
	    (param-pvars (idpredconst-name-to-param-pvars name))
	    (clauses (idpredconst-name-to-clauses name))
	    (et-types (map formula-to-et-type clauses))
	    (new-tvars (map PVAR-TO-TVAR new-pvars))
	    (et-tvars (set-minus (apply union (map type-to-free et-types))
				 new-tvars))
	    (relevant-types (do ((l1 tvars (cdr l1))
				 (l2 types (cdr l2))
				 (res '() (let ((tvar (car l1))
						(type (car l2)))
					    (if (member tvar et-tvars)
						(cons type res)
						res))))
				((null? l2) (reverse res))))
	    (relevant-cterm-types
	     (do ((l1 param-pvars (cdr l1))
		  (l2 cterms (cdr l2))
		  (res '() (let* ((pvar (car l1))
				  (cterm (car l2))
				  (formula (cterm-to-formula cterm))
				  (cterm-et-type (formula-to-et-type formula)))
			     (if (and (pvar-with-positive-content? pvar)
				      (member (PVAR-TO-TVAR pvar) et-tvars))
				 (if (nulltype? cterm-et-type)
				     (cons (make-alg "unit") res)
				     (cons cterm-et-type res))
				 res))))
		 ((null? l1) (reverse res)))))
       (apply make-alg
	      (cons alg-name (append relevant-types relevant-cterm-types)))))))

; Often we have to check whether a formula has computational content.
; This can be done without computing its et-type.

(define (formula-of-nulltype? formula)
  (case (tag formula)
    ((atom) #t)
    ((predicate)
     (let ((pred (predicate-form-to-predicate formula)))
       (cond ((pvar-form? pred)
	      (if (pvar-with-positive-content? pred)
		  #f
		  #t))
	     ((predconst-form? pred) #t)
	     ((idpredconst-form? pred)
	      (let* ((name (idpredconst-to-name pred))
		     (opt-alg-name (idpredconst-name-to-opt-alg-name name)))
		(if (null? opt-alg-name)
		    #t
		    #f)))
	     (else (myerror
		    "formula-of-nulltype?" "predicate expected" pred)))))
    ((imp) (formula-of-nulltype? (imp-form-to-conclusion formula)))
    ((impnc) (formula-of-nulltype? (impnc-form-to-conclusion formula)))
    ((and) (and (formula-of-nulltype? (and-form-to-left formula))
		(formula-of-nulltype? (and-form-to-right formula))))
    ((all) (formula-of-nulltype? (all-form-to-kernel formula)))
    ((ex) #f)
    ((allnc) (formula-of-nulltype? (allnc-form-to-kernel formula)))
    ((exnc) (formula-of-nulltype? (exnc-form-to-kernel formula)))
    ((exca excl excu) (formula-of-nulltype? (unfold-formula formula)))
    (else (myerror "formula-of-nulltype?" "formula expected" formula))))

; We initially supply the following global assumptions.
; This can be done only here, because for add-global-assumption we need
; formula-to-et-type.
; Efq-Log: bot -> Pvar
; Stab-Log: ((Pvar -> bot) -> bot) -> Pvar
; Efq: F -> Pvar
; Stab: ((Pvar -> F) -> F) -> Pvar

(add-global-assumption
 "Efq-Log" (make-imp
	    falsity-log
	    (make-predicate-formula (mk-pvar (make-arity)))))

(add-global-assumption
 "Stab-Log"
 (let ((p (make-predicate-formula (mk-pvar (make-arity)))))
   (make-imp (make-imp (make-imp p falsity-log) falsity-log) p)))

(add-global-assumption
 "Efq" (make-imp
	(make-atomic-formula
	 (make-term-in-const-form (constr-name-to-constr "False")))
	(make-predicate-formula (mk-pvar (make-arity)))))

(add-global-assumption
 "Stab"
 (let ((f (make-atomic-formula
	   (make-term-in-const-form (constr-name-to-constr "False"))))
       (p (make-predicate-formula (mk-pvar (make-arity)))))
   (make-imp (make-imp (make-imp p f) f) p)))

; Moreover we initially supply the identity theorem Id: Pvar -> Pvar.
; This can be done only here, because for add-theorem we need
; formula-to-et-type.

(define id-proof
  (let* ((pvar (mk-pvar (make-arity)))
	 (predicate-formula (make-predicate-formula pvar))
	 (avar (make-avar predicate-formula -1 "")))
    (make-proof-in-imp-intro-form
     avar (make-proof-in-avar-form avar))))

(add-theorem "Id" id-proof)

; Usage: When an object (value of a variable or realizer of a premise)
; might be used more than once, make sure (if necessary by a cut) that
; the goal has the form A -> B or all x A.  Now use Id: P -> P.  Its
; realizer then has the form [f,x]f x.  If cId is not animated, one
; obtains cId([x]body)arg, to be written [let x arg body].  When cId
; is animated, normalization substitutes arg for x in body.

; (animate "Id")
; ; ok, computation rule (cId alpha3) -> [(alpha3)_0](alpha3)_0 added
; (deanimate "Id")

; We initially supply the Cases Lemma If: all boole((boole -> Pvar) ->
; ((boole -> F) -> Pvar) -> Pvar).  This can be done only here,
; because for add-theorem we need formula-to-et-type.

(define (formula-to-if-proof formula)
  (let* ((var (type-to-new-var (make-alg "boole")))
	 (varterm (make-term-in-var-form var))
	 (varatom (make-atomic-formula varterm))
	 (imp1 (make-imp varatom formula))
	 (imp2 (make-imp (make-imp varatom falsity) formula))
	 (if-kernel (mk-imp imp1 imp2 formula))
	 (all-formula (make-all var if-kernel)))
    (make-proof-in-all-intro-form
     var
     (apply
      mk-proof-in-elim-form
      (append
       (list (make-proof-in-aconst-form
	      (all-formula-to-cases-aconst all-formula)))
       (map make-term-in-var-form (formula-to-free formula))
       (list
	(make-term-in-var-form var)
	(let ((u1 (formula-to-new-avar
		   (make-imp truth formula) DEFAULT-AVAR-NAME))
	      (u2 (formula-to-new-avar
		   (make-imp (make-imp truth falsity) formula)
		   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
		   (make-imp falsity formula) DEFAULT-AVAR-NAME))
	      (u2 (formula-to-new-avar
		   (make-imp (make-imp falsity falsity) formula)
		   DEFAULT-AVAR-NAME))
	      (u3 (formula-to-new-avar falsity 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)))))))))))

(add-theorem "If" (formula-to-if-proof (pf "Pvar")))

; If: all boole((boole -> Pvar) -> ((boole -> F) -> Pvar) -> Pvar) can
; be used for case distinctions.  After animation of cIf we have added
; the computation rule (cIf alpha4) ->
; [boole0,alpha4_1,alpha4_2][if boole0 alpha4_1 alpha4_2]

; (animate "If")

; We add some initial inductive definitions.  This can be done only
; here, since their clauses are added as theorems and might be c.r. 

(set! COMMENT-FLAG #f)

(add-ids (list (list "EqD" (make-arity (py "alpha") (py "alpha"))))
	 '("allnc alpha^ EqD alpha^ alpha^" "InitEqD"))

(add-ids (list (list "ExD" (make-arity) "algExD"))
	 '("all alpha^((Pvar alpha)alpha^ -> ExD)" "InitExD"))

(add-ids (list (list "ExL" (make-arity) "algExL"))
	 '("all alpha^((Pvar alpha)alpha^ --> ExL)" "InitExL")) 

(add-ids (list (list "ExR" (make-arity) "algExR"))
	 '("allnc alpha^((Pvar alpha)alpha^ -> ExR)" "InitExR")) 

(add-ids (list (list "ExU" (make-arity)))
	 '("allnc alpha^((Pvar alpha)alpha^ --> ExU)" "InitExU"))

(add-ids (list (list "ExDT" (make-arity) "algExDT"))
	 '("all alpha((Pvar alpha)alpha -> ExDT)" "InitExDT"))

(add-ids (list (list "ExLT" (make-arity) "algExLT"))
	 '("all alpha((Pvar alpha)alpha --> ExLT)" "InitExLT")) 

(add-ids (list (list "ExRT" (make-arity) "algExRT"))
	 '("allnc alpha((Pvar alpha)alpha -> ExRT)" "InitExRT")) 

(add-ids (list (list "ExUT" (make-arity)))
	 '("allnc alpha((Pvar alpha)alpha --> ExUT)" "InitExUT")) 

(add-ids (list (list "AndD" (make-arity) "algAndD"))
	 '("Pvar1 -> Pvar2 -> AndD" "InitAndD"))

; AndL is not accepted in the present implementation, since it is
; required there (without loss of generality) that impnc-param-prems
; come before imp-param-prems.  Use B andr A instead of A andl B.

; (add-ids (list (list "AndL" (make-arity) "algAndL"))
; 	 '("Pvar1 -> Pvar2 --> AndL" "InitAndL"))

(add-ids (list (list "AndR" (make-arity) "algAndR"))
	 '("Pvar1 --> Pvar2 -> AndR" "InitAndR"))

(add-ids (list (list "AndU" (make-arity)))
	 '("Pvar1 --> Pvar2 --> AndU" "InitAndU"))


(add-ids (list (list "OrD" (make-arity) "algOrD"))
	 '("Pvar1 -> OrD" "InlOrD")
	 '("Pvar2 -> OrD" "InrOrD"))

(add-ids (list (list "OrL" (make-arity) "algOrL"))
	 '("Pvar1 -> OrL" "InlOrL")
	 '("Pvar2 --> OrL" "InrOrL"))

(add-ids (list (list "OrR" (make-arity) "algOrR"))
	 '("Pvar1 --> OrR" "InlOrR")
	 '("Pvar2 -> OrR" "InrOrR"))

; OrU has computational content, because we know on which side we are.

(add-ids (list (list "OrU" (make-arity) "algOrU"))
	 '("Pvar1 --> OrU" "InlOrU")
	 '("Pvar2 --> OrU" "InrOrU"))

; We need to define eqd-compat-proof in order to put "EqDCompat" into
; THEOREMS when loading init.  This can be done only here, because for
; add-theorem we need formula-to-et-type.

(define eqd-compat-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-eqd varterm1 varterm2))
	 (fla1 (make-predicate-formula pvar varterm1))
	 (fla2 (make-predicate-formula pvar varterm2))
	 (imp-fla (mk-imp eq-fla fla1 fla2))
	 (aconst (imp-formulas-to-elim-aconst imp-fla))
	 (u (formula-to-new-avar eq-fla "u"))
	 (u1 (formula-to-new-avar fla1 "u")))
    (mk-proof-in-nc-intro-form
     var1 var2 u (mk-proof-in-elim-form
		  (make-proof-in-aconst-form aconst)
		  varterm1 varterm2
		  (make-proof-in-avar-form u)
		  (make-proof-in-allnc-intro-form
		   var1 (make-proof-in-imp-intro-form
			 u1 (make-proof-in-avar-form u1)))))))

(add-theorem "EqDCompat" eqd-compat-proof)

; ok, EqDCompat has been added as a new theorem.
; ok, program constant cEqDCompat: alpha5=>alpha5
; of t-degree 0 and arity 0 added

; These messages are to be suppressed (as for "Id" "If")

(define eqd-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-eqd varterm1 varterm2))
	 (fla1 (make-predicate-formula pvar varterm1))
	 (fla2 (make-predicate-formula pvar varterm2))
	 (imp-fla (mk-imp eq-fla fla2 fla1))
	 (aconst (imp-formulas-to-elim-aconst imp-fla))
	 (u (formula-to-new-avar eq-fla "u"))
	 (u2 (formula-to-new-avar fla2 "u")))
    (mk-proof-in-nc-intro-form
     var1 var2 u (mk-proof-in-elim-form
		  (make-proof-in-aconst-form aconst)
		  varterm1 varterm2
		  (make-proof-in-avar-form u)
		  (make-proof-in-allnc-intro-form
		   var2 (make-proof-in-imp-intro-form
			 u2 (make-proof-in-avar-form u2)))))))

(add-theorem "EqDCompatRev" eqd-compat-rev-proof)

(set! COMMENT-FLAG #t)


(define (make-avar-to-var)
					;returns a procedure assigning to
					;assumption variables whose types have
					;computational content new object vars
					;of the corresponding et-type.  
					;Remembers the assignment done so far.
  (let ((avar-assoc-list '()))
    (lambda (avar)
      (let ((info (assoc-wrt avar=? avar avar-assoc-list)))
	(if info
	    (cadr info)
	    (let* ((formula (avar-to-formula avar))
		   (type (formula-to-et-type formula))
		   (new-var (if (nulltype? type)
				(myerror "make-avar-to-var"
					 "computational content expected in"
					 formula)
				(type-to-new-var type))))
	      (begin (set! avar-assoc-list
			   (cons (list avar new-var) avar-assoc-list))
		     new-var)))))))

(define (proof-to-extracted-term proof)
  (let* ((formula (proof-to-formula proof))
	 (type (formula-to-et-type formula)))
    (if (nulltype? type) 'eps
	(let ((avar-to-var (make-avar-to-var)))
	  (proof-to-extracted-term-aux proof avar-to-var)))))

(define (proof-to-extracted-term-aux proof avar-to-var)
  (case (tag proof)
    ((proof-in-avar-form)
     (make-term-in-var-form
      (avar-to-var (proof-in-avar-form-to-avar proof))))
    ((proof-in-aconst-form)
     (let* ((aconst (proof-in-aconst-form-to-aconst proof))
	    (name (aconst-to-name aconst)))
       (case (aconst-to-kind aconst)
	 ((axiom)
	  (cond
	   ((string=? "Ind" name)
	    (make-term-in-const-form
	     (apply all-formulas-to-et-rec-const
		    (aconst-to-repro-formulas aconst))))
	   ((string=? "Cases" name)
	    (cases-aconst-to-if-term aconst))
	   ((string=? "GInd" name)
	    (make-term-in-const-form
	     (gind-aconst-to-et-grecguard-const aconst)))
	   ((string=? "Intro" name)
	    (apply number-and-idpredconst-to-et-constr-term
		   (aconst-to-repro-formulas aconst)))
	   ((string=? "Elim" name)
	    (let* ((aconst-fla (aconst-to-formula aconst))
		   (kernel (all-allnc-form-to-final-kernel aconst-fla))
		   (prems (imp-form-to-premises kernel))
		   (concl (imp-form-to-final-conclusion kernel))
		   (idpc-fla (if (pair? prems) (car prems)
				 (myerror "imp premises expected in" kernel)))
		   (pred (if (predicate-form? idpc-fla)
			     (predicate-form-to-predicate idpc-fla)
			     (myerror "predicate formula expected" idpc-fla)))
		   (idpc-name (if (idpredconst-form? pred)
				  (idpredconst-to-name pred)
				  (myerror "idpredconst expected" pred)))
		   (clauses (idpredconst-name-to-clauses idpc-name)))
	      (if ;uniform one-clause defined idpc
	       (and ;invariant idpc
		(null? (idpredconst-name-to-opt-alg-name idpc-name))
		(or ;either a special one allowing arbitrary conclusions
					;(to be extended to e.g. EvenReal)
		 (member idpc-name '("EqD" "ExU" "AndU"))		 
					;or a uniform one-clause defined idpc
		 (and (= 1 (length clauses))
		      (predicate-form?
		       (impnc-form-to-final-conclusion
			(allnc-form-to-final-kernel (car clauses)))))))
	       (let* ;then the extracted term in an identity
		   ((type (if (not (formula-of-nulltype? concl))
			      (formula-to-et-type concl)
			      (myerror "proof-to-extracted-term-aux"
				       "formula with content expected" concl)))
		    (var (type-to-new-partial-var type)))
		 (make-term-in-abst-form
		  var (make-term-in-var-form var)))
	       (make-term-in-const-form
		(apply imp-formulas-to-et-rec-const
		       (aconst-to-repro-formulas aconst))))))
	   ((string=? "Ex-Intro" name)
	    (ex-formula-to-ex-intro-et
	     (car (aconst-to-repro-formulas aconst))))
	   ((string=? "Ex-Elim" name)
	    (apply ex-formula-and-concl-to-ex-elim-et
		   (aconst-to-repro-formulas aconst)))
	   ((string=? "Exnc-Intro" name)
	    (exnc-formula-to-exnc-intro-et
	     (car (aconst-to-repro-formulas aconst))))
	   ((string=? "Exnc-Elim" name)
	    (apply exnc-formula-and-concl-to-exnc-elim-et
		   (aconst-to-repro-formulas aconst)))
	   ((string=? "Eq-Compat" name)
	    (let* ((formula (unfold-formula (aconst-to-formula aconst)))
		   (type (formula-to-et-type formula))
		   (arg-type (if (arrow-form? type)
				 (arrow-form-to-arg-type type)
				 (myerror "proof-to-extracted-term-aux"
					  "arrow type expected"
					  type)))
		   (var (type-to-new-var arg-type)))
	      (make-term-in-abst-form var (make-term-in-var-form var))))
	   ((or (and (<= (string-length "All-AllPartial")
			 (string-length name))
		     (string=?
		      (substring name 0 (string-length "All-AllPartial"))
		      "All-AllPartial"))
		(and (<= (string-length "ExPartial-Ex")
			 (string-length name))
		     (string=?
		      (substring name 0 (string-length "ExPartial-Ex"))
		      "ExPartial-Ex")))
	    (let* ((formula (unfold-formula (aconst-to-formula aconst)))
		   (type (formula-to-et-type formula))
		   (arg-type (if (arrow-form? type)
				 (arrow-form-to-arg-type type)
				 (myerror "proof-to-extracted-term-aux"
					  "arrow type expected"
					  type)))
		   (var (type-to-new-var arg-type)))
	      (make-term-in-abst-form var (make-term-in-var-form var))))
	   (else (myerror "proof-to-extracted-term-aux" "axiom expected"
			  name))))
	 ((theorem)
	  (let ((info (assoc name INITIAL-THEOREMS)))
	    (if info
		(let* ((formula (unfold-formula (aconst-to-formula aconst)))
		       (type (formula-to-et-type formula))
		       (arg-type (if (arrow-form? type)
				     (arrow-form-to-arg-type type)
				     (myerror "proof-to-extracted-term-aux"
					      "arrow type expected"
					      type)))
		       (var (type-to-new-var arg-type)))
		  (make-term-in-abst-form var (make-term-in-var-form var)))
		(make-term-in-const-form
		 (theorem-or-global-assumption-to-pconst aconst)))))
	 ((global-assumption)
	  (let ((info (assoc name GLOBAL-ASSUMPTIONS)))
	    (if
	     info
	     (cond
	      ((string=? "Stab-Log" name)
	       (let* ((formula (unfold-formula (proof-to-formula proof)))
		      (kernel (allnc-form-to-final-kernel formula))
		      (concl (imp-form-to-conclusion kernel)))
		 (case (tag concl)
		   ((atom predicate ex exnc)
		    (if
		     (not (equal? falsity-log concl))
		     (let* ((pconst
			     (theorem-or-global-assumption-to-pconst aconst))
			    (term (make-term-in-const-form pconst)))
		       (comment "Stab-Log realized by ad hoc term "
				(term-to-string term))
		       term) ;else first unfold
		     (proof-to-extracted-term-aux
		      (proof-of-stab-log-at concl) avar-to-var)))
		   ((imp impnc and all allnc) ;first unfold
		    (proof-to-extracted-term-aux
		     (proof-of-stab-log-at concl) avar-to-var))
		   (else (myerror
			  "proof-to-extracted-term-aux" "formula expected"
			  concl)))))
	      ((string=? "Efq-Log" name)
	       (let* ((formula (unfold-formula (proof-to-formula proof)))
		      (kernel (allnc-form-to-final-kernel formula))
		      (concl (imp-form-to-conclusion kernel)))
		 (case (tag concl)
		   ((atom predicate ex exnc)
		    (if (not (equal? falsity-log concl))
			(let* ((type (formula-to-et-type concl))
			       (inhab (type-to-canonical-inhabitant type)))
			  (comment "Efq-Log realized by canonical inhabitant "
				   (term-to-string inhab))
			  inhab) ;else first unfold
			(proof-to-extracted-term-aux
			 (proof-of-efq-log-at concl) avar-to-var)))
		   ((imp impnc and all allnc) ;first unfold
		    (proof-to-extracted-term-aux
		     (proof-of-efq-log-at concl) avar-to-var))
		   (else (myerror
			  "proof-to-extracted-term-aux" "formula expected"
			  concl)))))
	      ((string=? "Efq" name)
	       (let* ((formula (proof-to-formula proof))
		      (etype (formula-to-et-type formula)))
		 (type-to-canonical-inhabitant etype)))
	      ((or (and (<= (string-length "Eq-Compat-Rev")
			    (string-length name))
			(string=?
			 (substring name 0 (string-length "Eq-Compat-Rev"))
			 "Eq-Compat-Rev"))
		   (and (<= (string-length "Compat-Rev")
			    (string-length name))
			(string=?
			 (substring name 0 (string-length "Compat-Rev"))
			 "Compat-Rev"))
		   (and (<= (string-length "Compat")
			    (string-length name))
			(string=?
			 (substring name 0 (string-length "Compat"))
			 "Compat")))
	       (let* ((formula (unfold-formula (aconst-to-formula aconst)))
		      (type (formula-to-et-type formula))
		      (arg-type (if (arrow-form? type)
				    (arrow-form-to-arg-type type)
				    (myerror "proof-to-extracted-term-aux"
					     "arrow type expected"
					     type)))
		      (var (type-to-new-var arg-type)))
		 (make-term-in-abst-form var (make-term-in-var-form var))))
	      (else
	       (make-term-in-const-form
		(theorem-or-global-assumption-to-pconst aconst))))
	     (myerror "proof-to-extracted-term-aux"
		      "global assumption expected"
		      name))))
	 (else (myerror "proof-to-extracted-term-aux" "unknown kind of aconst"
			(aconst-to-kind aconst))))))
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (avar-type (formula-to-et-type (avar-to-formula avar)))
	    (kernel (proof-in-imp-intro-form-to-kernel proof))
	    (kernel-term (proof-to-extracted-term-aux kernel avar-to-var)))
       (if (nulltype? avar-type)
	   kernel-term
	   (make-term-in-abst-form (avar-to-var avar) kernel-term))))
    ((proof-in-imp-elim-form)
     (let* ((op (proof-in-imp-elim-form-to-op proof))
	    (arg (proof-in-imp-elim-form-to-arg proof))
	    (arg-type (formula-to-et-type (proof-to-formula arg)))
	    (op-term (proof-to-extracted-term-aux op avar-to-var)))
       (if (nulltype? arg-type)
	   op-term
	   (make-term-in-app-form
	    op-term (proof-to-extracted-term-aux arg avar-to-var)))))
    ((proof-in-impnc-intro-form)
     (proof-to-extracted-term-aux
      (proof-in-impnc-intro-form-to-kernel proof) avar-to-var))
    ((proof-in-impnc-elim-form)
     (proof-to-extracted-term-aux
      (proof-in-impnc-elim-form-to-op proof) avar-to-var))
    ((proof-in-and-intro-form)
     (let* ((left (proof-in-and-intro-form-to-left proof))
	    (right (proof-in-and-intro-form-to-right proof))
	    (left-type (formula-to-et-type (proof-to-formula left)))
	    (right-type (formula-to-et-type (proof-to-formula right))))
       (if (nulltype? left-type)
	   (proof-to-extracted-term-aux right avar-to-var)
           (if (nulltype? right-type)
               (proof-to-extracted-term-aux left avar-to-var)
	       (make-term-in-pair-form
                (proof-to-extracted-term-aux left avar-to-var)
                (proof-to-extracted-term-aux right avar-to-var))))))     
    ((proof-in-and-elim-left-form)
     (let* ((kernel (proof-in-and-elim-left-form-to-kernel proof))
	    (formula (proof-to-formula kernel))
	    (left-type (formula-to-et-type (and-form-to-left formula)))
	    (right-type (formula-to-et-type (and-form-to-right formula)))
	    (kernel-term (proof-to-extracted-term-aux kernel avar-to-var)))
       (if (or (nulltype? left-type) (nulltype? right-type))
	   kernel-term
	   (make-term-in-lcomp-form kernel-term))))
    ((proof-in-and-elim-right-form)
     (let* ((kernel (proof-in-and-elim-right-form-to-kernel proof))
	    (formula (proof-to-formula kernel))
	    (left-type (formula-to-et-type (and-form-to-left formula)))
	    (right-type (formula-to-et-type (and-form-to-right formula)))
	    (kernel-term (proof-to-extracted-term-aux kernel avar-to-var)))
       (if (or (nulltype? left-type) (nulltype? right-type))
	   kernel-term
	   (make-term-in-rcomp-form kernel-term))))
    ((proof-in-all-intro-form)
     (let* ((var (proof-in-all-intro-form-to-var proof))
	    (kernel (proof-in-all-intro-form-to-kernel proof)))
       (make-term-in-abst-form
	var (proof-to-extracted-term-aux kernel avar-to-var))))
    ((proof-in-all-elim-form)
     (let* ((op (proof-in-all-elim-form-to-op proof))
	    (arg (proof-in-all-elim-form-to-arg proof)))
       (make-term-in-app-form
	(proof-to-extracted-term-aux op avar-to-var) arg)))
    ((proof-in-allnc-intro-form)
     (let ((kernel (proof-in-allnc-intro-form-to-kernel proof)))
       (proof-to-extracted-term-aux kernel avar-to-var)))
    ((proof-in-allnc-elim-form)
     (let ((op (proof-in-allnc-elim-form-to-op proof)))
       (proof-to-extracted-term-aux op avar-to-var)))
    (else (myerror "proof-to-extracted-term-aux"
		   "proof tag expected" (tag proof)))))

(define (all-formulas-to-et-rec-const . all-formulas)
  (let* ((uninst-imp-formulas-and-tpinst
	  (apply all-formulas-to-uninst-imp-formulas-and-tpinst all-formulas))
	 (uninst-imp-formulas (car uninst-imp-formulas-and-tpinst))
	 (tpinst (cadr uninst-imp-formulas-and-tpinst))
	 (tsubst (list-transform-positive tpinst
		   (lambda (x) (tvar-form? (car x)))))
	 (pinst (list-transform-positive tpinst
		  (lambda (x) (pvar-form? (car x)))))
	 (relevant-pinst (list-transform-positive pinst
			   (lambda (x)
			     (not (formula-of-nulltype?
				   (cterm-to-formula (cadr x)))))))
	 (pvars (map car relevant-pinst))
	 (cterms (map cadr relevant-pinst))
	 (et-types (map (lambda (cterm)
			  (formula-to-et-type (cterm-to-formula cterm)))
			cterms))
	 (new-tvars (map PVAR-TO-TVAR pvars))
	 (new-tsubst (make-substitution new-tvars et-types))
	 (uninst-recop-types (map formula-to-et-type
				  uninst-imp-formulas))
	 (vars (map all-form-to-var all-formulas))
	 (types (map var-to-type vars))
	 (alg-names
	  (map (lambda (type)
		 (if (alg-form? type)
		     (alg-form-to-name type)
		     (myerror "all-formulas-to-et-rec-const" "alg expected"
			      type)))
	       types))
	 (alg-names-with-uninst-recop-types
	  (map (lambda (x y) (list x y)) alg-names uninst-recop-types))
	 (simalg-names (alg-name-to-simalg-names (car alg-names)))
	 (sorted-alg-names (list-transform-positive simalg-names
			     (lambda (x) (member x alg-names))))
	 (typed-constr-names
	  (apply append
		 (map alg-name-to-typed-constr-names sorted-alg-names)))
	 (constr-names (map typed-constr-name-to-name typed-constr-names))
	 (alg-name (car alg-names))
	 (uninst-recop-type
	  (cadr (assoc alg-name alg-names-with-uninst-recop-types)))
	 (inst-recop-type (type-substitute uninst-recop-type
					   (append tsubst new-tsubst)))
	 (arrow-types (map formula-to-et-type all-formulas)))
    (apply alg-name-etc-to-rec-const
	   (append (list alg-name uninst-recop-type (append tsubst new-tsubst)
			 inst-recop-type 0 constr-names
			 alg-names-with-uninst-recop-types)
		   arrow-types))))

(define (cases-aconst-to-if-term aconst)
  (let* ((uninst-imp-formula (aconst-to-uninst-formula aconst))
	 (tpinst (aconst-to-tpinst aconst))
	 (all-formulas (aconst-to-repro-formulas aconst))
	 (tsubst (list-transform-positive tpinst
		   (lambda (x) (tvar-form? (car x)))))
	 (pinst (list-transform-positive tpinst
		  (lambda (x) (pvar-form? (car x)))))
	 (relevant-pinst (list-transform-positive pinst
			   (lambda (x)
			     (not (formula-of-nulltype?
				   (cterm-to-formula (cadr x)))))))
	 (pvars (map car relevant-pinst))
	 (cterms (map cadr relevant-pinst))
	 (et-types (map (lambda (cterm)
			  (formula-to-et-type
			   (cterm-to-formula cterm)))
			cterms))
	 (new-tvars (map PVAR-TO-TVAR pvars))
	 (new-tsubst (make-substitution new-tvars et-types))
	 (uninst-casesop-type (formula-to-et-type uninst-imp-formula))
	 (s ;number of step types
	  (- (length (arrow-form-to-arg-types uninst-casesop-type)) 1))
	 (inst-casesop-type
	  (type-substitute uninst-casesop-type (append tsubst new-tsubst)))
	 (alt-types
          (cdr (arrow-form-to-arg-types inst-casesop-type (+ s 1))))
	 (test-type (arrow-form-to-arg-type inst-casesop-type))
	 (alt-vars (map type-to-new-var alt-types))
	 (test-var (type-to-new-var test-type)))
    (apply mk-term-in-abst-form
	   (cons test-var
                 (append
                  alt-vars
                  (list (make-term-in-if-form
                         (make-term-in-var-form test-var)
                         (map make-term-in-var-form alt-vars))))))))

(define (gind-aconst-to-et-grecguard-const aconst)
  (let* ((uninst-gind-formula (aconst-to-uninst-formula aconst))
         (measure-var-and-vars (all-form-to-vars uninst-gind-formula))
         (vars (cdr measure-var-and-vars))
         (m (length vars))
         (tpinst (aconst-to-tpinst aconst))
         (tsubst (list-transform-positive tpinst
                   (lambda (x) (tvar-form? (car x)))))
         (pvar-and-cterm
          (list-search-positive tpinst
            (lambda (x) (pvar-form? (car x)))))
         (cterm (cadr pvar-and-cterm))
         (et-type (formula-to-et-type (cterm-to-formula cterm)))
         (arg-types (map var-to-type vars))
         (type-info (append arg-types (list et-type))))
    (type-info-etc-to-grecguard-const type-info tsubst)))

; Terminology:
; clause            - with assigned predicate variable instead of the idpc
; uninst-intro-fla  - with idpc substituted, but still with tvars, param-pvars
; intro-fla         - fully substituted

(define (number-and-idpredconst-to-et-constr-term i idpc)
  (let* ((name (idpredconst-to-name idpc))
	 (clauses (idpredconst-name-to-clauses name))
	 (clause
	  (if (and (integer? i) (not (negative? i)) (< i (length clauses)))
	      (list-ref clauses i)
	      (myerror "number-and-idpredconst-to-et-constr-term" i
		       "should be an index of a clause for" name)))
	 (clauses-with-names (idpredconst-name-to-clauses-with-names name))
	 (clause-with-name (list-ref clauses-with-names i))
	 (constr-name (if (< 1 (length clause-with-name))
			  (string-append "c" (cadr clause-with-name))
			  (myerror "number-and-idpredconst-to-et-constr-term"
				   "constr name missing for" clause)))
	 (constr (constr-name-to-constr constr-name))
	 (types (idpredconst-to-types idpc))
	 (cterms (idpredconst-to-cterms idpc))
	 (tvars (idpredconst-name-to-tvars name))
	 (new-pvars (idpredconst-name-to-pvars name))
	 (param-pvars (idpredconst-name-to-param-pvars name))
	 (et-types (map formula-to-et-type clauses))
	 (new-tvars (map PVAR-TO-TVAR new-pvars))
	 (et-tvars (set-minus (apply union (map type-to-free et-types))
			      new-tvars))
	 (relevant-types (do ((l1 tvars (cdr l1))
			      (l2 types (cdr l2))
			      (res '() (let ((tvar (car l1))
					     (type (car l2)))
					 (if (member tvar et-tvars)
					     (cons type res)
					     res))))
			     ((null? l2) (reverse res))))
	 (relevant-cterm-types
	  (do ((l1 param-pvars (cdr l1))
	       (l2 cterms (cdr l2))
	       (res '() (let* ((pvar (car l1))
			       (cterm (car l2))
			       (formula (cterm-to-formula cterm))
			       (cterm-et-type (formula-to-et-type formula)))
			  (if (and (pvar-with-positive-content? pvar)
				   (member (PVAR-TO-TVAR pvar) et-tvars))
			      (if (nulltype? cterm-et-type)
				  (cons (make-alg "unit") res)
				  (cons cterm-et-type res))
			      res))))
	      ((null? l1) (reverse res))))
	 (val-types (append relevant-types relevant-cterm-types))
	 (standard-tvars ;alpha1 ... alphan
 	  (do ((i 1 (+ 1 i))
 	       (res '() (cons (make-tvar i DEFAULT-TVAR-NAME) res)))
 	      ((> i (length val-types)) (reverse res))))
	 (standard-tsubst (make-substitution standard-tvars val-types))
	 (subst-constr (const-substitute constr standard-tsubst #t))
	 (intro-aconst (number-and-idpredconst-to-intro-aconst i idpc))
	 (uninst-intro-fla (aconst-to-uninst-formula intro-aconst))
	 (inst-intro-fla (aconst-to-inst-formula intro-aconst))
	 (et-argvars-and-argterms
	  (do ((fla uninst-intro-fla
		    (case (tag fla)
		      ((all) (all-form-to-kernel fla))
		      ((allnc) (allnc-form-to-kernel fla))
		      ((imp) (imp-form-to-conclusion fla))
		      ((impnc) (impnc-form-to-conclusion fla))
		      (else (myerror "number-and-idpredconst-to-et-constr-term"
				     "unexpected formula" fla))))
	       (inst-fla inst-intro-fla
		    (case (tag inst-fla)
		      ((all) (all-form-to-kernel inst-fla))
		      ((allnc) (allnc-form-to-kernel inst-fla))
		      ((imp) (imp-form-to-conclusion inst-fla))
		      ((impnc) (impnc-form-to-conclusion inst-fla))
		      (else (myerror "number-and-idpredconst-to-et-constr-term"
				     "unexpected formula" inst-fla))))
	       (res
		'()
		(case (tag fla)
		  ((all) (let* ((var (all-form-to-var inst-fla))
				(type (var-to-type var))
				(new-var (type-to-new-var type)))
			   (cons (list new-var (make-term-in-var-form new-var))
				 res)))
		  ((allnc) res)
		  ((imp)
		   (let* ((prem (imp-form-to-premise fla))
			  (inst-prem (imp-form-to-premise inst-fla))
			  (type (formula-to-et-type inst-prem))) 
		     (if
		      (and (predicate-form? prem)
			   (pvar-form? (predicate-form-to-predicate prem)))
		      (let ((pvar (predicate-form-to-predicate prem)))
			(if
			 (and (pvar-with-positive-content? pvar)
			      (member (PVAR-TO-TVAR pvar) et-tvars))
			 (if
			  (nulltype? type)
			  (cons (list #f (make-term-in-const-form
					  (constr-name-to-constr "Dummy")))
				res)
			  (let ((new-var (type-to-new-var type)))
			    (cons (list new-var
					(make-term-in-var-form new-var))
				  res)))
			 res))
		      (let ((new-var (type-to-new-var type)))
			(cons (list new-var (make-term-in-var-form new-var))
			      res)))))
		  ((impnc) res)
		  (else (myerror "number-and-idpredconst-to-et-constr-term"
				  "unexpected formula" fla)))))
	      ((not (member (tag fla) '(all allnc imp impnc)))
	       (let* ((revres (reverse res))
		      (et-argvars-with-f (map car revres))
		      (argterms (map cadr revres))
		      (et-argvars (list-transform-positive et-argvars-with-f
				    var-form?)))
		 (list et-argvars-with-f et-argvars argterms)))))
	 (et-argvars-with-f (car et-argvars-and-argterms))
	 (et-argvars (cadr et-argvars-and-argterms))
	 (argterms (caddr et-argvars-and-argterms)))
    (if
     (member #f et-argvars-with-f) ;else subst-constr
     (apply mk-term-in-abst-form
	    (append et-argvars
		    (list (apply mk-term-in-app-form
				 (cons (make-term-in-const-form subst-constr)
				       argterms)))))
     (make-term-in-const-form subst-constr))))

; imp-formulas is a list of formulas I xs^ -> A[xs^].  uninst-elim-formula
; is Ij xs^ -> K1[Xs,Ps] -> .. -> Kk[Xs,Ps] -> Pj xs^

(define (imp-formulas-to-et-rec-const . imp-formulas)
  (let* ((uninst-elim-formulas-etc
	  (apply imp-formulas-to-uninst-elim-formulas-etc imp-formulas))
	 (uninst-elim-formulas (car uninst-elim-formulas-etc))
	 (tsubst (cadr uninst-elim-formulas-etc))
	 (pinst-for-param-pvars (caddr uninst-elim-formulas-etc))
	 (pinst-for-pvars (cadddr uninst-elim-formulas-etc))
	 (prems (map (lambda (x)
		       (if (imp-form? x) (imp-form-to-premise x)
			   (myerror
			    "imp-formulas-to-et-rec-const" "imp form expected"
			    x)))
		     imp-formulas))
	 (idpcs
	  (map (lambda (prem)
		 (if (and
		      (predicate-form? prem)
		      (idpredconst-form? (predicate-form-to-predicate prem)))
		     (predicate-form-to-predicate prem)
		     (myerror "imp-formulas-to-et-rec-const" "expected"
			      prem)))
	       prems))
	 (idpc-names (map idpredconst-to-name idpcs))
	 (pvar-cterm-et-types
	  (map (lambda (cterm)
		 (formula-to-et-type (cterm-to-formula cterm)))
	       (map cadr pinst-for-pvars)))
	 (relevant-lists
	  (do ((l1 pvar-cterm-et-types (cdr l1))
	       (l2 pinst-for-pvars (cdr l2))
	       (l3 uninst-elim-formulas (cdr l3))
	       (res '(() () ())
		    (if (nulltype? (car l1))
			res
			(let ((res1 (car res))
			      (res2 (cadr res))
			      (res3 (caddr res)))
			  (list (cons (car l1) res1)
				(cons (car l2) res2)
				(cons (car l3) res3))))))
	      ((or (null? l1) (null? l2) (null? l3))
	       (let ((res1 (car res)) (res2 (cadr res)) (res3 (caddr res)))
		 (list (reverse res1) (reverse res2) (reverse res3))))))
	 (relevant-pvar-cterm-et-types (car relevant-lists))
	 (relevant-pinst-for-pvars (cadr relevant-lists))
	 (relevant-uninst-elim-formulas (caddr relevant-lists))
	 (relevant-idpc-names
	  (map idpredconst-to-name
	       (map predicate-form-to-predicate
		    (map imp-form-to-premise
			 (map allnc-form-to-final-kernel
			      relevant-uninst-elim-formulas)))))
	 (param-pvar-cterms (map cadr pinst-for-param-pvars))
	 (param-pvar-formulas (map cterm-to-formula param-pvar-cterms))
	 (param-pvar-et-types
	  (map formula-to-et-type param-pvar-formulas))
	 (param-pvar-tsubst
	  (map (lambda (x param-pvar-et-type) ;x pair in pinst-for-param-pvars
		 (let* ((param-pvar (car x))
			(tvar (PVAR-TO-TVAR param-pvar)))
		   (list tvar param-pvar-et-type)))
	       pinst-for-param-pvars param-pvar-et-types))
	 (k (length (apply append (map idpredconst-name-to-clauses
				       idpc-names))))
	 (clauses (cdr (imp-form-to-premises
			(all-allnc-form-to-final-kernel
			 (car uninst-elim-formulas))
			(+ k 1))))
	 (uninst-imp-formulas ;all formulas Ij xs^ -> Xj xs^
	  (map (lambda (x)
		 (make-imp (imp-form-to-premise
			    (allnc-form-to-final-kernel x))
			   (imp-form-to-final-conclusion
			    (allnc-form-to-final-kernel x) (+ k 1))))
	       uninst-elim-formulas))
	 (relevant-pvars (map car relevant-pinst-for-pvars))
	 (relevant-clauses
	  (list-transform-positive clauses
	    (lambda (x)
	      (member (predicate-form-to-predicate
		       (imp-impnc-all-allnc-form-to-final-conclusion x))
		      relevant-pvars))))
	 (simplified-relevant-clauses
	  (map
	   (lambda (clause)
	     (let* ((ncvars-and-final-nckernel
		     (allnc-form-to-vars-and-final-kernel clause))
		    (ncvars (car ncvars-and-final-nckernel))
		    (nckernel (cadr ncvars-and-final-nckernel))
		    (vars-and-final-kernel
		     (all-form-to-vars-and-final-kernel nckernel))
		    (vars (car vars-and-final-kernel))
		    (kernel (cadr vars-and-final-kernel))
		    (ncprems (impnc-form-to-premises kernel))
		    (ncconcl (impnc-form-to-final-conclusion kernel))
		    (prems (imp-form-to-premises ncconcl))
		    (concl (imp-form-to-final-conclusion ncconcl))
		    (shortened-prems
		     (list-transform-positive prems
		       (lambda (prem)
			 (let ((pred
				(predicate-form-to-predicate
				 (imp-impnc-all-allnc-form-to-final-conclusion
				  prem))))
			   (or
			    (and (idpredconst? pred)
				 (let ((name (idpredconst-to-name pred)))
				   (or (member name relevant-idpc-names)
				       (pair? (idpredconst-name-to-opt-alg-name
					       name)))))
			    (and (pvar? pred)
				 (pvar-with-positive-content? pred))))))))
	       (apply mk-allnc
		      (append
		       ncvars 
		       (list
			(apply mk-all
			       (append
				vars
				(list
				 (apply mk-impnc
					(append
					 ncprems
					 (list
					  (apply mk-imp
						 (append
						  shortened-prems
						  (list concl))))))))))))))
	   relevant-clauses))
	 (var-lists (map (lambda (imp-formula)
			   (map term-in-var-form-to-var
				(predicate-form-to-args
				 (imp-form-to-premise imp-formula))))
			 uninst-imp-formulas))
	 (adapted-relevant-uninst-elim-formulas
	  (map (lambda (var-list imp-formula)
		 (apply
		  mk-allnc
		  (append
		   var-list
		   (list (apply mk-imp
				(cons (imp-form-to-premise imp-formula)
				      (append simplified-relevant-clauses
					      (list (imp-form-to-conclusion
						     imp-formula)))))))))
	       var-lists uninst-imp-formulas))
	 (uninst-recop-types
	  (map formula-to-et-type 
	       adapted-relevant-uninst-elim-formulas))
	 (alg-names (map idpredconst-name-to-alg-name relevant-idpc-names))
	 (pvar-tsubst
	  (map (lambda (x y) ;x pair from relevant-pinst-for-pvars
		 (let*       ;y relevant-pvar-cterm-et-type
		     ((pvar (car x))
		      (tvar (PVAR-TO-TVAR pvar)))
		   (list tvar y)))
	       relevant-pinst-for-pvars relevant-pvar-cterm-et-types))
	 (alg-names-with-uninst-recop-types
	  (map (lambda (x y) (list x y)) alg-names uninst-recop-types))
	 (simalg-names (alg-name-to-simalg-names (car alg-names)))
	 (sorted-alg-names (list-transform-positive simalg-names
			     (lambda (x) (member x alg-names))))
	 (typed-constr-names
	  (apply append
		 (map alg-name-to-typed-constr-names sorted-alg-names)))
	 (constr-names (map typed-constr-name-to-name typed-constr-names))
	 (alg-name (car alg-names))
	 (uninst-recop-type
	  (cadr (assoc alg-name alg-names-with-uninst-recop-types)))
	 (inst-recop-type
	  (type-substitute uninst-recop-type
			   (append tsubst param-pvar-tsubst pvar-tsubst)))
	 (arrow-types (map formula-to-et-type imp-formulas)))
    (apply alg-name-etc-to-rec-const
	   (append (list alg-name uninst-recop-type
			 (append tsubst param-pvar-tsubst pvar-tsubst)
			 inst-recop-type 0 constr-names
			 alg-names-with-uninst-recop-types)
		   arrow-types))))

(define (ex-formula-to-ex-intro-et ex-formula)
  (let* ((var (ex-form-to-var ex-formula))
         (kernel (ex-form-to-kernel ex-formula))
	 (kernel-type (formula-to-et-type kernel)))
    (if (nulltype? kernel-type)
	(make-term-in-abst-form var (make-term-in-var-form var))
	(let ((new-var (type-to-new-var kernel-type)))
	  (apply mk-term-in-abst-form
		 (list var new-var (make-term-in-pair-form
				    (make-term-in-var-form var)
				    (make-term-in-var-form new-var))))))))

(define (ex-formula-and-concl-to-ex-elim-et ex-formula concl)
  (let* ((var (ex-form-to-var ex-formula))
	 (type (var-to-type var))
         (kernel (ex-form-to-kernel ex-formula))
	 (kernel-type (formula-to-et-type kernel))
	 (ex-type (formula-to-et-type ex-formula))
	 (concl-type (formula-to-et-type concl)))
    (if (nulltype? kernel-type)
	(let* ((fct-type (make-arrow type concl-type))
	       (fct-var (type-to-new-var fct-type)))
	  (apply mk-term-in-abst-form
		 (list var fct-var (make-term-in-app-form
				    (make-term-in-var-form fct-var)
				    (make-term-in-var-form var)))))
	(let* ((fct-type (mk-arrow type kernel-type concl-type))
	       (fct-var (type-to-new-var fct-type))
	       (pair-var (type-to-new-var (make-star type kernel-type)))
	       (pair-var-term (make-term-in-var-form pair-var)))
	  (apply mk-term-in-abst-form
		 (list pair-var fct-var
		       (mk-term-in-app-form
			(make-term-in-var-form fct-var)
			(make-term-in-lcomp-form pair-var-term)
			(make-term-in-rcomp-form pair-var-term))))))))

(define (exnc-formula-to-exnc-intro-et exnc-formula)
  (let* ((kernel (exnc-form-to-kernel exnc-formula))
	 (kernel-type (formula-to-et-type kernel))
	 (new-var (type-to-new-var kernel-type)))
    (make-term-in-abst-form new-var (make-term-in-var-form new-var))))

(define (exnc-formula-and-concl-to-exnc-elim-et exnc-formula concl)
  (let* ((kernel (exnc-form-to-kernel exnc-formula))
	 (kernel-type (formula-to-et-type kernel))
	 (concl-type (formula-to-et-type concl))
	 (new-var (type-to-new-var concl-type)))
    (if (nulltype? kernel-type)
	(make-term-in-abst-form new-var (make-term-in-var-form new-var))
	(let* ((kernel-var (type-to-new-var kernel-type))
	       (fct-type (make-arrow kernel-type concl-type))
	       (fct-var (type-to-new-var fct-type)))
	  (apply mk-term-in-abst-form
		 (list kernel-var fct-var
		       (make-term-in-app-form
			(make-term-in-var-form fct-var)
			(make-term-in-var-form kernel-var))))))))

; We now aim at giving an internal proof of soundness.

(define (make-pvar-to-mr-pvar)
					;returns a procedure associating
					;extended pvars to predicate variables.
					;Remembers the assignment done so far.
  (let ((assoc-list '()))
    (lambda (pvar)
      (let ((info (assoc pvar assoc-list)))
	(if info
	    (cadr info)
	    (let* ((tvar (PVAR-TO-TVAR pvar))
		   (arity (pvar-to-arity pvar))
		   (types (arity-to-types arity))
		   (newarity (apply make-arity (cons tvar types)))
		   (newpvar (arity-to-new-pvar newarity)))
	      (set! assoc-list (cons (list pvar newpvar) assoc-list))
	      newpvar))))))

(define (real-and-formula-to-mr-formula real formula)
  (let* ((pvar-to-mr-pvar (make-pvar-to-mr-pvar))
	 (type (formula-to-et-type formula)))
    (if (or (and (eq? 'eps real) (nulltype? type))
	    (and (term-form? real) (equal? (term-to-type real) type)))
	(real-and-formula-to-mr-formula-aux real formula pvar-to-mr-pvar)
	(myerror "real-and-formula-to-mr-formula" "equal types expected"
		 (if (term-form? real)
		     (type-to-string (term-to-type real))
		     real)
		 type))))

(define (real-and-formula-to-mr-formula-aux real formula pvar-to-mr-pvar)
  (case (tag formula)
    ((atom) formula)
    ((predicate)
     (let ((pred (predicate-form-to-predicate formula))
	   (args (predicate-form-to-args formula)))
       (cond
	((pvar-form? pred)
	 (if (pvar-with-positive-content? pred)
	     (let* ((tvar (PVAR-TO-TVAR pred))
		    (newpvar (pvar-to-mr-pvar pred)))
	       (if (not (equal? tvar (term-to-type real)))
		   (myerror
		    "real-and-formula-to-mr-formula-aux" "equal types expected"
		    tvar (term-to-type real)))
	       (apply make-predicate-formula (cons newpvar (cons real args))))
	     formula))
	((predconst-form? pred) formula)
	((idpredconst-form? pred)
	 (let* ((idpc-name (idpredconst-to-name pred))
		(clauses (idpredconst-name-to-clauses idpc-name)))
	   (if ;uniform one-clause defined idpc
	    (and ;invariant idpc
	     (null? (idpredconst-name-to-opt-alg-name idpc-name))
	     (or ;either a special one allowing arbitrary conclusions
					;(to be extended to e.g. EvenReal)
	      (member idpc-name '("EqD" "ExU" "AndU"))		 
					;or a uniform one-clause defined idpc
	      (and (= 1 (length clauses))
		   (predicate-form?
		    (impnc-form-to-final-conclusion
		     (allnc-form-to-final-kernel (car clauses)))))))
	    (let* ;same mr formula with exnc y A for param formulas A
		((types (idpredconst-to-types pred))
		 (cterms (idpredconst-to-cterms pred))
		 (formulas (map cterm-to-formula cterms))
		 (et-types (map formula-to-et-type formulas))
		 (varterms-and-eps
		  (map (lambda (x)
			 (if (type-form? x)
			     (make-term-in-var-form (type-to-new-var x))
			     'eps))
		       et-types))
		 (mr-formulas
		  (map (lambda (x formula)
			 (real-and-formula-to-mr-formula-aux
			  x formula pvar-to-mr-pvar))
		       varterms-and-eps formulas))
		 (mr-cterms
		  (map (lambda (cterm mr-formula)
			 (apply make-cterm (append (cterm-to-vars cterm)
						   (list mr-formula))))
		       cterms mr-formulas))
		 (mr-idpc (make-idpredconst idpc-name types mr-cterms)))
	      (apply make-predicate-formula (cons mr-idpc args)))
					;else c.r. idpc
	    (apply make-predicate-formula
		   (cons (idpredconst-to-mr-idpredconst pred)
			 (cons real args))))))
	(else (myerror "real-and-formula-to-mr-formula-aux"
		       "predicate form expected" formula)))))
    ((imp)
     (let* ((prem (imp-form-to-premise formula))
	    (type1 (formula-to-et-type prem))
	    (concl (imp-form-to-conclusion formula))
	    (type2 (formula-to-et-type concl)))
       (cond
	((nulltype? type1)
	 (make-imp (real-and-formula-to-mr-formula-aux
		    'eps prem pvar-to-mr-pvar)
		   (real-and-formula-to-mr-formula-aux
		    real concl pvar-to-mr-pvar)))
	((nulltype? type2)
	 (let*  ((var (type-to-new-var type1))
		 (varterm (make-term-in-var-form var)))
	   (make-all var (make-imp
			  (real-and-formula-to-mr-formula-aux
			   varterm prem pvar-to-mr-pvar)
			  (real-and-formula-to-mr-formula-aux
			   'eps concl pvar-to-mr-pvar)))))
	(else ;neither type1 nor type2 equals nulltype
	 (let*  ((var (type-to-new-var type1))
		 (varterm (make-term-in-var-form var))
		 (appterm (make-term-in-app-form real varterm)))
	   (make-all var (make-imp
			  (real-and-formula-to-mr-formula-aux
			   varterm prem pvar-to-mr-pvar)
			  (real-and-formula-to-mr-formula-aux
			   appterm concl pvar-to-mr-pvar))))))))
    ((impnc)
     (let* ((prem (impnc-form-to-premise formula))
	    (type1 (formula-to-et-type prem))
	    (concl (impnc-form-to-conclusion formula))
	    (type2 (formula-to-et-type concl)))
       (cond
	((nulltype? type1)
	 (make-imp (real-and-formula-to-mr-formula-aux
		    'eps prem pvar-to-mr-pvar)
		   (real-and-formula-to-mr-formula-aux
		    real concl pvar-to-mr-pvar)))
	((nulltype? type2)
	 (let*  ((var (type-to-new-var type1))
		 (varterm (make-term-in-var-form var)))
	   (make-all var (make-imp
			  (real-and-formula-to-mr-formula-aux
			   varterm prem pvar-to-mr-pvar)
			  (real-and-formula-to-mr-formula-aux
			   'eps concl pvar-to-mr-pvar)))))
	(else ;neither type1 nor type2 equals nulltype
	 (let*  ((var (type-to-new-var type1))
		 (varterm (make-term-in-var-form var)))
	   (make-all var (make-imp
			  (real-and-formula-to-mr-formula-aux
			   varterm prem pvar-to-mr-pvar)
			  (real-and-formula-to-mr-formula-aux
			   real concl pvar-to-mr-pvar))))))))
    ((and)
     (let* ((left (and-form-to-left formula))
	    (type1 (formula-to-et-type left))
	    (right (and-form-to-right formula))
	    (type2 (formula-to-et-type right)))
       (cond
	((and (nulltype? type1) (nulltype? type2))
	 (make-and (real-and-formula-to-mr-formula-aux
		    'eps left pvar-to-mr-pvar)
		   (real-and-formula-to-mr-formula-aux
		    'eps right pvar-to-mr-pvar)))
	((nulltype? type1)
	 (make-and (real-and-formula-to-mr-formula-aux
		    'eps left pvar-to-mr-pvar)
		   (real-and-formula-to-mr-formula-aux
		    real right pvar-to-mr-pvar)))
	((nulltype? type2)
	 (make-and (real-and-formula-to-mr-formula-aux
		    real left pvar-to-mr-pvar)
		   (real-and-formula-to-mr-formula-aux
		    'eps right pvar-to-mr-pvar)))
	(else ;neither type1 nor type2 equals nulltype
	 (let*  ((term1 (make-term-in-lcomp-form real))
		 (term2 (make-term-in-rcomp-form real)))
	   (make-and (real-and-formula-to-mr-formula-aux
		      term1 left pvar-to-mr-pvar)
		     (real-and-formula-to-mr-formula-aux
		      term2 right pvar-to-mr-pvar)))))))
    ((all)
     (let* ((var (all-form-to-var formula))
	    (kernel (all-form-to-kernel formula))
	    (type (formula-to-et-type kernel)))
       (if
	(nulltype? type)
	(make-all var (real-and-formula-to-mr-formula-aux
		       'eps kernel pvar-to-mr-pvar))
	(let* ((varterm (make-term-in-var-form var))
	       (appterm (make-term-in-app-form real varterm)))
	  (make-all var (real-and-formula-to-mr-formula-aux
			 appterm kernel pvar-to-mr-pvar))))))
    ((ex)
     (let* ((var (ex-form-to-var formula))
	    (kernel (ex-form-to-kernel formula))
	    (type (formula-to-et-type kernel)))
       (if
	(nulltype? type)
	(real-and-formula-to-mr-formula-aux
	 'eps (formula-subst kernel var real) pvar-to-mr-pvar)
	(let* ((term1 (make-term-in-lcomp-form real))
	       (term2 (make-term-in-rcomp-form real)))
	  (real-and-formula-to-mr-formula-aux
	   term2 (formula-subst kernel var term1)
	   pvar-to-mr-pvar)))))
    ((allnc)
     (let* ((var (allnc-form-to-var formula))
	    (kernel (allnc-form-to-kernel formula))
	    (type (formula-to-et-type kernel)))
       (if
	(nulltype? type)
	(make-all var (real-and-formula-to-mr-formula-aux
		       'eps kernel pvar-to-mr-pvar))
	(make-all var (real-and-formula-to-mr-formula-aux
		       real kernel pvar-to-mr-pvar)))))
    ((exnc)
     (let* ((var (exnc-form-to-var formula))
	    (kernel (exnc-form-to-kernel formula))
	    (type (formula-to-et-type kernel)))
       (if
	(nulltype? type)
	(make-exnc var (real-and-formula-to-mr-formula-aux
			'eps kernel pvar-to-mr-pvar))
	(make-exnc var (real-and-formula-to-mr-formula-aux
			real kernel pvar-to-mr-pvar)))))
    ((exca excl excu)
     (real-and-formula-to-mr-formula-aux
      real (unfold-formula formula) pvar-to-mr-pvar))
    (else (myerror "real-and-formula-to-mr-formula-aux" "formula expected"
		   formula))))

(define (idpredconst-to-mr-idpredconst idpc)
  (myerror "idpredconst-to-mr-idpredconst"
	   "not implemented for idpredconst"
	   (idpredconst-to-string idpc)))

(define (all-formulas-to-mr-ind-proof . all-formulas)
  (let ((pvar-to-mr-pvar (make-pvar-to-mr-pvar)))
    (apply all-formulas-to-mr-ind-proof-aux
	   (cons pvar-to-mr-pvar all-formulas))))

(define (all-formulas-to-mr-ind-proof-aux pvar-to-mr-pvar . all-formulas)
  (let* ((free (apply union (map formula-to-free all-formulas)))
	 (vars (map all-form-to-var all-formulas))
	 (kernels (map all-form-to-kernel all-formulas))
	 (orig-ind-aconst (apply all-formulas-to-ind-aconst all-formulas))
	 (orig-inst-formula (aconst-to-inst-formula orig-ind-aconst))
	 (step-formulas ;D1 ... Dk
	  (imp-form-to-premises (all-form-to-kernel orig-inst-formula)))
	 (real-vars-with-eps ;f1 ... eps ... fk
	  (map (lambda (fla)
		 (let ((et-type (formula-to-et-type fla)))
		   (if (nulltype? et-type)
		       'eps
		       (type-to-new-var et-type))))
	       step-formulas))
	 (real-terms-with-eps
	  (map (lambda (x)
		 (if (var-form? x)
		     (make-term-in-var-form x)
		     x))
	       real-vars-with-eps))
	 (avars ;u1: f1 mr D1 ... ui: eps mr Di ... uk: fk mr Dk
	  (map (lambda (r fla)
		 (formula-to-new-avar
		  (real-and-formula-to-mr-formula-aux
		   r fla pvar-to-mr-pvar)
		  "u"))
	       real-terms-with-eps step-formulas))
	 (real-vars-with-eps-and-avars ;f1 u1 ... eps ui ... fk uk
	  (zip real-vars-with-eps avars))
	 (real-vars-and-avars ;f1 u1 ... ui ... fk uk
	  (list-transform-positive real-vars-with-eps-and-avars
	    (lambda (x) (not (equal? 'eps x)))))
	 (real-vars ;f1 ... fk
	  (list-transform-positive real-vars-and-avars var-form?))
         (real-terms
          (list-transform-positive real-terms-with-eps
	    (lambda (x) (not (equal? 'eps x)))))
	 (arrow-types (map formula-to-et-type all-formulas))
	 (proper-arrow-types
	  (list-transform-positive arrow-types
	    (lambda (x) (not (nulltype? x)))))
	 (rec-consts ;adapted to allnc free
	  (apply arrow-types-to-rec-consts proper-arrow-types))
         (rec-terms (map make-term-in-const-form rec-consts))
	 (alg-names-for-rec
	  (map (lambda (type)
		 (alg-form-to-name (arrow-form-to-arg-type type)))
	       proper-arrow-types))
	 (alg-names-with-rec-terms
	  (map (lambda (x y) (list x y))
	       alg-names-for-rec rec-terms))
	 (fully-applied-rec-consts-or-eps
	  (do ((l1 arrow-types (cdr l1))
	       (l2 vars (cdr l2))
	       (l3 rec-terms
		   (if (nulltype? (car l1))
		       l3
		       (cdr l3)))
	       (res '() (cons (if (nulltype? (car l1))
				  'eps
				  (apply
                                   mk-term-in-app-form
				   (cons (car l3)
                                         (cons (make-term-in-var-form (car l2))
                                               real-terms))))
			      res)))
	      ((null? l1) (reverse res))))
	 (mr-all-formulas
	  (map (lambda (var x kernel)
		 (make-all var (real-and-formula-to-mr-formula-aux
				x kernel pvar-to-mr-pvar)))
	       vars fully-applied-rec-consts-or-eps kernels))
	 (orig-uninst-step-formulas
	  (imp-form-to-premises
           (all-form-to-kernel (aconst-to-uninst-formula orig-ind-aconst))))
	 (component-lengths ;(s1 ... sk) with si=mi+ni
	  (map (lambda (x)
		 (length (car (all-form-to-vars-and-final-kernel x))))
	       orig-uninst-step-formulas))
	 (hyp-lengths ;(n1 ... nk)
	  (map (lambda (x)
		 (length (imp-form-to-premises
			  (cadr (all-form-to-vars-and-final-kernel x)))))
	       orig-uninst-step-formulas))
	 (param-lengths ;(m1 ... mk)
	  (map (lambda (s n) (- s n)) component-lengths hyp-lengths))
	 (mr-ind-aconst (apply all-formulas-to-ind-aconst mr-all-formulas))
	 (mr-inst-formula (aconst-to-inst-formula mr-ind-aconst))
	 (mr-step-formulas ;(D1^mr ... Dk^mr)
	  (imp-form-to-premises (all-form-to-kernel mr-inst-formula)
				(length orig-uninst-step-formulas)))
	 (var (all-form-to-var mr-inst-formula)) ;x_j
	 (var-lists ;((y1 ... ym y_{m+1} ... y_{m+n}) ...)
	  (map (lambda (s x)
		 (if (zero? s) '()
		     (list-head (car (all-form-to-vars-and-final-kernel x))
				s)))
	       component-lengths mr-step-formulas))
	 (prem-lists
	  (map (lambda (s n x)
		 (if (zero? s) '()
		     (list-head (imp-form-to-premises
				 (cadr (all-form-to-vars-and-final-kernel x)))
				n)))
	       component-lengths hyp-lengths mr-step-formulas))
	 (prem-avar-lists ;((v1 ... vn) ...)
	  (map (lambda (prems)
		 (map (lambda (fla) (formula-to-new-avar fla "v")) prems))
	       prem-lists))
	 (y-lists ;((y_{m+1} ... y_{m+n}) ...)
	  (map (lambda (l m) (list-tail l m)) var-lists param-lengths))
	 (prem-vars-lists ;list of lists of vec{x}'s
	  (map (lambda (prems ys)
		 (map (lambda (fla y)
			(list-head
			 (car (all-form-to-vars-and-final-kernel fla))
			 (length (arrow-form-to-arg-types (var-to-type y)))))
		      prems ys))
	       prem-lists y-lists))
	 (applied-y-lists
	  (map (lambda (ys prem-vars-list)
		 (map (lambda (y prem-vars)
			(apply mk-term-in-app-form
			       (map make-term-in-var-form
				    (cons y prem-vars))))
		      ys prem-vars-list))
	       y-lists prem-vars-lists))
	 (mr-step-formula-realizer-lists
	  (map (lambda (applied-y-list)
		 (map (lambda (term)
			(let ((info
			       (assoc (alg-form-to-name (term-to-type term))
				      alg-names-with-rec-terms)))
			  (if info
			      (apply
                               mk-term-in-app-form
                               (cons (cadr info)
                                     (cons term
                                           real-terms)))
			      'eps)))
		      applied-y-list))
	       applied-y-lists))
	 (mr-step-formula-realizer-and-prem-avar-lists
	  (map (lambda (mr-step-formula-realizers prem-avars)
		 (zip mr-step-formula-realizers prem-avars))
	       mr-step-formula-realizer-lists prem-avar-lists))
	 (mr-step-formula-real-term-and-prem-avar-lists
	  (map (lambda (mr-step-formula-realizers-and-prem-avars)
		 (list-transform-positive
		     mr-step-formula-realizers-and-prem-avars
		   (lambda (x) (not (equal? 'eps x)))))
	       mr-step-formula-realizer-and-prem-avar-lists))
	 (mr-step-proofs
	  (map (lambda (u ys l)
		 (let ((vs (list-transform-positive l avar-form?))
		       (varterms-and-avarproofs
			(map (lambda (x)
			       (cond
				((term-form? x) x)
				((avar-form? x) (make-proof-in-avar-form x))
				(else (myerror "term or avar expected" x))))
			     l)))
		   (apply
		    mk-proof-in-intro-form
		    (append
		     ys vs
		     (list
		      (apply mk-proof-in-elim-form
			     (cons (make-proof-in-avar-form u)
				   (append (map make-term-in-var-form ys)
					   varterms-and-avarproofs))))))))
	       avars
	       var-lists
	       mr-step-formula-real-term-and-prem-avar-lists)))
    (apply
     mk-proof-in-nc-intro-form
     (append
      free
      (list
       (apply
	mk-proof-in-intro-form
        (cons
         var
         (append
          real-vars-and-avars
          (list
           (apply
            mk-proof-in-elim-form
            (cons
             (make-proof-in-aconst-form mr-ind-aconst)
             (append
              (map make-term-in-var-form (formula-to-free mr-inst-formula))
              (cons
               (make-term-in-var-form var)
               mr-step-proofs)))))))))))))

(define (all-formula-to-mr-cases-proof all-formula)
  (let ((pvar-to-mr-pvar (make-pvar-to-mr-pvar)))
    (all-formula-to-mr-cases-proof-aux pvar-to-mr-pvar all-formula)))

(define (all-formula-to-mr-cases-proof-aux pvar-to-mr-pvar all-formula)
  (let* ((free (formula-to-free all-formula))
	 (var (all-form-to-var all-formula))
	 (kernel (all-form-to-kernel all-formula))
	 (orig-cases-aconst (all-formula-to-cases-aconst all-formula))
	 (orig-inst-formula (aconst-to-inst-formula orig-cases-aconst))
	 (cases-step-formulas ;Di1 ... Diq
	  (imp-form-to-premises
	   (all-form-to-kernel orig-inst-formula)
	   (length (imp-form-to-premises
		    (all-form-to-kernel
		     (aconst-to-uninst-formula orig-cases-aconst)))))))
    (if
     (formula-of-nulltype? kernel)
     (let* ((mr-all-formula
	     (real-and-formula-to-mr-formula-aux
	      'eps all-formula pvar-to-mr-pvar))
	    (cases-aconst (all-formula-to-cases-aconst mr-all-formula)))
       (make-proof-in-aconst-form cases-aconst))
     (let* ((real-vars ;f1 ... fq
	     (map (lambda (fla) (type-to-new-var (formula-to-et-type fla)))
		  cases-step-formulas))
	    (real-terms (map make-term-in-var-form real-vars))
	    (avars ;u1: f1 mr Di1 ... uq: fq mr Diq
	     (map (lambda (r fla)
		    (formula-to-new-avar
		     (real-and-formula-to-mr-formula-aux
		      r fla pvar-to-mr-pvar)
		     "u"))
		  real-terms cases-step-formulas))
	    (real-vars-and-avars ;f1 u1 ... fq uq
	     (zip real-vars avars))
	    (if-term (make-term-in-if-form
		      (make-term-in-var-form var) real-terms))
	    (mr-all-formula
	     (make-all var (real-and-formula-to-mr-formula-aux
			    if-term kernel pvar-to-mr-pvar)))
	    (cases-aconst (all-formula-to-cases-aconst mr-all-formula)))
       (apply
	mk-proof-in-nc-intro-form
	(append
	 free
	 (list
	  (apply
	   mk-proof-in-intro-form
           (cons
            var
            (append
             real-vars-and-avars
             (list
              (apply
               mk-proof-in-elim-form
               (cons
                (make-proof-in-aconst-form cases-aconst)
                (append
                 (map make-term-in-var-form (formula-to-free mr-all-formula))
                 (cons (make-term-in-var-form var)
                       (map make-proof-in-avar-form avars))))))))))))))))

(define (gind-aconst-to-mr-gind-proof aconst)
  (let ((pvar-to-mr-pvar (make-pvar-to-mr-pvar)))
    (gind-aconst-to-mr-gind-proof-aux pvar-to-mr-pvar aconst)))

(define (gind-aconst-to-mr-gind-proof-aux pvar-to-mr-pvar aconst)
  (let* ((uninst-gind-formula (aconst-to-uninst-formula aconst))
         (all-formula (car (aconst-to-repro-formulas aconst)))
         (free (formula-to-free all-formula))
         (measure-var-and-vars (all-form-to-vars uninst-gind-formula))
         (measure-var (car measure-var-and-vars))
         (vars (cdr measure-var-and-vars))
         (m (length vars))
         (kernel-formula (all-form-to-final-kernel all-formula m)) ;A(xs)
         (kernel-formula-et-type (formula-to-et-type kernel-formula)))
    (if
     (nulltype? kernel-formula-et-type)
     (let* ((mr-all-formula
             (real-and-formula-to-mr-formula-aux
              'eps all-formula pvar-to-mr-pvar))
            (gind-aconst (all-formula-to-gind-aconst mr-all-formula m)))
       (make-proof-in-aconst-form gind-aconst))
     (let* ((inst-formula (aconst-to-inst-formula aconst))
            (prog-formula ;Prog_mu{xs | A(xs)}
             (imp-form-to-premise (all-form-to-final-kernel inst-formula)))
            (prog-formula-et-type (formula-to-et-type prog-formula))
            (real-var (type-to-new-var prog-formula-et-type)) ;G
            (real-term (make-term-in-var-form real-var))
            (prog-avar ;v: G mr Prog_mu{xs | A(xs)}
             (formula-to-new-avar
              (real-and-formula-to-mr-formula-aux
               real-term prog-formula pvar-to-mr-pvar)
              "v"))
            (types (map term-to-type vars))
            (tpinst (aconst-to-tpinst aconst))
            (tsubst (list-transform-positive tpinst
                      (lambda (x) (tvar-form? (car x)))))
            (type-info (append types (list kernel-formula-et-type)))
            (grec-const
             (type-info-etc-to-grec-const type-info tsubst all-formula))
            (grec-term (make-term-in-const-form grec-const)) ;[[GInd]]
            (grecguard-const
             (type-info-etc-to-grecguard-const type-info tsubst all-formula))
            (grecguard-term (make-term-in-const-form grecguard-const))
            (applied-grec-term
             (apply mk-term-in-app-form
                    (cons grec-term
                          (append (map make-term-in-var-form
                                       measure-var-and-vars)
                                  (list real-term)))))
            (mr-kernel-formula ;GRec mu xs G mr A(xs)
             (real-and-formula-to-mr-formula-aux
              applied-grec-term kernel-formula pvar-to-mr-pvar))
            (mr-all-formula ;all xs.GRec mu xs G mr A(xs)
             (apply mk-all (append vars (list mr-kernel-formula))))
            (mr-free (formula-to-free mr-all-formula))
            (mr-gind-aconst
             (all-formula-to-gind-aconst mr-all-formula m))
            (mr-gind-inst-formula
             (aconst-to-inst-formula mr-gind-aconst))
            (mr-measure-var (all-form-to-var mr-gind-inst-formula))
            (mr-prog-formula
             (imp-form-to-premise
              (all-form-to-final-kernel mr-gind-inst-formula)))
            (subst-mr-prog-formula
             (formula-subst mr-prog-formula mr-measure-var
                            (make-term-in-var-form measure-var)))
            (mr-prog-prem-avar ;u:all ys.mu ys < mu xs -> GRec mu ys G mr A(ys)
             (formula-to-new-avar
              (imp-form-to-premise
               (all-form-to-final-kernel subst-mr-prog-formula)) "u"))
            (new-vars (map var-to-new-var vars)) ;ys
            (test-term ;mu ys < mu xs
             (apply mk-term-in-app-form
                    (list (if (not (assoc "nat" ALGEBRAS))
			      (myerror "First execute (libload \"nat.scm\")")
			      (pt "NatLt"))
                          (apply mk-term-in-app-form
                                 (map make-term-in-var-form
                                      (cons measure-var new-vars)))
                          (apply mk-term-in-app-form
                                 (map make-term-in-var-form
				      measure-var-and-vars)))))
            (prev-applied-grecguard-term ;GRecGuard mu ys G (mu xs < mu ys)
             (apply mk-term-in-app-form
                    (cons grecguard-term
                          (cons (make-term-in-var-form measure-var)
                                (append (map make-term-in-var-form new-vars)
                                        (list real-term test-term))))))
            (test-var (type-to-new-partial-var (py "boole")))
            (prev-applied-grecguard-var-term
             (apply mk-term-in-app-form
                    (cons grecguard-term
                          (cons (make-term-in-var-form measure-var)
                                (append (map make-term-in-var-form new-vars)
                                        (list
                                         real-term
                                         (make-term-in-var-form test-var)))))))
            (vars-to-new-vars-subst
             (make-substitution vars (map make-term-in-var-form new-vars)))
            (subst-kernel-formula
             (formula-substitute kernel-formula vars-to-new-vars-subst))
            (cterm (make-cterm test-var
                               (real-and-formula-to-mr-formula-aux
                                prev-applied-grecguard-var-term
                                subst-kernel-formula pvar-to-mr-pvar)))
					;this is a hack ... is there no better
					;way to do this substitution?
            (tsubst-eq-compat-rev-proof
             (proof-subst (make-proof-in-aconst-form eq-compat-rev-aconst)
                          (car (formula-to-tvars
                                (aconst-to-formula eq-compat-rev-aconst)))
                          (py "boole")))
            (tpsubst-eq-compat-rev-proof
             (proof-subst tsubst-eq-compat-rev-proof
                          (car (formula-to-pvars
                                (proof-to-formula tsubst-eq-compat-rev-proof)))
                          cterm))
            (aux-avar (formula-to-new-avar (make-atomic-formula test-term)))
            (aux-proof ;M' : all ys.mu ys < mu xs -> GRecGuard
					;mu ys G (mu ys < mu xs) mr A(ys)
             (apply
              mk-proof-in-intro-form
              (append
               new-vars
               (list
                aux-avar
                (mk-proof-in-elim-form
                 tpsubst-eq-compat-rev-proof test-term (pt "True")
                 (mk-proof-in-elim-form
                  (make-proof-in-aconst-form
                   (finalg-to-=-to-eq-aconst (py "boole")))
                  test-term (pt "True")
                  (mk-proof-in-elim-form
                   (make-proof-in-aconst-form atom-true-aconst)
                   test-term
                   (make-proof-in-avar-form aux-avar)))
                 (apply mk-proof-in-elim-form
                        (cons (make-proof-in-avar-form mr-prog-prem-avar)
                              (append (map make-term-in-var-form new-vars)
                                      (list (make-proof-in-avar-form
                                             aux-avar))))))))))
            (mr-prog-proof ;M : Prog_mu{xs | GRec mu xs G mr A(xs)}
             (apply
              mk-proof-in-intro-form
              (append
               vars
               (list
                mr-prog-prem-avar
                (apply
                 mk-proof-in-elim-form
                 (cons
                  (make-proof-in-avar-form prog-avar)
                  (append
                   (map make-term-in-var-form vars)
                   (list
                    (apply mk-term-in-abst-form
                           (append new-vars
                                   (list prev-applied-grecguard-term)))
                    aux-proof)))))))))
       (apply
        mk-proof-in-nc-intro-form
        (append
         free
         (list
          (apply
           mk-proof-in-intro-form
           (cons
            measure-var
            (append
             vars
             (list
              real-var
              prog-avar
              (apply
               mk-proof-in-elim-form
               (append
                (cons
                 (make-proof-in-aconst-form mr-gind-aconst)
                 (map make-term-in-var-form mr-free))
                (list (make-term-in-var-form measure-var))
                (map make-term-in-var-form vars)
                (list mr-prog-proof))))))))))))))

(define (ex-formula-to-ex-intro-mr-proof ex-formula)
  (let ((pvar-to-mr-pvar (make-pvar-to-mr-pvar)))
    (ex-formula-to-ex-intro-mr-proof-aux pvar-to-mr-pvar ex-formula)))

(define (ex-formula-to-ex-intro-mr-proof-aux pvar-to-mr-pvar ex-formula)
  (let* ((free (formula-to-free ex-formula))
	 (var (ex-form-to-var ex-formula))
	 (kernel (ex-form-to-kernel ex-formula))
	 (kernel-type (formula-to-et-type kernel)))
    (if
     (nulltype? kernel-type)
     (let* ((mr-formula (real-and-formula-to-mr-formula-aux
			 'eps kernel pvar-to-mr-pvar))
	    (avar (formula-to-new-avar mr-formula "u")))
       (apply
	mk-proof-in-nc-intro-form
	(append free (list (mk-proof-in-intro-form
			    var avar (make-proof-in-avar-form avar))))))
     (let* ((real-var (type-to-new-var kernel-type))
	    (real-term (make-term-in-var-form real-var))
	    (mr-formula (real-and-formula-to-mr-formula-aux
			 real-term kernel pvar-to-mr-pvar))
	    (avar (formula-to-new-avar mr-formula "u")))
       (apply
	mk-proof-in-nc-intro-form
	(append free (list (mk-proof-in-intro-form
			    var real-var avar
			    (make-proof-in-avar-form avar)))))))))

(define (ex-formula-and-concl-to-ex-elim-mr-proof ex-formula concl)
  (let ((pvar-to-mr-pvar (make-pvar-to-mr-pvar)))
    (ex-formula-and-concl-to-ex-elim-mr-proof-aux
     pvar-to-mr-pvar ex-formula concl)))

(define (ex-formula-and-concl-to-ex-elim-mr-proof-aux pvar-to-mr-pvar
						      ex-formula concl)
  (let* ((free (union (formula-to-free ex-formula) (formula-to-free concl)))
	 (var (ex-form-to-var ex-formula))
	 (type (var-to-type var))
	 (kernel (ex-form-to-kernel ex-formula))
	 (kernel-type (formula-to-et-type kernel))
	 (ex-type (formula-to-et-type ex-formula))
	 (concl-type (formula-to-et-type concl)))
    (if
     (nulltype? kernel-type)
     (let* ((mr-kernel (real-and-formula-to-mr-formula-aux
			'eps kernel pvar-to-mr-pvar))
	    (u (formula-to-new-avar mr-kernel "u")))
       (if
	(nulltype? concl-type)
	(let* ((mr-concl (real-and-formula-to-mr-formula-aux
			  'eps concl pvar-to-mr-pvar))
	       (v (formula-to-new-avar 
		   (make-all var (make-imp mr-kernel mr-concl)) "v")))
	  (apply
	   mk-proof-in-nc-intro-form
	   (append free (list (mk-proof-in-intro-form
			       var u v (mk-proof-in-elim-form
					(make-proof-in-avar-form v)
					(make-term-in-var-form var)
					(make-proof-in-avar-form u)))))))
	(let* ((z (type-to-new-var
		   (formula-to-et-type
		    (make-all var (make-imp kernel concl)))))
	       (zx (make-term-in-app-form (make-term-in-var-form z)
					  (make-term-in-var-form var)))
	       (mr-concl (real-and-formula-to-mr-formula-aux
			  zx concl pvar-to-mr-pvar))
	       (v (formula-to-new-avar 
		   (make-all var (make-imp mr-kernel mr-concl)) "v")))
	  (apply
	   mk-proof-in-nc-intro-form
	   (append free (list (mk-proof-in-intro-form
			       var u z v
			       (mk-proof-in-elim-form
				(make-proof-in-avar-form v)
				(make-term-in-var-form var)
				(make-proof-in-avar-form u)))))))))
     (let* ((pair-var (type-to-new-var (make-star type kernel-type)))
	    (pair-var-term (make-term-in-var-form pair-var))
	    (left-term (make-term-in-lcomp-form pair-var-term))
	    (right-term (make-term-in-rcomp-form pair-var-term))
	    (mr-kernel (real-and-formula-to-mr-formula-aux
			(make-term-in-rcomp-form pair-var-term)
			(formula-subst
			 kernel var (make-term-in-lcomp-form pair-var-term))
			pvar-to-mr-pvar))
	    (u (formula-to-new-avar mr-kernel "u"))
	    (g (type-to-new-var (formula-to-et-type
				 kernel)))
	    (g-mr-kernel (real-and-formula-to-mr-formula-aux
			  (make-term-in-var-form g) kernel
			  pvar-to-mr-pvar)))
       (if
	(nulltype? concl-type)
	(let* ((mr-concl (real-and-formula-to-mr-formula-aux
			  'eps concl pvar-to-mr-pvar))
	       (v (formula-to-new-avar 
		   (make-all var (make-imp g-mr-kernel mr-concl)) "v")))
	  (apply
	   mk-proof-in-nc-intro-form
	   (append free (list (mk-proof-in-intro-form
			       pair-var u v
			       (mk-proof-in-elim-form
				(make-proof-in-avar-form v)
				left-term right-term
				(make-proof-in-avar-form u)))))))
	(let* ((z (type-to-new-var
		   (formula-to-et-type
		    (make-all var (make-imp kernel concl)))))
	       (zxg (mk-term-in-app-form (make-term-in-var-form z)
					 (make-term-in-var-form var)
					 (make-term-in-var-form g)))
	       (mr-concl (real-and-formula-to-mr-formula-aux
			  zxg concl pvar-to-mr-pvar))
	       (mr-kernel-with-var-and-g
		(real-and-formula-to-mr-formula-aux
		 (make-term-in-var-form g) kernel pvar-to-mr-pvar))
	       (v (formula-to-new-avar 
		   (mk-all var g (make-imp mr-kernel-with-var-and-g
					   mr-concl)) "v")))
	  (apply
	   mk-proof-in-nc-intro-form
	   (append free (list (mk-proof-in-intro-form
			       pair-var u z v
			       (mk-proof-in-elim-form
				(make-proof-in-avar-form v)
				left-term right-term
				(make-proof-in-avar-form u))))))))))))

(define (exnc-formula-to-exnc-intro-mr-proof-aux pvar-to-mr-pvar exnc-formula)
  (let* ((free (formula-to-free exnc-formula))
	 (var (exnc-form-to-var exnc-formula))
	 (kernel (exnc-form-to-kernel exnc-formula))
	 (kernel-type (formula-to-et-type kernel)))
    (if
     (nulltype? kernel-type)
     (let* ((mr-formula (real-and-formula-to-mr-formula-aux
			 'eps exnc-formula pvar-to-mr-pvar))
	    (mr-free (formula-to-free mr-formula))
	    (aconst (exnc-formula-to-exnc-intro-aconst mr-formula)))
       (apply
	mk-proof-in-intro-form
	(append
	 free
	 (list (apply mk-proof-in-elim-form
		      (cons (make-proof-in-aconst-form aconst)
			    (map make-term-in-var-form mr-free)))))))
     (let* ((real-var (type-to-new-var kernel-type))
	    (real-term (make-term-in-var-form real-var))
	    (mr-formula (real-and-formula-to-mr-formula-aux
			 real-term exnc-formula pvar-to-mr-pvar))
	    (mr-free (formula-to-free mr-formula))
	    (aconst (exnc-formula-to-exnc-intro-aconst mr-formula)))
       (apply
	mk-proof-in-nc-intro-form
	(append
	 free
	 (list var
	       (make-proof-in-all-intro-form
		real-var
		(apply
		 mk-proof-in-elim-form
		 (cons (make-proof-in-aconst-form aconst)
		       (map make-term-in-var-form
			    (append mr-free (list var)))))))))))))

(define (compat-aconst-to-mr-compat-proof aconst pvar-to-mr-pvar)
  (let* ((name (aconst-to-name aconst))
	 (kind (aconst-to-kind aconst))
	 (tpinst (aconst-to-tpinst aconst))
	 (tinst (list-transform-positive tpinst
		  (lambda (x) (tvar-form? (car x)))))
	 (pinst (list-transform-positive tpinst
		  (lambda (x) (pvar-form? (car x)))))
	 (uninst-formula (aconst-to-uninst-formula aconst))
	 (var1 (allnc-form-to-var uninst-formula))
	 (kernel1 (allnc-form-to-kernel uninst-formula))
	 (var2 (allnc-form-to-var kernel1))
	 (kernel2 (allnc-form-to-kernel kernel1))
	 (eq-fla (imp-form-to-premise kernel2))
	 (fla1 (imp-form-to-premise (imp-form-to-conclusion kernel2)))
	 (pvar (predicate-form-to-predicate fla1))
	 (cterm (if (pair? pinst)
		    (cadr (car pinst))
		    (make-cterm var1 (make-predicate-formula
				      pvar (make-term-in-var-form var1)))))
	 (fla (cterm-to-formula cterm))
	 (et-type (formula-to-et-type fla)))
    (if
     (nulltype? et-type)
     (let* ((mr-fla (real-and-formula-to-mr-formula-aux
		     'eps fla pvar-to-mr-pvar))
	    (vars (cterm-to-vars cterm))
	    (var (if (pair? vars)
		     (car vars) 
		     (myerror
		      "eq-compat-aconst-to-mr-eq-compat-proof"
		      "var expected in cterm" cterm)))
	    (new-cterm (make-cterm var mr-fla))
	    (new-tpinst (append tinst (list (list pvar new-cterm))))
	    (new-aconst (make-aconst name kind uninst-formula new-tpinst)))
       (make-proof-in-aconst-form new-aconst))
     (let* ((free (cterm-to-free cterm))
	    (y1 (car (cterm-to-vars cterm)))
	    (y2 (var-to-new-var y1))
	    (f (type-to-new-var et-type))
	    (y1-term (make-term-in-var-form y1))
	    (y2-term (make-term-in-var-form y2))
	    (f-term (make-term-in-var-form f))
	    (mr-fla (real-and-formula-to-mr-formula-aux
		     f-term fla pvar-to-mr-pvar))
	    (new-cterm (make-cterm y1 mr-fla))
	    (new-tpinst (append tinst (list (list pvar new-cterm))))
	    (new-aconst (make-aconst name kind uninst-formula new-tpinst))
	    (subst-eq-fla (formula-substitute
			   eq-fla
			   (list (list var1 y1-term) (list var2 y2-term))))
	    (u (formula-to-new-avar subst-eq-fla "u")))
       (apply
	mk-proof-in-nc-intro-form
	(append
	 free
	 (list y1 y2 u
	       (make-proof-in-all-intro-form
		f 
		(apply
		 mk-proof-in-elim-form
		 (append
		  (list (make-proof-in-aconst-form new-aconst) f-term)
		  (map make-term-in-var-form free)
		  (list y1-term y2-term (make-proof-in-avar-form u))))))))))))

(define (efq-ga-to-mr-efq-ga-proof aconst pvar-to-mr-pvar)
  (let* ((name (aconst-to-name aconst)) ;Efq-Log or Efq
	 (kind (aconst-to-kind aconst)) ;global-assumption
	 (tpinst (aconst-to-tpinst aconst))
	 (tinst (list-transform-positive tpinst
		  (lambda (x) (tvar-form? (car x))))) ;empty
	 (pinst (list-transform-positive tpinst
		  (lambda (x) (pvar-form? (car x)))))
	 (uninst-formula (aconst-to-uninst-formula aconst))
	 (fla1 (imp-form-to-conclusion uninst-formula))
	 (pvar (predicate-form-to-predicate fla1))
	 (cterm (if (pair? pinst)
		    (cadr (car pinst))
		    (make-cterm fla1)))
	 (fla (cterm-to-formula cterm))
	 (et-type (formula-to-et-type fla))
	 (real (if (nulltype? et-type)
		   'eps
		   (type-to-canonical-inhabitant et-type)))
	 (mr-fla (real-and-formula-to-mr-formula-aux
		  real fla pvar-to-mr-pvar))
	 (new-cterm (make-cterm mr-fla))
	 (new-tpinst (append tinst (list (list pvar new-cterm))))
	 (new-aconst (make-aconst name kind uninst-formula new-tpinst)))
    (make-proof-in-aconst-form new-aconst)))

(define (make-avar-or-ga-to-var)
					;returns a procedure assigning to
					;assumption variables or constants 
					;(gas) whose types have computational 
					;content new object variables of the 
					;corresponding et-type.  It remembers 
					;the assignment done so far.
  (let ((avar-assoc-list '())
	(ga-assoc-list '()))
    (lambda (x)
      (let ((info (if (avar-form? x)
		      (assoc-wrt avar=? x avar-assoc-list)
		      (assoc-wrt aconst=? x ga-assoc-list))))
	(if info
	    (cadr info)
	    (let* ((formula (if (avar-form? x)
				(avar-to-formula x)
				(aconst-to-formula x)))
		   (type (formula-to-et-type formula))
		   (new-var (if (nulltype? type)
				(myerror "make-avar-or-ga-to-var"
					 "computational content expected in"
					 formula)
				(type-to-new-var type))))
	      (if (avar-form? x)
		  (begin (set! avar-assoc-list
			       (cons (list x new-var) avar-assoc-list))
			 new-var)
		  (begin (set! ga-assoc-list
			       (cons (list x new-var) ga-assoc-list))
			 new-var))))))))

(define (make-avar-or-ga-to-mr-avar pvar-to-mr-pvar avar-or-ga-to-var)
					;returns a procedure assigning to an
					;avar or ga u:A a new avar u':x_u mr A.
					;Remembers the assignment done so far.
  (let ((avar-assoc-list '())
	(ga-assoc-list '()))
    (lambda (x)
      (let ((info (if (avar-form? x)
		      (assoc-wrt avar=? x avar-assoc-list)
		      (assoc-wrt aconst=? x ga-assoc-list))))
	(if info
	    (cadr info)
	    (let* ((formula (if (avar-form? x)
				(avar-to-formula x)
				(aconst-to-formula x)))
		   (type (formula-to-et-type formula))
		   (mr-formula (real-and-formula-to-mr-formula-aux
				(if (nulltype? type)
				    'eps
				    (make-term-in-var-form
				     (avar-or-ga-to-var x)))
				formula
				pvar-to-mr-pvar))
		   (mr-avar (formula-to-new-avar mr-formula "umr")))
	      (if (avar-form? x)
		  (begin (set! avar-assoc-list
			       (cons (list x mr-avar) avar-assoc-list))
			 mr-avar)
		  (begin (set! ga-assoc-list
			       (cons (list x mr-avar) ga-assoc-list))
			 mr-avar))))))))

(define (proof-to-soundness-proof proof)
  (let* ((pvar-to-mr-pvar (make-pvar-to-mr-pvar))
	 (avar-or-ga-to-var (make-avar-or-ga-to-var))
	 (avar-or-ga-to-mr-avar (make-avar-or-ga-to-mr-avar
				 pvar-to-mr-pvar avar-or-ga-to-var)))
    (proof-to-soundness-proof-aux
     proof pvar-to-mr-pvar avar-or-ga-to-var avar-or-ga-to-mr-avar)))

(define (proof-to-soundness-proof-aux proof pvar-to-mr-pvar
				      avar-or-ga-to-var
				      avar-or-ga-to-mr-avar)
  (case (tag proof)
    ((proof-in-avar-form)
     (let* ((avar (proof-in-avar-form-to-avar proof))
	    (mr-avar (avar-or-ga-to-mr-avar avar)))
       (make-proof-in-avar-form mr-avar)))
    ((proof-in-aconst-form)
     (if
      (non-computational-invariant? (proof-to-formula proof))
      proof
      (let* ((aconst (proof-in-aconst-form-to-aconst proof))
	     (name (aconst-to-name aconst)))
	(case (aconst-to-kind aconst)
	  ((axiom)
	   (cond ((string=? "Ind" name)
		  (apply all-formulas-to-mr-ind-proof-aux
			 (cons pvar-to-mr-pvar
			       (aconst-to-repro-formulas aconst))))
		 ((string=? "Cases" name)
		  (all-formula-to-mr-cases-proof-aux
		   pvar-to-mr-pvar (car (aconst-to-repro-formulas aconst))))
                 ((string=? "GInd" name)
                  (gind-aconst-to-mr-gind-proof-aux pvar-to-mr-pvar aconst))
		 ((string=? "Ex-Intro" name)
		  (ex-formula-to-ex-intro-mr-proof-aux
		   pvar-to-mr-pvar (car (aconst-to-repro-formulas aconst))))
		 ((string=? "Ex-Elim" name)
		  (apply ex-formula-and-concl-to-ex-elim-mr-proof-aux
			 (cons pvar-to-mr-pvar
			       (aconst-to-repro-formulas aconst))))
		 ((string=? "Exnc-Intro" name)
		  (exnc-formula-to-exnc-intro-mr-proof-aux
		   pvar-to-mr-pvar (car (aconst-to-repro-formulas aconst))))
		 ((string=? "Eq-Compat" name)
		  (compat-aconst-to-mr-compat-proof
		   aconst pvar-to-mr-pvar))
		 (else (myerror
			"proof-to-soundness-proof-aux" "unexpected axiom"
			name))))
	  ((theorem)
	   (let ((info (assoc name THEOREMS)))
	     (if
	      info
	      (let* ((inst-proof (theorem-aconst-to-inst-proof aconst))
		     (free (formula-to-free (proof-to-formula inst-proof)))
		     (closed-inst-proof
		      (apply mk-proof-in-nc-intro-form
			     (append free (list inst-proof)))))
		(proof-to-soundness-proof-aux
		 closed-inst-proof pvar-to-mr-pvar
		 avar-or-ga-to-var avar-or-ga-to-mr-avar))
	      (myerror "proof-to-soundness-proof-aux" "theorem expected"
		       name))))
	  ((global-assumption)
	   (let ((info (assoc name GLOBAL-ASSUMPTIONS)))
	     (if
	      info
	      (cond
	       ((or (string=? "Efq" name) (string=? "Efq-Log" name))
		(efq-ga-to-mr-efq-ga-proof aconst pvar-to-mr-pvar))
	       ((or (and (<= (string-length "Eq-Compat-Rev")
			     (string-length name))
			 (string=?
			  (substring name 0 (string-length "Eq-Compat-Rev"))
			  "Eq-Compat-Rev"))
		    (and (<= (string-length "Compat-Rev")
			     (string-length name))
			 (string=?
			  (substring name 0 (string-length "Compat-Rev"))
			  "Compat-Rev"))
		    (and (<= (string-length "Compat")
			     (string-length name))
			 (string=?
			  (substring name 0 (string-length "Compat"))
			  "Compat")))
		(compat-aconst-to-mr-compat-proof aconst pvar-to-mr-pvar))
	       (else (let ((mr-avar (avar-or-ga-to-mr-avar aconst)))
		       (make-proof-in-avar-form mr-avar))))
	      (myerror
	       "proof-to-soundness-proof-aux" "global assumption expected"
	       name))))
	  (else (myerror
		 "proof-to-soundness-proof-aux" "unknown kind of aconst"
		 (aconst-to-kind aconst)))))))
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (mr-avar (avar-or-ga-to-mr-avar avar))
	    (avar-type (formula-to-et-type (avar-to-formula avar)))
	    (kernel (proof-in-imp-intro-form-to-kernel proof))
	    (kernel-proof (proof-to-soundness-proof-aux
			   kernel pvar-to-mr-pvar
			   avar-or-ga-to-var avar-or-ga-to-mr-avar))
	    (imp-intro-proof
	     (make-proof-in-imp-intro-form mr-avar kernel-proof)))
       (if (nulltype? avar-type)
	   imp-intro-proof
	   (make-proof-in-all-intro-form
	    (avar-or-ga-to-var avar) imp-intro-proof))))
    ((proof-in-imp-elim-form)
     (let* ((op (proof-in-imp-elim-form-to-op proof))
	    (arg (proof-in-imp-elim-form-to-arg proof))
	    (arg-type (formula-to-et-type (proof-to-formula arg)))
	    (op-proof (proof-to-soundness-proof-aux
		       op pvar-to-mr-pvar
		       avar-or-ga-to-var avar-or-ga-to-mr-avar))
	    (arg-proof (proof-to-soundness-proof-aux
			arg pvar-to-mr-pvar
			avar-or-ga-to-var avar-or-ga-to-mr-avar)))
       (if (nulltype? arg-type)
	   (make-proof-in-imp-elim-form op-proof arg-proof)
	   (mk-proof-in-elim-form
	    op-proof
	    (proof-to-extracted-term-aux arg avar-or-ga-to-var)
	    arg-proof))))
    ((proof-in-impnc-intro-form)
     (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	    (mr-avar (avar-or-ga-to-mr-avar avar))
	    (avar-type (formula-to-et-type (avar-to-formula avar)))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (kernel-proof (proof-to-soundness-proof-aux
			   kernel pvar-to-mr-pvar
			   avar-or-ga-to-var avar-or-ga-to-mr-avar))
	    (imp-intro-proof
	     (make-proof-in-impnc-intro-form mr-avar kernel-proof)))
       (if (nulltype? avar-type)
	   imp-intro-proof
	   (make-proof-in-all-intro-form
	    (avar-or-ga-to-var avar) imp-intro-proof))))
    ((proof-in-impnc-elim-form)
     (let* ((op (proof-in-impnc-elim-form-to-op proof))
	    (arg (proof-in-impnc-elim-form-to-arg proof))
	    (arg-type (formula-to-et-type (proof-to-formula arg)))
	    (op-proof (proof-to-soundness-proof-aux
		       op pvar-to-mr-pvar
		       avar-or-ga-to-var avar-or-ga-to-mr-avar))
	    (arg-proof (proof-to-soundness-proof-aux
			arg pvar-to-mr-pvar
			avar-or-ga-to-var avar-or-ga-to-mr-avar)))
       (if (nulltype? arg-type)
	   (make-proof-in-imp-elim-form op-proof arg-proof)
	   (mk-proof-in-elim-form
	    op-proof
	    (proof-to-extracted-term-aux arg avar-or-ga-to-var)
	    arg-proof))))
    ((proof-in-and-intro-form)
     (let* ((left (proof-in-and-intro-form-to-left proof))
	    (right (proof-in-and-intro-form-to-right proof))
	    (left-proof (proof-to-soundness-proof-aux
			 left pvar-to-mr-pvar
			 avar-or-ga-to-var avar-or-ga-to-mr-avar))
	    (right-proof (proof-to-soundness-proof-aux
			  right pvar-to-mr-pvar
			  avar-or-ga-to-var avar-or-ga-to-mr-avar)))
       (make-proof-in-and-intro-form left-proof right-proof)))
    ((proof-in-and-elim-left-form)
     (let* ((kernel (proof-in-and-elim-left-form-to-kernel proof))
	    (kernel-proof (proof-to-soundness-proof-aux
			   kernel pvar-to-mr-pvar
			   avar-or-ga-to-var avar-or-ga-to-mr-avar)))
       (make-proof-in-and-elim-left-form kernel-proof)))
    ((proof-in-and-elim-right-form)
     (let* ((kernel (proof-in-and-elim-right-form-to-kernel proof))
	    (kernel-proof (proof-to-soundness-proof-aux
			   kernel pvar-to-mr-pvar
			   avar-or-ga-to-var avar-or-ga-to-mr-avar)))
       (make-proof-in-and-elim-right-form kernel-proof)))
    ((proof-in-all-intro-form)
     (let* ((var (proof-in-all-intro-form-to-var proof))
	    (kernel (proof-in-all-intro-form-to-kernel proof))
	    (kernel-proof (proof-to-soundness-proof-aux
			   kernel pvar-to-mr-pvar
			   avar-or-ga-to-var avar-or-ga-to-mr-avar)))
       (make-proof-in-all-intro-form var kernel-proof)))
    ((proof-in-all-elim-form)
     (let* ((op (proof-in-all-elim-form-to-op proof))
	    (op-proof (proof-to-soundness-proof-aux
		       op pvar-to-mr-pvar
		       avar-or-ga-to-var avar-or-ga-to-mr-avar))
	    (arg (proof-in-all-elim-form-to-arg proof)))
       (make-proof-in-all-elim-form op-proof arg)))
    ((proof-in-allnc-intro-form)
     (let* ((var (proof-in-allnc-intro-form-to-var proof))
	    (kernel (proof-in-allnc-intro-form-to-kernel proof))
	    (kernel-proof (proof-to-soundness-proof-aux
			   kernel pvar-to-mr-pvar
			   avar-or-ga-to-var avar-or-ga-to-mr-avar)))
       (make-proof-in-allnc-intro-form var kernel-proof)))
    ((proof-in-allnc-elim-form)
     (let* ((op (proof-in-allnc-elim-form-to-op proof))
	    (op-proof (proof-to-soundness-proof-aux
		       op pvar-to-mr-pvar
		       avar-or-ga-to-var avar-or-ga-to-mr-avar))
	    (arg (proof-in-allnc-elim-form-to-arg proof)))
       (make-proof-in-allnc-elim-form op-proof arg)))
    (else (myerror
	   "proof-to-soundness-proof-aux" "proof expected" proof))))
