minlog 4.0.99.20100221-5.2 / usr / share / minlog / src / proof.scm

; $Id: proof.scm 2357 2009-12-10 17:10:45Z schwicht $
; 10. Proofs
; ==========

; 10-1. Constructors and accessors
; ================================

; Proofs are built from assumption variables and assumption constants
; (i.e., axioms, theorems and global assumption) by the usual rules of
; natural deduction, i.e., introduction and elimination rules for
; implication, conjunction and universal quantification.  From a proof
; we can read off its context, which is an ordered list of object and
; assumption variables.

(define proof-to-formula cadr)

; Proofs always have the form (tag formula ...) where ... is a list with
; further information.

; Constructor, accessor and test for proofs in assumption variable form:
; (proof-in-avar-form formula avar)

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

(define proof-in-avar-form-to-avar caddr)

(define (proof-in-avar-form? proof)
  (eq? 'proof-in-avar-form (tag proof)))

; Constructor, accessor and test for proofs in assumption constant form:

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

(define proof-in-aconst-form-to-aconst caddr)

(define (proof-in-aconst-form? proof)
  (eq? 'proof-in-aconst-form (tag proof)))

; Constructors, accessors and test for implication introduction:

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

(define proof-in-imp-intro-form-to-avar caddr)
(define proof-in-imp-intro-form-to-kernel cadddr)

(define (proof-in-imp-intro-form? proof)
  (eq? 'proof-in-imp-intro-form (tag proof)))

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

(define proof-in-impnc-intro-form-to-avar caddr)
(define proof-in-impnc-intro-form-to-kernel cadddr)

(define (proof-in-impnc-intro-form? proof)
  (eq? 'proof-in-impnc-intro-form (tag proof)))

; (mk-proof-in-intro-form x1 ... proof) is formed from proof by first 
; abstracting x1, then x2 and so on.  Here x1, x2 ... can be
; assumption or object variables.

(define (mk-proof-in-intro-form x . rest)
  (if (null? rest)
      x
      (cond ((avar-form? x)
	     (let ((prev (apply mk-proof-in-intro-form rest)))
	       (make-proof-in-imp-intro-form x prev)))
	    ((var-form? x)
	     (let ((prev (apply mk-proof-in-intro-form rest)))
	       (make-proof-in-all-intro-form x prev)))
	    (else (myerror "mk-proof-in-intro-form"
			   "assumption or object variable expected"
			   x)))))

(define (mk-proof-in-nc-intro-form x . rest)
  (if (null? rest)
      x
      (cond ((avar-form? x)
	     (let ((prev (apply mk-proof-in-nc-intro-form rest)))
	       (make-proof-in-impnc-intro-form x prev)))
	    ((var-form? x)
	     (let ((prev (apply mk-proof-in-nc-intro-form rest)))
	       (make-proof-in-allnc-intro-form x prev)))
	    (else (myerror "mk-proof-in-nc-intro-form"
			   "assumption or object variable expected"
			   x)))))

(define (proof-in-intro-form-to-kernel-and-vars proof)
  (case (tag proof)
    ((proof-in-imp-intro-form)
     (let* ((prev (proof-in-intro-form-to-kernel-and-vars
		   (proof-in-imp-intro-form-to-kernel proof)))
	    (prev-kernel (car prev))
	    (prev-vars (cdr prev)))
       (cons prev-kernel
	     (cons (proof-in-imp-intro-form-to-avar proof) prev-vars))))
    ((proof-in-impnc-intro-form)
     (let* ((prev (proof-in-intro-form-to-kernel-and-vars
		   (proof-in-impnc-intro-form-to-kernel proof)))
	    (prev-kernel (car prev))
	    (prev-vars (cdr prev)))
       (cons prev-kernel
	     (cons (proof-in-impnc-intro-form-to-avar proof) prev-vars))))
    ((proof-in-all-intro-form)
     (let* ((prev (proof-in-intro-form-to-kernel-and-vars
		   (proof-in-all-intro-form-to-kernel proof)))
	    (prev-kernel (car prev))
	    (prev-vars (cdr prev)))
       (cons prev-kernel
	     (cons (proof-in-all-intro-form-to-var proof) prev-vars))))
    ((proof-in-allnc-intro-form)
     (let* ((prev (proof-in-intro-form-to-kernel-and-vars
		   (proof-in-allnc-intro-form-to-kernel proof)))
	    (prev-kernel (car prev))
	    (prev-vars (cdr prev)))
       (cons prev-kernel
	     (cons (proof-in-allnc-intro-form-to-var proof) prev-vars))))
    (else (list proof))))

(define (proof-in-intro-form-to-vars proof . x)
  (cond
   ((null? x)
    (if (proof-in-imp-impnc-all-allnc-intro-form? proof)
	(cons (proof-in-imp-impnc-all-allnc-intro-form-to-var proof)
	      (proof-in-intro-form-to-vars
	       (proof-in-imp-impnc-all-allnc-intro-form-to-kernel proof)))
	'()))
   ((and (integer? (car x)) (not (negative? (car x))))
    (let ((n (car x)))
      (do ((p proof (proof-in-imp-impnc-all-allnc-intro-form-to-kernel p))
	   (i 0 (+ 1 i))
	   (res '() (cons (proof-in-imp-impnc-all-allnc-intro-form-to-var p)
			  res)))
	  ((or (= n i) (not (proof-in-imp-impnc-all-allnc-intro-form? p)))
	   (reverse res)))))
   (else (myerror "proof-in-intro-form-to-vars" "non-negative integer expected"
		  (car x)))))

; proof-in-intro-form-to-final-kernel computes the final kernel (the
; kernel after removing at most (car x) abstracted avars and vars) of
; a proof.

(define (proof-in-intro-form-to-final-kernel proof . x)
  (cond
   ((null? x)
    (if (proof-in-imp-impnc-all-allnc-intro-form? proof)
	(proof-in-intro-form-to-final-kernel
	 (proof-in-imp-impnc-all-allnc-intro-form-to-kernel proof))
	proof))
   ((and (integer? (car x)) (not (negative? (car x))))
    (let ((n (car x)))
      (do ((p proof (proof-in-imp-impnc-all-allnc-intro-form-to-kernel p))
	   (i 0 (+ 1 i))
	   (res proof (proof-in-imp-impnc-all-allnc-intro-form-to-kernel res)))
	  ((or (= n i) (not (proof-in-imp-impnc-all-allnc-intro-form? p)))
	   res))))
   (else (myerror "proof-in-intro-form-to-final-kernel"
		  "non-negative integer expected"
		  (car x)))))

(define (intro-proof-and-new-kernel-and-depth-to-proof proof new-kernel . x)
  (cond
   ((null? x)
    (case (tag proof)
      ((proof-in-imp-intro-form)
       (make-proof-in-imp-intro-form
	(proof-in-imp-intro-form-to-avar proof)
	(intro-proof-and-new-kernel-and-depth-to-proof
	 (proof-in-imp-intro-form-to-kernel proof) new-kernel)))
      ((proof-in-impnc-intro-form)
       (make-proof-in-impnc-intro-form
	(proof-in-impnc-intro-form-to-avar proof)
	(intro-proof-and-new-kernel-and-depth-to-proof
	 (proof-in-impnc-intro-form-to-kernel proof) new-kernel)))
      ((proof-in-all-intro-form)
       (make-proof-in-all-intro-form
	(proof-in-all-intro-form-to-var proof)
	(intro-proof-and-new-kernel-and-depth-to-proof
	 (proof-in-all-intro-form-to-kernel proof) new-kernel)))
      ((proof-in-allnc-intro-form)
       (make-proof-in-allnc-intro-form
	(proof-in-allnc-intro-form-to-var proof)
	(intro-proof-and-new-kernel-and-depth-to-proof
	 (proof-in-allnc-intro-form-to-kernel proof) new-kernel)))
      (else new-kernel)))
   ((and (integer? (car x)) (not (negative? (car x))))
    (let ((n (car x)))
      (if
       (zero? n) new-kernel
       (case (tag proof)
	 ((proof-in-imp-intro-form)
	  (make-proof-in-imp-intro-form
	   (proof-in-imp-intro-form-to-avar proof)
	   (intro-proof-and-new-kernel-and-depth-to-proof
	    (proof-in-imp-intro-form-to-kernel proof) new-kernel (- n 1))))
	 ((proof-in-impnc-intro-form)
	  (make-proof-in-impnc-intro-form
	   (proof-in-impnc-intro-form-to-avar proof)
	   (intro-proof-and-new-kernel-and-depth-to-proof
	    (proof-in-impnc-intro-form-to-kernel proof) new-kernel (- n 1))))
	 ((proof-in-all-intro-form)
	  (make-proof-in-all-intro-form
	   (proof-in-all-intro-form-to-var proof)
	   (intro-proof-and-new-kernel-and-depth-to-proof
	    (proof-in-all-intro-form-to-kernel proof) new-kernel (- n 1))))
	 ((proof-in-allnc-intro-form)
	  (make-proof-in-allnc-intro-form
	   (proof-in-allnc-intro-form-to-var proof)
	   (intro-proof-and-new-kernel-and-depth-to-proof
	    (proof-in-allnc-intro-form-to-kernel proof) new-kernel (- n 1))))
	 (else new-kernel)))))))

; Constructors, accessors and test for implication eliminations:

(define (make-proof-in-imp-elim-form proof1 proof2)
  (list 'proof-in-imp-elim-form 
	(imp-form-to-conclusion (proof-to-formula proof1))
	proof1
	proof2))

(define proof-in-imp-elim-form-to-op caddr)
(define proof-in-imp-elim-form-to-arg cadddr)

(define (proof-in-imp-elim-form? proof)
  (eq? 'proof-in-imp-elim-form (tag proof)))

(define (proof-to-final-imp-elim-op proof)
  (if (proof-in-imp-elim-form? proof)
      (proof-to-final-imp-elim-op (proof-in-imp-elim-form-to-op proof))
      proof))

(define (proof-to-imp-elim-args proof)
  (if (proof-in-imp-elim-form? proof)
      (append (proof-to-imp-elim-args
	       (proof-in-imp-elim-form-to-op proof))
	      (list (proof-in-imp-elim-form-to-arg proof)))
      '()))

(define (make-proof-in-impnc-elim-form proof1 proof2)
  (list 'proof-in-impnc-elim-form 
	(impnc-form-to-conclusion (proof-to-formula proof1))
	proof1
	proof2))

(define proof-in-impnc-elim-form-to-op caddr)
(define proof-in-impnc-elim-form-to-arg cadddr)

(define (proof-in-impnc-elim-form? proof)
  (eq? 'proof-in-impnc-elim-form (tag proof)))

(define (proof-to-final-impnc-elim-op proof)
  (if (proof-in-impnc-elim-form? proof)
      (proof-to-final-impnc-elim-op (proof-in-impnc-elim-form-to-op proof))
      proof))

(define (proof-to-impnc-elim-args proof)
  (if (proof-in-impnc-elim-form? proof)
      (append (proof-to-impnc-elim-args
	       (proof-in-impnc-elim-form-to-op proof))
	      (list (proof-in-impnc-elim-form-to-arg proof)))
      '()))

(define (proof-in-imp-impnc-all-allnc-intro-form? proof)
  (or (proof-in-imp-intro-form? proof)
      (proof-in-impnc-intro-form? proof)
      (proof-in-all-intro-form? proof)
      (proof-in-allnc-intro-form? proof)))

(define (proof-in-imp-impnc-all-allnc-intro-form-to-var proof)
  (case (tag proof)
    ((proof-in-imp-intro-form)
     (proof-in-imp-intro-form-to-avar proof))
    ((proof-in-impnc-intro-form)
     (proof-in-impnc-intro-form-to-avar proof))
    ((proof-in-all-intro-form)
     (proof-in-all-intro-form-to-var proof))
    ((proof-in-allnc-intro-form)
     (proof-in-allnc-intro-form-to-var proof))
    (else (myerror "proof-in-imp-impnc-all-allnc-intro-form-to-var"
		   "unexpected proof with tag" (tag proof)))))

(define (proof-in-imp-impnc-all-allnc-intro-form-to-kernel proof)
  (case (tag proof)
    ((proof-in-imp-intro-form)
     (proof-in-imp-intro-form-to-kernel proof))
    ((proof-in-impnc-intro-form)
     (proof-in-impnc-intro-form-to-kernel proof))
    ((proof-in-all-intro-form)
     (proof-in-all-intro-form-to-kernel proof))
    ((proof-in-allnc-intro-form)
     (proof-in-allnc-intro-form-to-kernel proof))
    (else (myerror "proof-in-imp-impnc-all-allnc-intro-form-to-kernel"
		   "unexpected proof with tag" (tag proof)))))

(define (mk-proof-in-elim-form proof . elim-items)
  (if
   (null? elim-items)
   proof
   (let ((formula (unfold-formula (proof-to-formula proof))))
     (cond
      ((or (prime-form? formula)
	   (ex-form? formula)
	   (exnc-form? formula)
	   (exd-form? formula)
	   (exl-form? formula)
	   (exr-form? formula)
	   (exu-form? formula)
	   (exdt-form? formula) 
	   (exlt-form? formula)
	   (exrt-form? formula)
	   (exut-form? formula))
       (myerror "mk-proof-in-elim-form"
		"applicable formula expected" formula))
      ((imp-form? formula)
       (apply mk-proof-in-elim-form
	      (cons (make-proof-in-imp-elim-form proof (car elim-items))
		    (cdr elim-items))))
      ((impnc-form? formula)
       (apply mk-proof-in-elim-form
	      (cons (make-proof-in-impnc-elim-form proof (car elim-items))
		    (cdr elim-items))))
      ((and-form? formula)
       (cond ((eq? 'left (car elim-items))
	      (apply mk-proof-in-elim-form
		     (cons (make-proof-in-and-elim-left-form proof)
			   (cdr elim-items))))
	     ((eq? 'right (car elim-items))
	      (apply mk-proof-in-elim-form
		     (cons (make-proof-in-and-elim-right-form proof)
			   (cdr elim-items))))
	     (else (myerror "mk-proof-in-elim-form" "left or right expected"
			    (car elim-items)))))
      ((and (bicon-form? formula)
	    (memq (bicon-form-to-bicon formula)
		  '(andd andl andr andu)))
       (let ((left-conjunct (bicon-form-to-left formula))
	     (right-conjunct (bicon-form-to-right formula)))
	 (myerror "mk-proof-in-elim-form"
		  "not implemented for"
		  formula)))
      ((all-form? formula)
       (if (term-form? (car elim-items))
	   (apply mk-proof-in-elim-form
		  (cons (make-proof-in-all-elim-form proof (car elim-items))
			(cdr elim-items)))
	   (myerror "mk-proof-in-elim-form" "term expected"
		    (car elim-items))))
      ((allnc-form? formula)
       (if (term-form? (car elim-items))
	   (apply mk-proof-in-elim-form
		  (cons (make-proof-in-allnc-elim-form proof (car elim-items))
			(cdr elim-items)))
	   (myerror "mk-proof-in-elim-form" "term expected"
		    (car elim-items))))
      (else (myerror "mk-proof-in-elim-form" "formula expected" formula))))))

(define (proof-in-elim-form-to-final-op proof)
  (case (tag proof)
    ((proof-in-imp-elim-form)
     (proof-in-elim-form-to-final-op
      (proof-in-imp-elim-form-to-op proof)))
    ((proof-in-impnc-elim-form)
     (proof-in-elim-form-to-final-op
      (proof-in-impnc-elim-form-to-op proof)))
    ((proof-in-and-elim-left-form)
     (proof-in-elim-form-to-final-op
      (proof-in-and-elim-left-form-to-kernel proof)))
    ((proof-in-and-elim-right-form)
     (proof-in-elim-form-to-final-op
      (proof-in-and-elim-right-form-to-kernel proof)))
    ((proof-in-all-elim-form)
     (proof-in-elim-form-to-final-op
      (proof-in-all-elim-form-to-op proof)))
    ((proof-in-allnc-elim-form)
     (proof-in-elim-form-to-final-op
      (proof-in-allnc-elim-form-to-op proof)))
    (else proof)))

(define (proof-in-elim-form-to-args proof)
  (case (tag proof)
    ((proof-in-imp-elim-form)
     (append (proof-in-elim-form-to-args
	      (proof-in-imp-elim-form-to-op proof))
	     (list (proof-in-imp-elim-form-to-arg proof))))
    ((proof-in-impnc-elim-form)
     (append (proof-in-elim-form-to-args
	      (proof-in-impnc-elim-form-to-op proof))
	     (list (proof-in-impnc-elim-form-to-arg proof))))
    ((proof-in-and-elim-left-form)
     (append (proof-in-elim-form-to-args
	      (proof-in-and-elim-left-form-to-kernel proof))
	     (list 'left)))
    ((proof-in-and-elim-right-form)
     (append (proof-in-elim-form-to-args
	      (proof-in-and-elim-right-form-to-kernel proof))
	     (list 'right)))
    ((proof-in-all-elim-form)
     (append (proof-in-elim-form-to-args
	      (proof-in-all-elim-form-to-op proof))
	     (list (proof-in-all-elim-form-to-arg proof))))
    ((proof-in-allnc-elim-form)
     (append (proof-in-elim-form-to-args
	      (proof-in-allnc-elim-form-to-op proof))
	     (list (proof-in-allnc-elim-form-to-arg proof))))
    (else '())))

(define (proof-in-elim-form-to-final-op-and-args proof)
  (case (tag proof)
    ((proof-in-imp-elim-form)
     (append (proof-in-elim-form-to-final-op-and-args
	      (proof-in-imp-elim-form-to-op proof))
	     (list (proof-in-imp-elim-form-to-arg proof))))
    ((proof-in-impnc-elim-form)
     (append (proof-in-elim-form-to-final-op-and-args
	      (proof-in-impnc-elim-form-to-op proof))
	     (list (proof-in-impnc-elim-form-to-arg proof))))
    ((proof-in-and-elim-left-form)
     (append (proof-in-elim-form-to-final-op-and-args
	      (proof-in-and-elim-left-form-to-kernel proof))
	     (list 'left)))
    ((proof-in-and-elim-right-form)
     (append (proof-in-elim-form-to-final-op-and-args
	      (proof-in-and-elim-right-form-to-kernel proof))
	     (list 'right)))
    ((proof-in-all-elim-form)
     (append (proof-in-elim-form-to-final-op-and-args
	      (proof-in-all-elim-form-to-op proof))
	     (list (proof-in-all-elim-form-to-arg proof))))
    ((proof-in-allnc-elim-form)
     (append (proof-in-elim-form-to-final-op-and-args
	      (proof-in-allnc-elim-form-to-op proof))
	     (list (proof-in-allnc-elim-form-to-arg proof))))
    (else (list proof))))

; We need to generalize mk-proof-in-gen-elim-form, to also cover the
; case of Ex-Elim written in application notation.

(define (mk-proof-in-gen-elim-form proof . elim-items)
  (if
   (null? elim-items)
   proof
   (let ((formula (unfold-formula (proof-to-formula proof))))
     (case (tag formula)
       ((atom predicate)
	(myerror "mk-proof-in-gen-elim-form" "applicable formula expected"
		 formula))
       ((ex)
	(let* ((side-premise (car elim-items))
	       (concl (imp-form-to-conclusion
		       (all-form-to-kernel
			(proof-to-formula side-premise))))
	       (ex-elim-aconst
		(ex-formula-and-concl-to-ex-elim-aconst formula concl))
	       (free (union (formula-to-free formula) (formula-to-free concl)))
	       (free-terms (map make-term-in-var-form free)))
	  (apply mk-proof-in-gen-elim-form
		 (cons (make-proof-in-aconst-form ex-elim-aconst)
		       (append free-terms elim-items)))))
       ((exnc)
	(let* ((side-premise (car elim-items))
	       (concl (imp-form-to-conclusion
		       (all-form-to-kernel
			(proof-to-formula side-premise))))
	       (exnc-elim-aconst
		(exnc-formula-and-concl-to-exnc-elim-aconst formula concl))
	       (free (union (formula-to-free formula) (formula-to-free concl)))
	       (free-terms (map make-term-in-var-form free)))
	  (apply mk-proof-in-gen-elim-form
		 (cons (make-proof-in-aconst-form exnc-elim-aconst)
		       (append free-terms elim-items)))))
       ((imp)
	(apply mk-proof-in-gen-elim-form
	       (cons (make-proof-in-imp-elim-form proof (car elim-items))
		     (cdr elim-items))))
       ((impnc)
	(apply mk-proof-in-gen-elim-form
	       (cons (make-proof-in-impnc-elim-form proof (car elim-items))
		     (cdr elim-items))))
       ((and)
	(cond ((eq? 'left (car elim-items))
	       (apply mk-proof-in-gen-elim-form
		      (cons (make-proof-in-and-elim-left-form proof)
			    (cdr elim-items))))
	      ((eq? 'right (car elim-items))
	       (apply mk-proof-in-gen-elim-form
		      (cons (make-proof-in-and-elim-right-form proof)
			    (cdr elim-items))))
	      (else (myerror "mk-proof-in-gen-elim-form"
			     "left or right expected"
			     (car elim-items)))))
       ((all)
	(if (term-form? (car elim-items))
	    (apply mk-proof-in-gen-elim-form
		   (cons (make-proof-in-all-elim-form proof (car elim-items))
			 (cdr elim-items)))
	    (myerror "mk-proof-in-gen-elim-form" "term expected"
		     (car elim-items))))
       ((allnc)
	(if (term-form? (car elim-items))
	    (apply mk-proof-in-gen-elim-form
		   (cons (make-proof-in-allnc-elim-form proof (car elim-items))
			 (cdr elim-items)))
	    (myerror "mk-proof-in-gen-elim-form" "term expected"
		     (car elim-items))))
       (else (myerror "mk-proof-in-gen-elim-form" "formula expected"
		      formula))))))

; We generalize proof-in-elim-form-to-final-op and
; proof-in-elim-form-to-args to treat Ex-Elim axioms as if they
; were rules in application notation.  

(define (proof-in-gen-elim-form-to-final-op proof)
  (case (tag 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)))
       (if (and (proof-in-aconst-form? op)
		(string=? "Ex-Elim" (aconst-to-name
				     (proof-in-aconst-form-to-aconst op))))
	   (proof-in-gen-elim-form-to-final-op arg)
	   (proof-in-gen-elim-form-to-final-op op))))
    ((proof-in-impnc-elim-form)
     (let ((op (proof-in-impnc-elim-form-to-op proof))
	   (arg (proof-in-impnc-elim-form-to-arg proof)))
       (if (and (proof-in-aconst-form? op)
		(string=? "Ex-Elim" (aconst-to-name
				     (proof-in-aconst-form-to-aconst op))))
	   (proof-in-gen-elim-form-to-final-op arg)
	   (proof-in-gen-elim-form-to-final-op op))))
    ((proof-in-and-elim-left-form)
     (let ((kernel (proof-in-and-elim-left-form-to-kernel proof)))
       (proof-in-gen-elim-form-to-final-op kernel)))
    ((proof-in-and-elim-right-form)
     (let ((kernel (proof-in-and-elim-right-form-to-kernel proof)))
       (proof-in-gen-elim-form-to-final-op kernel)))
    ((proof-in-all-elim-form)
     (let ((op (proof-in-all-elim-form-to-op proof)))
       (proof-in-gen-elim-form-to-final-op op)))
    ((proof-in-allnc-elim-form)
     (let ((op (proof-in-allnc-elim-form-to-op proof)))
       (proof-in-gen-elim-form-to-final-op op)))
    (else proof)))

(define (proof-in-gen-elim-form-to-args proof)
  (case (tag 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)))
       (if (and (proof-in-aconst-form? op)
		(string=? "Ex-Elim" (aconst-to-name
				     (proof-in-aconst-form-to-aconst op))))
	   (proof-in-gen-elim-form-to-args arg)
	   (append (proof-in-gen-elim-form-to-args op) (list arg)))))
    ((proof-in-impnc-elim-form)
     (let ((op (proof-in-impnc-elim-form-to-op proof))
	   (arg (proof-in-impnc-elim-form-to-arg proof)))
       (if (and (proof-in-aconst-form? op)
		(string=? "Ex-Elim" (aconst-to-name
				     (proof-in-aconst-form-to-aconst op))))
	   (proof-in-gen-elim-form-to-args arg)
	   (append (proof-in-gen-elim-form-to-args op) (list arg)))))
    ((proof-in-and-elim-left-form)
     (append (proof-in-gen-elim-form-to-args
	      (proof-in-and-elim-left-form-to-kernel proof))
	     (list 'left)))
    ((proof-in-and-elim-right-form)
     (append (proof-in-gen-elim-form-to-args
	      (proof-in-and-elim-right-form-to-kernel proof))
	     (list 'right)))
    ((proof-in-all-elim-form)
     (append (proof-in-gen-elim-form-to-args
	      (proof-in-all-elim-form-to-op proof))
	     (list (proof-in-all-elim-form-to-arg proof))))
    ((proof-in-allnc-elim-form)
     (append (proof-in-gen-elim-form-to-args
	      (proof-in-allnc-elim-form-to-op proof))
	     (list (proof-in-allnc-elim-form-to-arg proof))))
    (else '())))

; Constructors, accessors and test for and introduction:

(define (make-proof-in-and-intro-form proof1 proof2)
  (list 'proof-in-and-intro-form
	(make-and (proof-to-formula proof1) (proof-to-formula proof2))
	proof1
	proof2))

(define proof-in-and-intro-form-to-left caddr)
(define proof-in-and-intro-form-to-right cadddr)

(define (proof-in-and-intro-form? proof)
  (eq? 'proof-in-and-intro-form (tag proof)))

(define (mk-proof-in-and-intro-form proof . proofs)
  (if
   (null? proofs)
   proof
   (let ((last-proof (car (last-pair proofs)))
	 (init-proofs (reverse (cdr (reverse proofs)))))
     (make-proof-in-and-intro-form
      (apply mk-proof-in-and-intro-form (cons proof init-proofs))
      last-proof))))

; Constructors, accessors and test for the left and right and elimination:

(define (make-proof-in-and-elim-left-form proof)
  (let ((formula (proof-to-formula proof)))
    (if (and-form? formula)
	(list 'proof-in-and-elim-left-form
	      (and-form-to-left formula)
	      proof)
	(myerror "make-proof-in-and-elim-left-form" "and form expected"
		 formula))))

(define proof-in-and-elim-left-form-to-kernel caddr)

(define (proof-in-and-elim-left-form? proof)
  (eq? 'proof-in-and-elim-left-form (tag proof)))

(define (make-proof-in-and-elim-right-form proof)
  (let ((formula (proof-to-formula proof)))
    (if (and-form? formula)
	(list 'proof-in-and-elim-right-form
	      (and-form-to-right formula)
	      proof)
	(myerror "make-proof-in-and-elim-right-form" "and form expected"
		 formula))))

(define proof-in-and-elim-right-form-to-kernel caddr)

(define (proof-in-and-elim-right-form? proof)
  (eq? 'proof-in-and-elim-right-form (tag proof)))

; Constructors, accessors and test for all introduction:

(define (make-proof-in-all-intro-form var proof)
  (list 'proof-in-all-intro-form
	(make-all var (proof-to-formula proof))
	var
	proof))

(define proof-in-all-intro-form-to-var caddr)
(define proof-in-all-intro-form-to-kernel cadddr)

(define (proof-in-all-intro-form? proof)
  (eq? 'proof-in-all-intro-form (tag proof)))

; Constructors, accessors and test for all elimination:

(define (make-proof-in-all-elim-form proof term . conclusion)
  (if (null? conclusion)
      (let* ((formula (proof-to-formula proof))
	     (var (all-form-to-var formula))
	     (kernel (all-form-to-kernel formula)))
	(list 'proof-in-all-elim-form
	      (if (and (term-in-var-form? term)
		       (equal? var (term-in-var-form-to-var term)))
		  kernel	      
		  (formula-subst kernel var term))
	      proof
	      term))
      (list 'proof-in-all-elim-form
	    (car conclusion)
	    proof
	    term)))

(define proof-in-all-elim-form-to-op caddr)
(define proof-in-all-elim-form-to-arg cadddr)

(define (proof-in-all-elim-form? proof)
  (eq? 'proof-in-all-elim-form (tag proof)))

(define (proof-to-final-all-elim-op proof)
  (if (proof-in-all-elim-form? proof)
      (proof-to-final-all-elim-op (proof-in-all-elim-form-to-op proof))
      proof))

; Constructors, accessors and test for allnc introduction:

(define (make-proof-in-allnc-intro-form var proof)
  (list 'proof-in-allnc-intro-form
	(make-allnc var (proof-to-formula proof))
	var
	proof))

(define proof-in-allnc-intro-form-to-var caddr)
(define proof-in-allnc-intro-form-to-kernel cadddr)

(define (proof-in-allnc-intro-form? proof)
  (eq? 'proof-in-allnc-intro-form (tag proof)))

; Constructors, accessors and test for allnc-elimination:

(define (make-proof-in-allnc-elim-form proof term . conclusion)
  (if (null? conclusion)
      (let* ((formula (proof-to-formula proof))
	     (var (allnc-form-to-var formula))
	     (kernel (allnc-form-to-kernel formula)))
	(list 'proof-in-allnc-elim-form
	      (if (and (term-in-var-form? term)
		       (equal? var (term-in-var-form-to-var term)))
		  kernel	      
		  (formula-subst kernel var term))
	      proof
	      term))
      (list 'proof-in-allnc-elim-form
	    (car conclusion)
	    proof
	    term)))

(define proof-in-allnc-elim-form-to-op caddr)
(define proof-in-allnc-elim-form-to-arg cadddr)

(define (proof-in-allnc-elim-form? proof)
  (eq? 'proof-in-allnc-elim-form (tag proof)))

(define (proof-to-final-allnc-elim-op proof)
  (if (proof-in-allnc-elim-form? proof)
      (proof-to-final-allnc-elim-op (proof-in-allnc-elim-form-to-op proof))
      proof))

(define (proof-to-final-allnc-elim-op-and-args proof)
  (if (proof-in-allnc-elim-form? proof)
      (let* ((op (proof-in-allnc-elim-form-to-op proof))
	     (arg (proof-in-allnc-elim-form-to-arg proof))
	     (prev (proof-to-final-allnc-elim-op-and-args op)))
	(cons (car prev) (append (cdr prev) (list arg))))
      (list proof)))

; Sometimes it is useful to have a replacement to the ex-intro rule:

(define (make-proof-in-ex-intro-form term ex-formula proof-of-inst)
  (let* ((var (ex-form-to-var ex-formula))
	 (kernel (ex-form-to-kernel ex-formula))
	 (free (formula-to-free ex-formula)))
    (apply mk-proof-in-elim-form
	   (append (list (make-proof-in-aconst-form
			  (ex-formula-to-ex-intro-aconst ex-formula)))
		   (map make-term-in-var-form free)
		   (list term proof-of-inst)))))

(define (mk-proof-in-ex-intro-form . terms-and-ex-formula-and-proof-of-inst)
  (let* ((revargs (reverse terms-and-ex-formula-and-proof-of-inst))
	 (proof-of-inst
	  (if (pair? revargs)
	      (car revargs)
	      (myerror "mk-proof-in-ex-intro-form" "arguments expected")))
	 (ex-formula
	  (if (pair? (cdr revargs))
	      (cadr revargs)
	      (myerror "mk-proof-in-ex-intro-form" ">= 2 arguments expected"
		       terms-and-ex-formula-and-proof-of-inst)))
	 (terms (reverse (cddr revargs))))
    (if
     (null? terms)
     proof-of-inst
     (let* ((var (ex-form-to-var ex-formula))
	    (kernel (ex-form-to-kernel ex-formula))
	    (free (formula-to-free ex-formula))
	    (prev (apply mk-proof-in-ex-intro-form
			 (append (cdr terms)
				 (list (formula-subst kernel var (car terms))
				       proof-of-inst)))))
       (apply mk-proof-in-elim-form
	      (append (list (make-proof-in-aconst-form
			     (ex-formula-to-ex-intro-aconst ex-formula)))
		      (map make-term-in-var-form free)
		      (list (car terms) prev)))))))

(define (proof-in-ind-rule-form? proof)
  (let ((final-imp-op (proof-to-final-imp-elim-op proof))
        (arglength (length (proof-to-imp-elim-args proof))))
    (and
     (proof-in-all-elim-form? final-imp-op)
     (let ((final-op (proof-to-final-allnc-elim-op
		      (proof-in-all-elim-form-to-op final-imp-op))))
       (and (proof-in-aconst-form? final-op)
	    (string=? "Ind" (aconst-to-name
			     (proof-in-aconst-form-to-aconst final-op)))
	    (let* ((uninst-kernel (all-form-to-kernel
				   (aconst-to-uninst-formula
				    (proof-in-aconst-form-to-aconst
				     final-op))))
		   (indlength (length (imp-form-to-premises uninst-kernel))))
	      (= indlength arglength)))))))

(define (proof-in-cases-rule-form? proof)
  (let ((final-imp-op (proof-to-final-imp-elim-op proof))
        (arglength (length (proof-to-imp-elim-args proof))))
    (and
     (proof-in-all-elim-form? final-imp-op)
     (let ((final-op (proof-to-final-allnc-elim-op
		      (proof-in-all-elim-form-to-op final-imp-op))))
       (and (proof-in-aconst-form? final-op)
	    (string=? "Cases" (aconst-to-name
			       (proof-in-aconst-form-to-aconst final-op)))
	    (let* ((uninst-kernel (all-form-to-kernel
				   (aconst-to-uninst-formula
				    (proof-in-aconst-form-to-aconst
				     final-op))))
		   (caseslength (length (imp-form-to-premises uninst-kernel))))
	      (= caseslength arglength)))))))

(define (proof-in-ex-elim-rule-form? proof)
  (and (proof-in-imp-elim-form? proof)
       (let ((op1 (proof-in-imp-elim-form-to-op proof))
	     (arg1 (proof-in-imp-elim-form-to-arg proof)))
	 (and (all-form? (proof-to-formula arg1))
	      (proof-in-imp-elim-form? op1)
	      (let ((op2 (proof-in-imp-elim-form-to-op op1))
		    (arg2 (proof-in-imp-elim-form-to-arg op1)))
		(and (ex-form? (proof-to-formula arg2))
		     (let ((final-op (proof-to-final-allnc-elim-op op2)))
		       (and (proof-in-aconst-form? final-op)
			    (string=? "Ex-Elim"
				      (aconst-to-name
				       (proof-in-aconst-form-to-aconst
					final-op)))))))))))

(define (proof-in-exnc-elim-rule-form? proof)
  (and (proof-in-imp-elim-form? proof)
       (let ((op1 (proof-in-imp-elim-form-to-op proof))
	     (arg1 (proof-in-imp-elim-form-to-arg proof)))
	 (and (allnc-form? (proof-to-formula arg1))
	      (proof-in-imp-elim-form? op1)
	      (let ((op2 (proof-in-imp-elim-form-to-op op1))
		    (arg2 (proof-in-imp-elim-form-to-arg op1)))
		(and (exnc-form? (proof-to-formula arg2))
		     (let ((final-op (proof-to-final-allnc-elim-op op2)))
		       (and (proof-in-aconst-form? final-op)
			    (string=? "Exnc-Elim"
				      (aconst-to-name
				       (proof-in-aconst-form-to-aconst
					final-op)))))))))))

; Sometimes it is useful to have a replacement to the exnc-intro rule:

(define (make-proof-in-exnc-intro-form term exnc-formula proof-of-inst)
  (let* ((var (exnc-form-to-var exnc-formula))
	 (kernel (exnc-form-to-kernel exnc-formula))
	 (free (formula-to-free exnc-formula)))
    (apply mk-proof-in-elim-form
	   (append (list (make-proof-in-aconst-form
			  (exnc-formula-to-exnc-intro-aconst exnc-formula)))
		   (map make-term-in-var-form free)
		   (list term proof-of-inst)))))

(define (mk-proof-in-exnc-intro-form .
				     terms-and-exnc-formula-and-proof-of-inst)
  (let* ((revargs (reverse terms-and-exnc-formula-and-proof-of-inst))
	 (proof-of-inst
	  (if (pair? revargs)
	      (car revargs)
	      (myerror "mk-proof-in-exnc-intro-form" "arguments expected")))
	 (exnc-formula
	  (if (pair? (cdr revargs))
	      (cadr revargs)
	      (myerror "mk-proof-in-exnc-intro-form" ">= 2 arguments expected"
		       terms-and-exnc-formula-and-proof-of-inst)))
	 (terms (reverse (cddr revargs))))
    (if
     (null? terms)
     proof-of-inst
     (let* ((var (exnc-form-to-var exnc-formula))
	    (kernel (exnc-form-to-kernel exnc-formula))
	    (free (formula-to-free exnc-formula))
	    (prev (apply mk-proof-in-exnc-intro-form
			 (append (cdr terms)
				 (list (formula-subst kernel var (car terms))
				       proof-of-inst)))))
       (apply mk-proof-in-elim-form
	      (append (list (make-proof-in-aconst-form
			     (exnc-formula-to-exnc-intro-aconst exnc-formula)))
		      (map make-term-in-var-form free)
		      (list (car terms) prev)))))))

(define (proof-form? x)
  (and (pair? x)
       (memq (tag x) '(proof-in-avar-form
		       proof-in-aconst-form
		       proof-in-imp-intro-form
		       proof-in-imp-elim-form
		       proof-in-impnc-intro-form
		       proof-in-impnc-elim-form
		       proof-in-and-intro-form
		       proof-in-and-elim-left-form
		       proof-in-and-elim-right-form
		       proof-in-all-intro-form
		       proof-in-all-elim-form
		       proof-in-allnc-intro-form
		       proof-in-allnc-elim-form))))

; To define alpha-equality for proofs we use (following Robert Staerk)
; an auxiliary function (corr x y alist alistrev).  Here
; alist = ((u1 v1) ... (un vn)), alistrev = ((v1 u1) ... (vn un)).

; (corr-avar x y alist alistrev) iff one of the following holds.
; 1. There is a first entry (x v) of the form (x _) in alist
;    and a first entry (y u) of the form (y _) in alistrev,
;    and we have v=y and u=x.
; 2. There is no entry of the form (x _) in alist
;    and no entry of the form (y _) in alistrev,
;    and we have x=y.

(define (corr-avar x y alist alistrev)
  (let ((info-x (assoc-wrt avar-form? x alist))
        (info-y (assoc-wrt avar-form? y alistrev)))
    (if info-x
	(and (avar=? (car info-x) (cadr info-y))
	     (avar=? (car info-y) (cadr info-x)))
	(and (not info-y) (avar=? x y)))))

(define (proof=? proof1 proof2)
  (proof=-aux? proof1 proof2 '() '()))

(define (proofs=? proofs1 proofs2)
  (proofs=-aux? proofs1 proofs2 '() '()))

(define (proof=-aux? proof1 proof2 alist alistrev)
  (or (and (proof-in-avar-form? proof1) (proof-in-avar-form? proof2)
           (corr (proof-in-avar-form-to-avar proof1)
		 (proof-in-avar-form-to-avar proof2)
		 alist alistrev))
      (and (proof-in-aconst-form? proof1) (proof-in-aconst-form? proof2)
	   (aconst=? (proof-in-aconst-form-to-aconst proof1)
		     (proof-in-aconst-form-to-aconst proof2)))
      (and (proof-in-imp-intro-form? proof1) (proof-in-imp-intro-form? proof2)
           (let ((avar1 (proof-in-imp-intro-form-to-avar proof1))
		 (avar2 (proof-in-imp-intro-form-to-avar proof2))
		 (kernel1 (proof-in-imp-intro-form-to-kernel proof1))
		 (kernel2 (proof-in-imp-intro-form-to-kernel proof2)))
             (proof=-aux? kernel1 kernel2
			  (cons (list avar1 avar2) alist)
			  (cons (list avar2 avar1) alistrev))))
      (and (proof-in-imp-elim-form? proof1) (proof-in-imp-elim-form? proof2)
           (let ((op1 (proof-in-imp-elim-form-to-op proof1))
                 (op2 (proof-in-imp-elim-form-to-op proof2))
                 (arg1 (proof-in-imp-elim-form-to-arg proof1))
                 (arg2 (proof-in-imp-elim-form-to-arg proof2)))
             (and (proof=-aux? op1 op2 alist alistrev)
                  (proof=-aux? arg1 arg2 alist alistrev))))
      (and (proof-in-impnc-intro-form? proof1)
	   (proof-in-impnc-intro-form? proof2)
           (let ((avar1 (proof-in-impnc-intro-form-to-avar proof1))
		 (avar2 (proof-in-impnc-intro-form-to-avar proof2))
		 (kernel1 (proof-in-impnc-intro-form-to-kernel proof1))
		 (kernel2 (proof-in-impnc-intro-form-to-kernel proof2)))
             (proof=-aux? kernel1 kernel2
			  (cons (list avar1 avar2) alist)
			  (cons (list avar2 avar1) alistrev))))
      (and (proof-in-impnc-elim-form? proof1)
	   (proof-in-impnc-elim-form? proof2)
           (let ((op1 (proof-in-impnc-elim-form-to-op proof1))
                 (op2 (proof-in-impnc-elim-form-to-op proof2))
                 (arg1 (proof-in-impnc-elim-form-to-arg proof1))
                 (arg2 (proof-in-impnc-elim-form-to-arg proof2)))
             (and (proof=-aux? op1 op2 alist alistrev)
                  (proof=-aux? arg1 arg2 alist alistrev))))
      (and (proof-in-and-intro-form? proof1) (proof-in-and-intro-form? proof2)
           (let ((left1 (proof-in-and-intro-form-to-left proof1))
                 (left2 (proof-in-and-intro-form-to-left proof2))
                 (right1 (proof-in-and-intro-form-to-right proof1))
                 (right2 (proof-in-and-intro-form-to-right proof2)))
             (and (proof=-aux? left1 left2 alist alistrev)
                  (proof=-aux? right1 right2 alist alistrev))))
      (and (proof-in-and-elim-left-form? proof1)
	   (proof-in-and-elim-left-form? proof2)
           (let ((kernel1 (proof-in-and-elim-left-form-to-kernel proof1))
                 (kernel2 (proof-in-and-elim-left-form-to-kernel proof2)))
	     (proof=-aux? kernel1 kernel2 alist alistrev)))
      (and (proof-in-and-elim-right-form? proof1)
	   (proof-in-and-elim-right-form? proof2)
           (let ((kernel1 (proof-in-and-elim-right-form-to-kernel proof1))
                 (kernel2 (proof-in-and-elim-right-form-to-kernel proof2)))
	     (proof=-aux? kernel1 kernel2 alist alistrev)))
      (and (proof-in-all-intro-form? proof1) (proof-in-all-intro-form? proof2)
           (let ((var1 (proof-in-all-intro-form-to-var proof1))
		 (var2 (proof-in-all-intro-form-to-var proof2))
		 (kernel1 (proof-in-all-intro-form-to-kernel proof1))
		 (kernel2 (proof-in-all-intro-form-to-kernel proof2)))
             (proof=-aux? kernel1 kernel2
			  (cons (list var1 var2) alist)
			  (cons (list var2 var1) alistrev))))
      (and (proof-in-all-elim-form? proof1) (proof-in-all-elim-form? proof2)
           (let ((op1 (proof-in-all-elim-form-to-op proof1))
                 (op2 (proof-in-all-elim-form-to-op proof2))
                 (arg1 (proof-in-all-elim-form-to-arg proof1))
                 (arg2 (proof-in-all-elim-form-to-arg proof2)))
             (and (proof=-aux? op1 op2 alist alistrev)
                  (term=-aux? arg1 arg2 alist alistrev))))
      (and (proof-in-allnc-intro-form? proof1)
	   (proof-in-allnc-intro-form? proof2)
           (let ((var1 (proof-in-allnc-intro-form-to-var proof1))
		 (var2 (proof-in-allnc-intro-form-to-var proof2))
		 (kernel1 (proof-in-allnc-intro-form-to-kernel proof1))
		 (kernel2 (proof-in-allnc-intro-form-to-kernel proof2)))
             (proof=-aux? kernel1 kernel2
			  (cons (list var1 var2) alist)
			  (cons (list var2 var1) alistrev))))
      (and (proof-in-allnc-elim-form? proof1)
	   (proof-in-allnc-elim-form? proof2)
           (let ((op1 (proof-in-allnc-elim-form-to-op proof1))
                 (op2 (proof-in-allnc-elim-form-to-op proof2))
                 (arg1 (proof-in-allnc-elim-form-to-arg proof1))
                 (arg2 (proof-in-allnc-elim-form-to-arg proof2)))
             (and (proof=-aux? op1 op2 alist alistrev)
                  (term=-aux? arg1 arg2 alist alistrev))))))

(define (proofs=-aux? proofs1 proofs2 alist alistrev)
  (or (and (null? proofs1) (null? proofs2))
      (and (proof=-aux? (car proofs1) (car proofs2) alist alistrev)
           (proofs=-aux? (cdr proofs1) (cdr proofs2) alist alistrev))))

; For efficiency reasons (when working with goal in interactive proof
; development) it will be useful to optionally allow the context in a
; proof.

(define (proof-with-context? proof)
  (case (tag proof)
    ((proof-in-avar-form
      proof-in-aconst-form
      proof-in-and-elim-left-form
      proof-in-and-elim-right-form)
     (pair? (cdddr proof)))
    ((proof-in-imp-intro-form
      proof-in-imp-elim-form
      proof-in-impnc-intro-form
      proof-in-impnc-elim-form
      proof-in-and-intro-form
      proof-in-all-intro-form
      proof-in-all-elim-form
      proof-in-allnc-intro-form
      proof-in-allnc-elim-form)
     (pair? (cddddr proof)))
    (else (myerror "proof-with-context?" "proof tag expected" (tag proof)))))

(define (proof-with-context-to-context proof)
  (case (tag proof)
    ((proof-in-avar-form
      proof-in-aconst-form
      proof-in-and-elim-left-form
      proof-in-and-elim-right-form)
     (car (cdddr proof)))
    ((proof-in-imp-intro-form
      proof-in-imp-elim-form
      proof-in-impnc-intro-form
      proof-in-impnc-elim-form
      proof-in-and-intro-form
      proof-in-all-intro-form
      proof-in-all-elim-form
      proof-in-allnc-intro-form
      proof-in-allnc-elim-form)
     (car (cddddr proof)))
    (else (myerror "proof-with-context-to-context" "proof tag expected"
		   (tag proof)))))

(define (context-item=? x y)
  (or (and (var-form? x) (var-form? y) (equal? x y))
      (and (avar-form? x) (avar-form? y) (avar=? x y))))

(define (proof-to-context proof)
  (if
   (proof-with-context? proof)
   (proof-with-context-to-context proof)
   (case (tag proof)
     ((proof-in-avar-form)
      (let ((avar (proof-in-avar-form-to-avar proof)))
	(append (formula-to-free (avar-to-formula avar)) (list avar))))
     ((proof-in-aconst-form) '())
     ((proof-in-imp-intro-form)
      (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	     (kernel (proof-in-imp-intro-form-to-kernel proof))
	     (context (proof-to-context kernel)))
	(remove-wrt avar=? avar context)))       
     ((proof-in-imp-elim-form)
      (let ((context1 (proof-to-context (proof-in-imp-elim-form-to-op proof)))
	    (context2 (proof-to-context
		       (proof-in-imp-elim-form-to-arg proof))))
	(union-wrt context-item=? context1 context2)))
     ((proof-in-impnc-intro-form)
      (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	     (kernel (proof-in-impnc-intro-form-to-kernel proof))
	     (context (proof-to-context kernel)))
	(remove-wrt avar=? avar context)))       
     ((proof-in-impnc-elim-form)
      (let ((context1
	     (proof-to-context (proof-in-impnc-elim-form-to-op proof)))
	    (context2
	     (proof-to-context (proof-in-impnc-elim-form-to-arg proof))))
	(union-wrt context-item=? context1 context2)))
     ((proof-in-and-intro-form)
      (union-wrt context-item=?
		 (proof-to-context (proof-in-and-intro-form-to-left proof))
		 (proof-to-context (proof-in-and-intro-form-to-right proof))))
     ((proof-in-and-elim-left-form)
      (proof-to-context (proof-in-and-elim-left-form-to-kernel proof)))
     ((proof-in-and-elim-right-form)
      (proof-to-context (proof-in-and-elim-right-form-to-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))
	     (context (proof-to-context kernel)))
	(remove var context)))       
     ((proof-in-all-elim-form)
      (let ((context (proof-to-context (proof-in-all-elim-form-to-op proof)))
	    (free (term-to-free (proof-in-all-elim-form-to-arg proof))))
	(union context free)))
     ((proof-in-allnc-intro-form)
      (let* ((var (proof-in-allnc-intro-form-to-var proof))
	     (kernel (proof-in-allnc-intro-form-to-kernel proof))
	     (context (proof-to-context kernel)))
	(remove var context)))       
     ((proof-in-allnc-elim-form)
      (let ((context (proof-to-context (proof-in-allnc-elim-form-to-op proof)))
	    (free (term-to-free (proof-in-allnc-elim-form-to-arg proof))))
	(union context free)))
     (else (myerror "proof-to-context" "proof tag expected" (tag proof))))))

(define (proof-to-context-wrt avar-eq proof)
  (case (tag proof)
    ((proof-in-avar-form)
     (let ((avar (proof-in-avar-form-to-avar proof)))
       (append (formula-to-free (avar-to-formula avar)) (list avar))))
    ((proof-in-aconst-form) '())
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (kernel (proof-in-imp-intro-form-to-kernel proof))
	    (context (proof-to-context-wrt avar-eq kernel)))
       (remove-wrt avar-eq avar context)))       
    ((proof-in-imp-elim-form)
     (let ((context1 (proof-to-context-wrt
		      avar-eq (proof-in-imp-elim-form-to-op proof)))
	   (context2 (proof-to-context-wrt
		      avar-eq (proof-in-imp-elim-form-to-arg proof))))
       (union-wrt context-item-full=? context1 context2)))
    ((proof-in-impnc-intro-form)
     (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (context (proof-to-context-wrt avar-eq kernel)))
       (remove-wrt avar-eq avar context)))       
    ((proof-in-impnc-elim-form)
     (let ((context1 (proof-to-context-wrt
		      avar-eq (proof-in-impnc-elim-form-to-op proof)))
	   (context2 (proof-to-context-wrt
		      avar-eq (proof-in-impnc-elim-form-to-arg proof))))
       (union-wrt context-item-full=? context1 context2)))
    ((proof-in-and-intro-form)
     (union-wrt context-item-full=?
		(proof-to-context-wrt
		 avar-eq (proof-in-and-intro-form-to-left proof))
		(proof-to-context-wrt
		 avar-eq (proof-in-and-intro-form-to-right proof))))
    ((proof-in-and-elim-left-form)
     (proof-to-context-wrt
      avar-eq (proof-in-and-elim-left-form-to-kernel proof)))
    ((proof-in-and-elim-right-form)
     (proof-to-context-wrt
      avar-eq (proof-in-and-elim-right-form-to-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))
	    (context (proof-to-context-wrt avar-eq kernel)))
       (remove var context)))       
    ((proof-in-all-elim-form)
     (let ((context (proof-to-context-wrt
		     avar-eq (proof-in-all-elim-form-to-op proof)))
	   (free (term-to-free (proof-in-all-elim-form-to-arg proof))))
       (union context free)))
    ((proof-in-allnc-intro-form)
     (let* ((var (proof-in-allnc-intro-form-to-var proof))
	    (kernel (proof-in-allnc-intro-form-to-kernel proof))
	    (context (proof-to-context-wrt avar-eq kernel)))
       (remove var context)))       
    ((proof-in-allnc-elim-form)
     (let ((context (proof-to-context-wrt
		     avar-eq (proof-in-allnc-elim-form-to-op proof)))
	   (free (term-to-free (proof-in-allnc-elim-form-to-arg proof))))
       (union context free)))
    (else (myerror "proof-to-context-wrt" "proof tag expected"
		   (tag proof)))))

(define (context-to-vars context)
  (do ((l context (cdr l))
       (res '() (if (avar-form? (car l)) res (cons (car l) res))))
      ((null? l) (reverse res))))

(define (context-to-avars context)
  (do ((l context (cdr l))
       (res '() (if (avar-form? (car l)) (cons (car l) res) res)))
      ((null? l) (reverse res))))

(define (context=? context1 context2)
  (if (= (length context1) (length context2))
      (let context=?-aux ((c1 context1) (c2 context2))
	(if (null? c1)
	    #t
	    (let ((x1 (car c1))
		  (rest1 (cdr c1))
		  (x2 (car c2))
		  (rest2 (cdr c2)))
	      (if (context-item=? x1 x2)
		  (context=?-aux rest1 rest2)
		  #f))))
      #f))

(define (context-item-full=? x y)
  (or (and (var-form? x) (var-form? y) (equal? x y))
      (and (avar-form? x) (avar-form? y) (avar-full=? x y))))

(define (context-full=? context1 context2)
  (and (null? (context-fullminus context1 context2))
       (null? (context-fullminus context2 context1))))

(define (context-fullminus context1 context2)
  (do ((l context2 (cdr l))
       (res context1 (remove-wrt context-item-full=? (car l) res)))
      ((null? l) res)))

(define (pp-context context)
  (do ((c context (cdr c))
       (i 1 (if (avar-form? (car c)) (+ 1 i) i))
       (line "" line))
      ((null? c) (if (> (string-length line) 0) 
		     (begin (display-comment line) (newline))))
    (if (avar-form? (car c))
	(let* ((string (string-append (avar-to-name (car c)) "_"
				      (number-to-string i))))
	  (set! line (string-append line "  " string ":"))
	  (if (> (* 3 (string-length line)) pp-width)
	      (begin
		(display-comment line)
		(newline)
		(set! line "    ")))
	  (set! line (string-append 
		      line 
		      (pretty-print-string
		       (string-length line)
		       (- pp-width (string-length COMMENT-STRING))
		       (fold-formula (avar-to-formula (car c))))))
	  (if (pair? (cdr c))
	      (begin (display-comment line) (newline)
		     (set! line ""))))
	(let* ((var (car c))
	       (varstring (var-to-string var)))
	  (set! line (string-append line "  " varstring))))))

; We use acproof to mean proof-with-avar-contexts.  An acproof is a
; proof in the sense of check-and-display-proof.  It is used to avoid
; recomputation of avar-contexts when pruning.

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

(define (make-acproof-in-aconst-form aconst)
  (list 'proof-in-aconst-form (aconst-to-formula aconst) aconst '()))

(define (make-acproof-in-imp-intro-form avar proof)
  (list 'proof-in-imp-intro-form
	(make-imp (avar-to-formula avar) (proof-to-formula proof))
	avar
	proof
	(remove-wrt avar=? avar (proof-with-context-to-context proof))))

(define (make-acproof-in-imp-elim-form proof1 proof2)
  (list 'proof-in-imp-elim-form 
	(imp-form-to-conclusion (proof-to-formula proof1))
	proof1
	proof2
	(union-wrt avar=?
		   (proof-to-context proof1) (proof-to-context proof2))))

(define (make-acproof-in-impnc-intro-form avar proof)
  (list 'proof-in-impnc-intro-form
	(make-impnc (avar-to-formula avar) (proof-to-formula proof))
	avar
	proof
	(remove-wrt avar=? avar (proof-with-context-to-context proof))))

(define (make-acproof-in-impnc-elim-form proof1 proof2)
  (list 'proof-in-impnc-elim-form 
	(impnc-form-to-conclusion (proof-to-formula proof1))
	proof1
	proof2
	(union-wrt avar=?
		   (proof-to-context proof1) (proof-to-context proof2))))

(define (make-acproof-in-and-intro-form proof1 proof2)
  (list 'proof-in-and-intro-form
	(make-and (proof-to-formula proof1) (proof-to-formula proof2))
	proof1
	proof2
	(union-wrt avar=?
		   (proof-to-context proof1) (proof-to-context proof2))))

(define (make-acproof-in-and-elim-left-form proof)
  (let ((formula (proof-to-formula proof)))
    (if (and-form? formula)
	(list 'proof-in-and-elim-left-form
	      (and-form-to-left formula)
	      proof
	      (proof-to-context proof))
	(myerror "make-acproof-in-and-elim-left-form" "and form expected"
		 formula))))

(define (make-acproof-in-and-elim-right-form proof)
  (let ((formula (proof-to-formula proof)))
    (if (and-form? formula)
	(list 'proof-in-and-elim-right-form
	      (and-form-to-right formula)
	      proof
	      (proof-to-context proof))
	(myerror "make-acproof-in-and-elim-right-form" "and form expected"
		 formula))))

(define (make-acproof-in-all-intro-form var proof)
  (list 'proof-in-all-intro-form
	(make-all var (proof-to-formula proof))
	var
	proof
	(proof-to-context proof)))

(define (make-acproof-in-all-elim-form proof term . conclusion)
  (if (null? conclusion)
      (let* ((formula (proof-to-formula proof))
	     (var (all-form-to-var formula))
	     (kernel (all-form-to-kernel formula)))
	(list 'proof-in-all-elim-form
	      (if (and (term-in-var-form? term)
		       (equal? var (term-in-var-form-to-var term)))
		  kernel	      
		  (formula-subst kernel var term))
	      proof
	      term
	      (proof-to-context proof)))
      (list 'proof-in-all-elim-form
	    (car conclusion)
	    proof
	    term
	    (proof-to-context proof))))

(define (make-acproof-in-allnc-intro-form var proof)
  (list 'proof-in-allnc-intro-form
	(make-allnc var (proof-to-formula proof))
	var
	proof
	(proof-to-context proof)))

(define (make-acproof-in-allnc-elim-form proof term . conclusion)
  (if (null? conclusion)
      (let* ((formula (proof-to-formula proof))
	     (var (allnc-form-to-var formula))
	     (kernel (allnc-form-to-kernel formula)))
	(list 'proof-in-allnc-elim-form
	      (if (and (term-in-var-form? term)
		       (equal? var (term-in-var-form-to-var term)))
		  kernel	      
		  (formula-subst kernel var term))
	      proof
	      term
	      (proof-to-context proof)))
      (list 'proof-in-allnc-elim-form
	    (car conclusion)
	    proof
	    term
	    (proof-to-context proof))))

(define (proof-to-acproof proof)
  (case (tag proof)
    ((proof-in-avar-form)
     (let ((avar (proof-in-avar-form-to-avar proof)))
       (make-acproof-in-avar-form avar)))
    ((proof-in-aconst-form)
     (let ((aconst (proof-in-aconst-form-to-aconst proof)))
       (make-acproof-in-aconst-form aconst)))
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (kernel (proof-in-imp-intro-form-to-kernel proof))
	    (prev (proof-to-acproof kernel)))
       (make-acproof-in-imp-intro-form avar prev)))
    ((proof-in-imp-elim-form)
     (let* ((op (proof-in-imp-elim-form-to-op proof))
	    (arg (proof-in-imp-elim-form-to-arg proof))
	    (prev1 (proof-to-acproof op))
	    (prev2 (proof-to-acproof arg)))
       (make-acproof-in-imp-elim-form prev1 prev2)))
    ((proof-in-impnc-intro-form)
     (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (prev (proof-to-acproof kernel)))
       (make-acproof-in-impnc-intro-form avar prev)))
    ((proof-in-impnc-elim-form)
     (let* ((op (proof-in-impnc-elim-form-to-op proof))
	    (arg (proof-in-impnc-elim-form-to-arg proof))
	    (prev1 (proof-to-acproof op))
	    (prev2 (proof-to-acproof arg)))
       (make-acproof-in-impnc-elim-form prev1 prev2)))
    ((proof-in-and-intro-form)
     (let* ((left (proof-in-and-intro-form-to-left proof))
	    (right (proof-in-and-intro-form-to-right proof))
	    (prev1 (proof-to-acproof left))
	    (prev2 (proof-to-acproof right)))
       (make-acproof-in-and-intro-form prev1 prev2)))
    ((proof-in-and-elim-left-form)
     (let* ((kernel (proof-in-and-elim-left-form-to-kernel proof))
	    (prev (proof-to-acproof kernel)))
       (make-acproof-in-and-elim-left-form prev)))
    ((proof-in-and-elim-right-form)
     (let* ((kernel (proof-in-and-elim-right-form-to-kernel proof))
	    (prev (proof-to-acproof kernel)))
       (make-acproof-in-and-elim-right-form prev)))
    ((proof-in-all-intro-form)
     (let* ((var (proof-in-all-intro-form-to-var proof))
	    (kernel (proof-in-all-intro-form-to-kernel proof))
	    (prev (proof-to-acproof kernel)))
       (make-acproof-in-all-intro-form var prev)))
    ((proof-in-all-elim-form)
     (let* ((op (proof-in-all-elim-form-to-op proof))
	    (prev (proof-to-acproof op))
	    (arg (proof-in-all-elim-form-to-arg proof))
	    (conclusion (proof-to-formula proof)))
       (make-acproof-in-all-elim-form prev arg conclusion)))
    ((proof-in-allnc-intro-form)
     (let* ((var (proof-in-allnc-intro-form-to-var proof))
	    (kernel (proof-in-allnc-intro-form-to-kernel proof))
	    (prev (proof-to-acproof kernel)))
       (make-acproof-in-allnc-intro-form var prev)))
    ((proof-in-allnc-elim-form)
     (let* ((op (proof-in-allnc-elim-form-to-op proof))
	    (prev (proof-to-acproof op))
	    (arg (proof-in-allnc-elim-form-to-arg proof))
	    (conclusion (proof-to-formula proof)))
       (make-acproof-in-allnc-elim-form prev arg conclusion)))
    (else (myerror "proof-to-acproof" "proof tag expected" (tag proof)))))

; The variable condition for allnc refers to the computational variables.

(define (proof-to-cvars proof)
  (if (formula-of-nulltype? (proof-to-formula proof))
      '()
      (proof-to-cvars-aux proof)))

; In proof-to-cvars-aux we can assume that the proved formula has
; computational content.

(define (proof-to-cvars-aux proof) 
  (case (tag proof)
    ((proof-in-avar-form) (list (proof-in-avar-form-to-avar proof)))
    ((proof-in-aconst-form) '())
    ((proof-in-imp-intro-form)
     (remove-wrt avar=? (proof-in-imp-intro-form-to-avar proof)
		 (proof-to-cvars-aux
		  (proof-in-imp-intro-form-to-kernel 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))
	    (prevop (proof-to-cvars-aux op))
	    (prevarg (proof-to-cvars arg)))
       (union prevop prevarg)))
    ((proof-in-impnc-intro-form)
     (proof-to-cvars-aux (proof-in-impnc-intro-form-to-kernel proof)))
    ((proof-in-impnc-elim-form)
     (proof-to-cvars-aux (proof-in-impnc-elim-form-to-op 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)))
       (if (formula-of-nulltype? (proof-to-formula left))
	   (proof-to-cvars-aux right)
	   (union (proof-to-cvars-aux left)
		  (proof-to-cvars right)))))
    ((proof-in-and-elim-left-form)
     (proof-to-cvars-aux
      (proof-in-and-elim-left-form-to-kernel proof)))
    ((proof-in-and-elim-right-form)
     (proof-to-cvars-aux
      (proof-in-and-elim-right-form-to-kernel proof)))
    ((proof-in-all-intro-form)
     (remove (proof-in-all-intro-form-to-var proof)
	     (proof-to-cvars-aux
	      (proof-in-all-intro-form-to-kernel proof))))
    ((proof-in-all-elim-form)
     (let* ((op (proof-in-all-elim-form-to-op proof))
	    (arg (proof-in-all-elim-form-to-arg proof))
	    (prev (proof-to-cvars-aux op)))
       (union prev (term-to-free arg))))
    ((proof-in-allnc-intro-form)
     (proof-to-cvars-aux
      (proof-in-allnc-intro-form-to-kernel proof)))
    ((proof-in-allnc-elim-form)
     (proof-to-cvars-aux
      (proof-in-allnc-elim-form-to-op proof)))
    (else (myerror "proof-to-cvars" "proof tag expected" (tag proof)))))

(define (proof-to-free proof)
  (case (tag proof)
    ((proof-in-avar-form)
     (formula-to-free (proof-to-formula proof)))
    ((proof-in-aconst-form) '())
    ((proof-in-imp-intro-form)
     (let ((free1 (formula-to-free
		   (avar-to-formula (proof-in-imp-intro-form-to-avar proof))))
	   (free2 (proof-to-free (proof-in-imp-intro-form-to-kernel proof))))
       (union free1 free2)))
    ((proof-in-imp-elim-form)
     (union (proof-to-free (proof-in-imp-elim-form-to-op proof))
	    (proof-to-free (proof-in-imp-elim-form-to-arg proof))))
    ((proof-in-impnc-intro-form)
     (let ((free1 (formula-to-free
		   (avar-to-formula
		    (proof-in-impnc-intro-form-to-avar proof))))
	   (free2 (proof-to-free (proof-in-impnc-intro-form-to-kernel proof))))
       (union free1 free2)))
    ((proof-in-impnc-elim-form)
     (union (proof-to-free (proof-in-impnc-elim-form-to-op proof))
	    (proof-to-free (proof-in-impnc-elim-form-to-arg proof))))
    ((proof-in-and-intro-form)
     (union (proof-to-free (proof-in-and-intro-form-to-left proof))
	    (proof-to-free (proof-in-and-intro-form-to-right proof))))
    ((proof-in-and-elim-left-form)
     (proof-to-free (proof-in-and-elim-left-form-to-kernel proof)))
    ((proof-in-and-elim-right-form)
     (proof-to-free (proof-in-and-elim-right-form-to-kernel proof)))
    ((proof-in-all-intro-form)
     (remove (proof-in-all-intro-form-to-var proof)
	     (proof-to-free (proof-in-all-intro-form-to-kernel proof))))
    ((proof-in-all-elim-form)
     (union (proof-to-free (proof-in-all-elim-form-to-op proof))
	    (term-to-free (proof-in-all-elim-form-to-arg proof))))
    ((proof-in-allnc-intro-form)
     (remove (proof-in-allnc-intro-form-to-var proof)
	     (proof-to-free (proof-in-allnc-intro-form-to-kernel proof))))
    ((proof-in-allnc-elim-form)
     (union (proof-to-free (proof-in-allnc-elim-form-to-op proof))
	    (term-to-free (proof-in-allnc-elim-form-to-arg proof))))
    (else (myerror "proof-to-free" "proof tag expected" (tag proof)))))

(define (proof-to-free-avars proof)
  (case (tag proof)
    ((proof-in-avar-form) (list (proof-in-avar-form-to-avar proof)))
    ((proof-in-aconst-form) '())
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (kernel (proof-in-imp-intro-form-to-kernel proof))
	    (free-avars (proof-to-free-avars kernel)))
       (remove-wrt avar=? avar free-avars)))       
    ((proof-in-imp-elim-form)
     (let ((free-avars1
	    (proof-to-free-avars (proof-in-imp-elim-form-to-op proof)))
	   (free-avars2
	    (proof-to-free-avars (proof-in-imp-elim-form-to-arg proof))))
       (union-wrt avar=? free-avars1 free-avars2)))
    ((proof-in-impnc-intro-form)
     (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (free-avars (proof-to-free-avars kernel)))
       (remove-wrt avar=? avar free-avars)))       
    ((proof-in-impnc-elim-form)
     (let ((free-avars1
	    (proof-to-free-avars (proof-in-impnc-elim-form-to-op proof)))
	   (free-avars2
	    (proof-to-free-avars (proof-in-impnc-elim-form-to-arg proof))))
       (union-wrt avar=? free-avars1 free-avars2)))
    ((proof-in-and-intro-form)
     (union-wrt
      avar=?
      (proof-to-free-avars (proof-in-and-intro-form-to-left proof))
      (proof-to-free-avars (proof-in-and-intro-form-to-right proof))))
    ((proof-in-and-elim-left-form)
     (proof-to-free-avars (proof-in-and-elim-left-form-to-kernel proof)))
    ((proof-in-and-elim-right-form)
     (proof-to-free-avars (proof-in-and-elim-right-form-to-kernel proof)))
    ((proof-in-all-intro-form)
     (proof-to-free-avars (proof-in-all-intro-form-to-kernel proof)))
    ((proof-in-all-elim-form)
     (proof-to-free-avars (proof-in-all-elim-form-to-op proof)))
    ((proof-in-allnc-intro-form)
     (proof-to-free-avars (proof-in-allnc-intro-form-to-kernel proof)))
    ((proof-in-allnc-elim-form)
     (proof-to-free-avars (proof-in-allnc-elim-form-to-op proof)))
    (else (myerror "proof-to-free-avars" "proof tag expected" (tag proof)))))

(define (proof-to-bound-avars proof)
  (case (tag proof)
    ((proof-in-avar-form proof-in-aconst-form) '())
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (kernel (proof-in-imp-intro-form-to-kernel proof))
	    (bound (proof-to-bound-avars kernel)))
       (adjoin-wrt avar=? avar bound)))       
    ((proof-in-imp-elim-form)
     (let ((bound1 (proof-to-bound-avars
		    (proof-in-imp-elim-form-to-op proof)))
	   (bound2 (proof-to-bound-avars
		    (proof-in-imp-elim-form-to-arg proof))))
       (union-wrt avar=? bound1 bound2)))
    ((proof-in-impnc-intro-form)
     (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (bound (proof-to-bound-avars kernel)))
       (adjoin-wrt avar=? avar bound)))       
    ((proof-in-impnc-elim-form)
     (let ((bound1 (proof-to-bound-avars
		    (proof-in-impnc-elim-form-to-op proof)))
	   (bound2 (proof-to-bound-avars
		    (proof-in-impnc-elim-form-to-arg proof))))
       (union-wrt avar=? bound1 bound2)))
    ((proof-in-and-intro-form)
     (union-wrt
      avar=?
      (proof-to-bound-avars (proof-in-and-intro-form-to-left proof))
      (proof-to-bound-avars (proof-in-and-intro-form-to-right proof))))
    ((proof-in-and-elim-left-form)
     (proof-to-bound-avars (proof-in-and-elim-left-form-to-kernel proof)))
    ((proof-in-and-elim-right-form)
     (proof-to-bound-avars (proof-in-and-elim-right-form-to-kernel proof)))
    ((proof-in-all-intro-form)
     (proof-to-bound-avars (proof-in-all-intro-form-to-kernel proof)))
    ((proof-in-all-elim-form)
     (proof-to-bound-avars (proof-in-all-elim-form-to-op proof)))
    ((proof-in-allnc-intro-form)
     (proof-to-bound-avars (proof-in-allnc-intro-form-to-kernel proof)))
    ((proof-in-allnc-elim-form)
     (proof-to-bound-avars (proof-in-allnc-elim-form-to-op proof)))
    (else (myerror "proof-to-bound-avars" "proof tag expected" (tag proof)))))

(define (proof-to-free-and-bound-avars-wrt avar-eq proof)
  (case (tag proof)
    ((proof-in-avar-form) (list (proof-in-avar-form-to-avar proof)))
    ((proof-in-aconst-form) '())
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (kernel (proof-in-imp-intro-form-to-kernel proof))
	    (free-and-bound-avars
	     (proof-to-free-and-bound-avars-wrt avar-eq kernel)))
       (union-wrt avar-eq (list avar) free-and-bound-avars)))       
    ((proof-in-imp-elim-form)
     (let ((free-and-bound-avars1
	    (proof-to-free-and-bound-avars-wrt
	     avar-eq (proof-in-imp-elim-form-to-op proof)))
	   (free-and-bound-avars2
	    (proof-to-free-and-bound-avars-wrt
	     avar-eq (proof-in-imp-elim-form-to-arg proof))))
       (union-wrt avar-eq free-and-bound-avars1 free-and-bound-avars2)))
    ((proof-in-impnc-intro-form)
     (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (free-and-bound-avars
	     (proof-to-free-and-bound-avars-wrt avar-eq kernel)))
       (union-wrt avar-eq (list avar) free-and-bound-avars)))       
    ((proof-in-impnc-elim-form)
     (let ((free-and-bound-avars1
	    (proof-to-free-and-bound-avars-wrt
	     avar-eq (proof-in-impnc-elim-form-to-op proof)))
	   (free-and-bound-avars2
	    (proof-to-free-and-bound-avars-wrt
	     avar-eq (proof-in-impnc-elim-form-to-arg proof))))
       (union-wrt avar-eq free-and-bound-avars1 free-and-bound-avars2)))
    ((proof-in-and-intro-form)
     (union-wrt avar-eq
		(proof-to-free-and-bound-avars-wrt
		 avar-eq (proof-in-and-intro-form-to-left proof))
		(proof-to-free-and-bound-avars-wrt
		 avar-eq (proof-in-and-intro-form-to-right proof))))
    ((proof-in-and-elim-left-form)
     (proof-to-free-and-bound-avars-wrt
      avar-eq (proof-in-and-elim-left-form-to-kernel proof)))
    ((proof-in-and-elim-right-form)
     (proof-to-free-and-bound-avars-wrt
      avar-eq (proof-in-and-elim-right-form-to-kernel proof)))
    ((proof-in-all-intro-form)
     (proof-to-free-and-bound-avars-wrt
      avar-eq (proof-in-all-intro-form-to-kernel proof)))
    ((proof-in-all-elim-form)
     (proof-to-free-and-bound-avars-wrt
      avar-eq (proof-in-all-elim-form-to-op proof)))
    ((proof-in-allnc-intro-form)
     (proof-to-free-and-bound-avars-wrt
      avar-eq (proof-in-allnc-intro-form-to-kernel proof)))
    ((proof-in-allnc-elim-form)
     (proof-to-free-and-bound-avars-wrt
      avar-eq (proof-in-allnc-elim-form-to-op proof)))
    (else (myerror "proof-to-free-and-bound-avars-wrt" "proof tag expected"
		   (tag proof)))))

(define (proof-to-free-and-bound-avars proof)
  (proof-to-free-and-bound-avars-wrt avar=? proof))

(define (proof-respects-avar-convention? proof)
  (let* ((avars (proof-to-free-and-bound-avars-wrt avar-full=? proof))
	 (l (map (lambda (avar)
		   (list (avar-to-name avar) (avar-to-index avar)))
		 avars)))
    (equal? (remove-duplicates l) l)))

(define (proof-to-aconsts-without-rules-aux proof)
  (case (tag proof)
    ((proof-in-avar-form) '())
    ((proof-in-aconst-form)
     (let ((aconst (proof-in-aconst-form-to-aconst proof)))
       (if (aconst-without-rules? aconst) (list aconst) '())))
    ((proof-in-imp-intro-form)
     (proof-to-aconsts-without-rules-aux
      (proof-in-imp-intro-form-to-kernel proof)))
    ((proof-in-imp-elim-form)
     (let ((aconsts1 (proof-to-aconsts-without-rules-aux
		      (proof-in-imp-elim-form-to-op proof)))
	   (aconsts2 (proof-to-aconsts-without-rules-aux
		      (proof-in-imp-elim-form-to-arg proof))))
       (append aconsts1 aconsts2)))
    ((proof-in-impnc-intro-form)
     (proof-to-aconsts-without-rules-aux
      (proof-in-impnc-intro-form-to-kernel proof)))
    ((proof-in-impnc-elim-form)
     (let ((aconsts1 (proof-to-aconsts-without-rules-aux
		      (proof-in-impnc-elim-form-to-op proof)))
	   (aconsts2 (proof-to-aconsts-without-rules-aux
		      (proof-in-impnc-elim-form-to-arg proof))))
       (append aconsts1 aconsts2)))
    ((proof-in-and-intro-form)
     (append (proof-to-aconsts-without-rules-aux
	      (proof-in-and-intro-form-to-left proof))
	     (proof-to-aconsts-without-rules-aux
	      (proof-in-and-intro-form-to-right proof))))
    ((proof-in-and-elim-left-form)
     (proof-to-aconsts-without-rules-aux
      (proof-in-and-elim-left-form-to-kernel proof)))
    ((proof-in-and-elim-right-form)
     (proof-to-aconsts-without-rules-aux
      (proof-in-and-elim-right-form-to-kernel proof)))
    ((proof-in-all-intro-form)
     (proof-to-aconsts-without-rules-aux
      (proof-in-all-intro-form-to-kernel proof)))
    ((proof-in-all-elim-form)
     (proof-to-aconsts-without-rules-aux
      (proof-in-all-elim-form-to-op proof)))
    ((proof-in-allnc-intro-form)
     (proof-to-aconsts-without-rules-aux
      (proof-in-allnc-intro-form-to-kernel proof)))
    ((proof-in-allnc-elim-form)
     (proof-to-aconsts-without-rules-aux
      (proof-in-allnc-elim-form-to-op proof)))
    (else (myerror "proof-to-aconsts-without-rules-aux" "proof tag expected"
		   (tag proof)))))

(define (proof-to-aconsts-without-rules proof)  
  (remove-duplicates-wrt aconst=? (proof-to-aconsts-without-rules-aux proof)))

(define (proof-to-aconsts-with-repetitions proof)
  (case (tag proof)
    ((proof-in-avar-form) '())
    ((proof-in-aconst-form)
     (list (proof-in-aconst-form-to-aconst proof)))
    ((proof-in-imp-intro-form)
     (proof-to-aconsts-with-repetitions
      (proof-in-imp-intro-form-to-kernel proof)))
    ((proof-in-imp-elim-form)
     (let ((aconsts1 (proof-to-aconsts-with-repetitions
		      (proof-in-imp-elim-form-to-op proof)))
	   (aconsts2 (proof-to-aconsts-with-repetitions
		      (proof-in-imp-elim-form-to-arg proof))))
       (append aconsts1 aconsts2)))
    ((proof-in-impnc-intro-form)
     (proof-to-aconsts-with-repetitions
      (proof-in-impnc-intro-form-to-kernel proof)))
    ((proof-in-impnc-elim-form)
     (let ((aconsts1 (proof-to-aconsts-with-repetitions
		      (proof-in-impnc-elim-form-to-op proof)))
	   (aconsts2 (proof-to-aconsts-with-repetitions
		      (proof-in-impnc-elim-form-to-arg proof))))
       (append aconsts1 aconsts2)))
    ((proof-in-and-intro-form)
     (append (proof-to-aconsts-with-repetitions
	      (proof-in-and-intro-form-to-left proof))
	     (proof-to-aconsts-with-repetitions
	      (proof-in-and-intro-form-to-right proof))))
    ((proof-in-and-elim-left-form)
     (proof-to-aconsts-with-repetitions
      (proof-in-and-elim-left-form-to-kernel proof)))
    ((proof-in-and-elim-right-form)
     (proof-to-aconsts-with-repetitions
      (proof-in-and-elim-right-form-to-kernel proof)))
    ((proof-in-all-intro-form)
     (proof-to-aconsts-with-repetitions
      (proof-in-all-intro-form-to-kernel proof)))
    ((proof-in-all-elim-form)
     (proof-to-aconsts-with-repetitions (proof-in-all-elim-form-to-op proof)))
    ((proof-in-allnc-intro-form)
     (proof-to-aconsts-with-repetitions
      (proof-in-allnc-intro-form-to-kernel proof)))
    ((proof-in-allnc-elim-form)
     (proof-to-aconsts-with-repetitions
      (proof-in-allnc-elim-form-to-op proof)))
    (else (myerror "proof-to-aconsts-with-repetitions" "proof tag expected"
		   (tag proof)))))

(define (proof-to-aconsts proof)
  (remove-duplicates-wrt aconst=? (proof-to-aconsts-with-repetitions proof)))

(define (proof-to-global-assumptions-with-repetitions proof)
  (case (tag proof)
    ((proof-in-avar-form) '())
    ((proof-in-aconst-form)
     (let* ((aconst (proof-in-aconst-form-to-aconst proof))
	    (name (aconst-to-name aconst)))
       (case (aconst-to-kind aconst)
	 ((theorem)
	  (proof-to-global-assumptions-with-repetitions
	   (theorem-name-to-proof (aconst-to-name aconst))))
	 ((global-assumption)
	  (list aconst))
	 (else '()))))
    ((proof-in-imp-intro-form)
     (proof-to-global-assumptions-with-repetitions
      (proof-in-imp-intro-form-to-kernel proof)))
    ((proof-in-imp-elim-form)
     (let ((aconsts1 (proof-to-global-assumptions-with-repetitions
		      (proof-in-imp-elim-form-to-op proof)))
	   (aconsts2 (proof-to-global-assumptions-with-repetitions
		      (proof-in-imp-elim-form-to-arg proof))))
       (append aconsts1 aconsts2)))
    ((proof-in-impnc-intro-form)
     (proof-to-global-assumptions-with-repetitions
      (proof-in-impnc-intro-form-to-kernel proof)))
    ((proof-in-impnc-elim-form)
     (let ((aconsts1 (proof-to-global-assumptions-with-repetitions
		      (proof-in-impnc-elim-form-to-op proof)))
	   (aconsts2 (proof-to-global-assumptions-with-repetitions
		      (proof-in-impnc-elim-form-to-arg proof))))
       (append aconsts1 aconsts2)))
    ((proof-in-and-intro-form)
     (append (proof-to-global-assumptions-with-repetitions
	      (proof-in-and-intro-form-to-left proof))
	     (proof-to-global-assumptions-with-repetitions
	      (proof-in-and-intro-form-to-right proof))))
    ((proof-in-and-elim-left-form)
     (proof-to-global-assumptions-with-repetitions
      (proof-in-and-elim-left-form-to-kernel proof)))
    ((proof-in-and-elim-right-form)
     (proof-to-global-assumptions-with-repetitions
      (proof-in-and-elim-right-form-to-kernel proof)))
    ((proof-in-all-intro-form)
     (proof-to-global-assumptions-with-repetitions
      (proof-in-all-intro-form-to-kernel proof)))
    ((proof-in-all-elim-form)
     (proof-to-global-assumptions-with-repetitions
      (proof-in-all-elim-form-to-op proof)))
    ((proof-in-allnc-intro-form)
     (proof-to-global-assumptions-with-repetitions
      (proof-in-allnc-intro-form-to-kernel proof)))
    ((proof-in-allnc-elim-form)
     (proof-to-global-assumptions-with-repetitions
      (proof-in-allnc-elim-form-to-op proof)))
    (else (myerror
	   "proof-to-global-assumptions-with-repetitions" "proof tag expected"
	   (tag proof)))))

(define (proof-to-global-assumptions proof)
  (remove-duplicates-wrt aconst=?
			 (proof-to-global-assumptions-with-repetitions proof)))

(define (thm-or-ga-name-to-proof x)
  (cond
   ((and (string? x) (assoc x THEOREMS))
    (make-proof-in-aconst-form (theorem-name-to-aconst x)))
   ((and (string? x) (assoc x GLOBAL-ASSUMPTIONS))
    (make-proof-in-aconst-form (global-assumption-name-to-aconst x)))
   (else (myerror "thm-or-ga-name-to-proof"
		  "name of theorem or global assumption expected"
		  x))))

; proof-to-undec-proof turns every imp, all formula in the given proof
; in an impnc, allnc formula, including the parts of an aconst which
; come from its uninstatiated formula.  Hence undec-proof is in
; general not a proof.

(define (proof-to-undec-proof proof)
  (case (tag proof)
    ((proof-in-avar-form)
     (let* ((avar (proof-in-avar-form-to-avar proof))
	    (undec-avar (make-avar
			 (formula-to-undec-formula (proof-to-formula proof))
			 (avar-to-index avar) (avar-to-name avar))))
       (make-proof-in-avar-form undec-avar)))
    ((proof-in-aconst-form)
     (let ((aconst (proof-in-aconst-form-to-aconst proof)))
       (list 'proof-in-aconst-form
	     (formula-to-undec-formula (aconst-to-formula aconst))
	     (aconst-to-undec-aconst aconst))))
    ((proof-in-imp-intro-form)
     (let* ((kernel (proof-in-imp-intro-form-to-kernel proof))
	    (avar (proof-in-imp-intro-form-to-avar proof))
	    (undec-avar (make-avar
			 (formula-to-undec-formula (avar-to-formula avar))
			 (avar-to-index avar) (avar-to-name avar))))
       (make-proof-in-impnc-intro-form
	undec-avar (proof-to-undec-proof kernel))))
    ((proof-in-impnc-intro-form)
     (let* ((kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (avar (proof-in-impnc-intro-form-to-avar proof))
	    (undec-avar (make-avar
			 (formula-to-undec-formula (avar-to-formula avar))
			 (avar-to-index avar) (avar-to-name avar))))
       (make-proof-in-impnc-intro-form
	undec-avar (proof-to-undec-proof kernel))))
    ((proof-in-imp-elim-form)
     (make-proof-in-impnc-elim-form
      (proof-to-undec-proof (proof-in-imp-elim-form-to-op proof))
      (proof-to-undec-proof (proof-in-imp-elim-form-to-arg proof))))
    ((proof-in-impnc-elim-form)
     (make-proof-in-impnc-elim-form
      (proof-to-undec-proof (proof-in-impnc-elim-form-to-op proof))
      (proof-to-undec-proof (proof-in-impnc-elim-form-to-arg proof))))
    ((proof-in-and-intro-form)
     (make-proof-in-and-intro-form
      (proof-to-undec-proof (proof-in-and-intro-form-to-left proof))
      (proof-to-undec-proof (proof-in-and-intro-form-to-right proof))))
    ((proof-in-and-elim-left-form)
     (make-proof-in-and-elim-left-form
      (proof-to-undec-proof (proof-in-and-elim-left-form-to-kernel proof))))
    ((proof-in-and-elim-right-form)
     (make-proof-in-and-elim-right-form
      (proof-to-undec-proof (proof-in-and-elim-right-form-to-kernel proof))))
    ((proof-in-all-intro-form)
     (make-proof-in-allnc-intro-form
      (proof-in-all-intro-form-to-var proof)
      (proof-to-undec-proof
       (proof-in-all-intro-form-to-kernel proof))))
    ((proof-in-allnc-intro-form)
     (make-proof-in-allnc-intro-form
      (proof-in-allnc-intro-form-to-var proof)
      (proof-to-undec-proof
       (proof-in-allnc-intro-form-to-kernel proof))))
    ((proof-in-all-elim-form)
     (make-proof-in-allnc-elim-form
      (proof-to-undec-proof (proof-in-all-elim-form-to-op proof))
      (proof-in-all-elim-form-to-arg proof)))
    ((proof-in-allnc-elim-form)
     (make-proof-in-allnc-elim-form
      (proof-to-undec-proof (proof-in-allnc-elim-form-to-op proof))
      (proof-in-allnc-elim-form-to-arg proof)))
    (else (myerror "proof-to-undec-proof" "proof tag expected" (tag proof)))))

; (dp (proof-to-undec-proof (theorem-name-to-proof "NatPlusComm")))
; (dp (proof-to-undec-proof (theorem-name-to-proof "ListAppendNil")))

(define (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
	 proof decavars decfla)
  (if ;application of an aconst with a less extending alternative
   (and
    (or (and (predicate-form? decfla)
	     (idpredconst-form? (predicate-form-to-predicate decfla)))
					;temporarily we still have
	(ex-form? decfla)
	(exnc-form? decfla)
	(and-form? decfla))
    (let ((op (proof-in-elim-form-to-final-op proof)))
      (and
       (proof-in-aconst-form? op)
       (let ((opname (aconst-to-name (proof-in-aconst-form-to-aconst op))))
	 (and
	  (or (assoc opname THEOREMS)
	      (assoc opname GLOBAL-ASSUMPTIONS))
	  (let ((altops (decfla-and-opname-to-altops decfla opname)))
	    (and
	     (pair? altops)
	     (let*
		 ((args (proof-in-elim-form-to-args proof))
		  (extending-proofs-or-f
		   (map
		    (lambda (altop)
		      (op-and-args-and-altop-and-decfla-and-decavars-to-proof
		       op args altop decfla decavars))
		    altops))
		  (extending-proofs ;take only those that are not #f
		   (list-transform-positive extending-proofs-or-f
		     (lambda (x) x))))
	       (pair? extending-proofs)))))))))
					;take the first (or "least extended"?)
   (let* ((op (proof-in-elim-form-to-final-op proof))
	  (opname (aconst-to-name (proof-in-aconst-form-to-aconst op)))
	  (altops (decfla-and-opname-to-altops decfla opname))
	  (args (proof-in-elim-form-to-args proof))
	  (extending-proofs-or-f
	   (map
	    (lambda (altop)
	      (op-and-args-and-altop-and-decfla-and-decavars-to-proof
	       op args altop decfla decavars))
	    altops))
	  (extending-proofs ;take only those that are not #f
	   (list-transform-positive extending-proofs-or-f
	     (lambda (x) x))))
     (list (car extending-proofs) decavars))
					;else carry on
   (case (tag proof)
     ((proof-in-avar-form)
      (let*
	  ((avar (proof-in-avar-form-to-avar proof))
	   (test (member-wrt avar=? avar decavars))
	   (decavar
	    (if
	     test (car test)
	     (myerror
	      "undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars"
	      "avar" (avar-to-name avar) (avar-to-index avar)
	      "missing in decavars"
	      (pp-context decavars))))
	   (decavar-fla (avar-to-formula decavar))
	   (ext-fla (dec-variants-to-lub decfla decavar-fla))
	   (decavar
	    (make-avar ext-fla (avar-to-index avar) (avar-to-name avar))))
	(list (make-proof-in-avar-form decavar)
	      (list decavar))))
     ((proof-in-aconst-form)
      (let* ((aconst (proof-in-aconst-form-to-aconst proof))
	     (name (aconst-to-name aconst))
	     (kind (aconst-to-kind aconst)))
	(cond
	 ((string=? "Intro" name)
	  (let ((min-intro-aconst
		 (intro-aconst-and-decfla-to-min-intro-aconst aconst decfla)))
	    (list (make-proof-in-aconst-form min-intro-aconst) '())))
	 ((string=? "Elim" name)
	  (let ((min-elim-aconst
		 (elim-aconst-and-decfla-to-min-elim-aconst aconst decfla)))
	    (list (make-proof-in-aconst-form min-elim-aconst) '())))
	 ((eq? 'axiom kind)
	  (list (make-proof-in-aconst-form
		 (let* ((name (aconst-to-name aconst))
			(uninst-fla (aconst-to-uninst-formula aconst))
			(extended-tpinst
			 (aconst-and-dec-inst-formula-to-extended-tpinst
			  aconst decfla))
			(aconst-without-repro-formulas
			 (make-aconst name kind uninst-fla extended-tpinst)))
		   (apply make-aconst
			  (append (list name kind uninst-fla extended-tpinst)
				  (aconst-to-computed-repro-formulas
				   aconst-without-repro-formulas)))))
		'()))
	 (else
	  (let ((min-aconst
		 (let* ((aconsts
			 (map cadr (append THEOREMS GLOBAL-ASSUMPTIONS)))
			(extending-aconsts
			 (list-transform-positive aconsts
			   (lambda (ac)
			     (let ((match2-res ;ignore-deco-flag set to #t
				    (match2 (aconst-to-uninst-formula ac)
					    decfla #t)))
			       (and match2-res
				    (extending-dec-variants?
				     (formula-substitute
				      (aconst-to-uninst-formula ac)
				      match2-res)
				     decfla)))))))
		   (if
		    (pair? extending-aconsts)
		    (let aconst-and-aconsts-to-min-aconst
			((a (car extending-aconsts))
			 (as (cdr extending-aconsts)))
		      (if (null? as) a
			  (let* ((b (car as))
				 (rest (cdr as))
				 (fla (aconst-to-formula a)))
			    (if (apply
				 or-op (map
					(lambda (c)
					  (extending-dec-variants?
					   fla (aconst-to-formula c)))
					rest))
				(aconst-and-aconsts-to-min-aconst b rest)
				a))))
		    (myerror
		     "undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars"
		     "no theorem or global assumption found extending"
		     decfla)))))
	    (list
	     (make-proof-in-aconst-form
	      (let* ((name (aconst-to-name min-aconst))
		     (kind (aconst-to-kind min-aconst))
		     (uninst-fla (aconst-to-uninst-formula min-aconst))
		     (extended-tpinst
		      (aconst-and-dec-inst-formula-to-extended-tpinst
		       min-aconst decfla))
		     (aconst-without-repro-formulas
		      (make-aconst name kind uninst-fla extended-tpinst)))
		(apply make-aconst
		       (append (list name kind uninst-fla extended-tpinst)
			       (aconst-to-computed-repro-formulas
				aconst-without-repro-formulas)))))
	     '()))))))
     ((proof-in-impnc-intro-form)
      (let* ((kernel (proof-in-impnc-intro-form-to-kernel proof))
	     (avar (proof-in-impnc-intro-form-to-avar proof))
	     (free-avars (proof-to-free-avars kernel))
	     (decprem (imp-impnc-form-to-premise decfla))
	     (decconc (imp-impnc-form-to-conclusion decfla))
	     (decavar
	      (make-avar decprem (avar-to-index avar) (avar-to-name avar)))
	     (decavars-for-kernel
	      (do ((l free-avars (cdr l))
		   (res '() (let ((test (member-wrt avar=? (car l) decavars)))
			      (cond (test
				     (cons (car test) res))
				    ((avar=? (car l) avar)
				     (cons decavar res))
				    (else
				     (myerror "unexpected avar"
					      (avar-to-name (car l))
					      (avar-to-index (car l))
					      (avar-to-formula (car l))))))))
		  ((null? l) (reverse res))))
	     (decproof-and-ext-decavars
	      (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
	       kernel decavars-for-kernel decconc))
	     (decproof (car decproof-and-ext-decavars))
	     (ext-decavars (cadr decproof-and-ext-decavars))
	     (reduced-ext-decavars (remove-wrt avar=? avar ext-decavars))
	     (test (member-wrt avar=? avar ext-decavars))
	     (ext-decavar1 (if test (car test) decavar)))
	(list (if (and (impnc-form? decfla)
		       (not
			(member-wrt avar=? avar (proof-to-cvars decproof))))
		  (make-proof-in-impnc-intro-form ext-decavar1 decproof)
		  (make-proof-in-imp-intro-form ext-decavar1 decproof))
	      reduced-ext-decavars)))
     ((proof-in-impnc-elim-form)
      (let* ((op (proof-in-impnc-elim-form-to-op proof))
	     (arg (proof-in-impnc-elim-form-to-arg proof))
	     (avars1 (proof-to-free-avars op))
	     (avars2 (proof-to-free-avars arg))
	     (avars-int (intersection-wrt avar=? avars1 avars2))
	     (avars-lft (set-minus-wrt avar=? avars1 avars-int))
	     (avars-rht (set-minus-wrt avar=? avars2 avars-int))
	     (avars-to-int
	      (lambda (avars)
		(list-transform-positive avars
		  (lambda (x) (member-wrt avar=? x avars-int)))))
	     (avars-to-lft
	      (lambda (avars)
		(list-transform-positive avars
		  (lambda (x) (member-wrt avar=? x avars-lft)))))
	     (avars-to-rht
	      (lambda (avars)
		(list-transform-positive avars
		  (lambda (x) (member-wrt avar=? x avars-rht)))))
	     (decavars-int (avars-to-int decavars))
	     (decavars-lft (avars-to-lft decavars))
	     (decavars-rht (avars-to-rht decavars)))
	(do ((decproof-and-decavars-list
	      (let* ((decproof-and-decavars1
		      (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
		       op (append decavars-lft decavars-int)
		       (make-impnc
			(impnc-form-to-premise (proof-to-formula op))
			decfla)))
		     (decproof1 (car decproof-and-decavars1))
		     (decavars1 (cadr decproof-and-decavars1))
		     (decavars1-lft (avars-to-lft decavars1))
		     (decavars1-int (avars-to-int decavars1))
		     (decfla1 (proof-to-formula decproof1))
		     (decproof-and-decavars2
		      (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
		       arg (append decavars1-int decavars-rht)
		       (imp-impnc-form-to-premise decfla1))))
		(list decproof-and-decavars1 decproof-and-decavars2))
	      (let* ((decproof-and-decavars1 (car decproof-and-decavars-list))
		     (decproof1 (car decproof-and-decavars1))
		     (decavars1 (cadr decproof-and-decavars1))
		     (decavars1-lft (avars-to-lft decavars1))
		     (decfla1 (proof-to-formula decproof1))
		     (decproof-and-decavars2 (cadr decproof-and-decavars-list))
		     (decproof2 (car decproof-and-decavars2))
		     (decavars2 (cadr decproof-and-decavars2))
		     (decavars2-int (avars-to-int decavars2))
		     (decavars2-rht (avars-to-rht decavars2))
		     (decfla2 (proof-to-formula decproof2))
		     (decproof-and-decavars3
		      (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
		       op (append decavars1-lft decavars2-int)
		       (if (impnc-form? decfla1)
			   (make-impnc decfla2
				       (impnc-form-to-conclusion decfla1))
			   (make-imp decfla2
				     (imp-form-to-conclusion decfla1)))))
		     (decproof3 (car decproof-and-decavars3))
		     (decavars3 (cadr decproof-and-decavars3))
		     (decavars3-int (avars-to-int decavars3))
		     (decfla3 (proof-to-formula decproof3))
		     (decproof-and-decavars4
		      (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
		       arg (append decavars3-int decavars2-rht)
		       (imp-impnc-form-to-premise decfla3))))
		(list decproof-and-decavars3 decproof-and-decavars4)))
	     (i 0 (+ 1 i)))
	    ((let* ((decproof-and-decavars1 (car decproof-and-decavars-list))
		    (decproof1 (car decproof-and-decavars1))
		    (decavars1 (cadr decproof-and-decavars1))
		    (decproof-and-decavars2 (cadr decproof-and-decavars-list))
		    (decproof2 (car decproof-and-decavars2))
		    (decavars2 (cadr decproof-and-decavars2))
		    (decavars1-int (avars-to-int decavars1))
		    (decavars2-int (avars-to-int decavars2))
		    (decfla1 (proof-to-formula decproof1))
		    (decfla2 (proof-to-formula decproof2)))
	       (or (and (null? (set-minus-wrt
				avar-full=? decavars1-int decavars2-int))
			(null? (set-minus-wrt
				avar-full=? decavars2-int decavars1-int))
			(classical-formula=?
			 (imp-impnc-form-to-premise decfla1) decfla2))
		   (= 2 i)))
	     (let* ((decproof-and-decavars1 (car decproof-and-decavars-list))
		    (decproof1 (car decproof-and-decavars1))
		    (decavars1 (cadr decproof-and-decavars1))
		    (decfla1 (proof-to-formula decproof1))
		    (decproof-and-decavars2 (cadr decproof-and-decavars-list))
		    (decproof2 (car decproof-and-decavars2))
		    (decavars2 (cadr decproof-and-decavars2))
		    (decavars2-rht (avars-to-rht decavars2)))
					;(display "exit loop") (newline)
	       (if (= 3 i)
		   (begin (display "forced exit") (newline)
			  (display "decavars1-int: ")
			  (pp-context (avars-to-int decavars1))
			  (display "decavars2-int: ")
			  (pp-context (avars-to-int decavars2)) (newline)
			  (display "prem: ")
			  (pp (imp-impnc-form-to-premise decfla1))
			  (display "decfla2: ")
			  (pp (nf (proof-to-formula decproof2)))))
	       (list (if (impnc-form? decfla1)
			 (make-proof-in-impnc-elim-form decproof1 decproof2)
			 (make-proof-in-imp-elim-form decproof1 decproof2))
		     (append decavars1 decavars2-rht)))))))
     ((proof-in-allnc-intro-form)
      (let* ((var (proof-in-allnc-intro-form-to-var proof))
	     (kernel (proof-in-allnc-intro-form-to-kernel proof))
	     (decvar (all-allnc-form-to-var decfla))
	     (deckernel (all-allnc-form-to-kernel decfla))
	     (subst-deckernel
	      (if (equal? var decvar)
		  deckernel
		  (formula-subst deckernel decvar (make-term-in-var-form var))))
	     (decproof-and-ext-decavars
	      (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
	       kernel decavars subst-deckernel))
	     (decproof (car decproof-and-ext-decavars))
	     (ext-decavars (cadr decproof-and-ext-decavars)))
	(list (if (and (allnc-form? decfla)
		       (not (member var (proof-to-cvars decproof))))
		  (make-proof-in-allnc-intro-form var decproof)
		  (make-proof-in-all-intro-form var decproof))
	      ext-decavars)))
     ((proof-in-allnc-elim-form)
      (let* ((op (proof-in-allnc-elim-form-to-op proof))
	     (arg (proof-in-allnc-elim-form-to-arg proof))
	     (op-formula (proof-to-formula op))
	     (var (allnc-form-to-var op-formula))
	     (kernel (allnc-form-to-kernel op-formula))
	     (allnc-decfla
	      (make-allnc var (dec-variants-to-lub kernel decfla)))
	     (decproof-and-ext-decavars
	      (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
	       op decavars allnc-decfla))
	     (decproof (car decproof-and-ext-decavars))
	     (ext-decavars (cadr decproof-and-ext-decavars)))
	(list (if (allnc-form? (proof-to-formula decproof))
		  (make-proof-in-allnc-elim-form decproof arg)
		  (make-proof-in-all-elim-form decproof arg))
	      ext-decavars)))
     ((proof-in-and-intro-form)
      (let* ((left (proof-in-and-intro-form-to-left proof))
	     (right (proof-in-and-intro-form-to-right proof))
	     (avars1 (proof-to-free-avars left))
	     (avars2 (proof-to-free-avars right))
	     (avars-int (intersection-wrt avar=? avars1 avars2))
	     (avars-lft (set-minus-wrt avar=? avars1 avars-int))
	     (avars-rht (set-minus-wrt avar=? avars2 avars-int))
	     (avars-to-int
	      (lambda (avars)
		(list-transform-positive avars
		  (lambda (x) (member-wrt avar=? x avars-int)))))
	     (avars-to-lft
	      (lambda (avars)
		(list-transform-positive avars
		  (lambda (x) (member-wrt avar=? x avars-lft)))))
	     (avars-to-rht
	      (lambda (avars)
		(list-transform-positive avars
		  (lambda (x) (member-wrt avar=? x avars-rht)))))
	     (decavars-int (avars-to-int decavars))
	     (decavars-lft (avars-to-lft decavars))
	     (decavars-rht (avars-to-rht decavars)))
	(do ((decproof-and-decavars-list
	      (let* ((decproof-and-decavars1
		      (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
		       left (append decavars-lft decavars-int)
		       (and-form-to-left decfla)))
		     (decproof1 (car decproof-and-decavars1))
		     (decavars1 (cadr decproof-and-decavars1))
		     (decavars1-lft (avars-to-lft decavars1))
		     (decavars1-int (avars-to-int decavars1))
		     (decfla1 (proof-to-formula decproof1))
		     (decproof-and-decavars2
		      (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
		       right (append decavars1-int decavars-rht)
		       (and-form-to-right decfla))))
		(list decproof-and-decavars1 decproof-and-decavars2))
	      (let* ((decproof-and-decavars1 (car decproof-and-decavars-list))
		     (decproof1 (car decproof-and-decavars1))
		     (decavars1 (cadr decproof-and-decavars1))
		     (decavars1-lft (avars-to-lft decavars1))
		     (decfla1 (proof-to-formula decproof1))
		     (decproof-and-decavars2 (cadr decproof-and-decavars-list))
		     (decproof2 (car decproof-and-decavars2))
		     (decavars2 (cadr decproof-and-decavars2))
		     (decavars2-int (avars-to-int decavars2))
		     (decavars2-rht (avars-to-rht decavars2))
		     (decfla2 (proof-to-formula decproof2))
		     (decproof-and-decavars3
		      (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
		       left (append decavars1-lft decavars2-int) decfla1))
		     (decproof3 (car decproof-and-decavars3))
		     (decavars3 (cadr decproof-and-decavars3))
		     (decavars3-int (avars-to-int decavars3))
		     (decfla3 (proof-to-formula decproof3))
		     (decproof-and-decavars4
		      (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
		       right (append decavars3-int decavars2-rht) decfla2)))
		(list decproof-and-decavars3 decproof-and-decavars4)))
	     (i 0 (+ 1 i)))
	    ((let* ((decproof-and-decavars1 (car decproof-and-decavars-list))
		    (decavars1 (cadr decproof-and-decavars1))
		    (decproof-and-decavars2 (cadr decproof-and-decavars-list))
		    (decavars2 (cadr decproof-and-decavars2))
		    (decavars1-int (avars-to-int decavars1))
		    (decavars2-int (avars-to-int decavars2)))
	       (or (and (null? (set-minus-wrt
				avar-full=? decavars1-int decavars2-int))
			(null? (set-minus-wrt
				avar-full=? decavars2-int decavars1-int)))
		   (= 2 i)))
	     (let* ((decproof-and-decavars1 (car decproof-and-decavars-list))
		    (decproof1 (car decproof-and-decavars1))
		    (decavars1 (cadr decproof-and-decavars1))
		    (decproof-and-decavars2 (cadr decproof-and-decavars-list))
		    (decproof2 (car decproof-and-decavars2))
		    (decavars2 (cadr decproof-and-decavars2))
		    (decavars2-rht (avars-to-rht decavars2)))
					;(display "exit loop") (newline)
	       (if (= 2 i)
		   (begin (display "forced exit") (newline)
			  (display "decavars1-int: ")
			  (pp-context (avars-to-int decavars1))
			  (display "decavars2-int: ")
			  (pp-context (avars-to-int decavars2)) (newline)))
	       (list (make-proof-in-and-intro-form decproof1 decproof2)
		     (append decavars1 decavars2-rht)))))))
     ((proof-in-and-elim-left-form)
      (let* ((kernel (proof-in-and-elim-left-form-to-kernel proof))
	     (decproof-and-ext-decavars
	      (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
	       kernel decavars
	       (make-and decfla (and-form-to-right
				 (proof-to-formula kernel)))))
	     (decproof (car decproof-and-ext-decavars))
	     (ext-decavars (cadr decproof-and-ext-decavars)))
	(list (make-proof-in-and-elim-left-form decproof)
	      ext-decavars)))
     ((proof-in-and-elim-right-form)
      (let* ((kernel (proof-in-and-elim-right-form-to-kernel proof))
	     (decproof-and-ext-decavars
	      (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
	       kernel decavars
	       (make-and (and-form-to-left (proof-to-formula kernel)) decfla)))
	     (decproof (car decproof-and-ext-decavars))
	     (ext-decavars (cadr decproof-and-ext-decavars)))
	(list (make-proof-in-and-elim-right-form decproof)
	      ext-decavars)))
     (else (myerror
	    "undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars"
	    "unexpected proof tag"
	    (tag proof))))))

; op-and-args-and-altop-and-decfla-and-decavars-to-proof assumes that
; op applied to args proves an extension of decfla, and that altop
; differs from op only in possibly requiring additional premises.  It
; is tested whether altop applied to args and some of decavars is
; between op applied to args and decfla w.r.t. extension.  If so, a
; proof based on altop is returned, else #f.

(define (op-and-args-and-altop-and-decfla-and-decavars-to-proof
	 op args altop decfla decavars)
  (do ((altproof-and-restargs-and-proof
	(list altop args op)
	(let* ((altproof (car altproof-and-restargs-and-proof))
	       (restargs (cadr altproof-and-restargs-and-proof))
	       (proof (caddr altproof-and-restargs-and-proof))
	       (altfla (proof-to-formula altproof))
	       (fla (proof-to-formula proof)))
	  (cond
	   ((or (and (all-allnc-form? fla)
		     (all-allnc-form? altfla))
		(and (imp-impnc-form? fla)
		     (imp-impnc-form? altfla)
		     (formula=? (imp-impnc-form-to-premise fla)
				(imp-impnc-form-to-premise altfla))))
	    (list (mk-proof-in-elim-form altproof (car restargs))
		  (cdr restargs)
		  (mk-proof-in-elim-form proof (car restargs))))
	   ((and (imp-impnc-form? altfla)
		 (member-wrt formula=?
			     (imp-impnc-form-to-premise altfla)
			     (map avar-to-formula decavars)))
	    (let ((decavar
		   (car (list-transform-positive decavars
			  (lambda (avar)
			    (formula=? (imp-impnc-form-to-premise altfla)
				       (avar-to-formula avar)))))))
	      (list (mk-proof-in-elim-form
		     altproof (make-proof-in-avar-form decavar))
		    restargs
		    proof)))
	   (else (list #f restargs proof))))))
      ((or (not (car altproof-and-restargs-and-proof))
	   (let* ((altproof (car altproof-and-restargs-and-proof))
		  (proof (caddr altproof-and-restargs-and-proof))
		  (fla (proof-to-formula proof))
		  (altfla (proof-to-formula altproof)))
	     (and (dec-variants? fla altfla)
		  (extending-dec-variants? fla altfla)
		  (dec-variants? altfla decfla)
		  (extending-dec-variants? altfla decfla))))
       (car altproof-and-restargs-and-proof))))

; decfla-and-opname-to-altops returns a list of alternative operators
; (assumption constants) possibly usable to prove decfla.

(define (decfla-and-opname-to-altops decfla opname)
  (let* ((thm-or-ga-items (append THEOREMS GLOBAL-ASSUMPTIONS))
	 (candidate-thm-or-ga-items ;c.r., no pvar as final conclusion
	  (list-transform-positive thm-or-ga-items
	    (lambda (thm-or-ga-item)
	      (let* ((ac (cadr thm-or-ga-item))
		     (uninst-fla (aconst-to-uninst-formula ac))
		     (concl (imp-impnc-all-allnc-form-to-final-conclusion
			     uninst-fla)))
		(and
		 (or (and (predicate-form? concl)
			  (idpredconst-form?
			   (predicate-form-to-predicate concl)))
					;temporarily we still have
		     (ex-form? concl)
		     (exnc-form? concl)
		     (and-form? concl))
		 (not (formula-of-nulltype? concl))
		 (not (string=? (car thm-or-ga-item) opname)))))))
	 (candidate-aconsts (map cadr candidate-thm-or-ga-items))
	 (fitting-aconsts-with-psubst
	  (do ((l candidate-aconsts (cdr l))
	       (res
		'()
		(let* ((ac (car l))
		       (uninst-fla (aconst-to-uninst-formula ac))
		       (match-res
			(do ((concl
			      uninst-fla
			      (cond ((imp-impnc-form? concl)
				     (imp-impnc-form-to-conclusion concl))
				    ((all-allnc-form? concl)
				     (all-allnc-form-to-kernel concl))
				    (else #f)))
			     (mres ;ignore-deco-flag set to #t
			      (match2 uninst-fla decfla #t)
			      (or mres (match2 concl decfla #t))))
			    ((or mres (not concl)) mres))))
		  (if match-res
		      (let ((psubst (list-transform-positive match-res
				      (lambda (p) (pvar-form? (caar p))))))
			(cons (list ac psubst) res))
		      res))))
	      ((null? l) (reverse res)))))
    (map (lambda (x)
	   (let* ((ac (car x))
		  (psubst (cadr x))
		  (subst-proof (proof-substitute
				(make-proof-in-aconst-form ac) psubst))
		  (free (formula-to-free
			 (proof-to-formula subst-proof))))
	     (apply mk-proof-in-nc-intro-form
		    (append free (list subst-proof)))))
	 fitting-aconsts-with-psubst)))

; We assume that in IDS variants appear in decreasing order (i.e., the
; more extended ones are introduced first), that all possible variants
; do appear and that their clauses use the same parameter predicate
; variables.

(define (intro-aconst-and-decfla-to-min-intro-aconst aconst decfla)
  (let* ((repro-data (aconst-to-repro-formulas aconst))
	 (i (car repro-data))
	 (uninst-fla (aconst-to-uninst-formula aconst))
	 (uninst-idpc-fla (imp-impnc-form-to-final-conclusion
			   (all-allnc-form-to-final-kernel uninst-fla)))
	 (idpc (if (predicate-form? uninst-idpc-fla)
		   (predicate-form-to-predicate uninst-idpc-fla)
		   (myerror "intro-aconst-and-decfla-to-min-intro-aconst"
			    "predicate form expected" uninst-idpc-fla)))
	 (idpc-name (idpredconst-to-name idpc))
	 (given-clauses (idpredconst-name-to-clauses idpc-name))
	 (l (length given-clauses))
	 (variant-idpc-names ;assumed to be in increasing order in IDS
	  (list-transform-positive (map car IDS)
	    (lambda (name)
	      (let ((clauses (idpredconst-name-to-clauses name)))
		(and (= l (length clauses))
		     (apply and-op (map (lambda (cl1 cl2)
				     (dec-variants-up-to-pvars? cl1 cl2))
				   given-clauses clauses)))))))
	 (decfla-without-param-vars
	  (allnc-form-to-final-kernel
	   decfla (length (formula-to-free (aconst-to-inst-formula aconst)))))
	 (dec-kernel
	  (all-allnc-form-to-final-kernel decfla-without-param-vars))
	 (dec-idpc-fla (imp-impnc-form-to-final-conclusion dec-kernel))
	 (dec-idpc (predicate-form-to-predicate dec-idpc-fla))
	 (dec-args (predicate-form-to-args dec-idpc-fla))
	 (fitting-idpc-names ;whose i-th clause exactly fits decfla
	  (list-transform-positive variant-idpc-names
	    (lambda (name)
	      (let ((clauses (idpredconst-name-to-clauses name)))
		(and (= l (length clauses)) ;do not ignore decs
		     (match2 (list-ref clauses i)
			     decfla-without-param-vars #f)))))) 
	 (min-idpc-name
	  (if (pair? fitting-idpc-names)
	      (car fitting-idpc-names)
	      (myerror "intro-aconst-and-decfla-to-min-intro-aconst"
		       "fitting idpredconst missing for" decfla)))
	 (min-dec-idpc
	  (make-idpredconst min-idpc-name
			    (idpredconst-to-types dec-idpc)
			    (idpredconst-to-cterms dec-idpc))))
    (number-and-idpredconst-to-intro-aconst i min-dec-idpc)))

(define (elim-aconst-and-decfla-to-min-elim-aconst aconst decfla)
  (let* ((name (aconst-to-name aconst)) ;"Elim"
	 (kind (aconst-to-kind aconst))
	 (uninst-fla (aconst-to-uninst-formula aconst))
	 (uninst-idpc-fla
	  (if (imp-form? uninst-fla)
	      (imp-form-to-premise uninst-fla)
	      (myerror "elim-aconst-and-decfla-to-min-elim-aconst"
		       "unexpected uninstatiated formula" uninst-fla)))
	 (idpc (if (predicate-form? uninst-idpc-fla)
		   (predicate-form-to-predicate uninst-idpc-fla)
		   (myerror "elim-aconst-and-decfla-to-min-elim-aconst"
			    "predicate form expected" uninst-idpc-fla)))
	 (idpc-name (idpredconst-to-name idpc))
	 (given-clauses (idpredconst-name-to-clauses idpc-name))
	 (l (length given-clauses))
	 (variant-idpc-names ;assumed to be in increasing order in IDS
	  (list-transform-positive (map car IDS)
	    (lambda (name)
	      (let ((clauses (idpredconst-name-to-clauses name)))
		(and (= l (length clauses))
		     (apply and-op (map (lambda (cl1 cl2)
				     (dec-variants-up-to-pvars? cl1 cl2))
				   given-clauses clauses)))))))
	 (dec-kernel (all-allnc-form-to-final-kernel decfla))
	 (dec-idpc-fla (imp-form-to-premise dec-kernel))
	 (dec-idpc (predicate-form-to-predicate dec-idpc-fla))
	 (dec-args (predicate-form-to-args dec-idpc-fla))
	 (dec-concl (imp-form-to-conclusion dec-kernel))
	 (dec-clauses (imp-impnc-form-to-premises dec-concl l))
	 (dec-final-concl (imp-impnc-form-to-final-conclusion dec-concl l))
	 (fitting-idpc-names ;whose clauses exactly fit dec-clauses
	  (list-transform-positive variant-idpc-names
	    (lambda (name)
	      (let* ((clauses (idpredconst-name-to-clauses name)))
		(apply and-op (map (lambda (cl dec-cl)
				     (match2 cl dec-cl #f)) ;do not ignore decs
				   clauses dec-clauses))))))
	 (min-idpc-name
	  (if (pair? fitting-idpc-names)
	      (car fitting-idpc-names)
	      (myerror "elim-aconst-and-decfla-to-min-elim-aconst"
		       "fitting idpredconst missing for" decfla)))
	 (min-dec-idpc
	  (make-idpredconst min-idpc-name
			    (idpredconst-to-types dec-idpc)
			    (idpredconst-to-cterms dec-idpc)))
	 (min-dec-idpc-fla (apply make-predicate-formula
				  (cons min-dec-idpc dec-args)))
	 (min-imp-fla (make-imp min-dec-idpc-fla dec-final-concl))
	 (min-elim-aconst (imp-formulas-to-elim-aconst min-imp-fla))
	 (min-uninst-fla (aconst-to-uninst-formula min-elim-aconst))
	 (extended-tpinst (aconst-and-dec-inst-formula-to-extended-tpinst
			   min-elim-aconst decfla))
	 (aconst-without-repro-formulas
	  (make-aconst name kind min-uninst-fla extended-tpinst)))
    (apply make-aconst (append (list name kind min-uninst-fla extended-tpinst)
			       (aconst-to-computed-repro-formulas
				aconst-without-repro-formulas)))))

(define (undec-proof-and-decavars-and-decfla-to-decproof
	 proof decavars decfla)
  (car (undec-proof-and-decavars-and-decfla-to-decproof-and-ext-decavars
	proof decavars decfla)))

(define (decorate proof)
  (if (formula-of-nulltype? (proof-to-formula proof))
      proof
      (undec-proof-and-decavars-and-decfla-to-decproof
       (proof-to-undec-proof proof)
       (proof-to-free-avars proof)
       (proof-to-formula proof))))


; 10-2. Normalization by evaluation
; =================================

; Normalization of proofs will be done by reduction to normalization of
; terms.  (1) Construct a term from the proof.  To do this properly,
; create for every free avar in the given proof a new var whose type
; comes from the formula of the avar.  Store this information.  Note
; that in this construction one also has to first create new vars for
; the bound avars.  Similary to avars we have to treat assumption
; constants which are not axioms, i.e., theorems or global assumptions.
; (2) Normalize the resulting term.  (3) Reconstruct a normal proof from
; this term, the end formula and the stored information.  - The critical
; variables are carried along for efficiency reasons.

; To assign recursion constants to induction constants, we need to
; associate type variables with predicate variables, in such a way
; that we can later refer to this assignment.  Therefore we use a
; global variable PVAR-TO-TVAR-ALIST, which memorizes the assigment
; done so far.  A fixed PVAR-TO-TVAR refers to and updates
; PVAR-TO-TVAR-ALIST.

; For term extraction, in particular in formula-to-et-type and
; formula-to-etd-types, we will also need to assign type variables to
; predicate variables, this time only for those with positive or
; negative computational content.  There we will also refer to the
; same PVAR-TO-TVAR and PVAR-TO-TVARP and PVAR-TO-TVARN.  Later
; reference is necessary, because such tvars will appear in extracted
; terms of theorems involving pvars, and in a given development there
; may be many auxiliary lemmata containing the same pvar.  In a
; finished development with no free pvars left PVAR-TO-TVAR
; PVAR-TO-TVARP and PVAR-TO-TVARN are not relevant any more, because
; all pvars (in aconsts or idpcs) are bound.  In an unfinished
; development we want to assign the same tvar to all occurrences of a
; pvar, and it does not matter which tvar it is.

; Example Id: all alpha, beta all P^(alpha=>prop+beta).  P^ -> P^ has
; [beta][y]y as extracted term.  The tvar beta disappears as soon as
; Id is applied to some cterm without pvars.

(define PVAR-TO-TVAR-ALIST '())
(define INITIAL-PVAR-TO-TVAR-ALIST PVAR-TO-TVAR-ALIST)

(define (PVAR-TO-TVAR pvar)
  (let ((info (assoc pvar PVAR-TO-TVAR-ALIST)))
    (if info
	(cadr info)
	(let ((newtvar (new-tvar)))
	  (set! PVAR-TO-TVAR-ALIST
		(cons (list pvar newtvar) PVAR-TO-TVAR-ALIST))
	  newtvar))))

; Probably PVAR-TO-TVARP is not necessary; PVAR-TO-TVAR should suffice.

(define PVAR-TO-TVARP-ALIST '())
(define INITIAL-PVAR-TO-TVARP-ALIST PVAR-TO-TVARP-ALIST)

(define (PVAR-TO-TVARP pvar)
  (let ((info (assoc pvar PVAR-TO-TVARP-ALIST)))
    (if info
	(cadr info)
	(let ((newtvarp (new-tvar)))
	  (set! PVAR-TO-TVARP-ALIST
		(cons (list pvar newtvarp) PVAR-TO-TVARP-ALIST))
	  newtvarp))))

(define PVAR-TO-TVARN-ALIST '())
(define INITIAL-PVAR-TO-TVARN-ALIST PVAR-TO-TVARN-ALIST)

(define (PVAR-TO-TVARN pvar)
  (let ((info (assoc pvar PVAR-TO-TVARN-ALIST)))
    (if info
	(cadr info)
	(let ((newtvarn (new-tvar)))
	  (set! PVAR-TO-TVARN-ALIST
		(cons (list pvar newtvarn) PVAR-TO-TVARN-ALIST))
	  newtvarn))))

; Given a proof and suppose we want to extract its content.  Then we
; can concentrate on its computationally relevant parts, and replace
; the rest by newly introduced assumption variables.  This is useful
; for efficiency reasons when normalizing, and also for studying the
; need and the effect of pi-normalization, simplification and pruning.

(define (nbe-normalize-proof-without-eta proof)
  (nbe-normalize-proof-without-eta-aux proof #f #t))

(define (nbe-normalize-proof-without-eta-for-extraction proof)
  (nbe-normalize-proof-without-eta-aux
   proof #t (not (formula-of-nulltype? (proof-to-formula proof)))))

(define (nbe-normalize-proof-without-eta-aux
	 proof extraction-flag content-flag)
  (if
   (and extraction-flag (not content-flag))
   (let* ((proof-and-asubst (proof-to-c-r-proof-and-asubst proof))
	  (proof1 (car proof-and-asubst))
	  (asubst1 (cadr proof-and-asubst))
	  (nproof1 (nbe-normalize-proof-without-eta proof1)))
     (proof-substitute nproof1 asubst1))
   (let* ((formula (proof-to-formula proof))
	  (genavars (append (proof-to-free-and-bound-avars proof)
			    (proof-to-aconsts-without-rules proof)))
	  (vars (map (lambda (x)
		       (type-to-new-var
			(nbe-formula-to-type
			 (cond ((avar-form? x) (avar-to-formula x))
			       ((aconst-form? x) (aconst-to-formula x))
			       (else (myerror
				      "nbe-normalize-proof"
				      "genavar expected" x))))))
		     genavars))
	  (genavar-var-alist (map (lambda (u x) (list u x)) genavars vars))
	  (var-genavar-alist (map (lambda (x u) (list x u)) vars genavars))
	  (pterm (proof-and-genavar-var-alist-to-pterm
		  genavar-var-alist proof))
	  (npterm (nbe-normalize-term-without-eta pterm)))
     (npterm-and-var-genavar-alist-and-formula-to-proof
      npterm var-genavar-alist '() (unfold-formula formula)))))

(define (proof-to-c-r-proof-and-asubst proof)
  (if
   (formula-of-nulltype? (proof-to-formula proof))
   (let* ((context (proof-to-context proof))
	  (cvars (proof-to-cvars proof))
	  (avar (formula-to-new-avar
		 (context-and-cvars-and-formula-to-formula
		  context cvars (proof-to-formula proof)))))
     (list
      (apply mk-proof-in-elim-form
	     (append (list (make-proof-in-avar-form avar))
		     (map (lambda (x) (if (var-form? x)
					  (make-term-in-var-form x)
					  (make-proof-in-avar-form x)))
			  context)))
      (list (list avar
		  (apply mk-proof-in-intro-form
			 (append context (list proof)))))))
   (case (tag proof)
     ((proof-in-avar-form proof-in-aconst-form) (list proof '()))
     ((proof-in-imp-intro-form)
      (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	     (kernel (proof-in-imp-intro-form-to-kernel proof))
	     (prev (proof-to-c-r-proof-and-asubst kernel))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-imp-intro-form avar prev-proof)
	      prev-asubst)))
     ((proof-in-imp-elim-form)
      (let* ((op (proof-in-imp-elim-form-to-op proof))
	     (arg (proof-in-imp-elim-form-to-arg proof))
	     (prev1 (proof-to-c-r-proof-and-asubst op))
	     (prev-proof1 (car prev1))
	     (prev-asubst1 (cadr prev1))
	     (prev2 (proof-to-c-r-proof-and-asubst arg))
	     (prev-proof2 (car prev2))
	     (prev-asubst2 (cadr prev2)))
	(list (make-proof-in-imp-elim-form prev-proof1 prev-proof2)
	      (append prev-asubst1 prev-asubst2))))
     ((proof-in-and-intro-form)
      (let* ((left (proof-in-and-intro-form-to-left proof))
	     (right (proof-in-and-intro-form-to-right proof))
	     (prev1 (proof-to-c-r-proof-and-asubst left))
	     (prev-proof1 (car prev1))
	     (prev-asubst1 (cadr prev1))
	     (prev2 (proof-to-c-r-proof-and-asubst right))
	     (prev-proof2 (car prev2))
	     (prev-asubst2 (cadr prev2)))
	(list (make-proof-in-and-intro-form prev-proof1 prev-proof2)
	      (append prev-asubst1 prev-asubst2))))
     ((proof-in-and-elim-left-form)
      (let* ((kernel (proof-in-and-elim-left-form-to-kernel proof))
	     (prev (proof-to-c-r-proof-and-asubst kernel))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-and-elim-left-form prev-proof) prev-asubst)))
     ((proof-in-and-elim-right-form)
      (let* ((kernel (proof-in-and-elim-right-form-to-kernel proof))
	     (prev (proof-to-c-r-proof-and-asubst kernel))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-and-elim-right-form prev-proof) prev-asubst)))
     ((proof-in-all-intro-form)
      (let* ((var (proof-in-all-intro-form-to-var proof))
	     (kernel (proof-in-all-intro-form-to-kernel proof))
	     (prev (proof-to-c-r-proof-and-asubst kernel))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-all-intro-form var prev-proof)
	      prev-asubst)))
     ((proof-in-all-elim-form)
      (let* ((op (proof-in-all-elim-form-to-op proof))
	     (arg (proof-in-all-elim-form-to-arg proof))
	     (prev (proof-to-c-r-proof-and-asubst op))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-all-elim-form prev-proof arg) prev-asubst)))
     ((proof-in-allnc-intro-form)
      (let* ((var (proof-in-allnc-intro-form-to-var proof))
	     (kernel (proof-in-allnc-intro-form-to-kernel proof))
	     (prev (proof-to-c-r-proof-and-asubst kernel))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-allnc-intro-form var prev-proof)
	      prev-asubst)))
     ((proof-in-allnc-elim-form)
      (let* ((op (proof-in-allnc-elim-form-to-op proof))
	     (arg (proof-in-allnc-elim-form-to-arg proof))
	     (prev (proof-to-c-r-proof-and-asubst op))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-allnc-elim-form prev-proof arg) prev-asubst)))
     (else (myerror "proof-to-c-r-proof-and-asubst" "not implemented for"
		    (tag proof))))))

(define (genavar=? genavar1 genavar2)
  (or (and (avar-form? genavar1) (avar-form? genavar2)
	   (avar=? genavar1 genavar2))
      (and (aconst-form? genavar1) (aconst-form? genavar2)
	   (aconst=? genavar1 genavar2))))

(define (proof-and-genavar-var-alist-to-pterm genavar-var-alist proof)
  (case (tag proof)
    ((proof-in-avar-form)
     (let* ((avar (proof-in-avar-form-to-avar proof))
	    (info (assoc-wrt genavar=? avar genavar-var-alist))
	    (var (cadr info)))
       (make-term-in-var-form var)))
    ((proof-in-aconst-form)
     (let* ((aconst (proof-in-aconst-form-to-aconst proof))
	    (name (aconst-to-name aconst))
	    (repro-formulas (aconst-to-repro-formulas aconst)))
       (if (aconst-without-rules? aconst)
	   (let ((info (assoc-wrt genavar=? aconst genavar-var-alist)))
	     (if info
		 (make-term-in-var-form (cadr info))
		 (myerror
		  "proof-and-genavar-var-alist-to-pterm" "genavar expected"
		  (aconst-to-string aconst))))
	   (make-term-in-const-form
	    (cond
	     ((string=? "Ind" name)
	      (apply all-formulas-to-rec-const repro-formulas))
	     ((string=? "Cases" name)
	      (all-formula-to-cases-const (car repro-formulas)))
             ((string=? "GInd" name)
              (let* ((uninst-formula (aconst-to-uninst-formula aconst))
                     (vars (all-form-to-vars uninst-formula))
                     (m (- (length vars) 1)))
                (all-formula-to-grecguard-const (car repro-formulas) m)))
	     ((string=? "Intro" name)
	      (apply number-and-idpredconst-to-intro-const
		     repro-formulas)) ;better repro-data
             ((string=? "Efq" name) ;This is a hack.  The formula should be (?)
					;in the repro-data but isn't because
					;Efq is a global-assumption.
              (let ((formula (imp-form-to-conclusion
                              (allnc-form-to-final-kernel
                               (aconst-to-formula aconst)))))
                (formula-to-efq-const formula)))
	     ((string=? "Elim" name)
	      (apply imp-formulas-to-rec-const repro-formulas))
	     ((string=? "Ex-Intro" name)
	      (ex-formula-to-ex-intro-const (car repro-formulas)))
	     ((string=? "Ex-Elim" name)
	      (apply ex-formula-and-concl-to-ex-elim-const repro-formulas))
	     (else
	      (myerror "proof-and-genavar-var-alist-to-pterm" "aconst expected"
		       name)))))))
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (kernel (proof-in-imp-intro-form-to-kernel proof))
	    (info (assoc-wrt avar=? avar genavar-var-alist))
	    (var (cadr info)))
       (make-term-in-abst-form var (proof-and-genavar-var-alist-to-pterm
				    genavar-var-alist kernel))))
    ((proof-in-imp-elim-form)
     (let* ((op (proof-in-imp-elim-form-to-op proof))
	    (arg (proof-in-imp-elim-form-to-arg proof)))
       (make-term-in-app-form
	(proof-and-genavar-var-alist-to-pterm genavar-var-alist op)
	(proof-and-genavar-var-alist-to-pterm genavar-var-alist arg))))
    ((proof-in-impnc-intro-form)
     (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (info (assoc-wrt avar=? avar genavar-var-alist))
	    (var (cadr info)))
       (make-term-in-abst-form var (proof-and-genavar-var-alist-to-pterm
				    genavar-var-alist kernel))))
    ((proof-in-impnc-elim-form)
     (let* ((op (proof-in-impnc-elim-form-to-op proof))
	    (arg (proof-in-impnc-elim-form-to-arg proof)))
       (make-term-in-app-form
	(proof-and-genavar-var-alist-to-pterm genavar-var-alist op)
	(proof-and-genavar-var-alist-to-pterm genavar-var-alist arg))))
    ((proof-in-and-intro-form)
     (let ((left (proof-in-and-intro-form-to-left proof))
	   (right (proof-in-and-intro-form-to-right proof)))
       (make-term-in-pair-form
	(proof-and-genavar-var-alist-to-pterm genavar-var-alist left)
	(proof-and-genavar-var-alist-to-pterm genavar-var-alist right))))
    ((proof-in-and-elim-left-form)
     (let* ((kernel (proof-in-and-elim-left-form-to-kernel proof)))
       (make-term-in-lcomp-form
	(proof-and-genavar-var-alist-to-pterm genavar-var-alist kernel))))
    ((proof-in-and-elim-right-form)
     (let* ((kernel (proof-in-and-elim-right-form-to-kernel proof)))
       (make-term-in-rcomp-form
	(proof-and-genavar-var-alist-to-pterm genavar-var-alist kernel))))
    ((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-and-genavar-var-alist-to-pterm genavar-var-alist kernel))))
    ((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-and-genavar-var-alist-to-pterm genavar-var-alist op)
	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)))
       (make-term-in-abst-form
	var (proof-and-genavar-var-alist-to-pterm genavar-var-alist kernel))))
    ((proof-in-allnc-elim-form)
     (let* ((op (proof-in-allnc-elim-form-to-op proof))
	    (arg (proof-in-allnc-elim-form-to-arg proof)))
       (make-term-in-app-form
	(proof-and-genavar-var-alist-to-pterm genavar-var-alist op)
	arg)))
    (else
     (myerror "proof-and-genavar-var-alist-to-pterm" "proof tag expected"
	      (tag proof)))))

(define (npterm-and-var-genavar-alist-and-formula-to-proof
	 npterm var-genavar-alist crit formula)
  (case (tag npterm)
    ((term-in-abst-form)
     (let* ((npterm-var (term-in-abst-form-to-var npterm))
	    (npterm-kernel (term-in-abst-form-to-kernel npterm)))
       (cond
	((imp-form? formula)
	 (let* ((premise (imp-form-to-premise formula))
		(avar (formula-to-new-avar premise))
		(conclusion (imp-form-to-conclusion formula)))
	   (make-proof-in-imp-intro-form
	    avar	      
	    (npterm-and-var-genavar-alist-and-formula-to-proof
	     npterm-kernel 
	     (cons (list npterm-var avar) var-genavar-alist)
	     (union (formula-to-free premise) crit)
	     conclusion))))
	((impnc-form? formula)
	 (let* ((premise (impnc-form-to-premise formula))
		(avar (formula-to-new-avar premise))
		(conclusion (impnc-form-to-conclusion formula)))
	   (make-proof-in-impnc-intro-form
	    avar	      
	    (npterm-and-var-genavar-alist-and-formula-to-proof
	     npterm-kernel 
	     (cons (list npterm-var avar) var-genavar-alist)
	     (union (formula-to-free premise) crit)
	     conclusion))))
	((all-form? formula)
	 (let* ((var (all-form-to-var formula))
		(kernel (all-form-to-kernel formula))
		(var-is-crit? (member var crit))
		(new-var (if var-is-crit? (var-to-new-var var) var))
		(new-kernel
		 (if var-is-crit?
		     (formula-subst kernel var (make-term-in-var-form new-var))
		     kernel))
		(new-npterm-kernel
		 (if (equal? npterm-var new-var)
		     npterm-kernel
		     (term-subst npterm-kernel
				 npterm-var
				 (make-term-in-var-form new-var)))))
	   (make-proof-in-all-intro-form
	    new-var
	    (npterm-and-var-genavar-alist-and-formula-to-proof
	     new-npterm-kernel var-genavar-alist crit new-kernel))))
	((allnc-form? formula)
	 (let* ((var (allnc-form-to-var formula))
		(kernel (allnc-form-to-kernel formula))
		(var-is-crit? (member var crit))
		(new-var (if var-is-crit? (var-to-new-var var) var))
		(new-kernel
		 (if var-is-crit?
		     (formula-subst kernel var (make-term-in-var-form new-var))
		     kernel))
		(new-npterm-kernel
		 (if (equal? npterm-var new-var)
		     npterm-kernel
		     (term-subst npterm-kernel
				 npterm-var
				 (make-term-in-var-form new-var)))))
	   (make-proof-in-allnc-intro-form
	    new-var
	    (npterm-and-var-genavar-alist-and-formula-to-proof
	     new-npterm-kernel var-genavar-alist crit new-kernel))))
	(else
	 (myerror
	  "npterm-and-var-genavar-alist-and-formula-to-proof"
	  "imp- or all-formula expected"
	  formula)))))
    ((term-in-pair-form)
     (let ((npterm-left (term-in-pair-form-to-left npterm))
	   (npterm-right (term-in-pair-form-to-right npterm)))
       (cond ((and-form? formula)
	      (let ((left-formula (and-form-to-left formula))
		    (right-formula (and-form-to-right formula)))
		(make-proof-in-and-intro-form
		 (npterm-and-var-genavar-alist-and-formula-to-proof
		  npterm-left var-genavar-alist crit left-formula)
		 (npterm-and-var-genavar-alist-and-formula-to-proof
		  npterm-right var-genavar-alist crit right-formula))))
	     (else (myerror
		    "npterm-and-var-genavar-alist-and-formula-to-proof" 
		    "and-formula expected"
		    formula)))))
    (else
     (let ((prev (elim-npterm-and-var-genavar-alist-to-proof
		  npterm var-genavar-alist crit)))
       (if (classical-formula=? formula (proof-to-formula prev))
	   prev
	   (myerror "npterm-and-var-genavar-alist-and-formula-to-proof"
                    "classical equal formulas expected"
		    formula
		    (proof-to-formula prev)))))))

(define (elim-npterm-and-var-genavar-alist-to-proof
	 npterm var-genavar-alist crit)
  (case (tag npterm)
    ((term-in-var-form)
     (let* ((var (term-in-var-form-to-var npterm))
	    (info (assoc var var-genavar-alist)))
       (if info
	   (let ((genavar (cadr info)))
	     (cond
	      ((avar-form? genavar) (make-proof-in-avar-form genavar))
	      ((aconst-form? genavar) (make-proof-in-aconst-form genavar))
	      (else (myerror "elim-npterm-and-var-genavar-alist-to-proof"
			     "unexpected genavar" genavar))))
	   (myerror
	    "elim-npterm-and-var-genavar-alist-to-proof" "unexpected term"
	    npterm))))
    ((term-in-const-form)
     (let* ((const (term-in-const-form-to-const npterm))
	    (name (const-to-name const))
	    (repro-formulas (const-to-type-info-or-repro-formulas const)))
       (make-proof-in-aconst-form
	(cond
	 ((string=? "Rec" name) ;first repro fla depends on type of rec const
	  (if
	   (all-form? (car repro-formulas))
	   (let* ((uninst-recop-type (const-to-uninst-type const))
                  (f (length (formula-to-free (car repro-formulas))))
		  (arg-types (arrow-form-to-arg-types uninst-recop-type))
		  (alg-type (list-ref arg-types f))
		  (alg-name (alg-form-to-name alg-type))
		  (transformed-repro-formulas
		   (list-transform-positive repro-formulas
		     (lambda (x)
		       (let* ((type (var-to-type (all-form-to-var x))))
			 (and (alg-form? type)
			      (equal? (alg-form-to-name type) alg-name))))))
		  (repro-formula
		   (if (= 1 (length transformed-repro-formulas))
		       (car transformed-repro-formulas)
		       (myerror 
			"elim-npterm-and-var-genavar-alist-to-proof"
			"unexpected repro formulas" repro-formulas)))
		  (permuted-repro-formulas
		   (cons repro-formula
			 (remove-wrt classical-formula=?
				     repro-formula repro-formulas))))
	     (apply all-formulas-to-ind-aconst permuted-repro-formulas))
	   (let* ((uninst-recop-type (const-to-uninst-type const))
                  (f (length (formula-to-free (car repro-formulas))))
		  (arg-types (arrow-form-to-arg-types uninst-recop-type))
                  (alg-type (list-ref arg-types f))
		  (alg-name (alg-form-to-name alg-type))
		  (transformed-repro-formulas
		   (list-transform-positive repro-formulas
		     (lambda (x)
		       (let* ((prem (imp-form-to-premise x))
			      (pred (predicate-form-to-predicate prem))
			      (name (idpredconst-to-name pred))
			      (nbe-alg-name (idpredconst-name-to-nbe-alg-name
					     name)))
			 (equal? nbe-alg-name alg-name)))))
		  (repro-formula
		   (if (= 1 (length transformed-repro-formulas))
		       (car transformed-repro-formulas)
		       (myerror 
			"elim-npterm-and-var-genavar-alist-to-proof"
			"unexpected repro formulas" repro-formulas)))
		  (permuted-repro-formulas
		   (cons repro-formula
			 (remove-wrt classical-formula=?
				     repro-formula repro-formulas))))
	     (apply imp-formulas-to-elim-aconst permuted-repro-formulas))))
	 ((string=? "Cases" name)
	  (all-formula-to-cases-aconst (car repro-formulas)))
         ((string=? "GRec" name) ;should not happen since "GRec" is not normal
          (myerror "elim-npterm-and-var-genavar-alist-to-proof"
		   "unexpected term"
                   name))
         ((string=? "GRecGuard" name)
          (let* ((free (formula-to-free (car repro-formulas)))
                 (f (length free))
                 (type (term-to-type npterm))
                 (auxtype (arrow-form-to-final-val-type type f))
                 (argtypes (arrow-form-to-arg-types
                            (arrow-form-to-arg-type auxtype)))
                 (m (length argtypes)))
            (all-formula-to-gind-aconst (car repro-formulas) m)))
         ((string=? "Efq" name)
          (formula-to-efq-aconst (car repro-formulas)))
	 ((string=? "Intro" name)
	  (apply number-and-idpredconst-to-intro-aconst repro-formulas))
	 ((string=? "Ex-Intro" name)
	  (ex-formula-to-ex-intro-aconst (car repro-formulas)))
	 ((string=? "Ex-Elim" name)
	  (apply ex-formula-and-concl-to-ex-elim-aconst repro-formulas))
	 (else (myerror
		"elim-npterm-and-var-genavar-alist-to-proof" "unexpected term"
		name))))))
    ((term-in-app-form)
     (let* ((op (term-in-app-form-to-op npterm))
	    (arg (term-in-app-form-to-arg npterm))
	    (prev1 (elim-npterm-and-var-genavar-alist-to-proof
		    op var-genavar-alist crit))
	    (formula ;unfolding might still be necessary for aconsts 02-07-10
	     (unfold-formula (proof-to-formula prev1))))
       (cond
	((imp-form? formula)
	 (make-proof-in-imp-elim-form
	  prev1
	  (npterm-and-var-genavar-alist-and-formula-to-proof
	   arg var-genavar-alist crit (imp-form-to-premise formula))))
	((impnc-form? formula)
	 (make-proof-in-impnc-elim-form
	  prev1
	  (npterm-and-var-genavar-alist-and-formula-to-proof
	   arg var-genavar-alist crit (impnc-form-to-premise formula))))
	((all-form? formula) (make-proof-in-all-elim-form prev1 arg))
	((allnc-form? formula) (make-proof-in-allnc-elim-form prev1 arg))
	(else (myerror "elim-npterm-and-var-genavar-alist-to-proof" 
		       "imp- or all-formula expected"
		       formula)))))
    ((term-in-lcomp-form)
     (let* ((kernel (term-in-lcomp-form-to-kernel npterm))
	    (prev (elim-npterm-and-var-genavar-alist-to-proof
		   kernel var-genavar-alist crit))
	    (formula (proof-to-formula prev)))
       (cond
	((and-form? formula)
	 (make-proof-in-and-elim-left-form prev))
	(else (myerror "elim-npterm-and-var-genavar-alist-to-proof" 
		       "and-formula expected"
		       formula)))))
    ((term-in-rcomp-form)
     (let* ((kernel (term-in-rcomp-form-to-kernel npterm))
	    (prev (elim-npterm-and-var-genavar-alist-to-proof
		   kernel var-genavar-alist crit))
	    (formula (proof-to-formula prev)))
       (cond
	((and-form? formula)
	 (make-proof-in-and-elim-right-form prev))
	(else (myerror "elim-npterm-and-var-genavar-alist-to-proof" 
		       "and-formula expected"
		       formula)))))
    (else
     (myerror "elim-npterm-and-var-genavar-alist-to-proof" "unexpected term"
	      npterm))))

(define (proof-to-c-r-proof-and-asubst proof)
  (if
   (formula-of-nulltype? (proof-to-formula proof))
   (let* ((context (proof-to-context proof))
	  (cvars (proof-to-cvars proof))
	  (avar (formula-to-new-avar
		 (context-and-cvars-and-formula-to-formula
		  context cvars (proof-to-formula proof)))))
     (list
      (apply mk-proof-in-elim-form
	     (append (list (make-proof-in-avar-form avar))
		     (map (lambda (x) (if (var-form? x)
					  (make-term-in-var-form x)
					  (make-proof-in-avar-form x)))
			  context)))
      (list (list avar
		  (apply mk-proof-in-intro-form
			 (append context (list proof)))))))
   (case (tag proof)
     ((proof-in-avar-form proof-in-aconst-form) (list proof '()))
     ((proof-in-imp-intro-form)
      (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	     (kernel (proof-in-imp-intro-form-to-kernel proof))
	     (prev (proof-to-c-r-proof-and-asubst kernel))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-imp-intro-form avar prev-proof)
	      prev-asubst)))
     ((proof-in-imp-elim-form)
      (let* ((op (proof-in-imp-elim-form-to-op proof))
	     (arg (proof-in-imp-elim-form-to-arg proof))
	     (prev1 (proof-to-c-r-proof-and-asubst op))
	     (prev-proof1 (car prev1))
	     (prev-asubst1 (cadr prev1))
	     (prev2 (proof-to-c-r-proof-and-asubst arg))
	     (prev-proof2 (car prev2))
	     (prev-asubst2 (cadr prev2)))
	(list (make-proof-in-imp-elim-form prev-proof1 prev-proof2)
	      (append prev-asubst1 prev-asubst2))))
     ((proof-in-and-intro-form)
      (let* ((left (proof-in-and-intro-form-to-left proof))
	     (right (proof-in-and-intro-form-to-right proof))
	     (prev1 (proof-to-c-r-proof-and-asubst left))
	     (prev-proof1 (car prev1))
	     (prev-asubst1 (cadr prev1))
	     (prev2 (proof-to-c-r-proof-and-asubst right))
	     (prev-proof2 (car prev2))
	     (prev-asubst2 (cadr prev2)))
	(list (make-proof-in-and-intro-form prev-proof1 prev-proof2)
	      (append prev-asubst1 prev-asubst2))))
     ((proof-in-and-elim-left-form)
      (let* ((kernel (proof-in-and-elim-left-form-to-kernel proof))
	     (prev (proof-to-c-r-proof-and-asubst kernel))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-and-elim-left-form prev-proof) prev-asubst)))
     ((proof-in-and-elim-right-form)
      (let* ((kernel (proof-in-and-elim-right-form-to-kernel proof))
	     (prev (proof-to-c-r-proof-and-asubst kernel))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-and-elim-right-form prev-proof) prev-asubst)))
     ((proof-in-all-intro-form)
      (let* ((var (proof-in-all-intro-form-to-var proof))
	     (kernel (proof-in-all-intro-form-to-kernel proof))
	     (prev (proof-to-c-r-proof-and-asubst kernel))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-all-intro-form var prev-proof)
	      prev-asubst)))
     ((proof-in-all-elim-form)
      (let* ((op (proof-in-all-elim-form-to-op proof))
	     (arg (proof-in-all-elim-form-to-arg proof))
	     (prev (proof-to-c-r-proof-and-asubst op))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-all-elim-form prev-proof arg) prev-asubst)))
     ((proof-in-allnc-intro-form)
      (let* ((var (proof-in-allnc-intro-form-to-var proof))
	     (kernel (proof-in-allnc-intro-form-to-kernel proof))
	     (prev (proof-to-c-r-proof-and-asubst kernel))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-allnc-intro-form var prev-proof)
	      prev-asubst)))
     ((proof-in-allnc-elim-form)
      (let* ((op (proof-in-allnc-elim-form-to-op proof))
	     (arg (proof-in-allnc-elim-form-to-arg proof))
	     (prev (proof-to-c-r-proof-and-asubst op))
	     (prev-proof (car prev))
	     (prev-asubst (cadr prev)))
	(list (make-proof-in-allnc-elim-form prev-proof arg) prev-asubst)))
     (else (myerror "proof-to-c-r-proof-and-asubst" "not implemented for"
		    (tag proof))))))

(define (proof-to-eta-nf proof)
  (proof-to-eta-nf-aux proof #f #t))

(define (proof-to-eta-nf-for-extraction proof)
  (proof-to-eta-nf-aux
   proof #t (not (formula-of-nulltype? (proof-to-formula proof)))))

(define (proof-to-eta-nf-aux proof extraction-flag content-flag)
  (if
   (and extraction-flag (not content-flag))
   proof
   (case (tag proof)
     ((proof-in-imp-intro-form) ;[u]Mu -> M, if u is not free in M
      (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	     (kernel (proof-in-imp-intro-form-to-kernel proof))
	     (prev (proof-to-eta-nf-aux kernel extraction-flag content-flag)))
	(if (and (proof-in-imp-elim-form? prev)
		 (proof=? (proof-in-imp-elim-form-to-arg prev)
			  (make-proof-in-avar-form avar))
		 (not (member-wrt
		       avar=? avar (proof-to-context
				    (proof-in-imp-elim-form-to-op prev)))))
	    (proof-in-imp-elim-form-to-op prev)
	    (make-proof-in-imp-intro-form avar prev))))
     ((proof-in-imp-elim-form)
      (let ((op (proof-in-imp-elim-form-to-op proof))
	    (arg (proof-in-imp-elim-form-to-arg proof)))
	(make-proof-in-imp-elim-form
	 (proof-to-eta-nf-aux op extraction-flag content-flag)
	 (proof-to-eta-nf-aux
	  arg extraction-flag
	  (not (formula-of-nulltype? (proof-to-formula arg)))))))
     ((proof-in-impnc-intro-form) ;[u]Mu -> M, if u is not free in M
      (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	     (kernel (proof-in-impnc-intro-form-to-kernel proof))
	     (prev (proof-to-eta-nf-aux kernel extraction-flag content-flag)))
	(if (and (proof-in-impnc-elim-form? prev)
		 (proof=? (proof-in-impnc-elim-form-to-arg prev)
			  (make-proof-in-avar-form avar))
		 (not (member-wrt
		       avar=? avar (proof-to-context
				    (proof-in-impnc-elim-form-to-op prev)))))
	    (proof-in-impnc-elim-form-to-op prev)
	    (make-proof-in-impnc-intro-form avar prev))))
     ((proof-in-impnc-elim-form)
      (let ((op (proof-in-impnc-elim-form-to-op proof))
	    (arg (proof-in-impnc-elim-form-to-arg proof)))
	(make-proof-in-impnc-elim-form
	 (proof-to-eta-nf-aux op extraction-flag content-flag)
	 (proof-to-eta-nf-aux arg extraction-flag #f))))
     ((proof-in-and-intro-form) ;(and-intro p_1M p_2M) -> M
      (let* ((left (proof-in-and-intro-form-to-left proof))
	     (right (proof-in-and-intro-form-to-right proof))
	     (prev-left
	      (proof-to-eta-nf-aux
	       left extraction-flag
	       (not (formula-of-nulltype? (proof-to-formula left)))))
	     (prev-right
	      (proof-to-eta-nf-aux
	       right extraction-flag
	       (not (formula-of-nulltype? (proof-to-formula right))))))
	(if (and (proof-in-and-elim-left-form? prev-left)
		 (proof-in-and-elim-right-form? prev-right)
		 (proof=?
		  (proof-in-and-elim-left-form-to-kernel prev-left)
		  (proof-in-and-elim-right-form-to-kernel prev-right)))
	    (proof-in-and-elim-left-form-to-kernel prev-left)
	    (make-proof-in-and-intro-form prev-left prev-right))))
     ((proof-in-and-elim-left-form)
      (let* ((kernel (proof-in-and-elim-left-form-to-kernel proof))
	     (prev (proof-to-eta-nf-aux kernel extraction-flag content-flag)))
	(if (proof-in-and-intro-form? prev)
	    (proof-in-and-intro-form-to-left prev)
	    (make-proof-in-and-elim-left-form prev))))
     ((proof-in-and-elim-right-form)
      (let* ((kernel (proof-in-and-elim-right-form-to-kernel proof))
	     (prev (proof-to-eta-nf-aux kernel extraction-flag content-flag)))
	(if (proof-in-and-intro-form? prev)
	    (proof-in-and-intro-form-to-right prev)
	    (make-proof-in-and-elim-right-form prev))))
     ((proof-in-all-intro-form) ;[x]Mx -> M, if x is not free in M
      (let* ((var (proof-in-all-intro-form-to-var proof))
	     (kernel (proof-in-all-intro-form-to-kernel proof))
	     (prev (proof-to-eta-nf-aux kernel extraction-flag content-flag)))
	(if (and (proof-in-all-elim-form? prev)
		 (term=? (proof-in-all-elim-form-to-arg prev)
			 (make-term-in-var-form var))
		 (not (member var (proof-to-context
				   (proof-in-all-elim-form-to-op prev)))))
	    (proof-in-all-elim-form-to-op prev)
	    (make-proof-in-all-intro-form var prev))))
     ((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-proof-in-all-elim-form
	 (proof-to-eta-nf-aux op extraction-flag content-flag)
	 (term-to-eta-nf arg))))
     ((proof-in-allnc-intro-form) ;[x]Mx -> M, if x is not free in M
      (let* ((var (proof-in-allnc-intro-form-to-var proof))
	     (kernel (proof-in-allnc-intro-form-to-kernel proof))
	     (prev (proof-to-eta-nf-aux kernel extraction-flag content-flag)))
	(if (and (proof-in-allnc-elim-form? prev)
		 (term=? (proof-in-allnc-elim-form-to-arg prev)
			 (make-term-in-var-form var))
		 (not (member var (proof-to-context
				   (proof-in-allnc-elim-form-to-op prev)))))
	    (proof-in-allnc-elim-form-to-op prev)
	    (make-proof-in-allnc-intro-form var prev))))
     ((proof-in-allnc-elim-form)
      (let ((op (proof-in-allnc-elim-form-to-op proof))
	    (arg (proof-in-allnc-elim-form-to-arg proof)))
	(make-proof-in-allnc-elim-form
	 (proof-to-eta-nf-aux op extraction-flag content-flag)
	 (term-to-eta-nf arg))))
     (else proof))))

; For a full normalization of proofs, including permutative
; conversions, we define a preprocessing step that eta expands
; permutative aconsts such that the conclusion is atomic or
; existential.

(define (proof-to-proof-with-eta-expanded-permutative-aconsts proof)
  (proof-to-proof-with-eta-expanded-permutative-aconsts-aux proof #f #t))

(define (proof-to-proof-with-eta-expanded-permutative-aconsts-for-extraction
	 proof)
  (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
   proof #t (not (formula-of-nulltype? (proof-to-formula proof)))))

(define (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	 proof extraction-flag content-flag)
  (if
   (and extraction-flag (not content-flag))
   proof
   (case (tag proof)
     ((proof-in-aconst-form)
      (if (permutative-aconst? (proof-in-aconst-form-to-aconst proof))
	  (permutative-aconst-proof-to-eta-expansion proof)
	  proof))
     ((proof-in-imp-intro-form)
      (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	     (kernel (proof-in-imp-intro-form-to-kernel proof)))
	(make-proof-in-imp-intro-form
	 avar (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	       kernel extraction-flag content-flag))))
     ((proof-in-imp-elim-form)
      (let ((op (proof-in-imp-elim-form-to-op proof))
	    (arg (proof-in-imp-elim-form-to-arg proof)))
	(make-proof-in-imp-elim-form
	 (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	  op extraction-flag content-flag)
	 (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	  arg extraction-flag
	  (not (formula-of-nulltype? (proof-to-formula arg)))))))
     ((proof-in-impnc-intro-form)
      (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	     (kernel (proof-in-impnc-intro-form-to-kernel proof)))
	(make-proof-in-impnc-intro-form
	 avar (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	       kernel extraction-flag content-flag))))
     ((proof-in-impnc-elim-form)
      (let ((op (proof-in-impnc-elim-form-to-op proof))
	    (arg (proof-in-impnc-elim-form-to-arg proof)))
	(make-proof-in-impnc-elim-form
	 (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	  op extraction-flag content-flag)
	 (if (not extraction-flag)
	     (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	      arg #f #t) ;content flag irrelevant here
	     arg))))
     ((proof-in-and-intro-form)
      (let* ((left (proof-in-and-intro-form-to-left proof))
	     (right (proof-in-and-intro-form-to-right proof)))
	(make-proof-in-and-intro-form
	 (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	  left extraction-flag
	  (not (formula-of-nulltype? (proof-to-formula left))))
	 (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	  right extraction-flag
	  (not (formula-of-nulltype? (proof-to-formula right)))))))
     ((proof-in-and-elim-left-form)
      (let ((kernel (proof-in-and-elim-left-form-to-kernel proof)))
      (make-proof-in-and-elim-left-form
       (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	kernel extraction-flag content-flag))))
     ((proof-in-and-elim-right-form)
      (let ((kernel (proof-in-and-elim-right-form-to-kernel proof)))
      (make-proof-in-and-elim-right-form
       (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	kernel extraction-flag content-flag))))
     ((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-proof-in-all-intro-form
	 var (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	      kernel extraction-flag content-flag))))
     ((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-proof-in-all-elim-form
	 (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	  op extraction-flag content-flag) 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)))
	(make-proof-in-allnc-intro-form
	 var (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	      kernel extraction-flag content-flag))))
     ((proof-in-allnc-elim-form)
      (let ((op (proof-in-allnc-elim-form-to-op proof))
	    (arg (proof-in-allnc-elim-form-to-arg proof)))
	(make-proof-in-allnc-elim-form
	 (proof-to-proof-with-eta-expanded-permutative-aconsts-aux
	  op extraction-flag content-flag) arg)))
     (else proof))))

(define (permutative-aconst-proof-to-eta-expansion proof)
  (let* ((aconst (proof-in-aconst-form-to-aconst proof))
	 (uninst-formula (aconst-to-uninst-formula aconst))
	 (final-concl (imp-impnc-all-allnc-form-to-final-conclusion
		       uninst-formula))
	 (var-or-prem-list
	  (imp-impnc-all-allnc-form-to-vars-and-premises uninst-formula))
	 (pvar (predicate-form-to-predicate final-concl))
	 (tpinst (aconst-to-tpinst aconst))
	 (info (assoc pvar tpinst))
	 (tpinst-without-pvar
	  (if info	
	      (list-transform-positive tpinst
		(lambda (x) (not (equal? (car x) pvar))))
	      tpinst))
	 (orig-formula (if info (cterm-to-formula (cadr info)) final-concl))
	 (formula
	  (if (quant-form? orig-formula)
	      (let* ((quant (quant-form-to-quant orig-formula))
		     (vars (quant-form-to-vars orig-formula))
		     (kernel (quant-form-to-kernel orig-formula))
		     (bound-vars (formula-to-bound uninst-formula)))
		(if (pair? (intersection vars bound-vars))
		    (let* ((new-vars (map var-to-new-var vars)))
		      (make-quant
		       quant new-vars
		       (formula-substitute
			kernel
			(map (lambda (var new-var)
			       (list var (make-term-in-var-form new-var)))
			     vars new-vars))))
		    orig-formula))
	      orig-formula)))
    (case (tag formula)
      ((imp)
       (permutative-aconst-proof-to-eta-expansion-aux
	proof var-or-prem-list pvar tpinst-without-pvar formula
	make-proof-in-imp-intro-form
	(formula-to-new-avar (imp-form-to-premise formula))))
      ((impnc)
       (permutative-aconst-proof-to-eta-expansion-aux
	proof var-or-prem-list pvar tpinst-without-pvar formula
	make-proof-in-impnc-intro-form
	(formula-to-new-avar (impnc-form-to-premise formula))))
      ((and)
       (permutative-aconst-proof-to-eta-expansion-aux
	proof var-or-prem-list pvar tpinst-without-pvar formula
	make-proof-in-and-intro-form))
      ((all)
       (permutative-aconst-proof-to-eta-expansion-aux
	proof var-or-prem-list pvar tpinst-without-pvar formula
	make-proof-in-all-intro-form))
      ((allnc)
       (permutative-aconst-proof-to-eta-expansion-aux
	proof var-or-prem-list pvar tpinst-without-pvar formula
	make-proof-in-allnc-intro-form))
      (else proof))))

; permutative-aconst-proof-to-eta-expansion-aux is a generic helper
; function, which does eta-expansion in a perm-aconst with a composite
; formula (imp, impnc, and, all or allnc), where the introduction
; proof constructor is make-intro.  It returns the final proof.

(define (permutative-aconst-proof-to-eta-expansion-aux
	 proof var-or-prem-list pvar tpinst-without-pvar formula
	 make-intro . possible-avar)
  (let* ((aconst (proof-in-aconst-form-to-aconst proof))
	 (name (aconst-to-name aconst))
	 (kind (aconst-to-kind aconst))
	 (uninst-formula (aconst-to-uninst-formula aconst))
	 (inst-formula (proof-to-formula proof))
	 (free (formula-to-free inst-formula))
	 (var-or-inst-prem-list
	  (imp-impnc-all-allnc-form-to-vars-and-premises
	   inst-formula (length var-or-prem-list)))
	 (var-and-args-list ;((var1 arg11 arg12 ..) (var2 args21 arg22 ..) ..)
	  (do ((l1 var-or-prem-list (cdr l1))
	       (l2 var-or-inst-prem-list (cdr l2))
	       (res
		'()
		(let ((var-or-prem (car l1))
		      (var-or-inst-prem (car l2)))
		  (cond
		   ((var-form? var-or-prem)
		    (cons (list var-or-prem
				(make-term-in-var-form var-or-prem))
			  res))
		   ((not (member pvar (formula-to-pvars var-or-prem)))
		    (let ((avar (formula-to-new-avar var-or-inst-prem)))
		      (cons (list avar (make-proof-in-avar-form avar))
			    res)))
		   (else
		    (let*
			((l (length
			     (imp-impnc-all-allnc-form-to-vars-and-premises
			      var-or-prem)))
			 (new-avar (formula-to-new-avar var-or-inst-prem))
			 (inner-var-or-prem-list
			  (imp-impnc-all-allnc-form-to-vars-and-premises
			   var-or-inst-prem l))
			 (inner-vars-and-avars
			  (map (lambda (x)
				 (if (var-form? x) x
				     (formula-to-new-avar x)))
			       inner-var-or-prem-list))
			 (inner-elim-proof ;of inst pvar
			  (apply
			   mk-proof-in-elim-form
			   (append
			    (list (make-proof-in-avar-form new-avar))
			    (map (lambda (x)
				   (if (var-form? x)
				       (make-term-in-var-form x)
				       (make-proof-in-avar-form x)))
				 inner-vars-and-avars))))
			 (abst-applied-inner-elim-proofs
			  (case (tag formula)
			    ((imp)
			     (let* ((prem (imp-form-to-premise formula))
				    (prem-avar (car possible-avar))
				    (applied-inner-elim-proof
				     (make-proof-in-imp-elim-form
				      inner-elim-proof
				      (make-proof-in-avar-form prem-avar))))
			       (list
				(apply mk-proof-in-intro-form
				       (append
					inner-vars-and-avars
					(list applied-inner-elim-proof))))))
			    ((impnc)
			     (let* ((prem (impnc-form-to-premise formula))
				    (prem-avar (car possible-avar))
				    (applied-inner-elim-proof
				     (make-proof-in-impnc-elim-form
				      inner-elim-proof
				      (make-proof-in-avar-form prem-avar))))
			       (list
				(apply mk-proof-in-intro-form
				       (append
					inner-vars-and-avars
					(list applied-inner-elim-proof))))))
			    ((and)
			     (let* ((left (and-form-to-left formula))
				    (right (and-form-to-right formula))
				    (applied-inner-elim-proofs
				     (list (make-proof-in-and-elim-left-form
					    inner-elim-proof)
					   (make-proof-in-and-elim-right-form
					    inner-elim-proof))))
			       (map (lambda (p)
				      (apply mk-proof-in-intro-form
					     (append inner-vars-and-avars
						     (list p))))
				    applied-inner-elim-proofs)))
			    ((all)
			     (let* ((var (all-form-to-var formula))
				    (applied-inner-elim-proof
				     (make-proof-in-all-elim-form
				      inner-elim-proof
				      (make-term-in-var-form var))))
			       (list
				(apply mk-proof-in-intro-form
				       (append
					inner-vars-and-avars
					(list applied-inner-elim-proof))))))
			    ((allnc)
			     (let* ((var (allnc-form-to-var formula))
				    (applied-inner-elim-proof
				     (make-proof-in-allnc-elim-form
				      inner-elim-proof
				      (make-term-in-var-form var))))
			       (list
				(apply mk-proof-in-intro-form
				       (append
					inner-vars-and-avars
					(list applied-inner-elim-proof))))))
			    (else (myerror "not implemented")))))
		      (cons (cons new-avar abst-applied-inner-elim-proofs)
			    res)))))))
	      ((null? l1) (reverse res))))
	 (vars (map car var-and-args-list))
	 (args-list (map cdr var-and-args-list))
	 (args-left (map car args-list))
	 (args-right (map (lambda (args)
			    (if (= 1 (length args)) (car args) (cadr args)))
			  args-list))
	 (intro-items
	  (case (tag formula)
	    ((imp)
	     (let* ((prem (imp-form-to-premise formula))
		    (concl (imp-form-to-conclusion formula))
		    (prem-avar (car possible-avar))
		    (cterm (make-cterm concl))
		    (new-tpinst (if (pvar-cterm-equal? pvar cterm)
				    tpinst-without-pvar
				    (append tpinst-without-pvar
					    (list (list pvar cterm)))))
		    (new-aconst
		     (let ((aconst-without-repro-formulas
			    (make-aconst
			     name kind uninst-formula new-tpinst)))
		       (apply
			make-aconst
			(append (list name kind uninst-formula new-tpinst)
				(aconst-to-computed-repro-formulas
				 aconst-without-repro-formulas)))))
		    (new-inst-formula (aconst-to-inst-formula new-aconst))
		    (new-free (formula-to-free new-inst-formula)))
	       (list prem-avar
		     (apply mk-proof-in-elim-form
			    (append
			     (list (permutative-aconst-proof-to-eta-expansion
				    (make-proof-in-aconst-form new-aconst)))
			     (map make-term-in-var-form new-free)
			     args-left)))))
	    ((impnc)
	     (let* ((prem (impnc-form-to-premise formula))
		    (concl (impnc-form-to-conclusion formula))
		    (prem-avar (car possible-avar))
		    (cterm (make-cterm concl))
		    (new-tpinst (if (pvar-cterm-equal? pvar cterm)
				    tpinst-without-pvar
				    (append tpinst-without-pvar
					    (list (list pvar cterm)))))
		    (new-aconst
		     (let ((aconst-without-repro-formulas
			    (make-aconst
			     name kind uninst-formula new-tpinst)))
		       (apply
			make-aconst
			(append (list name kind uninst-formula new-tpinst)
				(aconst-to-computed-repro-formulas
				 aconst-without-repro-formulas)))))
		    (new-inst-formula (aconst-to-inst-formula new-aconst))
		    (new-free (formula-to-free new-inst-formula)))
	       (list prem-avar
		     (apply mk-proof-in-elim-form
			    (append
			     (list (permutative-aconst-proof-to-eta-expansion
				    (make-proof-in-aconst-form new-aconst)))
			     (map make-term-in-var-form new-free)
			     args-left)))))
	    ((and)
	     (let* ((left (and-form-to-left formula))
		    (right (and-form-to-right formula))
		    (cterm-left (make-cterm left))
		    (cterm-right (make-cterm right))
		    (new-tpinst-left
		     (if (pvar-cterm-equal? pvar cterm-left)
			 tpinst-without-pvar
			 (append tpinst-without-pvar
				 (list (list pvar cterm-left)))))
		    (new-tpinst-right
		     (if (pvar-cterm-equal? pvar cterm-right)
			 tpinst-without-pvar
			 (append tpinst-without-pvar
				 (list (list pvar cterm-right)))))
		    (new-aconst-left
		     (let ((aconst-without-repro-formulas
			    (make-aconst
			     name kind uninst-formula new-tpinst-left)))
		       (apply make-aconst
			      (append
			       (list name kind uninst-formula new-tpinst-left)
			       (aconst-to-computed-repro-formulas
				aconst-without-repro-formulas)))))
		    (new-aconst-right
		     (let ((aconst-without-repro-formulas
			    (make-aconst
			     name kind uninst-formula new-tpinst-right)))
		       (apply make-aconst
			      (append
			       (list name kind uninst-formula new-tpinst-right)
			       (aconst-to-computed-repro-formulas
				aconst-without-repro-formulas)))))
		    (new-inst-formula-left
		     (aconst-to-inst-formula new-aconst-left))
		    (new-free-left (formula-to-free new-inst-formula-left))
		    (new-inst-formula-right
		     (aconst-to-inst-formula new-aconst-right))
		    (new-free-right (formula-to-free new-inst-formula-right)))
	       (list (apply
		      mk-proof-in-elim-form
		      (append
		       (list (permutative-aconst-proof-to-eta-expansion
			      (make-proof-in-aconst-form new-aconst-left)))
		       (map make-term-in-var-form new-free-left)
		       args-left))
		     (apply
		      mk-proof-in-elim-form
		      (append
		       (list (permutative-aconst-proof-to-eta-expansion
			      (make-proof-in-aconst-form new-aconst-right)))
		       (map make-term-in-var-form new-free-right)
		       args-right)))))
	    ((all)
	     (let* ((var (all-form-to-var formula))
		    (kernel (all-form-to-kernel formula))
		    (cterm (make-cterm kernel))
		    (new-tpinst (if (pvar-cterm-equal? pvar cterm)
				    tpinst-without-pvar
				    (append tpinst-without-pvar
					    (list (list pvar cterm)))))
		    (new-aconst
		     (let ((aconst-without-repro-formulas
			    (make-aconst
			     name kind uninst-formula new-tpinst)))
		       (apply
			make-aconst
			(append (list name kind uninst-formula new-tpinst)
				(aconst-to-computed-repro-formulas
				 aconst-without-repro-formulas)))))
		    (new-inst-formula (aconst-to-inst-formula new-aconst))
		    (new-free (formula-to-free new-inst-formula)))
	       (list var
		     (apply mk-proof-in-elim-form
			    (append
			     (list (permutative-aconst-proof-to-eta-expansion
				    (make-proof-in-aconst-form new-aconst)))
			     (map make-term-in-var-form new-free)
			     args-left)))))
	    ((allnc)
	     (let* ((var (allnc-form-to-var formula))
		    (kernel (allnc-form-to-kernel formula))
		    (cterm (make-cterm kernel))
		    (new-tpinst (if (pvar-cterm-equal? pvar cterm)
				    tpinst-without-pvar
				    (append tpinst-without-pvar
					    (list (list pvar cterm)))))
		    (new-aconst
		     (let ((aconst-without-repro-formulas
			    (make-aconst
			     name kind uninst-formula new-tpinst)))
		       (apply
			make-aconst
			(append (list name kind uninst-formula new-tpinst)
				(aconst-to-computed-repro-formulas
				 aconst-without-repro-formulas)))))
		    (new-inst-formula (aconst-to-inst-formula new-aconst))
		    (new-free (formula-to-free new-inst-formula)))
	       (list var
		     (apply mk-proof-in-elim-form
			    (append
			     (list (permutative-aconst-proof-to-eta-expansion
				    (make-proof-in-aconst-form new-aconst)))
			     (map make-term-in-var-form new-free)
			     args-left))))))))
    (apply mk-proof-in-intro-form
	   (append free vars (list (apply make-intro intro-items))))))

; A permutative redex occurs if the conclusion of a permutative
; assumption constant (example: "Ex-Elim"), applied to parameters and
; all side premises, is the main premise of an elimination.  We assume
; that this conclusion is a prime or existential formula, since this
; will be the case when normalize-proof-pi is used in normalize-proof.
; Hence the final elimination must be an elimination axiom for an
; inductively defined predicate or else "Ex-Elim".

(define (permutative-aconst? aconst)
  (let ((name (aconst-to-name aconst)))
    (or
     (string=? "Ex-Elim" name)
     (string=? "Exnc-Elim" name)
     (string=? "If" name)
     (let* ((uninst-formula (aconst-to-uninst-formula aconst))
	    (final-concl (imp-impnc-all-allnc-form-to-final-conclusion
			  uninst-formula)))
       (and
	(predicate-form? final-concl)
	(pvar-form? (predicate-form-to-predicate final-concl))
	(let ((pvar (predicate-form-to-predicate final-concl)))
	  (and
	   (or
	    (null? (arity-to-types (predicate-to-arity pvar)))
	    (let* ((tpinst (aconst-to-tpinst aconst))
		   (info (assoc pvar tpinst)))
	      (and info
		   (let* ((cterm (cadr info))
			  (vars (cterm-to-vars cterm))
			  (formula (cterm-to-formula cterm)))
		     (null? (intersection vars (formula-to-free formula)))))))
	   (let* ((prems (imp-impnc-all-allnc-form-to-premises uninst-formula))
		  (prems-with-pvar
		   (list-transform-positive prems
		     (lambda (x) (member pvar (formula-to-pvars x))))))
	     (apply
	      and-op
	      (append
	       (list (pair? prems-with-pvar))
	       (map (lambda (prem)
		      (let ((prem-final-concl
			     (imp-impnc-all-allnc-form-to-final-conclusion
			      prem)))
			(and
			 (predicate-form? prem-final-concl)
			 (equal? pvar (predicate-form-to-predicate
				       prem-final-concl))
			 (let ((prem-prems
				(imp-impnc-all-allnc-form-to-premises prem)))
			   (apply and-op
				  (map (lambda (prem-prem)
					 (not (member pvar (formula-to-pvars
							    prem-prem))))
				       prem-prems))))))
		    prems)))))))))))

(define (permutative-redex? proof)
  (and (or (proof-in-ex-elim-rule-form? proof)
	   (proof-in-exnc-elim-rule-form? proof))
       (let* ((main-premise (car (proof-to-imp-elim-args proof)))
	      (op (proof-in-elim-form-to-final-op main-premise)))
	 (and (proof-in-aconst-form? op)
	      (permutative-aconst? (proof-in-aconst-form-to-aconst op))))))

; Now we define permutative conversions

; We assume that proof is in long normal form, and every variable
; bound in proof by all-intro or imp-intro is not free elsewhere (to
; avoid renaming after permutation).  This is the case for proofs
; obtained by nbe-normalize-proof-without-eta.

; For permutative conversion we use an auxiliary function
; (normalize-proof-pi-aux proof extraction-flag content-flag).  The
; extraction-flag indicates whether we are interested in extraction
; only.  If so, we can disregard (maximal) parts of the proof without
; computational content.  The content-flag indicates whether the
; formula of the proof has computational content.  This is for
; efficiency only, since it avoids recomputation.  When
; extraction-flag is #f content-flag is irrelevant.

(define (normalize-proof-pi proof)
  (normalize-proof-pi-aux proof #f #t))

(define (normalize-proof-pi-for-extraction proof)
  (normalize-proof-pi-aux
   proof #t (not (formula-of-nulltype? (proof-to-formula proof)))))

(define (normalize-proof-pi-aux proof extraction-flag content-flag)
  (if
   (and extraction-flag (not content-flag))
   proof
   (if
    (permutative-redex? proof)
    (let* ((imp-elim-args (proof-to-imp-elim-args proof))
	   (main-premise (car imp-elim-args))
	   (side-premise (cadr imp-elim-args))
	   (op2 (proof-in-elim-form-to-final-op proof)) ;Ex-Elim or Exnc-Elim
	   (op1 (proof-in-elim-form-to-final-op main-premise))
	   (aconst1
	    (begin 
	      (display (aconst-to-name
			(proof-in-aconst-form-to-aconst op1)))
	      (display "/")
	      (display (aconst-to-name
			(proof-in-aconst-form-to-aconst op2)))
	      (display " ")
	      (proof-in-aconst-form-to-aconst op1))) ;permutative aconst
	   (inst-formula1 (aconst-to-inst-formula aconst1))
	   (free1 (formula-to-free inst-formula1))
	   (args1 (proof-in-elim-form-to-args main-premise))
	   (params1 (list-head args1 (length free1)))
	   (rest-args1 (list-tail args1 (length free1)))
	   (end-formula (proof-to-formula proof))
	   (uninst-formula1 (aconst-to-uninst-formula aconst1))
	   (var-or-prem-list
	    (imp-impnc-all-allnc-form-to-vars-and-premises uninst-formula1))
	   (pvar (predicate-form-to-predicate
		  (imp-impnc-all-allnc-form-to-final-conclusion
		   uninst-formula1)))
	   (tpinst (aconst-to-tpinst aconst1))
	   (info (assoc pvar tpinst))
	   (tpinst-without-pvar
	    (if info	
		(list-transform-positive tpinst
		  (lambda (x) (not (equal? (car x) pvar))))
		tpinst))
	   (subst-tpinst-without-pvar
	    (if (equal? (map make-term-in-var-form free1) params1)
		tpinst-without-pvar
		(let ((subst1 (map (lambda (x y) (list x y)) free1 params1)))
		  (map (lambda (x)
			 (if (pvar? (car x))
			     (list (car x) (cterm-substitute (cadr x) subst1))
			     x))
		       tpinst-without-pvar))))
	   (cterm (make-cterm end-formula))
	   (new-tpinst
	    (if (pvar-cterm-equal? pvar cterm)
		subst-tpinst-without-pvar
		(append subst-tpinst-without-pvar (list (list pvar cterm)))))
	   (new-aconst1
	    (let* ((name (aconst-to-name aconst1))
		   (kind (aconst-to-kind aconst1))
		   (aconst-without-repro-formulas
		    (make-aconst name kind uninst-formula1 new-tpinst)))
	      (apply make-aconst
		     (append (list name kind uninst-formula1 new-tpinst)
			     (aconst-to-computed-repro-formulas
			      aconst-without-repro-formulas)))))
	   (new-free1 (formula-to-free (aconst-to-inst-formula new-aconst1)))
	   (rest-args1-pi
	    (do ((l1 var-or-prem-list (cdr l1))
		 (l2 rest-args1 (cdr l2))
		 (res
		  '()
		  (let ((uninst-arg (car l1))
			(arg1 (car l2)))
		    (if
		     (or (term-form? arg1)
			 (not (member pvar (formula-to-pvars uninst-arg))))
		     (cons arg1 res)
		     (let* ((l (length
				(imp-impnc-all-allnc-form-to-vars-and-premises
				 uninst-arg)))
			    (side-proof-kernel1
			     (proof-in-intro-form-to-final-kernel arg1 l))
			    (new-aconst2
			     (ex-formula-and-concl-to-ex-elim-aconst
			      (proof-to-formula side-proof-kernel1)
			      end-formula))
			    (new-free2 (formula-to-free
					(aconst-to-inst-formula new-aconst2)))
			    (new-side-proof-kernel1
			     (apply
			      mk-proof-in-elim-form
			      (append
			       (list (make-proof-in-aconst-form new-aconst2))
			       (map make-term-in-var-form new-free2)
			       (list side-proof-kernel1 side-premise))))
			    (abst-new-side-proof-kernel1
			     (intro-proof-and-new-kernel-and-depth-to-proof
			      arg1 new-side-proof-kernel1 l)))
		       (cons abst-new-side-proof-kernel1 res))))))
		((null? l1) (reverse res)))))
      (normalize-proof-pi-aux
       (apply mk-proof-in-elim-form
	      (append (list (make-proof-in-aconst-form new-aconst1))
		      (map make-term-in-var-form new-free1)
		      rest-args1-pi))
       extraction-flag content-flag))
					;proof is not a permutative redex:
    (case (tag proof)
      ((proof-in-avar-form proof-in-aconst-form) proof)
      ((proof-in-imp-intro-form)
       (let ((avar (proof-in-imp-intro-form-to-avar proof))
	     (kernel (proof-in-imp-intro-form-to-kernel proof)))
	 (make-proof-in-imp-intro-form
	  avar (normalize-proof-pi-aux kernel extraction-flag content-flag))))
      ((proof-in-imp-elim-form)
       (let ((op (proof-in-imp-elim-form-to-op proof))
	     (arg (proof-in-imp-elim-form-to-arg proof)))
	 (make-proof-in-imp-elim-form
	  (normalize-proof-pi-aux op extraction-flag content-flag)
	  (normalize-proof-pi-aux
	   arg extraction-flag
	   (not (formula-of-nulltype? (proof-to-formula arg)))))))
      ((proof-in-impnc-intro-form)
       (let ((avar (proof-in-impnc-intro-form-to-avar proof))
	     (kernel (proof-in-impnc-intro-form-to-kernel proof)))
	 (make-proof-in-impnc-intro-form
	  avar (normalize-proof-pi-aux kernel extraction-flag content-flag))))
      ((proof-in-impnc-elim-form)
       (let ((op (proof-in-impnc-elim-form-to-op proof))
	     (arg (proof-in-impnc-elim-form-to-arg proof)))
	 (make-proof-in-impnc-elim-form
	  (normalize-proof-pi-aux op extraction-flag content-flag)
	  (if (not extraction-flag)
	      (normalize-proof-pi-aux arg #f #t) ;content flag irrelevant here
	      arg))))
      ((proof-in-and-intro-form)
       (let ((left (proof-in-and-intro-form-to-left proof))
	     (right (proof-in-and-intro-form-to-right proof)))
	 (make-proof-in-and-intro-form
	  (normalize-proof-pi-aux
	   left extraction-flag
	   (not (formula-of-nulltype? (proof-to-formula left))))
	  (normalize-proof-pi-aux
	   right extraction-flag
	   (not (formula-of-nulltype? (proof-to-formula right)))))))
      ((proof-in-and-elim-left-form)
       (let ((kernel (proof-in-and-elim-left-form-to-kernel proof)))
	 (make-proof-in-and-elim-left-form
	  (normalize-proof-pi-aux kernel extraction-flag #t))))
      ((proof-in-and-elim-right-form)
       (let ((kernel (proof-in-and-elim-right-form-to-kernel proof)))
	 (make-proof-in-and-elim-right-form
	  (normalize-proof-pi-aux kernel extraction-flag #t))))
      ((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-proof-in-all-intro-form
	  var (normalize-proof-pi-aux kernel extraction-flag content-flag))))
      ((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-proof-in-all-elim-form
	  (normalize-proof-pi-aux op extraction-flag content-flag) 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)))
	 (make-proof-in-allnc-intro-form
	  var (normalize-proof-pi-aux kernel extraction-flag content-flag))))
      ((proof-in-allnc-elim-form)
       (let ((op (proof-in-allnc-elim-form-to-op proof))
	     (arg (proof-in-allnc-elim-form-to-arg proof)))
	 (make-proof-in-allnc-elim-form
	  (normalize-proof-pi-aux op extraction-flag content-flag) arg)))
      (else (myerror "normalize-proof-pi-aux" "proof tag expected"
		     (tag proof)))))))

; Test function to check normalize-proof-pi

(define (proof-in-permutative-normal-form? proof)
  (null? (proof-to-permutative-redexes proof)))

(define (proof-to-permutative-redexes proof)
  (if
   (permutative-redex? proof)
   (let* ((imp-elim-args (proof-to-imp-elim-args proof))
	  (main-premise (car imp-elim-args))
	  (side-premise (cadr imp-elim-args))
	  (op2 (proof-in-elim-form-to-final-op proof)) ;Ex-Elim or Exnc-Elim
	  (op1 (proof-in-elim-form-to-final-op main-premise))
	  (aconst1 (proof-in-aconst-form-to-aconst op1))
	  (aconst2 (proof-in-aconst-form-to-aconst op2)))
     (append (list (string-append (aconst-to-name aconst1) "/"
				  (aconst-to-name aconst2)))
	     (proof-to-permutative-redexes main-premise)
	     (proof-to-permutative-redexes side-premise)))
   (case (tag proof)
     ((proof-in-avar-form proof-in-aconst-form) '())
     ((proof-in-imp-intro-form)
      (let ((kernel (proof-in-imp-intro-form-to-kernel proof)))
	(proof-to-permutative-redexes kernel)))
     ((proof-in-imp-elim-form)
      (let ((op (proof-in-imp-elim-form-to-op proof))
	    (arg (proof-in-imp-elim-form-to-arg proof)))
	(append (proof-to-permutative-redexes op)
		(proof-to-permutative-redexes arg))))
     ((proof-in-impnc-intro-form)
      (let ((kernel (proof-in-impnc-intro-form-to-kernel proof)))
	(proof-to-permutative-redexes kernel)))
     ((proof-in-impnc-elim-form)
      (let ((op (proof-in-impnc-elim-form-to-op proof))
	    (arg (proof-in-impnc-elim-form-to-arg proof)))
	(append (proof-to-permutative-redexes op)
		(proof-to-permutative-redexes arg))))
     ((proof-in-and-intro-form)
      (let ((left (proof-in-and-intro-form-to-left proof))
	    (right (proof-in-and-intro-form-to-right proof)))
	(append (proof-to-permutative-redexes left)
		(proof-to-permutative-redexes right))))
     ((proof-in-and-elim-left-form)
      (proof-to-permutative-redexes
       (proof-in-and-elim-left-form-to-kernel proof)))
     ((proof-in-and-elim-right-form)
      (proof-to-permutative-redexes
       (proof-in-and-elim-right-form-to-kernel proof)))
     ((proof-in-all-intro-form)
      (let ((kernel (proof-in-all-intro-form-to-kernel proof)))
	(proof-to-permutative-redexes kernel)))
     ((proof-in-all-elim-form)
      (let ((op (proof-in-all-elim-form-to-op proof)))
	(proof-to-permutative-redexes op)))
     ((proof-in-allnc-intro-form)
      (let ((kernel (proof-in-allnc-intro-form-to-kernel proof)))
	(proof-to-permutative-redexes kernel)))
     ((proof-in-allnc-elim-form)
      (let ((op (proof-in-allnc-elim-form-to-op proof)))
	(proof-to-permutative-redexes op)))
     (else (myerror "proof-to-permutative-redexes" "proof tag expected"
		    (tag proof))))))

(define (proof-in-beta-normal-form? proof)
  (proof-in-beta-normal-form-aux? proof #f #t))

(define (proof-in-beta-normal-form-for-extraction? proof)
  (proof-in-beta-normal-form-aux?
   proof #t (not (formula-of-nulltype? (proof-to-formula proof)))))

(define (proof-in-beta-normal-form-aux? proof extraction-flag content-flag)
  (if
   (and extraction-flag (not content-flag))
   #t
   (case (tag proof)
     ((proof-in-avar-form proof-in-aconst-form) #t)
     ((proof-in-imp-intro-form)
      (let ((kernel (proof-in-imp-intro-form-to-kernel proof)))
	(proof-in-beta-normal-form-aux? kernel extraction-flag content-flag)))
     ((proof-in-imp-elim-form)
      (let ((op (proof-in-imp-elim-form-to-op proof))
	    (arg (proof-in-imp-elim-form-to-arg proof)))
	(cond
	 ((proof-in-imp-intro-form? op) #f)
	 ((and
	   (proof-in-imp-elim-form? op)
	   (let ((op1 (proof-in-imp-elim-form-to-op op)))
	     (and
	      (proof-in-aconst-form? op1)
	      (string=? "Ex-Elim" (aconst-to-name
				   (proof-in-aconst-form-to-aconst op1)))
	      (let ((arg1 (proof-in-imp-elim-form-to-arg op)))
		(and (proof-in-imp-elim-form? arg1)
		     (let ((op2 (proof-in-imp-elim-form-to-op arg1)))
		       (and (proof-in-all-elim-form? op2)
			    (let ((op3 (proof-in-all-elim-form-to-op op2)))
			      (and (proof-in-aconst-form? op3)
				   (string=? "Ex-Intro"
					     (aconst-to-name
					      (proof-in-aconst-form-to-aconst
					       op3))))))))))))
	  #f)
	 ((and
	   (proof-in-imp-elim-form? op)
	   (let ((op1 (proof-in-imp-elim-form-to-op op)))
	     (and
	      (proof-in-aconst-form? op1)
	      (string=? "Exnc-Elim" (aconst-to-name
				     (proof-in-aconst-form-to-aconst op1)))
	      (let ((arg1 (proof-in-imp-elim-form-to-arg op)))
		(and (proof-in-imp-elim-form? arg1)
		     (let ((op2 (proof-in-imp-elim-form-to-op arg1)))
		       (and (proof-in-allnc-elim-form? op2)
			    (let ((op3 (proof-in-allnc-elim-form-to-op op2)))
			      (and (proof-in-aconst-form? op3)
				   (string=? "Exnc-Intro"
					     (aconst-to-name
					      (proof-in-aconst-form-to-aconst
					       op3))))))))))))
	  #f)
	 (else (and (proof-in-beta-normal-form-aux?
		     op extraction-flag content-flag)
		    (proof-in-beta-normal-form-aux?
		     arg extraction-flag
		     (not (formula-of-nulltype? (proof-to-formula arg)))))))))
     ((proof-in-impnc-intro-form)
      (let ((kernel (proof-in-impnc-intro-form-to-kernel proof)))
	(proof-in-beta-normal-form-aux? kernel extraction-flag content-flag)))
     ((proof-in-impnc-elim-form)
      (let ((op (proof-in-impnc-elim-form-to-op proof))
	    (arg (proof-in-impnc-elim-form-to-arg proof)))
	(if
	 (proof-in-impnc-intro-form? op)
	 #f
	 (proof-in-beta-normal-form-aux? op extraction-flag content-flag))))
     ((proof-in-and-intro-form)
      (let ((left (proof-in-and-intro-form-to-left proof))
	    (right (proof-in-and-intro-form-to-right proof)))
	(and (proof-in-beta-normal-form-aux?
	      left extraction-flag
	      (not (formula-of-nulltype? (proof-to-formula left))))
	     (proof-in-beta-normal-form-aux?
	      right extraction-flag
	      (not (formula-of-nulltype? (proof-to-formula right)))))))
     ((proof-in-and-elim-left-form)
      (let ((kernel (proof-in-and-elim-left-form-to-kernel proof)))
	(and (not (proof-in-and-intro-form? kernel))
	     (proof-in-beta-normal-form-aux?
	      kernel extraction-flag content-flag))))
     ((proof-in-and-elim-right-form)
      (let ((kernel (proof-in-and-elim-right-form-to-kernel proof)))
	(and (not (proof-in-and-intro-form? kernel))
	     (proof-in-beta-normal-form-aux?
	      kernel extraction-flag content-flag))))
     ((proof-in-all-intro-form)
      (let ((kernel (proof-in-all-intro-form-to-kernel proof)))
	(proof-in-beta-normal-form-aux? kernel extraction-flag content-flag)))
     ((proof-in-all-elim-form)
      (let ((op (proof-in-all-elim-form-to-op proof)))
	(and
	 (not (proof-in-all-intro-form? op))
	 (proof-in-beta-normal-form-aux? op extraction-flag content-flag))))
     ((proof-in-allnc-intro-form)
      (let ((kernel (proof-in-allnc-intro-form-to-kernel proof)))
	(proof-in-beta-normal-form-aux? kernel extraction-flag content-flag)))
     ((proof-in-allnc-elim-form)
      (let ((op (proof-in-allnc-elim-form-to-op proof)))
	(and
	 (not (proof-in-allnc-intro-form? op))
	 (proof-in-beta-normal-form-aux? op extraction-flag content-flag))))
     (else (myerror "proof-in-beta-normal-form-aux?" "proof tag expected"
		    (tag proof))))))

; Normalization of proofs is made more efficient by allowing to know
; whether one is interested in extraction, and if so, disregard parts
; of the proof without computational content.  The extraction-flag
; indicates whether we are interested in extraction only.  If so, we
; can disregard (maximal) parts of the proof without computational
; content.  The content-flag indicates whether the formula of the
; proof has computational content.  This is for efficiency only, since
; it avoids recomputation.  When extraction-flag is #f content-flag is
; irrelevant.

(define (nbe-normalize-proof proof)
  (nbe-normalize-proof-aux proof #f #t))

(define (nbe-normalize-proof-for-extraction proof)
  (nbe-normalize-proof-aux
   proof #t (not (formula-of-nulltype? (proof-to-formula proof)))))

(define (nbe-normalize-proof-aux proof extraction-flag content-flag)
  (let ((init (normalize-proof-pi-aux
	       (nbe-normalize-proof-without-eta-aux
		(proof-to-proof-with-eta-expanded-permutative-aconsts-aux
		 proof extraction-flag content-flag)
		extraction-flag content-flag)
	       extraction-flag content-flag)))
    (do ((p init (normalize-proof-pi-aux
		  (nbe-normalize-proof-without-eta-aux
		   p extraction-flag content-flag)
		  extraction-flag content-flag)))
	((proof-in-beta-normal-form-aux? p extraction-flag content-flag)
	 (proof-to-eta-nf-aux p extraction-flag content-flag)))))

(define np nbe-normalize-proof)
(define npe nbe-normalize-proof-for-extraction)

; Now proof transformations (Prawitz' simplification, removal of
; predecided avars, removal of predecided if theorems, generalized
; pruning).

; Simplification conversions (Prawitz) make use of the concept of a
; permutative aconst.  It is checked whether one side-proof-kernel has
; no free occurrence of any avar bound in this side-proof.

(define (normalize-proof-simp proof)
  (case (tag proof)
    ((proof-in-avar-form proof-in-aconst-form) proof)
    ((proof-in-imp-intro-form)
     (let ((avar (proof-in-imp-intro-form-to-avar proof))
	   (kernel (proof-in-imp-intro-form-to-kernel proof)))
       (make-proof-in-imp-intro-form avar (normalize-proof-simp kernel))))
    ((proof-in-impnc-intro-form)
     (let ((avar (proof-in-impnc-intro-form-to-avar proof))
	   (kernel (proof-in-impnc-intro-form-to-kernel proof)))
       (make-proof-in-impnc-intro-form avar (normalize-proof-simp kernel))))
    ((proof-in-and-intro-form)
     (let ((left (proof-in-and-intro-form-to-left proof))
	   (right (proof-in-and-intro-form-to-right proof)))
       (make-proof-in-and-intro-form (normalize-proof-simp left)
				     (normalize-proof-simp right))))
    ((proof-in-and-elim-left-form)
     (make-proof-in-and-elim-left-form
      (normalize-proof-simp (proof-in-and-elim-left-form-to-kernel proof))))
    ((proof-in-and-elim-right-form)
     (make-proof-in-and-elim-right-form
      (normalize-proof-simp (proof-in-and-elim-right-form-to-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)))
       (make-proof-in-all-intro-form var (normalize-proof-simp kernel))))
    ((proof-in-allnc-intro-form)
     (let ((var (proof-in-allnc-intro-form-to-var proof))
	   (kernel (proof-in-allnc-intro-form-to-kernel proof)))
       (make-proof-in-allnc-intro-form var (normalize-proof-simp kernel))))
    ((proof-in-imp-elim-form
      proof-in-impnc-elim-form
      proof-in-all-elim-form
      proof-in-allnc-elim-form)
     (let* ((op (proof-in-elim-form-to-final-op proof))
	    (args (proof-in-elim-form-to-args proof))
	    (simp-args (map (lambda (arg)
			      (if (proof-form? arg)
				  (normalize-proof-simp arg)
				  arg))
			    args)))
       (if
	(not (proof-in-aconst-form? op))
	(apply mk-proof-in-elim-form (cons op simp-args))
	(let ((aconst (proof-in-aconst-form-to-aconst op)))
	  (if
	   (not (permutative-aconst? aconst))
	   (apply mk-proof-in-elim-form (cons op simp-args))
	   (let* ((uninst-formula (aconst-to-uninst-formula aconst))
		  (var-or-prem-list
		   (imp-impnc-all-allnc-form-to-vars-and-premises
		    uninst-formula))
		  (inst-formula (aconst-to-inst-formula aconst))
		  (free (formula-to-free inst-formula)))
	     (if
	      (< (length args) (length free))
	      (apply mk-proof-in-elim-form (cons op simp-args))
	      (let ((params (list-head args (length free)))
		    (rest-args (list-tail simp-args (length free))))
		(if
		 (< (length rest-args) (length var-or-prem-list))
		 (apply mk-proof-in-elim-form (cons op simp-args))
		 (let*
		     ((further-rest-args
		       (list-tail rest-args (length var-or-prem-list)))
		      (final-concl
		       (imp-impnc-all-allnc-form-to-final-conclusion
			uninst-formula))
		      (pvar (predicate-form-to-predicate final-concl))
		      (prems
		       (imp-impnc-all-allnc-form-to-premises uninst-formula))
		      (prems-with-pvar
		       (list-transform-positive prems
			 (lambda (x) (member pvar (formula-to-pvars x)))))
		      (args-for-simplification
		       (do ((l1 var-or-prem-list (cdr l1))
			    (l2 rest-args (cdr l2))
			    (res
			     '()
			     (let ((var-or-prem (car l1))
				   (arg (car l2)))
			       (if
				(or
				 (var-form? var-or-prem)
				 (not (member
				       pvar (formula-to-pvars var-or-prem))))
				res
				(let*
				    ((prem-var-or-prem-list
				      (imp-impnc-all-allnc-form-to-vars-and-premises
				       var-or-prem))
				     (l (length prem-var-or-prem-list))
				     (side-proof-kernel
				      (proof-in-intro-form-to-final-kernel
				       arg l))
				     (side-proof-vars
				      (proof-in-intro-form-to-vars arg l)))
				  (if (pair?
				       (intersection-wrt
					avar=?
					(proof-to-free-avars side-proof-kernel)
					side-proof-vars))
				      res
				      (cons side-proof-kernel res)))))))
			   ((null? l1) (reverse res)))))
		   (cond
		    ((null? args-for-simplification)
		     (apply mk-proof-in-elim-form (cons op simp-args)))
		    ((null? further-rest-args)
		     (car args-for-simplification))
		    (else (normalize-proof-simp
			   (apply mk-proof-in-elim-form
				  (cons (car args-for-simplification)
					further-rest-args)))))))))))))))
    (else (myerror "normalize-proof-simp" "proof tag expected"
		   (tag proof)))))

; proof-to-proof-without-predecided-avars removes dependencies on
; avars, and in this way helps to make normalize-proof-simp useful.

(define (proof-to-proof-without-predecided-avars proof)
  (proof-and-context-to-proof-without-predecided-avars proof '()))

(define (proof-and-context-to-proof-without-predecided-avars proof context)
  (case (tag proof)
    ((proof-in-avar-form proof-in-aconst-form) proof)     
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (kernel (proof-in-imp-intro-form-to-kernel proof))
	    (avars (context-to-avars context))
	    (previous-avar (do ((l avars (cdr l))
				(res #f (if (classical-formula=?
					     (avar-to-formula (car l))
					     (avar-to-formula avar))
					    (car l)
					    #f)))
			       ((or res (null? l)) res))))
       (make-proof-in-imp-intro-form
	avar (proof-and-context-to-proof-without-predecided-avars
	      (if previous-avar
		  (proof-subst kernel avar (make-proof-in-avar-form
					    previous-avar))
		  kernel)
	      (append context (list avar))))))
    ((proof-in-imp-elim-form)
     (let ((op (proof-in-imp-elim-form-to-op proof))
	   (arg (proof-in-imp-elim-form-to-arg proof)))
       (make-proof-in-imp-elim-form
	(proof-and-context-to-proof-without-predecided-avars op context)
	(proof-and-context-to-proof-without-predecided-avars arg context))))
    ((proof-in-impnc-intro-form)
     (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (avars (context-to-avars context))
	    (previous-avar (do ((l avars (cdr l))
				(res #f (if (classical-formula=?
					     (avar-to-formula (car l))
					     (avar-to-formula avar))
					    (car l)
					    #f)))
			       ((or res (null? l)) res))))
       (make-proof-in-impnc-intro-form
	avar (proof-and-context-to-proof-without-predecided-avars
	      (if previous-avar
		  (proof-subst kernel avar (make-proof-in-avar-form
					    previous-avar))
		  kernel)
	      (append context (list avar))))))
    ((proof-in-impnc-elim-form)
     (let ((op (proof-in-impnc-elim-form-to-op proof))
	   (arg (proof-in-impnc-elim-form-to-arg proof)))
       (make-proof-in-impnc-elim-form
	(proof-and-context-to-proof-without-predecided-avars op context)
	(proof-and-context-to-proof-without-predecided-avars arg context))))
    ((proof-in-and-intro-form)
     (let ((left (proof-in-and-intro-form-to-left proof))
	   (right (proof-in-and-intro-form-to-right proof)))
       (make-proof-in-and-intro-form
	(proof-and-context-to-proof-without-predecided-avars left context)
	(proof-and-context-to-proof-without-predecided-avars right context))))
    ((proof-in-and-elim-left-form)
     (let ((kernel (proof-in-and-elim-left-form-to-kernel proof)))
       (make-proof-in-and-elim-left-form
	(proof-and-context-to-proof-without-predecided-avars kernel context))))
    ((proof-in-and-elim-right-form)
     (let ((kernel (proof-in-and-elim-right-form-to-kernel proof)))
       (make-proof-in-and-elim-right-form
	(proof-and-context-to-proof-without-predecided-avars kernel context))))
    ((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-proof-in-all-intro-form
	var (proof-and-context-to-proof-without-predecided-avars
	     kernel (append context (list 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-proof-in-all-elim-form
	(proof-and-context-to-proof-without-predecided-avars op context)
	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)))
       (make-proof-in-allnc-intro-form
	var (proof-and-context-to-proof-without-predecided-avars
	     kernel (append context (list var))))))
    ((proof-in-allnc-elim-form)
     (let ((op (proof-in-allnc-elim-form-to-op proof))
	   (arg (proof-in-allnc-elim-form-to-arg proof)))
       (make-proof-in-allnc-elim-form
	(proof-and-context-to-proof-without-predecided-avars op context)
	arg)))
    (else
     (myerror "proof-and-context-to-proof-without-predecided-avars"
	      "unexpected proof tag" (tag proof)))))

; Removal of predecided If's (special for pruning), including those
; with True or False as boolean arguments.  negatom-context consists
; of all atomic or negated avars in the present context.

(define (remove-predecided-if-theorems proof)
  (remove-predecided-if-theorems-aux proof '()))

(define (remove-predecided-if-theorems-aux proof negatom-context)
  (case (tag proof)
    ((proof-in-avar-form proof-in-aconst-form) proof)
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (kernel (proof-in-imp-intro-form-to-kernel proof))
	    (formula (avar-to-formula avar))
	    (new-negatom-context ;add avar if a (possibly negated) atom
	     (if (or (atom-form? formula)
		     (and (imp-form? formula)
			  (atom-form? (imp-form-to-premise formula))
			  (formula=? (imp-form-to-conclusion formula)
				     falsity)))
		 (cons avar negatom-context)
		 negatom-context))
	    (prev (remove-predecided-if-theorems-aux
		   kernel new-negatom-context)))
       (make-proof-in-imp-intro-form avar prev)))
    ((proof-in-imp-elim-form)
     (let* ((final-op (proof-in-elim-form-to-final-op proof))
	    (args (proof-in-elim-form-to-args proof)))
       (if ;If-theorem with exactly 3 non-parameter args
	(and
	 (proof-in-aconst-form? final-op)
	 (let* ((aconst (proof-in-aconst-form-to-aconst final-op))
		(name (aconst-to-name aconst)))
	   (and
	    (string=? "If" name)
	    (let* ((term-args (do ((l args (cdr l))
				   (res '() (if (term-form? (car l))
						(cons (car l) res)
						(cons #f res))))
				  ((not (term-form? (car l))) (reverse res))))
		   (rest-args (list-tail args (length term-args))))
	      (and (= 2 (length rest-args))
		   (proof-in-imp-intro-form? (car rest-args))
		   (proof-in-imp-intro-form? (cadr rest-args)))))))
	(let* ((term-args (do ((l args (cdr l))
			       (res '() (if (term-form? (car l))
					    (cons (car l) res)
					    (cons #f res))))
			      ((not (term-form? (car l))) (reverse res))))
	       (boolean-arg (car (last-pair term-args)))
	       (rest-args (list-tail args (length term-args))))
	  (cond
	   ((term=? (make-term-in-const-form true-const) boolean-arg)
	    (let* ((arg1 (car rest-args))
		   (avar1 (proof-in-imp-intro-form-to-avar arg1))
		   (kernel1 (proof-in-imp-intro-form-to-kernel arg1))
		   (subst-kernel (proof-subst
				  kernel1 avar1
				  (make-proof-in-aconst-form truth-aconst))))
	      (remove-predecided-if-theorems-aux subst-kernel negatom-context)))
	   ((term=? (make-term-in-const-form false-const) boolean-arg)
	    (let* ((arg2 (cadr rest-args))
		   (avar2 (proof-in-imp-intro-form-to-avar arg2))
		   (kernel2 (proof-in-imp-intro-form-to-kernel arg2))
		   (false-avar (formula-to-new-avar falsity))
		   (subst-kernel (proof-subst
				  kernel2 avar2
				  (make-proof-in-imp-intro-form
				   false-avar
				   (make-proof-in-avar-form false-avar)))))
	      (remove-predecided-if-theorems-aux
	       subst-kernel negatom-context)))
	   (else
	    (let ((proof (negatom-context-and-bterm-to-proof
			  negatom-context boolean-arg)))
	      (if ;proof is found
	       proof
	       (if ;proof of (atom boolean-arg)
		(atom-form? (proof-to-formula proof))
		(let* ((arg1 (car rest-args))
		       (avar1 (proof-in-imp-intro-form-to-avar arg1))
		       (kernel1 (proof-in-imp-intro-form-to-kernel arg1))
		       (subst-kernel1 (proof-subst kernel1 avar1 proof)))
		  (remove-predecided-if-theorems-aux
		   subst-kernel1 negatom-context))
					;or proof of (atom boolean-arg) -> F
		(let* ((arg2 (cadr rest-args))
		       (avar2 (proof-in-imp-intro-form-to-avar arg2))
		       (kernel2 (proof-in-imp-intro-form-to-kernel arg2))
		       (subst-kernel2 (proof-subst kernel2 avar2 proof)))
		  (remove-predecided-if-theorems-aux
		   subst-kernel2 negatom-context)))
	       (apply
		mk-proof-in-elim-form
		(append (list final-op)
			term-args
			(list (remove-predecided-if-theorems-aux
			       (car rest-args) negatom-context)
			      (remove-predecided-if-theorems-aux
			       (cadr rest-args) negatom-context)))))))))
	(let* ((op (proof-in-imp-elim-form-to-op proof))
	       (arg (proof-in-imp-elim-form-to-arg proof))
	       (prev1 (remove-predecided-if-theorems-aux
		       op negatom-context))
	       (prev2 (remove-predecided-if-theorems-aux
		       arg negatom-context)))
	  (make-proof-in-imp-elim-form prev1 prev2)))))
    ((proof-in-and-intro-form)
     (let* ((left (proof-in-and-intro-form-to-left proof))
	    (right (proof-in-and-intro-form-to-right proof))
	    (prev1 (remove-predecided-if-theorems-aux left negatom-context))
	    (prev2 (remove-predecided-if-theorems-aux right negatom-context)))
       (make-proof-in-and-intro-form prev1 prev2)))
    ((proof-in-and-elim-left-form)
     (let* ((kernel (proof-in-and-elim-left-form-to-kernel proof))
	    (prev (remove-predecided-if-theorems-aux kernel negatom-context)))
       (make-proof-in-and-elim-left-form prev)))
    ((proof-in-and-elim-right-form)
     (let* ((kernel (proof-in-and-elim-right-form-to-kernel proof))
	    (prev (remove-predecided-if-theorems-aux kernel negatom-context)))
       (make-proof-in-and-elim-right-form prev)))
    ((proof-in-all-intro-form)
     (let* ((var (proof-in-all-intro-form-to-var proof))
	    (kernel (proof-in-all-intro-form-to-kernel proof))
	    (prev (remove-predecided-if-theorems-aux kernel negatom-context)))
       (make-proof-in-all-intro-form var prev)))
    ((proof-in-all-elim-form)
     (let* ((op (proof-in-all-elim-form-to-op proof))
	    (arg (proof-in-all-elim-form-to-arg proof))
	    (prev (remove-predecided-if-theorems-aux op negatom-context)))
       (make-proof-in-all-elim-form prev 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))
	    (prev (remove-predecided-if-theorems-aux kernel negatom-context)))
       (make-proof-in-allnc-intro-form var prev)))
    ((proof-in-allnc-elim-form)
     (let* ((op (proof-in-allnc-elim-form-to-op proof))
	    (arg (proof-in-allnc-elim-form-to-arg proof))
	    (prev (remove-predecided-if-theorems-aux op negatom-context)))
       (make-proof-in-allnc-elim-form prev arg)))
    (else (myerror "remove-predecided-if-theorems-aux"
		   "not implemented for" (tag proof)))))

; term-to-minuend-and-subtrahends writes the term in the form
; j--i0--i1..--in and returns j and the list (i0 i1 .. in) (the
; minuend and the subtrahends).

(define (term-to-minuend-and-subtrahends term)
  (let ((op (term-in-app-form-to-final-op term)))
    (if
     (and
      (term-in-const-form? op)
      (string=? (const-to-name (term-in-const-form-to-const op)) "NatMinus"))
     (let* ((args (term-in-app-form-to-args term))
	    (lhs (car args))
	    (rhs (cadr args))
	    (prev (term-to-minuend-and-subtrahends lhs))
	    (minuend (car prev))
	    (subtrahends (cadr prev)))
       (list minuend (append subtrahends (list rhs))))
     (list term '()))))

; (pp (car (term-to-minuend-and-subtrahends (pt "j--i1--i2"))))
; (for-each pp (cadr (term-to-minuend-and-subtrahends (pt "j--i1--i2"))))

; Consider avar:i<=j--i0--i1--i2 and subtrahends (i1 i2).  Then j--i0
; is the minuend.  We construct a proof of i<=j--i0 from avar.

(define (le-minuend-minus-subtrahends-avar-and-subtrahends-to-proof
	 avar subtrahends)
  (if
   (null? subtrahends)
   (make-proof-in-avar-form avar)
   (let* ((init-subtrahend (car subtrahends)) ;not used!
	  (rest-subtrahends (cdr subtrahends))
	  (prev (le-minuend-minus-subtrahends-avar-and-subtrahends-to-proof
		 avar rest-subtrahends))
	  (formula (proof-to-formula prev))
	  (kernel (atom-form-to-kernel formula))
	  (args (term-in-app-form-to-args kernel))
	  (lhs (car args))		   
	  (minuend (cadr args))
	  (new-minuend (car (term-in-app-form-to-args minuend))))
     (mk-proof-in-elim-form
      (make-proof-in-aconst-form (theorem-name-to-aconst "NatLeTrans"))
      lhs minuend new-minuend
      prev
      (make-proof-in-aconst-form truth-aconst)))))

; (cdp (le-minuend-minus-subtrahends-avar-and-subtrahends-to-proof
;       (formula-to-new-avar (pf "i<=j--i0--i1--i2"))
;       (list (pt "i0") (pt "i1")  (pt "i2"))))

; negatom-context-and-bterm-to-proof returns either a proof of bterm
; from the positive context or else a proof of the negation of bterm
; from the negative context if it finds one of them, and #f otherwise.
; Because of its usage of term-to-minuend-and-subtrahends and
; le-minuend-minus-subtrahends-avar-and-subtrahends-to-proof it is
; designed for use in the binpack case study, where the boolean terms
; are of the form i<=j--i0--...--in.  It would be better if a more
; general decision procedure is used (simplex-algorithm?).

(define (negatom-context-and-bterm-to-proof negatom-context bterm)
  (let ((op (term-in-app-form-to-final-op bterm)))
    (and
     (term-in-const-form? op)
     (string=? (const-to-name (term-in-const-form-to-const op)) "NatLe")
     (let* ((args (term-in-app-form-to-args bterm))
	    (lhs (car args))
	    (rhs (cadr args))
	    (minuend-and-subtrahends (term-to-minuend-and-subtrahends rhs))
	    (minuend (car minuend-and-subtrahends))
	    (subtrahends (cadr minuend-and-subtrahends))
	    (pos-fitting-context
	     (list-transform-positive negatom-context
	       (lambda (avar)
		 (let ((avar-fla (avar-to-formula avar)))
		   (and
		    (atom-form? avar-fla)
		    (let* ((avar-kernel (atom-form-to-kernel avar-fla))
			   (avar-op
			    (term-in-app-form-to-final-op avar-kernel)))
		      (and
		       (term-in-const-form? avar-op)
		       (string=?
			(const-to-name (term-in-const-form-to-const avar-op))
			"NatLe")
		       (let* ((avar-args
			       (term-in-app-form-to-args avar-kernel))
			      (avar-lhs (car avar-args))
			      (avar-rhs (cadr avar-args))
			      (avar-minuend-and-subtrahends
			       (term-to-minuend-and-subtrahends avar-rhs))
			      (avar-minuend (car avar-minuend-and-subtrahends))
			      (avar-subtrahends
			       (cadr avar-minuend-and-subtrahends)))
			 (and
			  (term=? lhs avar-lhs)
			  (term=? minuend avar-minuend)
			  (<= (length subtrahends) (length avar-subtrahends))
			  (apply and-op
				 (map term=?
				      subtrahends
				      (list-head
				       avar-subtrahends
				       (length subtrahends)))))))))))))
	    (neg-fitting-context
	     (list-transform-positive negatom-context
	       (lambda (avar)
		 (let ((avar-fla (avar-to-formula avar)))
		   (and
		    (imp-impnc-form? avar-fla)
		    (formula=? (imp-impnc-form-to-conclusion avar-fla)
			       falsity)
		    (atom-form? (imp-impnc-form-to-premise avar-fla))
		    (let* ((avar-atom (imp-impnc-form-to-premise avar-fla))
			   (avar-kernel (atom-form-to-kernel avar-atom))
			   (avar-op
			    (term-in-app-form-to-final-op avar-kernel)))
		      (and
		       (term-in-const-form? avar-op)
		       (string=?
			(const-to-name (term-in-const-form-to-const avar-op))
			"NatLe")
		       (let* ((avar-args
			       (term-in-app-form-to-args avar-kernel))
			      (avar-lhs (car avar-args))
			      (avar-rhs (cadr avar-args))
			      (avar-minuend-and-subtrahends
			       (term-to-minuend-and-subtrahends avar-rhs))
			      (avar-minuend (car avar-minuend-and-subtrahends))
			      (avar-subtrahends
			       (cadr avar-minuend-and-subtrahends)))
			 (and
			  (term=? lhs avar-lhs)
			  (term=? minuend avar-minuend)
			  (<= (length avar-subtrahends) (length subtrahends))
			  (apply and-op
				 (map term=?
				      avar-subtrahends
				      (list-head
				       subtrahends
				       (length avar-subtrahends))))))))))))))
       (and
	(or (pair? pos-fitting-context) (pair? neg-fitting-context))
	(if (pair? pos-fitting-context)
	    (let* ((avar (car pos-fitting-context))
		   (avar-fla (avar-to-formula avar))
		   (avar-kernel (atom-form-to-kernel avar-fla))
		   (avar-args (term-in-app-form-to-args avar-kernel))
		   (avar-rhs (cadr avar-args))
		   (avar-minuend-and-subtrahends
		    (term-to-minuend-and-subtrahends avar-rhs))
		   (avar-subtrahends (cadr avar-minuend-and-subtrahends))
		   (rest-avar-subtrahends
		    (list-tail avar-subtrahends (length subtrahends))))
	      (le-minuend-minus-subtrahends-avar-and-subtrahends-to-proof
	       avar rest-avar-subtrahends))
					;else (pair? neg-fitting-context)
	    (let* ((avar (car neg-fitting-context))
		   (avar-fla (avar-to-formula avar))
		   (avar-atom (imp-impnc-form-to-premise avar-fla))
		   (avar-kernel (atom-form-to-kernel avar-atom))
		   (avar-args (term-in-app-form-to-args avar-kernel))
		   (avar-rhs (cadr avar-args))
		   (avar-minuend-and-subtrahends
		    (term-to-minuend-and-subtrahends avar-rhs))
		   (avar-subtrahends (cadr avar-minuend-and-subtrahends))
		   (rest-subtrahends
		    (list-tail subtrahends (length avar-subtrahends)))
		   (bterm-atom (make-atomic-formula bterm))
		   (bterm-avar (formula-to-new-avar bterm-atom))
		   (proof-of-avar-prem
		    (le-minuend-minus-subtrahends-avar-and-subtrahends-to-proof
		     bterm-avar rest-subtrahends))
		   (proof-of-falsity
		    (mk-proof-in-elim-form
		     (make-proof-in-avar-form avar) proof-of-avar-prem)))
	      (make-proof-in-imp-intro-form
	       bterm-avar proof-of-falsity))))))))

; Generalization of Prawitz' simplification: pruning.  A problem with
; prune is that is is slow.  For efficiency the proof is first turned
; into an acproof, to avoid recomputation of avar-contexts when
; pruning.

(define (prune proof)
  (acproof-to-pruned-proof (proof-to-acproof proof)))

(define (acproof-to-pruned-proof acproof)
  (let ((formula (proof-to-formula acproof)))
    (case (tag acproof)
      ((proof-in-avar-form proof-in-aconst-form) acproof)
      ((proof-in-imp-intro-form)
       (let* ((avar (proof-in-imp-intro-form-to-avar acproof))
	      (kernel (proof-in-imp-intro-form-to-kernel acproof))
	      (proof-of-formula-or-f (prune-aux formula (list avar) kernel)))
	 (if proof-of-formula-or-f
	     (acproof-to-pruned-proof proof-of-formula-or-f)
	     (make-proof-in-imp-intro-form
	      avar (acproof-to-pruned-proof kernel)))))
      ((proof-in-imp-elim-form)
       (let* ((op (proof-in-imp-elim-form-to-op acproof))
	      (arg (proof-in-imp-elim-form-to-arg acproof))
	      (proof-of-formula-or-f1 (prune-aux formula '() op)))
	 (if
	  proof-of-formula-or-f1
	  (acproof-to-pruned-proof proof-of-formula-or-f1)
	  (let ((proof-of-formula-or-f2 (prune-aux formula '() arg)))
	    (if
	     proof-of-formula-or-f2
	     (acproof-to-pruned-proof proof-of-formula-or-f2)
	     (make-proof-in-imp-elim-form
	      (acproof-to-pruned-proof op) (acproof-to-pruned-proof arg)))))))
      ((proof-in-impnc-intro-form)
       (let* ((avar (proof-in-impnc-intro-form-to-avar acproof))
	      (kernel (proof-in-impnc-intro-form-to-kernel acproof))
	      (proof-of-formula-or-f (prune-aux formula (list avar) kernel)))
	 (if proof-of-formula-or-f
	     (acproof-to-pruned-proof proof-of-formula-or-f)
	     (make-proof-in-impnc-intro-form
	      avar (acproof-to-pruned-proof kernel)))))
      ((proof-in-impnc-elim-form)
       (let* ((op (proof-in-impnc-elim-form-to-op acproof))
	      (arg (proof-in-impnc-elim-form-to-arg acproof))
	      (proof-of-formula-or-f1 (prune-aux formula '() op)))
	 (if
	  proof-of-formula-or-f1
	  (acproof-to-pruned-proof proof-of-formula-or-f1)
	  (let ((proof-of-formula-or-f2 (prune-aux formula '() arg)))
	    (if
	     proof-of-formula-or-f2
	     (acproof-to-pruned-proof proof-of-formula-or-f2)
	     (make-proof-in-impnc-elim-form
	      (acproof-to-pruned-proof op) (acproof-to-pruned-proof arg)))))))
      ((proof-in-and-intro-form)
       (let* ((left (proof-in-and-intro-form-to-left acproof))
	      (right (proof-in-and-intro-form-to-right acproof))
	      (proof-of-formula-or-f1 (prune-aux formula '() left)))
	 (if
	  proof-of-formula-or-f1
	  (acproof-to-pruned-proof proof-of-formula-or-f1)
	  (let ((proof-of-formula-or-f2 (prune-aux formula '() right)))
	    (if
	     proof-of-formula-or-f2
	     (acproof-to-pruned-proof proof-of-formula-or-f2)
	     (make-proof-in-and-intro-form
	      (acproof-to-pruned-proof left)
	      (acproof-to-pruned-proof right)))))))
      ((proof-in-and-elim-left-form)
       (let* ((kernel (proof-in-and-elim-left-form-to-kernel acproof))
	      (proof-of-formula-or-f (prune-aux formula '() kernel)))
	 (if proof-of-formula-or-f
	     (acproof-to-pruned-proof proof-of-formula-or-f)
	     (make-proof-in-and-elim-left-form
	      (acproof-to-pruned-proof kernel)))))
      ((proof-in-and-elim-right-form)
       (let* ((kernel (proof-in-and-elim-right-form-to-kernel acproof))
	      (proof-of-formula-or-f (prune-aux formula '() kernel)))
	 (if proof-of-formula-or-f
	     (acproof-to-pruned-proof proof-of-formula-or-f)
	     (make-proof-in-and-elim-right-form
	      (acproof-to-pruned-proof kernel)))))
      ((proof-in-all-intro-form)
       (let* ((var (proof-in-all-intro-form-to-var acproof))
	      (kernel (proof-in-all-intro-form-to-kernel acproof))
	      (proof-of-formula-or-f (prune-aux formula '() kernel)))
	 (if proof-of-formula-or-f
	     (acproof-to-pruned-proof proof-of-formula-or-f)
	     (make-proof-in-all-intro-form
	      var (acproof-to-pruned-proof kernel)))))
      ((proof-in-all-elim-form)
       (let* ((op (proof-in-all-elim-form-to-op acproof))
	      (arg (proof-in-all-elim-form-to-arg acproof))
	      (proof-of-formula-or-f (prune-aux formula '() op)))
	 (if proof-of-formula-or-f
	     (acproof-to-pruned-proof proof-of-formula-or-f)
	     (make-proof-in-all-elim-form
	      (acproof-to-pruned-proof op) arg))))
      ((proof-in-allnc-intro-form)
       (let* ((var (proof-in-allnc-intro-form-to-var acproof))
	      (kernel (proof-in-allnc-intro-form-to-kernel acproof))
	      (proof-of-formula-or-f (prune-aux formula '() kernel)))
	 (if proof-of-formula-or-f
	     (acproof-to-pruned-proof proof-of-formula-or-f)
	     (make-proof-in-allnc-intro-form
	      var (acproof-to-pruned-proof kernel)))))
      ((proof-in-allnc-elim-form)
       (let* ((op (proof-in-allnc-elim-form-to-op acproof))
	      (arg (proof-in-allnc-elim-form-to-arg acproof))
	      (proof-of-formula-or-f (prune-aux formula '() op)))
	 (if proof-of-formula-or-f
	     (acproof-to-pruned-proof proof-of-formula-or-f)
	     (make-proof-in-allnc-elim-form
	      (acproof-to-pruned-proof op) arg))))
      (else (myerror "acproof-to-pruned-proof"
		     "proof tag expected"
		     (tag proof))))))

; prune-aux returns #f or the shorter acproof of formula

(define (prune-aux formula bound-avars acproof)
  (if
   (and
    (classical-formula=? formula (proof-to-formula acproof))
    (null? (intersection-wrt avar=? bound-avars (proof-to-context acproof))))
   acproof
   (case (tag acproof)
     ((proof-in-avar-form proof-in-aconst-form) #f)
     ((proof-in-imp-intro-form)
      (let ((avar (proof-in-imp-intro-form-to-avar acproof))
	    (kernel (proof-in-imp-intro-form-to-kernel acproof)))
	(prune-aux formula (adjoin-wrt avar=? avar bound-avars) kernel)))
     ((proof-in-imp-elim-form)
      (let ((op (proof-in-imp-elim-form-to-op acproof))
	    (arg (proof-in-imp-elim-form-to-arg acproof)))
	(or (prune-aux formula bound-avars op)
	    (prune-aux formula bound-avars arg))))
     ((proof-in-impnc-intro-form)
      (let ((avar (proof-in-impnc-intro-form-to-avar acproof))
	    (kernel (proof-in-impnc-intro-form-to-kernel acproof)))
	(prune-aux formula (adjoin-wrt avar=? avar bound-avars) kernel)))
     ((proof-in-impnc-elim-form)
      (let ((op (proof-in-impnc-elim-form-to-op acproof))
	    (arg (proof-in-impnc-elim-form-to-arg acproof)))
	(or (prune-aux formula bound-avars op)
	    (prune-aux formula bound-avars arg))))
     ((proof-in-and-intro-form)
      (let ((left (proof-in-and-intro-form-to-left acproof))
	    (right (proof-in-and-intro-form-to-right acproof)))
	(or (prune-aux formula bound-avars left)
	    (prune-aux formula bound-avars right))))
     ((proof-in-and-elim-left-form)
      (let ((kernel (proof-in-and-elim-left-form-to-kernel acproof)))
	(prune-aux formula bound-avars kernel)))
     ((proof-in-and-elim-right-form)
      (let ((kernel (proof-in-and-elim-right-form-to-kernel acproof)))
	(prune-aux formula bound-avars kernel)))
     ((proof-in-all-intro-form)
      (let ((kernel (proof-in-all-intro-form-to-kernel acproof)))
	(prune-aux formula bound-avars kernel)))
     ((proof-in-all-elim-form)
      (let ((op (proof-in-all-elim-form-to-op acproof)))
	(prune-aux formula bound-avars op)))
     ((proof-in-allnc-intro-form)
      (let ((kernel (proof-in-allnc-intro-form-to-kernel acproof)))
	(prune-aux formula bound-avars kernel)))
     ((proof-in-allnc-elim-form)
      (let ((op (proof-in-allnc-elim-form-to-op acproof)))
	(prune-aux formula bound-avars op)))
     (else (myerror "prune-aux" "proof tag expected" (tag acproof))))))

; For tests it might generally be useful to have a level-wise
; decomposition of proofs into subproofs: one level transforms a proof
; lambda us.v Ms into the list [v M1 ... Mn]

(define (proof-in-intro-form-to-final-kernels proof)
  (cond
   ((proof-in-imp-intro-form? proof)
    (proof-in-intro-form-to-final-kernels
     (proof-in-imp-intro-form-to-kernel proof)))
   ((proof-in-impnc-intro-form? proof)
    (proof-in-intro-form-to-final-kernels
     (proof-in-impnc-intro-form-to-kernel proof)))
   ((proof-in-and-intro-form? proof)
    (append (proof-in-intro-form-to-final-kernels
	     (proof-in-and-intro-form-to-left proof))
	    (proof-in-intro-form-to-final-kernels
	     (proof-in-and-intro-form-to-right proof))))
   ((proof-in-all-intro-form? proof)
    (proof-in-intro-form-to-final-kernels
     (proof-in-all-intro-form-to-kernel proof)))
   ((proof-in-allnc-intro-form? proof)
    (proof-in-intro-form-to-final-kernels
     (proof-in-allnc-intro-form-to-kernel proof)))
   (else (list proof))))

(define (proof-in-elim-form-to-final-op-and-args proof)
  (case (tag proof)
    ((proof-in-imp-elim-form)
     (append (proof-in-elim-form-to-final-op-and-args
	      (proof-in-imp-elim-form-to-op proof))
	     (proof-in-imp-elim-form-to-arg proof)))
    ((proof-in-impnc-elim-form)
     (append (proof-in-elim-form-to-final-op-and-args
	      (proof-in-impnc-elim-form-to-op proof))
	     (proof-in-impnc-elim-form-to-arg proof)))
    ((proof-in-and-elim-left-form)
     (append (proof-in-elim-form-to-final-op-and-args
	      (proof-in-and-elim-left-form-to-kernel proof))
	     (list 'left)))
    ((proof-in-and-elim-right-form)
     (append (proof-in-elim-form-to-final-op-and-args
	      (proof-in-and-elim-right-form-to-kernel proof))
	     (list 'right)))
    ((proof-in-all-elim-form)
     (append (proof-in-elim-form-to-final-op-and-args
	      (proof-in-all-elim-form-to-op proof))
	     (proof-in-all-elim-form-to-arg proof)))
    ((proof-in-allnc-elim-form)
     (append (proof-in-elim-form-to-final-op-and-args
	      (proof-in-allnc-elim-form-to-op proof))
	     (proof-in-allnc-elim-form-to-arg proof)))
    (else (list proof))))

(define (proof-to-parts-of-level-one proof)
  (let* ((final-kernels (proof-in-intro-form-to-final-kernels proof))
	 (lists (map proof-in-elim-form-to-final-op-and-args final-kernels)))
    (apply append lists)))	 

(define (proof-to-parts proof . opt-level)
  (if
   (null? opt-level)
   (proof-to-parts-of-level-one proof)
   (let ((l (car opt-level)))
     (if (and (integer? l) (not (negative? l)))
	 (if (zero? l)
	     (list proof)
	     (let* ((parts (proof-to-parts-of-level-one proof))
		    (proofs (list-transform-positive parts
			      proof-form?)))
	       (apply append (map (lambda (x) (proof-to-parts x (- l 1)))
				  proofs))))
   	 (myerror "proof-to-parts" "non-negative integer expected" l)))))

(define (proof-to-proof-parts proof)
  (list-transform-positive (proof-to-parts proof)
    proof-form?))

(define (proof-to-depth proof)
  (if
   (or (proof-in-avar-form? proof)
       (proof-in-aconst-form? proof))
   0
   (let* ((final-kernels (proof-in-intro-form-to-final-kernels proof))
	  (lists (map proof-in-elim-form-to-final-op-and-args final-kernels))
	  (proofs (list-transform-positive (apply append lists) proof-form?)))
     (+ 1 (apply max (map proof-to-depth proofs))))))

; For testing, beta-normalization by hand.

(define (proof-to-one-step-beta-reduct proof)
  (case (tag proof)
    ((proof-in-avar-form proof-in-aconst-form) proof)
    ((proof-in-imp-intro-form)
     (make-proof-in-imp-intro-form
      (proof-in-imp-intro-form-to-avar proof)
      (proof-to-one-step-beta-reduct
       (proof-in-imp-intro-form-to-kernel 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)))
       (if (proof-in-imp-intro-form? op)
	   (proof-subst (proof-in-imp-intro-form-to-kernel op)
			(proof-in-imp-intro-form-to-avar op)
			arg)
	   (make-proof-in-imp-elim-form
	    (proof-to-one-step-beta-reduct op)
	    (proof-to-one-step-beta-reduct arg)))))
    ((proof-in-impnc-intro-form)
     (make-proof-in-impnc-intro-form
      (proof-in-impnc-intro-form-to-avar proof)
      (proof-to-one-step-beta-reduct
       (proof-in-impnc-intro-form-to-kernel 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)))
       (if (proof-in-impnc-intro-form? op)
	   (proof-subst (proof-in-impnc-intro-form-to-kernel op)
			(proof-in-impnc-intro-form-to-avar op)
			arg)
	   (make-proof-in-impnc-elim-form
	    (proof-to-one-step-beta-reduct op)
	    (proof-to-one-step-beta-reduct arg)))))
    ((proof-in-and-intro-form)
     (make-proof-in-and-intro-form
      (proof-to-one-step-beta-reduct (proof-in-and-intro-form-to-left proof))
      (proof-to-one-step-beta-reduct
       (proof-in-and-intro-form-to-right proof))))
    ((proof-in-and-elim-left-form)
     (let ((kernel (proof-in-and-elim-left-form-to-kernel proof)))
       (if (proof-in-and-intro-form? kernel)
	   (proof-in-and-intro-form-to-left kernel)
	   (make-proof-in-and-elim-left-form
	    (proof-to-one-step-beta-reduct kernel)))))
    ((proof-in-and-elim-right-form)
     (let ((kernel (proof-in-and-elim-right-form-to-kernel proof)))
       (if (proof-in-and-intro-form? kernel)
	   (proof-in-and-intro-form-to-right kernel)
	   (make-proof-in-and-elim-right-form
	    (proof-to-one-step-beta-reduct kernel)))))
    ((proof-in-all-intro-form)
     (make-proof-in-all-intro-form
      (proof-in-all-intro-form-to-var proof)
      (proof-to-one-step-beta-reduct
       (proof-in-all-intro-form-to-kernel proof))))
    ((proof-in-all-elim-form)
     (let* ((op (proof-in-all-elim-form-to-op proof))
	    (arg (proof-in-all-elim-form-to-arg proof)))
       (if (proof-in-all-intro-form? op)
	   (proof-subst (proof-in-all-intro-form-to-kernel op)
			(proof-in-all-intro-form-to-var op)
			arg)
	   (make-proof-in-all-elim-form
	    (proof-to-one-step-beta-reduct op)
	    arg))))
    ((proof-in-allnc-intro-form)
     (make-proof-in-allnc-intro-form
      (proof-in-allnc-intro-form-to-var proof)
      (proof-to-one-step-beta-reduct
       (proof-in-allnc-intro-form-to-kernel proof))))
    ((proof-in-allnc-elim-form)
     (let* ((op (proof-in-allnc-elim-form-to-op proof))
	    (arg (proof-in-allnc-elim-form-to-arg proof)))
       (if (proof-in-allnc-intro-form? op)
	   (proof-subst (proof-in-allnc-intro-form-to-kernel op)
			(proof-in-allnc-intro-form-to-var op)
			arg)
	   (make-proof-in-allnc-elim-form
	    (proof-to-one-step-beta-reduct op)
	    arg))))
    (else (myerror "proof-to-one-step-beta-reduct" "proof tag expected"
		   (tag proof)))))

(define (proof-to-beta-nf proof)
  (if (proof-in-beta-normal-form? proof)
      proof
      (proof-to-beta-nf (proof-to-one-step-beta-reduct proof))))

(define (proof-to-beta-pi-eta-nf proof)
  (proof-to-eta-nf (normalize-proof-pi (proof-to-beta-nf proof))))

(define bpe-np proof-to-beta-pi-eta-nf)

; Useful functions for proofs

(define (proof-to-length proof)
  (case (tag proof)
    ((proof-in-avar-form proof-in-aconst-form) 1)
    ((proof-in-imp-intro-form)
     (+ 1 (proof-to-length (proof-in-imp-intro-form-to-kernel 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)))
       (+ 1 (proof-to-length op) (proof-to-length arg))))
    ((proof-in-impnc-intro-form)
     (+ 1 (proof-to-length (proof-in-impnc-intro-form-to-kernel 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)))
       (+ 1 (proof-to-length op) (proof-to-length arg))))
    ((proof-in-and-intro-form)
     (+ 1
	(proof-to-length (proof-in-and-intro-form-to-left proof))
	(proof-to-length (proof-in-and-intro-form-to-right proof))))
    ((proof-in-and-elim-left-form)
     (let ((kernel (proof-in-and-elim-left-form-to-kernel proof)))
       (+ 1 (proof-to-length kernel))))
    ((proof-in-and-elim-right-form)
     (let ((kernel (proof-in-and-elim-right-form-to-kernel proof)))
       (+ 1 (proof-to-length kernel))))
    ((proof-in-all-intro-form)
     (+ 1 (proof-to-length (proof-in-all-intro-form-to-kernel proof))))
    ((proof-in-all-elim-form)
     (let* ((op (proof-in-all-elim-form-to-op proof))
	    (arg (proof-in-all-elim-form-to-arg proof)))
       (+ 1 (proof-to-length op) 1)))
    ((proof-in-allnc-intro-form)
     (+ 1 (proof-to-length (proof-in-allnc-intro-form-to-kernel proof))))
    ((proof-in-allnc-elim-form)
     (let* ((op (proof-in-allnc-elim-form-to-op proof))
	    (arg (proof-in-allnc-elim-form-to-arg proof)))
       (+ 1 (proof-to-length op) 1)))
    (else (myerror "proof-to-length" "proof tag expected"
		   (tag proof)))))


; 10-3. Substitution
; ==================

; We define simultaneous substitution for type, object, predicate and
; assumption variables in a proof, via tsubst, subst, psubst and
; asubst.  It is assumed that subst only affects those vars whose type
; is not changed by tsubst, psubst only affects those pvars whose
; arity is not changed by tsubst, and that asubst only affects those
; avars whose formula is not changed by tsubst, subst and psubst.

; In the abstraction cases of the recursive definition, the abstracted
; variable (or assumption variable) may need to be renamed.  However,
; its type (or formula) can be affected by tsubst (or tsubst, subst
; and psubst).  Then the renaming cannot be made part of subst (or
; asubst), because the condition above would be violated.  Therefore
; we carry along procedures rename renaming variables and arename for
; assumption variables, which remember the renaming done so far.

; In make-arename classical-formula=? replaced by formula=?
; Reason: classical-formula=? finds that the normal forms are equal.
; But in arename we want syntactic equality, i.e., formula=?

; make-arename returns a procedure renaming assumption variables,
; which remembers the renaming of assumption variables done so far.

(define (make-arename tsubst psubst rename prename)
  (let ((assoc-list '()))
    (lambda (avar subst)
      (let ((info (assoc-wrt avar=? avar assoc-list)))
	(if info
	    (cadr info)
	    (let* ((formula (avar-to-formula avar))
		   (new-formula (formula-substitute-aux
				 formula tsubst subst psubst rename prename)))
	      (if (formula=? formula new-formula)
		  avar
		  (let ((new-avar (formula-to-new-avar new-formula)))
		    (set! assoc-list (cons (list avar new-avar) assoc-list))
		    new-avar))))))))

; rename-bound-avars replaces all bound avars by new ones with the
; same name but a new index.  Properties: (i) rename-bound-avars
; transforms a proof satisfying the avar convention w.r.t. its free
; avars into a proof satisfying the avar convention completely.  (ii)
; In every subproof of the result no free avar occurs (w.r.t. avar=?)
; bound as well.  Property (ii) is assumed in proof-substitute-aux.

(define (rename-bound-avars proof)
  (rename-bound-avars-aux proof '()))

(define (rename-bound-avars-aux proof alist)
  (case (tag proof)
    ((proof-in-avar-form)
     (let* ((avar (proof-in-avar-form-to-avar proof))
	    (info (assoc-wrt avar-full=? avar alist)))
       (if info (cadr info) proof)))
    ((proof-in-aconst-form) proof)
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (kernel (proof-in-imp-intro-form-to-kernel proof))
	    (formula (avar-to-formula avar))
	    (name (avar-to-name avar))
	    (new-avar (formula-to-new-avar formula name))
	    (new-alist (cons (list avar (make-proof-in-avar-form new-avar))
			     alist)))
       (make-proof-in-imp-intro-form
	new-avar (rename-bound-avars-aux kernel new-alist))))
    ((proof-in-imp-elim-form)
     (let ((op (proof-in-imp-elim-form-to-op proof))
	   (arg (proof-in-imp-elim-form-to-arg proof)))
       (make-proof-in-imp-elim-form
	(rename-bound-avars-aux op alist)
	(rename-bound-avars-aux arg alist))))
    ((proof-in-impnc-intro-form)
     (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (formula (avar-to-formula avar))
	    (name (avar-to-name avar))
	    (new-avar (formula-to-new-avar formula name))
	    (new-alist (cons (list avar (make-proof-in-avar-form new-avar))
			     alist)))
       (make-proof-in-impnc-intro-form
	new-avar (rename-bound-avars-aux kernel new-alist))))
    ((proof-in-impnc-elim-form)
     (let ((op (proof-in-impnc-elim-form-to-op proof))
	   (arg (proof-in-impnc-elim-form-to-arg proof)))
       (make-proof-in-impnc-elim-form
	(rename-bound-avars-aux op alist)
	(rename-bound-avars-aux arg alist))))
    ((proof-in-and-intro-form)
     (make-proof-in-and-intro-form
      (rename-bound-avars-aux (proof-in-and-intro-form-to-left proof) alist)
      (rename-bound-avars-aux (proof-in-and-intro-form-to-right proof) alist)))
    ((proof-in-and-elim-left-form)
     (make-proof-in-and-elim-left-form
      (rename-bound-avars-aux 
       (proof-in-and-elim-left-form-to-kernel proof) alist)))
    ((proof-in-and-elim-right-form)
     (make-proof-in-and-elim-right-form
      (rename-bound-avars-aux 
       (proof-in-and-elim-right-form-to-kernel proof) alist)))
    ((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-proof-in-all-intro-form
	var (rename-bound-avars-aux kernel alist))))
    ((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-proof-in-all-elim-form
	(rename-bound-avars-aux op alist) 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)))
       (make-proof-in-allnc-intro-form
	var (rename-bound-avars-aux kernel alist))))
    ((proof-in-allnc-elim-form)
     (let ((op (proof-in-allnc-elim-form-to-op proof))
	   (arg (proof-in-allnc-elim-form-to-arg proof)))
       (make-proof-in-allnc-elim-form
	(rename-bound-avars-aux op alist) arg)))
    (else (myerror "rename-bound-avars-aux" "proof tag expected"
		   (tag proof)))))

(define (proof-substitute proof topasubst)
  (let* ((tsubst-and-subst-and-psubst-and-asubst
	  (do ((l topasubst (cdr l))
	       (tsubst '() (if (tvar-form? (caar l))
			       (cons (car l) tsubst)
			       tsubst))
	       (subst '() (if (var-form? (caar l))
			      (cons (car l) subst)
			      subst))
	       (psubst '() (if (pvar-form? (caar l))
			       (cons (car l) psubst)
			       psubst))
	       (asubst '() (if (avar-form? (caar l))
			       (cons (car l) asubst)
			       asubst)))
	      ((null? l) (list (reverse tsubst)
			       (reverse subst)
			       (reverse psubst)
			       (reverse asubst)))))
	 (tsubst (car tsubst-and-subst-and-psubst-and-asubst))
	 (subst (cadr tsubst-and-subst-and-psubst-and-asubst))
	 (psubst (caddr tsubst-and-subst-and-psubst-and-asubst))
	 (asubst (cadddr tsubst-and-subst-and-psubst-and-asubst))
	 (unfolded-psubst
	  (map (lambda (x) (let ((pvar (car x))
				 (cterm (cadr x)))
			     (list pvar (unfold-cterm cterm))))
	       psubst))
	 (rename (make-rename tsubst))
	 (prename (make-prename tsubst))
	 (arename (make-arename tsubst unfolded-psubst rename prename))
	 (tvars (map car tsubst))
	 (vars (map car subst))
	 (pvars (map car psubst))
	 (avars (map car asubst))
	 (tvars-in-subst-vars
	  (apply union (map type-to-free (map var-to-type vars))))
	 (types-in-pvars
	  (apply union (map arity-to-types (map pvar-to-arity pvars))))
	 (tvars-in-psubst-pvars
	  (apply union (map type-to-free types-in-pvars)))
	 (formulas-in-avars (map avar-to-formula avars))
	 (subst-formulas-in-avars
	  (map (lambda (x) (formula-substitute-aux
			    x tsubst subst psubst rename prename))
	       formulas-in-avars))
	 (proof-with-no-free-avar-bound (rename-bound-avars proof)))
    (if (pair? (intersection tvars tvars-in-subst-vars))
	(myerror "proof-substitute" "one of the type variables"
		 (map type-to-string tvars)
		 "is free in the type of one of the variables"
		 (map var-to-string vars)
		 "affected by subst"))
    (if (pair? (intersection tvars tvars-in-psubst-pvars))
	(myerror "proof-substitute" "one of the type variables"
		 (map type-to-string tvars)
		 "is free in the arity of one of the predicate variables"
		 (map pvar-to-string pvars)
		 "affected by psubst"))
    (if (member #f (map (lambda (x y) (classical-formula=? x y))
			formulas-in-avars subst-formulas-in-avars))
	(myerror "proof-substitute" "one of the assumption variables"
		 (map avar-to-string avars)
		 "with formulas"
		 (map formula-to-string formulas-in-avars)
		 "is changed by tsubst, subst and/or psubst, yielding formulas"
		 (map formula-to-string subst-formulas-in-avars)))
    (proof-substitute-aux
     proof-with-no-free-avar-bound
     tsubst subst unfolded-psubst asubst rename prename arename)))

(define (avar-proof-equal? avar proof)
  (and (proof-in-avar-form? proof)
       (avar=? avar (proof-in-avar-form-to-avar proof))))

(define (proof-subst proof arg val)
  (let ((equality?
	 (cond
	  ((and (tvar? arg) (type? val)) equal?)
	  ((and (var-form? arg) (term-form? val)) var-term-equal?)
	  ((and (pvar? arg) (cterm-form? val)) pvar-cterm-equal?)
	  ((and (avar-form? arg) (proof-form? val)) avar-proof-equal?)
	  (else (myerror "proof-subst" "unexpected arg" arg "and val" val)))))
    (proof-substitute proof (make-subst-wrt equality? arg val))))

; In proof-substitute-aux we always first rename, when an assumption
; variable is encountered.  Notice that prename is not really
; necessary as an argument, since we do not have explicit predicate
; quantifiers.  However, we need prename for assumption constants, and
; it seems handy to create one for all of them.

; Substitution of a pvar in an aconst can generate new parameters,
; which will be generalized.  Hence the result must be applied to
; their varterms.  One must treat elim aconsts specially, since their
; uninst-formula has the argument variables of the idpc premise free.
; Therefore substitution is defined for aconsts applied to
; sufficiently many terms only.

(define (proof-substitute-aux proof tsubst subst psubst asubst
			      rename prename arename)
  (case (tag proof)
    ((proof-in-avar-form)
     (let* ((avar (arename (proof-in-avar-form-to-avar proof) subst))
	    (info (assoc-wrt avar=? avar asubst)))
       (if info
	   (cadr info)
	   (make-proof-in-avar-form avar))))
    ((proof-in-aconst-form proof-in-allnc-elim-form)
     (let* ((op-and-args (proof-to-final-allnc-elim-op-and-args proof))
	    (op (car op-and-args))
	    (args (cdr op-and-args)))
       (if
	(not (proof-in-aconst-form? op))
	(apply mk-proof-in-elim-form
	       (cons (proof-substitute-aux
		      op tsubst subst psubst asubst rename prename arename)
		     (map (lambda (arg)
			    (term-substitute-aux arg tsubst subst rename))
			  args)))
	(let* ((aconst (proof-in-aconst-form-to-aconst op))
	       (inst-formula (aconst-to-inst-formula aconst))
	       (free (formula-to-free inst-formula))
	       (k (if (string=? (aconst-to-name aconst) "Elim")
		      (let* ((imp-formulas (aconst-to-repro-formulas aconst))
			     (imp-formula (car imp-formulas))
			     (prem (imp-form-to-premise imp-formula))
			     (args (predicate-form-to-args prem)))
			(length args))
		      0))
	       (kplusn (length free))
	       (n (- kplusn k)))
	  (if
	   (<= kplusn (length args))
	   (let* ((elim-args (list-head args k))
		  (param-and-rest-args (list-tail args k))
		  (param-args (list-head param-and-rest-args n))
		  (rest-args (list-tail param-and-rest-args n))
		  (elim-free (list-head free k))
		  (param-free (list-tail free k))
		  (norm-param-subst (make-substitution-wrt var-term-equal?
							   param-free
							   param-args))
		  (new-subst
		   (compose-substitutions-wrt
		    (lambda (term sigma)
		      (term-substitute-aux term tsubst sigma rename))
		    equal? var-term-equal? norm-param-subst subst))
		  (new-aconst (aconst-substitute-aux
			       aconst tsubst new-subst psubst rename prename))
		  (new-free (formula-to-free
			     (aconst-to-inst-formula new-aconst))))
	     (apply
	      mk-proof-in-elim-form
	      (cons (make-proof-in-aconst-form new-aconst)
		    (append
		     (map (lambda (arg)
			    (term-substitute-aux arg tsubst subst rename))
			  elim-args)
		     (map make-term-in-var-form (list-tail new-free k))
		     (map (lambda (arg)
			    (term-substitute-aux arg tsubst subst rename))
			  rest-args)))))
	   (myerror "proof-substitute-aux"
		    "substitution in aconst with allnc elims"
		    (proof-to-expr proof)
		    "whose free parameters are"
		    (map var-to-string free)
		    "requires at least that many arguments"))))))
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (kernel (proof-in-imp-intro-form-to-kernel proof))
	    (new-avar (arename avar subst)))
       (make-proof-in-imp-intro-form
	new-avar
	(proof-substitute-aux
	 kernel tsubst subst psubst asubst rename prename arename))))
    ((proof-in-imp-elim-form)
     (let ((op (proof-in-imp-elim-form-to-op proof))
	   (arg (proof-in-imp-elim-form-to-arg proof)))
       (make-proof-in-imp-elim-form
	(proof-substitute-aux
	 op tsubst subst psubst asubst rename prename arename)
	(proof-substitute-aux 
	 arg tsubst subst psubst asubst rename prename arename))))
    ((proof-in-impnc-intro-form)
     (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (new-avar (arename avar subst)))
       (make-proof-in-impnc-intro-form
	new-avar
	(proof-substitute-aux
	 kernel tsubst subst psubst asubst rename prename arename))))
    ((proof-in-impnc-elim-form)
     (let ((op (proof-in-impnc-elim-form-to-op proof))
	   (arg (proof-in-impnc-elim-form-to-arg proof)))
       (make-proof-in-impnc-elim-form
	(proof-substitute-aux
	 op tsubst subst psubst asubst rename prename arename)
	(proof-substitute-aux 
	 arg tsubst subst psubst asubst rename prename arename))))
    ((proof-in-and-intro-form)
     (make-proof-in-and-intro-form
      (proof-substitute-aux 
       (proof-in-and-intro-form-to-left proof)
       tsubst subst psubst asubst rename prename arename)
      (proof-substitute-aux 
       (proof-in-and-intro-form-to-right proof)
       tsubst subst psubst asubst rename prename arename)))
    ((proof-in-and-elim-left-form)
     (make-proof-in-and-elim-left-form
      (proof-substitute-aux 
       (proof-in-and-elim-left-form-to-kernel proof)
       tsubst subst psubst asubst rename prename arename)))
    ((proof-in-and-elim-right-form)
     (make-proof-in-and-elim-right-form
      (proof-substitute-aux 
       (proof-in-and-elim-right-form-to-kernel proof)
       tsubst subst psubst asubst rename prename arename)))
    ((proof-in-all-intro-form)
     (let* ((var (rename (proof-in-all-intro-form-to-var proof)))
	    (kernel (proof-in-all-intro-form-to-kernel proof))
	    (new-var (var-to-new-var var))
	    (new-subst (compose-o-substitutions
			(make-subst var (make-term-in-var-form new-var))
			subst)))
       (make-proof-in-all-intro-form
	new-var
	(proof-substitute-aux
	 kernel tsubst new-subst psubst asubst rename prename arename))))
    ((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-proof-in-all-elim-form
	(proof-substitute-aux
	 op tsubst subst psubst asubst rename prename arename)
	(term-substitute-aux arg tsubst subst rename))))
    ((proof-in-allnc-intro-form)
     (let* ((var (rename (proof-in-allnc-intro-form-to-var proof)))
	    (kernel (proof-in-allnc-intro-form-to-kernel proof))
	    (new-var (var-to-new-var var))
	    (new-subst (compose-o-substitutions
			(make-subst var (make-term-in-var-form new-var))
			subst)))
       (make-proof-in-allnc-intro-form
	new-var
	(proof-substitute-aux
	 kernel tsubst new-subst psubst asubst rename prename arename))))
    (else (myerror "proof-substitute-aux" "proof tag expected" (tag proof)))))

(define (aconst-substitute-aux aconst0 tsubst subst psubst rename prename)
  (let* ((uninst-formula0 (aconst-to-uninst-formula aconst0))
	 (tpinst0 (aconst-to-tpinst aconst0))
	 (tsubst0 (list-transform-positive tpinst0
		    (lambda (x) (tvar-form? (car x)))))
	 (pinst0 (list-transform-positive tpinst0
		   (lambda (x) (pvar-form? (car x)))))
	 (repro-formulas0 (aconst-to-repro-formulas aconst0))
	 (tvars0 (formula-to-tvars uninst-formula0))
	 (pvars0 (formula-to-pvars uninst-formula0))
	 (composed-tsubst (compose-t-substitutions tsubst0 tsubst))
	 (reduced-composed-tsubst (list-transform-positive composed-tsubst
				    (lambda (x) (member (car x) tvars0))))
	 (omitted-pvars (set-minus pvars0 (map car pinst0)))
	 (completed-pinst0
	  (append pinst0 (map (lambda (x) (list x (predicate-to-cterm x)))
			      omitted-pvars)))
	 (composed-pinst (map (lambda (x)
				(let ((pvar (car x))
				      (cterm (cadr x)))
				  (list pvar (cterm-substitute-aux
					      cterm tsubst subst psubst
					      rename prename))))
			      completed-pinst0))
	 (reduced-composed-pinst
	  (list-transform-positive composed-pinst
	    (lambda (x) (and (not (pvar-cterm-equal? (car x) (cadr x)))
			     (member (car x) pvars0)))))
	 (new-repro-formulas ;better: repro-data
	  (if (string=? "Intro" (aconst-to-name aconst0))
	      (let* ((i (car repro-formulas0))
		     (idpredconst (cadr repro-formulas0))
		     (name (idpredconst-to-name idpredconst))
		     (types (idpredconst-to-types idpredconst))
		     (cterms (idpredconst-to-cterms idpredconst))
		     (new-idpredconst
		      (make-idpredconst
		       name
		       (map (lambda (x) (type-substitute x tsubst)) types)
		       (map (lambda (x)
			      (cterm-substitute x (append tsubst psubst)))
			    cterms))))
		(list i new-idpredconst))
	      (map (lambda (x) (formula-substitute-aux
				x tsubst subst psubst rename prename))
		   repro-formulas0))))
    (apply make-aconst
	   (append (list (aconst-to-name aconst0)
			 (aconst-to-kind aconst0)
			 uninst-formula0
			 (append reduced-composed-tsubst
				 reduced-composed-pinst))
		   new-repro-formulas))))

(define (proof-substitute-and-beta0-nf proof subst)
  (if
   (null? subst)
   proof
   (case (tag proof)
     ((proof-in-avar-form)
      (let* ((avar (proof-in-avar-form-to-avar proof))
	     (formula (avar-to-formula avar))
	     (newavar
	      (if (intersection (map car subst) (formula-to-free formula))
		  (make-avar
		   (formula-substitute-and-beta0-nf
		    (avar-to-formula avar) subst)
		   (avar-to-index avar)
		   (avar-to-name avar))
		  avar)))
	(make-proof-in-avar-form newavar)))
     ((proof-in-aconst-form) proof)
     ((proof-in-imp-intro-form)
      (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	     (formula (avar-to-formula avar))
	     (newavar
	      (if (intersection (map car subst) (formula-to-free formula))
		  (make-avar
		   (formula-substitute-and-beta0-nf formula subst)
		   (avar-to-index avar)
		   (avar-to-name avar))
		  avar))
	     (kernel (proof-in-imp-intro-form-to-kernel proof)))
	(make-proof-in-imp-intro-form newavar
				      (proof-substitute-and-beta0-nf
				       kernel subst))))
     ((proof-in-imp-elim-form)
      (make-proof-in-imp-elim-form
       (proof-substitute-and-beta0-nf
	(proof-in-imp-elim-form-to-op proof) subst)
       (proof-substitute-and-beta0-nf
	(proof-in-imp-elim-form-to-arg proof) subst)))
     ((proof-in-impnc-intro-form)
      (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	     (formula (avar-to-formula avar))
	     (newavar
	      (if (intersection (map car subst) (formula-to-free formula))
		  (make-avar
		   (formula-substitute-and-beta0-nf formula subst)
		   (avar-to-index avar)
		   (avar-to-name avar))
		  avar))
	     (kernel (proof-in-impnc-intro-form-to-kernel proof)))
	(make-proof-in-impnc-intro-form newavar
				      (proof-substitute-and-beta0-nf
				       kernel subst))))
     ((proof-in-impnc-elim-form)
      (make-proof-in-impnc-elim-form
       (proof-substitute-and-beta0-nf
	(proof-in-impnc-elim-form-to-op proof) subst)
       (proof-substitute-and-beta0-nf
	(proof-in-impnc-elim-form-to-arg proof) subst)))
     ((proof-in-and-intro-form)
      (make-proof-in-and-intro-form
       (proof-substitute-and-beta0-nf
	(proof-in-and-intro-form-to-left proof) subst)
       (proof-substitute-and-beta0-nf
	(proof-in-and-intro-form-to-right proof) subst)))
     ((proof-in-and-elim-left-form)
      (make-proof-in-and-elim-left-form
       (proof-substitute-and-beta0-nf
	(proof-in-and-elim-left-form-to-kernel proof) subst)))
     ((proof-in-and-elim-right-form)
      (make-proof-in-and-elim-right-form
       (proof-substitute-and-beta0-nf
	(proof-in-and-elim-right-form-to-kernel proof) subst)))
     ((proof-in-all-intro-form)
      (let* ((var (proof-in-all-intro-form-to-var proof))
	     (kernel (proof-in-all-intro-form-to-kernel proof))
	     (vars (map car subst))
	     (active-vars (intersection vars (proof-to-free proof)))
	     (active-subst
	      (do ((l subst (cdr l))
		   (res '() (if (member (caar l) active-vars)
				(cons (car l) res)
				res)))
		  ((null? l) (reverse res))))
	     (active-terms (map cadr active-subst)))
	(if (member var (apply union (map term-to-free active-terms)))
	    (let ((new-var (var-to-new-var var)))
	      (make-proof-in-all-intro-form
	       new-var
	       (proof-substitute-and-beta0-nf
		kernel (cons (list var (make-term-in-var-form new-var))
			     active-subst))))
	    (make-proof-in-all-intro-form
	     var (proof-substitute-and-beta0-nf kernel active-subst)))))
     ((proof-in-all-elim-form)
      (make-proof-in-all-elim-form
       (proof-substitute-and-beta0-nf
	(proof-in-all-elim-form-to-op proof) subst)
       (term-substitute-and-beta0-nf
	(proof-in-all-elim-form-to-arg proof) subst)))
     ((proof-in-allnc-intro-form)
      (let* ((var (proof-in-allnc-intro-form-to-var proof))
	     (kernel (proof-in-allnc-intro-form-to-kernel proof))
	     (vars (map car subst))
	     (active-vars (intersection vars (proof-to-free proof)))
	     (active-subst
	      (do ((l subst (cdr l))
		   (res '() (if (member (caar l) active-vars)
				(cons (car l) res)
				res)))
		  ((null? l) (reverse res))))
	     (active-terms (map cadr active-subst)))
	(if (member var (apply union (map term-to-free active-terms)))
	    (let ((new-var (var-to-new-var var)))
	      (make-proof-in-allnc-intro-form
	       new-var
	       (proof-substitute-and-beta0-nf
		kernel (cons (list var (make-term-in-var-form new-var))
			     active-subst))))
	    (make-proof-in-allnc-intro-form
	     var (proof-substitute-and-beta0-nf kernel active-subst)))))
     ((proof-in-allnc-elim-form)
      (make-proof-in-allnc-elim-form
       (proof-substitute-and-beta0-nf
	(proof-in-allnc-elim-form-to-op proof) subst)
       (term-substitute-and-beta0-nf
	(proof-in-allnc-elim-form-to-arg proof) subst)))
     (else (myerror "proof-substitute-and-beta0-nf" "proof tag expected"
		    (tag proof))))))

; (expand-theorems proof) expands all theorems recursively.
; (expand-theorems proof name-test?) expands (non-recursively) the theorems
; passing the test by instances of their saved proofs.

(define (expand-theorems proof . opt-name-test)
  (case (tag proof)
    ((proof-in-avar-form) proof)
    ((proof-in-aconst-form)
     (let* ((aconst (proof-in-aconst-form-to-aconst proof))
	    (name (aconst-to-name aconst))
	    (kind (aconst-to-kind aconst)))
       (cond ((not (eq? 'theorem kind)) proof)
             ((null? opt-name-test)
	      (let* ((inst-proof (theorem-aconst-to-inst-proof aconst))
		     (free (formula-to-free (proof-to-formula inst-proof))))
		(expand-theorems 
		 (apply mk-proof-in-nc-intro-form
			(append free (list inst-proof))))))
	     (((car opt-name-test) name)
	      (let* ((inst-proof (theorem-aconst-to-inst-proof aconst))
		     (free (formula-to-free (proof-to-formula inst-proof))))
		(apply mk-proof-in-nc-intro-form
		       (append free (list inst-proof)))))
	     (else 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)))
       (make-proof-in-imp-elim-form
	(apply expand-theorems (cons op opt-name-test))
	(apply expand-theorems (cons arg opt-name-test)))))
    ((proof-in-imp-intro-form)
     (let ((avar (proof-in-imp-intro-form-to-avar proof))
	   (kernel (proof-in-imp-intro-form-to-kernel proof)))
       (make-proof-in-imp-intro-form
	avar (apply expand-theorems (cons kernel opt-name-test)))))
    ((proof-in-impnc-elim-form)
     (let ((op (proof-in-impnc-elim-form-to-op proof))
	   (arg (proof-in-impnc-elim-form-to-arg proof)))
       (make-proof-in-impnc-elim-form
	(apply expand-theorems (cons op opt-name-test))
	(apply expand-theorems (cons arg opt-name-test)))))
    ((proof-in-impnc-intro-form)
     (let ((avar (proof-in-impnc-intro-form-to-avar proof))
	   (kernel (proof-in-impnc-intro-form-to-kernel proof)))
       (make-proof-in-impnc-intro-form
	avar (apply expand-theorems (cons kernel opt-name-test)))))
    ((proof-in-and-intro-form)
     (let ((left (proof-in-and-intro-form-to-left proof))
	   (right (proof-in-and-intro-form-to-right proof)))
       (make-proof-in-and-intro-form
	(apply expand-theorems (cons left opt-name-test))
	(apply expand-theorems (cons right opt-name-test)))))
    ((proof-in-and-elim-left-form)
     (let ((kernel (proof-in-and-elim-left-form-to-kernel proof)))
       (make-proof-in-and-elim-left-form
	(apply expand-theorems (cons kernel opt-name-test)))))
    ((proof-in-and-elim-right-form)
     (let ((kernel (proof-in-and-elim-right-form-to-kernel proof)))
       (make-proof-in-and-elim-right-form
	(apply expand-theorems (cons kernel opt-name-test)))))
    ((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-proof-in-all-intro-form
	var (apply expand-theorems (cons kernel opt-name-test)))))
    ((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-proof-in-all-elim-form
	(apply expand-theorems (cons op opt-name-test)) 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)))
       (make-proof-in-allnc-intro-form
	var (apply expand-theorems (cons kernel opt-name-test)))))
    ((proof-in-allnc-elim-form)
     (let ((op (proof-in-allnc-elim-form-to-op proof))
	   (arg (proof-in-allnc-elim-form-to-arg proof)))
       (make-proof-in-allnc-elim-form
	(apply expand-theorems (cons op opt-name-test)) arg)))
    (else (myerror "expand-theorems" "proof tag expected" (tag proof)))))

(define (expand-thm proof thm-name)
  (expand-theorems proof (lambda (name) (string=? name thm-name))))

(define (expand-theorems-with-positive-content proof)
  (case (tag proof)
    ((proof-in-avar-form) proof)
    ((proof-in-aconst-form)
     (let* ((aconst (proof-in-aconst-form-to-aconst proof))
	    (name (aconst-to-name aconst))
	    (kind (aconst-to-kind aconst)))
       (if (and (eq? 'theorem (aconst-to-kind aconst))
		(not (formula-of-nulltypep? (aconst-to-formula aconst))))
	   (let* ((inst-proof (theorem-aconst-to-inst-proof aconst))
		  (free (formula-to-free (proof-to-formula inst-proof))))
	     (expand-theorems-with-positive-content
	      (apply mk-proof-in-nc-intro-form
		     (append free (list inst-proof)))))
	   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)))
       (make-proof-in-imp-elim-form
	(expand-theorems-with-positive-content op)
	(expand-theorems-with-positive-content arg))))
    ((proof-in-imp-intro-form)
     (let ((avar (proof-in-imp-intro-form-to-avar proof))
	   (kernel (proof-in-imp-intro-form-to-kernel proof)))
       (make-proof-in-imp-intro-form
	avar (expand-theorems-with-positive-content kernel))))
    ((proof-in-impnc-elim-form)
     (let ((op (proof-in-impnc-elim-form-to-op proof))
	   (arg (proof-in-impnc-elim-form-to-arg proof)))
       (make-proof-in-impnc-elim-form
	(expand-theorems-with-positive-content op)
	(expand-theorems-with-positive-content arg))))
    ((proof-in-impnc-intro-form)
     (let ((avar (proof-in-impnc-intro-form-to-avar proof))
	   (kernel (proof-in-impnc-intro-form-to-kernel proof)))
       (make-proof-in-impnc-intro-form
	avar (expand-theorems-with-positive-content kernel))))
    ((proof-in-and-intro-form)
     (let ((left (proof-in-and-intro-form-to-left proof))
	   (right (proof-in-and-intro-form-to-right proof)))
       (make-proof-in-and-intro-form
	(expand-theorems-with-positive-content left)
	(expand-theorems-with-positive-content right))))
    ((proof-in-and-elim-left-form)
     (let ((kernel (proof-in-and-elim-left-form-to-kernel proof)))
       (make-proof-in-and-elim-left-form
	(expand-theorems-with-positive-content kernel))))
    ((proof-in-and-elim-right-form)
     (let ((kernel (proof-in-and-elim-right-form-to-kernel proof)))
       (make-proof-in-and-elim-right-form
	(expand-theorems-with-positive-content kernel))))
    ((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-proof-in-all-intro-form
	var (expand-theorems-with-positive-content kernel))))
    ((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-proof-in-all-elim-form
	(expand-theorems-with-positive-content op) 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)))
       (make-proof-in-allnc-intro-form
	var (expand-theorems-with-positive-content kernel))))
    ((proof-in-allnc-elim-form)
     (let ((op (proof-in-allnc-elim-form-to-op proof))
	   (arg (proof-in-allnc-elim-form-to-arg proof)))
       (make-proof-in-allnc-elim-form
	(expand-theorems-with-positive-content op) arg)))
    (else (myerror "expand-theorems-with-positive-content"
		   "proof tag expected" (tag proof)))))


; 10-4. Display
; =============

(define (display-proof . opt-proof)
  (if (and (null? opt-proof)
	   (null? PPROOF-STATE))
      (myerror
       "display-proof: proof argument or proof under construction expected"))
  (let ((proof (if (null? opt-proof)
		   (pproof-state-to-proof)
		   (car opt-proof))))
    (display-proof-aux proof 0)))

; (define (display-proof proof)
;   (display-proof-aux proof 0))

(define dp display-proof)

(define (display-normalized-proof . opt-proof)
  (if (and (null? opt-proof)
	   (null? PPROOF-STATE))
      (myerror "display-normalized-proof"
	       "proof argument or proof under construction expected"))
  (let ((proof (if (null? opt-proof)
		   (pproof-state-to-proof)
		   (car opt-proof))))
    (display-proof-aux (nbe-normalize-proof proof) 0)))

(define dnp display-normalized-proof)

(define (display-proof-aux proof n)
  (if
   COMMENT-FLAG
   (case (tag proof)
     ((proof-in-avar-form)
      (display-comment (make-string n #\.))
      (dff (proof-to-formula proof)) (display " by assumption ")
      (display (avar-to-string (proof-in-avar-form-to-avar proof))) (newline))
     ((proof-in-aconst-form)
      (let ((aconst (proof-in-aconst-form-to-aconst proof)))
	(display-comment (make-string n #\.))
	(dff (proof-to-formula proof))
	(case (aconst-to-kind aconst)
	  ((axiom) (display " by axiom "))
	  ((theorem) (display " by theorem "))
	  ((global-assumption) (display " by global assumption "))
	  (else (myerror "display-proof-aux" "kind of aconst expected"
			 (aconst-to-kind aconst))))
	(display (aconst-to-name aconst))
	(newline)))
     ((proof-in-imp-intro-form)
      (display-proof-aux (proof-in-imp-intro-form-to-kernel proof) (+ n 1))
      (display-comment (make-string n #\.))
      (dff (proof-to-formula proof)) (display " by imp intro ")
      (display (avar-to-string (proof-in-imp-intro-form-to-avar proof)))
      (newline))
     ((proof-in-imp-elim-form)
      (display-proof-aux (proof-in-imp-elim-form-to-op proof) (+ n 1))
      (display-proof-aux (proof-in-imp-elim-form-to-arg proof) (+ n 1))
      (display-comment (make-string n #\.))
      (dff (proof-to-formula proof)) (display " by imp elim") (newline))
     ((proof-in-impnc-intro-form)
      (display-proof-aux (proof-in-impnc-intro-form-to-kernel proof) (+ n 1))
      (display-comment (make-string n #\.))
      (dff (proof-to-formula proof)) (display " by impnc intro ")
      (display (avar-to-string (proof-in-impnc-intro-form-to-avar proof)))
      (newline))
     ((proof-in-impnc-elim-form)
      (display-proof-aux (proof-in-impnc-elim-form-to-op proof) (+ n 1))
      (display-proof-aux (proof-in-impnc-elim-form-to-arg proof) (+ n 1))
      (display-comment (make-string n #\.))
      (dff (proof-to-formula proof)) (display " by impnc elim") (newline))
     ((proof-in-and-intro-form)
      (display-proof-aux (proof-in-and-intro-form-to-left proof) (+ n 1))
      (display-proof-aux (proof-in-and-intro-form-to-right proof) (+ n 1))
      (display-comment (make-string n #\.))
      (dff (proof-to-formula proof)) (display " by and intro") (newline))
     ((proof-in-and-elim-left-form)
      (display-proof-aux
       (proof-in-and-elim-left-form-to-kernel proof) (+ n 1))
      (display-comment (make-string n #\.))
      (dff (proof-to-formula proof)) (display " by and elim left") (newline))
     ((proof-in-and-elim-right-form)
      (display-proof-aux
       (proof-in-and-elim-right-form-to-kernel proof) (+ n 1))
      (display-comment (make-string n #\.))
      (dff (proof-to-formula proof)) (display " by and elim right") (newline))
     ((proof-in-all-intro-form)
      (display-proof-aux (proof-in-all-intro-form-to-kernel proof) (+ n 1))
      (display-comment (make-string n #\.))
      (dff (proof-to-formula proof)) (display " by all intro") (newline))
     ((proof-in-all-elim-form)
      (display-proof-aux (proof-in-all-elim-form-to-op proof) (+ n 1))
      (display-comment (make-string (+ n 1) #\.))
      (display-term (proof-in-all-elim-form-to-arg proof)) (newline)
      (display-comment (make-string n #\.))
      (dff (proof-to-formula proof)) (display " by all elim") (newline))
     ((proof-in-allnc-intro-form)
      (display-proof-aux (proof-in-allnc-intro-form-to-kernel proof) (+ n 1))
      (display-comment (make-string n #\.))
      (dff (proof-to-formula proof)) (display " by allnc intro") (newline))
     ((proof-in-allnc-elim-form)
      (display-proof-aux (proof-in-allnc-elim-form-to-op proof) (+ n 1))
      (display-comment (make-string (+ n 1) #\.))
      (display-term (proof-in-allnc-elim-form-to-arg proof)) (newline)
      (display-comment (make-string n #\.))
      (dff (proof-to-formula proof)) (display " by allnc elim") (newline))
     (else (myerror "display-proof-aux" "proof tag expected" (tag proof))))))

(define (dff formula) (df (fold-formula formula)))

(define (proof-to-pterm proof)
  (let* ((genavars (append (proof-to-free-and-bound-avars proof)
			   (proof-to-aconsts-without-rules proof)))
	 (vars (map (lambda (x)
		      (type-to-new-var
		       (nbe-formula-to-type
			(cond
			 ((avar-form? x) (avar-to-formula x))
			 ((aconst-form? x) (aconst-to-formula x))
			 (else (myerror
				"proof-to-pterm" "genavar expected" x))))))
		    genavars))
	 (genavar-var-alist (map (lambda (u x) (list u x)) genavars vars))
	 (var-genavar-alist (map (lambda (x u) (list x u)) vars genavars)))
    (proof-and-genavar-var-alist-to-pterm genavar-var-alist proof)))

(define (display-pterm . opt-proof)
  (if (and (null? opt-proof)
	   (null? PPROOF-STATE))
      (myerror
       "display-pterm: proof argument or proof under construction expected"))
  (let ((proof (if (null? opt-proof)
		   (pproof-state-to-proof)
		   (car opt-proof))))
    (if
     COMMENT-FLAG
     (term-to-string (proof-to-pterm proof)))))

(define dpt display-pterm)

(define (display-normalized-pterm . opt-proof)
  (if (and (null? opt-proof)
	   (null? PPROOF-STATE))
      (myerror "display-normalized-pterm"
	       "proof argument or proof under construction expected"))
  (let ((proof (if (null? opt-proof)
		   (pproof-state-to-proof)
		   (car opt-proof))))
    (if
     COMMENT-FLAG
     (term-to-string (proof-to-pterm (nbe-normalize-proof proof))))))

(define dnpt display-normalized-pterm)

(define (display-eterm . opt-proof)
  (if (and (null? opt-proof)
	   (null? PPROOF-STATE))
      (myerror
       "display-eterm: proof argument or proof under construction expected"))
  (let ((proof (if (null? opt-proof)
		   (pproof-state-to-proof)
		   (car opt-proof))))
    (if
     COMMENT-FLAG
     (term-to-string (proof-to-extracted-term proof)))))

(define det display-eterm)

(define (display-normalized-eterm . opt-proof)
  (if (and (null? opt-proof)
	   (null? PPROOF-STATE))
      (myerror "display-normalized-eterm"
	       "proof argument or proof under construction expected"))
  (let ((proof (if (null? opt-proof)
		   (pproof-state-to-proof)
		   (car opt-proof))))
    (if
     COMMENT-FLAG
     (term-to-string (nbe-normalize-term (proof-to-extracted-term proof))))))

(define dnet display-normalized-eterm)

; We also provide a readable type-free lambda expression

(define (proof-to-expr proof)
  (case (tag proof)
    ((proof-in-avar-form)
     (let* ((avar (proof-in-avar-form-to-avar proof))
	    (string (avar-to-string avar)))
       (string->symbol string)))
    ((proof-in-aconst-form)
     (let* ((aconst (proof-in-aconst-form-to-aconst proof))
	    (string (aconst-to-name aconst)))
       (string->symbol string)))
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (kernel (proof-in-imp-intro-form-to-kernel proof))
	    (string (avar-to-string avar)))
       (list 'lambda (list (string->symbol string)) (proof-to-expr kernel))))
    ((proof-in-imp-elim-form)
     (let* ((op (proof-in-imp-elim-form-to-op proof))
	    (arg (proof-in-imp-elim-form-to-arg proof)))
       (list (proof-to-expr op)
	     (proof-to-expr arg))))
    ((proof-in-impnc-intro-form)
     (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (string (avar-to-string avar)))
       (list 'lambda (list (string->symbol string)) (proof-to-expr kernel))))
    ((proof-in-impnc-elim-form)
     (let* ((op (proof-in-impnc-elim-form-to-op proof))
	    (arg (proof-in-impnc-elim-form-to-arg proof)))
       (list (proof-to-expr op)
	     (proof-to-expr arg))))
    ((proof-in-and-intro-form)
     (let* ((left (proof-in-and-intro-form-to-left proof))
	    (right (proof-in-and-intro-form-to-right proof)))
       (list 'cons (proof-to-expr left) (proof-to-expr right))))
    ((proof-in-and-elim-left-form)
     (let ((kernel (proof-in-and-elim-left-form-to-kernel proof)))
       (list 'car (proof-to-expr kernel))))
    ((proof-in-and-elim-right-form)
     (let ((kernel (proof-in-and-elim-right-form-to-kernel proof)))
       (list 'cdr (proof-to-expr kernel))))
    ((proof-in-all-intro-form)
     (let* ((var (proof-in-all-intro-form-to-var proof))
	    (kernel (proof-in-all-intro-form-to-kernel proof))
	    (string (var-to-string var)))
       (list 'lambda (list (string->symbol string)) (proof-to-expr kernel))))
    ((proof-in-all-elim-form)
     (let* ((op (proof-in-all-elim-form-to-op proof))
	    (arg (proof-in-all-elim-form-to-arg proof)))
       (list (proof-to-expr op) (term-to-expr 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))
	    (string (var-to-string var)))
       (list 'lambda (list (string->symbol string)) (proof-to-expr kernel))))
    ((proof-in-allnc-elim-form)
     (let* ((op (proof-in-allnc-elim-form-to-op proof))
	    (arg (proof-in-allnc-elim-form-to-arg proof)))
       (list (proof-to-expr op) (term-to-expr arg))))
    (else (myerror "proof-to-expr" "proof tag expected" (tag proof)))))

(define (display-proof-expr . opt-proof)
  (if (and (null? opt-proof)
	   (null? PPROOF-STATE))
      (myerror 
       "display-proof-expr"
       "proof argument or proof under construction expected"))
  (let* ((proof (if (null? opt-proof)
		    (pproof-state-to-proof)
		    (car opt-proof))))
    (cond
     (COMMENT-FLAG
      (proof-to-expr proof)))))

(define dpe display-proof-expr)

(define (display-normalized-proof-expr . opt-proof)
  (if (and (null? opt-proof)
	   (null? PPROOF-STATE))
      (myerror 
       "display-normalized-proof-expr"
       " proof argument or proof under construction expected"))
  (let ((proof (if (null? opt-proof)
		   (pproof-state-to-proof)
		   (car opt-proof))))
    (if
     COMMENT-FLAG
     (proof-to-expr (nbe-normalize-proof proof)))))

(define dnpe display-normalized-proof-expr)

(define (proof-to-expr-with-formulas proof . x)
  (let ((f (if (null? x) 
	       fold-formula
	       (car x))))
    (proof-to-expr-with-formulas-aux proof f)))

(define (proof-to-expr-with-formulas-aux proof f)
  (if
   COMMENT-FLAG
   (let* ((aconsts (proof-to-aconsts proof))
	  (bound-avars (proof-to-bound-avars proof))
	  (free-avars (proof-to-free-avars proof)))
     (for-each
      (lambda (aconst)
	(display-comment
	 (aconst-to-name aconst) ": "
	 (pretty-print-string
	  (string-length COMMENT-STRING) ;indent
	  (- pp-width (string-length COMMENT-STRING))
	  (f (rename-variables (aconst-to-formula aconst)))))
	(newline))
      aconsts)
     (for-each
      (lambda (avar)
	(display-comment
	 (avar-to-string avar) ": "
	 (pretty-print-string
	  (string-length COMMENT-STRING) ;indent
	  (- pp-width (string-length COMMENT-STRING))
	  (f (rename-variables (avar-to-formula avar)))))
	(newline))
      free-avars)
     (for-each
      (lambda (avar)
	(display-comment
	 (avar-to-string avar) ": "
	 (pretty-print-string
	  (string-length COMMENT-STRING) ;indent
	  (- pp-width (string-length COMMENT-STRING))
	  (f (rename-variables (avar-to-formula avar)))))
	(newline))
      bound-avars)
     (proof-to-expr proof))))

(define (proof-to-expr-with-aconsts proof . x)
  (let ((f (if (null? x) 
	       fold-formula
	       (car x))))
    (proof-to-expr-with-aconsts-aux proof f)))

(define (proof-to-expr-with-aconsts-aux proof f)
  (if
   COMMENT-FLAG
   (let* ((aconsts (proof-to-aconsts proof)))
     (display-comment "Assumption constants:")
     (newline)
     (for-each
      (lambda (aconst)
	(display-comment
	 (aconst-to-name aconst) ": "
	 (pretty-print-string
	  (string-length COMMENT-STRING) ;indent
	  (- pp-width (string-length COMMENT-STRING))
	  (f (aconst-to-formula aconst))))
	(newline))
      aconsts)
     (proof-to-expr proof))))


; 10-5. Check
; ===========

(define (check-and-display-proof . opt-proof-and-ignore-deco-flag)
  (let* ((proofs (list-transform-positive opt-proof-and-ignore-deco-flag
		   proof-form?))
	 (rest (list-transform-positive opt-proof-and-ignore-deco-flag
		 (lambda (item) (not (proof-form? item)))))
	 (proof (if (pair? proofs)
		    (car proofs)
		    (pproof-state-to-proof)))
	 (ignore-deco-flag (if (pair? rest) (car rest) #f))
	 (nc-viols (nc-violations proof))
	 (h-deg-viols (h-deg-violations proof))
	 (avar-convention-viols (avar-convention-violations proof)))
    (check-and-display-proof-aux proof 0 ignore-deco-flag)
    (if (pair? nc-viols)
	(begin
	  (comment
	   "Incorrect proof: nc-intro with computational variable(s)")
	  (for-each comment (map (lambda (x)
				   (if (var-form? x)
				       (var-to-string x)
				       (avar-to-string x)))
				 nc-viols))))
    (if
     (pair? h-deg-viols)
     (begin
       (comment
	"Proof not suitable for extraction.  h-deg violations at aconst(s)")
       (for-each comment h-deg-viols)))
    (if (pair? avar-convention-viols)
	(begin
	  (comment
	   "Proof does not respect the avar convention.")
	  (do ((l avar-convention-viols (cdr l)))
	      ((null? l))
	    (let* ((pair (car l))
		   (avar1 (car pair))
		   (avar2 (cadr pair)))
	      (comment "The same avar with name "
		       (let ((name (avar-to-name avar1)))
			 (if (string=? "" name)
			     DEFAULT-AVAR-NAME
			     name)		       )
		       " and index "
		       (avar-to-index avar1)
		       " carries the two different formulas")
	      (pp (avar-to-formula avar1))
	      (comment "and")
	      (pp (avar-to-formula avar2))))))
    *the-non-printing-object*))

(define cdp check-and-display-proof)

(define (avar-convention-violations proof)
  (duplicates-wrt avar=?
		  (proof-to-free-and-bound-avars-wrt avar-full=? proof)))

(define CDP-COMMENT-FLAG #t)

(define (check-and-display-proof-aux proof n ignore-deco-flag)
  (if
   COMMENT-FLAG
   (cond
    ((proof-in-avar-form? proof)
     (let ((fla (proof-to-formula proof))
	   (avar (proof-in-avar-form-to-avar proof)))
       (if (not (avar? avar)) (myerror "avar expected" avar))
       (let ((avar-fla (avar-to-formula avar)))
	 (check-formula fla)
	 (check-formula avar-fla)
	 (if (not (classical-formula=? fla avar-fla ignore-deco-flag))
	     (myerror "equal formulas expected" fla avar-fla))
	 (if CDP-COMMENT-FLAG
	     (begin
	       (display-comment (make-string n #\.))
	       (dff fla) (display " by assumption ")
	       (display (avar-to-string avar)) (newline))))))
    ((proof-in-aconst-form? proof)
     (let ((fla (proof-to-formula proof))
	   (aconst (proof-in-aconst-form-to-aconst proof)))
       (check-aconst aconst)
       (let ((aconst-fla (aconst-to-formula aconst)))
	 (check-formula fla)
	 (check-formula aconst-fla)
	 (if (not (classical-formula=? fla aconst-fla ignore-deco-flag))
	     (myerror "equal formulas expected" fla aconst-fla))
	 (if ;check for correct Elim in case of an invariant idpc
	  (string=? "Elim" (aconst-to-name aconst))
	  (let* ((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
	     (and ;invariant idpc
	      (null? (idpredconst-name-to-opt-alg-name idpc-name))
					;but not one of the special ones
					;allowing arbitrary conclusions
					;(to be extended to e.g. EvenReal)
	      (not (member idpc-name '("EqD" "ExU" "AndU")))
					;not a uniform one-clause defined idpc
	      (not (and (= 1 (length clauses))
			(predicate-form?
			 (impnc-form-to-final-conclusion
			  (allnc-form-to-final-kernel (car clauses))))))
					;but with a c.r. conclusion
	      (not (formula-of-nulltype? concl)))
	     (myerror "invariant conclusion expected" concl
		      "in elimination axiom for invariant formula" idpc-fla))))
	 (if CDP-COMMENT-FLAG
	     (begin
	       (display-comment (make-string n #\.))
	       (dff fla)
	       (case (aconst-to-kind aconst)
		 ((axiom) (display " by axiom "))
		 ((theorem) (display " by theorem "))
		 ((global-assumption) (display " by global assumption "))
		 (else (myerror "kind of aconst expected"
				(aconst-to-kind aconst))))
	       (display (aconst-to-name aconst)) (newline))))))
    ((proof-in-imp-intro-form? proof)
     (let ((fla (proof-to-formula proof))
	   (avar (proof-in-imp-intro-form-to-avar proof))
	   (kernel (proof-in-imp-intro-form-to-kernel proof)))
       (check-and-display-proof-aux kernel (+ n 1) ignore-deco-flag)
       (if (not (avar? avar)) (myerror "avar expected" avar))
       (let ((avar-fla (avar-to-formula avar))
	     (kernel-fla (proof-to-formula kernel)))
	 (check-formula fla)
	 (if (not (classical-formula=? (make-imp avar-fla kernel-fla)
				       fla ignore-deco-flag))
	     (myerror "equal formulas expected"
		      (make-imp avar-fla kernel-fla) fla))
	 (if CDP-COMMENT-FLAG
	     (begin
	       (display-comment (make-string n #\.))
	       (dff fla) (display " by imp intro ")
	       (display (avar-to-string avar)) (newline))))))
    ((proof-in-imp-elim-form? proof)
     (let ((fla (proof-to-formula proof))
	   (op (proof-in-imp-elim-form-to-op proof))
	   (arg (proof-in-imp-elim-form-to-arg proof)))
       (check-and-display-proof-aux op (+ n 1) ignore-deco-flag)
       (check-and-display-proof-aux arg (+ n 1) ignore-deco-flag)
       (check-formula fla)
       (let ((op-fla (proof-to-formula op))
	     (arg-fla (proof-to-formula arg)))
	 (if (not (imp-form? op-fla))
	     (myerror "imp form expected" op-fla))
	 (if (not (classical-formula=?
		   (imp-form-to-conclusion op-fla) fla ignore-deco-flag))
	     (myerror
	      "equal formulas expected" (imp-form-to-conclusion op-fla) fla))
	 (if (not (classical-formula=?
		   (imp-form-to-premise op-fla) arg-fla ignore-deco-flag))
	     (myerror
	      "equal formulas expected" (imp-form-to-premise op-fla) arg-fla))
	 (if CDP-COMMENT-FLAG
	     (begin
	       (display-comment (make-string n #\.))
	       (dff fla) (display " by imp elim") (newline))))))
    ((proof-in-impnc-intro-form? proof)
     (let* ((fla (proof-to-formula proof))
	    (avar (proof-in-impnc-intro-form-to-avar proof))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof))
	    (cvars (proof-to-cvars kernel)))
       (if (and (not (formula-of-nulltype? (proof-to-formula kernel)))
		(member-wrt avar=? avar cvars))
	   (begin (display-comment "warning: impnc-intro with cvar"
				   (avar-to-string avar))
		  (newline)))
       (check-and-display-proof-aux kernel (+ n 1) ignore-deco-flag)
       (if (not (avar? avar)) (myerror "avar expected" avar))
       (let ((avar-fla (avar-to-formula avar))
	     (kernel-fla (proof-to-formula kernel)))
	 (check-formula fla)
	 (if (not (classical-formula=? (make-impnc avar-fla kernel-fla)
				       fla ignore-deco-flag))
	     (myerror "equal formulas expected"
		      (make-impnc avar-fla kernel-fla) fla))
	 (if CDP-COMMENT-FLAG
	     (begin
	       (display-comment (make-string n #\.))
	       (dff fla) (display " by impnc intro ")
	       (display (avar-to-string avar)) (newline))))))
    ((proof-in-impnc-elim-form? proof)
     (let ((fla (proof-to-formula proof))
	   (op (proof-in-impnc-elim-form-to-op proof))
	   (arg (proof-in-impnc-elim-form-to-arg proof)))
       (check-and-display-proof-aux op (+ n 1) ignore-deco-flag)
       (check-and-display-proof-aux arg (+ n 1) ignore-deco-flag)
       (check-formula fla)
       (let ((op-fla (proof-to-formula op))
	     (arg-fla (proof-to-formula arg)))
	 (if (not (impnc-form? op-fla))
	     (myerror "impnc form expected" op-fla))
	 (if (not (classical-formula=?
		   (impnc-form-to-conclusion op-fla) fla ignore-deco-flag))
	     (myerror
	      "equal formulas expected" (impnc-form-to-conclusion op-fla) fla))
	 (if (not (classical-formula=?
		   (impnc-form-to-premise op-fla) arg-fla ignore-deco-flag))
	     (myerror
	      "equal formulas expected"
	      (impnc-form-to-premise op-fla) arg-fla))
	 (if CDP-COMMENT-FLAG
	     (begin
	       (display-comment (make-string n #\.))
	       (dff fla) (display " by impnc elim") (newline))))))
    ((proof-in-and-intro-form? proof)
     (let ((fla (proof-to-formula proof))
	   (left (proof-in-and-intro-form-to-left proof))
	   (right (proof-in-and-intro-form-to-right proof)))
       (check-and-display-proof-aux left (+ n 1) ignore-deco-flag)
       (check-and-display-proof-aux right (+ n 1) ignore-deco-flag)
       (check-formula fla)
       (let ((left-fla (proof-to-formula left))
	     (right-fla (proof-to-formula right)))
	 (if (not (and-form? fla))
	     (myerror "and form expected" fla))
	 (if (not (classical-formula=?
		   left-fla (and-form-to-left fla) ignore-deco-flag))
	     (myerror
	      "equal formulas expected" left-fla (and-form-to-left fla)))
	 (if (not (classical-formula=?
		   right-fla (and-form-to-right fla) ignore-deco-flag))
	     (myerror
	      "equal formulas expected" right-fla (and-form-to-right fla)))
	 (if CDP-COMMENT-FLAG
	     (begin
	       (display-comment (make-string n #\.))
	       (dff fla) (display " by and intro") (newline))))))
    ((proof-in-and-elim-left-form? proof)
     (let ((fla (proof-to-formula proof))
	   (kernel (proof-in-and-elim-left-form-to-kernel proof)))
       (check-and-display-proof-aux kernel (+ n 1) ignore-deco-flag)
       (check-formula fla)
       (let ((kernel-fla (proof-to-formula kernel)))
	 (if (not (and-form? kernel-fla))
	     (myerror "in and-elim and-form expected" kernel-fla))
	 (if (not (classical-formula=?
		   (and-form-to-left kernel-fla) fla ignore-deco-flag))
	     (myerror "in and-elim formulas do not fit"
		      (and-form-to-left kernel-fla) fla))
	 (if CDP-COMMENT-FLAG
	     (begin
	       (display-comment (make-string n #\.))
	       (dff fla) (display " by and elim left") (newline))))))
    ((proof-in-and-elim-right-form? proof)
     (let ((fla (proof-to-formula proof))
	   (kernel (proof-in-and-elim-right-form-to-kernel proof)))
       (check-and-display-proof-aux kernel (+ n 1) ignore-deco-flag)
       (check-formula fla)
       (let ((kernel-fla (proof-to-formula kernel)))
	 (if (not (and-form? kernel-fla))
	     (myerror "in and-elim and-form expected" kernel-fla))
	 (if (not (classical-formula=?
		   (and-form-to-right kernel-fla) fla ignore-deco-flag))
	     (myerror "in and-elim formulas do not fit"
		      (and-form-to-right kernel-fla) fla))
	 (if CDP-COMMENT-FLAG
	     (begin
	       (display-comment (make-string n #\.))
	       (dff fla) (display " by and elim right") (newline))))))
    ((proof-in-all-intro-form? proof)
     (let ((fla (proof-to-formula proof))
	   (var (proof-in-all-intro-form-to-var proof))
	   (kernel (proof-in-all-intro-form-to-kernel proof)))
       (check-and-display-proof-aux kernel (+ n 1) ignore-deco-flag)
       (check-formula fla)
       (let* ((context (proof-to-context kernel))
	      (avars (context-to-avars context))
	      (formulas (map avar-to-formula avars)))
	 (if
	  (and
	   (member var (apply union (map formula-to-free formulas)))
	   (member var (apply union (map formula-to-free
					 (map normalize-formula formulas)))))
	  (myerror "variable condition fails for" var)))
       (if (not (all-form? fla))
	   (myerror "all form expected" fla))
       (let ((kernel-fla (proof-to-formula kernel)))
	 (if (not (classical-formula=?
		   (make-all var kernel-fla) fla ignore-deco-flag))
	     (myerror "equal formulas expected"
		      (make-all var kernel-fla) fla)))
       (if CDP-COMMENT-FLAG
	   (begin
	     (display-comment (make-string n #\.))
	     (dff fla) (display " by all intro") (newline)))))
    ((proof-in-all-elim-form? proof)
     (let ((fla (proof-to-formula proof))
	   (op (proof-in-all-elim-form-to-op proof))
	   (arg (proof-in-all-elim-form-to-arg proof)))
       (check-and-display-proof-aux op (+ n 1) ignore-deco-flag)
       (check-formula fla)
       (check-term arg)
       (let ((op-fla (proof-to-formula op)))
	 (if (not (all-form? op-fla))
	     (myerror "all form expected" op-fla))
	 (if (not (equal? (var-to-type (all-form-to-var op-fla))
			  (term-to-type arg)))
	     (myerror "equal types expected of variable"
		      (all-form-to-var op-fla) "and term" arg))
	 (if (and (t-deg-one? (var-to-t-deg (all-form-to-var op-fla)))
		  (not (synt-total? arg)))
	     (myerror "degrees of totality do not fit for variable"
		      (all-form-to-var op-fla) "and term" arg))
	 (let ((var (all-form-to-var op-fla))
	       (kernel (all-form-to-kernel op-fla)))
	   (if (and (term-in-var-form? arg)
		    (equal? var (term-in-var-form-to-var arg)))
	       (if (not (classical-formula=? fla kernel ignore-deco-flag))
		   (myerror "equal formulas expected" fla kernel))
	       (if (not (classical-formula=?
			 fla (formula-subst kernel var arg) ignore-deco-flag))
		   (myerror "equal formulas expected"
			    fla (formula-subst kernel var arg)))))
	 (if CDP-COMMENT-FLAG
	     (begin
	       (display-comment (make-string (+ n 1) #\.))
	       (display-term arg) (newline)
	       (display-comment (make-string n #\.))
	       (dff fla) (display " by all elim") (newline))))))
    ((proof-in-allnc-intro-form? proof)
     (let* ((fla (proof-to-formula proof))
	    (var (proof-in-allnc-intro-form-to-var proof))
	    (kernel (proof-in-allnc-intro-form-to-kernel proof))
	    (context (proof-to-context kernel))
	    (cvars (proof-to-cvars kernel))
	    (avars (context-to-avars context))
	    (formulas (map avar-to-formula avars))
	    (free (apply union (map formula-to-free formulas))))
       (if
	(or (and
	     (member var (apply union (map formula-to-free formulas)))
	     (member var (apply union (map formula-to-free
					   (map normalize-formula formulas)))))
	    (and (not (formula-of-nulltype? (proof-to-formula kernel)))
		 (member var cvars)))
	(begin (display-comment "warning: allnc-intro with cvar"
				(var-to-string var))
	       (newline)))
       (check-and-display-proof-aux kernel (+ n 1) ignore-deco-flag)
       (check-formula fla)
       (if (not (allnc-form? fla))
	   (myerror "allnc form expected" fla))
       (let ((kernel-fla (proof-to-formula kernel)))
	 (if (not (classical-formula=?
		   (make-allnc var kernel-fla) fla ignore-deco-flag))
	     (myerror "equal formulas expected"
		      (make-allnc var kernel-fla) fla)))
       (if CDP-COMMENT-FLAG
	   (begin
	     (display-comment (make-string n #\.))
	     (dff fla) (display " by allnc intro") (newline)))))
    ((proof-in-allnc-elim-form? proof)
     (let ((fla (proof-to-formula proof))
	   (op (proof-in-allnc-elim-form-to-op proof))
	   (arg (proof-in-allnc-elim-form-to-arg proof)))
       (check-and-display-proof-aux op (+ n 1) ignore-deco-flag)
       (check-formula fla)
       (check-term arg)
       (let ((op-fla (proof-to-formula op)))
	 (if (not (allnc-form? op-fla))
	     (myerror "allnc form expected" op-fla))
	 (if (not (equal? (var-to-type (allnc-form-to-var op-fla))
			  (term-to-type arg)))
	     (myerror "equal types expected of variable"
		      (allnc-form-to-var op-fla) "and term" arg))
	 (if (and (t-deg-one? (var-to-t-deg (allnc-form-to-var op-fla)))
		  (not (synt-total? arg)))
	     (myerror "degrees of totality do not fit for variable"
		      (allnc-form-to-var op-fla) "and term" arg))
	 (let ((op-var (allnc-form-to-var op-fla))
	       (op-kernel (allnc-form-to-kernel op-fla)))
	   (if (and (term-in-var-form? arg)
		    (equal? op-var (term-in-var-form-to-var arg)))
	       (if (not (classical-formula=? fla op-kernel ignore-deco-flag))
		   (myerror "equal formulas expected" fla op-kernel))
	       (if (not (classical-formula=?
			 fla (formula-subst op-kernel op-var arg)
			 ignore-deco-flag))
		   (myerror "equal formulas expected"
			    fla (formula-subst op-kernel op-var arg)))))
	 (if CDP-COMMENT-FLAG
	     (begin
	       (display-comment (make-string (+ n 1) #\.))
	       (display-term arg) (newline)
	       (display-comment (make-string n #\.))
	       (dff fla) (display " by allnc elim") (newline))))))
    (else (myerror "proof tag expected"
		   (tag proof))))))


; 10-6. Classical logic
; =====================

; (proof-of-stab-at formula) generates a proof of ((A -> F) -> F) -> A.
; For F, T one takes the obvious proof, and for other atomic formulas
; the proof using cases on booleans.  For all other prime, ex or exnc
; formulas one takes an instance of the global assumption Stab: 
; ((Pvar -> F) -> F) -> Pvar.

(define (proof-of-stab-at formula) ;formula must be unfolded
  (let ((rename (make-rename empty-subst))
	(prename (make-prename empty-subst)))
    (proof-of-stab-at-aux formula rename prename)))

(define (proof-of-stab-at-aux formula rename prename)
  (case (tag formula)
    ((atom predicate ex exnc)
     (cond
      ((equal? falsity formula)
;                                    u2:F
;                                   --------u2
;              u1:(F -> F) -> F      F -> F
;              ----------------------------
;                              F
       
       (let ((u1 (formula-to-new-avar (make-negation (make-negation falsity))))
	     (u2 (formula-to-new-avar falsity)))
	 (make-proof-in-imp-intro-form
	  u1 (make-proof-in-imp-elim-form
	      (make-proof-in-avar-form u1)
	      (make-proof-in-imp-intro-form
	       u2 (make-proof-in-avar-form u2))))))
      ((equal? truth formula)
       (let ((u1 (formula-to-new-avar (make-negation (make-negation truth)))))
	 (make-proof-in-imp-intro-form
	  u1 (make-proof-in-aconst-form truth-aconst))))
      ((atom-form? formula)
       (let ((kernel (atom-form-to-kernel formula)))
	 (if (not (synt-total? kernel))
	     (myerror "proof-of-stab-at-aux" "total kernel expected" kernel))
	 (mk-proof-in-elim-form
	  (make-proof-in-aconst-form 
	   (all-formula-to-cases-aconst
	    (pf "all boole(((boole -> F) -> F) -> boole)")))
	  kernel
	  (make-proof-in-imp-intro-form
	   (formula-to-new-avar (make-negation (make-negation truth)))
	   (make-proof-in-aconst-form truth-aconst))
	  (let ((u1 (formula-to-new-avar
		     (make-negation (make-negation falsity))))
		(u2 (formula-to-new-avar falsity)))
	    (make-proof-in-imp-intro-form
	     u1 (make-proof-in-imp-elim-form
		 (make-proof-in-avar-form u1)
		 (make-proof-in-imp-intro-form
		  u2 (make-proof-in-avar-form u2))))))))
      (else
       (let* ((aconst (global-assumption-name-to-aconst "Stab"))
	      (stab-formula (aconst-to-uninst-formula aconst))
	      (pvars (formula-to-pvars stab-formula))
	      (pvar (if (pair? pvars) (car pvars)
			(myerror
			 "proof-to-stab-at" "stab-formula with pvars expected"
			 stab-formula)))
	      (cterm (make-cterm formula))
	      (psubst (make-subst-wrt pvar-cterm-equal? pvar cterm)))
	 (proof-substitute-aux
	  (make-proof-in-aconst-form aconst)
	  empty-subst empty-subst psubst empty-subst
	  rename prename
	  (make-arename empty-subst psubst rename prename))))))
    ((imp)
;                                  u4:A -> B   u2:A
;                                  ----------------
;                           u3:~B          B
;                           ----------------
;                                       F
;                                   -------- u4
;              u1:~~(A -> B)        ~(A -> B)
;              ------------------------------
;                              F
;       |                     --- u3
;   ~~B -> B                  ~~B
;   -----------------------------
;                  B
     (let* ((prem (imp-form-to-premise formula))
	    (concl (imp-form-to-conclusion formula))
	    (u1 (formula-to-new-avar (make-negation (make-negation formula))))
	    (u2 (formula-to-new-avar prem))
	    (u3 (formula-to-new-avar (make-negation concl)))
	    (u4 (formula-to-new-avar formula)))
       (mk-proof-in-intro-form
	u1 u2 (make-proof-in-imp-elim-form
	       (proof-of-stab-at-aux concl rename prename)
	       (make-proof-in-imp-intro-form
		u3 (make-proof-in-imp-elim-form
		    (make-proof-in-avar-form u1)
		    (make-proof-in-imp-intro-form
		     u4 (make-proof-in-imp-elim-form
			 (make-proof-in-avar-form u3)
			 (make-proof-in-imp-elim-form
			  (make-proof-in-avar-form u4)
			  (make-proof-in-avar-form u2))))))))))
    ((impnc)
;                                  u4:A --> B   u2:A
;                                  -----------------
;                           u3:~B          B
;                           ----------------
;                                       F
;                                   -------- u4
;              u1:~~(A --> B)      ~(A --> B)
;              ------------------------------
;                              F
;       |                     --- u3
;   ~~B -> B                  ~~B
;   -----------------------------
;                  B
     (let* ((prem (impnc-form-to-premise formula))
	    (concl (impnc-form-to-conclusion formula))
	    (u1 (formula-to-new-avar (make-negation (make-negation formula))))
	    (u2 (formula-to-new-avar prem))
	    (u3 (formula-to-new-avar (make-negation concl)))
	    (u4 (formula-to-new-avar formula)))
       (mk-proof-in-intro-form
	u1 u2 (make-proof-in-imp-elim-form
	       (proof-of-stab-at-aux concl rename prename)
	       (make-proof-in-imp-intro-form
		u3 (make-proof-in-imp-elim-form
		    (make-proof-in-avar-form u1)
		    (make-proof-in-imp-intro-form
		     u4 (make-proof-in-imp-elim-form
			 (make-proof-in-avar-form u3)
			 (make-proof-in-impnc-elim-form
			  (make-proof-in-avar-form u4)
			  (make-proof-in-avar-form u2))))))))))
    ((and)
;                          u3:A&B                           u3:A&B
;                          ------                           ------
;                    u2:~A    A                       u2:~B    B
;                    ------------                     ------------
;                         F                                F
;                       ------ u3                        ------ u3
;          u1:~~(A&B)   ~(A&B)              u1:~~(A&B)   ~(A&B)
;          -------------------              -------------------
;                   F                                F
;      |           --- u2               |           --- u2
;  ~~A -> A        ~~A              ~~B -> B        ~~B
;  -------------------              -------------------
;            A                                B
;            ----------------------------------
;                           A & B
     (let* ((left-conjunct (and-form-to-left formula))
	    (right-conjunct (and-form-to-right formula))
	    (u1 (formula-to-new-avar (make-negation (make-negation formula))))
	    (u2left (formula-to-new-avar (make-negation left-conjunct)))
	    (u2right (formula-to-new-avar (make-negation right-conjunct)))
	    (u3 (formula-to-new-avar formula)))
       (make-proof-in-imp-intro-form
	u1 (make-proof-in-and-intro-form
	    (make-proof-in-imp-elim-form
	     (proof-of-stab-at-aux left-conjunct rename prename)
	     (make-proof-in-imp-intro-form
	      u2left (make-proof-in-imp-elim-form
		      (make-proof-in-avar-form u1)
		      (make-proof-in-imp-intro-form
		       u3 (make-proof-in-imp-elim-form
			   (make-proof-in-avar-form u2left)
			   (make-proof-in-and-elim-left-form
			    (make-proof-in-avar-form u3)))))))
	    (make-proof-in-imp-elim-form
	     (proof-of-stab-at-aux right-conjunct rename prename)
	     (make-proof-in-imp-intro-form
	      u2right (make-proof-in-imp-elim-form
		       (make-proof-in-avar-form u1)
		       (make-proof-in-imp-intro-form
			u3 (make-proof-in-imp-elim-form
			    (make-proof-in-avar-form u2right)
			    (make-proof-in-and-elim-right-form
			     (make-proof-in-avar-form u3)))))))))))
    ((all)
;                                  u3:all x A   x
;                                  --------------
;                           u2:~A          A
;                           ----------------
;                                       F
;                                   -------- u3
;              u1:~~all x A         ~all x A
;              -----------------------------
;                              F
;       |                     --- u2
;   ~~A -> A                  ~~A
;   -----------------------------
;                 A
;              -------
;              all x A
     (let* ((var (all-form-to-var formula))
	    (kernel (all-form-to-kernel formula))
	    (u1 (formula-to-new-avar (make-negation (make-negation formula))))
	    (u2 (formula-to-new-avar (make-negation kernel)))
	    (u3 (formula-to-new-avar formula)))
       (mk-proof-in-intro-form
	u1 var (make-proof-in-imp-elim-form
		(proof-of-stab-at-aux kernel rename prename)
		(make-proof-in-imp-intro-form
		 u2 (make-proof-in-imp-elim-form
		     (make-proof-in-avar-form u1)
		     (make-proof-in-imp-intro-form
		      u3 (make-proof-in-imp-elim-form
			  (make-proof-in-avar-form u2)
			  (make-proof-in-all-elim-form
			   (make-proof-in-avar-form u3)
			   (make-term-in-var-form var))))))))))
    ((allnc)
;                                    u3:allnc x A   x
;                                    ----------------
;                             u2:~A          A
;                             ----------------
;                                         F
;                                     ---------- u3
;              u1:~~allnc x A         ~allnc x A
;              ---------------------------------
;                              F
;       |                     --- u2
;   ~~A -> A                  ~~A
;   -----------------------------
;                 A
;              ---------
;              allnc x A
     (let* ((var (allnc-form-to-var formula))
	    (kernel (allnc-form-to-kernel formula))
	    (u1 (formula-to-new-avar (make-negation (make-negation formula))))
	    (u2 (formula-to-new-avar (make-negation kernel)))
	    (u3 (formula-to-new-avar formula)))
       (mk-proof-in-nc-intro-form
	u1 var (make-proof-in-imp-elim-form
		(proof-of-stab-at-aux kernel rename prename)
		(make-proof-in-imp-intro-form
		 u2 (make-proof-in-imp-elim-form
		     (make-proof-in-avar-form u1)
		     (make-proof-in-imp-intro-form
		      u3 (make-proof-in-imp-elim-form
			  (make-proof-in-avar-form u2)
			  (make-proof-in-allnc-elim-form
			   (make-proof-in-avar-form u3)
			   (make-term-in-var-form var))))))))))
    (else (myerror "proof-of-stab-at-aux" "formula expected" formula))))

(define (proof-of-stab-log-at formula) ;formula must be unfolded
  (let ((rename (make-rename empty-subst))
	(prename (make-prename empty-subst)))
    (proof-of-stab-log-at-aux formula rename prename)))

(define (proof-of-stab-log-at-aux formula rename prename)
  (case (tag formula)
    ((atom predicate ex exnc)
     (cond
      ((equal? falsity-log formula)
;                                            u2:bot
;                                          ----------u2
;              u1:(bot -> bot) -> bot      bot -> bot
;              --------------------------------------
;                                     bot
       
       (let ((u1 (formula-to-new-avar
		  (make-negation-log (make-negation-log falsity-log))))
	     (u2 (formula-to-new-avar falsity-log)))
	 (make-proof-in-imp-intro-form
	  u1 (make-proof-in-imp-elim-form
	      (make-proof-in-avar-form u1)
	      (make-proof-in-imp-intro-form
	       u2 (make-proof-in-avar-form u2))))))
      ((equal? truth formula)
       (let ((u1 (formula-to-new-avar
		  (make-negation-log (make-negation-log truth)))))
	 (make-proof-in-imp-intro-form
	  u1 (make-proof-in-aconst-form truth-aconst))))
      (else
       (let* ((aconst (global-assumption-name-to-aconst "Stab-Log"))
	      (stab-log-formula (aconst-to-uninst-formula aconst))
	      (pvars (formula-to-pvars stab-log-formula))
	      (pvar (if (pair? pvars) (car pvars)
			(myerror "proof-to-stab-log-at"
				 "stab-log-formula with pvars expected"
				 stab-log-formula)))
	      (cterm (make-cterm formula))
	      (psubst (make-subst-wrt pvar-cterm-equal? pvar cterm)))
	 (proof-substitute-aux
	  (make-proof-in-aconst-form aconst)
	  empty-subst empty-subst psubst empty-subst
	  rename prename
	  (make-arename empty-subst psubst rename prename))))))
    ((imp)
;                                  u4:A -> B   u2:A
;                                  ----------------
;                           u3:~B          B
;                           ----------------
;                                       bot
;                                   -------- u4
;              u1:~~(A -> B)        ~(A -> B)
;              ------------------------------
;                              bot
;       |                     --- u3
;   ~~B -> B                  ~~B
;   -----------------------------
;                  B
     (let* ((prem (imp-form-to-premise formula))
	    (concl (imp-form-to-conclusion formula))
	    (u1 (formula-to-new-avar
		 (make-negation-log (make-negation-log formula))))
	    (u2 (formula-to-new-avar prem))
	    (u3 (formula-to-new-avar (make-negation-log concl)))
	    (u4 (formula-to-new-avar formula)))
       (mk-proof-in-intro-form
	u1 u2 (make-proof-in-imp-elim-form
	       (proof-of-stab-log-at-aux concl rename prename)
	       (make-proof-in-imp-intro-form
		u3 (make-proof-in-imp-elim-form
		    (make-proof-in-avar-form u1)
		    (make-proof-in-imp-intro-form
		     u4 (make-proof-in-imp-elim-form
			 (make-proof-in-avar-form u3)
			 (make-proof-in-imp-elim-form
			  (make-proof-in-avar-form u4)
			  (make-proof-in-avar-form u2))))))))))
    ((impnc)
;                                  u4:A --> B   u2:A
;                                  -----------------
;                           u3:~B          B
;                           ----------------
;                                       bot
;                                   -------- u4
;              u1:~~(A --> B)      ~(A --> B)
;              ------------------------------
;                              bot
;       |                     --- u3
;   ~~B -> B                  ~~B
;   -----------------------------
;                  B
     (let* ((prem (impnc-form-to-premise formula))
	    (concl (impnc-form-to-conclusion formula))
	    (u1 (formula-to-new-avar
		 (make-negation-log (make-negation-log formula))))
	    (u2 (formula-to-new-avar prem))
	    (u3 (formula-to-new-avar (make-negation-log concl)))
	    (u4 (formula-to-new-avar formula)))
       (mk-proof-in-intro-form
	u1 u2 (make-proof-in-imp-elim-form
	       (proof-of-stab-log-at-aux concl rename prename)
	       (make-proof-in-imp-intro-form
		u3 (make-proof-in-imp-elim-form
		    (make-proof-in-avar-form u1)
		    (make-proof-in-imp-intro-form
		     u4 (make-proof-in-imp-elim-form
			 (make-proof-in-avar-form u3)
			 (make-proof-in-impnc-elim-form
			  (make-proof-in-avar-form u4)
			  (make-proof-in-avar-form u2))))))))))
    ((and)
;                          u3:A&B                           u3:A&B
;                          ------                           ------
;                    u2:~A    A                       u2:~B    B
;                    ------------                     ------------
;                         bot                              bot
;                       ------ u3                        ------ u3
;          u1:~~(A&B)   ~(A&B)              u1:~~(A&B)   ~(A&B)
;          -------------------              -------------------
;                  bot                             bot
;      |           --- u2               |           --- u2
;  ~~A -> A        ~~A              ~~B -> B        ~~B
;  -------------------              -------------------
;            A                                B
;            ----------------------------------
;                           A & B
     (let* ((left-conjunct (and-form-to-left formula))
	    (right-conjunct (and-form-to-right formula))
	    (u1 (formula-to-new-avar
		 (make-negation-log (make-negation-log formula))))
	    (u2left (formula-to-new-avar (make-negation-log left-conjunct)))
	    (u2right (formula-to-new-avar (make-negation-log right-conjunct)))
	    (u3 (formula-to-new-avar formula)))
       (make-proof-in-imp-intro-form
	u1 (make-proof-in-and-intro-form
	    (make-proof-in-imp-elim-form
	     (proof-of-stab-log-at-aux left-conjunct rename prename)
	     (make-proof-in-imp-intro-form
	      u2left (make-proof-in-imp-elim-form
		      (make-proof-in-avar-form u1)
		      (make-proof-in-imp-intro-form
		       u3 (make-proof-in-imp-elim-form
			   (make-proof-in-avar-form u2left)
			   (make-proof-in-and-elim-left-form
			    (make-proof-in-avar-form u3)))))))
	    (make-proof-in-imp-elim-form
	     (proof-of-stab-log-at-aux right-conjunct rename prename)
	     (make-proof-in-imp-intro-form
	      u2right (make-proof-in-imp-elim-form
		       (make-proof-in-avar-form u1)
		       (make-proof-in-imp-intro-form
			u3 (make-proof-in-imp-elim-form
			    (make-proof-in-avar-form u2right)
			    (make-proof-in-and-elim-right-form
			     (make-proof-in-avar-form u3)))))))))))
    ((all)
;                                  u3:all x A   x
;                                  --------------
;                           u2:~A          A
;                           ----------------
;                                      bot
;                                   -------- u3
;              u1:~~all x A         ~all x A
;              -----------------------------
;                             bot
;       |                     --- u2
;   ~~A -> A                  ~~A
;   -----------------------------
;                 A
;              -------
;              all x A
     (let* ((var (all-form-to-var formula))
	    (kernel (all-form-to-kernel formula))
	    (u1 (formula-to-new-avar
		 (make-negation-log (make-negation-log formula))))
	    (u2 (formula-to-new-avar (make-negation-log kernel)))
	    (u3 (formula-to-new-avar formula)))
       (mk-proof-in-intro-form
	u1 var (make-proof-in-imp-elim-form
		(proof-of-stab-log-at-aux kernel rename prename)
		(make-proof-in-imp-intro-form
		 u2 (make-proof-in-imp-elim-form
		     (make-proof-in-avar-form u1)
		     (make-proof-in-imp-intro-form
		      u3 (make-proof-in-imp-elim-form
			  (make-proof-in-avar-form u2)
			  (make-proof-in-all-elim-form
			   (make-proof-in-avar-form u3)
			   (make-term-in-var-form var))))))))))
    ((allnc)
;                                    u3:allnc x A   x
;                                    ----------------
;                             u2:~A          A
;                             ----------------
;                                        bot
;                                     ---------- u3
;              u1:~~allnc x A         ~allnc x A
;              -----------------------------
;                             bot
;       |                     --- u2
;   ~~A -> A                  ~~A
;   -----------------------------
;                 A
;              -------
;              allnc x A
     (let* ((var (allnc-form-to-var formula))
	    (kernel (allnc-form-to-kernel formula))
	    (u1 (formula-to-new-avar
		 (make-negation-log (make-negation-log formula))))
	    (u2 (formula-to-new-avar (make-negation-log kernel)))
	    (u3 (formula-to-new-avar formula)))
       (mk-proof-in-nc-intro-form
	u1 var (make-proof-in-imp-elim-form
		(proof-of-stab-log-at-aux kernel rename prename)
		(make-proof-in-imp-intro-form
		 u2 (make-proof-in-imp-elim-form
		     (make-proof-in-avar-form u1)
		     (make-proof-in-imp-intro-form
		      u3 (make-proof-in-imp-elim-form
			  (make-proof-in-avar-form u2)
			  (make-proof-in-allnc-elim-form
			   (make-proof-in-avar-form u3)
			   (make-term-in-var-form var))))))))))
    (else (myerror "proof-of-stab-log-at-aux" "formula expected" formula))))

(define (proof-of-efq-at formula) ;formula must be unfolded
  (let ((rename (make-rename empty-subst))
	(prename (make-prename empty-subst)))
    (proof-of-efq-at-aux formula rename prename)))

(define (proof-of-efq-at-aux formula rename prename)
  (case (tag formula)
    ((atom predicate)
     (cond
      ((equal? falsity formula)
;               u1:F
;             --------u1
;              F -> F
       (let ((u1 (formula-to-new-avar falsity)))
	 (make-proof-in-imp-intro-form
	  u1 (make-proof-in-avar-form u1))))
      ((equal? truth formula)
       (let ((u1 (formula-to-new-avar falsity)))
	 (make-proof-in-imp-intro-form
	  u1 (make-proof-in-aconst-form truth-aconst))))
      ((atom-form? formula)
       (let ((kernel (atom-form-to-kernel formula)))
	 (if (not (synt-total? kernel))
	     (myerror "proof-of-efq-at-aux" "total kernel expected" kernel))
	 (mk-proof-in-elim-form
	  (make-proof-in-aconst-form 
	   (all-formula-to-cases-aconst
	    (pf "all boole(F -> boole)")))
	  kernel
	  (make-proof-in-imp-intro-form
	   (formula-to-new-avar falsity)
	   (make-proof-in-aconst-form truth-aconst))
	  (let ((u1 (formula-to-new-avar falsity)))
	    (make-proof-in-imp-intro-form
	     u1 (make-proof-in-avar-form u1))))))
      (else
       (let* ((aconst (global-assumption-name-to-aconst "Efq"))
	      (efq-formula (aconst-to-uninst-formula aconst))
	      (pvars (formula-to-pvars efq-formula))
	      (pvar (if (pair? pvars) (car pvars)
			(myerror
			 "proof-to-efq-at" "efq-formula with pvars expected"
			 efq-formula)))
	      (cterm (make-cterm formula))
	      (psubst (make-subst-wrt pvar-cterm-equal? pvar cterm)))
	 (proof-substitute-aux
	  (make-proof-in-aconst-form aconst)
	  empty-subst empty-subst psubst empty-subst
	  rename prename
	  (make-arename empty-subst psubst rename prename))))))
    ((imp)
;              |
;            F -> B     u1:F
;          -----------------
;                    B
     (let* ((prem (imp-form-to-premise formula))
	    (concl (imp-form-to-conclusion formula))
	    (u1 (formula-to-new-avar falsity))
	    (u2 (formula-to-new-avar prem)))
       (mk-proof-in-intro-form
	u1 u2 (make-proof-in-imp-elim-form
	       (proof-of-efq-at-aux concl rename prename)
	       (make-proof-in-avar-form u1)))))
    ((impnc)
;              |
;            F -> B     u1:F
;          -----------------
;                    B
     (let* ((prem (impnc-form-to-premise formula))
	    (concl (impnc-form-to-conclusion formula))
	    (u1 (formula-to-new-avar falsity))
	    (u2 (formula-to-new-avar prem)))
       (make-proof-in-imp-intro-form
	u1 (make-proof-in-impnc-intro-form
	    u2 (make-proof-in-imp-elim-form
		(proof-of-efq-at-aux concl rename prename)
		(make-proof-in-avar-form u1))))))
    ((and)
;          |                              |
;        F -> A       u1:F              F -> B        u1:F
;        -------------------              ----------------
;                 A                               B
;                 ---------------------------------
;                               A & B
     (let* ((left-conjunct (and-form-to-left formula))
	    (right-conjunct (and-form-to-right formula))
	    (u1 (formula-to-new-avar falsity)))
       (make-proof-in-imp-intro-form
	u1 (make-proof-in-and-intro-form
	    (make-proof-in-imp-elim-form
	     (proof-of-efq-at-aux left-conjunct rename prename)
	     (make-proof-in-avar-form u1))
	    (make-proof-in-imp-elim-form
	     (proof-of-efq-at-aux right-conjunct rename prename)
	     (make-proof-in-avar-form u1))))))
    ((all)
     (let* ((var (all-form-to-var formula))
	    (kernel (all-form-to-kernel formula))
	    (u1 (formula-to-new-avar falsity)))
       (mk-proof-in-intro-form
	u1 var (make-proof-in-imp-elim-form
		(proof-of-efq-at-aux kernel rename prename)
		(make-proof-in-avar-form u1)))))
    ((allnc)
     (let* ((var (allnc-form-to-var formula))
	    (kernel (allnc-form-to-kernel formula))
	    (u1 (formula-to-new-avar falsity)))
       (mk-proof-in-intro-form
	u1 var (make-proof-in-imp-elim-form
		(proof-of-efq-at-aux kernel rename prename)
		(make-proof-in-avar-form u1)))))
    ((ex)
     (let* ((var (ex-form-to-var formula))
	    (kernel (ex-form-to-kernel formula))
	    (type (var-to-type var))
	    (inhab (type-to-canonical-inhabitant type))
	    (inst-kernel (formula-subst kernel var inhab))
	    (u1 (formula-to-new-avar falsity)))
       (make-proof-in-imp-intro-form
	u1 (make-proof-in-ex-intro-form
	    inhab formula
	    (make-proof-in-imp-elim-form
	     (proof-of-efq-at-aux inst-kernel rename prename)
	     (make-proof-in-avar-form u1))))))
    ((exnc)
     (let* ((var (exnc-form-to-var formula))
	    (kernel (exnc-form-to-kernel formula))
	    (type (var-to-type var))
	    (inhab (type-to-canonical-inhabitant type))
	    (inst-kernel (formula-subst kernel var inhab))
	    (u1 (formula-to-new-avar falsity)))
       (make-proof-in-imp-intro-form
	u1 (make-proof-in-exnc-intro-form
	    inhab formula
	    (make-proof-in-imp-elim-form
	     (proof-of-efq-at-aux inst-kernel rename prename)
	     (make-proof-in-avar-form u1))))))
    (else (myerror "proof-of-efq-at-aux" "formula expected" formula))))

(define (proof-of-efq-log-at formula) ;formula must be unfolded
  (let ((rename (make-rename empty-subst))
	(prename (make-prename empty-subst)))
    (proof-of-efq-log-at-aux formula rename prename)))

(define (proof-of-efq-log-at-aux formula rename prename)
  (case (tag formula)
    ((atom predicate ex exnc)
     (cond
      ((equal? falsity-log formula)
;               u1:bot
;             -----------u1
;              bot -> bot
       (let ((u1 (formula-to-new-avar falsity-log)))
	 (make-proof-in-imp-intro-form
	  u1 (make-proof-in-avar-form u1))))
      ((equal? truth formula)
       (let ((u1 (formula-to-new-avar falsity-log)))
	 (make-proof-in-imp-intro-form
	  u1 (make-proof-in-aconst-form truth-aconst))))
      (else
       (let* ((aconst (global-assumption-name-to-aconst "Efq-Log"))
	      (efq-log-formula (aconst-to-uninst-formula aconst))
	      (pvars (formula-to-pvars efq-log-formula))
	      (pvar (if (pair? pvars) (car (last-pair pvars))
			(myerror "proof-to-efq-log-at"
				 "efq-log-formula with pvars expected"
				 efq-log-formula)))
	      (cterm (make-cterm formula))
	      (psubst (make-subst-wrt pvar-cterm-equal? pvar cterm)))
	 (proof-substitute-aux
	  (make-proof-in-aconst-form aconst)
	  empty-subst empty-subst psubst empty-subst
	  rename prename
	  (make-arename empty-subst psubst rename prename))))))
    ((imp)
;              |
;          bot -> B     u1:bot
;          -------------------
;                    B
     (let* ((prem (imp-form-to-premise formula))
	    (concl (imp-form-to-conclusion formula))
	    (u1 (formula-to-new-avar falsity-log))
	    (u2 (formula-to-new-avar prem)))
       (mk-proof-in-intro-form
	u1 u2 (make-proof-in-imp-elim-form
	       (proof-of-efq-log-at-aux concl rename prename)
	       (make-proof-in-avar-form u1)))))
    ((impnc)
;              |
;          bot -> B     u1:bot
;          -------------------
;                    B
     (let* ((prem (impnc-form-to-premise formula))
	    (concl (impnc-form-to-conclusion formula))
	    (u1 (formula-to-new-avar falsity-log))
	    (u2 (formula-to-new-avar prem)))
       (make-proof-in-imp-intro-form
	u1 (make-proof-in-impnc-intro-form
	    u2 (make-proof-in-imp-elim-form
		(proof-of-efq-log-at-aux concl rename prename)
		(make-proof-in-avar-form u1))))))
    ((and)
;          |                              |
;        bot -> A     u1:bot              bot -> B    u1:bot
;        -------------------              ------------------
;                 A                               B
;                 ---------------------------------
;                               A & B
     (let* ((left-conjunct (and-form-to-left formula))
	    (right-conjunct (and-form-to-right formula))
	    (u1 (formula-to-new-avar falsity-log)))
       (make-proof-in-imp-intro-form
	u1 (make-proof-in-and-intro-form
	    (make-proof-in-imp-elim-form
	     (proof-of-efq-log-at-aux left-conjunct rename prename)
	     (make-proof-in-avar-form u1))
	    (make-proof-in-imp-elim-form
	     (proof-of-efq-log-at-aux right-conjunct rename prename)
	     (make-proof-in-avar-form u1))))))
    ((all)
     (let* ((var (all-form-to-var formula))
	    (kernel (all-form-to-kernel formula))
	    (u1 (formula-to-new-avar falsity-log)))
       (mk-proof-in-intro-form
	u1 var (make-proof-in-imp-elim-form
		(proof-of-efq-log-at-aux kernel rename prename)
		(make-proof-in-avar-form u1)))))
    ((allnc)
     (let* ((var (allnc-form-to-var formula))
	    (kernel (allnc-form-to-kernel formula))
	    (u1 (formula-to-new-avar falsity-log)))
       (mk-proof-in-nc-intro-form
	u1 var (make-proof-in-imp-elim-form
		(proof-of-efq-log-at-aux kernel rename prename)
		(make-proof-in-avar-form u1)))))
    (else (myerror "proof-of-efq-log-at-aux" "formula expected" formula))))

(define (formula-to-efq-proof formula) ;formula should be unfolded
  (case (tag formula)
    ((atom predicate) #f)
    ((imp)
     (let ((prem (imp-form-to-premise formula))
	   (concl (imp-form-to-conclusion formula)))
       (if (classical-formula=? prem falsity)
	   (proof-of-efq-at concl)
	   (let ((prev (formula-to-efq-proof concl)))
	     (if prev
		 (make-proof-in-imp-intro-form
		  (formula-to-new-avar prem) prev)
		 #f)))))
    ((impnc)
     (let ((prem (impnc-form-to-premise formula))
	   (concl (impnc-form-to-conclusion formula)))
       (if (classical-formula=? prem falsity)
	   (proof-of-efq-at concl)
	   (let ((prev (formula-to-efq-proof concl)))
	     (if prev
		 (make-proof-in-impnc-intro-form
		  (formula-to-new-avar prem) prev)
		 #f)))))
    ((and)
     (let* ((left (and-form-to-left formula))
	    (right (and-form-to-right formula))
	    (prev1 (formula-to-efq-proof left))
	    (prev2 (formula-to-efq-proof right)))
       (if (and prev1 prev2)
	   (make-proof-in-and-intro-form prev1 prev2)
	   #f)))
    ((all)
     (let* ((var (all-form-to-var formula))
	    (kernel (all-form-to-kernel formula))
	    (prev (formula-to-efq-proof kernel)))
       (if prev
	   (make-proof-in-all-intro-form var prev)
	   #f)))
    ((allnc)
     (let* ((var (allnc-form-to-var formula))
	    (kernel (allnc-form-to-kernel formula))
	    (prev (formula-to-efq-proof kernel)))
       (if prev
	   (make-proof-in-allnc-intro-form var prev)
	   #f)))
    ((ex)
     (let* ((var (ex-form-to-var formula))
	    (kernel (ex-form-to-kernel formula))
	    (prev (formula-to-efq-proof kernel)))
       (if prev
	   (make-proof-in-ex-intro-form var prev)
	   #f)))
    ((exnc)
     (let* ((var (exnc-form-to-var formula))
	    (kernel (exnc-form-to-kernel formula))
	    (prev (formula-to-efq-proof kernel)))
       (if prev
	   (make-proof-in-exnc-intro-form var prev)
	   #f)))
    ((exca excl)
     (myerror "formula-to-efq-proof" "unfolded formula exprected" formula))
    (else (myerror "formula-to-efq-proof" "formula expected" formula))))

(define (reduce-efq-and-stab proof)
  (case (tag proof)
    ((proof-in-avar-form) proof)
    ((proof-in-aconst-form)
     (let* ((aconst (proof-in-aconst-form-to-aconst proof))
	    (name (aconst-to-name aconst)))
       (cond ((string=? name "Stab")
	      (let* ((formula (unfold-formula (proof-to-formula proof)))
		     (vars-and-final-kernel
		      (allnc-form-to-vars-and-final-kernel formula))
		     (vars (car vars-and-final-kernel))
		     (kernel (cadr vars-and-final-kernel))
		     (concl (imp-form-to-conclusion kernel)))
		(apply mk-proof-in-nc-intro-form
		       (append vars (list (proof-of-stab-at concl))))))
	     ((string=? name "Efq")
	      (let* ((formula (unfold-formula (proof-to-formula proof)))
		     (vars-and-final-kernel
		      (allnc-form-to-vars-and-final-kernel formula))
		     (vars (car vars-and-final-kernel))
		     (kernel (cadr vars-and-final-kernel))
		     (concl (imp-form-to-conclusion kernel)))
		(apply mk-proof-in-nc-intro-form
		       (append vars (list (proof-of-efq-at concl))))))
	     ((string=? name "Stab-Log")
	      (let* ((formula (unfold-formula (proof-to-formula proof)))
		     (vars-and-final-kernel
		      (allnc-form-to-vars-and-final-kernel formula))
		     (vars (car vars-and-final-kernel))
		     (kernel (cadr vars-and-final-kernel))
		     (concl (imp-form-to-conclusion kernel)))
		(apply mk-proof-in-nc-intro-form
		       (append vars (list (proof-of-stab-log-at concl))))))
	     ((string=? name "Efq-Log")
	      (let* ((formula (unfold-formula (proof-to-formula proof)))
		     (vars-and-final-kernel
		      (allnc-form-to-vars-and-final-kernel formula))
		     (vars (car vars-and-final-kernel))
		     (kernel (cadr vars-and-final-kernel))
		     (concl (imp-form-to-conclusion kernel)))
		(apply mk-proof-in-nc-intro-form
		       (append vars (list (proof-of-efq-log-at concl))))))
	     (else 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)))
       (make-proof-in-imp-elim-form
	(reduce-efq-and-stab op)
	(reduce-efq-and-stab arg))))
    ((proof-in-imp-intro-form)
     (let ((avar (proof-in-imp-intro-form-to-avar proof))
	   (kernel (proof-in-imp-intro-form-to-kernel proof)))
       (make-proof-in-imp-intro-form
	avar (reduce-efq-and-stab kernel))))
    ((proof-in-impnc-elim-form)
     (let ((op (proof-in-impnc-elim-form-to-op proof))
	   (arg (proof-in-impnc-elim-form-to-arg proof)))
       (make-proof-in-impnc-elim-form
	(reduce-efq-and-stab op)
	(reduce-efq-and-stab arg))))
    ((proof-in-impnc-intro-form)
     (let ((avar (proof-in-impnc-intro-form-to-avar proof))
	   (kernel (proof-in-impnc-intro-form-to-kernel proof)))
       (make-proof-in-impnc-intro-form
	avar (reduce-efq-and-stab kernel))))
    ((proof-in-and-intro-form)
     (let ((left (proof-in-and-intro-form-to-left proof))
	   (right (proof-in-and-intro-form-to-right proof)))
       (make-proof-in-and-intro-form
	(reduce-efq-and-stab left)
	(reduce-efq-and-stab right))))
    ((proof-in-and-elim-left-form)
     (let ((kernel (proof-in-and-elim-left-form-to-kernel proof)))
       (make-proof-in-and-elim-left-form ;inserted M.S.
	(reduce-efq-and-stab kernel))))
    ((proof-in-and-elim-right-form)
     (let ((kernel (proof-in-and-elim-right-form-to-kernel proof)))
       (make-proof-in-and-elim-right-form ;inserted M.S.
	(reduce-efq-and-stab kernel))))
    ((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-proof-in-all-intro-form
	var (reduce-efq-and-stab kernel))))
    ((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-proof-in-all-elim-form (reduce-efq-and-stab op) 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)))
       (make-proof-in-allnc-intro-form
	var (reduce-efq-and-stab kernel))))
    ((proof-in-allnc-elim-form)
     (let ((op (proof-in-allnc-elim-form-to-op proof))
	   (arg (proof-in-allnc-elim-form-to-arg proof)))
       (make-proof-in-allnc-elim-form (reduce-efq-and-stab op) arg)))
    (else (myerror "reduce-efq-and-stab" "proof tag expected"
		   (tag proof)))))

; We can transform a proof involving classical existential quantifiers
; in another one without, i.e., in minimal logic.  The Exc-Intro and
; Exc-Elim theorems are replaced by their proofs, using expand-theorems.

(define (rm-exc proof)
  (let ((name-test?
	 (lambda (string)
	   (or
	    (and (<= (string-length "ExcaIntro") (string-length string))
		 (string=? (substring string 0 (string-length "ExcaIntro"))
			   "ExcaIntro"))
	    (and (<= (string-length "ExclIntro") (string-length string))
		 (string=? (substring string 0 (string-length "ExclIntro"))
			   "ExclIntro"))
	    (and (<= (string-length "ExcaElim") (string-length string))
		 (string=? (substring string 0 (string-length "ExcaElim"))
			   "ExcaElim"))
	    (and (<= (string-length "ExclElim") (string-length string))
		 (string=? (substring string 0 (string-length "ExclElim"))
			   "ExclElim"))))))
    (expand-theorems proof name-test?)))

; We now define the Goedel-Gentzen translation of formulas.  We do not
; consider $\exc$, because it is not needed for our purposes of program
; extraction.

(define (formula-to-goedel-gentzen-translation formula)
  (case (tag formula)
    ((atom predicate)
     (if (formula=? falsity-log formula)
	 falsity-log
	 (mk-neg-log (mk-neg-log formula))))
    ((imp)
     (let* ((prem (imp-form-to-premise formula))
	    (concl (imp-form-to-conclusion formula))
	    (prev1 (formula-to-goedel-gentzen-translation prem))
	    (prev2 (formula-to-goedel-gentzen-translation concl)))
       (make-imp prev1 prev2)))
    ((impnc)
     (let* ((prem (impnc-form-to-premise formula))
	    (concl (impnc-form-to-conclusion formula))
	    (prev1 (formula-to-goedel-gentzen-translation prem))
	    (prev2 (formula-to-goedel-gentzen-translation concl)))
       (make-impnc prev1 prev2)))
    ((and)
     (let* ((left (and-form-to-left formula))
	    (right (and-form-to-right formula))
	    (prev1 (formula-to-goedel-gentzen-translation left))
	    (prev2 (formula-to-goedel-gentzen-translation right)))
       (make-and prev1 prev2)))
    ((all)
     (let* ((var (all-form-to-var formula))
	    (kernel (all-form-to-kernel formula))
	    (prev (formula-to-goedel-gentzen-translation kernel)))
       (make-all var prev)))
    ((allnc)
     (let* ((var (allnc-form-to-var formula))
	    (kernel (allnc-form-to-kernel formula))
	    (prev (formula-to-goedel-gentzen-translation kernel)))
       (make-allnc var prev)))
    (else
     (myerror "formula-to-goedel-gentzen-translation" "unexpected formula"
	      formula))))

; We introduce a further observation (due to Leivant; see Troelstra and
; van Dalen \cite[Ch.2, Sec.3]{TroelstravanDalen88}) which will be
; useful for program extraction from classical proofs.  There it will be
; necessary to actually transform a given classical derivation $\vdash_c
; A$ into a minimal logic derivation $\vdash A^g$.  In particular, for
; every assumption constant $C$ used in the given derivation we have to
; provide a derivation of $C^g$.  Now for some formulas $S$ -- the
; so-called spreading formulas -- this is immediate, for we can derive
; $S \to S^g$, and hence can use the original assumption constant.

; In order to obtain a derivation of $C^g$ for $C$ an assumption
; constant it suffices to know that its uninstantiated formula $S$ is
; spreading, for then we generally have $\vdash S[\vec{A}^g] \to
; S[\vec{A}]^g$ and hence can use the same assumption constant with a
; different substitution.

; We define spreading, wiping and isolating formulas inductively.

(define (spreading-formula? formula)
  (case (tag formula)
    ((atom predicate) #t)
    ((imp)
     (let* ((prem (imp-form-to-premise formula))
	    (concl (imp-form-to-conclusion formula)))
       (and (isolating-formula? prem)
	    (spreading-formula? concl))))
    ((impnc)
     (let* ((prem (impnc-form-to-premise formula))
	    (concl (impnc-form-to-conclusion formula)))
       (and (isolating-formula? prem)
	    (spreading-formula? concl))))
    ((and)
     (let* ((left (and-form-to-left formula))
	    (right (and-form-to-right formula)))
       (and (spreading-formula? left)
	    (spreading-formula? right))))
    ((all)
     (let ((kernel (all-form-to-kernel formula)))
       (spreading-formula? kernel)))
    ((allnc)
     (let ((kernel (allnc-form-to-kernel formula)))
       (spreading-formula? kernel)))
    (else (myerror "spreading-formula?" "unexpected formula" formula))))

(define (wiping-formula? formula)
  (case (tag formula)
    ((atom predicate)
     (or (formula=? falsity-log formula)
	 (and (predicate-form? formula)
	      (pvar? (predicate-form-to-predicate formula)))))
    ((imp)
     (let* ((prem (imp-form-to-premise formula))
	    (concl (imp-form-to-conclusion formula)))
       (and (spreading-formula? prem)
	    (wiping-formula? concl))))
    ((impnc)
     (let* ((prem (impnc-form-to-premise formula))
	    (concl (impnc-form-to-conclusion formula)))
       (and (spreading-formula? prem)
	    (wiping-formula? concl))))
    ((and)
     (let* ((left (and-form-to-left formula))
	    (right (and-form-to-right formula)))
       (and (wiping-formula? left)
	    (wiping-formula? right))))
    ((all)
     (let ((kernel (all-form-to-kernel formula)))
       (wiping-formula? kernel)))
    ((allnc)
     (let ((kernel (allnc-form-to-kernel formula)))
       (wiping-formula? kernel)))
    (else (myerror "wiping-formula?" "unexpected formula" formula))))

(define (isolating-formula? formula)
  (or (prime-form? formula)
      (wiping-formula? formula)
      (and (and-form? formula)
	   (isolating-formula? (and-form-to-left formula))
	   (isolating-formula? (and-form-to-right formula)))))

; For a spreading formula S we can derive S[A^g] -> S[A]^g.
; opt-psubst consists of some X -> A; the other pvars in S are substituted
; automatically by their Goedel-Gentzen translations.

(define (spreading-formula-to-proof formula . opt-psubst)
  (let* ((orig-psubst (if (null? opt-psubst) empty-subst (car opt-psubst)))
	 (orig-psubst-gg
	  (map (lambda (item)
		 (let* ((pvar (car item))
			(cterm (cadr item))
			(vars (cterm-to-vars cterm))
			(formula (cterm-to-formula cterm))
			(formula-gg
			 (formula-to-goedel-gentzen-translation formula)))
		   (list pvar (apply make-cterm
				     (append vars (list formula-gg))))))
	       orig-psubst))
	 (pvars (remove (predicate-form-to-predicate falsity-log)
			(formula-to-pvars formula)))
	 (extra-pvars (set-minus pvars (map car orig-psubst)))
	 (extra-psubst-gg
	  (map (lambda (pvar)
		 (let* ((arity (pvar-to-arity pvar))
			(types (arity-to-types arity))
			(vars (map type-to-new-partial-var types))
			(varterms (map make-term-in-var-form vars))
			(formula (apply make-predicate-formula
					(cons pvar varterms)))
			(formula-gg (make-negation-log
				     (make-negation-log formula))))
		   (list pvar
			 (apply make-cterm
				(append vars (list formula-gg))))))
	       extra-pvars))
	 (psubst-gg (append orig-psubst-gg extra-psubst-gg)))
    (spreading-formula-to-proof-aux formula orig-psubst psubst-gg)))

; Now use psubst-gg (X -> A^g, Y -> ~~Y) for all (orig) formulas.

(define (spreading-formula-to-proof-aux formula psubst psubst-gg)
  (case (tag formula)
    ((atom predicate)
     (if (and (predicate-form? formula)
	      (pvar? (predicate-form-to-predicate formula)))
	 (let* ((subst-formula-gg (formula-substitute formula psubst-gg))
		(u (formula-to-new-avar subst-formula-gg)))
	   (make-proof-in-imp-intro-form 
	    u (make-proof-in-avar-form u)))
	 (let ((u (formula-to-new-avar formula))
	       (v (formula-to-new-avar (mk-neg-log formula))))
	   (mk-proof-in-intro-form
	    u v (make-proof-in-imp-elim-form
		 (make-proof-in-avar-form v)
		 (make-proof-in-avar-form u))))))
    ((imp)
     (let* ((subst-formula (formula-substitute formula psubst)) ;I[A] ->S[A]
	    (gg-subst-formula ;I[A^g] ->S[A^g]
	     (formula-substitute formula psubst-gg))
	    (prem (imp-form-to-premise formula))
	    (subst-prem (imp-form-to-premise subst-formula))
	    (subst-prem-gg ;I[A]^g
	     (formula-to-goedel-gentzen-translation subst-prem))
	    (gg-subst-prem ;I[A^g]
	     (imp-form-to-premise gg-subst-formula))
	    (concl (imp-form-to-conclusion formula))
	    (subst-concl (imp-form-to-conclusion subst-formula))
	    (subst-concl-gg ;S[A]^g
	     (formula-to-goedel-gentzen-translation subst-concl))
	    (gg-subst-concl ;S[A^g]
	     (imp-form-to-conclusion gg-subst-formula))
	    (u (formula-to-new-avar gg-subst-formula))
	    (v (formula-to-new-avar subst-prem-gg))
	    (w1 (formula-to-new-avar (mk-neg-log subst-concl-gg)))
	    (w2 (formula-to-new-avar gg-subst-prem)))
       (mk-proof-in-intro-form
	u v (make-proof-in-imp-elim-form
	     (proof-of-stab-log-at subst-concl-gg)
	     (make-proof-in-imp-intro-form
	      w1 (mk-proof-in-elim-form
		  (isolating-formula-to-proof-aux prem psubst psubst-gg)
		  (make-proof-in-avar-form v)
		  (make-proof-in-imp-intro-form
		   w2 (make-proof-in-imp-elim-form
		       (make-proof-in-avar-form w1)
		       (make-proof-in-imp-elim-form
			(spreading-formula-to-proof-aux
			 concl psubst psubst-gg)
			(make-proof-in-imp-elim-form
			 (make-proof-in-avar-form u)
			 (make-proof-in-avar-form w2)))))))))))
    ((impnc)
     (let* ((subst-formula (formula-substitute formula psubst)) ;I[A] ->S[A]
	    (gg-subst-formula ;I[A^g] ->S[A^g]
	     (formula-substitute formula psubst-gg))
	    (prem (impnc-form-to-premise formula))
	    (subst-prem (impnc-form-to-premise subst-formula))
	    (subst-prem-gg ;I[A]^g
	     (formula-to-goedel-gentzen-translation subst-prem))
	    (gg-subst-prem ;I[A^g]
	     (impnc-form-to-premise gg-subst-formula))
	    (concl (impnc-form-to-conclusion formula))
	    (subst-concl (impnc-form-to-conclusion subst-formula))
	    (subst-concl-gg ;S[A]^g
	     (formula-to-goedel-gentzen-translation subst-concl))
	    (gg-subst-concl ;S[A^g]
	     (impnc-form-to-conclusion gg-subst-formula))
	    (u (formula-to-new-avar gg-subst-formula))
	    (v (formula-to-new-avar subst-prem-gg))
	    (w1 (formula-to-new-avar (mk-neg-log subst-concl-gg)))
	    (w2 (formula-to-new-avar gg-subst-prem)))
       (make-proof-in-imp-intro-form
	u (make-proof-in-impnc-intro-form
	   v (make-proof-in-imp-elim-form
	      (proof-of-stab-log-at subst-concl-gg)
	      (make-proof-in-imp-intro-form
	       w1 (mk-proof-in-elim-form
		   (isolating-formula-to-proof-aux prem psubst psubst-gg)
		   (make-proof-in-avar-form v)
		   (make-proof-in-imp-intro-form
		    w2 (make-proof-in-imp-elim-form
			(make-proof-in-avar-form w1)
			(make-proof-in-imp-elim-form
			 (spreading-formula-to-proof-aux
			  concl psubst psubst-gg)
			 (make-proof-in-impnc-elim-form
			  (make-proof-in-avar-form u)
			  (make-proof-in-avar-form w2))))))))))))
     ((and)
      (let* ((u (formula-to-new-avar formula))
	     (left (and-form-to-left formula))
	     (right (and-form-to-right formula)))
	(mk-proof-in-intro-form
	 u (make-proof-in-and-intro-form
	    (make-proof-in-imp-elim-form
	     (spreading-formula-to-proof-aux left psubst psubst-gg)
	     (make-proof-in-and-elim-left-form
	      (make-proof-in-avar-form u)))
	    (make-proof-in-imp-elim-form
	     (spreading-formula-to-proof-aux right psubst psubst-gg)
	     (make-proof-in-and-elim-right-form
	      (make-proof-in-avar-form u)))))))
     ((all)
      (let* ((gg-subst-formula ;(all x S)[A^g]
	      (formula-substitute formula psubst-gg))
	     (u (formula-to-new-avar gg-subst-formula))
	     (var (all-form-to-var formula))
	     (kernel (all-form-to-kernel formula)))
	(make-proof-in-imp-intro-form
	 u (make-proof-in-all-intro-form
	    var (make-proof-in-imp-elim-form
		 (spreading-formula-to-proof-aux kernel psubst psubst-gg)
		 (make-proof-in-all-elim-form
		  (make-proof-in-avar-form u)
		  (make-term-in-var-form var)))))))
     ((allnc)
      (let* ((gg-subst-formula ;(allnc x S)[A^g]
	      (formula-substitute formula psubst-gg))
	     (u (formula-to-new-avar gg-subst-formula))
	     (var (allnc-form-to-var formula))
	     (kernel (allnc-form-to-kernel formula)))
	(make-proof-in-imp-intro-form
	 u (make-proof-in-allnc-intro-form
	    var (make-proof-in-imp-elim-form
		 (spreading-formula-to-proof-aux kernel psubst psubst-gg)
		 (make-proof-in-allnc-elim-form
		  (make-proof-in-avar-form u)
		  (make-term-in-var-form var)))))))
     (else (myerror "spreading-formula-to-proof-aux" "unexpected formula"
		    formula))))

(define (wiping-formula-to-proof formula . opt-psubst)
  (let* ((orig-psubst (if (null? opt-psubst) empty-subst (car opt-psubst)))
	 (orig-psubst-gg
	  (map (lambda (item)
		 (let* ((pvar (car item))
			(cterm (cadr item))
			(vars (cterm-to-vars cterm))
			(formula (cterm-to-formula cterm))
			(formula-gg
			 (formula-to-goedel-gentzen-translation formula)))
		   (list pvar (apply make-cterm
				     (append vars (list formula-gg))))))
	       orig-psubst))
	 (pvars (remove (predicate-form-to-predicate falsity-log)
			(formula-to-pvars formula)))
	 (extra-pvars (set-minus pvars (map car orig-psubst)))
	 (extra-psubst-gg
	  (map (lambda (pvar)
		 (let* ((arity (pvar-to-arity pvar))
			(types (arity-to-types arity))
			(vars (map type-to-new-partial-var types))
			(varterms (map make-term-in-var-form vars))
			(formula (apply make-predicate-formula
					(cons pvar varterms)))
			(formula-gg (make-negation-log
				     (make-negation-log formula))))
		   (list pvar
			 (apply make-cterm
				(append vars (list formula-gg))))))
	       extra-pvars))
	 (psubst-gg (append orig-psubst-gg extra-psubst-gg)))
    (wiping-formula-to-proof-aux formula orig-psubst psubst-gg)))

(define (wiping-formula-to-proof-aux formula psubst psubst-gg)
  (case (tag formula)
    ((atom predicate)
     (if (and (predicate-form? formula)
	      (pvar? (predicate-form-to-predicate formula)))
	 (let* ((gg-subst-formula (formula-substitute formula psubst-gg))
		(u (formula-to-new-avar gg-subst-formula)))
	   (make-proof-in-imp-intro-form 
	    u (make-proof-in-avar-form u)))
	 (myerror "wiping-formula-to-proof-aux" "pvar or falsity-log expected"
		  formula)))
    ((imp)
     (let* ((subst-formula ;S[A] -> W[A]
	     (formula-substitute formula psubst))
	    (prem (imp-form-to-premise formula))
	    (subst-prem (imp-form-to-premise subst-formula))
	    (subst-prem-gg ;S[A]^g
	     (formula-to-goedel-gentzen-translation subst-prem))
	    (gg-subst-prem ;S[A^g]
	     (formula-substitute prem psubst-gg))
	    (concl (imp-form-to-conclusion formula))
	    (subst-concl (imp-form-to-conclusion subst-formula))
	    (subst-concl-gg ;W[A]^g
	     (formula-to-goedel-gentzen-translation subst-concl))
	    (u (formula-to-new-avar (make-imp subst-prem-gg subst-concl-gg)))
	    (v (formula-to-new-avar gg-subst-prem)))
       (mk-proof-in-intro-form
	u v (make-proof-in-imp-elim-form
	     (wiping-formula-to-proof-aux concl psubst psubst-gg)
	     (make-proof-in-imp-elim-form
	      (make-proof-in-avar-form u)
	      (make-proof-in-imp-elim-form
	       (spreading-formula-to-proof-aux prem psubst psubst-gg)
	       (make-proof-in-avar-form v)))))))
    ((impnc)
     (let* ((subst-formula ;S[A] -> W[A]
	     (formula-substitute formula psubst))
	    (prem (impnc-form-to-premise formula))
	    (subst-prem (impnc-form-to-premise subst-formula))
	    (subst-prem-gg ;S[A]^g
	     (formula-to-goedel-gentzen-translation subst-prem))
	    (gg-subst-prem ;S[A^g]
	     (formula-substitute prem psubst-gg))
	    (concl (impnc-form-to-conclusion formula))
	    (subst-concl (impnc-form-to-conclusion subst-formula))
	    (subst-concl-gg ;W[A]^g
	     (formula-to-goedel-gentzen-translation subst-concl))
	    (u (formula-to-new-avar (make-impnc subst-prem-gg subst-concl-gg)))
	    (v (formula-to-new-avar gg-subst-prem)))
       (make-proof-in-imp-intro-form
	u (make-proof-in-impnc-intro-form
	   v (make-proof-in-imp-elim-form
	      (wiping-formula-to-proof-aux concl psubst psubst-gg)
	      (make-proof-in-impnc-elim-form
	       (make-proof-in-avar-form u)
	       (make-proof-in-imp-elim-form
		(spreading-formula-to-proof-aux prem psubst psubst-gg)
		(make-proof-in-avar-form v))))))))
    ((and)
     (let* ((gg-subst-formula ;(W1 & W2)^g
	     (formula-substitute formula psubst-gg))
	    (u (formula-to-new-avar gg-subst-formula))
	    (left (and-form-to-left formula))
	    (right (and-form-to-right formula)))
       (mk-proof-in-intro-form
	u (make-proof-in-and-intro-form
	   (make-proof-in-imp-elim-form
	    (wiping-formula-to-proof-aux left psubst psubst-gg)
	    (make-proof-in-and-elim-left-form
	     (make-proof-in-avar-form u)))
	   (make-proof-in-imp-elim-form
	    (wiping-formula-to-proof-aux right psubst psubst-gg)
	    (make-proof-in-and-elim-right-form
	     (make-proof-in-avar-form u)))))))
    ((all)
     (let* ((var (all-form-to-var formula))
	    (kernel (all-form-to-kernel formula))
	    (subst-kernel (formula-substitute kernel psubst))
	    (subst-kernel-gg ;W[A]^g
	     (formula-to-goedel-gentzen-translation subst-kernel))
	    (u (formula-to-new-avar (make-all var subst-kernel-gg))))
       (make-proof-in-imp-intro-form
	u (make-proof-in-all-intro-form
	   var (make-proof-in-imp-elim-form
		(wiping-formula-to-proof-aux kernel psubst psubst-gg)
		(make-proof-in-all-elim-form
		 (make-proof-in-avar-form u)
		 (make-term-in-var-form var)))))))
    ((allnc)
     (let* ((var (allnc-form-to-var formula))
	    (kernel (allnc-form-to-kernel formula))
	    (subst-kernel (formula-substitute kernel psubst))
	    (subst-kernel-gg ;W[A]^g
	     (formula-to-goedel-gentzen-translation subst-kernel))
	    (u (formula-to-new-avar (make-allnc var subst-kernel-gg))))
       (make-proof-in-imp-intro-form
	u (make-proof-in-allnc-intro-form
	   var (make-proof-in-imp-elim-form
		(wiping-formula-to-proof-aux kernel psubst psubst-gg)
		(make-proof-in-allnc-elim-form
		 (make-proof-in-avar-form u)
		 (make-term-in-var-form var)))))))
    (else (myerror "wiping-formula-to-proof-aux" "unexpected formula"
		   formula))))

(define (isolating-formula-to-proof formula . opt-psubst)
  (let* ((orig-psubst (if (null? opt-psubst) empty-subst (car opt-psubst)))
	 (orig-psubst-gg
	  (map (lambda (item)
		 (let* ((pvar (car item))
			(cterm (cadr item))
			(vars (cterm-to-vars cterm))
			(formula (cterm-to-formula cterm))
			(formula-gg
			 (formula-to-goedel-gentzen-translation formula)))
		   (list pvar (apply make-cterm
				     (append vars (list formula-gg))))))
	       orig-psubst))
	 (pvars (remove (predicate-form-to-predicate falsity-log)
			(formula-to-pvars formula)))
	 (extra-pvars (set-minus pvars (map car orig-psubst)))
	 (extra-psubst-gg
	  (map (lambda (pvar)
		 (let* ((arity (pvar-to-arity pvar))
			(types (arity-to-types arity))
			(vars (map type-to-new-partial-var types))
			(varterms (map make-term-in-var-form vars))
			(formula (apply make-predicate-formula
					(cons pvar varterms)))
			(formula-gg (make-negation-log
				     (make-negation-log formula))))
		   (list pvar
			 (apply make-cterm
				(append vars (list formula-gg))))))
	       extra-pvars))
	 (psubst-gg (append orig-psubst-gg extra-psubst-gg)))
    (isolating-formula-to-proof-aux formula orig-psubst psubst-gg)))

(define (isolating-formula-to-proof-aux formula psubst psubst-gg)
  (cond
   ((wiping-formula? formula)
    (let* ((subst-formula (formula-substitute formula psubst))
	   (subst-formula-gg ;W[A]^g
	    (formula-to-goedel-gentzen-translation subst-formula))
	   (gg-subst-formula ;W[A^g]
	    (formula-substitute formula psubst-gg))
	   (u (formula-to-new-avar subst-formula-gg))
	   (v (formula-to-new-avar (mk-neg-log gg-subst-formula))))
      (mk-proof-in-intro-form
       u v (make-proof-in-imp-elim-form
	    (make-proof-in-avar-form v)
	    (make-proof-in-imp-elim-form
	     (wiping-formula-to-proof-aux formula psubst psubst-gg)
	     (make-proof-in-avar-form u))))))
   ((prime-form? formula)
    (let ((u (formula-to-new-avar (mk-neg-log (mk-neg-log formula)))))
      (make-proof-in-imp-intro-form
       u (make-proof-in-avar-form u))))
   ((and-form? formula)
    (let* ((subst-formula (formula-substitute formula psubst))
	   (subst-formula-gg ;(I1 & I2)[A]^g
	    (formula-to-goedel-gentzen-translation subst-formula))
	   (u (formula-to-new-avar subst-formula-gg))
	   (left (and-form-to-left formula))
	   (right (and-form-to-right formula))
	   (v (formula-to-new-avar (make-negation-log formula)))
	   (w1 (formula-to-new-avar left))
	   (w2 (formula-to-new-avar right)))
      (mk-proof-in-intro-form
       u v (mk-proof-in-elim-form
	    (isolating-formula-to-proof-aux right psubst psubst-gg)
	    (make-proof-in-and-elim-right-form
	     (make-proof-in-avar-form u))
	    (make-proof-in-imp-intro-form
	     w2 (mk-proof-in-elim-form
		 (isolating-formula-to-proof-aux left psubst psubst-gg)
		 (make-proof-in-and-elim-left-form
		  (make-proof-in-avar-form u))
		 (make-proof-in-imp-intro-form
		  w1 (make-proof-in-imp-elim-form
		      (make-proof-in-avar-form v)
		      (make-proof-in-and-intro-form
		       (make-proof-in-avar-form w1)
		       (make-proof-in-avar-form w2))))))))))
   (else (myerror "isolating-formula-to-proof-aux" "unexpected formula"
		  formula))))

; Now we can define the Goedel-Gentzen translation.

(define (proof-to-goedel-gentzen-translation proof)
  (let ((avar-to-goedel-gentzen-avar
	 (let ((assoc-list '()))
	   (lambda (avar)
	     (let ((info (assoc-wrt avar=? avar assoc-list)))
	       (if info
		   (cadr info)
		   (let ((new-avar (formula-to-new-avar
				    (formula-to-goedel-gentzen-translation
				     (avar-to-formula avar)))))
		     (set! assoc-list (cons (list avar new-avar) assoc-list))
		     new-avar)))))))
    (proof-to-goedel-gentzen-translation-aux
     proof avar-to-goedel-gentzen-avar)))

(define (proof-to-goedel-gentzen-translation-aux proof
						 avar-to-goedel-gentzen-avar)
  (case (tag proof)
    ((proof-in-avar-form)
     (let ((avar (proof-in-avar-form-to-avar proof)))
       (make-proof-in-avar-form
	(avar-to-goedel-gentzen-avar avar))))
    ((proof-in-aconst-form)
     (let* ((aconst (proof-in-aconst-form-to-aconst proof))
	    (name (aconst-to-name aconst))
	    (kind (aconst-to-kind aconst))
	    (uninst-formula (aconst-to-uninst-formula aconst))
	    (tpinst (aconst-to-tpinst aconst))
	    (repro-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)))))
	    (rename (make-rename tsubst))
	    (prename (make-prename tsubst))
	    (typeinst-formula
	     (formula-substitute-aux
	      uninst-formula tsubst empty-subst empty-subst rename prename))
	    (psubst (map (lambda (x) (list (prename (car x)) (cadr x)))
			 pinst))
	    (inst-formula (formula-substitute typeinst-formula psubst))
	    (free (formula-to-free inst-formula)))
       (cond
	((spreading-formula? inst-formula)
	 (apply
	  mk-proof-in-nc-intro-form
	  (append
	   free
	   (list (make-proof-in-imp-elim-form
		  (spreading-formula-to-proof inst-formula)
		  (apply mk-proof-in-elim-form
			 (cons proof (map make-term-in-var-form free))))))))
	((spreading-formula? uninst-formula)
	 (let* ((pvars (remove (predicate-form-to-predicate falsity-log)
			       (formula-to-pvars uninst-formula)))
		(extra-pvars (set-minus pvars (map car pinst)))
		(extra-psubst-gg
		 (map (lambda (pvar)
			(let* ((arity (pvar-to-arity pvar))
			       (types (arity-to-types arity))
			       (vars (map type-to-new-partial-var types))
			       (varterms (map make-term-in-var-form vars))
			       (formula (apply make-predicate-formula
					       (cons pvar varterms)))
			       (formula-gg (make-negation-log
					    (make-negation-log formula))))
			  (list pvar
				(apply make-cterm
				       (append vars (list formula-gg))))))
		      extra-pvars))
		(original-pinst-gg
		 (map (lambda (item)
			(let* ((pvar (car item))
			       (cterm (cadr item))
			       (vars (cterm-to-vars cterm))
			       (formula (cterm-to-formula cterm))
			       (formula-gg
				(formula-to-goedel-gentzen-translation
				 formula)))
			  (list pvar (apply make-cterm
					    (append vars (list formula-gg))))))
		      pinst))
		(tpinst-gg (append tsubst original-pinst-gg extra-psubst-gg))
		(subst-aconst
		 (apply make-aconst
			(append (list name kind uninst-formula tpinst-gg)
				repro-formulas))))
	   (apply
	    mk-proof-in-nc-intro-form
	    (append
	     free
	     (list (make-proof-in-imp-elim-form
		    (spreading-formula-to-proof typeinst-formula psubst)
		    (apply mk-proof-in-elim-form
			   (cons (make-proof-in-aconst-form subst-aconst)
				 (map make-term-in-var-form free)))))))))
	((eq? 'theorem kind)
	 (proof-to-goedel-gentzen-translation-aux
	  (theorem-name-to-proof name) avar-to-goedel-gentzen-avar))
	(else (myerror "proof-to-goedel-gentzen-translation-aux"
		       "unexpected aconst of kind" kind "with formula"
		       formula)))))
    ((proof-in-imp-intro-form)
     (let* ((avar (proof-in-imp-intro-form-to-avar proof))
	    (u (avar-to-goedel-gentzen-avar avar))
	    (kernel (proof-in-imp-intro-form-to-kernel proof)))
       (make-proof-in-imp-intro-form
	u (proof-to-goedel-gentzen-translation-aux
	   kernel avar-to-goedel-gentzen-avar))))
    ((proof-in-imp-elim-form)
     (let* ((op (proof-in-imp-elim-form-to-op proof))
	    (arg (proof-in-imp-elim-form-to-arg proof))
	    (prev-op (proof-to-goedel-gentzen-translation-aux
		      op avar-to-goedel-gentzen-avar))
	    (prev-arg (proof-to-goedel-gentzen-translation-aux
		       arg avar-to-goedel-gentzen-avar)))
       (make-proof-in-imp-elim-form prev-op prev-arg)))
    ((proof-in-impnc-intro-form)
     (let* ((avar (proof-in-impnc-intro-form-to-avar proof))
	    (u (avar-to-goedel-gentzen-avar avar))
	    (kernel (proof-in-impnc-intro-form-to-kernel proof)))
       (make-proof-in-impnc-intro-form
	u (proof-to-goedel-gentzen-translation-aux
	   kernel avar-to-goedel-gentzen-avar))))
    ((proof-in-impnc-elim-form)
     (let* ((op (proof-in-impnc-elim-form-to-op proof))
	    (arg (proof-in-impnc-elim-form-to-arg proof))
	    (prev-op (proof-to-goedel-gentzen-translation-aux
		      op avar-to-goedel-gentzen-avar))
	    (prev-arg (proof-to-goedel-gentzen-translation-aux
		       arg avar-to-goedel-gentzen-avar)))
       (make-proof-in-impnc-elim-form prev-op prev-arg)))
    ((proof-in-and-intro-form)
     (make-proof-in-and-intro-form
      (proof-to-goedel-gentzen-translation-aux 
       (proof-in-and-intro-form-to-left proof)
       avar-to-goedel-gentzen-avar)
      (proof-to-goedel-gentzen-translation-aux 
       (proof-in-and-intro-form-to-right proof)
       avar-to-goedel-gentzen-avar)))
    ((proof-in-and-elim-left-form)
     (make-proof-in-and-elim-left-form
      (proof-to-goedel-gentzen-translation-aux 
       (proof-in-and-elim-left-form-to-kernel proof)
       avar-to-goedel-gentzen-avar)))
    ((proof-in-and-elim-right-form)
     (make-proof-in-and-elim-right-form
      (proof-to-goedel-gentzen-translation-aux 
       (proof-in-and-elim-right-form-to-kernel proof)
       avar-to-goedel-gentzen-avar)))
    ((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-proof-in-all-intro-form
	var (proof-to-goedel-gentzen-translation-aux
	     kernel avar-to-goedel-gentzen-avar))))
    ((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-proof-in-all-elim-form
	(proof-to-goedel-gentzen-translation-aux
	 op avar-to-goedel-gentzen-avar)
	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)))
       (make-proof-in-allnc-intro-form
	var (proof-to-goedel-gentzen-translation-aux
	     kernel avar-to-goedel-gentzen-avar))))
    ((proof-in-allnc-elim-form)
     (let ((op (proof-in-allnc-elim-form-to-op proof))
	   (arg (proof-in-allnc-elim-form-to-arg proof)))
       (make-proof-in-allnc-elim-form
	(proof-to-goedel-gentzen-translation-aux
	 op avar-to-goedel-gentzen-avar)
	arg)))
    (else (myerror "proof-to-goedel-gentzen-translation-aux"
		   "proof tag expected" (tag proof)))))

; Notice that the Goedel-Gentzen double negates every atom, and hence
; may produce triple negations.  However, we can systematically replace
; triple negations by single negations.

; For a formula A let A* be the formula obtaind by replacing triple
; negations whenever possible by single negations.

(define (formula-to-formula-without-triple-negations-log formula)
  (if ;formula is triple negation
   (and (imp-form? formula)
	(formula=? falsity-log (imp-form-to-conclusion formula)) 
	(imp-form? (imp-form-to-premise formula))
	(formula=? falsity-log (imp-form-to-conclusion
				(imp-form-to-premise formula)))
	(imp-form? (imp-form-to-premise (imp-form-to-premise formula)))
	(formula=? falsity-log (imp-form-to-conclusion
				(imp-form-to-premise
				 (imp-form-to-premise formula)))))
   (formula-to-formula-without-triple-negations-log
    (imp-form-to-premise (imp-form-to-premise formula)))
   (case (tag formula)
     ((atom predicate) formula)
     ((imp)
      (let* ((prem (imp-form-to-premise formula))
	     (concl (imp-form-to-conclusion formula))
	     (prev1 (formula-to-formula-without-triple-negations-log prem))
	     (prev2 (formula-to-formula-without-triple-negations-log concl)))
	(make-imp prev1 prev2)))
     ((impnc)
      (let* ((prem (impnc-form-to-premise formula))
	     (concl (impnc-form-to-conclusion formula))
	     (prev1 (formula-to-formula-without-triple-negations-log prem))
	     (prev2 (formula-to-formula-without-triple-negations-log concl)))
	(make-impnc prev1 prev2)))
     ((and)
      (let* ((left (and-form-to-left formula))
	     (right (and-form-to-right formula))
	     (prev1 (formula-to-formula-without-triple-negations-log left))
	     (prev2 (formula-to-formula-without-triple-negations-log right)))
	(make-and prev1 prev2)))
     ((all)
      (let* ((var (all-form-to-var formula))
	     (kernel (all-form-to-kernel formula))
	     (prev (formula-to-formula-without-triple-negations-log kernel)))
	(make-all var prev)))
     ((allnc)
      (let* ((var (allnc-form-to-var formula))
	     (kernel (allnc-form-to-kernel formula))
	     (prev (formula-to-formula-without-triple-negations-log kernel)))
	(make-allnc var prev)))
     (else
      (myerror
       "formula-to-formula-without-triple-negations-log" "unexpected formula"
       formula)))))

; We simultaneously construct derivations of (1) A -> A* and (2) A* -> A

(define (formula-to-rm-triple-negations-log-proof1 formula)
  (let ((reduced-formula
	 (formula-to-formula-without-triple-negations-log formula)))
    (case (tag formula)
      ((atom predicate)
       (let ((u (formula-to-new-avar formula)))
	 (make-proof-in-imp-intro-form
	  u (make-proof-in-avar-form u))))
      ((imp)
       (let ((prem (imp-form-to-premise formula))
	     (concl (imp-form-to-conclusion formula))
	     (u (formula-to-new-avar formula)))
	 (if ;formula is a triple negation
	  (and (formula=? falsity-log concl) 
	       (imp-form? prem)
	       (formula=? falsity-log (imp-form-to-conclusion prem))
	       (imp-form? (imp-form-to-premise prem))
	       (formula=? falsity-log (imp-form-to-conclusion
				       (imp-form-to-premise prem))))
	  (let ((v (formula-to-new-avar (imp-form-to-premise prem)))
		(w (formula-to-new-avar (imp-form-to-premise
					 (imp-form-to-premise prem)))))
	    (make-proof-in-imp-intro-form
	     u (make-proof-in-imp-elim-form
		(formula-to-rm-triple-negations-log-proof1
		 (imp-form-to-premise prem))
		(make-proof-in-imp-intro-form
		 w (make-proof-in-imp-elim-form
		    (make-proof-in-avar-form u)
		    (make-proof-in-imp-intro-form
		     v (make-proof-in-imp-elim-form
			(make-proof-in-avar-form v)
			(make-proof-in-avar-form w))))))))
	  (let ((v (formula-to-new-avar
		    (formula-to-formula-without-triple-negations-log prem))))
	    (mk-proof-in-intro-form
	     u v (make-proof-in-imp-elim-form
		  (formula-to-rm-triple-negations-log-proof1 concl)
		  (make-proof-in-imp-elim-form
		   (make-proof-in-avar-form u)
		   (make-proof-in-imp-elim-form
		    (formula-to-rm-triple-negations-log-proof2 prem)
		    (make-proof-in-avar-form v)))))))))
      ((impnc)
       (let ((prem (impnc-form-to-premise formula))
	     (concl (impnc-form-to-conclusion formula))
	     (u (formula-to-new-avar formula)))
	 (if ;formula is a triple negation
	  (and (formula=? falsity-log concl) 
	       (imp-form? prem)
	       (formula=? falsity-log (imp-form-to-conclusion prem))
	       (imp-form? (imp-form-to-premise prem))
	       (formula=? falsity-log (imp-form-to-conclusion
				       (imp-form-to-premise prem))))
	  (let ((v (formula-to-new-avar (imp-form-to-premise prem)))
		(w (formula-to-new-avar (imp-form-to-premise
					 (imp-form-to-premise prem)))))
	    (make-proof-in-imp-intro-form
	     u (make-proof-in-imp-elim-form
		(formula-to-rm-triple-negations-log-proof1
		 (imp-form-to-premise prem))
		(make-proof-in-imp-intro-form
		 w (make-proof-in-imp-elim-form
		    (make-proof-in-avar-form u)
		    (make-proof-in-imp-intro-form
		     v (make-proof-in-imp-elim-form
			(make-proof-in-avar-form v)
			(make-proof-in-avar-form w))))))))
	  (let ((v (formula-to-new-avar
		    (formula-to-formula-without-triple-negations-log prem))))
	    (make-proof-in-imp-intro-form
	     u (make-proof-in-impnc-intro-form
		v (make-proof-in-imp-elim-form
		   (formula-to-rm-triple-negations-log-proof1 concl)
		   (make-proof-in-impnc-elim-form
		    (make-proof-in-avar-form u)
		    (make-proof-in-imp-elim-form
		     (formula-to-rm-triple-negations-log-proof2 prem)
		     (make-proof-in-avar-form v))))))))))
      ((all)
       (let ((var (all-form-to-var formula))
	     (kernel (all-form-to-kernel formula))
	     (u (formula-to-new-avar formula)))
	 (make-proof-in-imp-intro-form
	  u (make-proof-in-all-intro-form
	     var (make-proof-in-imp-elim-form
		  (formula-to-rm-triple-negations-log-proof1 kernel)
		  (make-proof-in-all-elim-form
		   (make-proof-in-avar-form u)
		   (make-term-in-var-form var)))))))
      ((allnc)
       (let ((var (allnc-form-to-var formula))
	     (kernel (allnc-form-to-kernel formula))
	     (u (formula-to-new-avar formula)))
	 (make-proof-in-imp-intro-form
	  u (make-proof-in-allnc-intro-form
	     var (make-proof-in-imp-elim-form
		  (formula-to-rm-triple-negations-log-proof1 kernel)
		  (make-proof-in-allnc-elim-form
		   (make-proof-in-avar-form u)
		   (make-term-in-var-form var)))))))
      (else (myerror
	     "formula-to-rm-triple-negations-log-proof1" "unexpected formula"
	     formula)))))

(define (formula-to-rm-triple-negations-log-proof2 formula)
  (let ((reduced-formula
	 (formula-to-formula-without-triple-negations-log formula)))
    (case (tag formula)
      ((atom predicate)
       (let ((u (formula-to-new-avar formula)))
	 (make-proof-in-imp-intro-form
	  u (make-proof-in-avar-form u))))
      ((imp)
       (let ((prem (imp-form-to-premise formula))
	     (concl (imp-form-to-conclusion formula))
	     (u (formula-to-new-avar reduced-formula)))
	 (if ;formula is a triple negation
	  (and (formula=? falsity-log concl) 
	       (imp-form? prem)
	       (formula=? falsity-log (imp-form-to-conclusion prem))
	       (imp-form? (imp-form-to-premise prem))
	       (formula=? falsity-log (imp-form-to-conclusion
				       (imp-form-to-premise prem))))
	  (let ((v (formula-to-new-avar prem)))
	    (mk-proof-in-intro-form
	     u v (make-proof-in-imp-elim-form
		  (make-proof-in-avar-form v)
		  (make-proof-in-imp-elim-form
		   (formula-to-rm-triple-negations-log-proof2
		    (imp-form-to-premise prem))
		   (make-proof-in-avar-form u)))))
	  (let ((v (formula-to-new-avar prem)))
	    (mk-proof-in-intro-form
	     u v (make-proof-in-imp-elim-form
		  (formula-to-rm-triple-negations-log-proof2 concl)
		  (make-proof-in-imp-elim-form
		   (make-proof-in-avar-form u)
		   (make-proof-in-imp-elim-form
		    (formula-to-rm-triple-negations-log-proof1 prem)
		    (make-proof-in-avar-form v)))))))))
      ((impnc)
       (let ((prem (impnc-form-to-premise formula))
	     (concl (impnc-form-to-conclusion formula))
	     (u (formula-to-new-avar reduced-formula)))
	 (if ;formula is a triple negation
	  (and (formula=? falsity-log concl) 
	       (imp-form? prem)
	       (formula=? falsity-log (imp-form-to-conclusion prem))
	       (imp-form? (imp-form-to-premise prem))
	       (formula=? falsity-log (imp-form-to-conclusion
				       (imp-form-to-premise prem))))
	  (let ((v (formula-to-new-avar prem)))
	    (mk-proof-in-intro-form
	     u v (make-proof-in-imp-elim-form
		  (make-proof-in-avar-form v)
		  (make-proof-in-imp-elim-form
		   (formula-to-rm-triple-negations-log-proof2
		    (imp-form-to-premise prem))
		   (make-proof-in-avar-form u)))))
	  (let ((v (formula-to-new-avar prem)))
	    (make-proof-in-imp-intro-form
	     u (make-proof-in-impnc-intro-form
		v (make-proof-in-imp-elim-form
		   (formula-to-rm-triple-negations-log-proof2 concl)
		   (make-proof-in-impnc-elim-form
		    (make-proof-in-avar-form u)
		    (make-proof-in-imp-elim-form
		     (formula-to-rm-triple-negations-log-proof1 prem)
		     (make-proof-in-avar-form v))))))))))
      ((all)
       (let ((var (all-form-to-var formula))
	     (kernel (all-form-to-kernel formula))
	     (u (formula-to-new-avar
		 (formula-to-formula-without-triple-negations-log formula))))
	 (make-proof-in-imp-intro-form
	  u (make-proof-in-all-intro-form
	     var (make-proof-in-imp-elim-form
		  (formula-to-rm-triple-negations-log-proof2 kernel)
		  (make-proof-in-all-elim-form
		   (make-proof-in-avar-form u)
		   (make-term-in-var-form var)))))))
      ((allnc)
       (let ((var (allnc-form-to-var formula))
	     (kernel (allnc-form-to-kernel formula))
	     (u (formula-to-new-avar
		 (formula-to-formula-without-triple-negations-log formula))))
	 (make-proof-in-imp-intro-form
	  u (make-proof-in-allnc-intro-form
	     var (make-proof-in-imp-elim-form
		  (formula-to-rm-triple-negations-log-proof2 kernel)
		  (make-proof-in-allnc-elim-form
		   (make-proof-in-avar-form u)
		   (make-term-in-var-form var)))))))
      (else (myerror
	     "formula-to-rm-triple-negations-log-proof2" "unexpected formula"
	     formula)))))

; Now we can refine the Goedel-Gentzen translation accordingly.

(define (proof-to-reduced-goedel-gentzen-translation proof)
  (let* ((avar-to-goedel-gentzen-avar
	  (let ((assoc-list '()))
	    (lambda (avar)
	      (let ((info (assoc-wrt avar=? avar assoc-list)))
		(if info
		    (cadr info)
		    (let ((new-avar (formula-to-new-avar
				     (formula-to-goedel-gentzen-translation
				      (avar-to-formula avar)))))
		      (set! assoc-list (cons (list avar new-avar) assoc-list))
		      new-avar))))))
	 (proof-gg (proof-to-goedel-gentzen-translation-aux
		    proof avar-to-goedel-gentzen-avar))
	 (formula-gg (proof-to-formula proof-gg))
	 (proof1 ;of formula-gg -> formula-gg*
	  (formula-to-rm-triple-negations-log-proof1 formula-gg)))
    (make-proof-in-imp-elim-form proof1 proof-gg)))


; 10-7. Existence formulas
; ========================

; In case of ex-formulas ex xs1 A1 ... ex xsn An and conclusion B we
; recursively construct a proof of 

; ex xs1 A1 -> ... -> ex xsn An -> (all xs1,...,xsn.A1 -> ... -> An -> B) -> B.

; Notice that the free variables zs are not generalized here.  We assume
; that B does not contain any variable from xs1 ... xsn free.  This is
; checked and - if it does not hold - enforced in a preprocessing step.

(define (ex-formulas-and-concl-to-ex-elim-proof x . rest)
  (let* ((ex-formulas (list-head (cons x rest) (length rest)))
	 (concl (car (last-pair (cons x rest))))
	 (zs (apply union (map formula-to-free (cons x rest))))
	 (vars-and-kernel-list
	  (map ex-form-to-vars-and-final-kernel ex-formulas))
	 (varss (map car vars-and-kernel-list))
	 (kernels (map cadr vars-and-kernel-list))
	 (test (and (pair? ex-formulas)
		    (or (pair? (apply intersection varss))
			(pair? (intersection (apply append varss)
					     (formula-to-free concl))))))
	 (new-varss 
	  (if test
	      (map (lambda (vars) (map var-to-new-var vars)) varss)
	      varss))
	 (new-kernels
	  (if test
	      (do ((l1 varss (cdr l1))
		   (l2 kernels (cdr l2))
		   (l3 new-varss (cdr l3))
		   (res '() (let* ((vars (car l1))
				   (kernel (car l2))
				   (new-vars (car l3))
				   (subst (map (lambda (x y) (list x y))
					       vars
					       (map make-term-in-var-form
						    new-vars))))
			      (cons (formula-substitute kernel subst) res))))
		  ((null? l1) (reverse res)))
	      kernels)))
    (ex-formulas-and-concl-to-ex-elim-proof-aux
     new-varss new-kernels ex-formulas concl)))

(define (ex-formulas-and-concl-to-ex-elim-proof-aux varss kernels
						    ex-formulas concl)
  (if
   (null? kernels)
   (let ((u (formula-to-new-avar concl)))
     (make-proof-in-imp-intro-form u (make-proof-in-avar-form u)))
   (let ((vars (car varss))
	 (kernel (car kernels)))
     (if
      (null? vars)
      (let* ((prev (ex-formulas-and-concl-to-ex-elim-proof-aux
		    (cdr varss) (cdr kernels) (cdr ex-formulas) concl))
	     (u1 (formula-to-new-avar kernel))
	     (us (map formula-to-new-avar (cdr ex-formulas)))
	     (flattened-varss (apply append (cdr varss)))
	     (v (formula-to-new-avar
		 (apply
		  mk-all
		  (append
		   flattened-varss
		   (list (apply mk-imp (append kernels (list concl)))))))))
	(apply
	 mk-proof-in-intro-form
	 (cons
	  u1 (append
	      us (cons
		  v (list
		     (apply
		      mk-proof-in-elim-form
		      (cons
		       prev (append
			     (map make-proof-in-avar-form us)
			     (list
			      (apply
			       mk-proof-in-intro-form
			       (append
				flattened-varss
				(list
				 (apply
				  mk-proof-in-elim-form
				  (cons
				   (make-proof-in-avar-form v)
				   (append
				    (map make-term-in-var-form 
					 flattened-varss)
				    (list (make-proof-in-avar-form
					   u1))))))))))))))))))
      (let* ((prev (ex-formulas-and-concl-to-ex-elim-proof-aux
		    (cons (cdr vars) (cdr varss)) kernels
		    (cons (ex-form-to-kernel (car ex-formulas))
			  (cdr ex-formulas)) concl))
	     (ex-formula (apply mk-ex (append vars (list kernel))))
	     (zs (union (formula-to-free ex-formula) (formula-to-free concl)))
	     (aconst-proof
	      (apply
	       mk-proof-in-elim-form
	       (cons
		(make-proof-in-aconst-form
		 (ex-formula-and-concl-to-ex-elim-aconst ex-formula concl))
		(map make-term-in-var-form zs))))
	     (var (car vars))
	     (u1 (formula-to-new-avar ex-formula))
	     (us (map formula-to-new-avar (cdr ex-formulas)))
	     (flattened-varss (apply append varss))
	     (v (formula-to-new-avar
		 (apply
		  mk-all
		  (append
		   flattened-varss
		   (list (apply mk-imp (append kernels (list concl))))))))
	     (w (formula-to-new-avar
		 (apply mk-ex (append (cdr vars) (list kernel))))))
	(apply
	 mk-proof-in-intro-form
	 (cons
	  u1 (append
	      us (cons
		  v (list
		     (mk-proof-in-elim-form
		      aconst-proof
		      (make-proof-in-avar-form u1)
		      (mk-proof-in-intro-form
		       var w
		       (apply
			mk-proof-in-elim-form
			(cons
			 prev
			 (cons
			  (make-proof-in-avar-form w)
			  (append
			   (map make-proof-in-avar-form us)
			   (list
			    (make-proof-in-all-elim-form
			     (make-proof-in-avar-form v)
			     (make-term-in-var-form var)))))))))))))))))))

; Call a formula E essentially existential, if it can be transformed
; into an existential form.  Inductive definition:

; E ::= ex x A | A & E | E & A | decidable -> E (postponed)

; We want to replace an implication with an essentially existential
; premise by a formula with one existential quantifier less.
; Application: search.  Given a formula A, reduce it to A* by
; eliminating as many existential quantifiers as possible.  Then search
; for a proof of A*.  Since a proof of A* -> A can be constructed easily,
; one obtains a proof of A.

(define (formula-to-ex-red-formula formula) ;constructs A* from A
  (case (tag formula)
    ((predicate atom) formula)
    ((imp)
     (let* ((prem (imp-form-to-premise formula))
	    (concl (imp-form-to-conclusion formula))
	    (prev-prem (formula-to-ex-red-formula prem))
	    (prev-concl (formula-to-ex-red-formula concl)))
       (if
	(ex-form? prev-prem)
	(let* ((vars-and-kernel (ex-form-to-vars-and-final-kernel prev-prem))
	       (vars (car vars-and-kernel))
	       (kernel (cadr vars-and-kernel)))
	  (if
	   (null? (intersection vars (formula-to-free prev-concl)))
	   (apply mk-all (append vars (list (make-imp kernel prev-concl))))
	   (let* ((new-vars (map var-to-new-var vars))
		  (new-varterms (map make-term-in-var-form new-vars))
		  (subst (map (lambda (x y) (list x y))
			      vars new-varterms))
		  (new-kernel (formula-substitute kernel subst)))
	     (apply mk-all (append new-vars
				   (list (make-imp new-kernel prev-concl)))))))
	(make-imp prev-prem prev-concl))))
    ((impnc)
     (let* ((prem (impnc-form-to-premise formula))
	    (concl (impnc-form-to-conclusion formula))
	    (prev-prem (formula-to-ex-red-formula prem))
	    (prev-concl (formula-to-ex-red-formula concl)))
       (if
	(ex-form? prev-prem)
	(let* ((vars-and-kernel (ex-form-to-vars-and-final-kernel prev-prem))
	       (vars (car vars-and-kernel))
	       (kernel (cadr vars-and-kernel)))
	  (if
	   (null? (intersection vars (formula-to-free prev-concl)))
	   (apply mk-all (append vars (list (make-imp kernel prev-concl))))
	   (let* ((new-vars (map var-to-new-var vars))
		  (new-varterms (map make-term-in-var-form new-vars))
		  (subst (map (lambda (x y) (list x y))
			      vars new-varterms))
		  (new-kernel (formula-substitute kernel subst)))
	     (apply mk-all (append new-vars
				   (list (make-imp new-kernel prev-concl)))))))
	(make-impnc prev-prem prev-concl))))
    ((and)
     (let* ((left (and-form-to-left formula))
	    (right (and-form-to-right formula))
	    (prev1 (formula-to-ex-red-formula left))
	    (prev2 (formula-to-ex-red-formula right)))
       (if
	(or (ex-form? prev1) (ex-form? prev2))
	(let* ((vars-and-kernel1 (ex-form-to-vars-and-final-kernel prev1))
	       (vars1 (car vars-and-kernel1))
	       (kernel1 (cadr vars-and-kernel1))
	       (vars-and-kernel2 (ex-form-to-vars-and-final-kernel prev2))
	       (vars2 (car vars-and-kernel2))
	       (kernel2 (cadr vars-and-kernel2)))
	  (if
	   (and (null? (intersection vars1 (formula-to-free kernel2)))
		(null? (intersection vars2 (formula-to-free kernel1)))
		(null? (intersection vars1 vars2)))
	   (apply mk-ex (append vars1 vars2 (list (make-and kernel1 kernel2))))
	   (let* ((new-vars1 (map var-to-new-var vars1))
		  (new-varterms1 (map make-term-in-var-form new-vars1))
		  (subst1 (map (lambda (x y) (list x y))
			       vars1 new-varterms1))
		  (new-kernel1 (formula-substitute kernel1 subst1))
		  (new-vars2 (map var-to-new-var vars2))
		  (new-varterms2 (map make-term-in-var-form new-vars2))
		  (subst2 (map (lambda (x y) (list x y))
			       vars2 new-varterms2))
		  (new-kernel2 (formula-substitute kernel2 subst2)))
	     (apply mk-ex
		    (append new-vars1 new-vars2
			    (list (make-and new-kernel1 new-kernel2)))))))
	(make-and prev1 prev2))))
    ((all)
     (let* ((var (all-form-to-var formula))
	    (kernel (all-form-to-kernel formula))
	    (prev (formula-to-ex-red-formula kernel)))
       (make-all var prev)))
    ((allnc)
     (let* ((var (allnc-form-to-var formula))
	    (kernel (allnc-form-to-kernel formula))
	    (prev (formula-to-ex-red-formula kernel)))
       (make-allnc var prev)))
    ((ex)
     (let* ((var (ex-form-to-var formula))
	    (kernel (ex-form-to-kernel formula))
	    (prev (formula-to-ex-red-formula kernel)))
       (make-ex var prev)))
    (else (myerror "formula-to-ex-red-formula" "formula expected")
	  formula)))

(define (formula-to-proof-of-formula-imp-ex-red-formula formula)
  (case (tag formula)
    ((predicate atom)
     (let ((u (formula-to-new-avar formula)))
       (make-proof-in-imp-intro-form u (make-proof-in-avar-form u))))
    ((imp)
     (let* ((prem (imp-form-to-premise formula))
	    (concl (imp-form-to-conclusion formula))
	    (ex-red-prem (formula-to-ex-red-formula prem))
	    (ex-red-concl (formula-to-ex-red-formula concl))
	    (vars-and-kernel (ex-form-to-vars-and-final-kernel ex-red-prem))
	    (vars (car vars-and-kernel))
	    (kernel (cadr vars-and-kernel))
	    (test (null? (intersection vars (formula-to-free ex-red-concl))))
	    (new-vars (if test vars (map var-to-new-var vars)))
	    (new-varterms (map make-term-in-var-form new-vars))
	    (subst (map (lambda (x y) (list x y)) vars new-varterms))
	    (new-kernel (if test kernel (formula-substitute kernel subst)))
	    (u1 (formula-to-new-avar new-kernel)) ;A0
	    (u2 (formula-to-new-avar formula)) ;A -> B
	    (proof-of-ex-red-prem-to-prem ;A* -> A
	     (formula-to-proof-of-ex-red-formula-imp-formula prem))
	    (proof-of-concl-to-ex-red-concl ;B -> B*
	     (formula-to-proof-of-formula-imp-ex-red-formula concl)))
       (apply
	mk-proof-in-intro-form
	(cons
	 u2 ;A -> B
	 (append
	  new-vars ;xs
	  (list
	   u1 ;A0
	   (make-proof-in-imp-elim-form
	    proof-of-concl-to-ex-red-concl ;B -> B*
	    (make-proof-in-imp-elim-form
	     (make-proof-in-avar-form u2) ;A -> B
	     (make-proof-in-imp-elim-form
	      proof-of-ex-red-prem-to-prem ;A* -> A
	      (apply
	       mk-proof-in-ex-intro-form
	       (append
		(map make-term-in-var-form new-vars) ;xs
		(list ex-red-prem ;A*
		      (make-proof-in-avar-form u1)))))))))))))
    ((impnc)
     (let* ((prem (impnc-form-to-premise formula))
	    (concl (impnc-form-to-conclusion formula))
	    (ex-red-prem (formula-to-ex-red-formula prem))
	    (ex-red-concl (formula-to-ex-red-formula concl))
	    (vars-and-kernel (ex-form-to-vars-and-final-kernel ex-red-prem))
	    (vars (car vars-and-kernel))
	    (kernel (cadr vars-and-kernel))
	    (test (null? (intersection vars (formula-to-free ex-red-concl))))
	    (new-vars (if test vars (map var-to-new-var vars)))
	    (new-varterms (map make-term-in-var-form new-vars))
	    (subst (map (lambda (x y) (list x y)) vars new-varterms))
	    (new-kernel (if test kernel (formula-substitute kernel subst)))
	    (u1 (formula-to-new-avar new-kernel)) ;A0
	    (u2 (formula-to-new-avar formula)) ;A --> B
	    (proof-of-ex-red-prem-to-prem ;A* -> A
	     (formula-to-proof-of-ex-red-formula-imp-formula prem))
	    (proof-of-concl-to-ex-red-concl ;B -> B*
	     (formula-to-proof-of-formula-imp-ex-red-formula concl)))
       (apply
	mk-proof-in-intro-form
	(cons
	 u2 ;A --> B
	 (append
	  new-vars ;xs
	  (list
	   u1 ;A0
	   (make-proof-in-imp-elim-form
	    proof-of-concl-to-ex-red-concl ;B -> B*
	    (make-proof-in-impnc-elim-form
	     (make-proof-in-avar-form u2) ;A --> B
	     (make-proof-in-imp-elim-form
	      proof-of-ex-red-prem-to-prem ;A* -> A
	      (apply
	       mk-proof-in-ex-intro-form
	       (append
		(map make-term-in-var-form new-vars) ;xs
		(list ex-red-prem ;A*
		      (make-proof-in-avar-form u1)))))))))))))
    ((and)
     (let* ((left (and-form-to-left formula))
	    (right (and-form-to-right formula))
	    (ex-red-left (formula-to-ex-red-formula left))
	    (ex-red-right (formula-to-ex-red-formula right))
	    (vars-and-kernel1
	     (ex-form-to-vars-and-final-kernel ex-red-left))
	    (vars1 (car vars-and-kernel1))
	    (kernel1 (cadr vars-and-kernel1))
	    (vars-and-kernel2
	     (ex-form-to-vars-and-final-kernel ex-red-right))
	    (vars2 (car vars-and-kernel2))
	    (kernel2 (cadr vars-and-kernel2))
	    (test
	     (and (null? (intersection vars1 (formula-to-free kernel2)))
		  (null? (intersection vars2 (formula-to-free kernel1)))
		  (null? (intersection vars1 vars2))))
	    (new-vars1 (if test vars1 (map var-to-new-var vars1)))
	    (new-varterms1 (map make-term-in-var-form new-vars1))
	    (subst1 (map (lambda (x y) (list x y)) vars1 new-varterms1))
	    (new-kernel1
	     (if test kernel1 (formula-substitute kernel1 subst1)))
	    (new-vars2 (if test vars2 (map var-to-new-var vars2)))
	    (new-varterms2 (map make-term-in-var-form new-vars2))
	    (subst2 (map (lambda (x y) (list x y)) vars2 new-varterms2))
	    (new-kernel2
	     (if test kernel2 (formula-substitute kernel2 subst2)))
	    (ex-red-formula
	     (apply mk-ex
		    (append new-vars1 new-vars2
			    (list (make-and new-kernel1 new-kernel2)))))
	    (u1 (formula-to-new-avar new-kernel1)) ;A0
	    (u2 (formula-to-new-avar new-kernel2)) ;B0
	    (u3 (formula-to-new-avar formula)) ;A & B
	    (proof-of-left-to-ex-red-left ;A -> A*
	     (formula-to-proof-of-formula-imp-ex-red-formula left))
	    (proof-of-right-to-ex-red-right ;B -> B*
	     (formula-to-proof-of-formula-imp-ex-red-formula right)))
       (cond
	((and (ex-form? ex-red-left) (ex-form? ex-red-right))
	 (make-proof-in-imp-intro-form
	  u3
	  (make-proof-in-imp-elim-form
	   (make-proof-in-imp-elim-form
	    (ex-formulas-and-concl-to-ex-elim-proof ex-red-left ex-red-formula)
	    (make-proof-in-imp-elim-form
	     proof-of-left-to-ex-red-left ;A -> A*
	     (make-proof-in-and-elim-left-form
	      (make-proof-in-avar-form u3))))
	   (apply
	    mk-proof-in-intro-form
	    (append
	     new-vars1
	     (list
	      u1 ;A0
	      (make-proof-in-imp-elim-form
	       (make-proof-in-imp-elim-form
		(ex-formulas-and-concl-to-ex-elim-proof 
		 ex-red-right ex-red-formula)
		(make-proof-in-imp-elim-form
		 proof-of-right-to-ex-red-right ;B -> B*
		 (make-proof-in-and-elim-right-form
		  (make-proof-in-avar-form u3))))
	       (apply
		mk-proof-in-intro-form
		(append
		 new-vars2
		 (list u2 ;B0
		       (apply
			mk-proof-in-ex-intro-form
			(append
			 (map make-term-in-var-form new-vars1)
			 (map make-term-in-var-form new-vars2)
			 (list ex-red-formula
			       (make-proof-in-and-intro-form
				(make-proof-in-avar-form u1)
				(make-proof-in-avar-form u2)))))))))))))))
	((and (not (ex-form? ex-red-left)) (ex-form? ex-red-right))
	 (make-proof-in-imp-intro-form
	  u3 ;A & B
	  (make-proof-in-imp-elim-form
	   (make-proof-in-imp-elim-form
	    (ex-formulas-and-concl-to-ex-elim-proof
	     ex-red-right ex-red-formula)
	    (make-proof-in-imp-elim-form
	     proof-of-right-to-ex-red-right ;B -> B*
	     (make-proof-in-and-elim-right-form
	      (make-proof-in-avar-form u3))))
	   (apply
	    mk-proof-in-intro-form
	    (append
	     new-vars2
	     (list
	      u2 ;B0
	      (apply
	       mk-proof-in-ex-intro-form
	       (append
		(map make-term-in-var-form new-vars2)
		(list
		 ex-red-formula
		 (make-proof-in-and-intro-form
		  (make-proof-in-imp-elim-form
		   proof-of-left-to-ex-red-left ;A -> A*
		   (make-proof-in-and-elim-left-form
		    (make-proof-in-avar-form u3)))
		  (make-proof-in-avar-form u2)))))))))))
	((and (ex-form? ex-red-left) (not (ex-form? ex-red-right)))
	 (make-proof-in-imp-intro-form
	  u3 ;A & B
	  (make-proof-in-imp-elim-form
	   (make-proof-in-imp-elim-form
	    (ex-formulas-and-concl-to-ex-elim-proof ex-red-left ex-red-formula)
	    (make-proof-in-imp-elim-form
	     proof-of-left-to-ex-red-left ;A -> A*
	     (make-proof-in-and-elim-left-form
	      (make-proof-in-avar-form u3))))
	   (apply
	    mk-proof-in-intro-form
	    (append
	     new-vars1
	     (list
	      u1 ;A0
	      (apply
	       mk-proof-in-ex-intro-form
	       (append
		(map make-term-in-var-form new-vars1)
		(list
		 ex-red-formula
		 (make-proof-in-and-intro-form
		  (make-proof-in-avar-form u1)
		  (make-proof-in-imp-elim-form
		   proof-of-right-to-ex-red-right ;B -> B*
		   (make-proof-in-and-elim-right-form
		    (make-proof-in-avar-form u3)))))))))))))
	((and (not (ex-form? ex-red-left)) (not (ex-form? ex-red-right)))
	 (make-proof-in-imp-intro-form
	  u3 (make-proof-in-and-intro-form
	      (make-proof-in-imp-elim-form
	       proof-of-left-to-ex-red-left ;A -> A*
	       (make-proof-in-and-elim-left-form
		(make-proof-in-avar-form u3)))
	      (make-proof-in-imp-elim-form
	       proof-of-right-to-ex-red-right ;B -> B*
	       (make-proof-in-and-elim-right-form
		(make-proof-in-avar-form u3))))))
	(else (myerror "formula-to-proof-of-formula-imp-ex-red-formula"
		       "this cannot happen")))))
    ((all)
     (let* ((var (all-form-to-var formula))
	    (kernel (all-form-to-kernel formula))
	    (ex-red-kernel (formula-to-ex-red-formula kernel))
	    (ex-red-formula (formula-to-ex-red-formula formula))
	    (u1 (formula-to-new-avar formula)) ;all x A
	    (proof-of-kernel-to-ex-red-kernel ;A -> A*
	     (formula-to-proof-of-formula-imp-ex-red-formula kernel)))
       (mk-proof-in-intro-form
	u1 var (make-proof-in-imp-elim-form
		proof-of-kernel-to-ex-red-kernel ;A -> A*
		(make-proof-in-all-elim-form
		 (make-proof-in-avar-form u1)
		 (make-term-in-var-form var))))))
    ((allnc)
     (let* ((var (allnc-form-to-var formula))
	    (kernel (allnc-form-to-kernel formula))
	    (ex-red-kernel (formula-to-ex-red-formula kernel))
	    (ex-red-formula (formula-to-ex-red-formula formula))
	    (u1 (formula-to-new-avar formula)) ;allnc x A
	    (proof-of-kernel-to-ex-red-kernel ;A -> A*
	     (formula-to-proof-of-formula-imp-ex-red-formula kernel)))
       (mk-proof-in-intro-form
	u1 var (make-proof-in-imp-elim-form
		proof-of-kernel-to-ex-red-kernel ;A -> A*
		(make-proof-in-allnc-elim-form
		 (make-proof-in-avar-form u1)
		 (make-term-in-var-form var))))))
    ((ex)
     (let* ((var (ex-form-to-var formula))
	    (kernel (ex-form-to-kernel formula))
	    (ex-red-kernel (formula-to-ex-red-formula kernel))
	    (ex-red-formula (formula-to-ex-red-formula formula))
	    (u1 (formula-to-new-avar kernel)) ;A
	    (u2 (formula-to-new-avar formula)) ;ex x A
	    (proof-of-kernel-to-ex-red-kernel ;A -> A*
	     (formula-to-proof-of-formula-imp-ex-red-formula kernel)))
       (make-proof-in-imp-intro-form
	u2 (make-proof-in-imp-elim-form
	    (make-proof-in-imp-elim-form
	     (ex-formulas-and-concl-to-ex-elim-proof formula ex-red-formula)
	     (make-proof-in-avar-form u2))
	    (make-proof-in-all-intro-form
	     var (make-proof-in-imp-intro-form
		  u1 (make-proof-in-ex-intro-form
		      (make-term-in-var-form var)
		      ex-red-formula
		      (make-proof-in-imp-elim-form
		       proof-of-kernel-to-ex-red-kernel ;A -> A*
		       (make-proof-in-avar-form u1)))))))))
    (else (myerror
	   "formula-to-proof-of-formula-imp-ex-red-formula" "formula expected"
	   formula))))

(define (formula-to-proof-of-ex-red-formula-imp-formula formula)
  (case (tag formula)
    ((predicate atom)
     (let ((u (formula-to-new-avar formula)))
       (make-proof-in-imp-intro-form u (make-proof-in-avar-form u))))
    ((imp)
     (let* ((prem (imp-form-to-premise formula))
	    (concl (imp-form-to-conclusion formula))
	    (ex-red-prem (formula-to-ex-red-formula prem))
	    (ex-red-concl (formula-to-ex-red-formula concl))
	    (ex-red-formula (formula-to-ex-red-formula formula))
	    (u1 (formula-to-new-avar prem)) ;A
	    (u2 (formula-to-new-avar ex-red-formula)) ;(A -> B)*
	    (proof-of-ex-red-concl-to-concl ;B* -> B
	     (formula-to-proof-of-ex-red-formula-imp-formula concl))
	    (proof-of-prem-to-ex-red-prem ;A -> A*
	     (formula-to-proof-of-formula-imp-ex-red-formula prem)))
       (if
	(ex-form? ex-red-prem)
	(make-proof-in-imp-intro-form
	 u2 ;(A -> B)*
	 (make-proof-in-imp-intro-form
	  u1 ;A
	  (make-proof-in-imp-elim-form
	   proof-of-ex-red-concl-to-concl ;B* -> B
	   (make-proof-in-imp-elim-form
	    (make-proof-in-imp-elim-form
	     (ex-formulas-and-concl-to-ex-elim-proof ex-red-prem ex-red-concl)
	     (make-proof-in-imp-elim-form
	      proof-of-prem-to-ex-red-prem ;A -> A*
	      (make-proof-in-avar-form u1)))
	    (make-proof-in-avar-form u2)))))
	(make-proof-in-imp-intro-form
	 u2 ;(A -> B)*
	 (make-proof-in-imp-intro-form
	  u1 ;A
	  (make-proof-in-imp-elim-form
	   proof-of-ex-red-concl-to-concl ;B* -> B
	   (make-proof-in-imp-elim-form
	    (make-proof-in-avar-form u2) ;(A -> B)* = A* -> B*
	    (make-proof-in-imp-elim-form
	     proof-of-prem-to-ex-red-prem ;A -> A*
	     (make-proof-in-avar-form u1)))))))))
    ((impnc)
     (let* ((prem (impnc-form-to-premise formula))
	    (concl (impnc-form-to-conclusion formula))
	    (ex-red-prem (formula-to-ex-red-formula prem))
	    (ex-red-concl (formula-to-ex-red-formula concl))
	    (ex-red-formula (formula-to-ex-red-formula formula))
	    (u1 (formula-to-new-avar prem)) ;A
	    (u2 (formula-to-new-avar ex-red-formula)) ;(A -> B)*
	    (proof-of-ex-red-concl-to-concl ;B* -> B
	     (formula-to-proof-of-ex-red-formula-imp-formula concl))
	    (proof-of-prem-to-ex-red-prem ;A -> A*
	     (formula-to-proof-of-formula-imp-ex-red-formula prem)))
       (if
	(ex-form? ex-red-prem)
	(make-proof-in-imp-intro-form
	 u2 ;(A -> B)*
	 (make-proof-in-impnc-intro-form
	  u1 ;A
	  (make-proof-in-imp-elim-form
	   proof-of-ex-red-concl-to-concl ;B* -> B
	   (make-proof-in-imp-elim-form
	    (make-proof-in-imp-elim-form
	     (ex-formulas-and-concl-to-ex-elim-proof ex-red-prem ex-red-concl)
	     (make-proof-in-imp-elim-form
	      proof-of-prem-to-ex-red-prem ;A -> A*
	      (make-proof-in-avar-form u1)))
	    (make-proof-in-avar-form u2)))))
	(make-proof-in-imp-intro-form
	 u2 ;(A -> B)*
	 (make-proof-in-impnc-intro-form
	  u1 ;A
	  (make-proof-in-imp-elim-form
	   proof-of-ex-red-concl-to-concl ;B* -> B
	   (make-proof-in-impnc-elim-form
	    (make-proof-in-avar-form u2) ;(A -> B)* = A* -> B*
	    (make-proof-in-imp-elim-form
	     proof-of-prem-to-ex-red-prem ;A -> A*
	     (make-proof-in-avar-form u1)))))))))
    ((and)
     (let* ((left (and-form-to-left formula))
	    (right (and-form-to-right formula))
	    (ex-red-left (formula-to-ex-red-formula left))
	    (ex-red-right (formula-to-ex-red-formula right))
	    (vars-and-kernel1
	     (ex-form-to-vars-and-final-kernel ex-red-left))
	    (vars1 (car vars-and-kernel1))
	    (kernel1 (cadr vars-and-kernel1))
	    (vars-and-kernel2
	     (ex-form-to-vars-and-final-kernel ex-red-right))
	    (vars2 (car vars-and-kernel2))
	    (kernel2 (cadr vars-and-kernel2))
	    (test
	     (and (null? (intersection vars1 (formula-to-free kernel2)))
		  (null? (intersection vars2 (formula-to-free kernel1)))
		  (null? (intersection vars1 vars2))))
	    (new-vars1 (if test vars1 (map var-to-new-var vars1)))
	    (new-varterms1 (map make-term-in-var-form new-vars1))
	    (subst1 (map (lambda (x y) (list x y)) vars1 new-varterms1))
	    (new-kernel1
	     (if test kernel1 (formula-substitute kernel1 subst1)))
	    (new-vars2 (if test vars2 (map var-to-new-var vars2)))
	    (new-varterms2 (map make-term-in-var-form new-vars2))
	    (subst2 (map (lambda (x y) (list x y)) vars2 new-varterms2))
	    (new-kernel2
	     (if test kernel2 (formula-substitute kernel2 subst2)))
	    (ex-red-formula
	     (apply mk-ex
		    (append new-vars1 new-vars2
			    (list (make-and new-kernel1 new-kernel2)))))
	    (u1 (formula-to-new-avar ex-red-formula)) ;(A & B)*
	    (u2 ;A0 & B0
	     (formula-to-new-avar (make-and new-kernel1 new-kernel2)))
	    (proof-of-ex-red-left-to-left ;A* -> A
	     (formula-to-proof-of-ex-red-formula-imp-formula left))
	    (proof-of-ex-red-right-to-right ;B* -> B
	     (formula-to-proof-of-ex-red-formula-imp-formula right)))
       (cond
	((and (ex-form? ex-red-left) (ex-form? ex-red-right))
	 (make-proof-in-imp-intro-form
	  u1
	  (make-proof-in-imp-elim-form
	   (make-proof-in-imp-elim-form
	    (ex-formulas-and-concl-to-ex-elim-proof ex-red-formula formula)
	    (make-proof-in-avar-form u1))
	   (apply
	    mk-proof-in-intro-form
	    (append
	     new-vars1 new-vars2
	     (list
	      u2 ;A0 & B0
	      (make-proof-in-and-intro-form
	       (make-proof-in-imp-elim-form
		proof-of-ex-red-left-to-left ;A* -> A
		(apply
		 mk-proof-in-ex-intro-form
		 (append
		  (map make-term-in-var-form new-vars1)
		  (list
		   ex-red-left
		   (make-proof-in-and-elim-left-form
		    (make-proof-in-avar-form u2))))))
	       (make-proof-in-imp-elim-form
		proof-of-ex-red-right-to-right ;B* -> B
		(apply
		 mk-proof-in-ex-intro-form
		 (append
		  (map make-term-in-var-form new-vars2)
		  (list
		   ex-red-right
		   (make-proof-in-and-elim-right-form
		    (make-proof-in-avar-form u2)))))))))))))
	((and (not (ex-form? ex-red-left)) (ex-form? ex-red-right))
	 (make-proof-in-imp-intro-form
	  u1
	  (make-proof-in-imp-elim-form
	   (make-proof-in-imp-elim-form
	    (ex-formulas-and-concl-to-ex-elim-proof ex-red-formula formula)
	    (make-proof-in-avar-form u1))
	   (apply
	    mk-proof-in-intro-form
	    (append
	     new-vars2
	     (list
	      u2 ;A* & B0
	      (make-proof-in-and-intro-form
	       (make-proof-in-imp-elim-form
		proof-of-ex-red-left-to-left ;A* -> A
		(make-proof-in-and-elim-left-form
		 (make-proof-in-avar-form u2)))
	       (make-proof-in-imp-elim-form
		proof-of-ex-red-right-to-right ;B* -> B
		(apply
		 mk-proof-in-ex-intro-form
		 (append
		  (map make-term-in-var-form new-vars2)
		  (list
		   ex-red-right
		   (make-proof-in-and-elim-right-form
		    (make-proof-in-avar-form u2)))))))))))))
	((and (ex-form? ex-red-left) (not (ex-form? ex-red-right)))
	 (make-proof-in-imp-intro-form
	  u1
	  (make-proof-in-imp-elim-form
	   (make-proof-in-imp-elim-form
	    (ex-formulas-and-concl-to-ex-elim-proof ex-red-formula formula)
	    (make-proof-in-avar-form u1))
	   (apply
	    mk-proof-in-intro-form
	    (append
	     new-vars1
	     (list
	      u2 ;A0 & B*
	      (make-proof-in-and-intro-form
	       (make-proof-in-imp-elim-form
		proof-of-ex-red-left-to-left ;A* -> A
		(apply
		 mk-proof-in-ex-intro-form
		 (append
		  (map make-term-in-var-form new-vars1)
		  (list
		   ex-red-left
		   (make-proof-in-and-elim-left-form
		    (make-proof-in-avar-form u2))))))
	       (make-proof-in-imp-elim-form
		proof-of-ex-red-right-to-right ;B* -> B
		(make-proof-in-and-elim-right-form
		 (make-proof-in-avar-form u2))))))))))
	((and (not (ex-form? ex-red-left)) (not (ex-form? ex-red-right)))
	 (make-proof-in-imp-intro-form
	  u1 (make-proof-in-and-intro-form
	      (make-proof-in-imp-elim-form
	       proof-of-ex-red-left-to-left ;A* -> A
	       (make-proof-in-and-elim-left-form
		(make-proof-in-avar-form u1)))
	      (make-proof-in-imp-elim-form
	       proof-of-ex-red-right-to-right ;B* -> B
	       (make-proof-in-and-elim-right-form
		(make-proof-in-avar-form u1))))))
	(else (myerror "formula-to-proof-of-ex-red-formula-imp-formula"
		       "this cannot happen")))))
    ((all)
     (let* ((var (all-form-to-var formula))
	    (kernel (all-form-to-kernel formula))
	    (ex-red-kernel (formula-to-ex-red-formula kernel))
	    (ex-red-formula (formula-to-ex-red-formula formula))
	    (u1 (formula-to-new-avar ex-red-formula)) ;all x A*
	    (proof-of-ex-red-kernel-to-kernel ;A* -> A
	     (formula-to-proof-of-ex-red-formula-imp-formula kernel)))
       (mk-proof-in-intro-form
	u1 var (make-proof-in-imp-elim-form
		proof-of-ex-red-kernel-to-kernel ;A* -> A
		(make-proof-in-all-elim-form
		 (make-proof-in-avar-form u1)
		 (make-term-in-var-form var))))))
    ((allnc)
     (let* ((var (allnc-form-to-var formula))
	    (kernel (allnc-form-to-kernel formula))
	    (ex-red-kernel (formula-to-ex-red-formula kernel))
	    (ex-red-formula (formula-to-ex-red-formula formula))
	    (u1 (formula-to-new-avar ex-red-formula)) ;allnc x A*
	    (proof-of-ex-red-kernel-to-kernel ;A* -> A
	     (formula-to-proof-of-ex-red-formula-imp-formula kernel)))
       (mk-proof-in-intro-form
	u1 var (make-proof-in-imp-elim-form
		proof-of-ex-red-kernel-to-kernel ;A* -> A
		(make-proof-in-allnc-elim-form
		 (make-proof-in-avar-form u1)
		 (make-term-in-var-form var))))))
    ((ex)
     (let* ((var (ex-form-to-var formula))
	    (kernel (ex-form-to-kernel formula))
	    (ex-red-kernel (formula-to-ex-red-formula kernel))
	    (ex-red-formula (formula-to-ex-red-formula formula))
	    (u1 (formula-to-new-avar ex-red-kernel)) ;A*
	    (u2 (formula-to-new-avar ex-red-formula)) ;ex x A*
	    (proof-of-ex-red-kernel-to-kernel ;A* -> A
	     (formula-to-proof-of-ex-red-formula-imp-formula kernel)))
       (make-proof-in-imp-intro-form
	u2 (make-proof-in-imp-elim-form
	    (make-proof-in-imp-elim-form
	     (ex-formulas-and-concl-to-ex-elim-proof ex-red-formula formula)
	     (make-proof-in-avar-form u2))
	    (make-proof-in-all-intro-form
	     var (make-proof-in-imp-intro-form
		  u1 (make-proof-in-ex-intro-form
		      (make-term-in-var-form var)
		      formula
		      (make-proof-in-imp-elim-form
		       proof-of-ex-red-kernel-to-kernel ;A* -> A
		       (make-proof-in-avar-form u1)))))))))
    (else (myerror
	   "formula-to-proof-of-ex-red-formula-imp-formula" "formula expected"
	   formula))))