; $Id: higman01.scm 2204 2008-03-26 09:43:45Z schwicht $
; An inductive proof Higman's Lemma for a 0/1 alphabet
; see Coquand/Fridlender 1994
; We prove that every infinite sequence in a 0/1 alphabet has a good
; initial segment

; 1. Definitions

(set! COMMENT-FLAG #f)
(exload "bar/bar.scm")
(set! COMMENT-FLAG #t)

(add-global-assumption
 "OnlyTwoLetters" (pf "all a,b,c((a=b -> F) -> (c=a -> F) -> c=b)"))

; R a vs ws means vs= v1 ... vn, ws = v1::a ... vn::a

(add-ids (list (list "R" (make-arity nat seq seq)))
	 '("allnc a R a(Nil list nat)(Nil list nat)") 
	 '("allnc vs,ws,w,a(R a vs ws -> R a(vs::w)(ws::(w::a)))"))

(add-ids
 (list (list "TT" (make-arity nat seq seq)))
 '("allnc ws,zs,w,a,b((a=b -> F) -> R b ws zs -> TT a(zs::w)(zs::(w::a)))")
 '("allnc ws,zs,w,a(TT a ws zs -> TT a(ws::w)(zs::(w::a)))")
 '("allnc ws,zs,w,a,b((a=b -> F) -> TT a ws zs -> TT a ws(zs::(w::b)))"))

(add-global-assumption
 "Lemma1nc" (pf "allnc ws,w,a(L ws w -> L ws(w::a))"))
(add-global-assumption
 "Lemma2nc" (pf "allnc ws,zs,a(R a ws zs -> Good ws -> Good zs)"))
(add-global-assumption
 "Lemma3nc" (pf "allnc ws,zs,a(TT a ws zs -> Good ws -> Good zs)"))
(add-global-assumption
 "Lemma4nc" (pf "allnc ws,zs,a((ws=(Nil list nat) -> F) -> 
                       R a ws zs -> TT a ws zs)"))

; 2. Interactive proofs

; Prop1 has been proven in bar.scm

; Prop2

(set-goal  (pf "allnc xs(Bar xs ->
                allnc ys(Bar ys -> 
                all zs,a,b((a=b -> F) -> TT a xs zs  -> TT b ys zs -> 
                Bar zs)))"))
(assume "xs1")
(elim)

; 1. Good xs 
(assume "xs" "Good xs" "ys" "Bar ys" "zs" "a" "b" "a=b -> F" 
        "TT a xs zs" "TT b ys zs")
(intro 0)
(use-with "Lemma3nc" (pt "xs") (pt "zs") (pt "a") "TT a xs zs" "Good xs")

; 2. all w Bar(xs::w)
(assume "xs" "all w Bar(xs::w)" "IH1" "ys1")
(elim)

; 2.1
(assume "ys" "Good ys" "zs" "a" "b" "a=b -> F" "TT a xs zs" "TT b ws zs")
(intro 0)
(use-with "Lemma3nc" (pt "ys") (pt "zs") (pt "b") "TT b ws zs" "Good ys")

; 2.2
(assume "ys" "all w Bar(ys::w)" "IH2" "zs" "a" "b"
	"a=b -> F" "TT a xs zs" "TT b ws zs")
(intro 1)

; structural induction on w 
(ind) 

; 2.2.1
(use "Prop1")

; 2.2.2
(assume "z" "c" "Bar(zs::z)")

(cases (pt "c=a"))

(assume "c=a")
(simp "c=a")

(use "IH1" (pt "z") (pt "ys") (pt "a") (pt"b"))
; Bar ys
(intro 1)
(use "all w Bar(ys::w)")
; a=b -> F
(use "a=b -> F")

; TT a(xs::z) (zs::z::a)
(intro 1)
(use "TT a xs zs")

(intro 2)
(assume "b=a")
(use "a=b -> F")
(simp "b=a")
(prop)
(use "TT b ws zs")

; false
(assume "c=a -> F")
(cut (pf "c=b"))
(assume "c=b")

(use-with "IH2" (pt "z") (pt "zs::(z::c)") (pt "a") (pt "c") "?" "?" "?")
(assume "a=c")
(use "c=a -> F")
(simp "a=c")
(ng)
(use "Truth-Axiom")

(simp "c=b")
(intro 2)
(use "a=b -> F")
(use "TT a xs zs")

(simp "c=b")
(intro 1)
(use "TT b ws zs")
(use "OnlyTwoLetters" (pt "a"))
(use "a=b -> F")
(use "c=a -> F")
; Proof finished.
(save  "Prop2")

; The extracted program from Prop2

(remove-var-name "gc" "gd" "ge")

(add-var-name "gc" (py "list nat=>list(list nat)=>algBar"))
(add-var-name "gd" (py "list nat=>algBar=>list(list nat)=>nat=>nat=>algBar"))
(add-var-name "ge" (py "list nat=>list(list nat)=>nat=>nat=>algBar"))

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

; [algBar0]
;  (Rec algBar=>algBar=>list list nat=>nat=>nat=>algBar)algBar0
;  ([algBar5,ws6,a7,a8]cLeaf)
;  ([ga5,gd6,algBar7]
;    (Rec algBar=>list list nat=>nat=>nat=>algBar)algBar7([ws11,a12,a13]cLeaf)
;    ([ga11,ge12,ws13,a14,a15]
;      cBranch
;      ([w16]
;        (Rec list nat=>algBar)w16 cPropOne
;        ([w17,a18,algBar19]
;          [if (a18=a14)
;            (gd6 w17(cBranch ga11)(ws13::(w17::a14))a14 a15)
;            (ge12 w17(ws13::(w17::a18))a14 a18)]))))

; Prop3

(set-goal
 (pf "all a 
 allnc xs(Bar xs -> (xs=(Nil list nat) -> F) -> all zs(R a xs zs -> Bar zs))"))
(assume "a" "xs1")
(elim)

; all ws(good ws -> formula[a,ws])

(assume "xs" "Good xs" "xs ne Nil" "zs" "R a xs zs")
(intro 0)
(use-with "Lemma2nc" (pt "xs") (pt "zs") (pt "a") "R a xs zs" "Good xs")

; step
(assume "xs"  "all w Bar xs::w" "IH"  "xs ne Nil" "zs" "R a xs zs")
(intro 1)
(ind)
(use "Prop1")
(assume "z" "c" "Bar zs::z")
(cases (pt "c=a"))
(assume "c=a")
(use-with "IH" (pt "z") "?" (pt "zs::(z::c)") "?")
(ng)
(prop)

; R a(xs::z)(zs::(z::c))
(simp "c=a")
(intro 1)
(use "R a xs zs")

; (c=a -> F) -> Bar(zs::(z::c))
(assume "c=a -> F")
(cut (pf "a=c -> F"))
(assume "a=c -> F")
(use-with "Prop2"  (pt "xs") "?" 
                   (pt "zs::z") "Bar zs::z" 
                   (pt "zs::(z::c)")(pt "a") (pt "c") "?" "?" "?")

; Bar xs
(intro 1)
(use "all w Bar xs::w")

; a=c -> F 
(use "a=c -> F")

; TT a xs(zs::(z::c))
(intro 2)
(use "a=c -> F")

; TT a xs zs
(use "Lemma4nc" )
(use "xs ne Nil")
(use "R a xs zs")

; TT c(zs::z)(zs::(z::c))
(intro 0 (pt "xs") (pt "a"))
(use "c=a -> F")
(use "R a xs zs")

; a=c -> F
(assume "a=c")
(use "c=a -> F")
(simp "a=c")
(ng)
(use "Truth-Axiom")
; Proof finished.
(save "Prop3")

; The extracted program from Prop3

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

; [a0,algBar1]
;  (Rec algBar=>list list nat=>algBar)algBar1([ws3]cLeaf)
;  ([ga3,gc4,ws5]
;    cBranch
;    ([w6]
;      (Rec list nat=>algBar)w6 cPropOne
;      ([w7,a8,algBar9]
;        [if (a8=a0)
;          (gc4 w7(ws5::(w7::a8)))
;          (cPropTwo(cBranch ga3)algBar9(ws5::(w7::a8))a0 a8)])))

; The proof of the Theorem

(set-goal (pf "Bar(Nil list nat)"))
(intro 1)

(ind)
;1.
(use "Prop1")
;2.
(assume "w" "a" 1)
(use-with "Prop3" (pt "a") (pt ":w") 1 "?" (pt ":(w::a)") "?")
(ng)
(prop)

; R a(:w)(:(w::a))
(intro 1)
(intro 0)
; Proof finished.
(save "Thm")

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

; cBranch
; ([w0]
;   (Rec list nat=>algBar)w0 cPropOne
;   ([w1,a2,algBar3]cPropThree a2 algBar3:(w1::a2)))


(set-goal (pf "all f ex m Good(f fbar m)"))
(assume "f")
(use-with "BarThm" (pt "(Nil list nat)") "Thm" (pt "f") (pt "0") "?")
; (f fbar 0)=(Nil list nat) from
(ng)
(use "Truth-Axiom")
; Proof finished.
(save "HigmanThm")

(define eterm (proof-to-extracted-term (theorem-name-to-proof "HigmanThm")))

(animate "BarThm")
(animate "Thm")
(animate "Prop1")
(animate "Prop2")
(animate "Prop3")

(pp eterm)
; [f]cBarThm cThm f 0

(define neterm (nt eterm))
(pp neterm)

; [f0]
;  (Rec algBar=>(nat=>list nat)=>nat=>nat)
;  ((Rec list nat=>algBar)(f0 0)(cBranch([w1]cLeaf))
;   ([w1,a2,algBar3]
;     (Rec algBar=>list list nat=>algBar)algBar3([ws4]cLeaf)
;     ([ga4,gc5,ws6]
;       cBranch
;       ([w7]
;         (Rec list nat=>algBar)w7(cBranch([w8]cLeaf))
;         ([w8,a9,algBar10]
;           [if (a9=a2)
;             (gc5 w8(ws6::(w8::a9)))
;             ((Rec algBar=>list list nat=>nat=>nat=>algBar)algBar10
;             ([ws11,a12,a13]cLeaf)
;             ([ga11,ge12,ws13,a14,a15]
;               cBranch
;               ([w16]
;                 (Rec list nat=>algBar)w16(cBranch([w17]cLeaf))
;                 ([w17,a18,algBar19]
;                   [if (a18=a14)
;                     ((Rec algBar=>algBar=>list list nat=>nat=>nat=>algBar)
;                     (ga4 w17)
;                     ([algBar20,ws21,a22,a23]cLeaf)
;                     ([ga20,gd21,algBar22]
;                       (Rec algBar=>list list nat=>nat=>nat=>algBar)algBar22
;                       ([ws26,a27,a28]cLeaf)
;                       ([ga26,ge27,ws28,a29,a30]
;                         cBranch
;                         ([w31]
;                           (Rec list nat=>algBar)w31(cBranch([w32]cLeaf))
;                           ([w32,a33,algBar34]
;                             [if (a33=a29)
;                               (gd21 w32(cBranch ga26)(ws28::(w32::a29))a29 
;                               a30)
;                               (ge27 w32(ws28::(w32::a33))a29 a33)]))))
;                     (cBranch ga11)
;                     (ws13::(w17::a14))
;                     a14 
;                     a15)
;                     (ge12 w17(ws13::(w17::a18))a14 a18)])))
;             (ws6::(w8::a9))
;             a2 
;             a9)])))
;     :(w1::a2)))
;  ([f1,a2]a2)
;  ([ga1,gb2,f3,a4]gb2(f3 a4)f3(Succ a4))
;  f0 
;  1


; 3. Test of the extracted term.

(define (run-higman infinite-sequence)
  (pp (nt (mk-term-in-app-form neterm infinite-sequence))))

; a. [0 0], [1 1 0], [0 1 0 1], [0], ...
(add-program-constant "Seq" (mk-arrow (py "nat") (py "(list nat)")) 1)
(add-rewrite-rule (pt "Seq 0") (pt ":0::0"))
(add-rewrite-rule (pt "Seq 1") (pt ":1::1::0"))
(add-rewrite-rule (pt "Seq 2") (pt ":0::1::0::1"))
(add-rewrite-rule (pt "Seq(n+3)") (pt ":0"))
(run-higman (pt "Seq"))

; ==> 3
; i.e., the subsequence of consisting of the first three words is good

; b. [0 0], [1], [1 0], [], [], ...

(add-program-constant "Interesting" (mk-arrow (py "nat") (py "(list nat)")) 1)
(add-rewrite-rule (pt "Interesting 0") (pt ":0::0"))
(add-rewrite-rule (pt "Interesting 1") (pt ":1"))
(add-rewrite-rule (pt "Interesting 2") (pt ":1::0"))
(add-rewrite-rule (pt "Interesting 3") (pt "(Nil nat)"))
(add-rewrite-rule (pt "Interesting(n+4)") (pt "(Nil nat)"))
(run-higman (pt "Interesting"))

; ==> 5  
; This is an example in which not the shortest good initial segment is found.
