; $Id: sn.scm,v 1.4 2008/01/25 13:30:25 logik Exp $

; 2004-11-21. Proofs and extracted terms for Lemma 1 in Berger's
; `Program Extraction from Normalization Proofs', TLCA1993.  One
; already obtains the defining equations for normalization by
; evaluation.  We use type variables rho sig, and for rho=>sig assume
; the two parts of the Lemma, to be used in the inductive proof.

; (load "~/minlog/init.scm")

(libload "nat.scm")

(add-tvar-name "rho") ;type of terms of type rho
(add-tvar-name "vrho") ;type of variables of type rho
(add-tvar-name "rhostar") ;type of abstract objects of type rho
(add-tvar-name "sig")
(add-tvar-name "vsig")
(add-tvar-name "sigstar")
(add-tvar-name "tau")
(add-tvar-name "vtau")
(add-tvar-name "taustar")
(add-tvar-name "rhosig") ;type of terms of type rho=>sigma
(add-tvar-name "rhosigstar")

(add-var-name "xrho" (py "vrho"))
(add-var-name "xtau" (py "vtau"))
(add-var-name "mvarrho" (py "nat=>vrho"))
(add-var-name "abstrhosig" (py "vrho=>sig=>rhosig"))
(add-var-name "apprhosig" (py "rhosig=>rho=>sig"))
(add-var-name "mtermrho" (py "vrho=>rho"))
(add-var-name "starapprhosig" (py "rhosigstar=>rhostar=>sigstar"))
(add-var-name "substrhosigvtau" (py "rhosig=>vtau=>tau=>rhosig"))
(add-var-name "substsigvrhovtau" (py "sig=>vrho=>vtau=>rho=>tau=>sig"))
(add-var-name "varrhosig" (py "rhosig=>vrho"))
(add-var-name "kernelrhosig" (py "rhosig=>sig"))

(add-pvar-name "SCrho" (make-arity (py "rho")))
(set! PVAR-TO-TVAR-ALIST
      (cons (list (make-pvar (make-arity (py "rho")) -1 0 "SCrho")
		  (make-tvar -1 "rhostar"))
	    PVAR-TO-TVAR-ALIST))

(add-pvar-name "SCsig" (make-arity (py "sig")))
(set! PVAR-TO-TVAR-ALIST
      (cons (list (make-pvar (make-arity (py "sig")) -1 0 "SCsig")
		  (make-tvar -1 "sigstar"))
	    PVAR-TO-TVAR-ALIST))

(add-pvar-name "SCtau" (make-arity (py "tau")))
(set! PVAR-TO-TVAR-ALIST
      (cons (list (make-pvar (make-arity (py "tau")) -1 0 "SCtau")
		  (make-tvar -1 "taustar"))
	    PVAR-TO-TVAR-ALIST))

(add-pvar-name "SCrhosig" (make-arity (py "rhosig")))
(set! PVAR-TO-TVAR-ALIST
      (cons (list (make-pvar (make-arity (py "rhosig")) -1 0 "SCrhosig")
		  (make-tvar -1 "rhosigstar"))
	    PVAR-TO-TVAR-ALIST))

(add-pvar-name "Frho" (make-arity (py "rho") (py "nat")))
(add-pvar-name "Nrho" (make-arity (py "rho") (py "rho")))
(add-pvar-name "Arho" (make-arity (py "rho") (py "rho")))
(add-pvar-name "Hrho" (make-arity (py "rho") (py "rho")))
(add-pvar-name "Fsig" (make-arity (py "sig") (py "nat")))
(add-pvar-name "Nsig" (make-arity (py "sig") (py "sig")))
(add-pvar-name "Asig" (make-arity (py "sig") (py "sig")))
(add-pvar-name "Hsig" (make-arity (py "sig") (py "sig")))
(add-pvar-name "Frhosig" (make-arity (py "rhosig") (py "nat")))
(add-pvar-name "Nrhosig" (make-arity (py "rhosig") (py "rhosig")))
(add-pvar-name "Arhosig" (make-arity (py "rhosig") (py "rhosig")))
(add-pvar-name "Hrhosig" (make-arity (py "rhosig") (py "rhosig")))

(add-var-name "r" (py "rhosig"))
(add-var-name "s" (py "rho"))
(add-var-name "t" (py "sig"))
(add-var-name "ttau" (py "tau"))

(add-global-assumption
 "Ax1rhosig" (pf "allnc apprhosig,mtermrho,mvarrho,abstrhosig,k,r,t.
                   Frhosig r k -> 
                   Nsig(apprhosig r(mtermrho(mvarrho k)))t ->
                   Nrhosig r(abstrhosig(mvarrho k)t)"))

(add-global-assumption
 "Ax3rho" (pf "allnc mtermrho,xrho.Arho(mtermrho xrho)(mtermrho xrho)"))

(add-global-assumption
 "Ax4rhosig" (pf "allnc apprhosig,r1,r2,s1,s2.
                   Arhosig r1 r2 -> Nrho s1 s2 ->
                   Asig(apprhosig r1 s1)(apprhosig r2 s2)"))

(add-global-assumption
 "Ax5rho" (pf "allnc s1,s2,s3.Hrho s1 s2 -> Nrho s1 s2 ->  Nrho s1 s3"))

(add-global-assumption
 "Ax6sigtaurho"
 (pf "allnc substrhosigvtau,apprhosig,abstrhosig,substsigvrhovtau,
       s,xrho,t,xtau,ttau.
       (all k.Frho s k -> ex s1 Nrho s s1) ->
       Hsig(apprhosig(substrhosigvtau(abstrhosig xrho t)xtau ttau)s)
           (substsigvrhovtau t xrho xtau s ttau)"))        

(add-global-assumption
 "Ax7rhosig"
 (pf "allnc apprhosig,r1,r2,s.
       Hrhosig r1 r2 -> Hsig(apprhosig r1 s)(apprhosig r2 s)"))

(add-global-assumption
 "Ax8rhosig"
 (pf "allnc apprhosig,mtermrho,mvarrho,k,r.
       Frhosig r k -> Fsig(apprhosig r(mtermrho(mvarrho k)))(k+1)"))

(add-global-assumption
 "Ax9rhosig" (pf "allnc apprhosig,k,r,s.Fsig(apprhosig r s)k -> Frho s k"))

(add-global-assumption
 "Ax10rhosig"
 (pf "allnc apprhosig,k,r,s.Fsig(apprhosig r s)k -> Frhosig r k"))

; Lemma 1(a), Case rho=>sig
"SCrhosigSN"
(set-goal
 (pf "all apprhosig,mtermrho,mvarrho,abstrhosig.
      (allnc r.SCrhosig^r -> allnc s.SCrho^s -> SCsig^(apprhosig r s)) ->
      (allnc t1.SCsig^t1 -> all k.Fsig t1 k -> ex t2 Nsig t1 t2) ->
      (allnc s1.(all k.Frho s1 k -> ex s2 Arho s1 s2) -> SCrho^s1) ->
      allnc r1.SCrhosig^r1 -> all k.Frhosig r1 k -> ex r2 Nrhosig r1 r2"))
(assume "apprhosig" "mtermrho" "mvarrho" "abstrhosig"
	"SCrhosigDef" "SCsigSN" "SArhoSC"
	"r1" "SCrhosig^r1" "k" "Frhosig r1 k")
(cut (pf "ex t Nsig(apprhosig r1(mtermrho(mvarrho k)))t"))
(assume "ExHyp")
(by-assume-with "ExHyp" "t" "NsigInst")
(ex-intro (pt "abstrhosig(mvarrho k)t"))
(use "Ax1rhosig" (pt "apprhosig") (pt "mtermrho"))
(use "Frhosig r1 k")
(use "NsigInst")
(use "SCsigSN" (pt "k+1"))
(use "SCrhosigDef")
(use "SCrhosig^r1")
(use "SArhoSC")
(strip)
(ex-intro (pt "mtermrho(mvarrho k)"))
(use "Ax3rho")
(use "Ax8rhosig")
(use "Frhosig r1 k")
(save "SCrhosigSN")

(pp (nt (proof-to-extracted-term (theorem-name-to-proof "SCrhosigSN"))))

"[apprhosig0,mtermrho1,mvarrho2,abstrhosig3,starapprhosig4,
(sigstar=>nat=>sig)_5,((nat=>rho)=>rhostar)_6,rhosigstar7,n8]
 abstrhosig3(mvarrho2 n8)
 ((sigstar=>nat=>sig)_5
  (starapprhosig4 rhosigstar7
   (((nat=>rho)=>rhostar)_6([n9]mtermrho1(mvarrho2 n8))))
  (Succ n8))"

; Lemma 1(b), Case sig=>rho
"SArhosigSC"
(set-goal
 (pf "all apprhosig.
      (allnc r.(allnc s.SCrho^s -> SCsig^(apprhosig r s)) -> SCrhosig^r) ->
      (allnc s1.SCrho^s1 -> all k.Frho s1 k -> ex s2 Nrho s1 s2) ->
      (allnc t1.(all k.Fsig t1 k -> ex t2 Asig t1 t2) -> SCsig^t1) ->
      allnc r1.(all k.Frhosig r1 k -> ex r2 Arhosig r1 r2) -> SCrhosig^r1"))
(assume "apprhosig" "SCrhosigDef" "SCrhoSN" "SAsigSC" "r1" "SArhosig^r1")
(use "SCrhosigDef")
(assume "s" "SCrho^s")
(use "SAsigSC")
(assume "k" "Fsig(apprhosig r1 s)k")
(cut (pf "ex r2 Arhosig r1 r2"))
(assume "ExHyp1")
(by-assume-with "ExHyp1" "r2" "ExHyp1Inst")
(cut (pf "ex s2 Nrho s s2"))
(assume "ExHyp2")
(by-assume-with "ExHyp2" "s2" "ExHyp2Inst")
(ex-intro (pt "apprhosig r2 s2"))
(use "Ax4rhosig")
(use "ExHyp1Inst")
(use "ExHyp2Inst")
(use "SCrhoSN" (pt "k"))
(use "SCrho^s")
(use "Ax9rhosig" (pt "apprhosig") (pt "r1"))
(use "Fsig(apprhosig r1 s)k")
(use "SArhosig^r1" (pt "k"))
(use "Ax10rhosig" (pt "apprhosig") (pt "s"))
(use "Fsig(apprhosig r1 s)k")
(save "SArhosigSC")

(pp (nt (proof-to-extracted-term (theorem-name-to-proof "SArhosigSC"))))

"[apprhosig0,((rhostar=>sigstar)=>rhosigstar)_1,
(rhostar=>nat=>rho)_2,((nat=>sig)=>sigstar)_3,(nat=>rhosig)_4]
 ((rhostar=>sigstar)=>rhosigstar)_1
 ([rhostar5]
   ((nat=>sig)=>sigstar)_3
   ([n6]apprhosig0((nat=>rhosig)_4 n6)((rhostar=>nat=>rho)_2 rhostar5 n6)))"

; Finally the non-identical initial case.

(add-tvar-name "iota") ;type of terms of type iota
(add-tvar-name "viota") ;type of variables of type iota
(add-tvar-name "iotastar") ;type of abstract objects of type iota

(add-var-name "xiota" (py "viota"))
(add-var-name "mvariota" (py "nat=>viota"))
(add-var-name "mtermiota" (py "viota=>iota"))

(add-var-name "ri" (py "iota"))

(add-pvar-name "Ni" (make-arity (py "iota") (py "iota")))
(add-pvar-name "Ai" (make-arity (py "iota") (py "iota")))
(add-pvar-name "Hi" (make-arity (py "iota") (py "iota")))
(add-pvar-name "Fi" (make-arity (py "iota") (py "nat")))

(add-global-assumption
 "Ax2" (pf "allnc ri1,ri2.Ai ri1 ri2 -> Ni ri1 ri2"))

"SAiSN"
(set-goal (pf "(allnc ri1.(all k.Fi ri1 k -> ex ri2 Ai ri1 ri2) -> 
                           all k.Fi ri1 k -> ex ri2 Ni ri1 ri2)"))
(assume "ri1" "H1" "k" "Fi ri1 k")
(inst-with-to "H1" (pt "k") "Fi ri1 k" "H2")
(by-assume-with "H2" "ri2" "H2Inst")
(ex-intro (pt "ri2"))
(use "Ax2")
(use "H2Inst")
(save "SAiSN")

(pp (nt (proof-to-extracted-term (theorem-name-to-proof "SAiSN"))))

"[(nat=>iota)_0](nat=>iota)_0"


; Lemma 2
"SCHrhosig"
(set-goal
 (pf "allnc apprhosig,r1,r2.
       (allnc r.(allnc s.SCrho^s -> SCsig^(apprhosig r s)) -> SCrhosig^r) ->
       (allnc r.SCrhosig^r -> allnc s.SCrho^s -> SCsig^(apprhosig r s)) ->
       (allnc t1,t2.SCsig^t2 -> Hsig t1 t2 -> SCsig^t1) ->
       SCrhosig^r2 -> Hrhosig r1 r2 -> SCrhosig^r1"))
(assume "apprhosig" "r1" "r2"
	"SCrhosigDef1" "SCrhosigDef2" "IHsig" "SCrhosig^r2" "Hrhosig r1 r2")
(use "SCrhosigDef1")
(assume "s" "SCrho^s")
(use "IHsig" (pt "apprhosig r2 s")) 
(use "SCrhosigDef2")
(use "SCrhosig^r2")
(use "SCrho^s")
(use "Ax7rhosig")
(use "Hrhosig r1 r2")
(save "SCHrhosig")

(pp (nt (proof-to-extracted-term (theorem-name-to-proof "SCHrhosig"))))

"[((rhostar=>sigstar)=>rhosigstar)_0,starapprhosig1,(sigstar=>sigstar)_2,
  rhosigstar3]
 ((rhostar=>sigstar)=>rhosigstar)_0
 ([rhostar4](sigstar=>sigstar)_2(starapprhosig1 rhosigstar3 rhostar4))"

; By induction one can see that this is the identity.


; Lemma 3
"SCabstrhosig"
(set-goal
 (pf "allnc apprhosig,substsigvrhovtau,substrhosigvtau,abstrhosig,
       xrho,t,xtau,ttau.
       (allnc r.(allnc s.SCrho^s -> SCsig^(apprhosig r s)) -> SCrhosig^r) ->
       (allnc s.SCrho^s -> all k.Frho s k -> ex s1 Nrho s s1) ->
       (allnc t1,t2.SCsig^t2 -> Hsig t1 t2 -> SCsig^t1) ->
       (allnc ttau,s,xrho.
         SCrho^s -> SCtau^ttau ->
         SCsig^(substsigvrhovtau t xrho xtau s ttau)) ->
       SCtau^ttau ->
       SCrhosig^(substrhosigvtau(abstrhosig xrho t)xtau ttau)"))
(assume "apprhosig" "substsigvrhovtau" "substrhosigvtau" "abstrhosig"
	"xrho" "t" "xtau" "ttau"
	"SCrhosigDef1" "SCrhoSN" "SCHsig" "IHt" "SCtau^ttau")
(use "SCrhosigDef1")
(assume "s" "SCrho^s")
(use "SCHsig" (pt "substsigvrhovtau t xrho xtau s ttau"))
(use "IHt")
(use "SCrho^s")
(use "SCtau^ttau")
(use "Ax6sigtaurho")
(use "SCrhoSN")
(use "SCrho^s")
(save "SCabstrhosig")

(pp (nt (proof-to-extracted-term (theorem-name-to-proof "SCabstrhosig"))))

"[((rhostar=>sigstar)=>rhosigstar)_0,(rhostar=>nat=>rho)_1,
  (sigstar=>sigstar)_2,(rhostar=>taustar=>sigstar)_3,taustar4]
 ((rhostar=>sigstar)=>rhosigstar)_0
 ([rhostar5](sigstar=>sigstar)_2
  ((rhostar=>taustar=>sigstar)_3 rhostar5 taustar4))"

(dnpe)

'(lambda (apprhosig)
  (lambda (substsigvrhovtau)
    (lambda (substrhosigvtau)
      (lambda (abstrhosig)
        (lambda (xrho)
          (lambda (t)
            (lambda (xtau)
              (lambda (ttau)
                (lambda (u116) ;SCrhosigDef1
                  (lambda (u117) ;SCrhoSN
                    (lambda (u118) ;SCHsig
                      (lambda (u119) ;IHt
                        (lambda (u120) ;SCtau^ttau
                          ((u116 (((substrhosigvtau ((abstrhosig xrho) t))
                                   xtau)
                                  ttau))
                           (lambda (s)
                             (lambda (u121) ;SCrho^s
                               ((((u118 ((apprhosig
                                           (((substrhosigvtau
                                               ((abstrhosig xrho) t))
                                             xtau)
                                            ttau))
                                         s))
                                  (((((substsigvrhovtau t) xrho) xtau) s)
                                   ttau))
                                 (((((u119 ttau) s) xrho) u121) u120))
                                ((((((((((|Ax6sigtaurho| substrhosigvtau)
                                         apprhosig)
                                        abstrhosig)
                                       substsigvrhovtau)
                                      s)
                                     xrho)
                                    t)
                                   xtau)
                                  ttau)
                                 ((u117 s) u121)))))))))))))))))))

; Idea: internalize rho=>sigma by reflection, and provide an internal
; model for all finite type functionals (cf. Seisenberger/Wanger)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Now the proof by means of the SN-method

(reset)
(libload "nat.scm")

(add-tvar-name "rho") ;type of terms of type rho
(add-tvar-name "sig")
(add-tvar-name "tau")
(add-tvar-name "rhosig") ;type of terms of type rho=>sigma
(add-tvar-name "sigtau") ;type of terms of type sig=>tau
(add-tvar-name "rhosigtau") ;type of terms of type rho=>sig=>tau

(add-tvar-name "rhoreal") ;type of realizers for HB of type rho
(add-tvar-name "sigreal") ;type of realizers for HB of type sig
(add-tvar-name "taureal") ;type of realizers for HB of type tau
(add-tvar-name "sigtaureal") ;type of realizers for HB of type sig=>tau
(add-tvar-name
 "rhosigtaureal") ;type of realizers of terms of type rho=>sig=>tau

(add-tvar-name "vrho") ;type of variables of type rho
(add-tvar-name "vtau") ;type of variables of type tau
(add-tvar-name "vsigtau") ;type of variables of type sig=>tau
(add-tvar-name "vrhosigtau") ;type of variables of type rho=>sig=>tau

; The following is obsolete: we can use tvars for vars
(add-var-name "trho" (py "rho")) ;terms of type rho
(add-var-name "tsig" (py "sig")) ;terms of type sig
(add-var-name "ttau" (py "tau")) ;terms of type tau
(add-var-name "trhosig" (py "rhosig")) ;terms of type rho=>sig
(add-var-name "tsigtau" (py "sigtau")) ;terms of type sig=>tau
(add-var-name "trhosigtau" (py "rhosigtau")) ;terms of type rho=>sig=>tau

(add-var-name "xrho" (py "vrho"))
(add-var-name "xtau" (py "vtau"))
(add-var-name "xsigtau" (py "vsigtau")) ;variables of type sig=>tau
(add-var-name "xrhosigtau" (py "vrhosigtau")) ;vars of type rho=>sig=>tau

(add-var-name "substsigtauvrho" (py "sigtau=>vrho=>rho=>sigtau"))
(add-var-name "substrhovrhosigtau" (py "rho=>vrhosigtau=>rhosigtau=>rho"))
(add-var-name "substsigvrhosigtau" (py "sig=>vrhosigtau=>rhosigtau=>sig"))
(add-var-name "substtauvsigtau" (py "tau=>vsigtau=>sigtau=>tau"))
(add-var-name "substrhovtau" (py "rho=>vtau=>tau=>rho"))
(add-var-name "substsigvtau" (py "sig=>vtau=>tau=>sig"))
(add-var-name "substtauvtau" (py "tau=>vtau=>tau=>tau"))
(add-var-name "substrhosigvtau" (py "rhosig=>vtau=>tau=>rhosig"))


(add-var-name "apprhosig" (py "rhosig=>rho=>sig"))
(add-var-name "apprhosigttau" (py "rhosigtau=>rho=>sigtau"))
(add-var-name "appsigtau" (py "sigtau=>sig=>tau"))
(add-var-name "abstrhosig" (py "vrho=>sig=>rhosig"))

(add-var-name "mvarrho" (py "nat=>vrho"))
(add-var-name "mvartau" (py "nat=>vtau"))
(add-var-name "mvarsigtau" (py "nat=>vsigtau"))

(add-var-name "mtermrho" (py "vrho=>rho"))
(add-var-name "mtermtau" (py "vtau=>tau"))
(add-var-name "mtermsigtau" (py "vsigtau=>sigtau"))
(add-var-name "mtermrhosigtau" (py "vrhosigtau=>rhosigtau"))

(add-pvar-name "HBrho" (make-arity (py "rho")))
(set! PVAR-TO-TVAR-ALIST
      (cons (list (make-pvar (make-arity (py "rho")) -1 0 "HBrho")
		  (make-tvar -1 "rhoreal"))
	    PVAR-TO-TVAR-ALIST))

(add-pvar-name "HBsig" (make-arity (py "sig")))
(set! PVAR-TO-TVAR-ALIST
      (cons (list (make-pvar (make-arity (py "sig")) -1 0 "HBsig")
		  (make-tvar -1 "sigreal"))
	    PVAR-TO-TVAR-ALIST))

(add-pvar-name "HBtau" (make-arity (py "tau")))
(set! PVAR-TO-TVAR-ALIST
      (cons (list (make-pvar (make-arity (py "tau")) -1 0 "HBtau")
		  (make-tvar -1 "taureal"))
	    PVAR-TO-TVAR-ALIST))

(add-pvar-name "HBsigtau" (make-arity (py "sigtau")))
(set! PVAR-TO-TVAR-ALIST
      (cons (list (make-pvar (make-arity (py "sigtau")) -1 0 "HBsigtau")
		  (make-tvar -1 "sigtaureal"))
	    PVAR-TO-TVAR-ALIST))

(add-pvar-name "HBrhosigtau" (make-arity (py "rhosigtau")))
(set! PVAR-TO-TVAR-ALIST
      (cons (list (make-pvar (make-arity (py "rhosigtau")) -1 0 "HBrhosigtau")
		  (make-tvar -1 "rhosigtaureal"))
	    PVAR-TO-TVAR-ALIST))

(add-pvar-name "Frho" (make-arity (py "rho") (py "nat")))
(add-pvar-name "Fsig" (make-arity (py "sig") (py "nat")))
(add-pvar-name "Ftau" (make-arity (py "tau") (py "nat")))
(add-pvar-name "Frhosigtau" (make-arity (py "rhosigtau") (py "nat")))

(add-global-assumption
 "Ax13rhotau"
 (pf "allnc trho,k,substrhovtau,mvartau,ttau.
       Frho trho k -> Equal(substrhovtau trho(mvartau k)ttau)trho"))

(add-global-assumption
 "Ax14tau"
 (pf "allnc substtauvtau,mtermtau,mvartau,k,ttau.
       Equal(substtauvtau(mtermtau(mvartau k))(mvartau k)ttau)ttau"))

(add-global-assumption
 "Ax15tau"
 (pf "allnc substsigvtau,apprhosig,trhosig,trho,xtau,ttau,substrhosigvtau,
       substrhovtau.
       Equal(substsigvtau(apprhosig trhosig trho)xtau ttau)
            (apprhosig(substrhosigvtau trhosig xtau ttau)
                      (substrhovtau trho xtau ttau))"))

(add-global-assumption
 "Ax16tau"
 (pf "allnc substrhosigvtau,abstrhosig,mvarrho,k,tsig,xtau,ttau,
       abstrhosig,substsigvtau.Ftau ttau k ->
       Equal(substrhosigvtau(abstrhosig(mvarrho k)tsig)xtau ttau)
            (abstrhosig(mvarrho k)(substsigvtau tsig xtau ttau))"))

 (add-global-assumption
 "Ax17sigtau"
 (pf "allnc substtauvsigtau,appsigtau,mtermsigtau,mvarsigtau,k,tsig,tsigtau.
       Fsig tsig k ->
       Equal(substtauvsigtau(appsigtau(mtermsigtau(mvarsigtau k))tsig)
                            (mvarsigtau k)tsigtau)
            (appsigtau tsigtau tsig)"))

(add-global-assumption
 "Ax18rho"
 (pf "allnc trhosigtau,k,substsigtauvrho,apprhosigttau,mtermrho,mvarrho,trho.
       Frhosigtau trhosigtau k ->
       Equal(substsigtauvrho(apprhosigttau trhosigtau(mtermrho(mvarrho k)))
		            (mvarrho k) trho)
            (apprhosigttau trhosigtau trho)"))

(add-global-assumption
 "Ax18sigvrhosigtau"
 (pf "allnc tsig,k,trhosigtau,substsigvrhosigtau,xrhosigtau.
       Fsig tsig k -> Frhosigtau trhosigtau k ->
       Fsig(substsigvrhosigtau tsig xrhosigtau trhosigtau)k"))


; (add-global-assumption
;  "CompHBtau"
;  (pf "allnc ttau1,ttau2.Equal ttau1 ttau2 -> HBtau^ttau1 -> HBtau^ttau2"))

(add-global-assumption
 "Ax9rhosig"
 (pf "allnc appsigtau,tsigtau,tsig,k.
       Ftau(appsigtau tsigtau tsig)k ->
       Fsig tsig k"))

; Using David's trick (cf [JM03,p.71]) we only prove closure under subst

"HBVarApprhosigtau"
(set-goal
 (pf "allnc appsigtau,apprhosigttau,mtermrhosigtau,
xrhosigtau,trho,tsig,trhosigtau,substrhovrhosigtau,substsigvrhosigtau,k.
(allnc appsigtau,apprhosigttau,mtermrhosigtau,xrhosigtau,trho,tsig.
  HBtau^(appsigtau(apprhosigttau(mtermrhosigtau xrhosigtau) trho)tsig) ->
  HBrho^trho) ->
(allnc appsigtau,apprhosigttau,mtermrhosigtau,xrhosigtau,trho,tsig.
  HBtau^(appsigtau(apprhosigttau(mtermrhosigtau xrhosigtau) trho)tsig) ->
  HBsig^tsig) ->
(allnc tsig,appsigtau,mtermsigtau,xsigtau.
  HBsig^tsig -> HBtau^(appsigtau(mtermsigtau xsigtau)tsig)) ->
(allnc trhosigtau,apprhosigttau,mtermrho,xrho.
  HBrhosigtau^trhosigtau ->
  HBsigtau^(apprhosigttau trhosigtau(mtermrho xrho))) ->
(allnc tsigtau,trho,substsigtauvrho,xrho.
  HBsigtau^tsigtau -> HBrho^trho ->
  HBsigtau^(substsigtauvrho tsigtau xrho trho)) ->
(allnc ttau,tsigtau,substtauvsigtau,xsigtau.
  HBtau^ttau -> HBsigtau^tsigtau ->
  HBtau^(substtauvsigtau ttau xsigtau tsigtau)) ->
(allnc trho,trhosigtau,substrhovrhosigtau,xrhosigtau.
  HBrho^trho -> HBrhosigtau^trhosigtau -> 
  HBrho^(substrhovrhosigtau trho xrhosigtau trhosigtau)) ->
(allnc tsig,trhosigtau,substsigvrhosigtau,xrhosigtau.
  HBsig^tsig -> HBrhosigtau^trhosigtau -> 
  HBsig^(substsigvrhosigtau tsig xrhosigtau trhosigtau)) ->
Ftau(appsigtau(apprhosigttau(mtermrhosigtau xrhosigtau) trho)tsig) k ->
Frhosigtau trhosigtau k ->
HBtau^(appsigtau(apprhosigttau(mtermrhosigtau xrhosigtau) trho)tsig) ->
HBrhosigtau^trhosigtau ->
HBtau^(appsigtau
       (apprhosigttau
	trhosigtau
	(substrhovrhosigtau trho xrhosigtau trhosigtau))
       (substsigvrhosigtau tsig xrhosigtau trhosigtau))"))
(assume "appsigtau" "apprhosigttau"
	"mtermrhosigtau" "xrhosigtau" "trho" "tsig"
	"trhosigtau" "substrhovrhosigtau" "substsigvrhosigtau" "k"
	"HBDefVar1" "HBDefVar2" "HBDefVar3" "HBProp" "IHrho" "IHsigtau"
	"SIHrho" "SIHsig" "Ftau(x trho tsig)k" "Frhosigtau trhosigtau k"
	"HBtau x trho tsig"
	"HBrhosigtau^trhosigtau")
(use-with "Eq-Compat" (py "tau") (py "tau")
	  (make-cterm (pv "tau") (pf "HBtau^tau"))
	  (pt "substtauvsigtau
           (appsigtau(mtermsigtau(mvarsigtau k))
                     (substsigvrhosigtau tsig xrhosigtau trhosigtau))
           (mvarsigtau k)
           (apprhosigttau trhosigtau
	                  (substrhovrhosigtau trho xrhosigtau trhosigtau))")
	  (pt "(appsigtau
                (apprhosigttau trhosigtau
                               (substrhovrhosigtau trho xrhosigtau trhosigtau))
                (substsigvrhosigtau tsig xrhosigtau trhosigtau))")
	  "?" "?")
(use "Ax17sigtau")
(use "Ax18sigvrhosigtau")
(use "Ax9rhosig" (pt "appsigtau")
     (pt "(apprhosigttau(mtermrhosigtau xrhosigtau)trho)"))
(use "Ftau(x trho tsig)k")
(use "Frhosigtau trhosigtau k")
(use "IHsigtau")
(use "HBDefVar3")
(use "SIHsig")
(use "HBDefVar2" (pt "appsigtau") (pt "apprhosigttau") (pt "mtermrhosigtau")
     (pt "xrhosigtau") (pt "trho"))
(use "HBtau x trho tsig")
(use "HBrhosigtau^trhosigtau")
(use-with "Eq-Compat" (py "sigtau") (py "sigtau")
	  (make-cterm (pv "sigtau") (pf "HBsigtau^sigtau"))
	  (pt "substsigtauvrho
           (apprhosigttau trhosigtau(mtermrho(mvarrho k)))
           (mvarrho k)
           (substrhovrhosigtau trho xrhosigtau trhosigtau)")
	  (pt "(apprhosigttau trhosigtau
                 (substrhovrhosigtau trho xrhosigtau trhosigtau))")
	  "?" "?")
(use "Ax18rho")
(use "Frhosigtau trhosigtau k")
(use "IHrho")
(use "HBProp")
(use "HBrhosigtau^trhosigtau")
(use "SIHrho")
(use "HBDefVar1" (pt "appsigtau") (pt "apprhosigttau") (pt "mtermrhosigtau")
     (pt "xrhosigtau") (pt "tsig"))
(use "HBtau x trho tsig")
(use "HBrhosigtau^trhosigtau")
(save "HBVarApprhosigtau")

; (remove-theorem "HBVarApprhosigtau")

(pp (nt (proof-to-extracted-term (theorem-name-to-proof "HBVarApprhosigtau"))))

"[(taureal=>rhoreal)_0,               "HBDefVar1"
 (taureal=>sigreal)_1,                "HBDefVar2"
 (sigreal=>taureal)_2,                "HBDefVar3"
 (rhosigtaureal=>sigtaureal)_3,       "HBProp"
 (sigtaureal=>rhoreal=>sigtaureal)_4, "IHrho" 
 (taureal=>sigtaureal=>taureal)_5,    "IHsigtau"
 (rhoreal=>rhosigtaureal=>rhoreal)_6, "SIHrho" 
 (sigreal=>rhosigtaureal=>sigreal)_7, "SIHsig"
 taureal8,                            "HBtau x trho tsig"
 rhosigtaureal9]                      "HBrhosigtau^trhosigtau"
 (taureal=>sigtaureal=>taureal)_5
 ((sigreal=>taureal)_2
  ((sigreal=>rhosigtaureal=>sigreal)_7((taureal=>sigreal)_1 taureal8)
   rhosigtaureal9))
 ((sigtaureal=>rhoreal=>sigtaureal)_4
  ((rhosigtaureal=>sigtaureal)_3 rhosigtaureal9)
  ((rhoreal=>rhosigtaureal=>rhoreal)_6((taureal=>rhoreal)_0 taureal8)
   rhosigtaureal9))"

 (5 (2 (7 (1 8) 9))
    (4 (3 9)
       (6 (0 8) 9)))

; Proposition HB(r) -> HB(r x) is to be proved by induction on HB(r),
; hence needs to be split in three cases.

(pf "HBrhosig trhosig -> HBsig(apprhosig trhosig xrho)")

; Inductive definition of SN, by means of clauses.  Better name: HB
; Clause Var0 corresponds to Ax4
; Clause lambda needs cooperation with SC
; Clause beta corresponds to Lemma 2
; Content of HB(r): generation tree of how it came into HB

; HB(x)
; HB(r) -> A(r,x) -> HB(s) -> HB(app(r,s))
; HB(r) -> HB(lambda x r)
; H(s1,s2) -> HB(s2) -> HB(s1)

"HBwf"
"HB s -> all k.F s k -> ex s1 N s s1"
; Proof by induction on HB(s)

"HBappvar"
"HB(r) -> HB(rx)"
; Induction on HB(r)

"HBsubst"
"HB(r) -> HBrho(s) -> HB(subst r x s)"
; Induction on rho, side induction on HB(r)
; Case app(r,t), from HB(r), A(r,x), HB(t).  Then x:rho=>sigma.
; HB(subst r x s), HB(subst t x s) by SIH.  With fresh z:rho we have
; HB(app(z,subst t x s)).

; The extracted program will be leftmost outermost reduction.

"HBapp"  "HBsubst"
; (a) "HBrho(s) -> HB(t) -> HB(app s t)"
; (b) "HB(t) -> HBrho(s) -> HB(subst t xrho s)"
; (b') "HBA(t) -> HBrho(s) -> HBA(subst t xrho s)"
; Proof by Ind(rho)
rho=>sigma.  (a)
(b)  Side ind on HB(t).  Case 


; 2004-12-24
; Lambda terms with de Bruijn indizes (following Joachimski's thesis)
; ===================================================================

(reset)
(libload "nat.scm")
(libload "list.scm")

; "LtSuccCases"
(set-goal (pf "all m,n.n<Succ m -> (n<m -> Pvar^) -> (n=m -> Pvar^) -> Pvar^"))
(ind)
(cases)
(assume "H1" "H2" "H3")
(use "H3")
(use "Truth-Axiom")
(assume "n" "H1" "H2" "H3")
(use "Efq")
(use "H1")
(assume "m" "IHm")
(cases)
(assume "H1" "H2" "H3")
(use "H2")
(use "Truth-Axiom")
(use "IHm")
(save "LtSuccCases")

; inductive dB
;  | Var : nat=>dB
;  | App : dB=>dB=>dB
;  | Lam : dB=>dB

(add-alg "dB"
	 '("Var" "nat=>dB")
	 '("App" "dB=>dB=>dB")
	 '("Abs" "dB=>dB"))

(add-var-name "r" "s" (py "dB"))

; Application for terms is via the constant App

(add-new-application 
 (lambda (type) (equal? type (py "dB")))
 (lambda (term1 term2) (mk-term-in-app-form (pt "App") term1 term2)))

(add-new-application-syntax
 ; predicate
 (lambda (term)
   (and (term-in-app-form? term)
	(let ((op (term-in-app-form-to-op term)))
	  (term-in-app-form? op)
	  (term=? (pt "App") (term-in-app-form-to-op op)))))
 ; to arg
 (lambda (term)
   (term-in-app-form-to-arg term))
 ; to op
 (lambda (term)
   (term-in-app-form-to-arg
    (term-in-app-form-to-op term))))

; "DBCompatApp"
(set-goal (pf "all r1,r2,s1,s2.r1=r2 -> s1=s2 -> r1 s1 = r2 s2"))
(assume "r1" "r2" "s1" "s2" "r1=r2" "s1=s2")
(add-global-assumption "DBTransEq" (pf "all r1,r2,r3.r1=r2 -> r2=r3 -> r1=r3"))
(use "DBTransEq" (pt "r1 s2"))
(use "s1=s2")
(use "r1=r2")
(save "DBCompatApp")

; (pp (pt "Var 7(Abs(Var 0))"))

(add-program-constant "Lift" (py "dB=>nat=>nat=>dB") 1)

(add-var-name "l" (py "nat"))

(add-computation-rule (pt "Lift(Var n)l k")
		      (pt "[if (n<l) (Var n) (Var(n+k))]"))
(add-computation-rule (pt "Lift(r s)l k")
		      (pt "(Lift r l k)(Lift s l k)"))
(add-computation-rule (pt "Lift(Abs r)l k")
		      (pt "Abs(Lift r(l+1)k)"))

; "LiftId"
(set-goal (pf "all r,k.Lift r k 0=r"))
(ind)
(assume "n" "k")
(ng)
(use "Truth-Axiom")

; Case App r s
(assume "r" "s" "IHr" "IHs" "k")
(ng)
(simp "IHr")
(simp "IHs")
(use "Truth-Axiom")
; (use "DBCompatApp")
; (use "IHr")
; (use "IHs")

; Case Abs r
(assume "r" "IHr" "k")
(ng)
(use "IHr")
(save "LiftId")

(add-rewrite-rule (pt "Lift r k 0") (pt "r"))


; "LiftTwiceMod"
(set-goal (pf "all r,l,k,k1.Lift(Lift r l k)l k1=Lift r l(k+k1)"))
(ind)
(assume "n" "l" "k" "k1")
(cases (pt "n<l"))
(assume "n<l")
(ng)
(simp "n<l")
(ng)
(simp "n<l")
(use "Truth-Axiom")

(assume "n<l -> F")
(ng)
(simp "n<l -> F")
(ng)
(add-global-assumption "LiftTwiceModAux1" (pf "all n,l,k.n+k<l -> n<l"))
(cut (pf "n+k<l -> F")) 
(assume "H1")
(simp "H1")
(use "Truth-Axiom")
(assume "n+k<l")
(use "n<l -> F")
(use "LiftTwiceModAux1" (pt "k"))
(use "n+k<l")

; Case App r s
(assume "r" "s" "IHr" "IHs" "l" "k" "k1")
(ng)
(simp "IHr")
(simp "IHs")
(use "Truth-Axiom")
; (use "DBCompatApp")
; (use "IHr")
; (use "IHs")

; Case Abs r
(assume "r" "IHr" "l" "k" "k1")
(ng)
(use "IHr")
(save "LiftTwiceMod")

(add-rewrite-rule (pt "Lift(Lift r l k)l k1") (pt "Lift r l(k+k1)"))


; "LiftTwice"
(set-goal (pf "all r,l,k,k1.Lift(Lift r l k)(k+l)k1=Lift r l(k+k1)"))
(ind)
(ng)
(assume "n" "l" "k" "k1")
(cases (pt "n<l"))
(assume "n<l")
(ng)
(add-global-assumption "LiftTwiceAux1" (pf "all n,l,k.n<l -> n<k+l"))
(cut (pf "n<k+l"))
(assume "n<k+l")
(simp "n<k+l")
(use "Truth-Axiom")
(use "LiftTwiceAux1")
(use "n<l")

(assume "n<l -> F")
(ng)
(cut (pf "n+k<k+l -> F"))
(assume "n+k<k+l -> F")
(simp "n+k<k+l -> F")
(use "Truth-Axiom")
(assume "n+k<k+l")
(use "n<l -> F")
(add-global-assumption "LiftTwiceAux2" (pf "all n,l,k.n+k<k+l -> n<l"))
(use "LiftTwiceAux2" (pt "k"))
(use "n+k<k+l")

; Case App r s
(assume "r" "s" "IHr" "IHs" "l" "k" "k1")
(ng)
(simp "IHr")
(simp "IHs")
(use "Truth-Axiom")
; (use "DBCompatApp")
; (use "IHr")
; (use "IHs")

; Case Abs r
(assume "r" "IHr" "l" "k" "k1")
(ng)
; (use "IHr") ;`unusable formula' ??  Reason: (-> ref.tex)
; There are situations when use is not applicable but use-with is.
; Consider the goal P(Succ(k+l)) in a context H: all l P(k+l).  Then
; (use "H") cannot find the substitution l -> Succ l, but clearly
; (use-with (pt "Succ l")) works.
(use-with "IHr" (pt "Succ l") (pt "k") (pt "k1"))
(save "LiftTwice")


(add-global-assumption
 "LiftTwiceGen"
 (pf "all r,l,k,m,n.Lift(Lift r l k)(l+m+k)n=Lift(Lift r(l+m)n)l k"))

; Substitution in the style of Hancock/Joachimski

(add-alg "sub"
	 '("Up" "nat=>sub")
	 '("Dot" "dB=>sub=>sub"))

(add-var-name "theta" (py "sub"))

(add-program-constant "Sublift" (py "sub=>nat=>sub") 1 'const 2)

(add-computation-rule (pt "Sublift(Up m)n") (pt "Up(m+n)"))
(add-computation-rule (pt "Sublift(Dot r theta)n")
		      (pt "Dot(Lift r 0 n)(Sublift theta n)"))

; "SubliftId"
(set-goal (pf "all theta.Sublift theta 0=theta"))
(ind)
(assume "k")
(use "Truth-Axiom")
(assume "r" "theta" "IHtheta")
(ng)
(use "IHtheta")
(save "SubliftId")

(add-rewrite-rule (pt "Sublift theta 0") (pt "theta"))

; "SubliftTwice"
(set-goal (pf "all theta,n,m.Sublift(Sublift theta n)m=Sublift theta(n+m)"))
(ind)
(assume "k" "n" "m")
(ng)
(use "Truth-Axiom")
(assume "r" "theta" "IHtheta" "n" "m")
(ng)
(use "IHtheta")
(save "SubliftTwice")

; Sub r theta substitutes theta in the term r

(add-program-constant "Sub" (py "dB=>sub=>dB") 1 'const 2)

(add-computation-rule (pt "Sub(Var n)(Up m)") (pt "Var(n+m)"))
(add-computation-rule (pt "Sub(Var 0)(Dot r theta)") (pt "r"))
(add-computation-rule (pt "Sub(Var(Succ n))(Dot r theta)")
		      (pt "Sub(Var n)theta"))
(add-computation-rule (pt "Sub(r s)theta") (pt "(Sub r theta)(Sub s theta)"))
(add-computation-rule (pt "Sub(Abs r)theta")
		      (pt "(Abs(Sub r(Dot(Var 0)(Sublift theta 1))))"))

; In Coq we need a separate SubVar here, because Fixpoint does not allow
; this form of structural recursion.


; Spare appends 0 1 ... (m-1) to a substitution.

(add-program-constant "Spare" (py "nat=>sub=>sub") 1 'const 2)

(add-computation-rule (pt "Spare 0 theta") (pt "theta"))
(add-computation-rule (pt "Spare(Succ m)theta")
		      (pt "Spare m(Dot(Var m)theta)"))

; "SubVarSpare"
(set-goal (pf "all m,k,theta.Sub(Var(k+m))(Spare m theta)=Sub(Var k)theta"))
(ind)
(assume "k" "theta")
(use "Truth-Axiom")
(assume "m" "IHm" "k" "theta")
(ng)
(cut (pf "Succ(k+m)=Succ k+m"))
(assume "H1")
(simp "H1")
(use-with "IHm" (pt "Succ k") (pt "Dot(Var m)theta"))
(use "Truth-Axiom")
(save "SubVarSpare")

; "SubVarSpareLt"
(set-goal (pf "all m,k,theta.k<m -> Sub(Var k)(Spare m theta)=Var k"))
(ind)
(assume "k" "theta" "Absurd")
(use "Efq")
(use "Absurd")
(assume "m" "IHm" "k" "theta" "k<m+1")
(use "LtSuccCases" (pt "m") (pt "k"))
(use "k<m+1")
(ng)
(use "IHm")
(assume "k=m")
(simp "k=m")
(ng)
(use-with "SubVarSpare" (pt "m") (pt "0") (pt "Dot(Var m)theta"))
(save "SubVarSpareLt")

; "DotVarSubliftSpare"
(set-goal
 (pf "all m,theta.Dot(Var 0)(Sublift(Spare m theta)1)=
                  Spare(Succ m)(Sublift theta 1)"))
(ind)
(assume "theta")
(use "Truth-Axiom")
(assume "m" "IHm" "theta")
(ng)
(use-with "IHm" (pt "Dot(Var m)theta"))
(save "DotVarSubliftSpare")


; Joachimski's (2)
; "LiftEq"
(set-goal (pf "all r,n,m.Lift r m n=Sub r(Spare m(Up(m+n)))"))
(ind)
(assume "k" "n" "m")
(ng)
(cases (pt "k<m"))
(assume "k<m")
(ng)
(inst-with-to "SubVarSpareLt" (pt "m") (pt "k") (pt "Up(m+n)") "k<m" "H1")
(simp "H1")
(use "Truth-Axiom")
(assume "k<m -> F")
(ng)
(cut (pf "k=(k-m)+m"))
(assume "H2")
(simp "H2")
(cut (pf "Sub(Var(k-m+m))(Spare m(Up(m+n)))=Sub(Var(k-m))(Up(m+n))"))
(assume "H3")
(simp "H3")
(ng)
(use "Truth-Axiom")
(use "SubVarSpare")
(add-global-assumption "LiftEqAux" (pf "all k,m.(k<m -> F) -> k=k-m+m"))
(use "LiftEqAux")
(use "k<m -> F")

; App
(assume "r" "s" "IHr" "IHs" "n" "m")
(ng)
(inst-with-to "IHr" (pt "n") (pt "m") "IHrEq")
(simp "IHrEq")
(inst-with-to "IHs" (pt "n") (pt "m") "IHsEq")
(simp "IHsEq")
(use "Truth-Axiom")

; Abs
(assume "r" "IHr" "n" "m")
(ng)
(simp "DotVarSubliftSpare")
(simp "IHr")
(use "Truth-Axiom")
(save "LiftEq")

; (cut (pf "Dot(Var 0)(Sublift(Spare m (Up(m+n)))1)=
;                   Spare(Succ m)(Sublift (Up(m+n)) 1)"))
; (assume "H4")
; (simp "H4")
; (use "DotVarSubliftSpare")
; (cut (pf "Sublift(Up(m+n))1=Up(Succ m+n)"))
; (assume "H5")
; (simp "H5")
; (use "IHr")
; (ng)
; (use "Truth-Axiom")
; (use "DotVarSubliftSpare")


; Composition on substitutions, written infix

(add-program-constant "Subcompose" (py "sub=>sub=>sub") 1 'const 2)

(add-token
 "circ"
 'mul-op
 (lambda (x y)
   (let* ((type1 (term-to-type x))
	  (type2 (term-to-type y))
	  (type (types-lub type1 type2)))
     (mk-term-in-app-form
      (make-term-in-const-form (pconst-name-to-pconst "Subcompose"))
      x y))))

(add-display
 (py "sub")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "Subcompose"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'mul-op "circ"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))

(add-computation-rule (pt "Up 0 circ theta") (pt "theta"))
(add-computation-rule (pt "Up(Succ n) circ Dot r theta")
		      (pt "Up n circ theta"))
(add-computation-rule (pt "Up(Succ n)circ Up m") (pt "Up(Succ n+m)"))
(add-computation-rule (pt "Dot r theta circ theta1")
		      (pt "Dot(Sub r theta1)(theta circ theta1)"))


; "CircUpUp"
(set-goal (pf "all m,n.Up m circ Up n=Up(m+n)"))
(ind)
(assume "n")
(use "Truth-Axiom")
(assume "m" "IHm" "n")
(use "Truth-Axiom")
(save "CircUpUp")

(add-rewrite-rule (pt "Up m circ Up n") (pt "Up(m+n)"))


; Joachimski's (3)
; "CircUp"
(set-goal (pf "all n,theta.theta circ Up n=Sublift theta n"))
(assume "n")
(ind)
(assume "m")
(ng)
(use "Truth-Axiom")
(assume "r" "theta" "IHtheta")
(ng)
(simp "IHtheta")
(simp "LiftEq")
(use "Truth-Axiom")
(save "CircUp")

; (cut (pf "Lift r 0 n=Sub r(Up n)"))
; (assume "H1")
; (simp "H1")
; (use "Truth-Axiom")
; (use-with "LiftEq" (pt "r") (pt "n") (pt "0"))

(add-rewrite-rule (pt "theta circ Up n") (pt "Sublift theta n"))


; Joachimski's (4)
; "LiftSubSpare"
(set-goal (pf "all r,m,theta,n.
  Lift(Sub r(Spare m theta))m n=Sub r(Spare m(Sublift theta n))"))

; Counterexample:
; r=Var 1, m=1, theta=Up 0, n=2
(pp (nt (pt "Lift(Sub(Var 1)(Spare 1(Up 0)))1 2"))) ;=> Var 0
(pp (nt (pt "Sub(Var 1)(Spare 1(Sublift(Up 0)2))"))) ;=> Var 2

; Correction (4').  First an auxiliary proposition.
; "LiftSubSpareAux1"
(set-goal (pf "all theta,l,m,n.Lift(Sub(Var l)(Sublift theta m))m n=
                               Sub(Var l)(Sublift theta(m+n))"))
(ind)
(assume "k")
(ng)
(aga "LiftSubSpareAux2" (pf "all l,k,m.l+k+m<m -> F"))
(assume "l" "m" "n")
(cut (pf "l+k+m<m -> F"))
(assume "H1")
(simp "H1")
(use "Truth-Axiom")
(use "LiftSubSpareAux2")
(assume "s" "theta" "IHtheta")
(ind)
(assume "m" "n")
(ng)
(use-with "LiftTwice" (pt "s") (pt "0") (pt "m") (pt "n"))
(assume "l" "IHl" "m" "n")
(ng)
(use "IHtheta")
(save "LiftSubSpareAux1")

; Now the corrected (4')
; "LiftSubSpare"
(set-goal (pf "all r,m,theta,n.
  Lift(Sub r(Spare m(Sublift theta m)))m n=
  Sub r(Spare m(Sublift theta(m+n)))"))
(ind)
(assume "k" "m" "theta" "n")
(cases (pt "k<m"))
(assume "k<m")
(simp "SubVarSpareLt")
(simp "SubVarSpareLt")
(ng)
(simp "k<m")
(use "Truth-Axiom")
(use "k<m")
(use "k<m")
; (cut (pf "Sub(Var k)(Spare m(Sublift theta m))=Var k"))
; (assume "H2")
; (simp "H2")
; (cut (pf "Sub(Var k)(Spare m(Sublift theta(m+n)))=Var k"))
; (assume "H3")
; (simp "H3")
; (ng)
; (simp "k<m")
; (use "Truth-Axiom")
; (use "SubVarSpareLt")
; (use "k<m")
; (use "SubVarSpareLt")
; (use "k<m")

(assume "k<m -> F")
(cut (pf "k=(k-m)+m"))
(assume "H4")
(simp "H4")
(simp "SubVarSpare")
(simp "SubVarSpare")
(use "LiftSubSpareAux1")
; (cut (pf "Sub(Var(k-m+m))(Spare m(Sublift theta m))=
;           Sub(Var(k-m))(Sublift theta m)"))
; (assume "H5")
; (simp "H5")
; (cut (pf "Sub(Var(k-m+m))(Spare m(Sublift theta(m+n)))=
;           Sub(Var(k-m))(Sublift theta(m+n))"))
; (assume "H6")
; (simp "H6")
; (use "LiftSubSpareAux1")
; (use "SubVarSpare")
; (use "SubVarSpare")
(add-global-assumption "LiftEqAux" (pf "all k,m.(k<m -> F) -> k=k-m+m"))
(use "LiftEqAux")
(use "k<m -> F")

; App
(assume "r" "s" "IHr" "IHs" "m" "theta" "n")
(ng)
(simp "IHr")
(simp "IHs")
(use "Truth-Axiom")
; (cut (pf "Lift(Sub r(Spare m(Sublift theta m)))m n=
;           Sub r(Spare m(Sublift theta(m+n)))"))
; (assume "H7")
; (simp "H7")
; (cut (pf "Lift(Sub s(Spare m(Sublift theta m)))m n=
;           Sub s(Spare m(Sublift theta(m+n)))"))
; (assume "H8")
; (simp "H8")
; (use "Truth-Axiom")
; (use "IHs")
; (use "IHr")

; Abs
(assume "r" "IHr" "m" "theta" "n")
(ng)
(simp "DotVarSubliftSpare")
(simp "SubliftTwice")
(simp (pf "m+1=Succ m"))
(simp "IHr")
(simp "DotVarSubliftSpare")
(simp "SubliftTwice")
(simp (pf "Succ m+n=m+n+1"))
(use "Truth-Axiom")
(use "Truth-Axiom")
(use "Truth-Axiom")
(save "LiftSubSpare")


; Joachimski's (5)
"CircSublift"
(set-goal (pf "all theta,theta1,n.
  theta circ Sublift theta1 n=Sublift (theta circ theta1) n"))
(ind)
(ind)
(assume "theta1" "n")
(use "Truth-Axiom")
(assume "k" "IHk")
(cases)
(assume "l" "n")
(ng)
(use "Truth-Axiom")
(assume "r" "theta1" "n")
(ng)
(use "IHk")

(assume "r" "theta" "IHtheta" "theta1" "n")
(ng)
(simp "IHtheta")
(ng)
(simp-with "<-" "LiftSubSpare" (pt "r") (pt "0") (pt "theta1") (pt "n"))
(use "Truth-Axiom")
(save "CircSublift")

(add-program-constant "Pushlist" (py "list dB=>sub=>sub") 1 'const 2)

(add-var-name "rs" (py "list dB"))

(add-computation-rule (pt "Pushlist(Nil dB)theta") (pt "theta"))
(add-computation-rule (pt "Pushlist(r::rs)theta")
		      (pt "Dot r(Pushlist rs theta)"))

; "PushlistEq"
(set-goal (pf "all k,theta,rs.Sub(Var(k+Lh rs))(Pushlist rs theta)=
                              Sub(Var k)theta"))
(assume "k" "theta")
(ind)
(use "Truth-Axiom")
(assume "r" "rs" "IHrs")
(ng)
(use "IHrs")
(save "PushlistEq")

(add-rewrite-rule (pt "Sub(Var(k+Lh rs))(Pushlist rs theta)")
		  (pt "Sub(Var k)theta"))

(add-program-constant "Liftlist" (py "list dB=>nat=>nat=>list dB") 1)

(add-computation-rule (pt "Liftlist(Nil dB)m n") (pt "(Nil dB)"))
(add-computation-rule (pt "Liftlist(r::rs)m n")
		      (pt "(Lift r m n)::(Liftlist rs m n)"))

; "SubliftPushlist"
(set-goal (pf "all theta,n,rs.Sublift(Pushlist rs theta)n=
                              Pushlist(Liftlist rs 0 n)(Sublift theta n)"))
(assume "theta" "n")
(ind)
(use "Truth-Axiom")
(assume "r" "rs" "IHrs")
(ng)
(use "IHrs")
(save "SubliftPushlist")

(add-rewrite-rule (pt "Sublift(Pushlist rs theta)n")
		  (pt "Pushlist(Liftlist rs 0 n)(Sublift theta n)"))

; "LhLiftlist"
(set-goal (pf "all m,n,rs.Lh rs=Lh(Liftlist rs m n)"))
(assume "m" "n")
(ind)
(use "Truth-Axiom")
(assume "r" "rs" "IHrs")
(ng)
(use "IHrs")
(save "LhLiftlist")


; Joachimski's (6)
; "SubLiftSpare"
(set-goal (pf "all r,m,rs,theta.
  Sub(Lift r m Lh rs)(Spare m(Pushlist rs theta))=Sub r(Spare m theta)"))
(ind)
(assume "k" "m" "rs" "theta")
(cases (pt "k<m"))
(assume "k<m")
(ng)
(simp "k<m")
(ng)
(simp "SubVarSpareLt")
(simp "SubVarSpareLt")
(use "Truth-Axiom")
(use "k<m")
(use "k<m")

(assume "k<m -> F")
(ng)
(simp "k<m -> F")
(ng)
(cut (pf "k+Lh rs=k-m+Lh rs+m"))
(assume "H3")
(simp "H3")
(cut (pf "Sub(Var(k-m+Lh rs+m))(Spare m(Pushlist rs theta))=
          Sub(Var(k-m+Lh rs))(Pushlist rs theta)"))
(assume "H4")
(ng)
(simp "H4")
(ng)
(cut (pf "Var k=Var(k-m+m)"))
(assume "H5")
(simp "H5")
(cut (pf "Sub(Var(k-m+m))(Spare m theta)=Sub(Var(k-m))theta"))
(assume "H6")
(simp "H6")
(use "Truth-Axiom")
(use "SubVarSpare")
(add-global-assumption "SubLiftSpareAux1" (pf "all k,m.(k<m -> F) -> k-m+m=k"))
(cut (pf "k-m+m=k"))
(assume "H7")
(simp "H7")
(use "Truth-Axiom")
(use "SubLiftSpareAux1")
(use "k<m -> F")
(use "SubVarSpare")
(add-global-assumption "SubLiftSpareAux2"
		       (pf "all k,m,n.(k<m -> F) -> k+n=k-m+n+m"))
(use "SubLiftSpareAux2")
(use "k<m -> F")

; App
(assume "r" "s" "IHr" "IHs" "m" "rs" "theta")
(ng)
(simp "IHr")
(simp "IHs")
(use "Truth-Axiom")

; Abs
(assume "r" "IHr" "m" "rs" "theta")
(ng)
(cut (pf "(Dot(Var 0)(Sublift(Spare m(Pushlist rs theta))1))=
          Spare(Succ m)(Sublift(Pushlist rs theta)1)"))
(assume "H8")
(simp "H8")
(cut (pf "(Dot(Var 0)(Sublift(Spare m theta)1))=
          Spare(Succ m)(Sublift theta 1)"))
(assume "H9")
(simp "H9")
(cut (pf "Sublift(Pushlist rs theta)1=
          Pushlist(Liftlist rs 0 1)(Sublift theta 1)"))
(assume "H10")
(simp "H10")
(cut (pf "Lh rs=Lh(Liftlist rs 0 1)"))
(assume "H11")
(simp "H11")
(use "IHr")
(use "LhLiftlist")
(use "SubliftPushlist")
(use "DotVarSubliftSpare")
(use "DotVarSubliftSpare")
(save "SubLiftSpare")


; "SubliftCircAux"
(set-goal
 (pf "all m,theta,rs.Up(m+Lh rs)circ Pushlist rs theta=Up m circ theta"))
(assume "m" "theta")
(ind)
(ng)
(use "Truth-Axiom")
(assume "r" "rs" "IHr")
(ng)
(use "IHr")
(save "SubliftCircAux")


; Joachimski's (6')
; "SubliftCirc"
(set-goal (pf "all theta,theta1,rs.
  Sublift theta Lh rs circ Pushlist rs theta1=theta circ theta1"))
(ind)
(assume "m" "theta1" "rs")
(ng)
(use "SubliftCircAux")
(assume "r" "theta" "IHtheta" "theta1" "rs")
(ng)
(cut (pf "(Sub(Lift r 0 Lh rs)(Pushlist rs theta1))=Sub r theta1"))
(assume "H1")
(simp "H1")
(cut (pf "Sublift theta Lh rs circ Pushlist rs theta1=theta circ theta1"))
(assume "H2")
(simp "H2")
(use "Truth-Axiom")
(use "IHtheta")
(use-with "SubLiftSpare" (pt "r") (pt "0") (pt "rs") (pt "theta1"))
(save "SubliftCirc")


; "SubVarUp"
(set-goal (pf "all theta,n,m.Sub(Var(n+m))theta=Sub(Var n)(Up m circ theta)"))
(ind)
(assume "k" "n" "m")
(ng)
(use "Truth-Axiom")
(assume "r" "theta" "IHtheta" "n")
(cases)
(ng)
(use "Truth-Axiom")
(assume "m")
(use "IHtheta")
(save "SubVarUp")


; Joachimski's (7)
; "SubSub"
(set-goal (pf "all r,theta,theta1.
  Sub(Sub r theta)theta1=Sub r(theta circ theta1)"))
(ind)
(ind)
(ind)
(assume "m" "theta1")
(ng)
(use-with "SubVarUp" (pt "theta1") (pt "0") (pt "m"))
(assume "r" "theta" "IHtheta" "theta1")
(ng)
(use "Truth-Axiom")
(assume "n" "IHn")
(ind)
(assume "k" "theta1")
(ng)
(use-with "SubVarUp" (pt "theta1") (pt "Succ n") (pt "k"))
(assume "r" "theta" "IHtheta")
(ng)
(use "IHn")

; App
(assume "r" "s" "IHr" "IHs" "theta" "theta1")
(ng)
(simp "IHr")
(simp "IHs")
(use "Truth-Axiom")

; Abs
(assume "r" "IHr" "theta" "theta1")
(ng)
(cut (pf "Sub(Sub r(Dot(Var 0)(Sublift theta 1)))(Dot(Var 0)(Sublift theta1 1))
    =Sub r((Dot(Var 0)(Sublift theta 1))circ(Dot(Var 0)(Sublift theta1 1)))"))
(assume "H1")
(simp "H1")
(cut (pf "Dot(Var 0)(Sublift theta 1)circ Dot(Var 0)(Sublift theta1 1)=
          Dot(Var 0)(Sublift(theta circ theta1)1)"))
(assume "H2")
(simp "H2")
(use "Truth-Axiom")
(ng)
(cut (pf "Sublift theta 1 circ Dot(Var 0)(Sublift theta1 1)=
          theta circ(Sublift theta1 1)"))
(assume "H3")
(simp "H3")
(use "CircSublift")
(use-with "SubliftCirc" (pt "theta") (pt "Sublift theta1 1")
	  (pt "(Var 0)::(Nil dB)"))
(use "IHr")
(save "SubSub")


; Joachimski's (7')
; "CircAssoc"
(set-goal (pf "all theta,theta1,theta2.
  theta circ(theta1 circ theta2)=(theta circ theta1)circ theta2"))
(ind)
(ind)
(ng)
(assume "theta1" "theta2")
(use "Truth-Axiom")
(assume "k" "IHk")
(ind)
(ind)
(assume "theta2")
(ng)
(use "Truth-Axiom")
(assume "n" "IHn")
(ind)
(ng)
(assume "l")
(use "Truth-Axiom")
(assume "r" "theta2")
(assume "IHtheta2")
(ng)
(cut (pf "Up(Succ k)circ(Up n circ theta2)=Up(Succ(k+n))circ theta2"))
(assume "H1")
(simp "H1")
(use "Truth-Axiom")
(use "IHn")
(assume "r" "theta1" "IHtheta1")
(ng)
(assume "theta2")
(use "IHk")
(assume "r" "theta" "IHtheta")
(assume "theta1" "theta2")
(ng)
(cut (pf "theta circ(theta1 circ theta2)=theta circ theta1 circ theta2"))
(assume "H2")
(simp "H2")
(cut (pf "Sub r(theta1 circ theta2)=Sub(Sub r theta1)theta2"))
(assume "H3")
(simp "H3")
(use "Truth-Axiom")
(cut (pf "Sub(Sub r theta1)theta2=Sub r(theta1 circ theta2)"))
(assume "H4")
(simp "H4")
(use "Truth-Axiom")
(use "SubSub")
(use "IHtheta")
(save "CircAssoc")  


; Joachimski's (8)
; "SubVarCirc"
(set-goal (pf "all n,theta.Sub(Var n)theta=Sub(Var 0)(Up n circ theta)"))
(ind)
(assume "theta")
(use "Truth-Axiom")
(assume "n" "IHn")
(cases)
(assume "m")
(use "Truth-Axiom")
(assume "r" "theta")
(ng)
(use "IHn")
(save "SubVarCirc")
; Alternatively we could have used SubSub.


; Joachimski's "SubLemma"
(pp (pf "all r,s,theta.
  Sub(Sub r(Dot s(Up 1)))theta=Sub r(Dot(Sub s theta)theta)"))

; Counterexample
; r=Var 1, theta=Up 0
(pp (nt (pt "Sub(Sub(Var 1)(Dot s(Up 1)))(Up 0)"))) ;=> Var 1
(pp (nt (pt "Sub(Var 1)(Dot(Sub s(Up 0))(Up 0))"))) ;=> Var 0


(add-program-constant "Beta" (py "dB=>dB=>dB"))

(add-computation-rule (pt "Beta(Var n)s") (pt "Var n s"))
(add-computation-rule (pt "Beta(r1 r2)s") (pt "r1 r2 s"))
(add-computation-rule (pt "Beta(Abs r)s") (pt "Sub r(Dot s(Up 0))")) ;Rep

; Red reduces the rank by one (cf. APAL 1998)
(add-program-constant "Red" (py "dB=>dB"))

(add-computation-rule (pt "Red(Var n)") (pt "Var n"))
(add-computation-rule (pt "Red(Var n s)") (pt "Var n(Red s)"))
(add-computation-rule (pt "Red(r1 r2 s)") (pt "Beta(Red(r1 r2))(Red s)")) ;Rep
(add-computation-rule (pt "Red(Abs r s)") (pt "Beta(Red(Abs r))(Red s)")) ;Rep 
(add-computation-rule (pt "Red(Abs r)") (pt "Abs(Red r)"))

; For infinitary terms one may insert Rep at the marked places.

"Abs(Abs(Var 1))" ;K
"Abs(Abs(Abs(Var 2(Var 0)(Var 1(Var 0)))))" ;S

(pp (nt (pt "Red(Red((Abs(Abs(Abs(Var 2(Var 0)(Var 1(Var 0))))))
             (Abs(Abs(Var 1)))(Abs(Abs(Var 1)))))")))

; "BetaAppSubAbs"
(set-goal (pf "all r,theta,s.Beta(Sub(Abs r)theta)s=Sub r(Dot s theta)"))
(assume "r" "theta" "s")
(ng)
(cut (pf "Sub(Sub r(Dot(Var 0)(Sublift theta 1)))(Dot s(Up 0))=
          Sub r((Dot(Var 0)(Sublift theta 1))circ(Dot s(Up 0)))"))
(assume "H1")
(simp "H1")
(ng)
(cut (pf "Sublift theta 1 circ Dot s(Up 0)=theta circ(Up 0)"))
(assume "H2")
(simp "H2")
(ng)
(use "Truth-Axiom")
(use-with "SubliftCirc" (pt "theta") (pt "Up 0") (pt "s::(Nil dB)"))
(use "SubSub")
(save "BetaAppSubAbs")


; 2005-01-08
; De Bruijn indices for typed lambda terms
; ========================================

(reset)
(libload "nat.scm")
(libload "list.scm")

(add-var-name "l" (py "nat"))

; "LtSuccCases"
(set-goal (pf "all m,n.n<Succ m -> (n<m -> Pvar^) -> (n=m -> Pvar^) -> Pvar^"))
(ind)
(cases)
(assume "H1" "H2" "H3")
(use "H3")
(use "Truth-Axiom")
(assume "n" "H1" "H2" "H3")
(use "Efq")
(use "H1")
(assume "m" "IHm")
(cases)
(assume "H1" "H2" "H3")
(use "H2")
(use "Truth-Axiom")
(use "IHm")
(save "LtSuccCases")

; General list functions

"LhAppend"
(set-goal (pf "all (list alpha)_2,(list alpha)_1.
                Lh((list alpha)_1:+:(list alpha)_2)=
                Lh (list alpha)_1+Lh (list alpha)_2"))
(assume "(list alpha)_2")
(cases)
(use "Truth-Axiom")
(assume "alpha" "(list alpha)_1")
(use "Truth-Axiom")
(save "LhAppend")

; "ListRefAppendLt"
(set-goal
 (pf "all (list alpha)_2,(list alpha)_1,k.k<Lh (list alpha)_1 -> 
       Equal(k thof (list alpha)_1:+:(list alpha)_2)(k thof (list alpha)_1)"))
(assume "(list alpha)_2")
(ind)
(assume "k" "Absurd")
(use "Efq")
(use "Absurd")
(assume "alpha" "(list alpha)_1" "IH")
(cases)
(assume "Trivial")
(ng)
(use "Eq-Refl")
(assume "k" "k<Lh (list alpha)_1")
(ng)
(use "IH")
(use "k<Lh (list alpha)_1")
(save "ListRefAppendLt")

; "ListRefAppendGe"
(set-goal
 (pf "all (list alpha)_2,(list alpha)_1,k.(k<Lh (list alpha)_1 -> F) -> 
       Equal(k thof (list alpha)_1:+:(list alpha)_2)
            ((k-Lh (list alpha)_1)thof (list alpha)_2)"))
(assume "(list alpha)_2")
(ind)
(assume "k" "Trivial")
(ng)
(use "Eq-Refl")
(assume "alpha" "(list alpha)_1" "IH")
(cases)
(assume "Absurd")
(use "Efq")
(use "Absurd")
(use "Truth-Axiom")
(assume "k" "k<Lh (list alpha)_1")
(ng)
(add-global-assumption "ListRefAppendGeAux1"
		       (pf "all k,l.(k<l -> F) -> Succ k-l=Succ(k-l)"))
(simp "ListRefAppendGeAux1")
(use "IH")
(use "k<Lh (list alpha)_1")
(use "k<Lh (list alpha)_1")
(save "ListRefAppendGe")


; Map for lists

(add-program-constant
 "ListMap" (py "(alpha1=>alpha2)=>list alpha1=>list alpha2") 1)

(add-token
 "map" 'pair-op ;right associative
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "ListMap"))
	    (tvars (const-to-tvars const))
	    (listtype (term-to-type y))
	    (type1 (car (alg-form-to-types listtype)))
	    (type2 (arrow-form-to-val-type (term-to-type x)))
	    (subst (make-substitution tvars (list type1 type2))))
       (const-substitute const subst #f)))
    x y)))

(add-display
 (py "list alpha")
 (lambda (x)
   (let* ((op (term-in-app-form-to-final-op x))
	  (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "ListMap"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'pair-op "map"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))

(add-computation-rule
 (pt "alpha1=>alpha2 map(Nil alpha1)")
 (pt "(Nil alpha2)"))

(add-computation-rule
 (pt "alpha1=>alpha2 map alpha1::(list alpha1)_1")
 (pt "alpha1=>alpha2 alpha1::alpha1=>alpha2 map(list alpha1)_1"))

; "LhMap"
(set-goal (pf "all alpha1=>alpha2,(list alpha1) 
                Lh(alpha1=>alpha2 map (list alpha1))=Lh(list alpha1)"))
(assume "alpha1=>alpha2")
(ind)
(use "Truth-Axiom")
(assume "alpha1" "list alpha1" "IH")
(use "IH")
(save "LhMap")

; "MapAppend"
(set-goal (pf "all alpha1=>alpha2,(list alpha1)_2,(list alpha1)_1
               Equal(alpha1=>alpha2 map ((list alpha1)_1:+:(list alpha1)_2))
               ((alpha1=>alpha2 map (list alpha1)_1):+:
                (alpha1=>alpha2 map (list alpha1)_2))"))
(assume "alpha1=>alpha2" "(list alpha1)_2")
(ind)
(ng)
(use-with "Eq-Refl" (py "list alpha2")
	  (pt "(alpha1=>alpha2 map(list alpha1)_2)"))
(assume "alpha1" "list alpha1" "IH")
(ng)
(simp "IH")
(use "Eq-Refl")
(save "MapAppend")

; "ListRefMap"
(set-goal (pf "all alpha1=>alpha2,(list alpha1),k.k<Lh(list alpha1) ->
               Equal(k thof(alpha1=>alpha2 map(list alpha1)))
                    (alpha1=>alpha2(k thof(list alpha1)))"))
(assume "alpha1=>alpha2")
(ind)
(assume "k" "Absurd")
(use "Efq")
(use "Absurd")
(assume "alpha1" "(list alpha1)" "IH")
(cases)
(assume "Trivial")
(ng)
(use "Eq-Refl")
(assume "k" "k<Lh List alpha1")
(ng)
(use "IH")
(use "k<Lh List alpha1")
(save "ListRefMap")

 
(add-alg "type"
	 '("Iota" "type")
	 '("Arrow" "type=>type=>type"))

(add-token
 "to"
 'pair-op
 (lambda (x y)
   (let* ((type1 (term-to-type x))
	  (type2 (term-to-type y))
	  (type (types-lub type1 type2)))
     (mk-term-in-app-form
      (make-term-in-const-form (constr-name-to-constr "Arrow"))
      x y))))

(add-display
 (py "type")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "Arrow"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'pair-op "to"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))

(add-var-name "rho" "sig" "tau" (py "type"))

(add-program-constant "Argtyp" (py "type=>type") 1)
(add-program-constant "Valtyp" (py "type=>type") 1)
(add-program-constant "Arrowtyp" (py "type=>boole") 1)

(add-computation-rule (pt "Argtyp Iota") (pt "Iota"))
(add-computation-rule (pt "Valtyp Iota") (pt "Iota"))
(add-computation-rule (pt "Argtyp(rho to sig)") (pt "rho"))
(add-computation-rule (pt "Valtyp(rho to sig)") (pt "sig"))

(add-computation-rule (pt "Arrowtyp Iota") (pt "False"))
(add-computation-rule (pt "Arrowtyp(rho to sig)") (pt "True"))

; (add-program-constant "Argtype" (py "type=>type"))
; (add-program-constant "Valtype" (py "type=>type"))
; (add-program-constant "Arrowtype" (py "type=>boole"))

; (add-computation-rule (pt "Argtype(rho to sig)") (pt "rho"))
; (add-computation-rule (pt "Valtype(rho to sig)") (pt "sig"))

; (add-computation-rule (pt "Arrowtype Iota") (pt "False"))
; (add-computation-rule (pt "Arrowtype(rho to sig)") (pt "True"))

(add-alg "term"
	 '("Var" "nat=>term")
	 '("App" "term=>term=>term")
	 '("Abs" "type=>term=>term"))

; Application for terms is via the constant App

(add-new-application 
 (lambda (type) (equal? type (py "term")))
 (lambda (term1 term2) (mk-term-in-app-form (pt "App") term1 term2)))

(add-new-application-syntax
 ; predicate
 (lambda (term)
   (and (term-in-app-form? term)
	(let ((op (term-in-app-form-to-op term)))
	  (term-in-app-form? op)
	  (term=? (pt "App") (term-in-app-form-to-op op)))))
 ; to arg
 (lambda (term)
   (term-in-app-form-to-arg term))
 ; to op
 (lambda (term)
   (term-in-app-form-to-arg
    (term-in-app-form-to-op term))))

(add-var-name "r" "s" "t" (py "term"))
(add-var-name "rhos" "sigs" "taus" (py "list type")) ;used for contexts

; Example
(define term1 (pt "Var 0(Abs tau(Var 3(Var 2)(Var 0)))"))
(pp term1)

(define rhos1 (pt "(rho to tau to sig)::rho::((tau to sig)to rho):"))
(pp rhos1)
(define revrhos1 (pt "((tau to sig)to rho)::rho::(rho to tau to sig):"))
(pp revrhos1)

(add-program-constant "Typ" (py "list type=>term=>type") 1)

(add-computation-rule (pt "Typ(Nil type)(Var n)") (pt "Iota"))
(add-computation-rule (pt "Typ(rho::rhos)(Var 0)") (pt "rho"))
(add-computation-rule (pt "Typ(rho::rhos)(Var(Succ n))")
		      (pt "Typ rhos(Var n)"))
(add-computation-rule (pt "Typ rhos(r s)") (pt "Valtyp(Typ rhos r)"))
(add-computation-rule (pt "Typ rhos(Abs rho r)")
		      (pt "rho to Typ(rho::rhos)r"))

; (pp (nt (mk-term-in-app-form (pt "Typ") revrhos1 term1)))

(add-program-constant "Cor" (py "list type=>term=>boole") 1)

(add-computation-rule (pt "Cor rhos(Var n)") (pt "n<Lh rhos"))
(add-computation-rule (pt "Cor rhos(r s)")
		      (pt "Cor rhos r and Cor rhos s and
                           Typ rhos r=(Typ rhos s to Valtyp(Typ rhos r))"))
(add-computation-rule (pt "Cor rhos(Abs rho r)") (pt "Cor(rho::rhos)r"))

; (pp (nt (mk-term-in-app-form (pt "Cor") revrhos1 term1)))

(add-program-constant "TypJ" (py "list type=>term=>type=>boole") 1)
(add-computation-rule (pt "TypJ rhos r rho")
		      (pt "Cor rhos r and Typ rhos r=rho"))

; (add-program-constant "Type" (py "list type=>term=>type"))

; (add-computation-rule (pt "Type rhos(Var n)")
; 		      (pt "Lh rhos-(Succ n) thof rhos"))
; (add-computation-rule (pt "Type rhos(r s)") (pt "Valtype(Type rhos r)"))
; (add-computation-rule (pt "Type rhos(Abs rho r)")
; 		      (pt "rho to(Type(rhos:+:(rho:))r)"))

; (pp (nt (mk-term-in-app-form (pt "Type") rhos1 term1)))

; (add-program-constant "Corr" (py "list type=>term=>boole"))

; (add-computation-rule (pt "Corr rhos(Var n)") (pt "n<Lh rhos"))
; (add-computation-rule (pt "Corr rhos(r s)")
; 		      (pt "Corr rhos r and Corr rhos s and
;                            Argtype(Type rhos r)=Type rhos s"))
; (add-computation-rule (pt "Corr rhos(Abs rho r)") (pt "Corr(rhos:+:(rho:))r"))

; (pp (nt (mk-term-in-app-form (pt "Corr") rhos1 term1)))

; (add-program-constant "Typed" (py "list type=>term=>type=>boole"))
; (add-computation-rule (pt "Typed rhos r rho")
; 		      (pt "(Corr rhos r)and(Type rhos r=rho)"))

(add-program-constant "Up" (py "nat=>term=>term") 1)

(add-computation-rule (pt "Up l(Var n)")
		      (pt "[if (n<l) (Var n) (Var(Succ n))]"))
(add-computation-rule (pt "Up l(r s)")
		      (pt "(Up l r)(Up l s)"))
(add-computation-rule (pt "Up l(Abs rho r)")
		      (pt "Abs rho(Up(Succ l)r)"))

; "UpUp"
(set-goal (pf "all m,r,l.Up(m+Succ l)(Up l r)=Up l(Up(m+l)r)"))
(assume "m")
(ind)
(assume "k")
(assume "l")
(cases (pt "k<l"))

(assume "k<l")
(ng)
(simp "k<l")
(ng)
(add-global-assumption "UpUpAux1" (pf "all k,l,m.k<l -> k<Succ(m+l)"))
(simp "UpUpAux1")
(ng)
(add-global-assumption "UpUpAux2" (pf "all k,l,m.k<l -> k<m+l"))
(simp "UpUpAux2")
(ng)
(simp "k<l")
(use "Truth-Axiom")
(use "k<l")
(use "k<l")

(assume "k<l -> F")
(ng)
(simp "k<l -> F")
(ng)
(cases (pt "k<m+l"))

(assume "k<m+l")
(ng)
(simp "k<l -> F")
(use "Truth-Axiom")

(assume "k<m+l -> F")
(ng)
(add-global-assumption "UpUpAux3"
		       (pf "all k,l.(k<l -> F) -> Succ k<l -> F"))
(simp (pf "Succ k<l -> F"))
(use "Truth-Axiom")
(use "UpUpAux3")
(use "k<l -> F")

; App
(assume "r" "s" "IHr" "IHs" "l")
(ng)
(simp "IHr")
(simp "IHs")
(use "Truth-Axiom")

; Abs
(assume "rho" "r" "IHr" "l")
(ng)
(simp-with "IHr" (pt "Succ l"))
(use "Truth-Axiom")
(save "UpUp")

; Use Var map(Seq n l) instead of VarSeq n l.

(add-program-constant "Seq" (py "nat=>nat=>list nat") 1)

(add-computation-rule (pt "Seq n 0") (pt "(Nil nat)"))
(add-computation-rule (pt "Seq n(Succ l)") (pt "n::Seq(Succ n)l"))

; (pp (nt (pt "Seq 2 5")))
; => 2::3::4::5::6:

"LhSeq"
(set-goal (pf "all l,n Lh(Seq n l)=l"))
(ind)
(assume "n")
(use "Truth-Axiom")
(assume "l" "IHl")
(assume "n")
(ng)
(use "IHl")
(save "LhSeq")

"ListRefSeq"
(set-goal (pf "all l,k,n.k<l -> (k thof Seq n l)=k+n"))
(ind)
(assume "n" "k" "Absurd")
(use "Efq")
(use "Absurd")
(assume "l" "IHl")
(cases)
(assume "k" "Trivial")
(use "Truth-Axiom")
(assume "k" "n" "k<l")
(ng)
(use-with "IHl" (pt "k") (pt "Succ n") "k<l")
(save "ListRefSeq")

"UpSeq"
(set-goal (pf "all l,n (Up 0 map Var map Seq n l)=(Var map Seq(Succ n)l)"))
(ind)
(assume "n")
(use "Truth-Axiom")
(assume "l" "IHl" "n")
(use "IHl")
(save "UpSeq")

(add-var-name "ns" "ms" (py "list nat"))

"NatMapAppend"
; (set-goal (pf "all nat=>nat,ns2,ns1 
;                Equal(nat=>nat map ns1:+:ns2)
;                     ((nat=>nat map ns1):+:(nat=>nat map ns2))"))
; (use-with "MapAppend" (py "nat") (py "nat"))
; (save "NatMapAppend")

(add-program-constant "NatMax" (py "nat=>nat=>nat") 1)

(add-token
 "max"
 'mul-op
 (lambda (x y)
   (mk-term-in-app-form
      (make-term-in-const-form (pconst-name-to-pconst "NatMax"))
      x y)))

(add-display
 (py "nat")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "NatMax"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'mul-op "max"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))

(add-computation-rule (pt "0 max n") (pt "n"))
(add-computation-rule (pt "Succ m max 0") (pt "Succ m"))
(add-computation-rule (pt "Succ m max Succ n") (pt "Succ(m max n)"))
(add-rewrite-rule (pt "m max 0") (pt "m"))

(add-global-assumption "MaxUB1" (pf "all n,m n<=n max m"))
(add-global-assumption "MaxUB2" (pf "all n,m m<=n max m"))
(add-global-assumption "MaxLUB" (pf "all n,m,k.n<=k -> m<=k -> n max m<=k"))
(add-global-assumption "MaxLUB1" (pf "all n,m.n<=m -> n max m=m"))
(add-global-assumption "MaxLUB2" (pf "all n,m.m<=n -> n max m=n"))

; Free r is the least variable bigger than all variables free in r.
; If Free r=0, then r is closed.

(add-program-constant "Free" (py "term=>nat") 1)

(add-computation-rule (pt "Free(Var n)") (pt "Succ n"))
(add-computation-rule (pt "Free(r s)") (pt "Free r max Free s"))
(add-computation-rule (pt "Free(Abs rho r)") (pt "Pred(Free r)"))

; (pp (nt (pt "Free(Var 0(Abs tau(Var 3(Var 2)(Var 0))))")))

(add-program-constant "MaxFree" (py "list term=>nat") 1)

(add-var-name "rs" "ss" "ts" (py "list term"))

(add-computation-rule (pt "MaxFree(Nil term)") (pt "0"))
(add-computation-rule (pt "MaxFree(r::ss)") (pt "Free r max MaxFree ss"))

(display-program-constants "Up")

; "UpFree"
(set-goal
 (pf "all r,l.Free(Up l r)=[if (Free r<Succ l) (Free r) (Succ(Free r))]"))
(ind)
(assume "n" "l")
(ng)
(cases (pt "n<l"))
(assume "n<l")
(ng)
(use "Truth-Axiom")
(assume "n<l -> F")
(ng)
(use "Truth-Axiom")

; App
(assume "r" "s" "IHr" "IHs" "l")
(ng)
(cases (pt "Free r<Succ l"))
(assume "Free r<Succ l")
(simp "IHr")
(simp "Free r<Succ l")
(ng)
(cases (pt "Free s<Succ l"))
(assume "Free s<Succ l")
(simp "IHs")
(simp "Free s<Succ l")
(ng)
(cut (pf "Free r max Free s<Succ l"))
(assume "H")
(simp "H")
(use "Truth-Axiom")
(add-global-assumption "UpFreeAux1" (pf "all n,m,k.n<k -> m<k -> n max m<k"))
(use "UpFreeAux1")
(auto)
(assume "Free s<Succ l -> F")
(simp "IHs")
(simp "Free s<Succ l -> F")
(ng)
(cut (pf "Free r max Free s=Free s"))
(assume "H")
(simp "H")
(simp "Free s<Succ l -> F")
(ng)
(use "MaxLUB1")
(add-global-assumption "LeSucc" (pf "all n,m n<=Succ m"))
(use "LeSucc")
(use "MaxLUB1")
(add-global-assumption "TransLtLe" (pf "all n,m,k.n<m -> m<=k -> n<k"))
(add-global-assumption "LtLe" (pf "all n,m.n<m -> n<=m"))
(use "LtLe")
(use "TransLtLe" (pt "Succ l"))
(use "Free r<Succ l")
(add-global-assumption "NotLtImpLe" (pf "all n,m.(n<m -> F) -> m<=n"))
(use "NotLtImpLe")
(use "Free s<Succ l -> F")

(assume "Free r<Succ l -> F")
(simp "IHr")
(simp "Free r<Succ l -> F")
(ng)
(cases (pt "Free s<Succ l"))
(assume "Free s<Succ l")
(simp "IHs")
(simp "Free s<Succ l")
(ng)
(cut (pf "Free r max Free s=Free r"))
(assume "H")
(simp "H")
(simp "Free r<Succ l -> F")
(ng)
(use "MaxLUB2")
(add-global-assumption "TransLe" (pf "all n,m,k.n<=m -> m<=k -> n<=k"))
(use "TransLe" (pt "Free r"))
(use "LtLe")
(use "TransLtLe" (pt "Succ l"))
(use "Free s<Succ l")
(use "NotLtImpLe")
(use "Free r<Succ l -> F")
(add-global-assumption "LeSucc" (pf "all n,m n<=Succ m"))
(use "LeSucc")
(use "MaxLUB2")
(use "LtLe")
(use "TransLtLe" (pt "Succ l"))
(use "Free s<Succ l")
(use "NotLtImpLe")
(use "Free r<Succ l -> F")

(assume "Free s<Succ l -> F")
(simp "IHs")
(simp "Free s<Succ l -> F")
(ng)
(cut (pf "Free r max Free s<Succ l -> F"))
(assume "H")
(simp "H")
(ng)
(use "Truth-Axiom")
(add-global-assumption "UpFreeAux2"
		       (pf "all n,m,k.(n<k -> F) -> (m<k -> F) -> 
                                       n max m<k -> F"))
(use "UpFreeAux2")
(use "Free r<Succ l -> F")
(use "Free s<Succ l -> F")

; Abs
(assume "rho" "r" "IHr" "l")
(ng)
(simp "IHr")
(cases (pt "Free r"))
(assume "Free r=0")
(use "Truth-Axiom")
(assume "n" "Free r=Succ n")
(ng)
(cases (pt "n<Succ l"))
(assume "H")
(simp "H")
(ng)
(use "Truth-Axiom")
(assume "H")
(ng)
(use "Truth-Axiom")
(save "UpFree")

"FreeUp"
(set-goal (pf "all r,m Free(Up m r)<=Succ(Free r)"))
(assume "r" "m")
(simp "UpFree")
(cases (pt "Free r<Succ m"))
(assume "H")
(ng)
(use "LeSucc")
(assume "H")
(ng)
(use "Truth-Axiom")
(save "FreeUp")

"FreeUpList"
(set-goal (pf "all m,rs MaxFree(Up m map rs)<=Succ(MaxFree rs)"))
(assume "m")
(ind)
(ng)
(use "Truth-Axiom")
(assume "r" "rs" "IHrs")
(ng)
(use "TransLe" (pt "(Succ(Free r)) max (Succ(MaxFree rs))"))
(use "MaxLUB")
(use "TransLe" (pt "Succ(Free r)"))
(use "FreeUp")
(use "MaxUB1")
(use "TransLe" (pt "Succ(MaxFree rs)"))
(use "IHrs")
(use "MaxUB2")
(add-global-assumption "SuccMax"
		       (pf "all n,m.Succ n max Succ m=Succ(n max m)"))
(simp "SuccMax")
(ng)
(use "Truth-Axiom")
(save "FreeUpList")

; Instead of Spare m we use Var map(Seq 0 m)
; (pp (nt (pt "Var map(Seq 2 5)")))

; "MapUpUp"
(set-goal (pf "all rs,m,l.(Up(m+Succ l) map Up l map rs)=
                          (Up l map Up(m+l) map rs)"))
(ind)
(assume "m" "l")
(use "Truth-Axiom")
(assume "r" "rs" "IHrs" "m" "l")
(ng)
(split)
(use "UpUp")
(use "IHrs")
(save "MapUpUp")

(add-program-constant "Sub" (py "term=>list term=>term") 1)

; Defining
; (add-computation-rule (pt "Sub(Var k)rs") (pt "k thof rs"))
; would make Sub partial.  Hence we prefer

(add-computation-rule (pt "Sub(Var n)(Nil term)") (pt "Var n"))
(add-computation-rule (pt "Sub(Var 0)(r::rs)") (pt "r"))
(add-computation-rule (pt "Sub(Var(Succ n))(r::rs)") (pt "Sub(Var n)rs"))
(add-computation-rule (pt "Sub(r s)rs") (pt "Sub r rs(Sub s rs)"))
(add-computation-rule (pt "Sub(Abs rho r)rs")
		      (pt "Abs rho(Sub r(Var 0::Up 0 map rs))"))

; "SubVarListRef"
(set-goal (pf "all rs,k.k<Lh rs -> Sub(Var k)rs=(k thof rs)"))
(ind)
(assume "k" "Absurd")
(use "Efq")
(use "Absurd")
(assume "r" "rs" "IH")
(cases)
(assume "Trivial")
(ng)
(use "Truth-Axiom")
(assume "k" "k<Lh rs")
(ng)
(use "IH")
(use "k<Lh rs")
(save "SubVarListRef")

; Note that the following proposition cannot be generalized to the
; type (list alpha), because E needs a finitary type, not alpha. 

; "TermListRefE"
(set-goal (pf "all rs,k.k<Lh rs -> E(k thof rs)")) 
(ind)
(assume "k")
(assume "Absurd")
(use "Efq")
(use "Absurd")
(assume "r" "rs" "IH")
(cases)
(assume "Trivial")
(use "Truth-Axiom")
(assume "k" "k<Lh rs")
(ng)
(use "IH")
(use "k<Lh rs")
(save "TermListRefE")

; Obsolete instanciations of general propositions
; "TermLhMap"
; (set-goal (pf "all term=>term,rs.Lh(term=>term map rs)=Lh rs"))
; (use-with "LhMap" (py "term") (py "term"))
; (save "TermLhMap")

; "TermLhAppend"
; (set-goal (pf "all rs,ss.Lh(rs:+:ss)=Lh rs+Lh ss"))
; (use-with "LhAppend" (py "term"))
; (save "TermLhAppend")

; "TermMapAppend"
; (set-goal (pf "all term=>term,rs2,rs1 
;                Equal(term=>term map rs1:+:rs2)
;                     ((term=>term map rs1):+:(term=>term map rs2))"))
; (use-with "MapAppend" (py "term") (py "term"))
; (save "TermMapAppend")

; "TermListRefAppendLt"
; (set-goal (pf "all ss,rs,k.k<Lh rs -> Equal(k thof rs:+:ss)(k thof rs)"))
; (use-with "ListRefAppendLt" (py "term"))
; (save "TermListRefAppendLt")

; "TermListRefAppendGe"
; (set-goal (pf "all ss,rs,k.(k<Lh rs -> F) -> 
;                            Equal(k thof rs:+:ss)((k-Lh rs)thof ss)"))
; (use-with "ListRefAppendGe" (py "term"))
; (save "TermListRefAppendGe")


; "UpSubVarGen"
(set-goal  (pf "all k,m,ss.k<m+Lh ss ->
                           Up m(Sub(Var k)((Var map(Seq 0 m)):+:ss))=
                           Sub(Var k)((Var map(Seq 0 m)):+:(Up m map ss))"))
(assume "k" "m" "ss" "k<m+Lh ss")
(cases (pt "k<m"))

(assume "k<m")
(simp "SubVarListRef")
(simp "SubVarListRef")
(simp "ListRefAppendLt")
(simp "ListRefAppendLt")
(simp "ListRefMap")
(simp "ListRefSeq")
(ng)
(simp "k<m")
(use "Truth-Axiom")
(use "k<m")
(simp "LhSeq")
(use "k<m")
(simp-with "LhMap" (py "nat") (py "term") (pt "Var") (pt "Seq 0 m"))
(simp "LhSeq")
(use "k<m")
(simp-with "LhMap" (py "nat") (py "term") (pt "Var") (pt "Seq 0 m"))
(simp "LhSeq")
(use "k<m")
(simp "LhAppend")
(simp "LhMap")
(simp "LhSeq")
(simp "LhMap")
(use "k<m+Lh ss")
(simp "LhAppend")
(simp "LhMap")
(simp "LhSeq")
(use "k<m+Lh ss")

(assume "k<m -> F")
(simp "SubVarListRef")
(simp "SubVarListRef")
(simp "ListRefAppendGe")
(simp "ListRefAppendGe")
(simp "LhMap")
(simp "LhSeq")
(simp "ListRefMap")
(use (make-proof-in-aconst-form (finalg-to-eq-to-=-1-aconst (py "term"))))
(use "Eq-Refl")
(use (make-proof-in-aconst-form (finalg-to-total-to-e-aconst (py "term"))))
(use "Total")
(add-global-assumption "TotalUpm" (pf "all m Total(Up m)"))
(use "TotalUpm")
(use (make-proof-in-aconst-form (finalg-to-e-to-total-aconst (py "term"))))
(use "TermListRefE")
(add-global-assumption "UpSubVarGenAux1" (pf "all k,m,n.k<m+n -> k-m<n"))
(use "UpSubVarGenAux1")
(use "k<m+Lh ss")
(use "UpSubVarGenAux1")
(use "k<m+Lh ss")
(simp  "LhMap")
(simp "LhSeq")
(use "k<m -> F")
(simp  "LhMap")
(simp "LhSeq")
(use "k<m -> F")
(simp "LhAppend")
(simp  "LhMap")
(simp "LhSeq")
(simp  "LhMap")
(use "k<m+Lh ss")
(simp "LhAppend")
(simp  "LhMap")
(simp "LhSeq")
(use "k<m+Lh ss")
(save "UpSubVarGen")

; For the Abs case of "UpSubGen" we need

; "SubAbsAppendSeq"
(set-goal (pf "all rho,r,m,ss Sub(Abs rho r)((Var map Seq 0 m):+:ss)=
                Abs rho(Sub r((Var map Seq 0(Succ m)):+:(Up 0 map ss)))"))
(assume "rho" "r" "m" "ss")
(ng)
(simp "MapAppend")
(simp "UpSeq")
(use "Truth-Axiom")
(save "SubAbsAppendSeq")

; "UpSubGen"
(set-goal
 (pf "all r,l,ss.Free r<=l+Lh ss -> Up l(Sub r((Var map(Seq 0 l)):+:ss))=
                 Sub r((Var map(Seq 0 l)):+:(Up l map ss))"))
(ind)

; Var
(assume "k" "l" "ss" "H")
(use "UpSubVarGen")
(ng)
(add-global-assumption "UpSubGenAux1" (pf "all k,n.Succ k<=n -> k<n"))
(use "UpSubGenAux1")
(use "H")

; App
(assume "r" "s" "IHr" "IHs" "k" "ss" "H")
(ng)
(split)
(use "IHr")
(add-global-assumption "TransLe" (pf "all n,m,k.n<=m -> m<=k -> n<=k"))
(use "TransLe" (pt "Free r max Free s"))
(use "MaxUB1")
(use "H")
(use "IHs")
(use "TransLe" (pt "Free r max Free s"))
(use "MaxUB2")
(use "H")

; Abs
(assume "rho" "r" "IHr" "l" "ss" "H")
(simp "SubAbsAppendSeq")
(simp "SubAbsAppendSeq")
(ng)
(simp-with "<-" "MapUpUp" (pt "ss") (pt "l") (pt "0"))
(use-with "IHr" (pt "Succ l") (pt "Up 0 map ss") "?")
(simp "LhMap")
(add-global-assumption "UpSubGenAux2"
		       (pf "all n,m,k.Pred n<=m+k ->n<=Succ m+k"))
(use "UpSubGenAux2")
(use "H")
(save "UpSubGen")

; We specialize UpSubGen to Zero:

; "UpSub"
(set-goal (pf "all r,ss.Free r<=Lh ss -> Up 0(Sub r ss)=Sub r(Up 0 map ss)"))
(assume "r" "ss" "Free r<=Lh ss")
(inst-with-to "UpSubGen" (pt "r") (pt "0") (pt "ss") "Free r<=Lh ss" "H")
(ng)
(use "H")
(save "UpSub")

; We extend UpSub to lists:

; "UpSubList"
(set-goal (pf "all rs,ss.MaxFree rs<=Lh ss -> 
               (Up 0 map([r]Sub r ss)map rs)=(([r]Sub r(Up 0 map ss))map rs)"))
(ind)
(assume "ss" "Trivial")
(ng)
(use "Truth-Axiom")

; Cons
(assume "r" "rs" "IH" "ss" "H")
(ng)
(split)
(use "UpSub")
(use "TransLe" (pt "Free r max MaxFree rs"))
(use "MaxUB1")
(use "H")
(use "IH")
(use "TransLe" (pt "Free r max MaxFree rs"))
(use "MaxUB2")
(use "H")
(save "UpSubList")

; Composition of substitutions.  We use Subcompose as an abbreviation
; only and define it via map:

(add-program-constant "Subcompose" (py "list term=>list term=>list term") 1)

(add-token
 "circ"
 'mul-op
 (lambda (x y)
   (let* ((type1 (term-to-type x))
	  (type2 (term-to-type y))
	  (type (types-lub type1 type2)))
     (mk-term-in-app-form
      (make-term-in-const-form (pconst-name-to-pconst "Subcompose"))
      x y))))

(add-display
 (py "list term")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "Subcompose"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'mul-op "circ"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))

; (add-computation-rule (pt "(Nil term)circ ss") (pt "(Nil term)"))
; (add-computation-rule (pt "(r::rs)circ ss") (pt "(Sub r ss)::(rs circ ss)"))

(add-computation-rule (pt "rs circ ss") (pt "([r]Sub r ss)map rs"))

; (remove-program-constant "Subcompose")

; "SubSubVar"
(set-goal (pf "all k,ss,ts.k<Lh ss -> MaxFree ss<=Lh ts ->
                Sub(Var k)(ss circ ts)=Sub(Sub(Var k)ss)ts"))
(assume "k" "ss" "ts" "k<Lh ss" "MaxFree ss<=Lh ts")
(ng)
(simp "SubVarListRef")
(simp "ListRefMap")
(ng)
(simp "SubVarListRef")
(use (make-proof-in-aconst-form (finalg-to-eq-to-=-1-aconst (py "term"))))
(use "Eq-Refl")
(add-global-assumption "SubSubVarAux1"
		       (pf "all r^,rs.E r^ -> E(Sub r^ rs)"))
(use "SubSubVarAux1")
(use "TermListRefE")
(use "k<Lh ss")
(use "k<Lh ss")
(use "k<Lh ss")
(simp "LhMap")
(use "k<Lh ss")
(save "SubSubVar")

; For the Abs case of the final goal SubSub we need

; "SubUpGen"
(set-goal (pf "all r,l,s,ss.Free r<=l+Lh ss ->
                Sub(Up l r)((Var map Seq 0 l):+:(s::ss))=
                Sub r((Var map Seq 0 l):+:ss)"))
(ind)
(assume "k" "l" "s" "ss" "Free(Var k)<=l+Lh ss")
(simp (pf "Up l(Var k)=[if (k<l) (Var k) (Var(Succ k))]"))
(cases (pt "k<l"))
(assume "k<l")
(cut (pf "[if True (Var k) (Var(Succ k))]=Var k"))
(assume "H")
(simp "H")
(simp "SubVarListRef")
(simp "SubVarListRef")
(simp "ListRefAppendLt")
(simp "ListRefAppendLt")
(simp "ListRefMap")
(simp "ListRefSeq")
(use "Truth-Axiom")
(use "k<l")
(simp "LhSeq")
(use "k<l")
(simp "LhMap")
(simp "LhSeq")
(use "k<l")
(simp "LhMap")
(simp "LhSeq")
(use "k<l")
(simp "LhAppend")
(simp "LhMap")
(simp "LhSeq")
(add-global-assumption "SubUpGenAux2" (pf "all k,l,m.k<l -> k<l+m"))
(use "SubUpGenAux2")
(use "k<l")
(simp "LhAppend")
(simp "LhMap")
(simp "LhSeq")
(add-global-assumption "SubUpGenAux3" (pf "all k,l,m.k<l -> k<Succ l+m"))
(use "SubUpGenAux3")
(use "k<l")
(use "Truth-Axiom")

(assume "k<l -> F")
(cut (pf "[if False (Var k) (Var(Succ k))]=Var(Succ k)"))
(assume "H")
(simp "H")
(simp "SubVarListRef")
(simp "SubVarListRef")
(simp "ListRefAppendGe")
(simp "ListRefAppendGe")
(simp "LhMap")
(simp "LhSeq")
(add-global-assumption "SubUpGenAux12" (pf "all k,l.Succ k-l=Succ(k-l)"))
(simp "SubUpGenAux12")
(use (make-proof-in-aconst-form (finalg-to-eq-to-=-1-aconst (py "term"))))
(use "Eq-Refl")
(use "TermListRefE")
(ng)
(add-global-assumption "SubUpGenAux5" (pf "all k,l,m.Succ k<=l+m -> k-l<m"))
(use "SubUpGenAux5")
(use "Free(Var k)<=l+Lh ss")
(simp "LhMap")
(simp "LhSeq")
(use "k<l -> F")
(simp "LhMap")
(simp "LhSeq")
(add-global-assumption "SubUpGenAux15" (pf "all k,l.Succ k<l -> k<l"))
(assume "Succ k<l")
(use "k<l -> F")
(use "SubUpGenAux15")
(use  "Succ k<l")
(simp "LhAppend")
(simp "LhMap")
(simp "LhSeq")
(add-global-assumption "SubUpGenAux16" (pf "all k,l.Succ k<=l -> k<l"))
(use "SubUpGenAux16")
(use "Free(Var k)<=l+Lh ss")
(simp "LhAppend")
(simp "LhMap")
(simp "LhSeq")
(ng)
(use "SubUpGenAux16")
(use "Free(Var k)<=l+Lh ss")
(ng)
(use "Truth-Axiom")
(ng)
(use "Truth-Axiom")

; App
(assume "r" "s" "IHr" "IHs" "l" "s1" "ss" "H")
(ng)
(split)
(use "IHr")
(use "TransLe" (pt "Free r max Free s"))
(use "MaxUB1")
(use "H")
(use "IHs")
(use "TransLe" (pt "Free r max Free s"))
(use "MaxUB2")
(use "H")

; Abs
(assume "rho" "r" "IHr" "l" "s" "ss" "H")
(simp "SubAbsAppendSeq")
(simp (pf "Up l(Abs rho r)=Abs rho(Up(Succ l)r)"))
(simp "SubAbsAppendSeq")
(simp (pf "(Up 0 map s::ss)=(Up 0 s::Up 0 map ss)"))
(simp "IHr")
(use "Truth-Axiom")
(simp "LhMap")
(ng)
(add-global-assumption "SubUpGenAux7" (pf "all n,m.Pred n<=m -> n<=Succ m"))
(use "SubUpGenAux7")
(use "H")
(use "Truth-Axiom")
(use "Truth-Axiom")
(save "SubUpGen")

; We specialize SubUpGen to Zero:

; "SubUp"
(set-goal (pf "all r,s,ss.Free r<=Lh ss -> Sub(Up 0 r)(s::ss)=Sub r ss"))
(assume "r" "s" "ss" "Free r<=Lh ss")
(inst-with-to
 "SubUpGen" (pt "r") (pt "0") (pt "s") (pt "ss") "Free r<=Lh ss" "H")
(use "H")
(save "SubUp")

; We extend SubUp to lists:

; "SubUpList"
(set-goal (pf "all rs,s,ss.MaxFree rs<=Lh ss -> 
               (([r]Sub r(s::ss))map Up 0 map rs)=(([r]Sub r ss)map rs)"))
(ind)
(assume "s" "ss" "Trivial")
(use "Truth-Axiom")

; Cons
(assume "r" "rs" "IH" "s" "ss" "H")
(ng)
(split)
(use "SubUp")
(use "TransLe" (pt "Free r max MaxFree rs"))
(use "MaxUB1")
(use "H")
(use "IH")
(use "TransLe" (pt "Free r max MaxFree rs"))
(use "MaxUB2")
(use "H")
(save "SubUpList")

; The final goal is
; "SubSub"
(set-goal (pf "all r,ss,ts.Free r<=Lh ss -> MaxFree ss<=Lh ts ->
                Sub r(ss circ ts)=Sub(Sub r ss)ts"))
(ind)

; Var
(assume "k" "ss" "ts" "Succ k<=Lh ss" "MaxFree ss<=Lh ts")
(use "SubSubVar")
(use "UpSubGenAux1")
(use "Succ k<=Lh ss")
(use "MaxFree ss<=Lh ts")

; App
(assume "r" "s" "IHr" "IHs" "ss" "ts" "H1" "H2")
(ng)
(split)
(use "IHr")
(use "TransLe" (pt "Free r max Free s"))
(use "MaxUB1")
(use "H1")
(use "H2")
(use "IHs")
(use "TransLe" (pt "Free r max Free s"))
(use "MaxUB2")
(use "H1")
(use "H2")

; Abs
(assume "rho" "r" "IHr" "ss" "ts" "H1" "H2")
(ng)
(simp "UpSubList")
(simp "<-" "IHr")
(simp "<-" "SubUpList" (pt "Var 0"))
(ng)
(use "Truth-Axiom")
(simp "LhMap")
(use "H2")
(ng)
(simp "LhMap")
(use "MaxLUB")
(use "Truth-Axiom")
(use "TransLe" (pt "Succ(MaxFree ss)"))
(use "FreeUpList")
(use "H2")
(ng)
(simp "LhMap")
(cases (pt "Free r"))
(auto)
(assume "n" "Free r=Succ n")
(cut (pf "Pred(Free r)<=Lh ss"))
(simp "Free r=Succ n")
(auto)
(save "SubSub")

; 2005-02-26 Proposal Thiel/Schimanski: simp and search return a new
; proof state in case no simplification is possible or no proof is
; found.  This is needed for proof-general.  [Really?]

; (define (simp opt-dir . rest)
;   (let* ((num-goals (pproof-state-to-num-goals))
; 	 (proof (pproof-state-to-proof))
; 	 (maxgoal (pproof-state-to-maxgoal))
; 	 (number (num-goal-to-number (car num-goals)))
; 	 (simp-result
; 	  (apply simp-intern
; 		 (append (list num-goals proof maxgoal opt-dir) rest))))
;     (if (not simp-result)
; 	(begin
; 	  (set! PPROOF-STATE (make-pproof-state num-goals proof maxgoal))
; 	  (set! PPROOF-STATE-HISTORY (cons PPROOF-STATE PPROOF-STATE-HISTORY))
; 	  (display-comment "no simplification possible") (newline))
; 	(begin
; 	  (set! PPROOF-STATE simp-result)
; 	  (set! PPROOF-STATE-HISTORY (cons PPROOF-STATE PPROOF-STATE-HISTORY))
; 	  (let* ((l1 (length num-goals))
; 		 (l2 (length (pproof-state-to-num-goals)))
; 		 (new-num-goals
; 		  (list-head (pproof-state-to-num-goals) (- (+ l2 1) l1))))
; 	    (if (pair? new-num-goals)
; 		(begin (display-comment "ok, " DEFAULT-GOAL-NAME "_"
; 					(number-to-string number)
; 					" can be obtained from")
; 		       (for-each (lambda (g) (newline) (display-num-goal g))
; 				 (reverse new-num-goals)))
; 		(begin
; 		  (display-comment "ok, " DEFAULT-GOAL-NAME "_"
; 				   (number-to-string number) " is proved.")
; 		  (if (null? (pproof-state-to-num-goals))
; 		      (begin (display "  Proof finished.") (newline))
; 		      (begin (display "  The active goal now is") (newline)
; 			     (display-num-goal
; 			      (car (pproof-state-to-num-goals))))))))))))


; Proofs and extracted terms for Berger's `Program Extraction from
; Normalization Proofs', TLCA1993.
; ================================================================  

(add-pvar-name "SC" (make-arity (py "type") (py "term")))

; We must refer to the tvar assigned to SC.  So first put it into
; PVAR-TO-TVAR-ALIST

(formula-to-et-type (pf "SC^type term"))

; We can also refer to this tvar by 

(pvar-to-tvar (make-pvar (pvar-name-to-arity "SC") -1 0 "SC"))

(add-pvar-name "N" (make-arity (py "type") (py "term") (py "term")))
(add-pvar-name "A" (make-arity (py "type") (py "term") (py "term")))
(add-pvar-name "Head" (make-arity (py "type") (py "term") (py "term")))
(add-pvar-name "Fr" (make-arity (py "term") (py "nat")))


(add-global-assumption
 "SCDefIotaOne"
 (pf "allnc r.SC^Iota r -> all k.Fr r k -> ex s N Iota r s"))

(add-global-assumption
 "SCDefIotaTwo"
 (pf "allnc r.(all k.Fr r k -> ex s N Iota r s) -> SC^Iota r"))

(add-global-assumption
 "SCDefOne"
 (pf "allnc rho,sig,r.SC^(rho to sig)r -> allnc s.SC^rho s -> SC^sig(r s)"))

(add-global-assumption
 "SCDefTwo"
 (pf "allnc rho,sig,r.(allnc s.SC^rho s -> SC^sig(r s)) -> SC^(rho to sig)r"))

; We first need ListTail, generally for lists

(add-program-constant "ListTail" (py "list alpha => list alpha"))
; (remove-program-constant "ListTail")

(add-token
 "Tail"
 'prefix-op
 (lambda (x)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "ListTail"))
	    (tvars (const-to-tvars const))
	    (listtype (term-to-type x))
	    (type (car (alg-form-to-types listtype)))
	    (subst (make-substitution tvars (list type))))
       (const-substitute const subst #f)))
    x)))

(add-display
 (py "list alpha")
 (lambda (x)
   (let* ((op (term-in-app-form-to-final-op x))
	  (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "ListTail"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 1 (length args)))
	 (list 'prefix-op "Tail"
	       (term-to-token-tree (car args)))
	 #f))))

; (pp (pt "Tail(Nil alpha)"))
; (pp (pt "Tail(alpha::(list alpha)_1)"))
; (pp (pt "Tail(nat::(list nat)_1)"))

(add-computation-rule (pt "Tail(alpha::(list alpha)_1)")
		      (pt "(list alpha)_1"))

; (pp (pt "Tail(0::1::2::3:)"))
; (pp (nt (pt "Tail(0::1::2::3:)")))

(set-goal (pf "all ss.0<Lh ss -> ss=((0 thof ss)::Tail ss)"))
(cases)
(prop)
(auto)
(save "ConsTail")

(add-pvar-name "SCs" (make-arity (py "list type") (py "list term")))

; We must refer to the tvar assigned to SCs.  So first put it into
; PVAR-TO-TVAR-ALIST

(formula-to-et-type (pf "SCs^(list type)(list term)"))

; We can also refer to this tvar by 

(pvar-to-tvar (make-pvar (pvar-name-to-arity "SCs") -1 0 "SCs"))

(add-global-assumption
 "SCsDefNilOne" (pf "all rs^.SCs^(Nil type)rs^ -> rs^ =(Nil term)"))

(add-global-assumption "SCsDefNilTwo" (pf "SCs^(Nil type)(Nil term)"))

(add-global-assumption
 "SCsDefNilThree" (pf "all rhos.SCs^rhos(Nil term) -> rhos =(Nil type)"))

(add-global-assumption
 "SCsDefOne"
 (pf "all rho,rhos allnc rs^.SCs^(rho::rhos)rs^ -> SC^rho(0 thof rs^)"))

(add-global-assumption
 "SCsDefTwo"
 (pf "all rho,rhos allnc rs^.SCs^(rho::rhos)rs^ -> SCs^rhos(Tail rs^)"))

(add-global-assumption
 "SCsDefThree" (pf "allnc rho,rhos,r,rs.SC^rho r -> SCs^rhos rs ->
                      SCs^(rho::rhos)(r::rs)"))

; "LengthSCs"
(set-goal (pf "all rhos,ss.SCs^rhos ss -> Lh rhos=Lh ss"))
(ind)
(cases)
(prop)
(assume "s" "ss" "Absurd")
(assert (pf "(s::ss)=(Nil term)"))
(use "SCsDefNilOne")
(use "Absurd")
(assume "ExHyp")
(simp "ExHyp")
(use "Truth-Axiom")
(assume "rho" "rhos" "IHrhos")
(cases)
(assume "Absurd")
(assert (pf "(rho::rhos)=(Nil type)"))
(use "SCsDefNilThree")
(use "Absurd")
(assume "ExHyp")
(simp "ExHyp")
(use "Truth-Axiom")
(assume "r" "rs")
(assume "SCs^(rho::rhos)(r::rs)")
(ng)
(use "IHrhos")
(use-with "SCsDefTwo" (pt "rho") (pt "rhos") (pt "r::rs") "?")
(use "SCs^(rho::rhos)(r::rs)")
(save "LengthSCs")

(add-global-assumption
 "Ax1" (pf "all rho,sig,r,k,s.Fr r k -> N sig(r(Var k))s -> 
             N(rho to sig)r(Abs rho(Sub s((Var map(Seq 1 k)):+:(Var 0):)))"))

(add-global-assumption "Ax2" (pf "all r,s.A Iota r s -> N Iota r s"))

(add-global-assumption "Ax3" (pf "all rho,k A rho(Var k)(Var k)"))

(add-global-assumption
 "Ax4" (pf "all rho,sig,r,r1,s,s1.
             A(rho to sig)r r1 -> N rho s s1 -> A sig(r s)(r1 s1)"))

(add-global-assumption
 "Ax5" (pf "all rho,r,s,t.Head rho r s -> N rho s t -> N rho r t"))

(add-global-assumption
 "Ax6" (pf "all rho,sig,r allnc ss,s.(all k.Fr s k -> ex r2 N rho s r2) ->
              Head sig((Sub(Abs rho r)ss)s)(Sub r(s::ss))"))

(add-global-assumption
 "Ax7" (pf "all rho,sig,r,s,t.Head(rho to sig)r s -> Head sig(r t)(s t)"))

(add-global-assumption
 "Ax8" (pf "all r,k.Fr r k -> Fr(r(Var k))(Succ k)"))

(add-global-assumption "Ax9" (pf "all r,s,k.Fr(r s)k -> Fr s k"))

(add-global-assumption "Ax10" (pf "all r,s,k.Fr(r s)k -> Fr r k"))

(add-global-assumption
 "Ax11" (pf "all rho,r,s,k.Fr r k -> Head rho r s -> Fr s k"))

(add-global-assumption "Ax12" (pf "all rhos,r.Cor rhos r -> Fr r(Lh rhos)"))

; "LemmaOne"
(set-goal
 (pf "all rho allnc r1.(SC^rho r1 -> all k.Fr r1 k -> ex r2 N rho r1 r2)&
             ((all k.Fr r1 k -> ex r2 A rho r1 r2) -> SC^rho r1)"))
(ind)
(assume "r")
(split)
(use "SCDefIotaOne")
(assume "H1")
(use "SCDefIotaTwo")
(assume "k" "H2")
(inst-with-to "H1" (pt "k") "H2" "ExHyp")
(by-assume-with "ExHyp" "s" "ExHypInst")
(ex-intro (pt "s"))
(use "Ax2")
(use "ExHypInst")

(assume "rho" "sig" "IHrho" "IHsig" "r")
(split)
(assume "SC^(rho to sig)r" "k" "Fr r k")
(cut (pf "ex s N sig(r(Var k))s"))
(assume "ExHyp")
(by-assume-with "ExHyp" "s" "NsigInst")
(ex-intro (pt "(Abs rho(Sub s((Var map(Seq 1 k)):+:(Var 0):)))"))
(use "Ax1")
(use "Fr r k")
(use "NsigInst")
(use "IHsig" (pt "Succ k"))
(use "SCDefOne" (pt "rho"))
(use "SC^(rho to sig)r")
(use "IHrho")
(assume "l" "Fr(Var k)l")
(ex-intro (pt "Var k"))
(use "Ax3")
(use "Ax8")
(use "Fr r k")

(assume "H1")
(use "SCDefTwo")
(assume "s" "SC^rho s")
(use "IHsig")
(assume "k" "Fr(r s)k")
(cut (pf "ex t A(rho to sig)r t"))
(assume "ExHyp1")
(by-assume-with "ExHyp1" "r1" "ExHyp1Inst")
(cut (pf "ex s1 N rho s s1"))
(assume "ExHyp2")
(by-assume-with "ExHyp2" "s1" "ExHyp2Inst")
(ex-intro (pt "r1 s1"))
(use "Ax4" (pt "rho"))
(use "ExHyp1Inst")
(use "ExHyp2Inst")
(use "IHrho" (pt "k"))
(use "SC^rho s")
(use "Ax9" (pt "r"))
(use "H1")
(use "Fr(r s)k")
(use "H1" (pt "k"))
(use "Ax10" (pt "s"))
(use "Fr(r s)k")
(save "LemmaOne")

(define sc-type 
  (pvar-to-tvar (make-pvar (pvar-name-to-arity "SC") -1 0 "SC")))

(add-var-name "a" sc-type)
(add-var-name "p" (mk-star (mk-arrow sc-type (py "nat") (py "term"))
			   (mk-arrow (py "nat=>term") sc-type)))
(add-var-name "f" (py "nat=>term"))

(pp (nt (proof-to-extracted-term (theorem-name-to-proof "LemmaOne"))))

; (Rec type=>(alpha34=>nat=>term)@@((nat=>term)=>alpha34))
; ((cSCDefIotaOne alpha34)@(cSCDefIotaTwo alpha34))
; ([rho3,rho4,p5,p6]
;   ([a7,n8]
;     Abs rho3
;     (Sub(left p6((cSCDefOne alpha34)a7(right p5([n9]Var n8)))(Succ n8))
;      ((Var map Seq 1 n8):+:(Var 0):)))@
;   ([f7](cSCDefTwo alpha34)([a8]right p6([n9]f7 n9(left p5 a8 n9)))))

; "LemmaTwo"
(set-goal (pf "all rho allnc r1,r.SC^rho r1 -> Head rho r r1 -> SC^rho r"))
(ind)
(assume "r1" "r" "SC^Iota r1" "Head Iota r r1")
(use "SCDefIotaTwo")
(assume "k" "Fr r k")
(cut (pf "ex s N Iota r1 s"))
(assume "ExHyp")
(by-assume-with "ExHyp"  "s" "ExHypInst")
(ex-intro (pt "s"))
(use "Ax5" (pt "r1"))
(use "Head Iota r r1")
(use "ExHypInst")
(use "SCDefIotaOne" (pt "k"))
(use "SC^Iota r1")
(use "Ax11" (pt "Iota") (pt "r"))
(use "Fr r k")
(use "Head Iota r r1")

(assume "rho" "sig" "IHrho" "IHsig" "r1" "r"
	"SC^(rho to sig)r1" "Head(rho to sig)r r1")
(use "SCDefTwo")
(assume "s" "SC^rho s")
(use "IHsig" (pt "r1 s"))
(use "SCDefOne" (pt "rho"))
(use "SC^(rho to sig)r1")
(use "SC^rho s")
(use "Ax7" (pt "rho"))
(use "Head(rho to sig)r r1")
(save "LemmaTwo")

(add-var-name "b" sc-type)
(add-var-name "g" (mk-arrow sc-type sc-type))

(pp (nt (proof-to-extracted-term (theorem-name-to-proof "LemmaTwo"))))

; (Rec type=>alpha34=>alpha34)
; ([a2](cSCDefIotaTwo alpha34)((cSCDefIotaOne alpha34)a2))
; ([rho2,rho3,g4,g5,a6](cSCDefTwo alpha34)([a7]g5((cSCDefOne alpha34)a6 a7)))

; For the variable case of Lemma 3:

; "LemmaThreeVar"
(set-goal (pf "all rhos,k allnc ss^.SCs^rhos ss^ -> k<Lh ss^ ->
                SC^(k thof rhos)(k thof ss^)"))
(ind)
(cases)
(assume "ss^" "SCs^(Nil type)ss^")
(assert (pf "ss^ =(Nil term)"))
 (use "SCsDefNilOne")
 (prop) 
(assume "ss^ =(Nil term)")
(simp "ss^ =(Nil term)")
(prop)
(assume "k")
(assume "ss^" "SCs^(Nil type)ss^")
(assert (pf "ss^ =(Nil term)"))
 (use "SCsDefNilOne")
 (prop)
(assume "ss^ =(Nil term)")
(simp "ss^ =(Nil term)")
(prop)

(assume "rho" "rhos" "IHrhos")
(cases)
(assume "ss^" "SCs^(rho::rhos)ss^" "0<Lh ss^")
(ng)
(use "SCsDefOne" (pt "rhos"))
(use "SCs^(rho::rhos)ss^")
(assume "k" "ss^" "SCs^(rho::rhos)ss^" "Succ k<Lh ss^")
(ng)
(assert (pf "SCs^rhos(Tail ss^)"))
 (use "SCsDefTwo" (pt "rho"))
 (prop)
(assume "SCs^rhos(Tail ss^)")
(add-global-assumption
 "LemmaThreeVarAux1"
 (pf "all k,ss^.Succ k<Lh ss^ -> (Succ k thof ss^)=(k thof Tail ss^)"))
(assert (pf "(Succ k thof ss^)=(k thof Tail ss^)"))
 (use "LemmaThreeVarAux1")
 (prop)
(assume "EqHyp")
(simp "EqHyp")
(use "IHrhos")
(auto)
(add-global-assumption
 "LemmaThreeVarAux2"
 (pf "all k,ss^.Succ k<Lh ss^ -> k<Lh Tail ss^"))
(use "LemmaThreeVarAux2")
(prop)
(save "LemmaThreeVar")

"TypVar"
(set-goal (pf "all k,rhos.k<Lh rhos -> Typ rhos(Var k)=(k thof rhos)"))
(ind)
(ind)
(auto)
(prop)
(auto)
(assume "n" "IHn")
(cases)
(prop)
(auto)
(save "TypVar")

"SubVar"
(set-goal (pf "all k,ss.k<Lh ss -> Sub(Var k)ss=(k thof ss)"))
(ind)
(ind)
(auto)
(prop)
(auto)
(assume "n" "IHn")
(cases)
(prop)
(auto)
(save "SubVar")

; "LemmaThree"
(set-goal
 (pf "all r,rhos allnc ss.Cor rhos r -> SCs^rhos ss ->
                    SC^(Typ rhos r)(Sub r ss)"))
(ind)
(assume "k")
(assume "rhos" "ss" "Cor rhos(Var k)" "SCs^rhos ss")
(assert (pf "(Typ rhos(Var k))=(k thof rhos)"))
 (use "TypVar")
 (prop)
(assume "EqHyp")
(simp "EqHyp")
(assert (pf "Lh rhos=Lh ss"))
 (use "LengthSCs")
 (use "SCs^rhos ss")
(assume "Lh rhos=Lh ss")
(assert (pf "(Sub(Var k)ss)=(k thof ss)"))
 (use "SubVar")
 (simp "<-" "Lh rhos=Lh ss")
 (prop)
(assume "EqHyp1")
(simp "EqHyp1")
(use "LemmaThreeVar")
(prop)
(simp "<-" "Lh rhos=Lh ss")
(prop)

; Case App
(assume "r" "s" "IHr" "IHs" "rhos" "ss" "Cor rhos(r s)" "SCs^rhos ss")
(ng #t)
(use "SCDefOne" (pt "Typ rhos s"))
(ng)
(assert (pf "Typ rhos r=(Typ rhos s to Valtyp(Typ rhos r))"))
 (ng)
 (use-with "Cor rhos(r s)" 'right)
(assume "EqHyp")
(simp "<-" "EqHyp")
(use "IHr")
(use-with "Cor rhos(r s)" 'left 'left) ;to do: use for flas with AndConst
(use "SCs^rhos ss")
(use "IHs")
(ng)
(use-with "Cor rhos(r s)" 'left 'right)
(use "SCs^rhos ss")

; Case Abs
(assume "rho" "r" "IHr")
(assume "rhos" "ss" "Cor rhos(Abs rho r)" "SCs^rhos ss")
(use "SCDefTwo")
(assume "s" "SC^rho s")
(use "LemmaTwo" (pt "Sub r(s::ss)"))
(use "IHr")
(prop)
(use "SCsDefThree")
(auto)
(use "Ax6")
(use "LemmaOne")
(use "SC^rho s")
(save "LemmaThree")

(define scs-type 
  (pvar-to-tvar (make-pvar (pvar-name-to-arity "SCs") -1 0 "SCs")))

(add-var-name "a" sc-type)
(add-var-name "p" (mk-star (mk-arrow sc-type (py "nat") (py "term"))
			   (mk-arrow (py "nat=>term") sc-type)))
(add-var-name "f" (py "nat=>term"))

(add-var-name "h" (mk-arrow (py "list type") scs-type sc-type))
(add-var-name "x" scs-type)

(pp (nt (proof-to-extracted-term (theorem-name-to-proof "LemmaThree"))))

; (Rec term=>list type=>alpha36=>alpha34)
; ([n3,rhos4](cLemmaThreeVar alpha36 alpha34)rhos4 n3)
; ([r3,r4,h5,h6,rhos7,x8](cSCDefOne alpha34)(h5 rhos7 x8)(h6 rhos7 x8))
; ([rho3,r4,h5,rhos6,x7]
;   (cSCDefTwo alpha34)
;   ([a8]
;     (cLemmaTwo alpha34)(Typ(rho3::rhos6)r4)
;     (h5(rho3::rhos6)((cSCsDefThree alpha34 alpha36)a8 x7))))

(pp (nt (proof-to-extracted-term
	 (expand-theorems (theorem-name-to-proof "LemmaThree")))))

; (Rec term=>list type=>alpha36=>alpha34)
; ([n3,rhos4]
;   (Rec list type=>nat=>alpha36=>alpha34)([n6,x7](arbalphaThreeFour alpha34))
;   ([rho6,rhos7,(nat=>alpha36=>alpha34)_8,n9,x10]
;     [if n9
;       ((cSCsDefOne alpha36 alpha34)rho6 rhos7 x10)
;       ([n11](nat=>alpha36=>alpha34)_8 n11((cSCsDefTwo alpha36)rho6 rhos7 x10))])
;   rhos4 
;   n3)
; ([r3,r4,h5,h6,rhos7,x8](cSCDefOne alpha34)(h5 rhos7 x8)(h6 rhos7 x8))
; ([rho3,r4,h5,rhos6,x7]
;   (cSCDefTwo alpha34)
;   ([a8]
;     (Rec type=>alpha34=>alpha34)
;     ([a9](cSCDefIotaTwo alpha34)((cSCDefIotaOne alpha34)a9))
;     ([rho9,rho10,g11,g12,a13]
;       (cSCDefTwo alpha34)([a14]g12((cSCDefOne alpha34)a13 a14)))
;     (Typ(rho3::rhos6)r4)
;     (h5(rho3::rhos6)((cSCsDefThree alpha34 alpha36)a8 x7))))

; "SCsSeq"
(set-goal (pf "all rhos,k SCs^ rhos(Var map(Seq k(Lh rhos)))"))
(ind)
(assume "k")
(use "SCsDefNilTwo")
(assume "rho" "rhos" "IHrhos")
(assume "k")
(ng)
(use "SCsDefThree")
(use "LemmaOne")
(assume "k1" "Fr(Var k)k1")
(ex-intro (pt "Var k"))
(use "Ax3")
(use "IHrhos")
(save "SCsSeq")

; "SubIds"
(set-goal (pf "all r,rhos.Cor rhos r -> Sub r(Var map(Seq 0(Lh rhos)))=r"))
(ind)
(assume "k" "rhos" "Cor rhos(Var k)")
(simp "SubVar")
(simp "ListRefMap")
(simp "ListRefSeq")
(auto)
(simp "LhSeq")
(auto)
(simp "LhMap")
(simp "LhSeq")
(auto)

; App
(assume "r" "s" "IHr" "IHs" "rhos" "Cor rhos(r s)")
(ng)
(split)
(use "IHr")
(use-with "Cor rhos(r s)" 'left 'left)
(use "IHs")
(use-with "Cor rhos(r s)" 'left 'right)

; Abs
(assume "rho" "r" "IHr" "rhos" "Cor rhos(Abs rho r)")
(ng)
(assert (pf "Sub r(Var map Seq 0 Lh(rho::rhos))=r"))
(use "IHr")
(use "Cor rhos(Abs rho r)")
(assume "EqHyp")
(ng)
(simp "UpSeq")
(use "EqHyp")
(save "SubIds")

; "NTheorem"
(set-goal (pf "all rhos,rho,r.Cor rhos r -> ex s N(Typ rhos r)r s"))
(assume "rhos" "rho" "r" "Cor rhos r")
(assert (pf "all k.Fr r k -> ex s N(Typ rhos r)r s"))
(use "LemmaOne")
(cut (pf "SC^(Typ rhos r)(Sub r(Var map Seq 0 Lh rhos))"))
(simp "SubIds")
(auto)
(use "LemmaThree")
(prop)
(use "SCsSeq")
(assume "H1")
(use "H1" (pt "Lh rhos"))
(use "Ax12")
(use "Cor rhos r")
(save "NTheorem")

(pp (nt (proof-to-extracted-term (theorem-name-to-proof "NTheorem"))))

; [rhos0,rho1,r2]
;  left((cLemmaOne alpha34)(Typ rhos0 r2))
;  ((cLemmaThree alpha36 alpha34)r2 rhos0((cSCsSeq alpha36)rhos0 0))
;  Lh rhos0

(pp (nt (proof-to-extracted-term
	 (expand-theorems
	  (theorem-name-to-proof "NTheorem")
	  (lambda (x) (member x '("LemmaOne" "LemmaThree")))))))

; [rhos0,rho1,r2]
;  left((Rec type=>(alpha34=>nat=>term)@@((nat=>term)=>alpha34))
;       ((cSCDefIotaOne alpha34)@(cSCDefIotaTwo alpha34))
;       ([rho3,rho4,p5,p6]
;         ([a7,n8]
;           Abs rho3
;           (Sub
;            (left p6((cSCDefOne alpha34)a7(right p5([n9]Var n8)))(Succ n8))
;            ((Var map Seq 1 n8):+:(Var 0):)))@
;         ([f7](cSCDefTwo alpha34)([a8]right p6([n9]f7 n9(left p5 a8 n9)))))
;       (Typ rhos0 r2))
;  ((Rec term=>list type=>alpha36=>alpha34)
;   ([n3,rhos4](cLemmaThreeVar alpha36 alpha34)rhos4 n3)
;   ([r3,r4,h5,h6,rhos7,x8](cSCDefOne alpha34)(h5 rhos7 x8)(h6 rhos7 x8))
;   ([rho3,r4,h5,rhos6,x7]
;     (cSCDefTwo alpha34)
;     ([a8]
;       (cLemmaTwo alpha34)(Typ(rho3::rhos6)r4)
;       (h5(rho3::rhos6)((cSCsDefThree alpha34 alpha36)a8 x7))))
;   r2 
;   rhos0
;   ((cSCsSeq alpha36)rhos0 0))
;  Lh rhos0

(pp (nt (proof-to-extracted-term
	 (expand-theorems (theorem-name-to-proof "NTheorem")))))

; ; ok, program constant arbalphaThreeFour: alpha34
; ; of t-degree 1 and arity 0 added
; [rhos0,rho1,r2]
;  left((Rec type=>(alpha34=>nat=>term)@@((nat=>term)=>alpha34))
;       ((cSCDefIotaOne alpha34)@(cSCDefIotaTwo alpha34))
;       ([rho3,rho4,p5,p6]
;         ([a7,n8]
;           Abs rho3
;           (Sub
;            (left p6((cSCDefOne alpha34)a7(right p5([n9]Var n8)))(Succ n8))
;            ((Var map Seq 1 n8):+:(Var 0):)))@
;         ([f7](cSCDefTwo alpha34)([a8]right p6([n9]f7 n9(left p5 a8 n9)))))
;       (Typ rhos0 r2))
;  ((Rec term=>list type=>alpha36=>alpha34)
;   ([n3,rhos4]
;     (Rec list type=>nat=>alpha36=>alpha34)
;     ([n6,x7](arbalphaThreeFour alpha34))
;     ([rho6,rhos7,(nat=>alpha36=>alpha34)_8,n9,x10]
;       [if n9
;         ((cSCsDefOne alpha36 alpha34)rho6 rhos7 x10)
;         ([n11]
;          (nat=>alpha36=>alpha34)_8 n11((cSCsDefTwo alpha36)rho6 rhos7 x10))])
;     rhos4 
;     n3)
;   ([r3,r4,h5,h6,rhos7,x8](cSCDefOne alpha34)(h5 rhos7 x8)(h6 rhos7 x8))
;   ([rho3,r4,h5,rhos6,x7]
;     (cSCDefTwo alpha34)
;     ([a8]
;       (Rec type=>alpha34=>alpha34)
;       ([a9](cSCDefIotaTwo alpha34)((cSCDefIotaOne alpha34)a9))
;       ([rho9,rho10,g11,g12,a13]
;         (cSCDefTwo alpha34)([a14]g12((cSCDefOne alpha34)a13 a14)))
;       (Typ(rho3::rhos6)r4)
;       (h5(rho3::rhos6)((cSCsDefThree alpha34 alpha36)a8 x7))))
;   r2 
;   rhos0
;   ((Rec list type=>nat=>alpha36)([n3](cSCsDefNilTwo alpha36))
;    ([rho3,rhos4,(nat=>alpha36)_5,n6]
;      (cSCsDefThree alpha34 alpha36)
;      (right((Rec type=>(alpha34=>nat=>term)@@((nat=>term)=>alpha34))
;             ((cSCDefIotaOne alpha34)@(cSCDefIotaTwo alpha34))
;             ([rho7,rho8,p9,p10]
;               ([a11,n12]
;                 Abs rho7
;                 (Sub
;                  (left p10((cSCDefOne alpha34)a11(right p9([n13]Var n12)))
;                   (Succ n12))
;                  ((Var map Seq 1 n12):+:(Var 0):)))@
;               ([f11]
;                 (cSCDefTwo alpha34)
;                 ([a12]right p10([n13]f11 n13(left p9 a12 n13)))))
;             rho3)
;       ([n7]Var n6))
;      ((nat=>alpha36)_5(Succ n6)))
;    rhos0 
;    0))
;  Lh rhos0


; 2005-03-14 Inductive definitions of N A H Fr.
; ============================================
; (Obsolete)
; We first need vector notation for terms.

(add-alg "vterm"
	 '("VVar" "nat=>(list vterm)=>vterm")
	 '("VAbs" "type=>vterm=>(list vterm)=>vterm"))

(add-var-name "vt" (py "vterm"))
(add-var-name "vts" (py "list vterm"))

(pp (nt (pt "VVar 2(vt1::vt2:)")))
(pp (nt (pt "VAbs Iota vt(vt1::vt2:)")))

(add-program-constant "VApp" (py "vterm=>vterm=>vterm") 1)

(add-computation-rule (pt "VApp(VVar n vts)vt") (pt "VVar n(vts:+:vt:)"))
(add-computation-rule (pt "VApp(VAbs rho vt vts)vt1")
		      (pt "VAbs rho vt(vts:+:vt1:)"))

(add-program-constant "VAppList" (py "vterm=>(list vterm)=>vterm") 1)

(add-computation-rule (pt "VAppList vt(Nil vterm)") (pt "vt"))
(add-computation-rule (pt "VAppList vt(vt1::vts)")
		      (pt "VAppList(VApp vt vt1)vts"))

(add-program-constant "AppList" (py "term=>(list term)=>term") 1)

(add-computation-rule (pt "AppList r(Nil term)") (pt "r"))
(add-computation-rule (pt "AppList r(r1::rs)") (pt "AppList(r r1)rs"))

(add-program-constant "TermToVterm" (py "term=>vterm") 1)

(add-computation-rule (pt "TermToVterm(Var n)") (pt "VVar n(Nil vterm)"))
(add-computation-rule (pt "TermToVterm(r s)")
		      (pt "VApp(TermToVterm r)(TermToVterm s)"))
(add-computation-rule (pt "TermToVterm(Abs rho r)")
		      (pt "VAbs rho(TermToVterm r)(Nil vterm)"))

(pp (nt (pt "TermToVterm(Var 0(Var 2(Abs Iota(Var 7))))")))
; VVar 0(VVar 2(VAbs Iota(VVar 7(Nil vterm))(Nil vterm)):):

(add-program-constant "VtermToTerm" (py "vterm=>term") 1)

(add-computation-rule (pt "VtermToTerm(VVar n vts)")
		      (pt "AppList(Var n)(VtermToTerm map vts)"))
(add-computation-rule (pt "VtermToTerm(VAbs rho vt vts)")
		      (pt "AppList(Abs rho(VtermToTerm vt))
                                  (VtermToTerm map vts)"))

(pp (nt (pt "VtermToTerm(TermToVterm(Var 0(Var 2(Abs Iota(Var 7)))))")))

(pp (nt (pt "TermToVterm(VtermToTerm(
             VVar 0(VVar 2(VAbs Iota(VVar 7(Nil vterm))(Nil vterm)):):))")))

; Now we inductively define WN, Eta and Exp

(add-ids
 (list (list "WN" (make-arity (py "vterm") (py "vterm")))
       (list "WNs" (make-arity (py "list vterm") (py "list vterm"))))
 '("all n,vts1,vts2.WNs vts1 vts2 -> WN(VVar n vts1)(VVar n vts2)")
 '("all vt1,vt1.WN vt1 vt2 -> 
                WN(VAbs rho vt1(Nil vterm))(VAbs rho vt2(Nil vterm))")
 '("all rho,vt1,vt2,vt3,vts1,vts2.
  WN(VAppList(TermToVterm(Sub(VtermToTerm vt1)((VtermToTerm vt2):)))vts1)vt3 ->
  WN(VAbs rho vt1(vt2::vts1))vt3")
 '("WNs(Nil vterm)(Nil vterm)")
 '("all vt1,vt2,vts1,vts2.WN vt1 vt2 -> WNs vts1 vts2 -> 
                          WNs(vt1::vts1)(vt2::vts2)"))

; Fb vt k means that k is a bound for the variables free in vt
(add-ids
 (list (list "Fb" (make-arity (py "vterm") (py "nat")))
       (list "FbList" (make-arity (py "list vterm") (py "nat"))))
 '("all k,n,vts.FbList vts k -> n<k -> Fb(VVar n vts)k")
 '("all rho,k,vt,vts.Fb vt k -> FbList vts k -> Fb(VAbs rho vt vts)k")
 '("all k FbList(Nil vterm)k")
 '("all k,vt,vts.Fb vt k -> FbList vts k -> FbList(vt::vts)k"))

; Eta rho vt1 vt2 means that vt2 is the outer eta expansion of vt1 : rho
(add-ids
 (list (list "Eta" (make-arity (py "type") (py "vterm") (py "vterm"))))
 '("all vt Eta Iota vt vt")
 '("all rho,sig,k,vt1,vt2,vt3.Fb vt1 k -> Eta rho(VVar k(Nil vterm))vt2 -> 
     Eta sig(VApp vt1 vt2)vt3 ->
     Eta(rho to sig)vt1
 (TermToVterm(Abs rho(Sub(VtermToTerm vt3)((Var map(Seq 1 k)):+:(Var 0):))))"))

; Exp vt1 vt2 means that vt2 is the eta expansion of vt1
(add-ids
 (list (list "Exp" (make-arity (py "vterm") (py "vterm")))
       (list "ExpList" (make-arity (py "list vterm") (py "list vterm"))))
 '("all rho,k,vts1,vts2,vt.ExpList vts1 vts2 -> Eta rho(VVar k vts2)vt ->
     Exp(VVar k vts1)vt")
 '("all rho,vt1,vt1.Exp vt1 vt2 -> 
     Exp(VAbs rho vt1(Nil vterm))(VAbs rho vt2(Nil vterm))")
 '("ExpList(Nil vterm)(Nil vterm)")
 '("all vt1,vt2,vts1,vts2.Exp vt1 vt2 -> ExpList vts1 vts2 -> 
                          ExpList(vt1::vts1)(vt2::vts2)"))

; (remove-pvar-name "Exp")
; (remove-idpc-name "Exp")

; LNF vt1 vt2 means that vt2 is the long normal form of vt1

(add-ids
 (list (list "LNF" (make-arity (py "vterm") (py "vterm"))))
 '("all vt1,vt2,vt3.WN vt1 vt2 -> Exp vt2 vt3 -> LNF vt1 vt3"))

; Test of elim-aconst
(add-pvar-name "Q" (make-arity (py "vterm") (py "vterm")))
(add-pvar-name "Qs" (make-arity (py "list vterm") (py "list vterm")))
(define aconst1 (imp-formulas-to-elim-aconst
		(pf "Exp vt^1 vt^2 -> Q^vt^1 vt^2")
		(pf "ExpList vts^1 vts^2 -> Qs^vts^1 vts^2")))
(pp (aconst-to-formula aconst1))
(define aconst2 (imp-formulas-to-elim-aconst
		 (pf "ExpList vts^1 vts^2 -> Qs^vts^1 vts^2")
		 (pf "Exp vt^1 vt^2 -> Q^vt^1 vt^2")))
(pp (aconst-to-formula aconst2))

; "LemmaAx1"
(set-goal
 (pf "all rho,k,vt1,vt2.Fb vt1 k -> LNF(VApp vt1(VVar k(Nil vterm)))vt2 ->
       LNF vt1(TermToVterm
      (Abs rho(Sub(VtermToTerm vt2)((Var map(Seq 1 k)):+:(Var 0):))))"))
(assume "rho" "k")
(ind)
(assume "n" "vts" "vt" "Fb(VVar n vts)k")
(ng #t)
(elim)
(assume "vt1" "vt2" "vt3" "WN vt1 vt2" "Exp vt2 vt3")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Test with Sub

(pp (pt "Sub(Abs Iota(Var 0(Var 1)(Var 2)))(Var 7):"))
(pp (nt (pt "Sub(Abs Iota(Var 0(Var 1)(Var 2)))(Var 7):")))
; Abs Iota(Var 0(Var 8)(Var 0))
; the final Var 0 should be Var 1 !
; The problem is that 
(pp (nt (pt "Free(Abs Iota(Var 0(Var 1)(Var 2)))"))) ;=> 2 and 
(pp (nt (pt "Lh((Var 7):)"))) ;=>1 
; and Sub r rs behaves reasonable only when Free r<=Lh rs (cf SubSub)

(display-program-constants "Sub")
Sub
  comprules
	Sub(Var n)(Nil term)	Var n
	Sub(Var 0)(r::rs)	r
	Sub(Var(Succ n))(r::rs)	Sub(Var n)rs
	Sub(r s)rs	Sub r rs(Sub s rs)
	Sub(Abs rho r)rs	Abs rho(Sub r(Var 0::Up 0 map rs))

; Cure: Add additional integer, which explains what to do with
; remaining vars above the substituted ones (cf Joachimski)

(pp (nt (pt "Sub(Var 0(Var 1)(Var 2))(Var 0::Up 0 map(Var 7):)"))) 

(pp (nt (pt "Sub(Abs Iota(Var 0(Var 1)(Var 2)))((Var 7)::(Var 1):)")))
; Abs Iota(Var 0(Var 8)(Var 2)), as it should be.

; For beta-conversion (Abs rho r)s one wants to substitute just one
; term s.  To employ Sub for this, one needs to use the list
; s::1::2::...::k: of length >=Free r.  As a shorthand for this one
; may use the pair of the list s: and the number 1, where the 1 stands
; for a sufficiently long list 1::2::...::k: .

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; 2005-05-01 Program extraction from normalization proofs: semantic
; based treatment, with SCr instead of SC.  All operations should be
; executable, and all data should be kept finite if they are finite
; (e.g., we do not view substitutions a functions).  Moreover, they
; should be short if they can be short: hence substitutions are treated
; in Joachimski/Hancock style, as a list with a trailing number.  Then
; beta can easily be formulated.

(reset)

(set! COMMENT-FLAG #f)
(libload "nat.scm")
(libload "list.scm")
(set! COMMENT-FLAG #t)

(av "l" (py "nat"))

(add-alg "type"
	 '("Iota" "type")
	 '("Arrow" "type=>type=>type"))

(add-token
 "to"
 'pair-op
 (lambda (x y)
   (let* ((type1 (term-to-type x))
	  (type2 (term-to-type y))
	  (type (types-lub type1 type2)))
     (mk-term-in-app-form
      (make-term-in-const-form (constr-name-to-constr "Arrow"))
      x y))))

(add-display
 (py "type")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "Arrow"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'pair-op "to"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))

(add-var-name "rho" "sig" "tau" (py "type"))

(add-program-constant "Argtyp" (py "type=>type") 1)
(add-program-constant "Valtyp" (py "type=>type") 1)
(add-program-constant "Arrowtyp" (py "type=>boole") 1)

(add-computation-rule (pt "Argtyp Iota") (pt "Iota"))
(add-computation-rule (pt "Valtyp Iota") (pt "Iota"))
(add-computation-rule (pt "Argtyp(rho to sig)") (pt "rho"))
(add-computation-rule (pt "Valtyp(rho to sig)") (pt "sig"))

(add-computation-rule (pt "Arrowtyp Iota") (pt "False"))
(add-computation-rule (pt "Arrowtyp(rho to sig)") (pt "True"))

(add-alg "term"
	 '("Var" "nat=>term")
	 '("App" "term=>term=>term")
	 '("Abs" "type=>term=>term"))

; Application for terms is via the constant App

(add-new-application 
 (lambda (type) (equal? type (py "term")))
 (lambda (term1 term2) (mk-term-in-app-form (pt "App") term1 term2)))

(add-new-application-syntax
 ; predicate
 (lambda (term)
   (and (term-in-app-form? term)
	(let ((op (term-in-app-form-to-op term)))
	  (term-in-app-form? op)
	  (term=? (pt "App") (term-in-app-form-to-op op)))))
 ; to arg
 (lambda (term)
   (term-in-app-form-to-arg term))
 ; to op
 (lambda (term)
   (term-in-app-form-to-arg
    (term-in-app-form-to-op term))))

(add-var-name "r" "s" "t" (py "term"))
(add-var-name "rs" "ss" "ts" (py "list term"))
(add-var-name "rhos" "sigs" "taus" (py "list type")) ;used for contexts

(add-program-constant "Typ" (py "list type=>term=>type") 1)

(add-computation-rule (pt "Typ(Nil type)(Var n)") (pt "Iota"))
(add-computation-rule (pt "Typ(rho::rhos)(Var 0)") (pt "rho"))
(add-computation-rule (pt "Typ(rho::rhos)(Var(Succ n))")
		      (pt "Typ rhos(Var n)"))
(add-computation-rule (pt "Typ rhos(r s)") (pt "Valtyp(Typ rhos r)"))
(add-computation-rule (pt "Typ rhos(Abs rho r)")
		      (pt "rho to Typ(rho::rhos)r"))

(add-program-constant "Cor" (py "list type=>term=>boole") 1)

(add-computation-rule (pt "Cor rhos(Var n)") (pt "n<Lh rhos"))
(add-computation-rule (pt "Cor rhos(r s)")
		      (pt "Cor rhos r and Cor rhos s and
                           Typ rhos r=(Typ rhos s to Valtyp(Typ rhos r))"))
(add-computation-rule (pt "Cor rhos(Abs rho r)") (pt "Cor(rho::rhos)r"))

(add-program-constant "Lift" (py "term=>nat=>nat=>term") 1)

(add-computation-rule (pt "Lift(Var n)l k")
		      (pt "[if (n<l) (Var n) (Var(n+k))]"))
(add-computation-rule (pt "Lift(r s)l k")
		      (pt "(Lift r l k)(Lift s l k)"))
(add-computation-rule (pt "Lift(Abs rho r)l k")
		      (pt "Abs rho(Lift r(l+1)k)"))

; Substitution in the style of Hancock/Joachimski

(add-alg "sub"
	 '("Up" "nat=>sub")
	 '("Dot" "term=>sub=>sub"))

(add-var-name "theta" (py "sub"))

(add-program-constant "Sublift" (py "sub=>nat=>sub") 1)

(add-computation-rule (pt "Sublift(Up m)n") (pt "Up(m+n)"))
(add-computation-rule (pt "Sublift(Dot r theta)n")
		      (pt "Dot(Lift r 0 n)(Sublift theta n)"))

; For convenience we want to view a substitution as a pair of a list
; and a number.

(add-program-constant "Mksub" (py "list term=>nat=>sub") 1)

(add-computation-rule (pt "Mksub(Nil term)n") (pt "Up n"))
(add-computation-rule (pt "Mksub(r::rs)n") (pt "Dot r(Mksub rs n)"))

(add-program-constant "Sublist" (py "sub=>list term") 1)

(add-computation-rule (pt "Sublist(Up n)") (pt "(Nil term)"))
(add-computation-rule (pt "Sublist(Dot r theta)") (pt "r::(Sublist theta)"))

(add-program-constant "Subup" (py "sub=>nat") 1)

(add-computation-rule (pt "Subup(Up n)") (pt "n"))
(add-computation-rule (pt "Subup(Dot r theta)") (pt "Subup theta"))

; Sub r theta substitutes theta in the term r

(add-program-constant "Sub" (py "term=>sub=>term") 1)

(add-computation-rule (pt "Sub(Var n)(Up m)") (pt "Var(n+m)"))
(add-computation-rule (pt "Sub(Var 0)(Dot r theta)") (pt "r"))
(add-computation-rule (pt "Sub(Var(Succ n))(Dot r theta)")
		      (pt "Sub(Var n)theta"))
(add-computation-rule (pt "Sub(r s)theta") (pt "(Sub r theta)(Sub s theta)"))
(add-computation-rule (pt "Sub(Abs rho r)theta")
		      (pt "(Abs rho(Sub r(Dot(Var 0)(Sublift theta 1))))"))

; We add omega to algebra type, and call the resulting algebra typeinf
; First the general sum type-operator:

(add-param-alg "yplus" 'sum-typeop
	       '("Inleft" "alpha1=>yplus")
	       '("Inright" "alpha2=>yplus"))

(add-var-name "a" "b" "c" (py "type yplus unit"))
(add-var-name "as" "bs"  (py "list(type yplus unit)"))

(add-token
 "Inl"
 'prefix-op
 (lambda (x) (mk-term-in-app-form (pt "(Inleft type unit)") x)))

(add-token
 "Inr"
 'prefix-op
 (lambda (x) (mk-term-in-app-form (pt "(Inright unit type)") x)))

(add-display
 (py "type yplus unit")
 (lambda (x)
   (let* ((op (term-in-app-form-to-final-op x))
	  (args (term-in-app-form-to-args x)))
     (cond ((and (term-in-const-form? op)
		 (string=? "Inleft"
			   (const-to-name (term-in-const-form-to-const op)))
		 (= 1 (length args)))
	    (list 'prefix-op "Inl" (term-to-token-tree (car args))))
	   ((and (term-in-const-form? op)
		 (string=? "Inright"
			   (const-to-name (term-in-const-form-to-const op)))
		 (= 1 (length args)))
	    (list 'prefix-op "Inr" (term-to-token-tree (car args))))
	   (else #f)))))

; Map for lists

(add-program-constant
 "ListMap" (py "(alpha1=>alpha2)=>list alpha1=>list alpha2") 1)

(add-token
 "map" 'pair-op ;right associative
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "ListMap"))
	    (tvars (const-to-tvars const))
	    (listtype (term-to-type y))
	    (type1 (car (alg-form-to-types listtype)))
	    (type2 (arrow-form-to-val-type (term-to-type x)))
	    (subst (make-substitution tvars (list type1 type2))))
       (const-substitute const subst #f)))
    x y)))

(add-display
 (py "list alpha")
 (lambda (x)
   (let* ((op (term-in-app-form-to-final-op x))
	  (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "ListMap"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'pair-op "map"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))

(add-computation-rule
 (pt "alpha1=>alpha2 map(Nil alpha1)")
 (pt "(Nil alpha2)"))

(add-computation-rule
 (pt "alpha1=>alpha2 map alpha1::(list alpha1)_1")
 (pt "alpha1=>alpha2 alpha1::alpha1=>alpha2 map(list alpha1)_1"))

(add-program-constant "Seq" (py "nat=>nat=>list nat") 1)

(add-computation-rule (pt "Seq n 0") (pt "(Nil nat)"))
(add-computation-rule (pt "Seq n(Succ l)") (pt "n::Seq(Succ n)l"))

(add-program-constant "Part" (py "type yplus unit=>type") 1)
(add-program-constant "ModIota" (py "type yplus unit=>nat=>term") 1)
(add-program-constant "HatIota" (py "(nat=>term)=>type yplus unit") 1)
(add-program-constant
 "Mod" (py "type yplus unit=>type yplus unit=>type yplus unit") 1)
(add-program-constant
 "Hat" (py "type=>type=>(type yplus unit=>type yplus unit)=>type yplus unit")
 1)

(add-global-assumption
 "HatModIota" (pf "all a.Part a=Iota -> HatIota(ModIota a)=a"))

(add-var-name "g" (py "nat=>term"))

(add-global-assumption
 "ModHatIota" (pf "all g Equal(ModIota(HatIota g))g"))

(add-global-assumption
 "HatMod" (pf "all rho,sig,a.Part a=(rho to sig) -> Hat rho sig(Mod a)=a"))

(add-var-name "h" (py "type yplus unit=>type yplus unit"))

(add-global-assumption
 "ModHat" (pf "all rho,sig,h.(all a.Part a=rho -> Part(h a)=sig) ->
                             all a.Mod(Hat rho sig h)a=h a"))

; Predicates

(add-predconst-name "N" (make-arity (py "term") (py "term")))
(add-predconst-name "A" (make-arity (py "term") (py "term")))
(add-predconst-name "Head" (make-arity (py "term") (py "term")))
(add-predconst-name "Fr" (make-arity (py "term") (py "nat")))

(add-predconst-name
 "SCr" (make-arity (py "type yplus unit") (py "type") (py "term")))

(add-global-assumption
 "SCrIotaOne" (pf "all a,r.SCr a Iota r -> Part a=Iota"))

(add-global-assumption
 "SCrIotaTwo" (pf "all a,r.SCr a Iota r -> all k.Fr r k -> N r(ModIota a k)"))

(add-global-assumption
 "SCrIotaThree"
 (pf "all a,r.Part a=Iota -> (all k.Fr r k -> N r(ModIota a k)) -> 
              SCr a Iota r"))

(add-global-assumption
 "SCrOne" (pf "all rho,sig,a,r.SCr a(rho to sig)r -> Part a=(rho to sig)"))

(add-global-assumption
 "SCrTwo" (pf "all rho,sig,a,r.SCr a(rho to sig)r -> 
                               all b,s.SCr b rho s -> SCr(Mod a b)sig(r s)"))

(add-global-assumption
 "SCrThree"
 (pf "all rho,sig,a,r.Part a=(rho to sig) -> 
                      (all b,s.SCr b rho s -> SCr(Mod a b)sig(r s)) -> 
                      SCr a(rho to sig)r"))

(add-predconst-name
 "SCrs" (make-arity (py "list(type yplus unit)")
		    (py "list type") (py "list term")))

(add-global-assumption
 "SCrsDefNil" (pf "SCrs(Nil type yplus unit)(Nil type)(Nil term)"))

(add-global-assumption
 "SCsDefOne" (pf "all rho,rhos,a,as,r,rs.SCr a rho r -> SCrs as rhos rs ->
                      SCrs(a::as)(rho::rhos)(r::rs)"))

(add-global-assumption
 "SCsDefTwo" (pf "all rho,rhos,a,as,r,rs.SCrs(a::as)(rho::rhos)(r::rs) ->
                                         SCr a rho r"))

(add-global-assumption
 "SCsDefThree" (pf "all rho,rhos,a,as,r,rs.SCrs(a::as)(rho::rhos)(r::rs) ->
                                           SCrs as rhos rs"))

(add-global-assumption
 "Ax1"
 (pf "all rhos,r,k,s.Fr r k -> Cor rhos r -> N(r(Var k))s -> 
       N r(Abs(Argtyp(Typ rhos r))
           (Sub s(Mksub((Var map(Seq 1 k)):+:(Var 0):)0)))"))

(add-global-assumption "Ax2" (pf "all r,s.A r s -> N r s"))

(add-global-assumption "Ax3" (pf "all k A(Var k)(Var k)"))

(add-global-assumption
 "Ax4" (pf "all r,r1,s,s1.A r r1 -> N s s1 -> A(r s)(r1 s1)"))

(add-global-assumption "Ax5" (pf "all r,s,t.Head r s -> N s t -> N r t"))

(add-global-assumption
 "Ax6" (pf "all rho,r,theta,s 
             Head(Sub(Abs rho r)theta s)(Sub r(Dot s(Sublift theta 1)))"))

(add-global-assumption "Ax7" (pf "all r,s,t.Head r s -> Head(r t)(s t)"))

(add-global-assumption
 "Ax8" (pf "all r,k.Fr r k -> Fr(r(Var k))(Succ k)"))

(add-global-assumption "Ax9" (pf "all r,s,k.Fr(r s)k -> Fr s k"))

(add-global-assumption "Ax10" (pf "all r,s,k.Fr(r s)k -> Fr r k"))

(add-global-assumption "Ax11" (pf "all r,s,k.Fr r k -> Head r s -> Fr s k"))

(add-global-assumption
 "ACIota" (pf "(all k.(Pvar nat)k -> ex r (Pvar nat term)k r) ->
                ex g all k.(Pvar nat)k ->  (Pvar nat term)k(g k)") 1)

(add-global-assumption
 "AC" (pf "(all b allnc s.(Pvar type yplus unit term)_1 b s ->
            ex c (Pvar type yplus unit term)_2 c s) ->
           ex h all b,s.(Pvar type yplus unit term)_1 b s ->
                        (Pvar type yplus unit term)_2(h b)s"))

; "LemmaOne"
; (set-goal
(add-global-assumption "LemmaOne"
 (pf "all rho allnc r1.
       (all a.SCr a rho r1 -> all k.Fr r1 k -> ex r2 N r1 r2) &
       ((all k.Fr r1 k -> ex r2 A r1 r2) -> ex a SCr a rho r1)"))

; LemmaTwo
; (set-goal 
(add-global-assumption "LemmaTwo"
       (pf "all rho,r1,r,a.SCr a rho r1 -> Head r r1 -> SCr a rho r"))

; "LemmaThree"
(set-goal
 (pf "all r allnc rhos,sigs,as,ss,l.Cor rhos r ->
       SCrs as rhos ss -> (0<l -> Lh rhos-1+l<Lh sigs) ->
       ex a SCr a(Typ rhos r)(Sub r(Mksub ss l))"))
(ind)
(assume "k" "rhos" "sigs" "as" "ss" "l" "Cor rhos r"
        "SCrs as rhos ss")

; "NTheorem"
(set-goal (pf "all rhos,rho,r.Cor rhos r -> ex s N r s"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 2005-10-14 New attempt (with the intention that all previous ones
; should go).  Main points (1) Substitutions in Hancock/Joachimski
; style, with a trailing number.  (2) WN, Eta, Exp, IExp should all be
; recursively defined, hence also N and A.

(reset)

(set! COMMENT-FLAG #f)
(libload "nat.scm")
(libload "list.scm")
(set! COMMENT-FLAG #t)

(av "l" (py "nat"))

(add-alg "type"
	 '("Iota" "type")
	 '("Arrow" "type=>type=>type"))

(add-token
 "to"
 'pair-op
 (lambda (x y)
   (let* ((type1 (term-to-type x))
	  (type2 (term-to-type y))
	  (type (types-lub type1 type2)))
     (mk-term-in-app-form
      (make-term-in-const-form (constr-name-to-constr "Arrow"))
      x y))))

(add-display
 (py "type")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "Arrow"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'pair-op "to"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))

(add-var-name "rho" "sig" "tau" (py "type"))

(add-program-constant "Argtyp" (py "type=>type") 1)
(add-program-constant "Valtyp" (py "type=>type") 1)
(add-program-constant "Arrowtyp" (py "type=>boole") 1)

(add-computation-rule (pt "Argtyp Iota") (pt "Iota"))
(add-computation-rule (pt "Valtyp Iota") (pt "Iota"))
(add-computation-rule (pt "Argtyp(rho to sig)") (pt "rho"))
(add-computation-rule (pt "Valtyp(rho to sig)") (pt "sig"))

(add-computation-rule (pt "Arrowtyp Iota") (pt "False"))
(add-computation-rule (pt "Arrowtyp(rho to sig)") (pt "True"))

(add-alg "term"
	 '("Var" "nat=>term")
	 '("App" "term=>term=>term")
	 '("Abs" "type=>term=>term"))

; Application for terms is via the constant App

(add-new-application 
 (lambda (type) (equal? type (py "term")))
 (lambda (term1 term2) (mk-term-in-app-form (pt "App") term1 term2)))

(add-new-application-syntax
 ; predicate
 (lambda (term)
   (and (term-in-app-form? term)
	(let ((op (term-in-app-form-to-op term)))
	  (term-in-app-form? op)
	  (term=? (pt "App") (term-in-app-form-to-op op)))))
 ; to arg
 (lambda (term)
   (term-in-app-form-to-arg term))
 ; to op
 (lambda (term)
   (term-in-app-form-to-arg
    (term-in-app-form-to-op term))))

(add-var-name "r" "s" "t" (py "term"))
(add-var-name "rs" "ss" "ts" (py "list term"))
(add-var-name "rhos" "sigs" "taus" (py "list type")) ;used for contexts

(add-program-constant "Typ" (py "list type=>term=>type") 1)

(add-computation-rule (pt "Typ(Nil type)(Var n)") (pt "Iota"))
(add-computation-rule (pt "Typ(rho::rhos)(Var 0)") (pt "rho"))
(add-computation-rule (pt "Typ(rho::rhos)(Var(Succ n))")
		      (pt "Typ rhos(Var n)"))
(add-computation-rule (pt "Typ rhos(r s)") (pt "Valtyp(Typ rhos r)"))
(add-computation-rule (pt "Typ rhos(Abs rho r)")
		      (pt "rho to Typ(rho::rhos)r"))

(add-program-constant "Cor" (py "list type=>term=>boole") 1)

(add-computation-rule (pt "Cor rhos(Var n)") (pt "n<Lh rhos"))
(add-computation-rule (pt "Cor rhos(r s)")
		      (pt "Cor rhos r and Cor rhos s and
                           Typ rhos r=(Typ rhos s to Valtyp(Typ rhos r))"))
(add-computation-rule (pt "Cor rhos(Abs rho r)") (pt "Cor(rho::rhos)r"))

(add-program-constant "Lift" (py "term=>nat=>nat=>term") 1)

(add-computation-rule (pt "Lift(Var n)l k")
		      (pt "[if (n<l) (Var n) (Var(n+k))]"))
(add-computation-rule (pt "Lift(r s)l k")
		      (pt "(Lift r l k)(Lift s l k)"))
(add-computation-rule (pt "Lift(Abs rho r)l k")
		      (pt "Abs rho(Lift r(l+1)k)"))

; Substitution in the style of Hancock/Joachimski

(add-alg "sub"
	 '("Up" "nat=>sub")
	 '("Dot" "term=>sub=>sub"))

(add-var-name "theta" (py "sub"))

(add-program-constant "Sublift" (py "sub=>nat=>sub") 1)

(add-computation-rule (pt "Sublift(Up m)n") (pt "Up(m+n)"))
(add-computation-rule (pt "Sublift(Dot r theta)n")
		      (pt "Dot(Lift r 0 n)(Sublift theta n)"))

; For convenience we want to view a substitution as a pair of a list
; and a number.

(add-program-constant "Mksub" (py "list term=>nat=>sub") 1)

(add-computation-rule (pt "Mksub(Nil term)n") (pt "Up n"))
(add-computation-rule (pt "Mksub(r::rs)n") (pt "Dot r(Mksub rs n)"))

(add-program-constant "Sublist" (py "sub=>list term") 1)

(add-computation-rule (pt "Sublist(Up n)") (pt "(Nil term)"))
(add-computation-rule (pt "Sublist(Dot r theta)") (pt "r::(Sublist theta)"))

(add-program-constant "Subup" (py "sub=>nat") 1)

(add-computation-rule (pt "Subup(Up n)") (pt "n"))
(add-computation-rule (pt "Subup(Dot r theta)") (pt "Subup theta"))


; Sub r theta substitutes theta in the term r

(add-program-constant "Sub" (py "term=>sub=>term") 1)

(add-computation-rule (pt "Sub(Var n)(Up m)") (pt "Var(n+m)"))
(add-computation-rule (pt "Sub(Var 0)(Dot r theta)") (pt "r"))
(add-computation-rule (pt "Sub(Var(Succ n))(Dot r theta)")
		      (pt "Sub(Var n)theta"))
(add-computation-rule (pt "Sub(r s)theta") (pt "(Sub r theta)(Sub s theta)"))
(add-computation-rule (pt "Sub(Abs rho r)theta")
		      (pt "(Abs rho(Sub r(Dot(Var 0)(Sublift theta 1))))"))


; Wrap n rs wraps up a list of terms to a Sublist with a parameter for lifting

(add-program-constant "Wrap" (py "nat=>list term=>sub") 1)

(add-computation-rule (pt "Wrap n(Nil term)") (pt "Up n"))
(add-computation-rule (pt "Wrap n(r::rs)") (pt "Dot r(Wrap n rs)"))


; Eta is the outer eta expansion
(add-program-constant "Eta" (py "type=>term=>term") 1)

(add-computation-rule (pt "Eta Iota r") (pt "r"))
(add-computation-rule (pt "Eta(rho to sig)r") 
		      (pt "Abs rho(Eta sig(Lift r 0 1(Eta rho(Var 0))))"))

(pp (nt (pt "Eta(Iota to Iota)(Var 0)")))
(pp (nt (pt "Eta(Iota to Iota)(Var 7)")))
(pp (nt (pt "Eta((Iota to Iota)to(Iota to Iota))(Var 7)")))

; Notice that the "1" (i.e., the totality) of Eta must be proved.
; This is easy, by induction on types.


; Exp is full eta expansion.  It is defined simultaneously with IExp,
; the inner eta expansion.

(add-program-constant "Exp" (py "list type=>type=>term=>term") 1)
(add-program-constant "IExp" (py "list type=>term=>term") 1)

(add-computation-rule (pt "Exp rhos rho(Var n)") (pt "Eta rho(Var n)"))
(add-computation-rule (pt "Exp rhos rho(r s)")
		      (pt "Eta rho(IExp rhos(r s))"))
(add-computation-rule (pt "Exp rhos tau(Abs rho r)")
		      (pt "Abs rho(Exp(rho::rhos)(Valtyp tau)r)"))

(add-computation-rule (pt "IExp rhos(Var n)") (pt "Var n"))
(add-computation-rule (pt "IExp rhos(r s)")
		      (pt "IExp rhos r(Exp rhos(Typ rhos s)s)"))

; Notice that the "1" (i.e., the totality) of Exp and IExp must be
; proved.  This is easy, by induction on terms (simultaneously).

(pp (pt "Abs rho(Abs sig(Var 1))")) ;K
(pp (pt "Abs(rho to sig to rho)
          (Abs(rho to sig)
            (Abs rho(Var 2(Var 0)(Var 1(Var 0)))))")) ;S

(define sterm
  (pt "Abs((Iota to Iota) to Iota to (Iota to Iota))
          (Abs((Iota to Iota) to Iota)
            (Abs (Iota to Iota)(Var 2(Var 0)(Var 1(Var 0)))))"))
(define stype (mk-term-in-app-form (pt "Typ") (pt "(Nil type)") sterm))
(pp stype)
(pp (nt stype))

(pp (nt (mk-term-in-app-form (pt "Exp(Nil type)") stype sterm)))


; The following is a useful comment, but obsolete for the development
; ; Beta performs a head beta reduction
; (add-program-constant "Beta" (py "term=>term=>term"))

; (add-computation-rule (pt "Beta(Var n)s") (pt "Var n s"))
; (add-computation-rule (pt "Beta(Abs rho r)s") (pt "Sub r(Dot s(Up 0))")) ;Rep
; (add-computation-rule (pt "Beta(r1 r2)s") (pt "r1 r2 s"))


; ; Red reduces the rank by one (cf. APAL 1998)
; (add-program-constant "Red" (py "term=>term"))

; (add-computation-rule (pt "Red(Var n)") (pt "Var n"))
; (add-computation-rule (pt "Red(Abs rho r)") (pt "Abs rho(Red r)"))
; (add-computation-rule (pt "Red(Var n s)") (pt "Var n(Red s)"))
; (add-computation-rule (pt "Red(r1 r2 s)")
; 		      (pt "Beta(Red(r1 r2))(Red s)")) ;Rep
; (add-computation-rule (pt "Red(Abs rho r s)")
; 		      (pt "Beta(Red(Abs rho r))(Red s)")) ;Rep 

; ; For infinitary terms one may insert Rep at the marked places.


; ; We could now define WN to compute the normal form, by iterating Red.
; ; But the totality of WN the whole point here; it cannot be assumed.
; ; A way to prove it is by induction on the rank, using that Red
; ; reduces the rank by 1.  But that would be a different proof, not the
; ; one using computability predicates.

; (add-program-constant "WN" (py "term=>term"))

(add-program-constant "NegConst" (py "boole=>boole") 1)

; We add a prefix notation `neg' for NegConst

(add-token
 "neg"
 'prefix-op
 (lambda (x)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "NegConst")) x)))

(add-display
 (py "boole")
 (lambda (x)
   (let* ((op (term-in-app-form-to-final-op x))
	  (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "NegConst"
			(const-to-name (term-in-const-form-to-const op)))
	      (= 1 (length args)))
	 (list 'prefix-op "neg"
	       (term-to-token-tree (car args)))
	 #f))))

(pp (pt "neg boole1 and neg boole2"))

(add-computation-rule (pt "NegConst True") (pt "False"))
(add-computation-rule (pt "NegConst False") (pt "True"))

(add-program-constant "IsAbs" (py "term=>boole") 1)

(add-computation-rule (pt "IsAbs(Var n)") (pt "False"))
(add-computation-rule (pt "IsAbs(Abs rho r)") (pt "True"))
(add-computation-rule (pt "IsAbs(r s)") (pt "False"))

(add-program-constant "IsNormal" (py "term=>boole") 1)

(add-computation-rule (pt "IsNormal(Var n)") (pt "True"))
(add-computation-rule (pt "IsNormal(Abs rho r)") (pt "IsNormal r"))
(add-computation-rule (pt "IsNormal(r s)")
		      (pt "IsNormal r and IsNormal s and neg(IsAbs r)"))

(add-program-constant "AreNormal" (py "list term=>boole") 1)

(add-computation-rule (pt "AreNormal(Nil term)") (pt "True"))
(add-computation-rule (pt "AreNormal(r::rs)")
		      (pt "IsNormal r and AreNormal rs"))

; (add-computation-rule (pt "WN r") (pt "[if (IsNormal r) r (WN(Red r))]"))


; ; Alternative: recusive definition of WN avoiding Red and Beta

; (add-computation-rule (pt "WN(Var n)") (pt "Var n"))
; (add-computation-rule (pt "WN(Abs rho r)") (pt "Abs rho(WN r)"))
; (add-computation-rule (pt "WN(Var n s)") (pt "Var n(WN s)"))
; (add-computation-rule (pt "WN(Abs rho r s)") (pt "WN(Sub r(Dot s(Up 0)))")
; (add-computation-rule
;  (pt "WN(r1 r2 s)")
;  (pt "([r0][if (IsAbs r0) (WN(r0 s)) (r0(WN s))])(WN(r1 r2))"))

; ; However, proving totality of this recursive definition and proving
; ; all r ex s WNInd r s for a corresponding inductive definition of
; ; WNInd is essentially the same.  Notice that application the
; ; inversion rule in case of a hypothesis WNInd r s with r of a
; ; specific form corresponds to normalizing the term WN r in the
; ; recursively defined WN.  (=> Schlenker)

; ; Therefore we now work with an inductive definition of WN,
; ; simultaneously with WNs.
; End of obsolete comment.


; Definition: FoldApp
; -------------------
(add-program-constant "FoldApp" (py "term => list term => term") 1)

(add-computation-rule (pt "FoldApp r(Nil term)") (pt "r"))
(add-computation-rule (pt "FoldApp r(s::ss)") (pt "FoldApp(r s)ss"))

(pp (nt (pt "FoldApp r(s::t:)")))
; => r s t


; Definition: "WN"
; ----------------
; Inductive definition of "WN", simultaneously with "WNs".

(add-ids
 (list (list "WN" (make-arity (py "term") (py "term")) "algWN")
       (list "WNs" (make-arity (py "list term") (py "list term")) "algWNs"))
 '("all n,rs,ss.WNs rs ss -> WN(FoldApp(Var n)rs)(FoldApp(Var n)ss)" "WNVar")
 '("all rho,r,s.WN r s -> WN(Abs rho r)(Abs rho s)" "WNAbs")
 '("all rho,r,s,t,rs.WN(FoldApp(Sub r(Wrap 0(s:)))rs)t ->
     WN(FoldApp(Abs rho r)(s::rs))t" "WNBeta")
 '("WNs(Nil term)(Nil term)" "WNsNil")
 '("all r,s,rs,ss.WN r s -> WNs rs ss -> WNs(r::rs)(s::ss)" "WNsCons"))

; (elim) expects an imp-formula I(ts) -> A[ts] as goal.  We have to
; provide the other imp-formulas to be proved simultaneously with the
; given one.  imp-formulas not provided are taken as I xs -> I xs.
; Then the (strengthened) clauses are generated as new goals.

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

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

; New inversion: imp-formulas not provided are taken as I xs -> I xs
; clause-proofs are extended: for clauses corresponding to I xs -> I xs
; we can use an intro-axiom (the rec-prems are not needed)

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

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

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

(add-ids (list (list "Even" (make-arity (py "nat")) "algEven"))
	 '("Even 0" "InitEven")
	 '("allnc n.Even n -> Even(n+2)" "GenEven"))

(set-goal (pf "all n.Even(Succ(Succ n)) -> Even n"))
(assume "n" "H")
(inversion "H")
(assume "m")
(ng)
(assume "Even m" "H1" "n=m")
(simp "n=m")
(use "Even m")

(set-goal (pf "all r,s,rs,ss.WNs(r::rs)(s::ss) -> WNs rs ss"))
(strip)
(inversion 1)
(assume "r1" "s1" "rs1" "ss1")
(strip)
(ng)
(inst-with-to 6 'right "rs=rs1")
(simp "rs=rs1")
(inst-with-to 7 'right "ss=ss1")
(simp "ss=ss1")
(use 3)

(set-goal (pf "all r,rs,ss.WNs(r::rs)ss -> ss=(Nil term) -> F"))
(assume "r" "rs" "ss" "H1")
(inversion "H1")
(assume "r1" "s1" "rs1" "ss1" "H2" "H3" "H4" "H5" "H6" "H7")
(simp "H7")
(prop)

(set-goal (pf "all r,rs,ts.WNs(r::rs)ts -> 
                ex s,ss.WN r s & WNs(r::rs)(s::ss)"))
(assume "r" "rs" "ts" "H1")
(inversion "H1")
(assume "r1" "s1" "rs1" "ss1" "H2" "H3" "H4" "H5" "H6" "H7")
(ex-intro (pt "s1"))
(ex-intro (pt "ss1"))
(split)
(ng 6)
(inst-with-to "H6" 'left "r=r1")
(simp "r=r1")
(use "H2")
(simp "<-" "H7")
(use "H1")

; WNTest0
(set-goal (pf "all rs,ss.WNs rs ss -> rs=(Nil term) -> ss=(Nil term)"))
(assume "rs" "ss")
(elim)
(prop)
(strip)
(prop)

; WNTest1
(set-goal (pf "all r,s.WN r s -> IsNormal r -> r=s"))
(assume "r" "s")
(elim (pf "WNs rs ss -> AreNormal rs -> rs=ss"))
; ok, the right clauses are generated.

(add-program-constant "Abss" (py "list type=>list term=>list term"))

(add-computation-rule (pt "Abss(Nil type)(Nil term)") (pt "(Nil term)"))
(add-computation-rule (pt "Abss(rho::rhos)(r::rs)")
		      (pt "(Abs rho r)::(Abss rhos rs)"))

; WNTest2
(set-goal (pf "all rho,r,s.
                WN(Abs rho r)s -> IsNormal(Abs rho r) -> (Abs rho r)=s"))
(assume "rho" "r" "s" "H")
; (inversion "H" (pf "WNs(Abss rhos rs)ss -> AreNormal(Abss rhos rs) -> 
;                    Abss rhos rs=ss"))
(inversion "H") ;now generates 3 subgoals

; The one for WNVar follows by efq, because a FoldApp term cannot be
; an Abs term.  The one for WNAbs needs WNTest1 above.  The one for
; WNApp follows from efq.


; WNsNil
(set-goal (pf "all ss.WNs(Nil term)ss -> ss=(Nil term)"))
(assume "ss" "H1")
(inversion "H1")
(prop)

; "WNsApp"
(set-goal (pf "all rs1,ss1,rs2,ss2.
                WNs rs1 ss1 -> WNs rs2 ss2 -> WNs(rs1:+:rs2)(ss1:+:ss2)"))
(ind)
(cases)

(strip)
(ng)
(use 2)

(strip)
(inversion 1)

(assume "r1" "rs1" "IH")
(cases)
(strip)
(inversion 2)

(assume "s1" "ss1" "rs2" "ss2" "H")
(inversion "H")
(assume "r" "s" "rs" "ss")
(strip)
(ng)
(inst-with-to 7 'left "r1=r")
(simp "r1=r")
(inst-with-to 8 'left "s1=s")
(simp "s1=s")
; (use "WNsCons") ;This does not (yet) work.  After changing add-ids it does
(use (make-proof-in-aconst-form
      (number-and-idpredconst-to-intro-aconst
       1 (make-idpredconst "WNs" '() '()))))
(use 3)
(use "IH")
(inst-with-to 7 'right "rs1=rs")
(simp "rs1=rs")
(inst-with-to 8 'right "ss1=ss")
(simp "ss1=ss")
(use 4)
(use 9)
(save "WNsApp")
(cdp)

(pp (proof-to-extracted-term (theorem-name-to-proof "InitEven")))

; constr-name-and-tsubst-to-constr
; constructor name expected
; InitEven


