; $Id: taitScott.scm 2156 2008-01-25 13:25:12Z schimans $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(begin ;closed at EOF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Hat ohne Typargumente, 
;; Typkonstante Scott = (nat -> term) + (Scott -> Scott), 
;; rewrite rules statt Axiome fuer Mod/Hat,
;; Ax6 mit SN Praemisse,
;; Lemmas fuer SC rho r := ex a SCr a rho r
;; die zeigen, dass SC sich wie erwartet verhaelt,
;; alle Lemmas mit SC (statt SCr) formuliert.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Based on venedig.scm,v 1.2

; The Tait proof is formalized with untyped, named lambda terms, as
; in Ulrich Berger's lecture in Venice.  Contexts are viewed as
; functions nat=>term, hence Overwrite and Sub take a function
; argument


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

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

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

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

; Application for terms is via the constant App

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

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

(av "r" "s" "t" (py "term"))
(av "rs" "ss" "ts" (py "nat=>term"))

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

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

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

(av "rho" "sig" "tau" (py "type"))
(av "rhos" "sigs" "taus" (py "nat=>type"))

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


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

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



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

(add-computation-rule (pt "Overwrite rs k s n") 
                      (pt "[if (n=k) s (rs n)]"))

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

(add-computation-rule (pt "OverwriteC rhos k sig n") 
                      (pt "[if (n=k) sig (rhos n)]"))

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

; The computation rules specify Sub only partially:

(add-computation-rule (pt "Sub(Var n)rs") (pt "rs n"))
(add-computation-rule (pt "Sub(r s)rs") (pt "Sub r rs(Sub s rs)"))

(add-global-assumption "SubId" (pf "all r.Sub r([n](Var n))=r"))

(define (add-type-const-name name)
  (if (assoc name TYPE-CONSTANTS)
      (myerror "already a type constant name" name)
      (begin
        (set! TYPE-CONSTANTS (cons (list name) TYPE-CONSTANTS)) 
	(add-token name 'tconst name)
	(comment "ok, type constant " name " added"))))

(add-type-const-name "Scott")

(add-var-name "a" "b" "c" (py "Scott"))
(add-var-name "as" "bs"  (py "nat=>Scott"))

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

(add-computation-rule (pt "OverwriteR as k a n") 
                      (pt "[if (n=k) a (as n)]"))

(add-program-constant "ModL" (py "Scott=>nat=>term") 1)
(add-program-constant "HatL" (py "(nat=>term)=>Scott") 1)
(add-program-constant
 "Mod" (py "Scott=>Scott=>Scott") 1)

(add-program-constant
 "Hat" (py "(Scott=>Scott)=>Scott") 1)

; (remove-program-constant "HatL")
; (remove-program-constant "ModL")

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

;;; (add-global-assumption
;;;  "ModHatL" (pf "all g Equal(ModL(HatL g))g"))

(add-rewrite-rule (pt "ModL(HatL g) k") 
                      (pt "g k"))

(add-var-name "h" (py "Scott=>Scott"))

;;; (add-global-assumption 
;;;  "ModHat" (pf "all h,a.Mod(Hat h)a=h a"))

(add-rewrite-rule (pt "Mod(Hat h)a") 
                      (pt "h a"))

; Predicates

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

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

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

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

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

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


(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)
; (remove-global-assumption "ACL")

(add-global-assumption
 "AC" (pf "(all b allnc s.(Pvar Scott term)_1 b s ->
            ex c (Pvar Scott term)_2 c s) ->
           ex h all b,s.(Pvar Scott term)_1 b s ->
                        (Pvar Scott term)_2(h b)s"))
; (remove-global-assumption "AC")



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

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

(assume "r" "SC Iota r" "k" "Fr r k")
(by-assume-with "SC Iota r" "a" "SCr a Iota r")
(assert (pf "N r(ModL a k)"))
 (use "SCrIotaUnfold")
 (prop)
 (prop)
(assume "N r(ModL a k)")
(ex-intro (pt "ModL a k"))
(prop)

(save "LemmaSCIotaUnfold")

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

(assume "r" "SN r")
(assert (pf "ex g all k.Fr r k -> N r(g k)"))
 (use-with "ACL"
 	   (make-cterm (pv "k") (pf "Fr r k"))
 	   (make-cterm (pv "k") (pv "s") (pf "N r s")) "SN r")
(assume "SN r realizable")
(by-assume-with "SN r realizable" "g" "g realizes SN r")
(ex-intro (pt "HatL g"))
(use "SCrIotaFold")
(ng)
(prop)

(save "LemmaSCIotaFold")

    
;;; LemmaSCUnfold: allnc rho,sig,r. 
;;;      SC (rho to sig)r -> allnc s. SC rho s -> SC sig(r s)
(set-goal (pf "allnc rho,sig,r. ex a SCr a(rho to sig)r -> 
              allnc s. ex a SCr a rho s -> ex a SCr a sig(r s)"))
(assume "rho" "sig" "r" "SC(rho to sigma)r" "s" "SC rho s")
(by-assume-with "SC(rho to sigma)r" "a" "SCr a(rho to sigma)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")


;;;LemmaSCFold allnc rho,sig,r. 
;;;      (allnc s. SC rho s -> SC sig(r s)) -> SC (rho to sig)r
(set-goal (pf "allnc rho,sig,r.
                (allnc s. ex a SCr a rho s -> ex a SCr a sig(r s)) -> 
                ex a SCr a(rho to sig)r"))
(assume "rho" "sig" "r" "allnc s. SC rho s -> SC sig(r s)")
(assert (pf "ex h all a, s. SCr a rho s -> SCr(h a)sig(r s)"))
 (use-with "AC" (make-cterm (pv "b") (pv "s") (pf "SCr b rho s"))
	   (make-cterm (pv "b") (pv "s") (pf "SCr b sig(r s)")) "?")
 (assume "b" "s" "SCr b rho s")
 (use "allnc s. SC rho s -> SC sig(r s)")
 (ex-intro (pt "b"))
 (prop)
(assume "ex h...")
(by-assume-with "ex h..." "h" "...")
(ex-intro (pt "Hat h"))
(use "SCrFold")
(ng)
(use "...")

(save "LemmaSCFold")


(add-global-assumption
 "Ax1" (pf "all r,k,s.Fr r k -> N(r(Var k))s -> N r(Abs k s)"))

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

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

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

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

(add-global-assumption   ;;; Ax6 now with an SN hypothesis
 "Ax6" (pf "all k,r,rs,s. (all k. Fr s k -> ex s1 N s s1)
             -> Head((Sub(Abs k r)rs)s)(Sub r(Overwrite rs k s))"))

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

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

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

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

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

(add-global-assumption
 "Ax12"
 (pf "all rhos,sig,k.TypJ rhos(Var k)sig -> (sig = rhos k)"))

(add-global-assumption
 "Ax13" (pf "all rhos,sig,r,s.TypJ rhos(r s)sig -> 
                       exnc rho.TypJ rhos r(rho to sig) & TypJ rhos s rho"))

(add-global-assumption
 "Ax14" (pf "all rhos,rho,n,r.TypJ rhos(Abs n r)rho -> 
                    (rho = ((Argtyp rho) to (Valtyp rho))) 
                  & TypJ(OverwriteC rhos n (Argtyp rho))r (Valtyp rho)"))

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


; "LemmaOne": all rho allnc r. (SCr rho r -> SN r) & (SA r -> SC rho r)
(set-goal
 (pf "all rho allnc r.
       (ex a SCr a rho r -> all k.Fr r k -> ex s N r s) &
       ((all k.Fr r k -> ex s A r s) -> ex a SCr a rho r)"))

(ind)

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

; goal: SCr IOta r -> SN r
(use "LemmaSCIotaUnfold")

; goal: SA r -> SCr IOta r
(assume "SA r")
(use "LemmaSCIotaFold")
(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 sigma
(assume "rho" "sig" "IHrho" "IHsig" "r")
(split)

; goal: SC(rho to sigma)r -> SN r
(assume "SC(rho to sig)r" "k" "Fr r k")
(cut (pf "ex s N(r(Var k))s"))
(assume "ExHyp")
(by-assume-with "ExHyp" "s" "N(r(Var k))s")
(ex-intro (pt "Abs k s"))
(use "Ax1")
(use "Fr r k")
(use "N(r(Var k))s")
(assert (pf "ex a SCr a rho(Var k)"))
 (use "IHrho")
 (assume "k1" "Fr(Var k)k1")
 (ex-intro (pt "Var k"))
 (use "Ax3")
(assume "SC rho(Var k)")
(use "IHsig" (pt "k+1"))
(use "LemmaSCUnfold" (pt "rho"))
(use "SC(rho to sig)r")
(use "SC rho(Var k)")
(use "Ax8")
(use "Fr r k")

; goal: SA r -> SC(rho to sigma)r
(assume "SA r")
(use "LemmaSCFold")
(assume "s" "SC rho s")
(use "IHsig")
(assume "k" "Fr(r s)k")
(cut (pf "ex t A r t"))
(assume "ExHyp1")
(by-assume-with "ExHyp1" "r1" "A r r1")
(cut (pf "ex s1 N s s1"))
(assume "ExHyp2")
(by-assume-with "ExHyp2" "s1" "N s s1")
(ex-intro (pt "r1 s1"))
(use "Ax4")
(use "A r r1")
(use "N s s1")
(use "IHrho" (pt "k"))
(use "SC rho s")
(use "Ax9" (pt "r"))
(use "Fr(r s)k")
(use "SA r" (pt "k"))
(use "Ax10" (pt "s"))
(use "Fr(r s)k")

(save "LemmaOne")




; LemmaTwo: allnc rho,r1,r. SC rho r1 -> Head r r1 -> SC rho r
(set-goal (pf "allnc rho,r1,r. ex a SCr a rho r1 -> Head r r1 -> 
                               ex a SCr a rho r"))

(cut (pf "all rho,r1,r,a.SCr a rho r1 -> Head r r1 -> SCr a rho r"))
(assume "LemmaTwoR")
(assume "rho" "r1" "r" "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 "SCr a rho r1")
(use "Head r r1")

; proof of LemmaTwoR: 
(ind)

; Ground  type
(assume "r1" "r" "a" "SCr a Iota r1" "Head r r1")
(use "SCrIotaFold")
(assume "k" "Fr r k")
(use "Ax5" (pt "r1"))
(use "Head r r1")
(use "SCrIotaUnfold")
(use "SCr a Iota r1")
(use "Ax11" (pt "r"))
(use "Fr r k")
(use "Head r r1")

; Step type
(assume "rho" "sig" "IHrho" "IHsig" "r1" "r" "a"
	"SCr a(rho to sig)r1" "Head r r1")
(use "SCrFold")
(assume "b" "s" "SCr b rho s")
(use "IHsig" (pt "r1 s"))
(use "SCrUnfold" (pt "rho"))
(use "SCr a(rho to sig)r1")
(use "SCr b rho s")
(use "Ax7")
(use "Head r r1")

(save "LemmaTwo")


; LemmaThree: all r allnc rhos,rho,ss. TypJ rhos r rho -> 
;                                      SCs rhos ss -> SC rho(Sub r ss)
(set-goal
 (pf "all r allnc rhos,rho,ss. TypJ rhos r rho -> 
                               (all k.ex a SCr a (rhos k)(ss k)) ->
                               ex a SCr a rho(Sub r ss)"))

(ind)

; Case Variables
(assume "k" "rhos" "rho" "ss" "TypJ rhos(Var k)rho" "SCs rhos ss")
(ng)

; goal: SC rho(ss k)
(assert (pf "rho = (rhos k)"))
 (use "Ax12")
 (use "TypJ rhos(Var k)rho")
 (assume "rho=rhos k")
(simp "rho=rhos k")
(use "SCs rhos ss")

; Case App
(assume "r" "s" "IHr" "IHs" "rhos" "rho" "ss" "TypJ rhos(r s)rho"
	"SCs rhos ss")
(ng #t)
; goal: SC rho(Sub r ss(Sub s ss))
(assert (pf "exnc tau.TypJ rhos r(tau to rho) & TypJ rhos s tau"))
 (use "Ax13")
 (use "TypJ rhos(r s)rho")
(assume "H1")
(exnc-elim "H1")
(assume "tau" "H1Inst")
(use "LemmaSCUnfold" (pt "tau"))
(use "IHr" (pt "rhos"))
(use "H1Inst")
(use "SCs rhos ss")
(use "IHs" (pt "rhos"))
(use "H1Inst")
(use "SCs rhos ss")

; Case Abs
(assume "n" "r" "IHr" "rhos" "rho" "ss" "TypJH" "SCs rhos ss")
; goal: SC rho(Sub(Abs n r)ss)
(assert (pf "rho = ((Argtyp rho) to (Valtyp rho))"))
 (use "Ax14" (pt "rhos") (pt "n") (pt "r"))
 (use "TypJH")
(assume "rho=(Argtyp rho to Valtyp rho)")
(simp "rho=(Argtyp rho to Valtyp rho)")
; goal: SC(Argtyp rho to Valtyp rho)(Sub(Abs n r)ss)
(assert (pf "allnc s. ex a SCr a(Argtyp rho)s -> 
              ex a SCr a(Valtyp rho)(Sub(Abs n r)ss s)"))
 (assume "s" "SC(Argtyp rho)s")
 (use "LemmaTwo" (pt "Sub r(Overwrite ss n s)"))
 (use "IHr" (pt "(OverwriteC rhos n (Argtyp rho))"))
 (use "Ax14")
 (use "TypJH")
 (assume "k")
 (cases (pt "k=n"))
 (assume "k=n")
 (simp "k=n")
 (ng #t)
 (use "SC(Argtyp rho)s")
 (assume "k=n -> F")
 (ng)
 (simp "k=n -> F")
 (ng)
 (use "SCs rhos ss")
 (use "Ax6")
; goal: SN s
 (use "LemmaOne" (pt "Argtyp rho"))
 (use "SC(Argtyp rho)s")
(use "LemmaSCFold")

(save "LemmaThree")


;;; SNTheorem: all r,rhos,rho. TypJ rhos r rho -> SN r
(set-goal
 (pf "all r,rhos,rho.TypJ rhos r rho -> 
                     all k.Fr r k -> ex s N r s"))
(assume "r" "rhos" "rho" "TypJ rhos r rho")
(assert (pf "all k ex a SCr a (rhos k)(Var k)"))
 (assume "k")
 (use "LemmaOne")
 (assume "k1" "Fr (Var k) k1")
 (ex-intro (pt "Var k"))
 (use "Ax3")
(assume "SCs rhos Id" "k" "Fr r k")
(assert (pf "ex a SCr a rho (Sub r ([k](Var k)))"))
 (use "LemmaThree" (pt "rhos"))
 (use "TypJ rhos r rho")
 (ng)
 (use "SCs rhos Id")
(simp "SubId")
(assume "SC rho r")
(use "LemmaOne" (pt "rho") (pt "k"))
(use "SC rho r")
(use "Fr r k")

(save "SNTheorem")

;;; Extracted programs

(define SCLemmas 
  '("LemmaSCIotaUnfold" "LemmaSCFold" "LemmaSCUnfold" "LemmaSCFold")) 

(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 "(Scott=>nat=>term)@@((nat=>term)=>Scott)"))

(add-var-name "q" (py "(nat=>Scott)=>Scott"))

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

;[r0,rhos1,rho2]
; left(cLemmaOne rho2)
; (cLemmaThree r0([n4]right(cLemmaOne(rhos1 n4))([n5]Var n4)))

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

;(Rec type=>(Scott=>nat=>term)@@((nat=>term)=>Scott))(ModL@cLemmaSCIotaFold)
;([rho3,rho4,p5,p6]
;  ([a7,n8]Abs n8(left p6(Mod a7(right p5([n9]Var n8)))(Succ n8)))@
;  ([rs7]Hat(cAC([a9]right p6([n10]rs7 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=>(nat=>Scott)=>Scott)([n2,as3]as3 n2)
;([r2,r3,q4,q5,as6]Mod(q4 as6)(q5 as6))
;([n2,r3,q4,as5]Hat(cAC([a7]q4([n8][if (n8=n2) a7 (as5 n8)]))))



);matches  (begin  at the beginning if this file
; this closing bracket should stay at the end of this file
