; ***********************************************************
; ; 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")
;
; NOTICE: Uncomment modules only when file is run on its own
; ***********************************************************


; ==============================
;  Section: Substitution Lemmas
; ==============================
; Substitution in Joachimski style

; Lemma: "LtSuccCases"
; --------------------
; later used induction scheme

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


; Definition: "Subcompose"
; ------------------------
; Composition on substitutions

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

; ________________________ 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 "Sublist")
 (lambda (x)
   (let ((op (term-in-app-form-to-final-op x))
	 (args (term-in-app-form-to-args x)))
     (if (and (term-in-const-form? op)
	      (string=? "Subcompose"
			(const-to-name 
                         (term-in-const-form-to-const op)))
	      (= 2 (length args)))
	 (list 'mul-op "circ"
	       (term-to-token-tree (car args))
	       (term-to-token-tree (cadr args)))
	 #f))))
; _________________________________________________________


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

; Lemma: "LiftId"
; --------------
; lifting with value 0 is identity

(set-goal (pf "all r,k.Lift r k 0=r"))

(ind)
(assume "n" "k")
(ng)
(use "Truth-Axiom")

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

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

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

; Lemma: "LiftTwiceMod"
; ---------------------
; lifting with k and then with k1 is the same as lifting
; with (k+k1) at one step

(set-goal (pf "all r,l,k,k1.Lift(Lift r l k)l k1=Lift r l(k+k1)"))

(ind)
(assume "n" "l" "k" "k1")
(cases (pt "n<l"))
(assume "n<l")
(ng)
(simp "n<l")
(ng)
(simp "n<l")
(use "Truth-Axiom")

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

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

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

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


; Lemma: "LiftTwice"
; ------------------
; Joachimski (1)

(set-goal (pf "all r,l,k,k1.Lift(Lift r l k)(k+l)k1=
                            Lift r l(k+k1)"))

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

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

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

; Case Abs r
(assume "rho" "r" "IHr" "l" "k" "k1")
(ng)
(use-with "IHr" (pt "Succ l") (pt "k") (pt "k1"))
(save "LiftTwice")

; Lemma: "SubliftId"
; ------------------
; lifting of a substitution list with value 0 is identity

(set-goal (pf "all theta.Sublift theta 0=theta"))

(ind)
(assume "k")
(use "Truth-Axiom")
(assume "r" "theta" "IHtheta")
(ng)
(use "IHtheta")
(save "SubliftId")

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

; Lemma: "SubliftTwice"
; ---------------------
; lifting with n and then with m is the same as lifting
; with (m+n) at one step

(set-goal (pf "all theta,n,m.Sublift(Sublift theta n)m=
                             Sublift theta(n+m)"))

(ind)
(assume "k" "n" "m")
(ng)
(use "Truth-Axiom")
(assume "r" "theta" "IHtheta" "n" "m")
(ng)
(use "IHtheta")
(save "SubliftTwice")


; Definition: "Spare"
; -------------------
; adds 0 1 ... (m-1) to a substitution list

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

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

; Lemma: "SubVarSpare"
; --------------------
(set-goal (pf "all m,k,theta.Sub(Var(k+m))(Spare m theta)=
                             Sub(Var k)theta"))

(ind)
(assume "k" "theta")
(use "Truth-Axiom")
(assume "m" "IHm" "k" "theta")
(ng)
(cut (pf "Succ(k+m)=Succ k+m"))
(assume "H1")
(simp "H1")
(use-with "IHm" (pt "Succ k") (pt "Dot(Var m)theta"))
(use "Truth-Axiom")
(save "SubVarSpare")

; Lemma: "SubVarSpareLt"
; ----------------------
(set-goal (pf "all m,k,theta.k<m -> 
               Sub(Var k)(Spare m theta)=Var k"))

(ind)
(assume "k" "theta" "Absurd")
(use "Efq")
(use "Absurd")
(assume "m" "IHm" "k" "theta" "k<m+1")
(use "LtSuccCases" (pt "m") (pt "k"))
(use "k<m+1")
(ng)
(use "IHm")
(assume "k=m")
(simp "k=m")
(ng)
(use-with "SubVarSpare" (pt "m") (pt "0") (pt "Dot(Var m)theta"))
(save "SubVarSpareLt")

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

; Lemma: "LiftEq"
; ---------------
; Joachimski's (2)

(set-goal (pf "all r,n,m.Lift r m n=Sub r(Spare m(Up(m+n)))"))

(ind)
(assume "k" "n" "m")
(ng)

; Case: k<m
(cases (pt "k<m"))
(assume "k<m")
(ng)
(inst-with-to "SubVarSpareLt" (pt "m") (pt "k") 
 (pt "Up(m+n)") "k<m" "H1")
(simp "H1")
(use "Truth-Axiom")

; Case k >= m
(assume "k<m -> F")
(ng)
(cut (pf "k=(k-m)+m"))
(assume "H2")
(simp "H2")
(cut (pf "Sub(Var(k-m+m))(Spare m(Up(m+n)))=
          Sub(Var(k-m))(Up(m+n))"))
(assume "H3")
(simp "H3")
(ng)
(use "Truth-Axiom")
(use "SubVarSpare")
(add-global-assumption "LiftEqAux" 
 (pf "all k,m.(k<m -> F) -> k=k-m+m"))
(use "LiftEqAux")
(use "k<m -> F")

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

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

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

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

; Lemma: "CircUp"
; ---------------
; Joachimski's (3)

(set-goal (pf "all n,theta.theta circ Up n=Sublift theta n"))

(assume "n")
(ind)
(assume "m")
(ng)
(use "Truth-Axiom")
(assume "r" "theta" "IHtheta")
(ng)
(simp "IHtheta")
(simp "LiftEq")
(use "Truth-Axiom")
(save "CircUp")

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

; Lemmma: "LiftSubSpare"
; ----------------------
; Joachimski's (4)
; In the original text there is a tiny flaw. Therefore there is a
; corrected version

(set-goal (pf "all r,m,theta,n.
  Lift(Sub r(Spare m theta))m n=Sub r(Spare m(Sublift theta n))"))

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

; Correction (4').  First an auxiliary proposition.

; Lemmma: "LiftSubSpareAux1"
; --------------------------
(set-goal (pf "all theta,l,m,n.
 Lift(Sub(Var l)(Sublift theta m))m n=
 Sub(Var l)(Sublift theta(m+n))"))

(ind)
(assume "k")
(ng)
(aga "LiftSubSpareAux2" (pf "all l,k,m.l+k+m<m -> F"))
(assume "l" "m" "n")
(cut (pf "l+k+m<m -> F"))
(assume "H1")
(simp "H1")
(use "Truth-Axiom")
(use "LiftSubSpareAux2")
(assume "s" "theta" "IHtheta")
(ind)
(assume "m" "n")
(ng)
(use-with "LiftTwice" (pt "s") (pt "0") (pt "m") (pt "n"))
(assume "l" "IHl" "m" "n")
(ng)
(use "IHtheta")
(save "LiftSubSpareAux1")

; Lemmma: "LiftSubSpare"
; ----------------------
; the corrected (4') (see above)

(set-goal (pf "all r,m,theta,n.
  Lift(Sub r(Spare m(Sublift theta m)))m n=
  Sub r(Spare m(Sublift theta(m+n)))"))

(ind)
(assume "k" "m" "theta" "n")
(cases (pt "k<m"))
(assume "k<m")
(simp "SubVarSpareLt")
(simp "SubVarSpareLt")
(ng)
(simp "k<m")
(use "Truth-Axiom")
(use "k<m")
(use "k<m")

(assume "k<m -> F")
(cut (pf "k=(k-m)+m"))
(assume "H4")
(simp "H4")
(simp "SubVarSpare")
(simp "SubVarSpare")
(use "LiftSubSpareAux1")

(add-global-assumption "LiftEqAux" 
 (pf "all k,m.(k<m -> F) -> k=k-m+m"))
(use "LiftEqAux")
(use "k<m -> F")

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

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

; Lemma: "CircSublift"
; --------------------
; Joachimski's (5)

(set-goal (pf "all theta,theta1,n.
  theta circ Sublift theta1 n=Sublift (theta circ theta1) n"))

(ind)
(ind)
(assume "theta1" "n")
(use "Truth-Axiom")
(assume "k" "IHk")
(cases)
(assume "l" "n")
(ng)
(use "Truth-Axiom")
(assume "r" "theta1" "n")
(ng)
(use "IHk")

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

; Definition: "Pushlist"
; ----------------------
; adds the elements of a list to a substitution list

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

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

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

; Lemma: "PushlistEq"
; -------------------
(set-goal (pf "all k,theta,rs.Sub(Var(k+Lh rs))(Pushlist rs theta)=
                              Sub(Var k)theta"))

(assume "k" "theta")
(ind)
(use "Truth-Axiom")
(assume "r" "rs" "IHrs")
(ng)
(use "IHrs")
(save "PushlistEq")

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

; Definition: "Liftlist"
; ----------------------
; used in Joachimski (6)

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

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

; Lemma: "SubliftPushlist"
; ------------------------
(set-goal (pf "all theta,n,rs.Sublift(Pushlist rs theta)n=
               Pushlist(Liftlist rs 0 n)(Sublift theta n)"))

(assume "theta" "n")
(ind)
(use "Truth-Axiom")
(assume "r" "rs" "IHrs")
(ng)
(use "IHrs")
(save "SubliftPushlist")

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

; Lemma: "LhLiftlist"
; -------------------
(set-goal (pf "all m,n,rs.Lh rs=Lh(Liftlist rs m n)"))

(assume "m" "n")
(ind)
(use "Truth-Axiom")
(assume "r" "rs" "IHrs")
(ng)
(use "IHrs")
(save "LhLiftlist")

; Lemma: "SubLiftSpare"
; ---------------------
; Joachimski's (6)

(set-goal (pf "all r,m,rs,theta.
 Sub(Lift r m Lh rs)(Spare m(Pushlist rs theta))=
 Sub r(Spare m theta)"))

(ind)
(assume "k" "m" "rs" "theta")
(cases (pt "k<m"))
(assume "k<m")
(ng)
(simp "k<m")
(ng)
(simp "SubVarSpareLt")
(simp "SubVarSpareLt")
(use "Truth-Axiom")
(use "k<m")
(use "k<m")

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

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

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

; Lemma: "SubliftCircAux"
; -----------------------
(set-goal
 (pf "all m,theta,rs.Up(m+Lh rs)circ Pushlist rs theta=
                     Up m circ theta"))

(assume "m" "theta")
(ind)
(ng)
(use "Truth-Axiom")
(assume "r" "rs" "IHr")
(ng)
(use "IHr")
(save "SubliftCircAux")

; Lemma: "SubliftCirc"
; --------------------
; Joachimski's (6')

(set-goal (pf "all theta,theta1,rs.
  Sublift theta Lh rs circ Pushlist rs theta1=theta circ theta1"))

(ind)
(assume "m" "theta1" "rs")
(ng)
(use "SubliftCircAux")
(assume "r" "theta" "IHtheta" "theta1" "rs")
(ng)
(cut (pf "(Sub(Lift r 0 Lh rs)(Pushlist rs theta1))=Sub r theta1"))
(assume "H1")
(simp "H1")
(cut (pf "Sublift theta Lh rs circ Pushlist rs theta1=
          theta circ theta1"))
(assume "H2")
(simp "H2")
(use "Truth-Axiom")
(use "IHtheta")
(use-with "SubLiftSpare" (pt "r") (pt "0") (pt "rs") (pt "theta1"))
(save "SubliftCirc")

; Lemma: "SubVarUp"
; -----------------
(set-goal (pf "all theta,n,m.Sub(Var(n+m))theta=
                             Sub(Var n)(Up m circ theta)"))

(ind)
(assume "k" "n" "m")
(ng)
(use "Truth-Axiom")
(assume "r" "theta" "IHtheta" "n")
(cases)
(ng)
(use "Truth-Axiom")
(assume "m")
(use "IHtheta")
(save "SubVarUp")

; Theorem: "SubSub"
; -----------------
; Joachimski's (7)

(set-goal (pf "all r,theta,theta1.
  Sub(Sub r theta)theta1=Sub r(theta circ theta1)"))

(ind)
(ind)
(ind)
(assume "m" "theta1")
(ng)
(use-with "SubVarUp" (pt "theta1") (pt "0") (pt "m"))
(assume "r" "theta" "IHtheta" "theta1")
(ng)
(use "Truth-Axiom")
(assume "n" "IHn")
(ind)
(assume "k" "theta1")
(ng)
(use-with "SubVarUp" (pt "theta1") (pt "Succ n") (pt "k"))
(assume "r" "theta" "IHtheta")
(ng)
(use "IHn")

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

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