; ***********************************************************
; ; Adapt path if necessary:
; (define path "~/minlog/examples/tait/diplomarbeit_schlenker/")

; ; Defines the function "pload" to load files 
; ; from the path defined above
; (define pload (lambda (x) (load (string-append path x))))

; ; Used Modules:
; (pload "./initiate.scm")
; (pload "./defsLamCalc.scm")
; (pload "./defsSubst.scm")
; (pload "./subst_Joachimski_SHORT.scm")
; (pload "./omega.scm")
; (pload "./defsNT.scm")
; (pload "./defsAxiomsSpecial.scm")
; (pload "./trivial.scm")
; (pload "./auxGlobal_SHORT.scm")
; (pload "./defsPred.scm")
;
; NOTICE: Uncomment modules only when file is run on its own
; ***********************************************************

; =======================================
;  Section: Global Proofs for the Axioms
; =======================================
; contains global lemmas and definitions for
; the proofs of the axioms

; Subsection: "Miscellaneous"
; ===========================

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

(add-computation-rule (pt "Typs rhos (Nil term)")
                      (pt "(Nil type)"))
(add-computation-rule (pt "Typs rhos (r::rs)")
                      (pt "(Typ rhos r)::(Typs rhos rs)"))

; Lemma: "CorTypJ"
; ---------------
(set-goal
 (pf "all rhos, r.Cor rhos r -> TypJ rhos r (Typ rhos r)"))

(assume "rhos" "r" 1)
(ng)
(use 1)
(save "CorTypJ")

; Lemma: "TypJFoldHead"
; ---------------------
(add-global-assumption "TypJFoldHead"
 (pf "all rhos,rho,r,s,rs.
 TypJ rhos (FoldApp r rs) rho ->
 TypJ rhos s (Typ rhos r) ->
 TypJ rhos (FoldApp s rs) rho"))

; Lemma: "TypJFoldHeadCor"
; ------------------------
(add-global-assumption "TypJFoldHeadCor"
 (pf "all rhos,rho,sig,r,s,rs.
 TypJ rhos (FoldApp (Abs rho r s) rs) sig ->
 Cor rhos (Abs rho r s)"))


; Subsection: "SR"
; ================
; "SR" stands for "Subject Reduction";
; needed for Ax8, BNTypJ and Ax1

; Subsubsection: Auxiliaries for "SR"
; :::::::::::::::::::::::::::::::::::

; Lemma: "SRAux1"
; ---------------
(set-goal (pf "all rhos,rho,sig,r,s.
 TypJ rhos ((Abs sig r) s) rho ->
 TypJ (sig::rhos) r rho & TypJ rhos s sig"))

(assume "rhos" "rho" "sig" "r" "s" 1)
(split)
(ng)
(split)
(use-with 1 'left 'left 'left)
(use-with 1 'right)

(ng)
(split)
(use-with 1 'left 'left 'right)
(simp-with 1 'left 'right)
(prop)
(save "SRAux1")

; Lemma: "SRAux2aAux"
; -------------------
(add-global-assumption "SRAux2aAux"
 (pf "all n, sigs,rhos,rho1.Lh sigs=n -> 
      n<Succ(Lh sigs+Lh rhos)and 
      Typ(sigs:+:(rho1::rhos))(Var n)=rho1"))

; Lemma: "SRAux2a"
; ----------------
(set-goal (pf "all rhos,sigs,n,k.
 Lh sigs = n ->
 TypJsSublist (sigs:+:rhos) 
  (Wrap k(Var map Seq n Lh rhos)) rhos"))

(ind)
(assume "sigs" "n" "k")
(assume 1)
(ng)
(prop)

(assume "rho1" "rhos" "IH")
(assume "sigs" "n" "k")
(assume 1)
(ng)
(split)

(use "SRAux2aAux")
(use 2)

(simp (pf "(sigs:+:(rho1::rhos) = 
 (sigs:+:rho1:):+:rhos) "))
(use "IH")
(ng)
(use 2)

(use "SRAux2aTrivial")
(save "SRAux2a")

; Lemma: "SRAux2b"
; ----------------
(set-goal (pf "all rhos,k.
 TypJsSublist rhos 
  (Wrap k (Var map Seq 0 Lh rhos)) rhos"))

(assume "rhos" "k")

(simp (pf "TypJsSublist rhos 
  (Wrap k(Var map Seq 0 Lh rhos))rhos = 
 TypJsSublist ((Nil type) :+: rhos)
  (Wrap k(Var map Seq 0 Lh rhos))rhos "))

(use "SRAux2a")
(ng)
(prop)
(simp (pf "(Nil type) :+: rhos = rhos"))
(ng)
(prop)
(use "NilAppend2")
(save "SRAux2b")

; Lemma: "SRAux2"
; ---------------
(set-goal (pf "all rhos,rho,sig,r,s,k.
 TypJ (sig::rhos) r rho -> TypJ rhos s sig ->
 TypJsSublist rhos 
  (Wrap k (s::(Var map (Seq 0 (Lh(rhos)))))) (sig::rhos)"))

(ng)
(assume "rhos" "rho" "sig" "r" "s" "k" 1 2)
(split)
(use 2)
(use "SRAux2b")
(save "SRAux2")

; Lemma: "SRAux3"
; ---------------
(set-goal (pf "all rhos,r,rho,s,sig,k.
 TypJ (sig::rhos) r rho ->
 TypJsSublist rhos (Wrap k (s::(Var map (Seq 0 (Lh(rhos))))))
  (sig::rhos) ->
 TypJ rhos (Sub r 
  (Wrap k (s::(Var map (Seq 0 (Lh(rhos))))))) 
   rho"))

(assume "rhos" "r" "rho" "s" "sig" "k")
(use "TypJSub")
(save "SRAux3")

; Lemma: "SRAux4"
; ---------------
(set-goal (pf "all rhos,r,rho,s,sig,k.
 TypJ rhos ((Abs sig r) s) rho ->
 TypJ rhos (Sub r 
  (Wrap k (s::(Var map (Seq 0 (Lh(rhos))))))) 
   rho"))

(assume "rhos" "r" "rho" "s" "sig" "k" 1)
(assert (pf "
 TypJ (sig::rhos) r rho ->
 TypJsSublist rhos (Wrap k (s::(Var map (Seq 0 (Lh(rhos))))))
  (sig::rhos) ->
 TypJ rhos (Sub r 
  (Wrap k (s::(Var map (Seq 0 (Lh(rhos))))))) 
   rho"))
(use "SRAux3")
(assume 1)
(use 2)
(assert (pf "TypJ rhos ((Abs sig r) s) rho ->
 TypJ (sig::rhos) r rho & TypJ rhos s sig"))
(use "SRAux1")
(assume 1)
(use 3)
(use 1)
(assert (pf "TypJ (sig::rhos) r rho -> TypJ rhos s sig ->
 TypJsSublist rhos (Wrap k (s::(Var map (Seq 0 (Lh(rhos)))))) 
 (sig::rhos)"))
(use "SRAux2")
(assume 1)
(use 3)
(assert (pf "TypJ rhos ((Abs sig r) s) rho ->
 TypJ (sig::rhos) r rho & TypJ rhos s sig"))
(use "SRAux1")
(assume 1)
(use 4)
(use 1)
(assert (pf "TypJ rhos ((Abs sig r) s) rho ->
 TypJ (sig::rhos) r rho & TypJ rhos s sig"))
(use "SRAux1")
(assume 1)
(use 4)
(use 1)
(save "SRAux4")

; Lemma: "SRAux5"
; ---------------
(add-global-assumption "SRAux5"
 (pf "all sigs,r,ss,k,l.
 Cor sigs r -> (l + Lh ss < Lh sigs -> F) ->
 Sub r (Wrap k (ss)) =
 Sub r (Wrap 0 ((ss) 
  :+:(Var map (Seq k l))))"))

; Lemma: "SRAux6"
; ---------------
(set-goal (pf "all sig,rhos,r,k,s. Cor (sig::rhos) r ->
 Sub r (Wrap k ((Var map (Seq 0 k)):+:(Lift s 0 k):)) =
 Sub r (Wrap 0 (((Var map (Seq 0 k)):+:(Lift s 0 k):)
  :+:(Var map (Seq k (Lh rhos)))))"))

(assume "sig" "rhos" "r" "k" "s" 1)
(use "SRAux5" (pt "(sig::rhos)") (pt "r")
 (pt "((Var map (Seq 0 k)):+:(Lift s 0 k):)") 
 (pt "Lh rhos") )
(use 1)
(ng)

(use "SRAux6Trivial")
(save "SRAux6")

; Lemma: "SRAux7"
; ---------------
(set-goal (pf "all sig,rhos,r,s.
 Cor (sig::rhos) r -> 
 Sub r (Wrap 0 (s:)) =
 Sub r (Wrap 0 (s::(Var map (Seq 0 (Lh (rhos))))))"))

(assume "sig" "rhos" "r" "s" 1)
(simp (pf "(s::Var map Seq 0 Lh rhos) =
           ((s:):+:(Var map Seq 0 Lh rhos))"))
(simp (pf "(s:) = (Var map (Seq 0 0)):+:(Lift s 0 0):"))
(use "SRAux6" (pt "sig"))
(use 1)
(ng)
(prop)
(use "SRAux7Trivial2")
(save "SRAux7")


; Subsubsection: Proof of "SR"
; ::::::::::::::::::::::::::::

; Lemma: "SR"
; -----------
(set-goal (pf "all rhos,rho,sig,r,s.
 TypJ rhos ((Abs sig r) s) rho -> 
 TypJ rhos (Sub r (Wrap 0 (s:))) rho"))

(assume "rhos" "rho" "sig" "r" "s" 1)
(simp "SRAux7" (pt "sig") (pt "rhos")) 
(use "SRAux4" (pt "sig"))
(use 1)
(ng)
(use-with 1 'left 'left 'left)
(save "SR")


; Subsection: "ExpTypJ"
; =====================

; Subsubsection: Auxiliaries for "ExpTypJ"
; ::::::::::::::::::::::::::::::::::::::::

; Lemma: "FoldTypJ"
; -----------------
; auxiliary for "ExpTypJLeft"

(add-global-assumption "FoldTypJ"
 (pf "all rhos,k,sigs,rho,rs.
 TypJ rhos (Var k) (---> sigs rho) ->
 TypJs rhos rs sigs ->
 TypJ rhos (FoldApp (Var k) rs) rho"))

; Definition: "OR"
; ----------------
(add-program-constant "OR" 
 (py "boole => boole => boole") 1)

(add-computation-rule (pt "OR F F ")
                      (pt "F"))
(add-computation-rule (pt "OR T F ")
                      (pt "T"))
(add-computation-rule (pt "OR F T ")
                      (pt "T"))
(add-computation-rule (pt "OR T T ")
                      (pt "T"))

; Definition: "Occurs"
; --------------------
(add-program-constant "Occurs" 
 (py "nat => term => boole") 1)

(add-computation-rule (pt "Occurs 0 (Var 0) ")
                      (pt "T"))
(add-computation-rule (pt "Occurs 0 (Var (Succ n)) ")
                      (pt "F"))
(add-computation-rule (pt "Occurs (Succ n) (Var 0) ")
                      (pt "F"))
(add-computation-rule (pt "Occurs n (r s) ")
 (pt "OR (Occurs n r) (Occurs n s)"))
(add-computation-rule (pt "Occurs n (Abs rho s) ")
                      (pt "Occurs (Succ n) s"))

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

(add-computation-rule (pt "Occurss n (Nil term)")
                      (pt "F"))
(add-computation-rule (pt "Occurss n (r::rs)")
 (pt "OR (Occurs n r) (Occurss n rs)"))

; Lemma: "OccursFold"
; -------------------
; auxiliary for "ExpOccurs"

(add-global-assumption "OccursFold"
 (pf "all n,rs,ss,k.
 Occurss n rs = Occurss n ss ->
 Occurs n (FoldApp(Var k)rs) = 
 Occurs n (FoldApp(Var k)ss)"))

; Lemma: "EtaOccurs"
; ------------------
; auxiliary for "ExpOccurs"

(add-global-assumption "EtaOccurs"
 (pf "all n,r,rho.
 Occurs n (Eta rho r) = Occurs n r"))

; Lemma: "OccursABS"
; ------------------
; auxiliary for "ExpOccurs"

(add-global-assumption "OccursABS"
 (pf "all r,s.
 all k (Occurs k r = Occurs k s) ->
 all n,m,rho.
 Occurs n (ABS m rho r) = 
 Occurs n (ABS m rho s)"))

; Lemma: "OccurssAux"
; -------------------
; auxiliary for "ExpOccurs"

(add-global-assumption "OccurssAux"
 (pf "all k,r,s,rs,ss.
 Occurs k r = Occurs k s ->
 Occurss k rs = Occurss k ss ->
 Occurss k (r::rs) = 
 Occurss k (s::ss)"))

; Lemma: "ExpOccurs"
; ------------------
; auxiliary for "ExpTypJRight"

(set-goal (pf "all rhos,rho,r,s.
 Exp rhos rho r s -> 
 all k. Occurs k r = Occurs k s"))

(assume "rhos" "rho" "r" "s")
(elim (pf "Exps rhos sigs rs ss -> 
 all k. Occurss k rs = Occurss k ss"))

(assume "rhos2" "sigs" "rs" "ss" 
 "k" "t" "rho2")
(assume 1 2 3 4)

(assume "n")
(simp 3)

(simp (pf "
 Occurs n(Eta rho2(FoldApp(Var k)ss)) =
 Occurs n (FoldApp(Var k)ss)"))
(use "OccursFold")
(use 4)
(use "EtaOccurs")

; Case 2
(assume "rhos1" "rhos2" "sigs" "taus"
 "rho2" "sig" "r2" "s2" "k")

(assume 1 2 3 4)
(assume "n")
(use "OccursABS")
(use 4)

; Case 3
(assume "rhos2" "k")
(ng)
(prop)

; Case 4
(assume "rhos2" "sigs" "r2" "s2"
 "rs" "ss")
(assume 1 2 3 4)
(assume "k")
(use "OccurssAux")
(use 3)
(use 4)
(save "ExpOccurs")

; Lemma: "EtaTypJ2"
; -----------------
; auxiliary for "ExpTypJRight"

(add-global-assumption "EtaTypJ2"
 (pf "all rhos,rho,r.
 TypJ rhos r rho ->
 TypJ rhos (Eta rho r) rho"))

; Lemma: "OccursAux"
; ------------------
; auxiliary for "ExpTypJRight"

(add-global-assumption "OccursAux"
 (pf "all rhos1,rhos2,sigs,rho,sig,r,s,k.
 TypJ (rhos1:+:rhos2) r sig ->
 TypJ (rhos1:+:rhos2) s sig ->
 TypJ ((rhos1:+:rhos2):+:sigs) (Var k) rho ->
 Occurs k r = Occurs k s ->
 TypJ (rhos1) (ABS k rho r) (rho to sig) ->
 TypJ (rhos1) (ABS k rho s) (rho to sig)"))


; Subsubsection: Proof of "ExpTypJ"
; :::::::::::::::::::::::::::::::::
; contains "ExpTypJLeft" "ExpTypJRight" and
; "ExpTypJ"

; Lemma: "ExpTypJLeft"
; --------------------
(set-goal (pf "all rhos,rho,r,s.
 Exp rhos rho r s -> 
 TypJ rhos r rho"))

(assume "rhos" "rho" "r" "s")
(elim (pf "Exps rhos sigs rs ss ->
 TypJs rhos rs sigs"))

; Case 1
(assume "rhos2" "sigs" "rs" "ss" 
 "k" "t" "rho2")
(assume 1 2 3 4)

(use "FoldTypJ" (pt "sigs"))
(use 1)
(use 4)

; Case 2
(assume "rhos1" "rhos2" "sigs" "taus"
 "rho2" "sig" "r2" "s2" "k")

(assume 1 2 3 4)
(use "TypJExtCtx")
(use 3)

; Case 3
(assume "rhos2")
(ng)
(prop)

; Case 4
(assume "rhos2" "sigs2" "r2" "s2" 
 "rs2" "ss2")
(assume 1 2 3 4)
(ng)
(split)
(use 3)
(use 4)
(save "ExpTypJLeft")

; Lemma: "ExpTypJRight"
; --------------------
(set-goal (pf "all rhos,rho,r,s.
 Exp rhos rho r s -> 
 TypJ rhos s rho"))

(assume "rhos" "rho" "r" "s")
(elim (pf "Exps rhos sigs rs ss ->
 TypJs rhos ss sigs"))

; Case 1
(assume "rhos2" "sigs" "rs" "ss" 
 "k" "t" "rho2")
(assume 1 2 3 4)

(simp 3)
(use "EtaTypJ2")
(use "FoldTypJ" (pt "sigs"))
(use 1)
(use 4)

; Case 2
(assume "rhos1" "rhos2" "sigs" "taus"
 "rho2" "sig" "r2" "s2" "k")

(assume 1 2 3 4)
(use "TypJExtCtx")
(use "OccursAux" (pt "rhos2") (pt "sigs")
 (pt "r2"))
(use "ExpTypJLeft" (pt "s2"))
(use 2)
(use 4)
(use 1)

(use "ExpOccurs" (pt "(rhos1:+:rhos2)") 
 (pt "sig"))
(use 2)
(use 3)

; Case 3
(assume "rhos2")
(ng)
(prop)

; Case 4
(assume "rhos2" "sigs2" "r2" "s2" 
 "rs2" "ss2")
(assume 1 2 3 4)
(ng)
(split)
(use 3)
(use 4)
(save "ExpTypJRight")

; Lemma: "ExpTypJ"
; ----------------
(set-goal (pf "all rhos,rho,r,s.
 Exp rhos rho r s -> 
 TypJ rhos r rho & TypJ rhos s rho"))

(assume "rhos" "rho" "r" "s")
(assume 1)
(split)
(use "ExpTypJLeft" (pt "s"))
(use 1)
(use "ExpTypJRight" (pt "r"))
(use 1)
(save "ExpTypJ")


; Subsection: "BNTypJ"
; ====================

; Subsubsection: Auxiliaries for "BNTypJ"
; :::::::::::::::::::::::::::::::::::::::

; Lemma: "BNTypJAux1"
; -------------------
(add-global-assumption "BNTypJAux1"
 (pf "all rhos,sigs,rho,rs,n.
 TypJ rhos (Var n) (---> sigs rho) ->
 TypJs rhos rs sigs ->
 TypJ rhos (FoldApp(Var n)rs) rho"))

; Lemma: "BNTypJAux2"
; -------------------
(add-global-assumption "BNTypJAux2"
 (pf "all rhos,rho,rs,n.
 TypJ rhos (FoldApp(Var n)rs) rho ->
 TypJ rhos (Var n) 
  (---> (Typs rhos rs) rho) &
 TypJs rhos rs (Typs rhos rs)"))

; Lemma: "BNTypJAux3"
; -------------------
(add-global-assumption "BNTypJAux3"
 (pf "all rhos,rho,sig,r.
 TypJ rhos (Abs rho r) (rho to sig) ->
 TypJ (rho::rhos) r sig"))

; Lemma: "BNTypJAux4"
; -------------------
(add-global-assumption "BNTypJAux4"
 (pf "all rhos,rho,sig,r.
 TypJ (rho::rhos) r sig -> 
 TypJ rhos (Abs rho r) (rho to sig)"))

; Lemma: "BNTypJAux5"
; -------------------
(add-global-assumption "BNTypJAux5"
 (pf "all rhos3,rho2,r2,sig1,sig2.
 TypJ rhos3(Abs rho2 r2)(sig1 to sig2) ->
 rho2 = sig1"))


; Subsubsection: Proof of "BNTypJ"
; ::::::::::::::::::::::::::::::::

; Lemma: "BNTypJ"
; ---------------
(set-goal (pf "all r,s.
 BN r s -> 
 all rhos,rho.TypJ rhos r rho ->
 TypJ rhos s rho"))

(assume "r" "s")
(elim (pf "BNs rs ss -> 
 all rhos.
 TypJs rhos rs (Typs rhos rs) ->
 TypJs rhos ss (Typs rhos rs)"))

; Case 0
(assume "n" "rs" "ss")
(assume 1 2)
(assume "rhos" "rho")
(assume 1)

(assert (pf "
 TypJs rhos rs (Typs rhos rs)"))

(use "BNTypJAux2" (pt "rho") (pt "n"))
(use 3)

(assume 1)

(assert (pf "
 TypJ rhos (Var n) 
  (---> (Typs rhos rs) rho) &
 TypJs rhos rs  (Typs rhos rs)"))

(use "BNTypJAux2")
(use 3)
(assume 1)
(assert (pf "
 TypJs rhos ss(Typs rhos rs)"))
(use 2)
(use 4 'right)
(assume 1)

(use "BNTypJAux1" (pt "(Typs rhos rs)"))
(use 5 'left)
(use 6)

; Case 1
(assume "rho2" "r2" "s2")
(assume 1 2)
(assume "rhos3" "rho3")
(assume 1)

(cut (pf "TypJ rhos3(Abs rho2 r2)rho3"))
(cases (pt "rho3"))
(assume 1 2)
(ng 5)
(prop)

; Case 2
(assume "sig1" "sig2")
(assume 1 2)

(assert (pf "rho2 = sig1"))
(use "BNTypJAux5" (pt "rhos3") (pt "r2")
 (pt "sig2"))
(use 5)
(assume 1)
(simp "<-" 6)

(use "BNTypJAux4")
(use 2)
(use "BNTypJAux3")
(simp (pf "(rho2 to sig2) = (sig1 to sig2)")) 
(use 5)

(simp 6)
(ng)
(prop)
(use 3)

; Case 3
(assume "rho2" "r2" "s2" "t2" "rs2")
(assume 1 2)
(assume "rhos3" "rho3")
(assume 1)
(use 2)

(assert (pf "TypJ rhos3 
  (FoldApp((Abs rho2 r2) s2) rs2) rho3"))
(ng)
(use 3)
(assume 1)

(use "TypJFoldHead" (pt "(Abs rho2 r2) s2"))
(use 4)

(use "SR" (pt "rho2"))
(use "CorTypJ")
(use "TypJFoldHeadCor" (pt"rho3")(pt "rs2"))
(use 4)

; Residual Cases
(assume "rhos")
(prop)

(assume "r2" "s2" "rs" "ss")
(assume 1 2 3 4)
(assume "rhos")
(assume 1)
(ng)

(split)
;(split)
(inst-with 3 (pt "rhos") 
 (pt "Typ rhos r2"))
(use 6)
(split)
(use-with 5 'left)
(ng)
(prop)

(use 4)
(use-with 5 'right)
(save "BNTypJ")


; Subsection: "NTypJ"
; ===================
; not used explicitly, but for "N" to be
; a proper definition the formula
; "TypJ rhos r rho -> N rhos rho r s -> TypJ rhos s rho"
; is implicitly required.
;
; Our Definition of "N" has the property
; that the type judgements follow directly from "N".
; Hence N rhos rho r s means exactly that 
; "s" is the long Normalform of "r" 
; in the given context with the given type

; Lemma: "NIndTypJLeft"
; ---------------------
(set-goal
 (pf "all rhos,rho,r,s.
 NInd rhos rho r s -> TypJ rhos r rho"))

(assume "rhos" "rho" "r" "s")
(elim)

(assume "rhos2" "rho2" "r2" "s2" "t2")
(assume 1 2 3)
(use 1)
(save "NIndTypJLeft")

; Lemma: "NIndTypJRight"
; ----------------------
(set-goal
 (pf "all rhos,rho,r,s.
 NInd rhos rho r s -> TypJ rhos s rho"))

(assume "rhos" "rho" "r" "s")
(elim)

(assume "rhos2" "rho2" "r2" "s2" "t2")
(assume 1 2 3)
(use "ExpTypJRight" (pt "t2"))
(use 3)
(save "NIndTypJRight")

; Lemma: "NIndTyp"
; ----------------
(set-goal
 (pf "all rhos,rho,r,s.
 NInd rhos rho r s -> 
 TypJ rhos r rho & TypJ rhos s rho"))

(assume "rhos" "rho" "r" "s")
(assume 1)
(split)
(use "NIndTypJLeft" (pt "s"))
(use 1)
(use "NIndTypJRight" (pt "r"))
(use 1)
(save "NIndTypJ")

; Lemma: "NTypJ"
; --------------
(set-goal
 (pf "all rhos,rho,r,s.
 N rhos rho r s -> 
 TypJ rhos r rho & TypJ rhos s rho"))

(assume "rhos" "rho" "r" "s")
(assume 1)

(assert (pf "NInd rhos rho r s"))
(use "NDef")
(use 1)
(use "NIndTypJ")
(save "NTypJ")
