; ; MDH 2005 - Slightly modified variant to treat nc-quantifiers
; ; $Id: newatr.scm 2156 2008-01-25 13:25:12Z schimans $
; ; 17. A-translation
; ; =================

; Based on Berger, Buchholz, Schwichtenberg: Refined program extraction 
; from classical proofs, APAL 114 (2002), 3--25

; A formula is relevant if it ends with bot.

(define (atr-relevant? formula)
  (case (tag formula)
    ((atom) #f)
    ((predicate) (formula=? formula falsity-log))
    ((imp) (atr-relevant? (imp-form-to-conclusion formula)))
    ((all) (atr-relevant? (all-form-to-kernel formula)))
    ((allnc) (atr-relevant? (allnc-form-to-kernel formula)))
    ((and tensor ex exca excl) #f)
;    (myerror "atr-relevant?: unexpected formula" (formula-to-string formula)))
    (else (myerror "atr-relevant?: formula expected" formula))))

; Definite and goal formulas are defined by a simultaneous recursion.

(define (atr-definite? formula)
  (case (tag formula)
    ((atom predicate) #t)
    ((imp)
     (let ((prem (imp-form-to-premise formula))
	   (concl (imp-form-to-conclusion formula)))
       (and (atr-definite? concl)
	    (atr-goal? prem)
	    (or (atr-relevant? concl) (not (atr-relevant? prem))))))
    ((all) (atr-definite? (all-form-to-kernel formula)))
    ((allnc) (atr-definite? (allnc-form-to-kernel formula)))
    ((and tensor ex exca excl) #f)
;    (myerror "atr-definite?: unexpected formula" (formula-to-string formula)))
    (else (myerror "atr-definite?: formula expected" formula))))

(define (atr-goal? formula)
  (case (tag formula)
    ((atom predicate) #t)
    ((imp)
     (let ((prem (imp-form-to-premise formula))
	   (concl (imp-form-to-conclusion formula)))
       (and (atr-goal? concl)
	    (atr-definite? prem)
	    (or (atr-relevant? prem) (quant-free? prem)))))
    ((all)
     (let ((kernel (all-form-to-kernel formula)))
       (and (atr-goal? kernel) (not (atr-relevant? kernel)))))
    ((allnc)
     (let ((kernel (allnc-form-to-kernel formula)))
       (and (atr-goal? kernel) (not (atr-relevant? kernel)))))
    ((and tensor ex exca excl) #f)
;      (myerror "atr-goal?: unexpected formula" (formula-to-string formula)))
    (else (myerror "atr-goal?: formula expected" formula))))

(add-pvar-name "atrX" (make-arity))
(define atr-x-pvar (make-pvar (make-arity) -1 0 "atrX"))
; (define atr-x-pvar (make-pvar (make-arity) MAXPVARINDEX 0 "atrX"))
(define atr-x-formula (make-predicate-formula atr-x-pvar))
(define atr-x-cterm (make-cterm atr-x-formula))

(define falsity-log-pvar (predicate-form-to-predicate falsity-log))

; We begin with implementing Lemma 2.3. This will involve

; dec-cases-proof: ((boole -> bot) -> atrX^) -> (boole -> atrX^) -> atrX^
; imp-const, and-const: boole -> boole -> boole

; imp-to-atom-proof: (boole1 -> boole2) -> ImpConst boole1 boole2
; atom-to-imp-proof: ImpConst boole1 boole2 -> boole1 -> boole2
; and-to-atom-proof: boole1 & boole2 -> AndConst boole1 boole2
; atom-to-and-proof: AndConst boole1 boole2 -> boole1 & boole2

; Let C be quantifier-free with bot the only possible pvar.
; qf-to-term  C |-> r_C:boole
; qf-to-atom-imp-qf-proof: atom(r_C) -> C
; qf-to-qf-imp-atom-proof: C -> atom(r_C)
; qf-to-qf-cases-proof: ((C -> bot) -> atrX^) -> (C -> atrX^) -> atrX^

; We prove

; "all boole.((boole -> bot) -> atrX^) -> (boole -> atrX^) -> atrX^"

; from the cases axiom at this formula, i.e.

; "(((T -> bot) -> atrX^) -> (T -> atrX^) -> atrX^) -> 
;  (((F -> bot) -> atrX^) -> (F -> atrX^) -> atrX^) -> 
;  all boole.((boole -> bot) -> atrX^) -> (boole -> atrX^) -> atrX^"

; by proving the two cases via

;                   u2: T -> atrX^   T
;                   ------------------
;                          atrX^
;      ----------------------------------------------
;      ((T -> bot) -> atrX^) -> (T -> atrX^) -> atrX^

; and

;     u1: (F -> bot) -> atrX^   efq-bot-proof: F -> bot
;     -------------------------------------------------
;                           atrX^
;      ----------------------------------------------
;      ((F -> bot) -> atrX^) -> (F -> atrX^) -> atrX^

(define dec-cases-proof
  (mk-proof-in-elim-form
   (make-proof-in-aconst-form
    (all-formula-to-cases-aconst
     (pf "all boole.((boole -> bot) -> atrX^) -> (boole -> atrX^) -> atrX^")))
   (let ((u1 (formula-to-new-avar (pf "(T -> bot) -> atrX^")))
	 (u2 (formula-to-new-avar (pf "T -> atrX^"))))
     (mk-proof-in-intro-form
      u1 u2
      (mk-proof-in-elim-form
       (make-proof-in-avar-form u2)
       (make-proof-in-aconst-form truth-aconst))))
   (let* ((u1 (formula-to-new-avar (pf "(F -> bot) -> atrX^")))
	  (u2 (formula-to-new-avar (pf "F -> atrX^")))
	  (efq-aconst (global-assumption-name-to-aconst "Efq"))
	  (efq-formula (aconst-to-formula efq-aconst))
	  (pvar (predicate-form-to-predicate
		 (imp-form-to-conclusion efq-formula)))
	  (efq-bot-proof (proof-subst
			  (make-proof-in-aconst-form efq-aconst)
			  pvar (make-cterm (pf "bot")))))
     (mk-proof-in-intro-form
      u1 u2
      (mk-proof-in-elim-form
       (make-proof-in-avar-form u1) efq-bot-proof)))))

(add-program-constant "ImpConst" (py "boole=>boole=>boole") 1)
(add-computation-rule (pt "ImpConst True True") (pt "True"))
(add-computation-rule (pt "ImpConst False True") (pt "True"))
(add-computation-rule (pt "ImpConst True False") (pt "False"))
(add-computation-rule (pt "ImpConst False False") (pt "True"))
(add-rewrite-rule (pt "ImpConst boole True") (pt "True"))
(add-rewrite-rule (pt "ImpConst False boole") (pt "True"))

; 2004-12-31 Moved into boole.scm
; (add-program-constant "AndConst" (py "boole=>boole=>boole") 1)
; (add-computation-rule (pt "AndConst True True") (pt "True"))
; (add-computation-rule (pt "AndConst False True") (pt "False"))
; (add-computation-rule (pt "AndConst True False") (pt "False"))
; (add-computation-rule (pt "AndConst False False") (pt "False"))
; (add-rewrite-rule (pt "AndConst False boole") (pt "False"))
; (add-rewrite-rule (pt "AndConst boole False") (pt "False"))

(define imp-const (term-in-const-form-to-const (pt "ImpConst")))
(define and-const (term-in-const-form-to-const (pt "AndConst")))

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

(formula-to-string
 (aconst-to-formula
  (all-formula-to-cases-aconst
   (pf "all boole1,boole2.(boole1 -> boole2) -> ImpConst boole1 boole2"))))

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

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

; (cdp (np imp-to-atom-proof))
; (proof-to-expr imp-to-atom-proof)

; ((|Cases|
;    ((|Cases| (lambda (|15|) |Truth-Axiom|))
;     (lambda (|16|) (|16| |Truth-Axiom|))))
;  ((|Cases| (lambda (|17|) |Truth-Axiom|))
;   (lambda (|18|) |Truth-Axiom|)))

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

; (proof-to-expr and-to-atom-proof)

; ((|Cases|
;    ((|Cases| (lambda (|29|) |Truth-Axiom|))
;     (lambda (|30|) (cdr |30|))))
;  ((|Cases| (lambda (|31|) (car |31|)))
;   (lambda (|32|) (car |32|))))

; (cdp (np and-to-atom-proof))

(formula-to-string
 (aconst-to-formula
  (all-formula-to-cases-aconst
   (pf "all boole1,boole2.ImpConst boole1 boole2 -> boole1 -> boole2"))))

; "(all boole2.ImpConst True boole2 -> T -> boole2) -> 
;  (all boole2.ImpConst False boole2 -> F -> boole2) -> 
;  all boole45,boole2.ImpConst boole45 boole2 -> boole45 -> boole2"

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

; (cdp (np atom-to-imp-proof))
; (proof-to-expr (np atom-to-imp-proof))

; ((|Cases|
;    ((|Cases| (lambda (|66|) (lambda (|67|) |Truth-Axiom|)))
;     (lambda (|68|) (lambda (|69|) |68|))))
;  ((|Cases| (lambda (|72|) (lambda (|73|) |Truth-Axiom|)))
;   (lambda (|74|) (lambda (|75|) |75|))))

(define atom-to-and-proof
  (mk-proof-in-elim-form
   (make-proof-in-aconst-form
    (all-formula-to-cases-aconst
     (pf "all boole1,boole2.AndConst boole1 boole2 -> boole1 & boole2")))
   (mk-proof-in-elim-form
    (make-proof-in-aconst-form
     (all-formula-to-cases-aconst
      (pf "all boole2.AndConst True boole2 -> T & boole2")))
    (make-proof-in-imp-intro-form
     (formula-to-new-avar (pf "T"))
     (make-proof-in-and-intro-form
      (make-proof-in-aconst-form truth-aconst)
      (make-proof-in-aconst-form truth-aconst)))
    (let ((u (formula-to-new-avar (pf "F"))))
      (make-proof-in-imp-intro-form
       u (make-proof-in-and-intro-form
	  (make-proof-in-aconst-form truth-aconst)
	  (make-proof-in-avar-form u)))))
   (mk-proof-in-elim-form
    (make-proof-in-aconst-form
     (all-formula-to-cases-aconst
      (pf "all boole2.AndConst False boole2 -> F & boole2")))
    (let ((u (formula-to-new-avar (pf "F"))))
      (make-proof-in-imp-intro-form
       u (make-proof-in-and-intro-form
	  (make-proof-in-avar-form u)
	  (make-proof-in-aconst-form truth-aconst))))
    (let ((u (formula-to-new-avar (pf "F"))))
      (make-proof-in-imp-intro-form
       u (make-proof-in-and-intro-form
	  (make-proof-in-avar-form u)
	  (make-proof-in-avar-form u)))))))

; (cdp (np atom-to-and-proof))
; (proof-to-expr (np atom-to-imp-proof))

; ((|Cases|
;    ((|Cases| (lambda (|105|) (lambda (|106|) |Truth-Axiom|)))
;     (lambda (|107|) (lambda (|108|) |107|))))
;  ((|Cases| (lambda (|111|) (lambda (|112|) |Truth-Axiom|)))
;   (lambda (|113|) (lambda (|114|) |114|))))

(define (qf-to-term formula)
  (case (tag formula)
    ((atom) (atom-form-to-kernel formula))
    ((predicate)
     (if (formula=? falsity-log formula)
	 (make-term-in-const-form false-const)
	 (myerror "qf-to-term: unexpected predicate"
		  (formula-to-string formula))))
    ((imp)
     (mk-term-in-app-form
      (make-term-in-const-form imp-const)
      (qf-to-term (imp-form-to-premise formula))
      (qf-to-term (imp-form-to-conclusion formula))))
    ((and)
     (mk-term-in-app-form
      (make-term-in-const-form and-const)
      (qf-to-term (and-form-to-left formula))
      (qf-to-term (and-form-to-right formula))))
    (else (myerror "qf-to-term: quantifier free formula expected"
		   (formula-to-string formula)))))

; qf-to-atom-imp-qf-proof: atom(r_C) -> C
; qf-to-qf-imp-atom-proof: C -> atom(r_C)

(define (qf-to-atom-imp-qf-proof formula)
  (case (tag formula)
    ((atom)
     (let ((u (formula-to-new-avar formula)))
       (make-proof-in-imp-intro-form u (make-proof-in-avar-form u))))
    ((predicate)
     (if (formula=? falsity-log formula)
	 (let* ((efq-aconst (global-assumption-name-to-aconst "Efq"))
		(efq-formula (aconst-to-formula efq-aconst))
		(pvar (predicate-form-to-predicate
		       (imp-form-to-conclusion efq-formula))))
	   (proof-subst (make-proof-in-aconst-form efq-aconst)
			pvar (make-cterm (pf "bot"))))
	 (myerror "qf-to-atom-imp-qf-proof: bot expected"
		  (formula-to-string formula))))
    ((imp)
     (let* ((prem (imp-form-to-premise formula))
	    (concl (imp-form-to-conclusion formula))
	    (term1 (qf-to-term prem))
	    (term2 (qf-to-term concl))
	    (term (mk-term-in-app-form
		   (make-term-in-const-form imp-const) term1 term2))
	    (atom (make-atomic-formula term))
	    (u1 (formula-to-new-avar prem))
	    (u (formula-to-new-avar atom)))
       (mk-proof-in-intro-form
	u u1 (make-proof-in-imp-elim-form
	      (qf-to-atom-imp-qf-proof concl)
	      (mk-proof-in-elim-form
	       atom-to-imp-proof
	       term1 term2
	       (make-proof-in-avar-form u)
	       (make-proof-in-imp-elim-form
		(qf-to-qf-imp-atom-proof prem)
		(make-proof-in-avar-form u1)))))))
    ((and)
     (let* ((left (and-form-to-left formula))
	    (right (and-form-to-right formula))
	    (term1 (qf-to-term left))
	    (term2 (qf-to-term right))
	    (term (mk-term-in-app-form
		   (make-term-in-const-form and-const) term1 term2))
	    (atom (make-atomic-formula term))
	    (u (formula-to-new-avar atom))
	    (and-term-proof
	     (mk-proof-in-elim-form
	      atom-to-and-proof term1 term2 (make-proof-in-avar-form u))))
       (make-proof-in-imp-intro-form
	u (make-proof-in-and-intro-form
	   (make-proof-in-imp-elim-form
	    (qf-to-atom-imp-qf-proof left)
	    (make-proof-in-and-elim-left-form and-term-proof))
	   (make-proof-in-imp-elim-form
	    (qf-to-atom-imp-qf-proof right)
	    (make-proof-in-and-elim-right-form and-term-proof))))))
    (else (myerror "qf-to-atom-imp-qf-proof: quantifier free formula expected"
		   (formula-to-string formula)))))

(define (qf-to-qf-imp-atom-proof formula)
  (case (tag formula)
    ((atom)
     (let ((u (formula-to-new-avar formula)))
       (make-proof-in-imp-intro-form u (make-proof-in-avar-form u))))
    ((predicate)
     (if (formula=? falsity-log formula)
	 (let* ((efq-log-aconst (global-assumption-name-to-aconst "Efq-Log"))
		(efq-log-formula (aconst-to-formula efq-log-aconst))
		(pvar (predicate-form-to-predicate
		       (imp-form-to-conclusion efq-log-formula))))
	   (proof-subst (make-proof-in-aconst-form efq-log-aconst)
			pvar (make-cterm (pf "F"))))
	 (myerror "qf-to-qf-imp-atom-proof: bot expected"
		  (formula-to-string formula))))
    ((imp)
     (let* ((prem (imp-form-to-premise formula))
	    (concl (imp-form-to-conclusion formula))
	    (term1 (qf-to-term prem))
	    (term2 (qf-to-term concl))
	    (atom1 (make-atomic-formula term1))
	    (atom2 (make-atomic-formula term2))
	    (v1 (formula-to-new-avar atom1))
	    (u (formula-to-new-avar formula)))
       (make-proof-in-imp-intro-form
	u (mk-proof-in-elim-form
	   imp-to-atom-proof
	   term1 term2
	   (make-proof-in-imp-intro-form
	    v1 (make-proof-in-imp-elim-form
		(qf-to-qf-imp-atom-proof concl)
		(make-proof-in-imp-elim-form
		 (make-proof-in-avar-form u)
		 (make-proof-in-imp-elim-form
		  (qf-to-atom-imp-qf-proof prem)
		  (make-proof-in-avar-form v1)))))))))
    ((and)
     (let* ((left (and-form-to-left formula))
	    (right (and-form-to-right formula))
	    (term1 (qf-to-term left))
	    (term2 (qf-to-term right))
	    (atom1 (make-atomic-formula term1))
	    (atom2 (make-atomic-formula term2))
	    (u (formula-to-new-avar formula)))
       (make-proof-in-imp-intro-form
	u (mk-proof-in-elim-form
	   and-to-atom-proof
	   term1 term2
	   (make-proof-in-and-intro-form
	    (make-proof-in-imp-elim-form
	     (qf-to-qf-imp-atom-proof left)
	     (make-proof-in-and-elim-left-form
	      (make-proof-in-avar-form u)))
	    (make-proof-in-imp-elim-form
	     (qf-to-qf-imp-atom-proof right)
	     (make-proof-in-and-elim-right-form
	      (make-proof-in-avar-form u))))))))
    (else (myerror "qf-to-qf-imp-atom-proof: quantifier free formula expected"
		   (formula-to-string formula)))))

(proof-to-expr (qf-to-qf-imp-atom-proof (pf "T")))
(formula-to-string (proof-to-formula (qf-to-qf-imp-atom-proof (pf "T"))))
(formula-to-string (proof-to-formula (qf-to-qf-imp-atom-proof (pf "F"))))
(formula-to-string (proof-to-formula (qf-to-qf-imp-atom-proof (pf "boole"))))
(formula-to-string (proof-to-formula (qf-to-qf-imp-atom-proof (pf "bot"))))
(formula-to-string (proof-to-formula
		    (qf-to-qf-imp-atom-proof (pf "boole -> bot"))))
(formula-to-string (proof-to-formula
		    (np (qf-to-qf-imp-atom-proof (pf "boole1 -> boole2")))))
(formula-to-string (proof-to-formula
		    (np (qf-to-qf-imp-atom-proof (pf "boole1 & boole2")))))
(formula-to-string
 (proof-to-formula
  (np (qf-to-qf-imp-atom-proof (pf "(boole1 & boole2) -> boole")))))

(formula-to-string
 (proof-to-formula
  (np (qf-to-qf-imp-atom-proof (pf "(boole1 -> boole2) -> boole")))))

(formula-to-string
 (proof-to-formula
  (np (qf-to-qf-imp-atom-proof
       (pf "((boole1 -> boole2) -> boole3) -> boole")))))

(formula-to-string
 (proof-to-formula
  (np (qf-to-atom-imp-qf-proof
       (pf "((boole1 -> boole2) -> boole3) -> boole")))))

; qf-to-qf-cases-proof: ((C -> bot) -> atrX^) -> (C -> atrX^) -> atrX^

(define (qf-to-qf-cases-proof formula)
  (let* ((neg-formula (make-imp formula falsity-log))
	 (u1 (formula-to-new-avar (make-imp neg-formula atr-x-formula)))
	 (u2 (formula-to-new-avar (make-imp formula atr-x-formula)))
	 (term (qf-to-term formula))
	 (atom (make-atomic-formula term))
	 (v1 (formula-to-new-avar (make-imp atom falsity-log)))
	 (v2 (formula-to-new-avar atom))
	 (w (formula-to-new-avar formula)))
    (mk-proof-in-intro-form
     u1 u2 (mk-proof-in-elim-form
	    dec-cases-proof
	    term
	    (make-proof-in-imp-intro-form
	     v1 (make-proof-in-imp-elim-form
		 (make-proof-in-avar-form u1)
		 (make-proof-in-imp-intro-form
		  w (make-proof-in-imp-elim-form
		     (make-proof-in-avar-form v1)
		     (make-proof-in-imp-elim-form
		      (qf-to-qf-imp-atom-proof formula)
		      (make-proof-in-avar-form w))))))
	    (make-proof-in-imp-intro-form
	     v2 (make-proof-in-imp-elim-form
		 (make-proof-in-avar-form u2)
		 (make-proof-in-imp-elim-form
		  (qf-to-atom-imp-qf-proof formula)
		  (make-proof-in-avar-form v2))))))))
     
; To implement Lemma 3.1, we need the following procedures, to construct
; proofs from formulas
; N_D: ((D -> bot) -> X) -> D^X   for D relevant
; M_D: D -> D^X              
; K_G: G -> G^X                   for G irrelevant
; H_G: G^X -> (G -> X) -> X 

(define (atr-rel-definite-proof formula)
  (if
   (atr-definite? formula)
   (if
    (atr-relevant? formula)
    (case (tag formula)
      ((predicate) ;falsity-log
       (let ((u (formula-to-new-avar
		 (mk-imp (mk-imp falsity-log falsity-log) atr-x-formula)))
	     (v (formula-to-new-avar falsity-log)))
	 (make-proof-in-imp-intro-form
	  u
	  (make-proof-in-imp-elim-form
	   (make-proof-in-avar-form u)
	   (make-proof-in-imp-intro-form
	    v
	    (make-proof-in-avar-form v))))))
      ((imp)
       (let* ((prem (imp-form-to-premise formula))
	      (concl (imp-form-to-conclusion formula))
	      (prem-x (formula-subst prem falsity-log-pvar atr-x-cterm))
	      (concl-x (formula-subst concl falsity-log-pvar atr-x-cterm))
	      (u1 (formula-to-new-avar prem-x))
	      (u2 (formula-to-new-avar
		   (mk-imp (mk-neg-log formula) atr-x-formula)))
	      (u3 (formula-to-new-avar (mk-neg-log concl)))
	      (u4 (formula-to-new-avar formula))
	      (u5 (formula-to-new-avar prem)))
	 (mk-proof-in-intro-form
	  u2 u1
	  (make-proof-in-imp-elim-form
	   (atr-rel-definite-proof concl)
	   (make-proof-in-imp-intro-form
	    u3
	    (mk-proof-in-elim-form
	     (atr-arb-goal-proof prem)
	     (make-proof-in-avar-form u1)
	     (make-proof-in-imp-intro-form
	      u5
	      (make-proof-in-imp-elim-form
	       (make-proof-in-avar-form u2)
	       (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 u5))))))))))))
      ((all)
       (let* ((var (all-form-to-var formula))
	      (kernel (all-form-to-kernel formula))
	      (kernel-x
	       (formula-subst kernel falsity-log-pvar atr-x-cterm))
	      (u2 (formula-to-new-avar
		   (mk-imp (mk-neg-log formula) atr-x-formula)))
	      (u3 (formula-to-new-avar (mk-neg-log kernel)))
	      (u4 (formula-to-new-avar formula)))
	 (mk-proof-in-intro-form
	  u2 var
	  (make-proof-in-imp-elim-form
	   (atr-rel-definite-proof kernel)
	   (make-proof-in-imp-intro-form
	    u3
	    (make-proof-in-imp-elim-form
	     (make-proof-in-avar-form u2)
	     (make-proof-in-imp-intro-form
	      u4
	      (make-proof-in-imp-elim-form
	       (make-proof-in-avar-form u3)
	       (make-proof-in-all-elim-form
		(make-proof-in-avar-form u4)
		(make-term-in-var-form var))))))))))
      ((allnc)
       (let* ((var (allnc-form-to-var formula))
	      (kernel (allnc-form-to-kernel formula))
	      (kernel-x
	       (formula-subst kernel falsity-log-pvar atr-x-cterm))
	      (u2 (formula-to-new-avar
		   (mk-imp (mk-neg-log formula) atr-x-formula)))
	      (u3 (formula-to-new-avar (mk-neg-log kernel)))
	      (u4 (formula-to-new-avar formula)))
	 (mk-proof-in-nc-intro-form
	  u2 var
	  (make-proof-in-imp-elim-form
	   (atr-rel-definite-proof kernel)
	   (make-proof-in-imp-intro-form
	    u3
	    (make-proof-in-imp-elim-form
	     (make-proof-in-avar-form u2)
	     (make-proof-in-imp-intro-form
	      u4
	      (make-proof-in-imp-elim-form
	       (make-proof-in-avar-form u3)
	       (make-proof-in-allnc-elim-form
		(make-proof-in-avar-form u4)
		(make-term-in-var-form var))))))))))
      ((and tensor ex exca excl)
       (myerror "atr-rel-definite-proof: unexpected formula"
		(formula-to-string formula)))
      (else (myerror "atr-rel-definite-proof: formula expected" formula)))
    (myerror "atr-rel-definite-proof: relevant formula expected"
	     (formula-to-string formula)))
   (myerror "atr-rel-definite-proof: definite formula expected"
	    (formula-to-string formula))))

; (cdp (atr-rel-definite-proof (mk-imp atr-x-formula falsity-log)))
; (cdp (atr-rel-definite-proof falsity-log))
; (cdp (atr-rel-definite-proof
;       (mk-all (type-to-new-var (make-alg "boole")) falsity-log)))

(define (atr-arb-definite-proof formula)
  (if
   (atr-definite? formula)
   (if
    (atr-relevant? formula)
    (let* ((u1 (formula-to-new-avar (mk-neg-log formula)))
	   (u2 (formula-to-new-avar formula))
	   (efq-log-aconst (global-assumption-name-to-aconst "Efq-Log"))
	   (concl (imp-form-to-conclusion (aconst-to-formula efq-log-aconst)))
	   (pvar (predicate-form-to-predicate concl))
	   (efq-log-x-proof
	    (proof-subst (make-proof-in-aconst-form efq-log-aconst)
			 pvar atr-x-cterm)))
      (make-proof-in-imp-intro-form
       u2
       (make-proof-in-imp-elim-form
	(atr-rel-definite-proof formula)
	(make-proof-in-imp-intro-form
	 u1
	 (make-proof-in-imp-elim-form
	  efq-log-x-proof
	  (make-proof-in-imp-elim-form
	   (make-proof-in-avar-form u1)
	   (make-proof-in-avar-form u2)))))))
    (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)) ;irrelevant
	      (concl (imp-form-to-conclusion formula)) ;also irrelevant
	      (prem-x (formula-subst prem falsity-log-pvar atr-x-cterm))
	      (concl-x (formula-subst concl falsity-log-pvar atr-x-cterm))
	      (u1 (formula-to-new-avar formula))
	      (u2 (formula-to-new-avar prem-x)))
	 (mk-proof-in-intro-form
	  u1 u2
	  (make-proof-in-imp-elim-form
	   (atr-arb-definite-proof concl)
	   (make-proof-in-imp-elim-form
	    (make-proof-in-avar-form u1)
	    (make-proof-in-imp-elim-form
	     (atr-irrel-goal-proof prem)
	     (make-proof-in-avar-form u2)))))))
      ((all)
       (let* ((var (all-form-to-var formula))
	      (kernel (all-form-to-kernel formula))
	      (u (formula-to-new-avar formula)))
	 (mk-proof-in-intro-form
	  u var
	  (make-proof-in-imp-elim-form
	   (atr-arb-definite-proof 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)))
	 (mk-proof-in-nc-intro-form
	  u var
	  (make-proof-in-imp-elim-form
	   (atr-arb-definite-proof kernel)
	   (make-proof-in-allnc-elim-form
	    (make-proof-in-avar-form u)
	    (make-term-in-var-form var))))))
      ((and tensor ex exca excl)
       (myerror "atr-arb-definite-proof: unexpected formula"
		(formula-to-string formula)))
      (else (myerror "atr-arb-definite-proof: formula expected" formula))))
   (myerror "atr-arb-definite-proof: definite formula expected"
	    (formula-to-string formula))))

(define (atr-irrel-goal-proof formula)
  (if
   (atr-goal? formula)
   (if
    (atr-relevant? formula)
    (myerror "atr-irrel-goal-proof: irrelevant formula expected"
	     (formula-to-string 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)) ;irrelevant
	      (concl (imp-form-to-conclusion formula)) ;also irrelevant
	      (prem-x (formula-subst prem falsity-log-pvar atr-x-cterm))
	      (concl-x (formula-subst concl falsity-log-pvar atr-x-cterm))
	      (u1 (formula-to-new-avar (mk-imp prem-x concl-x)))
	      (u2 (formula-to-new-avar prem)))
; 	      (u2 (formula-to-new-avar (mk-neg-log prem))))
	 (mk-proof-in-intro-form
	  u1 u2
	  (make-proof-in-imp-elim-form
	   (atr-irrel-goal-proof concl)
	   (make-proof-in-imp-elim-form
	    (make-proof-in-avar-form u1)
	    (make-proof-in-imp-elim-form
	     (atr-arb-definite-proof prem)
	     (make-proof-in-avar-form u2)))))))
      ((all)
       (let* ((var (all-form-to-var formula))
	      (kernel (all-form-to-kernel formula))
	      (formula-x
	       (formula-subst formula falsity-log-pvar atr-x-cterm))
	      (u (formula-to-new-avar formula-x)))
	 (make-proof-in-imp-intro-form
	  u (make-proof-in-all-intro-form
	     var (make-proof-in-imp-elim-form
		  (atr-irrel-goal-proof 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))
	      (formula-x
	       (formula-subst formula falsity-log-pvar atr-x-cterm))
	      (u (formula-to-new-avar formula-x)))
	 (make-proof-in-imp-intro-form
	  u (make-proof-in-allnc-intro-form
	     var (make-proof-in-imp-elim-form
		  (atr-irrel-goal-proof kernel)
		  (make-proof-in-allnc-elim-form
		   (make-proof-in-avar-form u)
		   (make-term-in-var-form var)))))))
      (else (myerror "atr-irrel-goal-proof: formula expected" formula))))
   (myerror "atr-irrel-goal-proof: goal formula expected"
	    (formula-to-string formula))))

(define (atr-arb-goal-proof formula)
  (if
   (atr-goal? formula)
   (if
    (atr-relevant? formula)
    (case (tag formula)
      ((predicate) ;falsity-log
       (let ((u1 (formula-to-new-avar atr-x-formula))
	     (u2 (formula-to-new-avar (mk-imp formula atr-x-formula))))
	 (mk-proof-in-intro-form
	  u1 u2
	  (make-proof-in-avar-form u1))))
      ((imp)
       (let* ((prem (imp-form-to-premise formula))
	      (concl (imp-form-to-conclusion formula))
	      (prem-x (formula-subst prem falsity-log-pvar atr-x-cterm))
	      (concl-x (formula-subst concl falsity-log-pvar atr-x-cterm))
	      (u1 (formula-to-new-avar (mk-imp prem-x concl-x)))
	      (u2 (formula-to-new-avar (mk-imp formula atr-x-formula)))
	      (u3 (formula-to-new-avar (mk-neg-log prem)))
	      (u4 (formula-to-new-avar prem))
	      (u5 (formula-to-new-avar concl))
	      (u6 (formula-to-new-avar prem-x))
	      (proof-of-prem-x-to-x
	       (make-proof-in-imp-intro-form
		u6
		(mk-proof-in-elim-form
		 (atr-arb-goal-proof concl)
		 (make-proof-in-imp-elim-form
		  (make-proof-in-avar-form u1)
		  (make-proof-in-avar-form u6))
		 (make-proof-in-imp-intro-form
		  u5
		  (make-proof-in-imp-elim-form
		   (make-proof-in-avar-form u2)
		   (make-proof-in-imp-intro-form
		    u4
		    (make-proof-in-avar-form u5)))))))
	      (renamed-elab-list
	       (formula-and-elab-path-to-renamed-elab-list concl '() '()))
	      (context (map (lambda (x) (if (formula? x)
					    (formula-to-new-avar x)
					    x))
			    (reverse (cdr (reverse renamed-elab-list)))))
	      (proof-of-neg-prem-to-x
	       (make-proof-in-imp-intro-form
		u3
		(make-proof-in-imp-elim-form
		 (make-proof-in-avar-form u2)
		 (apply mk-proof-in-intro-form
			(append (list u4)
				context
				(list (make-proof-in-imp-elim-form
				       (make-proof-in-avar-form u3)
				       (make-proof-in-avar-form u4)))))))))
	 (if
	  (atr-relevant? prem)
	  (mk-proof-in-intro-form
	   u1 u2
	   (make-proof-in-imp-elim-form
	    proof-of-prem-x-to-x
	    (make-proof-in-imp-elim-form
	     (atr-rel-definite-proof prem)
	     proof-of-neg-prem-to-x)))
	  (mk-proof-in-intro-form
	   u1 u2
	   (mk-proof-in-elim-form
	    (qf-to-qf-cases-proof prem)
	    proof-of-neg-prem-to-x
	    (make-proof-in-imp-intro-form
	     u4
	     (make-proof-in-imp-elim-form
	      proof-of-prem-x-to-x
	      (make-proof-in-imp-elim-form
	       (atr-arb-definite-proof prem)
	       (make-proof-in-avar-form u4))))))))))
    (let* ((formula-x
	    (formula-subst formula falsity-log-pvar atr-x-cterm))
	   (u1 (formula-to-new-avar (mk-imp formula atr-x-formula)))
	   (u2 (formula-to-new-avar formula-x)))
      (mk-proof-in-intro-form
       u2 u1
       (make-proof-in-imp-elim-form
	(make-proof-in-avar-form u1)
	(make-proof-in-imp-elim-form
	 (atr-irrel-goal-proof formula)
	 (make-proof-in-avar-form u2))))))
   (myerror "atr-arb-goal-proof: goal formula expected"
	    (formula-to-string formula))))

; We now implement Lemma 3.2

(define (atr-goals-to-x-proof . goals)
  (let* ((goals-to-x (apply mk-imp (append goals (list atr-x-formula))))
	 (u (formula-to-new-avar goals-to-x))
	 (goals-x
	  (map (lambda (f) (formula-subst f falsity-log-pvar atr-x-cterm))
	       goals))
	 (goal-x-avars (map (lambda (f) (formula-to-new-avar f)) goals-x))
	 (goal-avars (map (lambda (f) (formula-to-new-avar f)) goals)))
    (do ((gs (reverse goals) (cdr gs))
	 (vs (reverse goal-x-avars) (cdr vs))
	 (ws (reverse goal-avars) (cdr ws))
	 (proof-of-x
	  (apply mk-proof-in-elim-form
		 (cons (make-proof-in-avar-form u)
		       (map make-proof-in-avar-form goal-avars)))
	  (mk-proof-in-elim-form
	   (atr-arb-goal-proof (car gs))
	   (make-proof-in-avar-form (car vs))
	   (make-proof-in-imp-intro-form
	    (car ws)
	    proof-of-x))))
	((null? gs)
	 (apply mk-proof-in-intro-form
		(cons u (append goal-x-avars (list proof-of-x))))))))

; The first part of Theorem 3.3:

(define (atr-min-excl-proof-to-x-proof min-excl-proof)
  (let* ((formula (unfold-formula (proof-to-formula min-excl-proof)))
	 (params-and-kernel (all-form-to-vars-and-final-kernel formula))
	 (params (car params-and-kernel))
	 (kernel (cadr params-and-kernel))
	 (prems (imp-form-to-premises kernel))
	 (rev-prems (reverse prems))
	 (wrong-formula (car rev-prems))
	 (vars-and-final-kernel
	  (all-form-to-vars-and-final-kernel wrong-formula))
	 (vars (car vars-and-final-kernel))
	 (goals (imp-form-to-premises (cadr vars-and-final-kernel)))
	 (ds (reverse (cdr rev-prems)))
	 (subst-proof
	  (proof-subst min-excl-proof falsity-log-pvar atr-x-cterm))
	 (us (map formula-to-new-avar ds))
	 (wrong-formula-with-x
	   (apply mk-all
		  (append vars
			  (list (apply mk-imp
				       (append goals
					       (list atr-x-formula)))))))
	 (u (formula-to-new-avar wrong-formula-with-x))
	 (d-x-proofs (map (lambda (d u)
			    (make-proof-in-imp-elim-form
			     (atr-arb-definite-proof d)
			     (make-proof-in-avar-form u)))
			  ds us))
	 (wrong-formula-x-proof
	  (apply mk-proof-in-intro-form
		 (append vars
			 (list (make-proof-in-imp-elim-form
				(apply atr-goals-to-x-proof goals)
				(apply mk-proof-in-elim-form
				       (cons (make-proof-in-avar-form u)
					     (map make-term-in-var-form
						  vars))))))))
	 (proof-of-x
	  (apply mk-proof-in-elim-form
		 (append (list subst-proof)
			 (map make-term-in-var-form params)
			 d-x-proofs
			 (list wrong-formula-x-proof)))))
    (apply mk-proof-in-intro-form
	   (append params us (list u proof-of-x)))))

; The second part of Theorem 3.3:

(define (atr-min-excl-proof-to-intuit-ex-proof min-excl-proof)
  (let* ((x-proof (atr-min-excl-proof-to-x-proof min-excl-proof))
	 (formula (unfold-formula (proof-to-formula min-excl-proof)))
	 (params-and-kernel (all-form-to-vars-and-final-kernel formula))
	 (params (car params-and-kernel))
	 (kernel (cadr params-and-kernel))
	 (prems (imp-form-to-premises kernel))
	 (rev-prems (reverse prems))
	 (wrong-formula (car rev-prems))
	 (vars-and-final-kernel
	  (all-form-to-vars-and-final-kernel wrong-formula))
	 (vars (car vars-and-final-kernel))
	 (goals (imp-form-to-premises (cadr vars-and-final-kernel)))
	 (ds (reverse (cdr rev-prems)))
	 (ex-formula (apply mk-ex (append vars (list (apply mk-and goals)))))
	 (ex-cterm (make-cterm ex-formula))
	 (psubst (make-subst-wrt pvar-cterm-equal? atr-x-pvar ex-cterm))
	 (subst-x-proof (proof-substitute x-proof psubst))
	 (us (map formula-to-new-avar ds))
	 (vs (map formula-to-new-avar goals))
	 (proof-of-goals (apply mk-proof-in-and-intro-form
				(map make-proof-in-avar-form vs)))
	 (proof-of-ex-intro-formula ;all vars.Gs -> ex vars Gs
	  (apply mk-proof-in-intro-form
		 (append
		  vars vs
		  (list (apply mk-proof-in-ex-intro-form
			       (append (map make-term-in-var-form vars)
				       (list ex-formula proof-of-goals))))))))
    (apply mk-proof-in-intro-form
	   (append params us
		   (list (apply mk-proof-in-elim-form
				(append (list subst-x-proof)
					(map make-term-in-var-form params)
					(map make-proof-in-avar-form us)
					(list proof-of-ex-intro-formula))))))))

; Code discarded 02-12-21
; (define (atr-min-excl-proof-to-intuit-ex-proof min-excl-proof)
;   (let* ((formula (unfold-formula (proof-to-formula min-excl-proof)))
; 	 (params-and-kernel (all-form-to-vars-and-final-kernel formula))
; 	 (params (car params-and-kernel))
; 	 (kernel (cadr params-and-kernel))
; 	 (prems (imp-form-to-premises kernel))
; 	 (rev-prems (reverse prems))
; 	 (wrong-formula (car rev-prems))
; 	 (vars-and-final-kernel
; 	  (all-form-to-vars-and-final-kernel wrong-formula))
; 	 (vars (car vars-and-final-kernel))
; 	 (goals (imp-form-to-premises (cadr vars-and-final-kernel)))
; 	 (ds (reverse (cdr rev-prems)))
; 	 (ex-formula (apply mk-ex (append vars (list (apply mk-and goals)))))
; 	 (ex-cterm (make-cterm ex-formula))
; 	 (subst-proof (proof-subst min-excl-proof falsity-log-pvar ex-cterm))
; 	 (us (map formula-to-new-avar ds))
; 	 (wrong-formula-with-x
; 	   (apply mk-all
; 		  (append vars
; 			  (list (apply mk-imp
; 				       (append goals
; 					       (list atr-x-formula)))))))
; 	 (u (formula-to-new-avar wrong-formula-with-x))
; 	 (d-x-proofs (map (lambda (d u)
; 			    (make-proof-in-imp-elim-form
; 			     (atr-arb-definite-proof d)
; 			     (make-proof-in-avar-form u)))
; 			  ds us))
; 	 (wrong-formula-x-proof
; 	  (apply mk-proof-in-intro-form
; 		 (append vars
; 			 (list (make-proof-in-imp-elim-form
; 				(apply atr-goals-to-x-proof goals)
; 				(apply mk-proof-in-elim-form
; 				       (cons (make-proof-in-avar-form u)
; 					     (map make-term-in-var-form
; 						  vars))))))))
; 	 (proof-of-x
; 	  (apply mk-proof-in-elim-form
; 		 (cons (proof-subst min-excl-proof
; 				    falsity-log-pvar atr-x-cterm)
; 		       (append (map make-term-in-var-form params)
; 			       d-x-proofs
; 			       (list wrong-formula-x-proof)))))
; 	 (vs (map formula-to-new-avar goals))
; 	 (proof-of-goals (apply mk-proof-in-and-intro-form
; 				(map make-proof-in-avar-form vs)))
; 	 (proof-of-ex-intro-formula ;all vars.Gs -> ex vars Gs
; 	  (apply mk-proof-in-intro-form
; 		 (append
; 		  vars vs
; 		  (list (apply mk-proof-in-ex-intro-form
; 			       (append (map make-term-in-var-form vars)
; 				       (list ex-formula proof-of-goals)))))))
; 	 (subst-proof-of-x
; 	  (proof-substitute
; 	   proof-of-x
; 	   (append (make-subst-wrt pvar-cterm-equal? atr-x-pvar ex-cterm)
; 		   (make-subst-wrt avar-proof-equal?
; 				   u proof-of-ex-intro-formula)))))
;     (apply mk-proof-in-intro-form
; 	   (append params (list subst-proof-of-x)))))
    
; We make sure that PVAR-TO-TVAR-ALIST assigns nulltype to
; falsity-log-pvar.  

(set! PVAR-TO-TVAR-ALIST
  (cons (list falsity-log-pvar (make-tconst "nulltype")) PVAR-TO-TVAR-ALIST))

; In (atr-proof-to-extracted-term proof type) we update
; PVAR-TO-TVAR-ALIST by assigning type to atr-x-pvar.  Reason: the
; special role of the predicate variable X; see Section 4 in the paper.

(define (atr-proof-to-extracted-term proof type)
  (if (formula-of-nulltype? (proof-to-formula proof))
      (myerror "atr-proof-to-extracted-term:"
	       "formula with computational content expected"
	       (formula-to-string formula)))
  (set! PVAR-TO-TVAR-ALIST (cons (list atr-x-pvar type) PVAR-TO-TVAR-ALIST))
  (proof-to-extracted-term proof))

; We now implement the finer analysis of the extracted program, from
; Section 5 of the APAL paper.  

; The t_j and s_i needed in Theorem 5.1 are identified in Theorem 5.2 as
; the extracted terms of the N_D and H_G, respectively.  The r and AAA
; in Theorem 5.1 depend on the problem at hand.  In most examples AAA is
; {y|A_0(y)} and r is lambda y y.

; Let minl-excl-proof be a proof of D_1 ->...D_n -> all y.((G -> bot) -> bot)
; where D_1,...,D_k are arbitrary formulas
;       D_{k+1},...,D_n are definite formulas
;       G is a goal formulas.   
; Moreover let realizers-for-nondefinite-formulas = t1,...,t_k be such that
; t_i mr D_i^atr-X. Then atr-min-excl-proof-and-realizers-to-extracted-term 
; yields an extracted term et such that Ds->G[y:=et].

(define (atr-min-excl-proof-to-structured-extracted-term
	 min-excl-proof . realizers-for-nondefinite-formulas-and-opt-realizer)
  (if (not (min-excl-proof? min-excl-proof))
      (myerror "atr-min-excl-proof-to-structured-extracted-term:"
	       "unexpected proof"))
  (let* ((formula (unfold-formula (proof-to-formula min-excl-proof)))
	 (params-and-kernel (all-form-to-vars-and-final-kernel formula))
	 (params (car params-and-kernel))
	 (kernel (cadr params-and-kernel))
	 (prems (imp-form-to-premises kernel))
	 (rev-prems (reverse prems))
	 (wrong-formula (car rev-prems))
	 (vars-and-final-kernel
	  (all-form-to-vars-and-final-kernel wrong-formula))
	 (vars (car vars-and-final-kernel))
	 (goals (imp-form-to-premises (cadr vars-and-final-kernel)))
	 (ds (reverse (cdr rev-prems)))
	 (definite-ds (list-transform-positive ds atr-definite?))
	 (length-of-nondefinite-ds (- (length ds) (length definite-ds)))
	 (realizers-for-nondefinite-formulas
	  (list-head realizers-for-nondefinite-formulas-and-opt-realizer
		     length-of-nondefinite-ds))
	 (opt-realizer
	  (list-tail realizers-for-nondefinite-formulas-and-opt-realizer
		     length-of-nondefinite-ds))
	 (type (apply mk-star (map var-to-type vars)))
	 (proofs ;of G_i^X -> (G_i -> X) -> X 
	  (map (lambda (x) (nbe-normalize-proof (atr-arb-goal-proof x)))
	       goals))
	 (eterms ;the [[H_{G_i}]] =: s_i
	  (map (lambda (x) (atr-proof-to-extracted-term x type)) proofs))
	 (types (map term-to-type eterms))
	 (arg-types (map arrow-form-to-arg-type types))
	 (ws (map type-to-new-var arg-types))
	 (app-term ;<\vec{y}>, or r \vec{y}
	  (if (null? opt-realizer)
	      (apply mk-term-in-pair-form
		     (map make-term-in-var-form vars))
	      (let ((r (car opt-realizer)))
		(apply mk-term-in-app-form
		       (cons r (map make-term-in-var-form vars))))))
	 (long-app-term
	  (do ((flas (reverse (map proof-to-formula proofs)) (cdr flas))
	       (s-list (reverse eterms) (cdr s-list))
	       (w-list (reverse ws) (cdr w-list))
	       (res app-term
		    (if
		     (formula-of-nulltype? ;G_i^X
		      (imp-form-to-premise (car flas)))
		     (make-term-in-app-form (car s-list) res)
		     (mk-term-in-app-form
		      (car s-list) (make-term-in-var-form (car w-list)) res))))
	      ((null? s-list) res)))
	 (proper-ws
	  (do ((flas (reverse (map proof-to-formula proofs)) (cdr flas))
	       (w-list (reverse ws) (cdr w-list))
	       (res '() (if (formula-of-nulltype? ;G_i^X
			     (imp-form-to-premise (car flas)))
			    res
			    (cons (car w-list) res))))
	      ((null? flas) res)))
	 (s (apply mk-term-in-abst-form
		   (append vars proper-ws (list long-app-term))))
	 (min-excl-proof-with-params
	  (apply mk-proof-in-elim-form
		 (cons min-excl-proof
		       (map make-term-in-var-form params))))
	 (subst-proof (proof-subst min-excl-proof-with-params
				   falsity-log-pvar atr-x-cterm))
	 (eterm (atr-proof-to-extracted-term subst-proof type))
	 (subst-definite-ds
	  (map (lambda (x) (formula-subst x falsity-log-pvar atr-x-cterm))
	       definite-ds))
	 (proper-ts
	  (do ((l (reverse definite-ds) (cdr l))
	       (subst-l (reverse subst-definite-ds) (cdr subst-l))
	       (res '() (if (formula-of-nulltype? (car subst-l))
			    res
			    (cons (atr-proof-to-extracted-term
				   (atr-arb-definite-proof (car l)) type)
				  res))))
	      ((null? l) res))))
    (apply
     mk-term-in-abst-form
     (append params
	     (list (apply mk-term-in-app-form
			  (cons eterm
				(append realizers-for-nondefinite-formulas
					proper-ts
					(list s)))))))))

(define (min-excl-proof? proof)
  (let* ((formula (unfold-formula (proof-to-formula proof)))
	 (params-and-kernel (all-form-to-vars-and-final-kernel formula))
	 (params (car params-and-kernel))
	 (kernel (cadr params-and-kernel))
	 (prems (imp-form-to-premises kernel))
	 (concl (imp-form-to-final-conclusion kernel))
	 (rev-prems (if (null? prems)
			(myerror "min-excl-proof?: unexpected formula"
				 (formula-to-string formula))
			(reverse prems)))
	 (wrong-formula (car rev-prems))
	 (vars-and-final-kernel
	  (all-form-to-vars-and-final-kernel wrong-formula))
	 (vars (car vars-and-final-kernel))
	 (final-kernel (cadr vars-and-final-kernel))
	 (goals (imp-form-to-premises (cadr vars-and-final-kernel)))
	 (ds (reverse (cdr rev-prems))))
    (if (not (formula=? concl falsity-log))
	(myerror "min-excl-proof?: falsity-log expected"
		 (formula-to-string concl)))
    (if (not (formula=?
	      (imp-form-to-final-conclusion final-kernel) falsity-log))
	(myerror "min-excl-proof?: falsity-log expected"
		 (formula-to-string
		  (imp-form-to-final-conclusion final-kernel))))
    (if (not (apply and-op (map atr-goal? goals)))
	(myerror "min-excl-proof?: goal formulas expected"
		 (map formula-to-string goals)))
    (if (or (null? vars) (null? goals))
	(myerror "min-excl-proof?: unexpected formula"
		 (formula-to-string formula)))
    #t))

