; $Id: dbrealrs.scm,v 1.16 2008/01/25 13:30:25 logik Exp $
; Based on examples/sn.scm, from 2005-01-08 to NTheorem

; omega viewed as algebra with infinitely many constructors.
; InOut added, to force values of h:omega=>omega into the right part.

; For program extraction from normalization proofs we use de Bruijn
; indices for typed lambda terms, and a 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).

; To be changed later: substitutions should be short if they can be
; short: hence substitutions done in Joachimski/Hancock style, as a
; list with a trailing number.  Then beta can easily be formulated.


; ==========================
;  Section: Initial Section
; ==========================

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

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

(av "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")


; ===========================
;  Section: Basic Defintions
; ===========================

; Subsection: Definition of Types and Terms
; =========================================

; Definition: type (Types of the Lambda terms)
; --------------------------------------------
(add-alg "type"
	 '("Iota" "type")
	 '("Arrow" "type=>type=>type"))


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


; ________________________ INTERNAL ________________________
; Allows the infix notation with "to" instead of "Arrow"

(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))))
; _________________________________________________________


; Definition: term ("de Bruijn" terms)
; ------------------------------------
; "term" represents a "de Bruijn" term
(add-alg "term"
	 '("Var" "nat=>term")
	 '("App" "term=>term=>term")
	 '("Abs" "type=>term=>term"))

(add-var-name "r" "s" "t" (py "term"))


; ________________________ INTERNAL ________________________
; Allows the simplier notation for application without constructor

(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)
; _________________________________________________________


; Subsection: Typechecking
; ========================

; a) Analysis of the type
; -----------------------

; Definition: Arrowtyp
; --------------------
; Checking, if it is an arrow type

(add-program-constant "Arrowtyp" (py "type=>boole") 1)
(add-computation-rule (pt "Arrowtyp Iota") (pt "False"))
(add-computation-rule (pt "Arrowtyp(rho to sig)") (pt "True"))

; Definition: Argtyp, Valtyp
; --------------------------
; Return the first or second part of an arrow type respectively

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

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

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

; ________________________ INTERNAL ________________________
; Numeral

(define (typealg-numeral-to-type typealg-numeral)
  (let* ((op (term-in-app-form-to-final-op typealg-numeral))
	 (args (term-in-app-form-to-args typealg-numeral)))
    (if (not (and (term-in-const-form? op)
		  (eq? 'constr (const-to-kind
				(term-in-const-form-to-const op)))))
	(myerror "typealg-numeral-to-type" "constructor expected" op))
    (let ((name (const-to-name (term-in-const-form-to-const op))))
      (cond
       ((string=? "Iota" name) (py "nat=>term"))
       ((string=? "Arrow" name)
	(if (= 2 (length args))
	    (make-arrow (typealg-numeral-to-type (car args))
			(typealg-numeral-to-type (cadr args)))
	    (myerror "typealg-numeral-to-type" "2 arguments expected"
		     typealg-numeral)))
       (else (myerror "typealg-numeral-to-type" "typealg numeral expected"
		      typealg-numeral))))))

(define (typealg-numeral? term) ;should be done generally for algebras
  (or
   (and (term-in-const-form? term)
	(string=? "Iota" (const-to-name (term-in-const-form-to-const term))))
   (and (term-in-app-form? term)
	(let ((op (term-in-app-form-to-final-op term))
	      (args (term-in-app-form-to-args term)))
	  (and
	   (string=? "Arrow" (const-to-name (term-in-const-form-to-const op)))
	   (= 2 (length args))
	   (typealg-numeral? (car args))
	   (typealg-numeral? (cadr args)))))))

(define (type-to-typealg-numeral type)
  (if (not (arrow-form? type))
      (myerror "type-to-typealg-numeral" "arrow form expected" type))
  (let ((arg-type (arrow-form-to-arg-type type))
	(val-type (arrow-form-to-val-type type)))
    (if ;(equal? (py "nat=>term") type), that is
     (and (alg-form? arg-type)
	  (alg-form? val-type)
	  (string=? "nat" (alg-form-to-name arg-type))
	  (string=? "term" (alg-form-to-name val-type)))
     (make-term-in-const-form (constr-name-to-constr "Iota"))
     (mk-term-in-app-form
      (make-term-in-const-form (constr-name-to-constr "Arrow"))
      (type-to-typealg-numeral arg-type)
      (type-to-typealg-numeral val-type)))))

; Tests
; (typealg-numeral? (pt "Iota to rho"))
; (typealg-numeral? (pt "(Iota to rho)to Iota"))
; (typealg-numeral? (pt "(Iota to Iota)to Iota"))
; (type-to-string (typealg-numeral-to-type (pt "(Iota to Iota)")))
; (type-to-string (typealg-numeral-to-type (pt "(Iota to Iota)to Iota")))
; (pp (type-to-typealg-numeral (typealg-numeral-to-type (pt "(Iota to Iota)to Iota"))))
; _________________________________________________________


; b) Determination of the Type
; ----------------------------
; Definition: Typ
; ---------------
(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)))

; c) Checking Correctness
; -----------------------
; Definition: Cor
; ---------------
; Checks, if a term is correctly typed with respect to a given context
; (also if the context is long enough)

(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)))

; d) Type Judgement
; -----------------
; Definition: TypJ
; ----------------
; Checks if a term has a given type with respect to a given context
; (and if the term is correctly typed at all)

(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"))


; =======================
;  Section: Substitution
; =======================

; Definition: Up
; --------------
; Lifting of a term by 1 with the threshold as a parameter

(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)"))

; Lemma: "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.

; Definition: Seq
; ---------------
; list on natural numbers from n to (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:

; Lemma: "LhSeq"
; --------------
; Length of Seq

(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")

; Lemma: "ListProjSeq"
; -------------------
; k-th element of Seq

(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 "ListProjSeq")

; Lemma "UpSeq"
; -------------
; Effekt of Up 0 on Seq

(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")

; Declaration: ns, ms
; -------------------
(add-var-name "ns" "ms" (py "list nat"))

; Definition: NatMax
; ------------------
; Maximum of two natural numbers

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

; ________________________ INTERNAL ________________________
; Allows infix notation with "max"

(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"))


; Simple Facts about NatMax
; -------------------------
(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"))

; Definition: Free
; ----------------
; 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))))")))

; Definition: MaxFree
; -------------------
; As Free but for a whole list of terms

(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")

; Lemma: "UpFree"
; ---------------
; Effect of Up on free variables

(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")
(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")

; Lemma: "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")

; Lemma: "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)")))

; Lemma: "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")

; Definition: Sub (Substitutions)
; -------------------------------
(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))"))

; Lemma: "SubVarListProj"
; ----------------------
(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 "SubVarListProj")

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

; Lemma: "TermListProjE"
; ---------------------
(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 "TermListProjE")

; Lemma: "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 "SubVarListProj")
(simp "SubVarListProj")
(simp "ListProjAppendLt")
(simp "ListProjAppendLt")
(simp "ListProjMap")
(simp "ListProjSeq")
(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 "SubVarListProj")
(simp "SubVarListProj")
(simp "ListProjAppendGe")
(simp "ListProjAppendGe")
(simp "LhMap")
(simp "LhSeq")
(simp "ListProjMap")
(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 "TermListProjE")
(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

; Lemma: "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")

; Lemma: "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")
(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:

; Lemma: "UpSub"
; --------------
; We specialize UpSubGen to Zero

(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")

 ; Lemma: "UpSubList"
; ------------------
; We extend UpSub to lists

(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")

; Definition: Subcompose
; ----------------------
; 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)

; ________________________ INTERNAL ________________________
; Allows the infix notation with "circ" instead of "Subcompose"

(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")

; Lemma: "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 "SubVarListProj")
(simp "ListProjMap")
(ng)
(simp "SubVarListProj")
(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 "TermListProjE")
(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

; Lemma: "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 "SubVarListProj")
(simp "SubVarListProj")
(simp "ListProjAppendLt")
(simp "ListProjAppendLt")
(simp "ListProjMap")
(simp "ListProjSeq")
(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 "SubVarListProj")
(simp "SubVarListProj")
(simp "ListProjAppendGe")
(simp "ListProjAppendGe")
(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 "TermListProjE")
(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:

; Lemma: "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:

; Lemma: "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")

; Lemma: "SubSub" (Final goal)
; ----------------------------
; Subsequent substitution equals the substitution of the composition
; of the substitutions

(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")


; =======================================================
;  Section: Program Extraction from Normalization Proofs
; =======================================================

; Subsection: Omega
; =================

; Addition of type constants
; --------------------------
; In typ.scm

; addition of type constants generally allowed

(define (add-tconst-name . x)
  (if (null? x)
      (myerror "add-tconst-name: arguments expected")
      (do ((l x (cdr l)))
	  ((null? l))
	(let ((string (car l)))
	  (if (and (string? string) (not (string=? string "")))
	      (if (is-used? string '() 'type-constant)
		  *the-non-printing-object*
		  (begin
		    (set! TYPE-CONSTANTS
			  (append TYPE-CONSTANTS (list (list string))))
		    (add-token string 'tconst string)
		    (comment "ok, type constant " string " added")))
	      (myerror "add-tconst-name: string expected" string)))))) 

(define atc add-tconst-name)

(define (remove-tconst-name . x)
  (define (rtc1 tconst-name)
    (if (assoc tconst-name TYPE-CONSTANTS)
	(begin (do ((l TYPE-CONSTANTS (cdr l))
		    (res '() (let* ((info (car l))
				    (string (car info)))
			       (if (string=? string tconst-name)
				   res
				   (cons info res)))))
		   ((null? l) (set! TYPE-CONSTANTS (reverse res))))
	       (remove-token tconst-name)
	       (comment
		"ok, type vonstant " tconst-name " is removed"))
	(myerror "remove-type-constant: type constant expected" tconst-name)))
  (do ((l x (cdr l)))
      ((null? l) *the-non-printing-object*)
    (rtc1 (car l))))

(define rtc remove-tconst-name)

; Definition: OmegaIn
; -------------------
; In pconst.scm

; The treatment of constructors is to be extended to also cover
; constructors for sumtypes.

; Notice that we do not have dependent types.  Hence we need a
; numeral-string to be part of the name of a constructor.  Form
; e.g. "Arrow(Iota)(Iota)", which can be parsed.  So
; "OmegaInIota to Iota" would be a constructor name, of type
; ((nat=>term)=>(nat=>term))=>omega.

; Obsolete:
; Notice that we do not have dependent types.  Hence for parsing and
; display we need a numeral-string to be part of the name of a
; constructor.  Form e.g. "Arrow(Iota)(Iota)", which can be parsed.
; So "OmegaInArrow(Iota)(Iota)" would be a constructor name, of type
; ((nat=>term)=>(nat=>term))=>omega.

; nbe-reify and nbe-reflect are changed only in that the tag sumtype
; is treated exactly as alg.

(define (initial-substring? string1 string2)
  (and (<= (string-length string1) (string-length string2))
       (string=? string1 (substring string2 0 (string-length string1)))))

; (initial-substring? "ab" "abc")

(define (constr-name-to-inst-constructors name)
  (let ((info (assoc name CONSTRUCTORS)))
    (cond
     (info (cadr info))
     ((initial-substring? "OmegaIn" name)
      (let* ((typestring
	      (substring name (string-length "OmegaIn") (string-length name)))
	     (typealg-numeral (pt typestring))
	     (type (typealg-numeral-to-type typealg-numeral))
	     (del-constr 
	      (eval-once (lambda () (constr-name-to-constr name))))
	     (obj
	      (nbe-make-object
	       (mk-arrow type (py "omega"))
	       (lambda (obj1)
		 (nbe-make-object (py "omega")
				  (nbe-make-constr-value
				   name (list obj1) del-constr)))))
	     (constr (make-const obj name 'constr (mk-arrow type (py "omega"))
				 empty-subst 1 'const)))
	(list (list empty-subst constr))))
     (else
      (myerror "constr-name-to-inst-constructors: constructor name expected"
	       name)))))

(define (constr-name? string)
  (or (assoc string CONSTRUCTORS)
      (and
       (initial-substring? "OmegaIn" string)
       (typealg-numeral?
	(pt (substring
	     string (string-length "OmegaIn") (string-length string)))))))

; (constr-name? "OmegaInIota")
; (constr-name? "OmegaInArrow(Iota)(Iota)") 
; (constr-name? "OmegaInIota to Iota") 

(define (constr-name-and-tsubst-to-constr name tsubst)
  (let ((info (assoc name CONSTRUCTORS)))
    (cond
     (info
      (let ((info1 (assoc-wrt substitution-equal? tsubst (cadr info))))
	(if info1
	    (cadr info1)
	    (myerror "constr-name-and-tsubst-to-constr: unknown tsubst"
		     tsubst "for constructor" name))))
     ((initial-substring? "OmegaIn" name)
      (let* ((typestring
	      (substring name (string-length "OmegaIn") (string-length name)))
	     (typealg-numeral (pt typestring))
	     (type (typealg-numeral-to-type typealg-numeral))
	     (del-constr 
	      (eval-once (lambda () (constr-name-to-constr name))))
	     (obj
	      (nbe-make-object
	       (mk-arrow type (py "omega"))
	       (lambda objs
		 (nbe-make-object (py "omega")
				  (nbe-make-constr-value
				   name objs del-constr)))))
	     (constr (make-const obj name 'constr (mk-arrow type (py "omega"))
				 empty-subst 1 'const)))
	constr))
     (else
      (myerror "constr-name-and-tsubst-to-constr: constructor name expected"
	       name)))))

(define (constr-name-to-constr name . rest)
  (cond
   ((string? name)
    (let ((tsubst (if (null? rest) empty-subst (car rest))))
      (constr-name-and-tsubst-to-constr name tsubst)))
   ((and (pair? name) (string=? "Ex-Intro" (car name)))
    (let ((ex-formula
	   (if (pair? (cdr name))
	       (cadr name)
	       (myerror "constr-name-to-constr: name expected" name)))
	  (opt-pvar-to-tvar (cddr name)))
      (apply ex-formula-to-ex-intro-const (cons ex-formula opt-pvar-to-tvar))))
   ((and (pair? name) (string=? "Intro" (car name)))
    (let ((i (if (pair? (cdr name))
		 (cadr name)
		 (myerror "constr-name-to-constr: name expected" name)))
	  (idpc (if (pair? (cddr name))
			   (caddr name)
			   (myerror "constr-name-to-constr: name expected"
				    name)))
	  (opt-pvar-to-tvar (cdddr name)))
      (apply number-and-idpredconst-to-intro-const
	     (cons i (cons idpc opt-pvar-to-tvar)))))
   (else (myerror "constr-name-to-constr: name expected" name))))

; Definition: OmegaOut
; --------------------
; The treatment of program constants is to be extended to also allow
; the infinitely many program constants OmegaOut... with ... a string
; denoting a typealg-numeral.

(define (pconst-name-to-pconst name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (cond
     (info (cadr info))
     ((initial-substring? "OmegaOut" name)
      (let* ((typestring
	      (substring name (string-length "OmegaOut") (string-length name)))
	     (typealg-numeral (pt typestring))
	     (type (typealg-numeral-to-type typealg-numeral)))
	(type-to-omegaout-pconst type)))
     (else (myerror "pconst-name-to-pconst: pconst name expected"
		    name)))))

(define (type-to-omegaout-pconst type)
  (let* ((typealg-numeral (type-to-typealg-numeral type))
	 (string (term-to-string typealg-numeral))
	 (name (string-append "OmegaOut" string)))    
    (make-const
     (nbe-make-object
      (mk-arrow (py "omega") type) (type-to-omegaout-value type))
     name 'pconst (mk-arrow (py "omega") type) empty-subst 1 'const)))

(define (type-to-omegaout-value type)
  (lambda (obj)
    (let ((val (nbe-object-to-value obj)))
      (cond
       ((nbe-fam-value? val) ;reproduce
	(let* ((op-obj (nbe-reflect (nbe-term-to-termfam
				     (make-term-in-const-form
				      (type-to-omegaout-pconst type)))))
	       (op-val (nbe-object-to-value op-obj)))
	  (op-val obj)))
       ((nbe-constr-value? val)
	(let* ((name (nbe-constr-value-to-name val))
	       (typestring1
		(substring
		 name (string-length "OmegaIn") (string-length name)))
	       (typealg-numeral1 (pt typestring1))
	       (type1 (typealg-numeral-to-type typealg-numeral1)))
	  (if (equal? type1 type)
	      (car (nbe-constr-value-to-args val))
	      (nbe-reflect
	       (nbe-make-termfam
		type (lambda (k) (type-to-canonical-inhabitant type)))))))
       (else (myerror "type-to-omegaout-value" "unexpected object" obj))))))

(define (pconst-name-to-comprules name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (cond
     (info (caddr info))
     ((initial-substring? "OmegaOut" name) '())
     (else (myerror "pconst-name-to-comprules: pconst name expected"
		    name)))))

(define (pconst-name-to-rewrules name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (cond
     (info (cadddr info))
     ((initial-substring? "OmegaOut" name) '())
     (else (myerror "pconst-name-to-rewrules: pconst name expected"
		    name)))))

(define (pconst-name-to-inst-objs name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (cond
     (info (car (cddddr info)))
     ((initial-substring? "OmegaOut" name) '())
     (else (myerror "pconst-name-to-inst-objs: pconst name expected"
		    name)))))

(define (pconst-name-and-tsubst-to-object name tsubst)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (cond
     (info
      (let ((info1
	     (assoc-wrt substitution-equal? tsubst (car (cddddr info)))))
	(if info1
	    (cadr info1)
	    (let ((pconst (pconst-name-to-pconst name)))
	      (const-substitute pconst tsubst #f) ;updates PROGRAM-CONSTANTS
	      (pconst-name-and-tsubst-to-object name tsubst)))))
     ((initial-substring? "OmegaOut" name)
      (let* ((typestring
	      (substring name (string-length "OmegaOut") (string-length name)))
	     (typealg-numeral (pt typestring))
	     (type (typealg-numeral-to-type typealg-numeral)))
	(nbe-make-object
	 (mk-arrow (py "omega") type) (type-to-omegaout-value type))))
     (else (myerror "pconst-name-and-tsubst-to-object: pconst name expected"
		    name)))))

(define (pconst-name-to-external-code name)
  (let ((info (assoc name PROGRAM-CONSTANTS)))
    (cond
     (info (let ((info1 (cdr (cddddr info))))
	     (if (pair? info1)
		 (car info1)
		 #f)))
     ((initial-substring? "OmegaOut" name) #f)
     (else (myerror "pconst-name-to-external-code: pconst name expected"
		    name)))))

; Empty-Test
; ----------
; const-substitute now needs an initial test whether the type
; substitution is empty.

(define (const-substitute const tsubst update-of-program-constants-done?)
  (if
   (null? tsubst)
   const
   (let* ((obj-or-arity (const-to-object-or-arity const))
	  (name (const-to-name const))
	  (uninst-type (const-to-uninst-type const))
	  (orig-tsubst (const-to-tsubst const))
	  (t-deg (const-to-t-deg const))
	  (token-type (const-to-token-type const))
	  (type-info-or-repro-formulas
	   (const-to-type-info-or-repro-formulas const))
	  (composed-tsubst (compose-t-substitutions orig-tsubst tsubst))
	  (tvars (const-to-tvars const))
	  (restricted-tsubst
	   (restrict-substitution-to-args composed-tsubst tvars)))
     (case (const-to-kind const)
       ((constr)
	(if
	 (or (string=? "Ex-Intro" (const-to-name const))
	     (string=? "Intro" (const-to-name const)))		      
	 const
	;else form new-constr with restricted-subst.  If not yet done,
	;update CONSTRUCTORS, via computing for all simalgs and all of
	;their constructors the new object, type etc.  Return new-constr
	 (let* ((val-type (arrow-form-to-final-val-type uninst-type))
		(alg-name (alg-form-to-name val-type))
		(alg-names (alg-name-to-simalg-names alg-name))
		(alg-names-with-typed-constr-names
		 (map (lambda (x)
			(cons x (alg-name-to-typed-constr-names x)))
		      alg-names))
		(assoc-list (constr-name-to-inst-constructors name))
		(info (assoc-wrt substitution-equal?
				 restricted-tsubst assoc-list)))
	   (if
	    info
	    (cadr info) ;else update CONSTRUCTORS, return new-constr
	    (begin
	      (for-each ;of alg-names-with-typed-constr-names
	       (lambda (item)
		 (let ((typed-constr-names (cdr item)))
		   (for-each ;of typed-constr-names, update CONSTRUCTORS
		    (lambda (y)
		      (let* ((constr-name (car y))
			     (type (cadr y))
			     (token-type1
			      (if (null? (cddr y)) 'const (caddr y)))
			     (argtypes (arrow-form-to-arg-types type))
			     (arity (length argtypes))
			     (new-type
			      (type-substitute type restricted-tsubst))
			     (new-valtype
			      (arrow-form-to-final-val-type new-type))
			     (del-constr 
			      (eval-once (lambda ()
					   (constr-name-and-tsubst-to-constr
					    constr-name restricted-tsubst))))
			     (obj
			      (nbe-make-object
			       new-type
			       (if
				(zero? arity)
				(nbe-make-constr-value
				 constr-name '() del-constr)
				(nbe-curry
				 (lambda objs ;as many as argtypes
				   (nbe-make-object
				    new-valtype
				    (nbe-make-constr-value
				     constr-name objs del-constr)))
				 new-type
				 arity))))
			     (constr
			      (make-const obj constr-name 'constr type
					  restricted-tsubst 1 token-type1))
			     (constrs-exept-name
			      (do ((l CONSTRUCTORS (cdr l))
				   (res '() (if (string=? (caar l) constr-name)
						res
						(cons (car l) res))))
				  ((null? l) (reverse res))))
			     (prev-alist-for-name
			      (let ((info (assoc constr-name CONSTRUCTORS)))
				(if info
				    (cadr info)
				    (myerror
				     "const-substitute: constr expected"
				     constr-name))))
			     (new-alist-for-name
			      (cons (list restricted-tsubst constr)
				    prev-alist-for-name)))
			(set! CONSTRUCTORS
			      (cons (list constr-name new-alist-for-name)
				    constrs-exept-name))))
		    typed-constr-names)))
	       alg-names-with-typed-constr-names)
	      (constr-name-and-tsubst-to-constr name restricted-tsubst))))))
       ((pconst)
	;form new-pconst with restricted-tsubst.  If not yet done, update
	;PROGRAM-CONSTANTS with new object for restricted-tsubst,
	;return new-pconst.
	(let* ((new-pconst (make-const obj-or-arity
				       name
				       'pconst
				       uninst-type
				       restricted-tsubst
				       t-deg
				       token-type))
	       (assoc-list (pconst-name-to-inst-objs name))
	       (info (assoc-wrt substitution-equal?
				restricted-tsubst assoc-list)))
	  (if
	   (or update-of-program-constants-done? info)
	   new-pconst ;else update PROGRAM-CONSTANTS, then return new-pconst
	   (let* ((uninst-const (pconst-name-to-pconst name))
		  (comprules (pconst-name-to-comprules name))
		  (rewrules (pconst-name-to-rewrules name))
		  (external-code (pconst-name-to-external-code name))
		  (obj (if external-code
			   (nbe-pconst-and-tsubst-and-rules-to-object
			    const restricted-tsubst comprules rewrules
			    external-code)
			   (nbe-pconst-and-tsubst-and-rules-to-object
			    const restricted-tsubst comprules rewrules)))
		  (pconsts-exept-name
		   (do ((l PROGRAM-CONSTANTS (cdr l))
			(res '() (if (string=? (caar l) name)
				     res
				     (cons (car l) res))))
		       ((null? l) (reverse res))))
		  (prev-alist-for-name (pconst-name-to-inst-objs name))
		  (new-alist-for-name (cons (list restricted-tsubst obj)
					    prev-alist-for-name)))
	     (set! PROGRAM-CONSTANTS
		   (cons (list name uninst-const comprules rewrules
			       new-alist-for-name)
			 pconsts-exept-name))
	     new-pconst))))
       ((fixed-rules)
	(cond
	 ((string=? "Rec" name)
	  (let* ((param-types (rec-const-to-param-types const))
		 (f (length param-types))
		 (arg-types (arrow-form-to-arg-types uninst-type))
		 (step-types-and-alg-type (list-tail arg-types f))
		 (step-types
		  (list-head step-types-and-alg-type
			     (- (length step-types-and-alg-type) 1)))
		 (alg-type (car (last-pair arg-types)))
		 (alg-name (alg-form-to-name alg-type))
		 (uninst-arrow-types (rec-const-to-uninst-arrow-types const))
		 (alg-types (map arrow-form-to-arg-type uninst-arrow-types))
		 (alg-names (map alg-form-to-name alg-types))
		 (uninst-recop-types
		  (map (lambda (x)
			 (apply mk-arrow
				(append param-types step-types (list x))))
		       uninst-arrow-types))
		 (alg-names-with-uninst-recop-types
		  (map (lambda (x y) (list x y)) alg-names uninst-recop-types))
		 (simalg-names (alg-name-to-simalg-names alg-name))
		 (sorted-alg-names (list-transform-positive simalg-names
				     (lambda (x) (member x alg-names))))
		 (typed-constr-names
		  (apply append (map alg-name-to-typed-constr-names
				     sorted-alg-names)))
		 (constr-names (map car typed-constr-names))
		 (uninst-recop-type
		  (cadr (assoc alg-name alg-names-with-uninst-recop-types)))
		 (inst-recop-type (type-substitute uninst-recop-type
						   restricted-tsubst)))
	    (apply alg-name-etc-to-rec-const
		   (append (list alg-name uninst-recop-type restricted-tsubst
				 inst-recop-type f constr-names
				 alg-names-with-uninst-recop-types)
			   type-info-or-repro-formulas))))
	 ((string=? "Cases" name)
	  (let* ((param-types (cases-const-to-param-types const))
		 (f (length param-types))
		 (arg-types (arrow-form-to-arg-types uninst-type))
		 (val-type (arrow-form-to-final-val-type uninst-type))
		 (step-types-and-alg-type (list-tail arg-types f))
		 (step-types
		  (list-head step-types-and-alg-type
			     (- (length step-types-and-alg-type) 1)))
		 (alg-type (car (last-pair arg-types)))
		 (alg-name (alg-form-to-name alg-type))
		 (uninst-arrow-type (make-arrow alg-type val-type))
		 (uninst-casesop-type
		  (apply mk-arrow (append param-types step-types
					  (list uninst-arrow-type))))
		 (typed-constr-names (alg-name-to-typed-constr-names alg-name))
		 (constr-names (map car typed-constr-names)))
	    (apply
	     make-const
	     (append
	      (list (apply 
		     cases-at (append (list alg-name restricted-tsubst f
					    constr-names uninst-casesop-type)
				      type-info-or-repro-formulas))
		    "Cases" 'fixed-rules uninst-type restricted-tsubst
		    1 'const)
	      type-info-or-repro-formulas))))
	 ((string=? "=" name) const)
	 ((string=? "E" name) const)
	 ((string=? "Ex-Elim" name) const)
	 (else (myerror "const-substitute: fixed rule name expected"
			name))))
       (else (myerror "const-substitute: unknown kind"
		      (const-to-kind const)))))))
; Nbe
; ---
; In term.scm

(define (nbe-reify obj)
  (let ((type (nbe-object-to-type obj))
	(value (nbe-object-to-value obj)))
    (case (tag type)
      ((alg) 
       (cond
	((nbe-constr-value? value)
	 (let ((args (nbe-constr-value-to-args value)))
	   (nbe-make-termfam
	    type
	    (lambda (k)
	      (apply mk-term-in-app-form
		     (cons (make-term-in-const-form
			    (nbe-constr-value-to-constr value))
			   (map (lambda (obj)
				  (nbe-fam-apply (nbe-reify obj) k))
				args)))))))
	((nbe-fam-value? value) value)
	(else (myerror "nbe-reify: unexpected value" value
		       "for alg type" type))))
      ((tvar) (nbe-object-to-value obj))
      ((tconst)
       (if (or (string=? "existential" (tconst-to-name type))
	       (string=? "omega" (tconst-to-name type)))
	   (cond
	    ((nbe-constr-value? value)
	     (let ((args (nbe-constr-value-to-args value)))
	       (nbe-make-termfam
		type
		(lambda (k)
		  (apply mk-term-in-app-form
			 (cons (make-term-in-const-form
				(nbe-constr-value-to-constr value))
			       (map (lambda (obj)
				      (nbe-fam-apply (nbe-reify obj) k))
				    args)))))))
	    ((nbe-fam-value? value) value)
	    (else (myerror "nbe-reify: unexpected value for type"
			   (tconst-to-name type)
			   value)))
	   (nbe-object-to-value obj)))
      ((arrow)
       (let ((type1 (arrow-form-to-arg-type type)))
	 (nbe-make-termfam
	  type
	  (lambda (k)
	    (let ((var-k (make-var type1 k 1 (default-var-name type1))))
	      (make-term-in-abst-form
	       var-k (nbe-fam-apply
		      (nbe-reify
		       (nbe-object-apply
			obj
			(nbe-reflect (nbe-term-to-termfam
				      (make-term-in-var-form var-k)))))
		      (+ k 1))))))))
      ((star)
       (nbe-make-termfam
	type
	(lambda (k)
	  (make-term-in-pair-form
	   (nbe-fam-apply (nbe-reify (nbe-object-car obj)) k)
	   (nbe-fam-apply (nbe-reify (nbe-object-cdr obj)) k)))))
      (else (myerror "nbe-reify: type expected" type)))))

; Definition: omega
; -----------------
; The parser cannot handle these constructor names.  However, we want
; that at least "OmegaInIota" is known to the parser.

(add-tconst-name "omega")

(add-var-name "a" "b" "c" (py "omega"))
(add-var-name "as" "bs"  (py "list omega"))

(add-token "OmegaInIota"
	   'const (const-to-token-value (constr-name-to-constr "OmegaInIota")))

; We want to be able to overwrite the value of a pconst, assuming that
; there are no type parameters in pconst,

(define (overwrite-pconst name val)
  (let* ((uninst-pconst (pconst-name-to-pconst name))
	 (type (const-to-type uninst-pconst))
	 (obj (nbe-make-object type val))
	 (assoc-list (pconst-name-to-inst-objs name))
	 (external-code (pconst-name-to-external-code name))
	 (pconsts-exept-name
	  (do ((l PROGRAM-CONSTANTS (cdr l))
	       (res '() (if (string=? (caar l) name)
			    res
			    (cons (car l) res))))
	      ((null? l) (reverse res))))
	 (new-alist-for-name
	  (map (lambda (x) (if (equal? empty-subst (car x))
			       (list empty-subst obj) x))
	       assoc-list)))
    (set! PROGRAM-CONSTANTS
	  (cons (if external-code
		    (list name uninst-pconst '() '()
			  new-alist-for-name external-code)
		    (list name uninst-pconst '() '()
			  new-alist-for-name))
		pconsts-exept-name))))

; Definition: OmegaPart
; ---------------------
(add-program-constant "OmegaPart" (py "omega=>type") 1)

; OmegaPart applied to a constr-value returns the typealg-numeral.

(define (omegapart-value obj)
  (let ((val (nbe-object-to-value obj)))
    (cond
     ((nbe-fam-value? val) ;reproduce
      (nbe-reflect
       (nbe-make-termfam
	(make-alg "type")
	(lambda (k)
	  (mk-term-in-app-form
	   (make-term-in-const-form omegapart-pconst)
	   (nbe-fam-apply (nbe-reify obj) k))))))
     ((nbe-constr-value? val)
      (let* ((name (nbe-constr-value-to-name val))
	     (typestring
	      (substring name (string-length "OmegaIn") (string-length name)))
	     (typealg-numeral (pt typestring)))
	(nbe-reflect
	 (nbe-make-termfam
	  (make-alg "type")
	  (lambda (k) typealg-numeral)))))
     (else (myerror "omegapart-value" "unexpected object" obj)))))

(define omegapart-pconst
  (make-const
   (nbe-make-object (py "omega=>type") omegapart-value)
   "OmegaPart" 'pconst (py "omega=>type") empty-subst 1 'const))

; (pp (nt (pt "OmegaPart(OmegaInIota nat=>term)")))

(overwrite-pconst "OmegaPart" omegapart-value)

; (pp (nt (pt "OmegaPart(OmegaInIota nat=>term)")))

; Definition: Hat
; ---------------
(add-program-constant "Hat" (py "type=>type=>(omega=>omega)=>omega"))

; (add-program-constant "Hat" (py "type=>type=>(omega=>omega)=>omega") 1)

; For (hat-value type-obj1 type-obj2 fct-obj) check whether type-obj1
; and type-obj2 come from typealg-numerals rho and sig.  If so, form
; the object for In_{rho=>sig}(Out_sig o fct-term o In_rho)

(define (hat-value obj1)
  (nbe-make-object
   (py "type=>(omega=>omega)=>omega")
   (lambda (obj2)
     (nbe-make-object
      (py "(omega=>omega)=>omega")
      (lambda (fct-obj)
	(let* ((reified-obj1 (nbe-reify obj1))
	       (extracted-term1 (nbe-extract reified-obj1))
	       (reified-obj2 (nbe-reify obj2))
	       (extracted-term2 (nbe-extract reified-obj2))
	       (reified-fct-obj (nbe-reify fct-obj))
	       (extracted-fct-term (nbe-extract reified-fct-obj)))
	  (if ;the first two extracted terms are typealg-numerals
	   (and (typealg-numeral? extracted-term1)
		(typealg-numeral? extracted-term2))
	   (let* ((omegain-constr
		   (typealg-numeral-to-omegain-constr
		    (mk-term-in-app-form
		     (make-term-in-const-form (constr-name-to-constr "Arrow"))
		     extracted-term1 extracted-term2)))
		  (omegain-constr1
		   (typealg-numeral-to-omegain-constr extracted-term1))
		  (omegaout-pconst2
		   (type-to-omegaout-pconst
		    (typealg-numeral-to-type extracted-term2)))
		  (type1 (typealg-numeral-to-type extracted-term1))
		  (new-var (type-to-new-var type1))
		  (free (term-to-free extracted-fct-term))
		  (objs (map (lambda (x) (nbe-reflect
					  (nbe-term-to-termfam
					   (make-term-in-var-form x)))) free))
		  (bindings (nbe-make-bindings free objs))
		  (abst-term
		   (make-term-in-abst-form
		    new-var
		    (make-term-in-app-form
		     (make-term-in-const-form omegaout-pconst2)
		     (make-term-in-app-form
		      extracted-fct-term
		      (make-term-in-app-form
		       (make-term-in-const-form omegain-constr1)
		       (make-term-in-var-form new-var))))))
		  (final-term (make-term-in-app-form
			       (make-term-in-const-form omegain-constr)
			       abst-term)))
	     (nbe-term-to-object final-term bindings))
					;else reproduce
	   (let* ((obj (nbe-reflect (nbe-term-to-termfam
				     (make-term-in-const-form hat-pconst))))
		  (val (nbe-object-to-value obj)))
	     (apply (nbe-uncurry val 3) (list obj1 obj2 fct-obj))))))))))
		 
(define (typealg-numeral-to-omegain-constr typealg-numeral)
  (constr-name-to-constr (string-append
			  "OmegaIn" (term-to-string typealg-numeral))))

(define hat-pconst
  (let ((hat-type (py "type=>type=>(omega=>omega)=>omega")))
    (make-const (nbe-make-object hat-type hat-value)
		"Hat" 'pconst hat-type empty-subst 0 'const)))

; (define hat-pconst
;   (let ((hat-type (py "type=>type=>(omega=>omega)=>omega")))
;     (make-const (nbe-make-object hat-type hat-value)
; 		"Hat" 'pconst hat-type empty-subst 1 'const)))

(overwrite-pconst "Hat" hat-value)

; (pp (nt (pt "Hat")))

; Definition: Mod
; ---------------
(add-program-constant "Mod" (py "omega=>omega=>omega"))
; (add-program-constant "Mod" (py "omega=>omega=>omega") 1)

; For (mod-value obj) check whether obj is a constr-object of the form
; In_{rho=>sig} s.  If so, form the object for In_sig o s o Out_rho.
; Else reproduce.

(define (mod-value obj1)
  (let ((val1 (nbe-object-to-value obj1)))
    (if ;obj1 is a constr-object of the form In_{rho=>sig} arg
     (and (nbe-constr-value? val1)
	  (let* ((args (nbe-constr-value-to-args val1))
		 (arg (if (= 1 (length args))
			  (car args)
			  (myerror "mod-value" "unexpected object" obj1)))
		 (type (nbe-object-to-type arg)))
	    (not (equal? (py "nat=>term") type))))
     (let* ((constr (nbe-constr-value-to-constr val1))
	    (args (nbe-constr-value-to-args val1))
	    (type (nbe-object-to-type (car args)))
	    (type1 (arrow-form-to-arg-type type))
	    (type2 (arrow-form-to-val-type type))
	    (typealg-numeral1 (type-to-typealg-numeral type1))
	    (typealg-numeral2 (type-to-typealg-numeral type2))
	    (omegaout-pconst1
	     (type-to-omegaout-pconst
	      (typealg-numeral-to-type typealg-numeral1)))
	    (omegain-constr2
	     (typealg-numeral-to-omegain-constr typealg-numeral2))
	    (new-var (type-to-new-var (py "omega")))
	    (arg-term (nbe-extract (nbe-reify (car args))))
	    (free (term-to-free arg-term))
	    (objs (map (lambda (x) (nbe-reflect
				    (nbe-term-to-termfam
				     (make-term-in-var-form x)))) free))
	    (bindings (nbe-make-bindings free objs))
	    (abst-term
	     (make-term-in-abst-form
	      new-var
	      (make-term-in-app-form
	       (make-term-in-const-form omegain-constr2)
	       (make-term-in-app-form
		arg-term
		(make-term-in-app-form
		 (make-term-in-const-form omegaout-pconst1)
		 (make-term-in-var-form new-var)))))))
       (nbe-term-to-object abst-term bindings))
     					;else reproduce
     (let* ((obj (nbe-reflect (nbe-term-to-termfam
				(make-term-in-const-form mod-pconst))))
	    (val (nbe-object-to-value obj)))
       (val obj1)))))

(define mod-pconst
  (make-const
   (nbe-make-object (py "omega=>omega=>omega") mod-value)
   "Mod" 'pconst (py "omega=>omega=>omega") empty-subst 0 'const))

; (define mod-pconst
;   (make-const
;    (nbe-make-object (py "omega=>omega=>omega") mod-value)
;    "Mod" 'pconst (py "omega=>omega=>omega") empty-subst 1 'const))

(overwrite-pconst "Mod" mod-value)

; (pp (nt (nt (pt "Mod(Hat Iota Iota ([a]a))b"))))

; Definition: ModIota
; -------------------
(add-program-constant "ModIota" (py "omega=>nat=>term"))

; (add-program-constant "ModIota" (py "omega=>nat=>term") 1)

; (modiota-val obj1) checks whether obj1 is a constructor value of
; type Iota.  If so, return its argument.  Else reproduce.

(define (modiota-value obj1)
  (let ((val1 (nbe-object-to-value obj1)))
    (if ;constructor values, of type Iota
     (and (nbe-constr-value? val1)
	  (let* ((args (nbe-constr-value-to-args val1))
		 (arg (if (= 1 (length args))
			  (car args)
			  (myerror "mod-value" "unexpected object" obj1)))
		 (type (nbe-object-to-type arg)))
	    (equal? (py "nat=>term") type)))
     (car (nbe-constr-value-to-args val1))
					;else reproduce
     (let* ((obj (nbe-reflect (nbe-term-to-termfam
			       (make-term-in-const-form modiota-pconst))))
	    (val (nbe-object-to-value obj)))
       (val obj1)))))

(define modiota-pconst
  (make-const
   (nbe-make-object (py "omega=>nat=>term") modiota-value)
   "ModIota" 'pconst (py "omega=>nat=>term") empty-subst 0 'const))

; (define modiota-pconst
;   (make-const
;    (nbe-make-object (py "omega=>nat=>term") modiota-value)
;    "ModIota" 'pconst (py "omega=>nat=>term") empty-subst 1 'const))

(overwrite-pconst "ModIota" modiota-value)

; Definition: h
; -------------
(add-var-name "h" (py "omega=>omega"))
; (pp (nt (pt "Mod(Hat Iota Iota h)b")))

; 2005-08-14 Not needed:
; Lemma: "TotalOmegaPart"
; -----------------------
; (add-global-assumption
;  "TotalOmegaPart" (pf "all a^.E(OmegaPart a^) -> Total a^"))

; Lemma: "TypeHat"
; ----------------
(add-global-assumption
 "TypeHat" (pf "all rho,sig,h^ OmegaPart(Hat rho sig h^)=(rho to sig)"))

; (add-global-assumption
;  "TypeHat" (pf "all rho,sig,h OmegaPart(Hat rho sig h)=(rho to sig)"))

; 2005-08-14 Not needed:
; Lemma: "HatSuperTotal"
; ----------------------
; (set-goal (pf "all rho,sig,h^ Total(Hat rho sig h^)"))

; (assume "rho" "sig" "h^")
; (use "TotalOmegaPart")
; (simp "TypeHat")
; (use "Truth-Axiom")
; (save "HatSuperTotal")

; The following is not valid:
; (add-global-assumption
;  "EModIota" (pf "all a^,k.OmegaPart a^ =Iota -> E(ModIota a^k)"))

; (add-global-assumption
; "HatModIota" (pf "all a.OmegaPart a=Iota -> Equal(OmegaInIota(ModIota a))a"))

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

; The following is probably not needed (with N r^s^ -> E s^)
; (add-global-assumption
;  "ModHatIota" (pf "all g Equal(ModIota(OmegaInIota g))g"))
; (add-rewrite-rule (pt "ModIota(OmegaInIota g)k") (pt "g k"))

; (pp (nt (pt "ModIota(OmegaInIota g)")))

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

; Corrected 2005-07-01.  See below
; (add-global-assumption
;  "ModHat" (pf "all rho,sig,h.(all a.OmegaPart a=rho -> OmegaPart(h a)=sig) ->
;                              all a Equal(Mod(Hat rho sig h)a)(h a)"))
; (remove-global-assumption "ModHat")

; Definition: InOut
; -----------------
; Added 2005-05-29:
(add-program-constant "InOut" (py "type=>omega=>omega"))

; (add-program-constant "InOut" (py "type=>omega=>omega") 1)

; Lemma: "InOutId"
; ----------------
(add-global-assumption
 "InOutId" (pf "all sig,a^.OmegaPart a^ =sig -> Equal(InOut sig a^)a^"))

; Lemma: "InOutPart"
; ------------------
(add-global-assumption
 "InOutPart" (pf "all sig,a^ OmegaPart(InOut sig a^)=sig"))

; 2005-08-14 Not needed:
; Lemma: "InOutSuperTotal"
; ------------------------
; (set-goal (pf "all rho,a^ Total(InOut rho a^)"))
; (assume "rho" "a^")
; (use "TotalOmegaPart")
; (simp "InOutPart")
; (use "Truth-Axiom")
; (save "InOutSuperTotal")

; Lemma: "ModHat"
; ---------------
(add-global-assumption
 "ModHat" (pf "all rho,sig,h^,a^ Equal(Mod(Hat rho sig h^)a^)
                                      (InOut sig(h^(InOut rho a^)))"))

; Definition: "ExtCtx"
; --------------------
; We need totality assumptions on Mod and Hat

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

(add-computation-rule (pt "ExtCtx rhos k rho")
		      (pt "(Consn type)(Lh rhos-k)rho(Nil type)"))


; Subsection: Predicates
; ======================

; Definition: Fr, N, A, FN, FA
; ----------------------------
; Predicates for the proof

(add-predconst-name
 "Fr" (make-arity (py "list type") (py "type") (py "term") (py "nat")))

(add-predconst-name
 "N" (make-arity (py "list type") (py "type") (py "term") (py "term")))

(add-predconst-name
 "A" (make-arity (py "list type") (py "type") (py "term") (py "term")))

(add-predconst-name "Head" (make-arity (py "term") (py "term")))

(add-predconst-name
 "FN" (make-arity (py "list type") (py "type") (py "term")))
; to be defined by
; (pf "all k.Fr rhos rho r k -> ex s N rhos rho r s")

(add-predconst-name
 "FA" (make-arity (py "list type") (py "type") (py "term")))
; to be defined by
; (pf "all k.Fr rhos rho r k -> ex s A rhos rho r s")

; The definitions will be inductive:
; all t.WN r t -> EtaExp rhos rho t s -> N rhos rho r s

; AVar : all rho,k.TypJ rhos(Var k)rho -> A rhos rho(Var k)(Var k)
; AApp : all rho,sig,r,s,r1,s1.
;    A rhos(rho to sig)r s -> 
;    TypJ rhos r1 rho -> N rhos rho r1 s1 -> A rhos sig(r r1)(s s1)

; Head((Sub(Abs rho r)ss)s)(Sub r(s::ss))

; Definition: SCr
; ---------------
(add-predconst-name
 "SCr" (make-arity (py "list type") (py "type") (py "omega") (py "term")))

; Definition: SC
; --------------
(add-predconst-name
 "SC" (make-arity (py "list type") (py "type") (py "term")))

; Definition: SCrs
; ----------------
; SCr for a list of terms

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


; Subsection: Strong Computability
; ================================

; Definition: "SCrUnfoldOne", "SCrUnfoldTwo", "SCrIotaUnfold", "SCrIotaFold"
; --------------------------------------------------------------------------

(add-global-assumption
 "SCrUnfoldOne"
 (pf "all rhos,rho,a^,r.SCr rhos rho a^r -> TypJ rhos r rho"))

(add-global-assumption
 "SCrUnfoldTwo"
 (pf "all rhos,rho,a^,r.SCr rhos rho a^r -> OmegaPart a^ =rho"))

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

(add-global-assumption
 "SCrIotaFold"
 (pf "all rhos,a^,r.
       TypJ rhos r Iota -> OmegaPart a^ =Iota ->
       (all k.Fr rhos Iota r k -> N rhos Iota r(ModIota a^k)) ->
       SCr rhos Iota a^r"))

; Definition: "SCrUnfold", "SCrFold"
; ----------------------------------

(add-global-assumption
 "SCrUnfold"
 (pf "all rhos,rho,sig,a^,r.
       SCr rhos(rho to sig)a^r ->
       all sigs,b^,s.SCr(rhos:+:sigs)rho b^s ->
                     SCr(rhos:+:sigs)sig(Mod a^b^)(r s)"))

(add-global-assumption
 "SCrFold"
 (pf "all rhos,rho,sig,a^,r.
       TypJ rhos r(rho to sig) -> OmegaPart a^ =(rho to sig) ->
       (all sigs,b^,s.SCr(rhos:+:sigs)rho b^s ->
                      SCr(rhos:+:sigs)sig(Mod a^b^)(r s)) ->
       SCr rhos(rho to sig)a^r"))

; Definition: "SCrsDefNil", "SCrsDef", "SCrsLhOne", "SCrsLhTwo"
; -------------------------------------------------------------

(add-global-assumption
 "SCrsDefNil" (pf "all sigs SCrs sigs(Nil type)(Nil omega)(Nil term)"))

(add-global-assumption
 "SCrsDef"
 (pf "all sigs,rho,rhos,a^,as^,s,ss.
       SCr sigs rho a^s -> SCrs sigs rhos as^ss -> 
       SCrs sigs(rho::rhos)(a^ ::as^)(s::ss)"))

(add-global-assumption
 "SCrsLhOne"
 (pf "all sigs,rhos,as^,rs.SCrs sigs rhos as^rs -> Lh as^ =Lh rhos"))

(add-global-assumption
 "SCrsLhTwo" (pf "all sigs,rhos,as^,ss.SCrs sigs rhos as^ss -> Lh rhos=Lh ss"))


; Subsection: Axioms
; ==================
; The axioms for the proof

; Definition: "AxNStrict1", "AxNStrict2", "AVar", "AApp", "HDef"
; --------------------------------------------------------------

(add-global-assumption
 "AxNStrict1" (pf "all rhos,rho,r^,s^.N rhos rho r^s^ -> E r^"))

(add-global-assumption
 "AxNStrict2" (pf "all rhos,rho,r^,s^.N rhos rho r^s^ -> E s^"))

(add-global-assumption
 "AVar" (pf "all rhos,rho,k.TypJ rhos(Var k)rho -> A rhos rho(Var k)(Var k)"))

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

(add-global-assumption
 "HDef" (pf "all rho,r,s,ss Head((Sub(Abs rho r)ss)s)(Sub r(s::ss))"))

; Definition: Ax1 - Ax4
; ---------------------

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

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

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

; The following could be proved from "All-AllPartial" and "AxNStrict2"
; (add-global-assumption
;  "Ax3P" (pf "all rhos,rho,r,s,t^.
;               Head r s -> N rhos rho s t^ -> N rhos rho r t^"))

; However, we need here All-AllPartial without nc.  New names should be:
; Allnc-AllncPartial and All-AllPartial.  For the moment we take
; All-AllPartial-nonc

(define (finalg-to-all-allpartial-nonc-aconst finalg)
  (let* ((name (default-var-name finalg))
	 (var (make-var finalg -1 1 name))
	 (varpartial (make-var finalg -1 0 name))
	 (varterm (make-term-in-var-form var))
	 (varpartialterm (make-term-in-var-form varpartial))
	 (pvar (make-pvar (make-arity finalg) -1 0 ""))
	 (all-fla (mk-all var (make-predicate-formula pvar varterm)))
	 (allpartial-fla
	  (mk-all varpartial
		  (mk-imp (make-e varpartialterm)
			  (make-predicate-formula pvar varpartialterm))))
	 (formula-of-all-allpartial-nonc-aconst
	  (mk-imp all-fla allpartial-fla))
	 (name (string-append "All-AllPartial-nonc-" (type-to-string finalg))))
    (make-aconst
     name 'axiom formula-of-all-allpartial-nonc-aconst empty-subst)))

; (dp (make-proof-in-aconst-form (finalg-to-all-allpartial-nonc-aconst (py "term"))))

; "Ax3P" 
(set-goal (pf "all rhos,rho,r,s,t^.
               Head r s -> N rhos rho s t^ -> N rhos rho r t^"))
(assume "rhos" "rho" "r" "s")
(assert
 (pf "all t^.E t^ -> Head r s -> N rhos rho s t^ -> N rhos rho r t^"))
 (use-with
  (make-proof-in-aconst-form
   (finalg-to-all-allpartial-nonc-aconst (py "term")))
  (make-cterm (pv "t^") (pf "Head r s -> N rhos rho s t^ -> N rhos rho r t^"))
   "?")
 (use "Ax3")
(assume "H" "t^" "Head r s" "N rhos rho s t^")
(use "H")
(use "AxNStrict2" (pt "rhos") (pt "rho") (pt "s"))
(use "N rhos rho s t^")
(use "Head r s")
(use "N rhos rho s t^")
(save "Ax3P")

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

; Definition: "ACL", "IP", "UNC", "AC"
; ------------------------------------
(add-global-assumption
 "ACL" (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
;  "IP" (pf "(Pvar -> ex alpha^ (Pvar alpha)^alpha^) -> 
;            ex alpha^(Pvar -> (Pvar alpha)^alpha^)"))

; Produces error in extracted term of LemmaOne:
; make-term-in-app-form: unexpected terms.  Operator:
; (cIP omega nulltype)
; with argument type
; omega@@nulltype
; Argument:
; h2967(([b^]b^)b^2886)
; of type
; omega

(add-global-assumption
 "IP" (pf "(Pvar -> ex alpha^ (Pvar alpha)alpha^) -> 
           ex alpha^(Pvar -> (Pvar alpha)alpha^)"))

(add-global-assumption
 "UNC" (pf "allnc alpha1 ex alpha2^ (Pvar alpha1 alpha2)alpha1 alpha2^ ->
             ex alpha2^ allnc alpha1 (Pvar alpha1 alpha2)alpha1 alpha2^"))

(add-global-assumption
 "AC" (pf "all alpha1^ ex alpha2^ (Pvar alpha1 alpha2)alpha1^alpha2^ ->
            ex alpha1=>alpha2^ all alpha1^ 
             (Pvar alpha1 alpha2)alpha1^(alpha1=>alpha2^alpha1^)"))


; Subsection: Proof of former SC-Definition
; =========================================

; In the tactic scripts below we use the following assumption names:
; "SC r" for  "ex a^ SCr rhos rho a^r"
; "SN r" for  "all k.Fr rhos rho r k -> ex s N rhos rho r s"
; "SA r" for  "all k.Fr rhos rho r k -> ex s A rhos rho r s"
; "SCs rhos ss" for "all k ex a^ SCr sigs (rhos k) a^(ss k)"

; In order to be as close as possible to the informal proof, we first
; prove the expected "definition" of SC (trivial except for the use of
; AC in the folding lemmas):

; Lemma: "LemmaSCIotaUnfold" (allnc r.SC Iota r -> SN r)
; ------------------------------------------------------
(set-goal
 (pf "allnc rhos,r.ex a^ SCr rhos Iota a^r -> 
                   all k.Fr rhos Iota r k -> ex s N rhos Iota r s"))

(assume "rhos" "r" "SC r" "k" "Fr r k")
(by-assume-with "SC r" "a^" "SCr a^r")
(assert (pf "N rhos Iota r(ModIota a^k)"))
 (use "SCrIotaUnfold")
 (prop)
 (prop)
(assume "N r(ModIota a^k)")
(assert (pf "E(ModIota a^ k)"))
 (use "AxNStrict2" (pt "rhos") (pt "Iota") (pt "r"))
 (prop)
(assume "E(ModIota a^k)")
(use-with (make-proof-in-aconst-form
	   (finalg-to-expartial-ex-aconst (py "term")))
	  (make-cterm (pv "s") (pf "N rhos Iota r s"))
	  "?")
(ex-intro (pt "ModIota a^k"))
(split)
(prop)
(prop)
(save "LemmaSCIotaUnfold")

; Lemma: "LemmaSCIotaFold" (allnc r.SN r -> SC Iota r)
; ----------------------------------------------------
(set-goal
 (pf "allnc rhos,r.
       TypJ rhos r Iota ->
       (all k.Fr rhos Iota r k -> ex s N rhos Iota r s) ->
       ex a^ SCr rhos Iota a^r"))

(assume "rhos" "r" "TypJ rhos r Iota" "SN r")
(assert (pf "ex g all k.Fr rhos Iota r k -> N rhos Iota r(g k)"))
 (use-with "ACL"
	   (make-cterm (pv "k") (pf "Fr rhos Iota r k"))
	   (make-cterm (pv "k") (pv "s") (pf "N rhos Iota r s"))
	   "SN r")
(assume "SN r realizable")
(by-assume-with "SN r realizable" "g" "g realizes SN r")
(ex-intro (pt "OmegaInIota g"))
(use "SCrIotaFold")
(use "TypJ rhos r Iota")
(ng)
(use "Truth-Axiom")
(assume "k" "Fr r k")
(use "g realizes SN r")
(use "Fr r k")
(save "LemmaSCIotaFold")

; Lemma: "LemmaSCUnfold"
; ----------------------
; (allnc rho,sig,r. SC (rho to sig)r -> allnc s.SC rho s -> SC sig(r s)

(set-goal
 (pf "allnc rhos,rho,sig,r.ex a^ SCr rhos(rho to sig)a^r -> 
       allnc sigs,s.ex b^ SCr(rhos:+:sigs)rho b^s -> 
                    ex c^ SCr(rhos:+:sigs)sig c^(r s)"))

(assume "rhos" "rho" "sig" "r" "SC(rho to sig)r" "sigs" "s" "SC rho s")
(by-assume-with "SC(rho to sig)r" "a^" "SCr a(rho to sig)r")
(by-assume-with "SC rho s" "b^" "SCr b rho s")
(ex-intro (pt "Mod a^b^"))
(use "SCrUnfold" (pt "rho"))
(prop)
(prop)
(save "LemmaSCUnfold")

; Lemma: "LemmaSCFold"
; --------------------
; all rho,sig allnc r.(allnc s.SC rho s -> SC sig(r s)) -> SC(rho to sig)r

(set-goal (pf "allnc rhos all rho,sig allnc r.
                TypJ rhos r(rho to sig) ->
                (allnc sigs,s.ex b^ SCr(rhos:+:sigs)rho b^s -> 
                    ex c^ SCr(rhos:+:sigs)sig c^(r s)) -> 
                ex a^ SCr rhos(rho to sig)a^r"))

(assume "rhos" "rho" "sig" "r" "TypJ rhos r(rho to sig)"
	"allnc s.SC rho s -> SC sig(r s)")
(assert (pf "ex h^ all b^ allnc sigs,s.SCr(rhos:+:sigs)rho b^s -> 
              SCr(rhos:+:sigs)sig(h^b^)(r s)"))
 (use-with "AC" (py "omega") (py "omega")
	   (make-cterm (pv "b^") (pv "c^")
		       (pf "allnc sigs,s.SCr(rhos:+:sigs)rho b^s -> 
                            SCr(rhos:+:sigs)sig c^(r s)")) "?")
 (assume "b^")
 (use-with "UNC" (py "list type") (py "omega")
	   (make-cterm (pv "sigs") (pv "c^")
	    (pf "allnc s.SCr(rhos:+:sigs)rho b^s -> 
                         SCr(rhos:+:sigs)sig c^(r s)")) "?")
 (assume "sigs")
 (use-with "UNC" (py "term") (py "omega")
	   (make-cterm (pv "s") (pv "c^")
	    (pf "SCr(rhos:+:sigs)rho b^s -> 
                 SCr(rhos:+:sigs)sig c^(r s)")) "?")
 (assume "s")
 (inst-with-to "allnc s.SC rho s -> SC sig(r s)" (pt "sigs") "H1")
 (inst-with-to "H1" (pt "s") "H2")
 (use-with "IP" (py "omega")
	   (make-cterm (pf "SCr(rhos:+:sigs)rho b^s"))
	   (make-cterm (pv "c^") (pf "SCr(rhos:+:sigs)sig c^(r s)")) "?")
 (assume "H3")
 (use "H2")
 (ex-intro (pt "b^"))
 (use "H3")
(assume "ExHyp")
(by-assume-with "ExHyp" "h^" "ExHypInst")
(ex-intro (pt "Hat rho sig h^"))
(use "SCrFold")
(prop)
(use "TypeHat")
(assume "sigs" "b^" "s" "SCr b rho s")
(simp "ModHat")
(simp (pf "Equal(InOut rho b^)b^"))
(simp (pf "Equal(InOut sig(h^b^))(h^b^)"))
(use "ExHypInst")
(use "SCr b rho s")
(use "InOutId")
(use "SCrUnfoldTwo" (pt "rhos:+:sigs") (pt "r s"))
(use "ExHypInst")
(use "SCr b rho s")
(use "InOutId")
(use "SCrUnfoldTwo" (pt "rhos:+:sigs") (pt "s"))
(use "SCr b rho s")
(save "LemmaSCFold")


; Subsection: Main Proof
; ======================

; Lemma: "LemmaOne"
; -----------------
; First Lemma of the Tait proof

(set-goal
 (pf "all rho allnc rhos,r.TypJ rhos r rho ->
       (ex a^ SCr rhos rho a^r -> 
        all k.Fr rhos rho r k -> ex s N rhos rho r s) & 
       ((all k.Fr rhos rho r k -> ex s A rhos rho r s) -> 
        ex a^ SCr rhos rho a^r)"))

(ind)

; base Iota
(assume "rhos" "r" "TypH")
(split)

; goal: SC rhos Iota r -> FN rhos Iota r
(use "LemmaSCIotaUnfold")

; goal: SA r -> SCr IOta r
(assume "SA r")
(use "LemmaSCIotaFold")
(use "TypH")
(assume "k" "Fr r k")
(inst-with-to "SA r" (pt "k") "Fr r k" "ex s A r s")
(by-assume-with "ex s A r s" "s" "A r s")
(ex-intro (pt "s"))
(use "Ax2")
(use "A r s")
; base Iota proved

; step rho to sig
(assume "rho" "sig" "IHrho" "IHsig" "rhos" "r"  "TypH")
(split)

; goal: SC(rho to sig)r -> SN r
(assume "SC(rho to sig)r" "k" "Fr r k")
(cut (pf "ex s N(rhos:+:(ExtCtx rhos k rho))sig(r(Var k))s"))
(assume "ExHyp")
(by-assume-with "ExHyp" "s" "N(rhos:+:(ExtCtx rhos k rho))sig(r(Var k))s")
(ex-intro (pt "(Abs rho(Sub s((Var map(Seq 1 k)):+:(Var 0):)))"))
(use "Ax1")
(use "Fr r k")
(use "N(rhos:+:(ExtCtx rhos k rho))sig(r(Var k))s")
(assert (pf "ex a^ SCr(rhos:+:(ExtCtx rhos k rho))rho a^(Var k)"))
 (use "IHrho")
 (add-global-assumption
  "LemmaOneAux1"
  (pf "all rhos,rho,sig,r,k.
        Fr rhos(rho to sig)r k -> TypJ(rhos:+:ExtCtx rhos k rho)(Var k)rho"))
 (use "LemmaOneAux1" (pt "sig") (pt "r"))
 (use "Fr r k")
 (assume "k1" "Fr k k1")
 (ex-intro (pt "Var k"))
 (use "AVar")
 (use "LemmaOneAux1" (pt "sig") (pt "r"))
 (use "Fr r k")
(assume "SC rho(Var k)")
(use "IHsig" (pt "k+1"))
(add-global-assumption
 "LemmaOneAux2" (pf "all rhos,rho,sig,r,k.
                      TypJ rhos r(rho to sig) -> Fr rhos(rho to sig)r k -> 
                      TypJ(rhos:+:ExtCtx rhos k rho)(r(Var k))sig"))

(use "LemmaOneAux2" (pt "sig") (pt "r"))
(use "TypH")
(use "Fr r k")
(use "LemmaSCUnfold" (pt "rho"))
(use "SC(rho to sig)r")
(use "SC rho(Var k)")
(add-global-assumption
 "LemmaOneAux3"
 (pf "all rhos,rho,sig,r,k.
        Fr rhos(rho to sig)r k -> 
        Fr(rhos:+:ExtCtx rhos k rho)sig(r(Var k))(k+1)"))
(use "LemmaOneAux3")
(use "Fr r k")

; goal: SA r -> SC(rho to sig)r
(assume "SA r")
(use "LemmaSCFold")
(use "TypH")
(assume "sigs" "s" "SC rho s")
(use "IHsig")
(add-global-assumption
 "LemmaOneAux4"
 (pf "all rhos,sigs,rho,sig,r,s.
        TypJ rhos r(rho to sig) -> TypJ(rhos:+:sigs)s rho ->
        TypJ(rhos:+:sigs)(r s)sig"))
(use "LemmaOneAux4" (pt "rho"))
(use "TypH")
(by-assume-with "SC rho s" "b^" "H1")
(use "SCrUnfoldOne" (pt "b^"))
(use "H1")
(assume "k" "Fr(r s)k")
(cut (pf "ex t A rhos(rho to sig)r t"))
(assume "ExHyp1")
(by-assume-with "ExHyp1" "r1" "A rhos(rho to sig)r r1")

(cut (pf "ex s1 N(rhos:+:sigs)rho s s1"))
(assume "ExHyp2")
(by-assume-with "ExHyp2" "s1" "N rho s s1")
(ex-intro (pt "r1 s1"))
(use "AApp" (pt "rho"))
(add-global-assumption
 "AExtCtx"
 (pf "all rhos,sigs,rho,r,s.A rhos rho r s -> A(rhos:+:sigs)rho r s"))
(use "AExtCtx")
(use "A rhos(rho to sig)r r1")
(by-assume-with "SC rho s" "b^" "H1")
(use "SCrUnfoldOne" (pt "b^"))
(use "H1")
(use "N rho s s1")
(use "IHrho" (pt "k"))
(by-assume-with "SC rho s" "b^" "H2")
(use "SCrUnfoldOne" (pt "b^"))
(use "H2")
(use "SC rho s")
(add-global-assumption
 "LemmaOneAux5"
 (pf "all rhos,sigs,rho,sig,r,s,k.
      Fr(rhos:+:sigs)sig(r s)k -> TypJ(rhos:+:sigs)s rho ->
      Fr(rhos:+:sigs)rho s k"))
(use "LemmaOneAux5" (pt "sig") (pt "r"))
(use "Fr(r s)k")
(by-assume-with "SC rho s" "b^" "H1")
(use "SCrUnfoldOne" (pt "b^"))
(use "H1")
(use "SA r" (pt "k"))
(add-global-assumption
 "LemmaOneAux7"
 (pf "all rhos,sigs,rho,sig,r,s,k.
      Fr(rhos:+:sigs)sig(r s)k -> TypJ rhos r(rho to sig) ->
      Fr rhos(rho to sig)r k"))
(use "LemmaOneAux7" (pt "sigs") (pt "s"))
(use "Fr(r s)k")
(by-assume-with "SC rho s" "b^" "H1")
(use "TypH")
(save "LemmaOne")


; Lemma: "LemmaTwo" (allnc rho,r1,r.SC rho r1 -> Head r r1 -> SC rho r)
; ---------------------------------------------------------------------
; Second Lemma of the Tait proof

(set-goal (pf "allnc rho,rhos,r1,r.TypJ rhos r rho ->
                ex a^ SCr rhos rho a^r1 -> Head r r1 -> 
                ex a^ SCr rhos rho a^r"))

(cut (pf "all rho,rhos,r1,r,a^.TypJ rhos r rho ->
           SCr rhos rho a^r1 -> Head r r1 -> SCr rhos rho a^r"))
(assume "LemmaTwoR")
(assume "rho" "rhos" "r1" "r" "TypH" "SC rho r1" "Head r r1")
(by-assume-with "SC rho r1" "a^" "SCr a^ rho r1")
(ex-intro (pt "a^"))
(use "LemmaTwoR" (pt "r1"))
(use "TypH")
(use "SCr a^ rho r1")
(use "Head r r1")

; proof of LemmaTwoR:
(ind)

; Ground  type
(assume "rhos" "r1" "r" "a^" "TypH" "SCr Iota a^r1" "Head r r1")
(use "SCrIotaFold")
(use "TypH")
(use "SCrUnfoldTwo" (pt "rhos") (pt "r1"))
(use "SCr Iota a^r1")
(assume "k" "Fr r k")
(use "Ax3P" (pt "r1"))
(use "Head r r1")
(use "SCrIotaUnfold")
(use "SCr Iota a^r1")
(add-global-assumption
 "LemmaTwoAux1"
 (pf "all rhos,r,r1,k.Head r r1 -> Fr rhos Iota r k -> Fr rhos Iota r1 k"))
(use "LemmaTwoAux1" (pt "r"))
(use "Head r r1")
(use "Fr r k")

; Step type
(assume "rho" "sig" "IHrho" "IHsig" "rhos" "r1" "r" "a^" "TypH"
	"SCr(rho to sig)a^r1" "Head r r1")
(use "SCrFold")
(use "TypH")
(use "SCrUnfoldTwo" (pt "rhos") (pt "r1"))
(use "SCr(rho to sig)a^r1")
(assume "sigs" "b^" "s" "SCr rho b^s")
(use "IHsig" (pt "r1 s"))

; Lemma: "LemmaOneAux4"
; ---------------------
(add-global-assumption
 "LemmaOneAux4"
 (pf "all rhos,sigs,rho,sig,r,s.
        TypJ rhos r(rho to sig) -> TypJ(rhos:+:sigs)s rho ->
        TypJ(rhos:+:sigs)(r s)sig"))

(use "LemmaOneAux4" (pt "rho"))
(use "TypH")
(use "SCrUnfoldOne" (pt "b^"))
(use "SCr rho b^s")
(use "SCrUnfold" (pt "rho"))
(use "SCr(rho to sig)a^r1")
(use "SCr rho b^s")
(use "Ax4")
(use "Head r r1")
(save "LemmaTwo")

; Lemma: "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")

; For the variable case of LemmaThree

; Lemma: "LemmaThreeVar"
; ----------------------
(add-global-assumption
 "LemmaThreeVar"
 (pf "all sigs,rhos,as^,ss,k.
       SCrs sigs rhos as^ss -> k<Lh ss -> 
       SCr sigs(k thof rhos)(k thof as^)(k thof ss)"))

; Lemma: "LemmaThree"
; -------------------
; Third lemma of the Tait proof

(set-goal
 (pf "all r,rhos allnc sigs,rho,ss.
       TypJ rhos r rho -> ex as^ SCrs sigs rhos as^ss ->
                          ex a^ SCr sigs rho a^(Sub r ss)"))

(ind)

; Case variables
(assume "k" "rhos" "sigs" "rho" "ss" "TypH" "SCs rhos ss")
(add-global-assumption
 "TypJVarRef"
 (pf "all rhos,k,rho.TypJ rhos(Var k)rho -> rho=(k thof rhos)"))
(by-assume-with "SCs rhos ss" "as^" "SCrs sigs rhos as^ss")
(ex-intro (pt "k thof as^"))
(add-global-assumption
 "SCrCompat2"
 (pf "all rhos,rho^1,rho^2,a^,r.rho^1=rho^2 -> SCr rhos rho^1 a^ r ->
                                               SCr rhos rho^2 a^ r"))
(add-global-assumption
 "SCrCompat2Rev"
 (pf "all rhos,rho^1,rho^2,a^,r.rho^1=rho^2 -> SCr rhos rho^2 a^ r ->
                                               SCr rhos rho^1 a^ r"))
(use "SCrCompat2Rev" (pt "k thof rhos"))
(use "TypJVarRef")
(use "TypH")
(simp "SubVar")
(use "LemmaThreeVar")
(use "SCrs sigs rhos as^ss")
(simp "<-" "SCrsLhTwo" (pt "sigs") (pt "rhos") (pt "as^"))
(add-global-assumption
 "TypJVarLh"
 (pf "all rhos,rho,k.TypJ rhos(Var k)rho -> k<Lh rhos"))
(simp "TypJVarLh" (pt "rho"))
(prop)
(prop)
(prop)
(simp "<-" "SCrsLhTwo" (pt "sigs") (pt "rhos") (pt "as^"))
(simp "TypJVarLh" (pt "rho"))
(prop)
(prop)
(prop)

; Case App
(assume "r" "s" "IHr" "IHs" "rhos" "sigs" "sig" "ss" "TypH" "SCs rhos ss")
(ng #t)
(assert (pf "ex a^ SCr sigs(Typ rhos r)a^(Sub r ss)"))
 (use "IHr" (pt "rhos"))
 (add-global-assumption
  "TypJTyp"
  (pf "all rhos,r TypJ rhos r(Typ rhos r)"))
 (use "TypJTyp")
 (use "SCs rhos ss")
 (assume "ExH1")
(assert (pf "ex b^ SCr sigs(Typ rhos s)b^(Sub s ss)"))
 (use "IHs" (pt "rhos"))
 (use "TypJTyp")
 (use "SCs rhos ss")
 (assume "ExH2")
(by-assume-with "ExH1" "a^" "ExH1Inst")
(by-assume-with "ExH2" "b^" "ExH2Inst")
(ex-intro (pt "Mod a^b^"))
(simp (pf "Equal sigs(sigs:+:(Nil type))"))
(use "SCrUnfold" (pt "Typ rhos s"))
(assert (pf "Typ rhos r=(Typ rhos s to sig)"))
 (add-global-assumption
  "TypJApp"
  (pf "all rhos,sig,r,s.
        TypJ rhos(r s)sig -> Typ rhos r=(Typ rhos s to sig)"))
 (use "TypJApp")
 (use "TypH")
 (assume "EqH1")
(simp "<-" "EqH1")
(use "ExH1Inst")
(simp "ListAppendNil")
(use "ExH2Inst")
(use "Eq-Symm")
(use-with "ListAppendNil" (py "type") (pt "sigs"))

; Case Abs
(assume "rho" "r" "IHr" "rhos" "sigs" "tau" "ss" "TypH" "SCs rhos ss")
(simp (pf "tau=(rho to Typ(rho::rhos)r)"))
(use "LemmaSCFold")
(add-global-assumption
 "LemmaThreeAux1"
 (pf "all rhos,sigs,rho,tau,r,ss.TypJ rhos(Abs rho r)tau ->
      ex as^ SCrs sigs rhos as^ss -> 
      TypJ sigs(Sub(Abs rho r)ss)(rho to Typ(rho::rhos)r)"))
(use "LemmaThreeAux1" (pt "tau"))
(prop)
(prop)
(assume "taus" "s" "SC rho s")
(use "LemmaTwo" (pt "Sub r(s::ss)"))
(add-global-assumption
 "TypJAppIntro"
 (pf "all rhos,sigs,rho,sig,r,s.
       TypJ rhos r(rho to sig) -> TypJ(rhos:+:sigs)s rho -> 
       TypJ(rhos:+:sigs)(r s)sig"))
(use "TypJAppIntro" (pt "rho"))
(use "LemmaThreeAux1" (pt "tau"))
(prop)
(prop)
(by-assume-with "SC rho s" "b^" "SCHyp")
(use "SCrUnfoldOne" (pt "b^"))
(prop)
(use "IHr" (pt "rho::rhos"))
(add-global-assumption
 "TypJAbsElim"
 (pf "all rhos,rho,tau,r.
       TypJ rhos(Abs rho r)tau -> TypJ(rho::rhos)r(Typ(rho::rhos)r)"))
(use "TypJAbsElim" (pt "tau"))
(prop)
(by-assume-with "SCs rhos ss" "as^" "SCHyp2")
(by-assume-with "SC rho s" "b^" "SCHyp3")
(ex-intro (pt "b^ ::as^"))
(use "SCrsDef")
(prop)
(add-global-assumption
 "SCrsExtCtx"
 (pf "all rhos,sigs,taus,as^,ss.
       SCrs sigs rhos as^ss -> SCrs(sigs:+:taus)rhos as^ss"))
(use "SCrsExtCtx")
(prop)
(use "HDef")
(add-global-assumption
 "TypJAbsArrow"
 (pf "all rhos,rho,tau,r.
       TypJ rhos(Abs rho r)tau -> tau=(rho to Typ(rho::rhos)r)"))
(use "TypJAbsArrow")
(prop)
(save "LemmaThree")

; For the Normalization Theorem we need some auxiliaries:

; Lemma: "SCrsSeq"
; ----------------
(set-goal
 (pf "all rhos,sigs ex as^ 
       SCrs(sigs:+:rhos)rhos as^(Var map(Seq(Lh sigs)(Lh rhos)))"))

(ind)
(assume "sigs")
(ex-intro (pt "(Nil omega)"))
(simp "ListAppendNil")
(use "SCrsDefNil")
(assume "rho" "rhos" "IHrhos" "sigs")
(inst-with-to "IHrhos" (pt "sigs:+:rho:") "IH1")
(by-assume-with "IH1" "as^" "IHInst")
(assert (pf "ex a^ SCr(sigs:+:rho: :+:rhos) rho a^(Var(Lh sigs))"))
 (use "LemmaOne")
 (add-global-assumption
  "TypJVar"
  (pf "all sigs,rhos,rho TypJ(sigs:+:rho: :+:rhos)(Var Lh sigs)rho"))
 (use "TypJVar")
 (assume "k" "Fr(sigs:+:rho: :+:rhos)rho(Var Lh sigs)k")
 (ex-intro (pt "Var Lh sigs"))
 (use "AVar")
 (use "TypJVar")
(assume "ExHyp")
(by-assume-with "ExHyp" "a^" "ExHypInst")
(ex-intro (pt "a^ ::as^"))
(ng #t)
(simp (pf "(sigs:+:(rho::rhos))=(sigs:+:rho: :+:rhos)"))
(use "SCrsDef")
(use "ExHypInst")
(use "IHInst")
(add-global-assumption
 "ListAppendAssoc"
 (pf "all (list alpha)_1,(list alpha)_2,(list alpha)_3.
       Equal(((list alpha)_1:+:(list alpha)_2):+:(list alpha)_3)
            ((list alpha)_1:+:((list alpha)_2:+:(list alpha)_3))"))
(simp "ListAppendAssoc")
(use "Truth-Axiom")
(save "SCrsSeq")

; Lemma: "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 "ListProjMap")
(simp "ListProjSeq")
(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")

; Lemma: "NTheorem" (all rhos,r.Cor rhos r -> SN r)
; -------------------------------------------------
(set-goal (pf "all rhos,r.Cor rhos r -> ex s N rhos(Typ rhos r)r s"))

(assume "rhos" "r" "Cor rhos r")
(assert (pf "ex as^ SCrs rhos rhos as^(Var map Seq 0 Lh rhos)"))
 (use-with "SCrsSeq" (pt "rhos") (pt "(Nil type)"))
(assume "ExHyp")
(by-assume-with "ExHyp" "as^" "ExHypInst")
(assert (pf "ex a^ SCr rhos(Typ rhos r)a^(Sub r(Var map Seq 0 Lh rhos))"))
 (use "LemmaThree" (pt "rhos"))
 (use "TypJTyp")
 (ex-intro (pt "as^"))
 (prop)
(assume "ExHyp1")
(by-assume-with "ExHyp1" "a^" "ExHyp1Inst")
(use "LemmaOne" (pt "Lh rhos"))
(use "TypJTyp")
(assert (pf "SCr rhos (Typ rhos r) a^(Sub r(Var map Seq 0 Lh rhos))"))
 (use "ExHyp1Inst")
(simp "SubIds")
(assume "H1")
(ex-intro (pt "a^"))
(prop)
(prop)
(add-global-assumption
 "FrIntro1"
 (pf "all rhos,r.Cor rhos r -> Fr rhos(Typ rhos r)r(Lh rhos)"))
(use "FrIntro1")
(prop)
(save "NTheorem")


; ====================
;  Extracted programs
; ====================

(define SCLemmas
  '("LemmaSCIotaFold" "LemmaSCIotaUnfold" "LemmaSCFold" "LemmaSCUnfold"))
(define AllLemmas (append SCLemmas '("LemmaOne" "LemmaTwo" "LemmaThree")))

(define (theorem-name-to-expanded-proof name names)
  (expand-theorems (theorem-name-to-proof name)
                   (lambda (x) (member x names))))

(add-var-name "p" (py "(omega=>nat=>term)@@((nat=>term)=>omega)"))
(add-var-name "q" (py "list type=>list omega=>omega"))

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

; [rhos0,r1]
;  left(cLemmaOne(Typ rhos0 r1))
;  (cLemmaThree r1 rhos0(cSCrsSeq rhos0(Nil type)))
;  Lh rhos0

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

; (Rec type=>(omega=>nat=>term)@@((nat=>term)=>omega))
; (ModIota@([g3]OmegaInIota(cACL g3)))
; ([rho3,rho4,p5,p6]
;   ([a7,n8]
;     Abs rho3
;     (Sub(left p6(Mod a7(right p5([n9]Var n8)))(Succ n8))
;      ((Var map Seq 1 n8):+:(Var 0):)))@
;   ([g7]
;     Hat rho3 rho4
;     ((cAC omega omega)
;      ([a9]
;        (cUNC omega)
;        ((cUNC omega)((cIP omega)(right p6([n10]g7 n10(left p5 a9 n10)))))))))

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

; [a0]a0

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

; (Rec term=>list type=>list omega=>omega)([n3,rhos4](ListProj omega)n3)
; ([r3,r4,q5,q6,rhos7,as8]Mod(q5 rhos7 as8)(q6 rhos7 as8))
; ([rho3,r4,q5,rhos6,as7]
;   Hat rho3(Typ(rho3::rhos6)r4)
;   ((cAC omega omega)
;    ([a9](cUNC omega)((cUNC omega)((cIP omega)(q5(rho3::rhos6)(a9::as7)))))))
