;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MDH -- updated 071117; MDH -- created around 060804 (4 August 2006)
;; This module is essential to the Hereditary Extensional Equality examples
;; Translation of closed terms to \Sigma\Pi terms and building of proofs
;; that such a closed \Sigma\Pi term is h-e-equal to itself
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(newline)
(display "****************************************")
(newline)
(display "*****     BEGIN loading  HEEQ-DEF  module ...")
(newline)
(display "*****************************************")
(newline)

(set! DEBUG-HEEQ #f)
(comment "***  DEBUG-HEEQ flag was set to FALSE ***")
(set! Zero-COUNT 0)
(comment "***  Zero-COUNT counter set to ZERO ***")
(set! Succ-COUNT 0)
(comment "***  Succ-COUNT counter set to ZERO ***")
(set! Plus-COUNT 0)
(comment "***  Plus-COUNT counter set to ZERO ***")
(set! Pi-COUNT 0)
(comment "***  Pi-COUNT counter set to ZERO ***")
(set! Sigma-COUNT 0)
(comment "***  Sigma-COUNT counter set to ZERO ***")
(set! Rec-COUNT 0)
(comment "***  Rec-COUNT counter set to ZERO ***")
(set! Strange-COUNT 0)
(comment "***  Strange-COUNT counter set to ZERO ***")

(define (SPR-count)
    (begin
               (newline)
	 (display "***********************************************")
	 (newline)
	 (display "*** Number of Sigma IS  ") (display Sigma-COUNT)
	 (newline)
	  (display "*** Number of Pi IS  ") (display Pi-COUNT)
	  (newline)
	  (display "*** Number of Rec IS  ") (display Rec-COUNT)
	 (newline)
	 (display "***********************************************")
	 (newline)
	 ))

(define (abstraction-var-count tm)
    (case (tag tm)  
          ((term-in-abst-form) 
	   (+ 1 (abstraction-var-count (term-in-abst-form-to-kernel tm))))
          (else 0)))

(add-tvar-name "beta")
(add-var-name "b" (py "beta"))
(add-var-name "c" (py "nat=>beta=>beta"))
(add-predconst-name "Heeq" (make-arity (py "alpha") (py "alpha")))


(av "g" (py "(nat=>nat)=>nat"))
(av "G" (py "nat=>nat=>nat"))
(av "h" (py "(nat=>nat)=>nat=>nat"))
(av "H" (py "(nat=>nat)=>(nat=>nat)=>nat=>nat"))
(av "R" (py "nat=>nat=>(nat=>nat=>nat)=>nat"))

(aga "Zero-Eq-Trans" (pf "allnc m,n,k. m=n -> n=k -> m=k"))
(av "f" (py "nat=>nat"))
(aga "Zero-Eq-Ext" (pf "allnc f,m,n. m=n -> f m=f n"))
(add-var-name "d" (py "nat=>alpha"))
(aga "Alpha-Eq-Ext" (pf "allnc d,m,n. m=n -> Equal (d m) (d n)"))
(aga "NatPlus-Ext" 
     (pf "all n1,n2.n1=n2 -> all m1,m2.m1=m2 -> n1+m1=n2+m2"))
(aga "R-Ext" 
     (pf "allnc R,G,n1,n2,m1,m2. n1=n2 -> m1=m2 -> R n1 m1 G = R n2 m2 G "))

(define (finite-type? typ)
  (if (not (type? typ))
      (myerror "finite-type?: type argument expected" typ)
      (finite-type?-aux typ)))
(define (finite-type?-aux typ)
  (case (tag typ)
    ((tvar) (equal? typ (py "beta")))
    ((alg) (string=? (type-to-string typ) "nat"))
    ((arrow) (and (finite-type?-aux (arrow-form-to-arg-type typ))
		  (finite-type?-aux (arrow-form-to-val-type typ))))
    (else #f)))

(define (make-heeq-bis tm1 tm2)
  (if (not (term? tm1))
      (myerror "make-heeq-bis: 1st argument is not term" tm1)
      (if (not (term? tm2))
	  (myerror "make-heeq-bis: 2nd argument is not term" tm2)
	  (let*((typ1 (term-to-type tm1))
		(typ2 (term-to-type tm2)))
	    (if (not (equal? typ1 typ2))
		(myerror "make-heeq-bis: arguments have different types" typ1 typ2)
		(make-heeq-aux tm1 tm2 typ1))))))

(define (make-heeq tm1 tm2)
  (if (not (term? tm1))
      (myerror "make-heeq: 1st argument is not term" tm1)
      (if (not (term? tm2))
	  (myerror "make-heeq: 2nd argument is not term" tm2)
	  (let*((typ1 (term-to-type tm1))
		(typ2 (term-to-type tm2)))
	    (if (not (equal? typ1 typ2))
		(myerror "make-heeq: arguments have different types" typ1 typ2)
		(if (not (finite-type? typ1))
		    (myerror "make-heeq: term types are not in Goedel's T"
			     (type-to-string typ1))
		    (make-heeq-aux tm1 tm2 typ1)))))))

(define (make-heeq-aux tm1 tm2 typ)
 (begin
;    (nldisplay "make-heeq-aux BEG:" (term-to-string tm1) 
; 	      (term-to-string tm2) (type-to-string typ))
  (case (tag typ)
;     ((tvar) (make-predicate-formula 
; 	       (make-predconst (make-arity (py "alpha") (py "alpha"))
; 			       (make-subst (py "alpha") typ)
; 			       -1 "Heeq")
; 	       tm1 tm2))
    ((alg) (make-atomic-formula 
	     (mk-term-in-app-form 
	       (make-term-in-const-form 
		 (finalg-to-=-const typ)) tm1 tm2)))
    ((arrow) 
       (let*((arg_typ (arrow-form-to-arg-type typ))
	     (va1 (type-to-new-var arg_typ))
	     (prem_tm1 (make-term-in-var-form va1))
	     (va2 (type-to-new-var arg_typ))
	     (prem_tm2 (make-term-in-var-form va2))
	     (prem (make-heeq-aux prem_tm1 prem_tm2 arg_typ))
	     (val_typ (arrow-form-to-val-type typ))
	     (conc_tm1 (make-term-in-app-form tm1 prem_tm1))
	     (conc_tm2 (make-term-in-app-form tm2 prem_tm2))
	     (conc (make-heeq-aux conc_tm1 conc_tm2 val_typ))	     
	     (imp-fmla (make-imp prem conc))
	     (fin-fmla (mk-all va1 va2 imp-fmla)))
	 (begin fin-fmla)))
    (else (myerror "make-heeq-aux: unexpected type argument" typ)))))

(define (make-heeq-va va1 va2)
  (if (not (var? va1))
      (myerror "make-heeq-va: 1st argument is not var" va1)
      (if (not (var? va2))
	  (myerror "make-heeq-va: 2nd argument is not var" va2)
	  (make-heeq (make-term-in-var-form va1)
		     (make-term-in-var-form va2)))))

(define (HEEQ-proof-of-Zero)
  (let ((info (assoc "HEEQ-Zero" THEOREMS)))
    (if info
	(caddr info)
	(begin
	  (set-goal (make-heeq (pt "0") (pt "0")))
	  (search)
	  (save "HEEQ-Zero")
	  (current-proof)))))

(define (HEEQ-proof-of-Succ)
  (let ((info (assoc "HEEQ-Succ" THEOREMS)))
    (if info
	(caddr info)
	(begin
	  (set-goal (make-heeq (pt "Succ") (pt "Succ")))
	  (search)
	  (save "HEEQ-Succ")
	  (current-proof)))))

(define (HEEQ-proof-of-NatPlus)
  (let ((info (assoc "HEEQ-NatPlus" THEOREMS)))
    (if info
	(caddr info)
	(begin
	  (set-goal (make-heeq (pt "NatPlus") (pt "NatPlus")))
	  (use "NatPlus-Ext")
	  (save "HEEQ-NatPlus")
	  (current-proof)))))

(define (make-Pi-tm typ1 typ2)
  (if (not (type? typ1))
      (myerror "make-Pi-tm: 1st argument not a type" typ1)
      (if (not (type? typ2))
	  (myerror "make-Pi-tm: 2nd argument not a type" typ2)
	  (let*((rv (make-Pi-tm-aux typ1 typ2)))
	    (begin ;; (nldisplay "make-Pi-tm:")
	      ;; (nldisplay (term-to-string rv))
		   rv)))))
(define (make-Pi-tm-aux typ1 typ2)
  (let*((va1 (type-to-new-var typ1))
	(tm1 (make-term-in-var-form va1))
	(va2 (type-to-new-var typ2)))
    (mk-term-in-abst-form va1 va2 tm1)))

(define (HEEQ-proof-of-Pi typ1 typ2)
(begin
   (set! Pi-COUNT (+ Pi-COUNT 1))
  (if (not (type? typ1))
      (myerror "HEEQ-proof-of-Pi: 1st argument not a type" typ1)
      (if (not (type? typ2))
	  (myerror "HEEQ-proof-of-Pi: 2nd argument not a type" typ2)
	  (let*((name 
		   (string-append "HEEQ-Pi-" (type-to-string typ1) 
				  "-" (type-to-string typ2)))
		(info (assoc name THEOREMS)))
	    (if info
		(caddr info)
		(HEEQ-proof-of-Pi-aux typ1 typ2 name)))))))
(define (HEEQ-proof-of-Pi-aux typ1 typ2 name)
  (let*((Pi-tm (make-Pi-tm typ1 typ2))
            (Pi-fmla (make-heeq-bis Pi-tm Pi-tm)))
    (begin
      (set-goal Pi-fmla)
      (search)
      (save name)
      (current-proof))))
      
(define (make-Sig-tm typ0 typ1 typ2) 
  (if (not (type? typ0))
      (myerror "make-Sig-tm: 1st argument not a type" typ0)
      (if (not (type? typ1))
	  (myerror "make-Sig-tm: 2nd argument not a type" typ1)
	  (if (not (type? typ2))
	      (myerror "make-Sig-tm: 3rd argument not a type" typ2)
	      (make-Sig-tm-aux typ0 typ1 typ2)))))
(define (make-Sig-tm-aux typ0 typ1 typ2)
  (let*((va_z (type-to-new-var typ0))
	(tm_z (make-term-in-var-form va_z))
	(va_y (type-to-new-var (make-arrow typ0 typ1)))
	(tm_y (make-term-in-var-form va_y))
	(va_x (type-to-new-var (mk-arrow typ0 typ1 typ2)))
	(tm_x (make-term-in-var-form va_x)))
    (mk-term-in-abst-form va_x va_y va_z 
	  (mk-term-in-app-form tm_x tm_z
			       (make-term-in-app-form tm_y tm_z)))))

(define (HEEQ-proof-of-Sig typ0 typ1 typ2)
(begin
   (set! Sigma-COUNT (+ Sigma-COUNT 1))
  (if (not (type? typ0))
      (myerror "HEEQ-proof-of-Sig: 1st argument not a type" typ0)
      (if (not (type? typ1))
	  (myerror "HEEQ-proof-of-Sig: 2nd argument not a type" typ1)
	  (if (not (type? typ2))
	      (myerror "HEEQ-proof-of-Sig: 3rd argument not a type" typ2)
	      (let*((name 
		       (string-append "HEEQ-Sig-" (type-to-string typ0) 
				      "-" (type-to-string typ1) 
				      "-" (type-to-string typ2)))
		(info (assoc name THEOREMS)))
	     (if info
		 (caddr info)
		 (HEEQ-proof-of-Sig-aux typ0 typ1 typ2 name))))))))
(define (HEEQ-proof-of-Sig-aux typ0 typ1 typ2 name)
  (let*((Sig-tm (make-Sig-tm typ0 typ1 typ2))
	(Sig-fmla (make-heeq-bis Sig-tm Sig-tm)))
    (begin
      (set-goal Sig-fmla)
      (search)
      (save name)
      (current-proof))))

(define (HEEQ-type-to-rec-term typ)
   (make-term-in-const-form 
     (type-info-to-rec-const (make-arrow (py "nat") typ))))

(define (type-to-Heeq-Rec-fmla typ)
  (let((Rec-tm (HEEQ-type-to-rec-term typ)))
    (make-heeq Rec-tm Rec-tm)))

(define (eq-heeq-trans typ)
  (if (not (equal? typ (py "nat")))
      (myerror "eq-heeq-trans: nat type expected")
  (let*((var1 (type-to-new-var typ))
	(var2 (type-to-new-var typ))
	(var3 (type-to-new-var typ))
	(tm1 (make-term-in-var-form var1))
	(tm2 (make-term-in-var-form var2))
	(tm3 (make-term-in-var-form var3))
	(mid (make-atomic-formula
	         (mk-term-in-app-form 
		   (make-term-in-const-form (finalg-to-=-const typ)) tm1 tm2)))
	(left (make-heeq tm2 tm3))
	(right (make-heeq tm1 tm3)))
    (mk-allnc var1 var2 var3 
	  (mk-imp left mid right)))))


(define (HEEQ-proof-of-Rec typ)
(begin
   (set! Rec-COUNT (+ Rec-COUNT 1)) 
  (if (not (type? typ))
      (myerror "HEEQ-proof-of-Rec: argument not a type" typ)
      (if (not (finite-type? typ))
	  (myerror "HEEQ-proof-of-Rec: argument not in Goedel's T " 
		   (type-to-string typ))
	  (HEEQ-proof-of-Rec-aux typ)))))

(define (HEEQ-proof-of-Rec-aux typ)
  (let*((typ-name (type-to-string typ))
	(trans-name (string-append "Eq-Heeq-Trans-" typ-name))
	(itran-name (string-append "Inst-" trans-name))
	(c_typ (mk-arrow (py "nat") typ typ))
	(b1 (type-to-new-var typ))
	(b1_str (var-to-string b1))
              (b1_tm (pt b1_str))
	(b2 (type-to-new-var typ))
	(b2_str (var-to-string b2))
	(c1 (type-to-new-var c_typ))
	(c1_str (var-to-string c1))
	(c2 (type-to-new-var c_typ))
	(c2_str (var-to-string c2))
	(thm-name (string-append "HEEQ-Rec-" typ-name)))
  (begin
    (set-goal (type-to-Heeq-Rec-fmla typ))
    (assume "m" "n" "mEn" b1_str b2_str "b1Hb2" c1_str c2_str "c1Hc2")
    (aga trans-name (eq-heeq-trans typ))
    (let*((fmla (proof-to-formula (current-goal)))
	  (Global-UNFOLDING UNFOLDING-FLAG)
	  (eq_tm (atom-form-to-kernel fmla))
	  (tm_r (term-in-app-form-to-arg eq_tm))
	  (tm_l (term-in-app-form-to-arg 
		   (term-in-app-form-to-op eq_tm)))
	  (G2 (term-in-app-form-to-arg tm_r))
	  (G1 (term-in-app-form-to-arg tm_l))
	  (R (HEEQ-type-to-rec-term typ))   
	  (tm_i (make-term-in-app-form 
		   (term-in-app-form-to-op tm_l) G2))
	  (tm1 (mk-term-in-app-form R (pt "k") b1_tm G1))
	  (tm2 (mk-term-in-app-form R (pt "k") b1_tm G2)))
       (begin
	 (set! UNFOLDING-FLAG #t)
	  (inst-with-to trans-name tm_l tm_i tm_r itran-name)
	  (use itran-name)
	  (use-with "R-Ext" R G2 (pt "m") (pt "n") b1_tm (pt b2_str) 
			"mEn"  "b1Hb2")
	  (drop itran-name "mEn" "b1Hb2")
	  (ind (pt "m"))
	  (use "Truth-Axiom")
	  (assume "k" "IHyp")
	  (use-with "c1Hc2" (pt "k") (pt "k") "Truth-Axiom" tm1 tm2 "IHyp")
	  (set! UNFOLDING-FLAG Global-UNFOLDING)
	  )))
    (save thm-name)
    (current-proof)))


(define (term-to-comb tm)
 (begin ;; (nldisplay "term-to-comb: " (term-to-string tm))
  (case (tag tm)
    ((term-in-const-form) tm)
    ((term-in-var-form) tm)
    ((term-in-abst-form) 
       (term-to-comb-aux 
	  (term-in-abst-form-to-var tm)
	  (term-in-abst-form-to-kernel tm)))
    ((term-in-app-form)
       (make-term-in-app-form 
	  (term-to-comb (term-in-app-form-to-op tm))
	  (term-to-comb (term-in-app-form-to-arg tm))))
    ((term-in-pair-form)
     (myerror "term-to-comb: not implemented for pair-form"))
;         (make-term-in-pair-form
; 	   (term-to-comb (term-in-pair-form-to-left tm))
; 	   (term-to-comb (term-in-pair-form-to-right tm))))
    ((term-in-lcomp-form)
     (myerror "term-to-comb: not implemented for lcomp-form"))
;         (make-term-in-lcomp-form
; 	    (term-to-comb (term-in-lcomp-form-to-kernel tm))))
    ((term-in-rcomp-form)
     (myerror "term-to-comb: not implemented for rcomp-form"))
;         (make-term-in-rcomp-form
; 	    (term-to-comb (term-in-rcomp-form-to-kernel tm)))) 
    
    ((term-in-if-form)
     (myerror "term-to-comb: not implemented for if-form"))
;         (make-term-in-if-form (term-in-if-form-to-test tm)
; 			      (map term-to-comb (term-in-if-form-to-alts tm))))
    (else
       (myerror "term-to-comb: term expected" tm)))))

(define (term-to-comb-aux va tm)
 (begin ;; (nldisplay "term-to-comb-aux: " (var-to-string va) (term-to-string tm))
  (let*((vatyp (var-to-type va))
	(tmtyp (term-to-type tm)))
    (if (not (member va (term-to-free tm)))
	    (make-term-in-app-form
	       (make-Pi-tm tmtyp vatyp)
	       (term-to-comb tm))
	(if (term-in-app-form? tm)
	    (let*((tm_op (term-in-app-form-to-op tm))
		  (comb_tm_op (term-to-comb-aux va tm_op))
		  (tm_arg (term-in-app-form-to-arg tm))
		  (comb_tm_arg (term-to-comb-aux va tm_arg))
		  (typ_op (arrow-form-to-val-type (term-to-type tm_op)))
		  (typ_arg (term-to-type tm_arg))
		  (sig_tm (make-Sig-tm vatyp typ_arg typ_op)))
	      (mk-term-in-app-form sig_tm comb_tm_op comb_tm_arg))
	    (case (tag tm)
	      ((term-in-var-form)
	          (let*((atyp (make-arrow vatyp vatyp))
		       (sig_tm (make-Sig-tm vatyp atyp vatyp))
		       (pi_tm_l (make-Pi-tm vatyp atyp))
		       (pi_tm_2 (make-Pi-tm vatyp vatyp))
		       (rv (mk-term-in-app-form sig_tm pi_tm_l pi_tm_2)))
		    (begin
		      ;; (nldisplay (term-to-string rv))
		      rv)))
	      ((term-in-abst-form)
	       (term-to-comb-bis va 
			  (term-to-comb-aux 
			      (term-in-abst-form-to-var tm)
			      (term-in-abst-form-to-kernel tm))))
	      ((term-in-const-form)
	          (myerror "term-to-comb-aux: unexpected term-in-const-form"))
	      ((term-in-var-form) 
	          (myerror "term-to-comb-aux: unexpected term-in-var-form"))
	      ((term-in-app-form)
	          (myerror "term-to-comb-aux: unexpected term-in-app-form"))	
	      ((term-in-pair-form)
	          (myerror "term-to-comb-aux: not implemented for pair-form"))
	      ((term-in-lcomp-form)
	          (myerror "term-to-comb-aux: not implemented for lcomp-form"))
	      ((term-in-rcomp-form)
	          (myerror "term-to-comb-aux: not implemented for rcomp-form"))
	      ((term-in-if-form)
	          (myerror "term-to-comb-aux: not implemented for if-form"))
	      (else
	          (myerror "term-to-comb-aux: term expected" tm))))))))


(define (term-to-comb-bis va tm)
 (begin ;; (nldisplay "term-to-comb-bis: " (var-to-string va) (term-to-string tm))
  (let*((vatyp (var-to-type va))
	(tmtyp (term-to-type tm)))
    (if (not (member va (term-to-free tm)))
	    (make-term-in-app-form
	       (make-Pi-tm tmtyp vatyp)
	       tm)
	(if (term-in-app-form? tm)
	    (let*((tm_op (term-in-app-form-to-op tm))
		  (comb_tm_op (term-to-comb-bis va tm_op))
		  (tm_arg (term-in-app-form-to-arg tm))
		  (comb_tm_arg (term-to-comb-bis va tm_arg))
		  (typ_op (arrow-form-to-val-type (term-to-type tm_op)))
		  (typ_arg (term-to-type tm_arg))
		  (sig_tm (make-Sig-tm vatyp typ_arg typ_op)))
	      (mk-term-in-app-form sig_tm comb_tm_op comb_tm_arg))
	    (case (tag tm)
	      ((term-in-var-form)
	          (let*((atyp (make-arrow vatyp vatyp))
		       (sig_tm (make-Sig-tm vatyp atyp vatyp))
		       (pi_tm_l (make-Pi-tm vatyp atyp))
		       (pi_tm_2 (make-Pi-tm vatyp vatyp))
		       (rv (mk-term-in-app-form sig_tm pi_tm_l pi_tm_2)))
		    (begin
		      ;; (nldisplay (term-to-string rv))
		      rv)))
	      ((term-in-abst-form)
	       (myerror "term-to-comb-bis: unexpected term-in-abst-form"))		    
	      ((term-in-const-form)
	          (myerror "term-to-comb-bis: unexpected term-in-const-form"))
	      ((term-in-var-form) 
	          (myerror "term-to-comb-bis: unexpected term-in-var-form"))
	      ((term-in-app-form)
	          (myerror "term-to-comb-bis: unexpected term-in-app-form"))	
	      ((term-in-pair-form)
	          (myerror "term-to-comb-bis: not implemented for pair-form"))
	      ((term-in-lcomp-form)
	          (myerror "term-to-comb-bis: not implemented for lcomp-form"))
	      ((term-in-rcomp-form)
	          (myerror "term-to-comb-bis: not implemented for rcomp-form"))
	      ((term-in-if-form)
	          (myerror "term-to-comb-bis: not implemented for if-form"))
	      (else
	          (myerror "term-to-comb-bis: term expected" tm))))))))

(define (HEEQ-proof-of-combinatorial-term tm)
 (begin 
  (case (tag tm)
    ((term-in-const-form) 
       (let*((cst (term-in-const-form-to-const tm))
	     (name (const-to-name cst)))
       (cond 
	 ((string=? "Rec" name)
	   (let*((cst_typ (const-to-type cst))
	             (typ (arrow-form-to-arg-type cst_typ)))
	     (HEEQ-proof-of-Rec typ)))
	 ((string=? "Zero" name) 
	         (begin
		(set! Zero-COUNT (+ Zero-COUNT 1))
		(HEEQ-proof-of-Zero)))
	 ((string=? "Succ" name) 
	          (begin
		(set! Succ-COUNT (+ Succ-COUNT 1))
		(HEEQ-proof-of-Succ)))
	 ((string=? "NatPlus" name) 
	         (begin
		(set! Plus-COUNT (+ Plus-COUNT 1))
	              (HEEQ-proof-of-NatPlus)))
	 (else
	   (myerror "HEEQ-proof-of-combinatorial-term: unexpected const " (term-to-string tm))))))
    ((term-in-var-form) 
     (begin 
       (let*((fmla (make-heeq tm tm)))
	  (make-proof-in-avar-form
	    (formula-to-new-avar fmla)))))
    ((term-in-abst-form) 
     (begin
          (case (abstraction-var-count tm)
	 ((2) (begin
		(set! Pi-COUNT (+ Pi-COUNT 1))
		(if DEBUG-HEEQ (nldisplay "Pi TERM no. " Pi-COUNT))
		))
	 ((3) (begin
		(set! Sigma-COUNT (+ Sigma-COUNT 1))
		(if DEBUG-HEEQ (nldisplay "Sigma TERM no. " Sigma-COUNT))
		))
	 (else (set! Strange-COUNT (+ Strange-COUNT 1))))
     (let*((fmla (make-heeq tm tm)))
	   (begin
	     (set-goal fmla)
	     (search)
	     (current-proof)))))
    ((term-in-app-form)
        (let*((tm-op (term-in-app-form-to-op tm))
	      (prf-op (HEEQ-proof-of-combinatorial-term tm-op))
	      (tm-arg (term-in-app-form-to-arg tm))
	      (prf-arg (HEEQ-proof-of-combinatorial-term tm-arg)))
	  (make-proof-in-imp-elim-form
	   (make-proof-in-all-elim-form 
	    (make-proof-in-all-elim-form prf-op tm-arg) tm-arg) prf-arg)))
    ((term-in-pair-form)
       (myerror "HEEQ-proof-of-combinatorial-term: pair not allowed" (term-to-string tm)))
    ((term-in-lcomp-form)
       (myerror "HEEQ-proof-of-combinatorial-term: lcomp not allowed" (term-to-string tm))) 
    ((term-in-rcomp-form)
       (myerror "HEEQ-proof-of-combinatorial-term: rcomp not allowed" (term-to-string tm)))
    ((term-in-if-form)
       (myerror "HEEQ-proof-of-combinatorial-term: if-term not allowed" (term-to-string tm)))
    (else
       (myerror "HEEQ-proof-of-combinatorial-term: term expected" tm)))))

(define (HEEQ-proof-of-term tm)
  (begin 
	 (let*((comb_tm (term-to-comb tm))
	            (rv (HEEQ-proof-of-combinatorial-term comb_tm)))
	   rv)))


(define nat_eq_cst (finalg-to-=-const (py "nat")))

(define (term-to-heeq-proof tm)
  (if (not (term? tm))
      (myerror "term-to-heeq-proof: term argument expected" tm)
      (if (not (equal? (term-to-type tm) (py "(nat=>nat)=>nat=>nat")))
	  (myerror "term-to-heeq-proof: argument must have type (nat=>nat)=>nat=>nat")
	  (term-to-heeq-proof-aux tm))))
(define (term-to-heeq-proof-aux tm)
  (begin
    (save "HEEQ-Lemma" (HEEQ-proof-of-term tm))
   (let*((vax_1 (type-to-new-var (py "nat=>nat")))
	(tmx_1 (make-term-in-var-form vax_1))
	(vax_2 (type-to-new-var (py "nat=>nat")))
	(tmx_2 (make-term-in-var-form vax_2))
	(tm_tx1 (make-term-in-app-form tm tmx_1))
	(tm_tx2 (make-term-in-app-form tm tmx_2))
	(va_i (type-to-new-var (py "nat")))
	(tm_i (make-term-in-var-form va_i))
	(va_j (type-to-new-var (py "nat")))
	(tm_j (make-term-in-var-form va_j))
	(prem (make-all va_i
		 (make-atomic-formula
		     (mk-term-in-app-form
		       (make-term-in-const-form nat_eq_cst)
		       (make-term-in-app-form tmx_1 tm_i)
		       (make-term-in-app-form tmx_2 tm_i)))))
	(conc (make-all va_j
		 (make-atomic-formula
		    (mk-term-in-app-form
		       (make-term-in-const-form nat_eq_cst)
		       (make-term-in-app-form tm_tx1 tm_j)
		       (make-term-in-app-form tm_tx2 tm_j)))))
	(gfmla (make-imp prem conc))
	(Global-UNFOLDING UNFOLDING-FLAG)
	)
  (begin
     (set! UNFOLDING-FLAG #t)
     (set-goal gfmla)
     (pp gfmla)
     (assume (var-to-string vax_1) (var-to-string vax_2))
     (assume "Prem")
     (assume (var-to-string va_j))
     (use "HEEQ-Lemma" tmx_1 tmx_2)
     (assume "m" "n" "Eq0")
     (inst-with-to "Prem" (pt "n") "Inst-Prem")
     (inst-with-to  "Zero-Eq-Trans" (make-term-in-app-form tmx_1 (pt "m"))
	  (make-term-in-app-form tmx_1 (pt "n"))
	  (make-term-in-app-form tmx_2 (pt "n")) "Inst-Zero-Eq-Trans")
     (use "Inst-Zero-Eq-Trans")
     (use "Zero-Eq-Ext")
     (use "Eq0")
     (use "Inst-Prem")
     (use "Truth-Axiom")
     (save "HEEQ-Theorem")
     (set! UNFOLDING-FLAG Global-UNFOLDING)
     (current-proof)
))))

(newline)
(display "****************************************")
(newline)
(display "*******    OK,  HEEQ-DEF module LOADED !!! ")
(newline)
(display "*****************************************")
(newline)
