; $Id: fanwklu.scm 2231 2008-04-02 12:43:01Z schimans $

; Formalization of the equivalence of Fan and a weakened form of WKL,
; with EffUniq as an additional hypothesis.  Based on

; @Article{Schwichtenberg05c,
;   author = 	 {Helmut Schwichtenberg},
;   title = 	 {{A direct proof of the equivalence between Brouwer's fan 
;                 theorem and K{\"o}nig's lemma with a uniqueness hypothesis}},
;   journal = 	 {Journal of Universal Computer Science},
;   year = 	 2005,
;   volume =	 11,
;   number =	 12,
;   pages =	 {2086--2095},
;   note =	 {\url|http://www.jucs.org/jucs_11_12/a_direct_proof_of|}
; }

; To be done: (1) remove n>0 in FanImpPfan, (2) replace + by max where
; possible, (3) provide totality proofs for the progrsm constants.

; (load "~/minlog/init.scm")
(set! DOT-NOTATION #f)

(set! COMMENT-FLAG #f)
(mload "../lib/nat.scm")
(mload "../lib/listrev.scm")
(set! COMMENT-FLAG #t)
(display "loading fanwklu.scm ...") (newline)


; "ListZip" and "ListUnzip" added as program constants

(add-program-constant
 "ListZip" (py "list(alpha@@alpha)=>list alpha") t-deg-one)

(add-token
 "Zip" 'prefix-op 
 (lambda (x) (make-term-in-app-form
	      (make-term-in-const-form
	       (let* ((const (pconst-name-to-pconst "ListZip"))
		      (tvars (const-to-tvars const))
		      (pairlisttype (term-to-type x))
		      (pairtype (car (alg-form-to-types pairlisttype)))
		      (type (star-form-to-left-type pairtype))
		      (subst (make-substitution tvars (list type))))
		 (const-substitute const subst #f)))
	      x)))

(add-display
 (py "list alpha")
 (lambda (x)
   (if (term-in-app-form? x)
       (let ((op (term-in-app-form-to-op x))
	     (args (term-in-app-form-to-args x)))
	 (if (and (term-in-const-form? op)
		  (string=? "ListZip"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 1 (length args)))
	     (list 'prefix-op "Zip"
		   (term-to-token-tree (car args)))
	     #f))
       #f)))

(add-computation-rule (pt "Zip(Nil alpha@@alpha)") (pt "(Nil alpha)"))

(add-computation-rule
 (pt "Zip(list(alpha@@alpha)::alpha@@alpha)")
 (pt "Zip list(alpha@@alpha)::left alpha@@alpha::right alpha@@alpha"))

; (pp (nt (pt "Zip(:(0@1)::(2@3)::(4@5))"))) 
; :0::1::2::3::4::5

(add-program-constant
 "ListUnzip" (py "nat=>list alpha=>list(alpha@@alpha)") t-deg-one)

(add-token
 "unzip" 'pair-op ;hence right associative
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "ListUnzip"))
	    (tvars (const-to-tvars const))
	    (listtype (term-to-type y))
	    (type (car (alg-form-to-types listtype)))
	    (subst (make-substitution tvars (list type))))
       (const-substitute const subst #f)))
    x y)))

(add-display
 (py "list(alpha@@alpha)")
 (lambda (x)
   (if (term-in-app-form? 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=? "ListUnzip"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 2 (length args)))
	     (list 'pair-op "unzip"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args)))
	     #f))
       #f)))

(add-computation-rule (pt "0 unzip list alpha") (pt "(Nil alpha@@alpha)"))

(add-computation-rule (pt "Succ nat unzip(Nil alpha)")
		      (pt "(Nil alpha@@alpha)"))

(add-computation-rule (pt "Succ nat unzip:alpha") (pt "(Nil alpha@@alpha)"))

(add-computation-rule (pt "Succ nat unzip list alpha::alpha_1::alpha_2")
		      (pt "(nat unzip list alpha)::(alpha_1@alpha_2)"))

; (pp (nt (pt "3 unzip(:0::1::2::3::4::5)")))
; :(0@1)::(2@3)::(4@5)

; "UnzipZipPair"
(set-goal
 (pf "all list(alpha@@alpha)^.STotal list(alpha@@alpha)^ ->
       Equal(Lh list(alpha@@alpha)^unzip Zip list(alpha@@alpha)^)
            list(alpha@@alpha)^"))
(ind)
(use "Eq-Refl")
(assume "list(alpha@@alpha)^" "alpha@@alpha^" "H" "IH")
(ng)
(simp "IH")
(use "Eq-Refl")
; Proof finished.
(save "UnzipZipPair")

(add-rewrite-rule
 (pt "Lh list(alpha@@alpha)unzip Zip list(alpha@@alpha)")
 (pt "list(alpha@@alpha)"))

; "LhZipPair"
(set-goal
 (pf "all list(alpha@@alpha)^.STotal list(alpha@@alpha)^ ->
       Lh Zip list(alpha@@alpha)^ =2*Lh list(alpha@@alpha)^"))
(ind)
(use "Truth-Axiom")
(assume "list(alpha@@alpha)^" "alpha@@alpha^" "H" "IH")
(ng)
(use "IH")
; Proof finished.
(save "LhZipPair")

(add-rewrite-rule (pt "Lh Zip list(alpha@@alpha)")
		  (pt "2*Lh list(alpha@@alpha)"))


(add-program-constant "Half" (py "nat=>nat") t-deg-one)

(add-computation-rule (pt "Half 0") (pt "0"))
(add-computation-rule (pt "Half 1") (pt "0"))
(add-computation-rule (pt "Half(Succ(Succ nat))") (pt "Succ(Half nat)"))

; (pp (nt (pt "Half 17")))

(add-program-constant "Even" (py "nat=>boole") t-deg-one)

(add-computation-rule (pt "Even 0") (pt "True"))
(add-computation-rule (pt "Even 1") (pt "False"))
(add-computation-rule (pt "Even(Succ(Succ nat))") (pt "Even nat"))

; (pp (nt (pt "Even 17")))

; "ListFzip" and "ListFunzip" added as program constants

(add-program-constant
 "ListFzip" (py "(nat=>alpha@@alpha)=>nat=>alpha") t-deg-one)

(add-token
 "fzip" 'pair-op ;hence right associative
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "ListFzip"))
	    (tvars (const-to-tvars const))
	    (pairfcttype (term-to-type x))
	    (pairtype (arrow-form-to-val-type pairfcttype))
	    (type (star-form-to-left-type pairtype))
	    (subst (make-substitution tvars (list type))))
       (const-substitute const subst #f)))
    x y)))

(add-display
 (py "alpha")
 (lambda (x)
   (if (term-in-app-form? 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=? "ListFzip"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 2 (length args)))
	     (list 'pair-op "fzip"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args)))
	     #f))
       #f)))

(add-token
 "Fzip" 'prefix-op
 (lambda (x) (make-term-in-app-form
	      (make-term-in-const-form
	       (let* ((const (pconst-name-to-pconst "ListFzip"))
		      (tvars (const-to-tvars const))
		      (pairfcttype (term-to-type x))
		      (pairtype (arrow-form-to-val-type pairfcttype))
		      (type (star-form-to-left-type pairtype))
		      (subst (make-substitution tvars (list type))))
		 (const-substitute const subst #f)))
	      x)))

(add-display
 (py "nat=>alpha")
 (lambda (x)
   (if (term-in-app-form? 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=? "ListFzip"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 1 (length args)))
	     (list 'prefix-op "Fzip"
		   (term-to-token-tree (car args)))
	     #f))
       #f)))

(add-computation-rule
 (pt "nat=>alpha@@alpha fzip nat")
 (pt "[if (Even nat) 
          (left(nat=>alpha@@alpha(Half nat)))
          (right(nat=>alpha@@alpha(Half nat)))]"))

; (pp (pt "Fzip([n]2*n@2*n+1)"))
; (pp (pt "([n]2*n@2*n+1)fzip 16"))
; (pp (nt (pt "([n]2*n@2*n+1)fzip 16")))
; 16


(add-program-constant
 "ListFunzip" (py "(nat=>alpha)=>nat=>alpha@@alpha") t-deg-one)

(add-token
 "funzip" 'pair-op ;hence right associative
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form
     (let* ((const (pconst-name-to-pconst "ListFunzip"))
	    (tvars (const-to-tvars const))
	    (fcttype (term-to-type x))
	    (type (arrow-form-to-val-type fcttype))
	    (subst (make-substitution tvars (list type))))
       (const-substitute const subst #f)))
    x y)))

(add-display
 (py "alpha@@alpha")
 (lambda (x)
   (if (term-in-app-form? 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=? "ListFunzip"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 2 (length args)))
	     (list 'pair-op "funzip"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args)))
	     #f))
       #f)))

(add-token
 "Funzip" 'prefix-op
 (lambda (x) (make-term-in-app-form
	      (make-term-in-const-form
	       (let* ((const (pconst-name-to-pconst "ListFunzip"))
		      (tvars (const-to-tvars const))
		      (fcttype (term-to-type x))
		      (type (arrow-form-to-val-type fcttype))
		      (subst (make-substitution tvars (list type))))
		 (const-substitute const subst #f)))
	      x)))

(add-display
 (py "nat=>alpha@@alpha")
 (lambda (x)
   (if (term-in-app-form? 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=? "ListFunzip"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 1 (length args)))
	     (list 'prefix-op "Funzip"
		   (term-to-token-tree (car args)))
	     #f))
       #f)))

(add-computation-rule
 (pt "nat=>alpha funzip nat")
 (pt "nat=>alpha(2*nat)@nat=>alpha(2*nat+1)"))

; (pp (nt (pt "([n]n)funzip 3")))
; 6@7

; (pp (nt (pt "Zip(Funzip([n]n)fbar 3)")))
; :0::1::2::3::4::5
; (pp (nt (pt "Zip(Funzip(nat=>nat)fbar 3)")))

; :((nat=>nat)0)::(nat=>nat)1::(nat=>nat)2::(nat=>nat)3::(nat=>nat)4::
; (nat=>nat)5


(add-var-name "a" "b" "c" (py "list boole")) ;node
(add-var-name "r" "s" "t" (py "list boole=>boole")) ;tree, bar
(add-var-name "as" "bs" "cs" (py "nat=>list boole")) ;sequences of nodes
(add-var-name "f" "g" "h" (py "nat=>boole")) ;path
(add-var-name "i" "j" (py "nat")) ;natural numbers
(add-var-name "p" "q" (py "boole")) ;booleans
(add-var-name "ns" "ms" "ks" (py "nat=>nat")) ;sequences of numbers

(add-computation-rule (pt "(Inhab boole)") (pt "True"))


; "=FBar"
(set-goal
 (pf "all f^1,f^2,n(all i(i<n -> f^1 i=f^2 i) -> (f^1 fbar n)=(f^2 fbar n))"))
(assume "f^1" "f^2")
(ind)
(assume "H1")
(ng)
(use "Truth-Axiom")
(assume "n" "IH" "H1")
(ng)
(split)
(use "IH")
(assume "i" "i<n")
(use "H1")
(use "NatLtTrans" (pt "n"))
(use "i<n")
(use "Truth-Axiom")
(use "H1")
(use "Truth-Axiom")
; Proof finished.
(save "=FBar")


; "=FbarIf"
(set-goal
 (pf "all b,n,m(n<=m -> (([i][if (i<m) (b__i) True])fbar n)=b bar n)"))
(assume "b" "n" "m" "n<=m")
(use "=FBar")
(assume "i" "i<n")
(assert (pf "i<m"))
 (use "NatLtLeTrans" (pt "n"))
 (use "i<n")
 (use "n<=m")
(assume "i<m")
(simp "i<m")
(ng)
(use "Truth-Axiom")
; Proof finished.
(save "=FbarIf")


; "=FbarIfGen"
(set-goal
 (pf "all f^,b,n,m(n<=m ->  (([i][if (i<m) (b__i) (f^ i)])fbar n)=b bar n)"))
(assume "f^" "b" "n" "m" "n<=m")
(use "=FBar")
(assume "i" "i<n")
(assert (pf "i<m"))
 (use "NatLtLeTrans" (pt "n"))
 (use "i<n")
 (use "n<=m")
(assume "i<m")
(simp "i<m")
(ng)
(use "Truth-Axiom")
; Proof finished.
(save "=FbarIfGen")


; "=FBar1"
(set-goal
 (pf "all a,n,p (([i][if (i<n) (a__i) [if (i=n) p True]])fbar n)=a bar n"))
(assume "a" "n" "p")
(use "=FBar")
(assume "i" "i<n")
(simp "i<n")
(ng)
(use "Truth-Axiom")
; Prof finished.
(save "=FBar1")


; "ListLhBar"
(set-goal (pf "all n,a(Lh a=n -> a bar n=a)"))
(ind)
(cases)
(assume "Trivial")
(use "Truth-Axiom")
(assume "a" "p" "Absurd")
(use "Efq")
(use "Absurd")
(assume "n" "IHn")
(cases)
(assume "Absurd")
(use "Efq")
(use "Absurd")
(assume "a" "p" "Lh a=n")
(ng)
(simp "<-" "Lh a=n")
(ng)
(simp "Lh a=n")
(ng)
(inst-with-to "IHn" (pt "a") "Lh a=n" "H1")
(simp "=FBar1")
(use "H1")
; Proof finished.
(save "ListLhBar")


; "ListBarBar"
(set-goal (pf "all a,n,m a bar(n+m) bar n=a bar n"))
(assume "a" "n")
(ind)
(use "ListLhBar")
(use "Truth-Axiom")
(assume "m" "IH")
; ?_11: a bar(n+Succ m)bar n=a bar n from
;   a  n  m  IH:a bar(n+m)bar n=a bar n

(assert (pf "a bar(n+Succ m)=a bar(n+m)::a__(n+m)"))
 (ng)
 (use "Truth-Axiom")
(assume "EqHyp1")
(simp "EqHyp1")
(ng)
(simp-with "=FbarIfGen"
	  (pt "[i][if (i=n+m) (a__(n+m)) True]")
	  (pt "a bar(n+m)")
	  (pt "n") (pt "n+m") "?")
(use "IH")
(use "Truth-Axiom")
; Proof finished.
(save "ListBarBar")


(add-global-assumption
 "ListBarBarCor" (pf "all a,n,m(n<=m -> a bar m bar n=a bar n)"))


; Definition of Tree
(add-ids
 (list (list "Tree" (make-arity (py "list boole=>boole"))))
 '("all t(all a AllBNat(Lh a)([n]t a impb t(a bar n)) -> Tree t)" "TreeIntro"))

; Alternative, with a logical formula:

(add-ids
 (list (list "TreeL" (make-arity (py "list boole=>boole"))))
 '("all t((all a,n.n<=Lh a -> t a -> t(a bar n)) -> TreeL t)" "GenTreeL"))

; Definition of Upclosed
(add-ids
 (list (list "Upclosed" (make-arity (py "list boole=>boole"))))
 '("all s(all a AllBNat(Lh a)([n]s(a bar n)impb s a) -> Upclosed s)"
   "GenUpclosed"))

; Alternative, with a logical formula:

(add-ids
 (list (list "UpclosedL" (make-arity (py "list boole=>boole"))))
 '("all s(all a,n(n<Lh a -> s(a bar n) -> s a) -> UpclosedL s)"
   "GenUpclosedL"))

; Notice that both definitions do not have computational content.
; (there are no "algUpclosed" "algTree" at the end of the first lines)

(add-var-name "bc" (py "list(boole@@boole)"))
(add-var-name "ss" (py "(list(boole@@boole))=>boole"))
(add-var-name "gh" (py "nat=>boole@@boole"))


(add-rewrite-rule (pt "Even(nat+nat)") (pt "True"))
(add-rewrite-rule (pt "Even(Succ(nat+nat))") (pt "False"))

(add-rewrite-rule (pt "Half(nat+nat)") (pt "nat"))
(add-rewrite-rule (pt "Half(Succ(nat+nat))") (pt "nat"))


(pp
 (pf "all s^(all f ex m s^(f fbar m) -> ex k all f exca m(m<k+1 ! s^(f fbar m))) -> 
all n,ss(
 all bc,n(n<=Lh bc -> ss(bc bar n) -> ss bc) -> 
 all gh(
  ((([i]left(gh i))fbar n)=(([i]right(gh i))fbar n) -> F) -> 
  ex m ss(gh fbar m)) -> 
 ex k 
  all gh(
   ((([i]left(gh i))fbar n)=(([i]right(gh i))fbar n) -> F) ->
  ss(gh fbar k)))"))

; "FanImpPFan"
(set-goal
 (pf "all s^(
all f ex m s^(f fbar m) -> ex k all f exca m(m<k+1 ! s^(f fbar m))) -> 
all n,ss(
 all bc,n(n<=Lh bc -> ss(bc bar n) -> ss bc) -> 
 all gh(
  ((([i]left(gh i))fbar n)=(([i]right(gh i))fbar n) -> F) -> 
  ex m ss(gh fbar m)) -> 
 ex k 
  all gh(
   ((([i]left(gh i))fbar n)=(([i]right(gh i))fbar n) -> F) ->
    ss(gh fbar k)))"))
(assume "Fan" "n" "ss" "Upclosed_ss" "Bar_ss")
(assert
 (pf "all f ex m  AllBNat n([i]((f fbar m)__(2*i)=(f fbar m)__(2*i+1)impb
                                 False)impb
                           ss(Half Lh(f fbar m)unzip(f fbar m))) -> 
          ex k all f exca m.
             m<k+1 ! 
             AllBNat n([i]((f fbar m)__(2*i)=(f fbar m)__(2*i+1)impb
                            False)impb
                      ss(Half Lh(f fbar m)unzip(f fbar m)))"))
; We instantiate Fan with s_n
(use-with "Fan" (pt "[a]AllBNat n([i](a__(2*i)=a__(2*i+1) impb False)impb 
                                     ss((Half(Lh a)unzip a)))"))
(assume "FanInst")
(drop "Fan")
; We need to show that s_n bars every path.
(assert
 (pf "all f ex m AllBNat n([i]((f fbar m)__(2*i)=(f fbar m)__(2*i+1)impb
                                False)impb
                           ss(Half Lh(f fbar m)unzip f fbar m))"))
 (assume "f")
 (cases (pt "AllBNat n([i]f(2*i)=f(2*i+1))"))
 (assume "Case1")
 ; For easier use we write our case assumption in logical form
 (assert (pf "all i(i<n -> f(2*i)=f(2*i+1))"))
  (use-with "AllBNatElim" (pt "[i]f(2*i)=f(2*i+1)") (pt "n")
            "Case1")
 (drop "Case1")
 (assume "Case1Log")
 ; We guess that 2*n will be the proper m
 (ex-intro (pt "2*n"))
 ; For easier use we write our goal in logical form
 (use-with
  "AllBNatIntro"
  (pt "[i]((f fbar 2*n)__(2*i)=(f fbar 2*n)__(2*i+1)impb False)impb 
          ss(Half Lh(f fbar 2*n)unzip f fbar 2*n)")
  (pt "n") "?")
 (assume "i" "i<n")
 (ng #t)
 ; From i<n we infer (f fbar n+n)__(i+i)=f(i+i)
 (assert (pf "(f fbar n+n)__(i+i)=f(i+i)"))
  (add-global-assumption
   "FanImpPFanAux2" (pf "all f,i,n(i<n -> (f fbar n+n)__(i+i)=f(i+i))"))
  (use "FanImpPFanAux2")
  (use "i<n")
 (assume "H1")
 (simp "H1")
 ; From i<n we infer (f fbar n+n)__(Succ(i+i))=f(Succ(i+i))
 (assert (pf "(f fbar n+n)__(Succ(i+i))=f(Succ(i+i))"))
  (add-global-assumption "FanImpPFanAux2a"
       (pf "all f,i,n(i<n -> (f fbar n+n)__(Succ(i+i))=f(Succ(i+i)))"))
  (use "FanImpPFanAux2a")
  (use "i<n")
 (assume "H2")
 (simp "H2")
 (assert (pf "f(2*i)=f(2*i+1)"))
  (use "Case1Log")
  (use "i<n")
 (assume "H3")
 (simp "H3")
 (use "Truth-Axiom")

 (assume "Case2")
 ; By Bar_ss with gh := Funzip f we can find an m such that
 ; bc := (Funzip f fbar m) is in ss
 (assert (pf "ex m ss(Funzip f fbar m)"))
  (use "Bar_ss")
  (add-global-assumption "FanImpPFanAux3"
       (pf "all f,n((AllBNat n([i]f(2*i)=f(2*i+1)) -> F) -> 
         (([i]left(f funzip i))fbar n)=(([i]right(f funzip i))fbar n) -> F)"))
  (use "FanImpPFanAux3")
  (use "Case2")
 (assume "ExHyp")
 (by-assume-with "ExHyp" "m" "ExHypInst")
 ;By Upclosed_ss we can assume n<=m
 (add-global-assumption "FanImpPFanAux4"
      (pf "all ss,gh,m,n((all bc,n.n<=Lh bc -> ss(bc bar n) -> ss bc) ->
                         ss(gh fbar m) ->
                         ss(gh fbar(m + n)))")) ;+ -> max, add max to nat.scm
 (assert (pf "ss(Funzip f fbar(m+n))"))
  (use "FanImpPFanAux4")
  (use "Upclosed_ss")
  (use "ExHypInst")
 (assume "H1")
 ; Now we can take a:= Zip(bc) = Zip(Funzip f fbar(m+n)) = f fbar(2*(m+n))
 (ex-intro (pt "2*(m+n)"))
  (add-global-assumption "FanImpPFanAux5"
       (pf "all f,m,n(Equal(Half Lh(f fbar 2*(m+n))unzip f fbar 2*(m+n))
                           (Funzip f fbar m))"))
  (simp "FanImpPFanAux5")
  (simp "ExHypInst")
  (use "AllBNatIntro")
  (strip)
  (use "Truth-Axiom")

(assume "FanInstHyp")
(inst-with-to "FanInst" "FanInstHyp" "ExHyp")
(drop "FanInst" "FanInstHyp")
(by-assume-with "ExHyp" "k" "Uniform-sn-bound")
(ex-intro (pt "(k+n)"))
(assume "gh" "ghdiff")
; We use ss(gh fbar 2*(k+n)) from sn(a), for a = f fbar(2*(k+n))
(add-global-assumption
 "FanImpPFanAux6"
 (pf "all gh,n,ss,k(
 ((([i]left(gh i))fbar n)=(([i]right(gh i))fbar n) -> F) -> 
 all f 
  exca m(
   m<k+1 ! 
   AllBNat n
   ([i]
     ((f fbar m)__(2*i)=(f fbar m)__(2*i+1)impb False)impb 
     ss(Half Lh(f fbar m)unzip f fbar m))) -> 
   ss(gh fbar k+n))"))
(use "FanImpPFanAux6")
(use "ghdiff")
(use "Uniform-sn-bound")
; Proof finished.
(save "FanImpPFan")

; Variable names to be used in the extracted term.

(add-var-name "fan" (py "(list boole=>boole)=>((nat=>boole)=>nat)=>nat"))
(add-var-name "pbar" (py "(nat=>boole@@boole)=>nat"))

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

;[fan0,n1,ss2,pbar3]
; fan0
; ([a4]
;   AllBNat n1
;   ([n5](a4__(n5+n5)=a4__Succ(n5+n5)impb False)impb ss2(Half Lh a4 unzip a4)))
; ([f4]
;   [if (AllBNat n1([n5]f4(n5+n5)=f4(Succ(n5+n5))))
;     (n1+n1)
;     (pbar3([n5]f4(n5+n5)@f4(Succ(n5+n5)))+n1+
;     pbar3([n5]f4(n5+n5)@f4(Succ(n5+n5)))+
;     n1)])+ n1

; We are given a functional fan0 realizing Fan, a number n1, a set ss2
; of pair nodes and a functional pbar3 mapping a pair path differing at
; n to a bar.  Apply fan0 to (1) the set of all nodes a4 such that for
; all n5<n1, if the elements of a4 at 2*n5 and 2*n5+1 are distinct,
; then the result of unzipping a4 at half of its length is in ss2, and
; (2) a witness that every path f4 hits this set, and add n1.  For (2),
; distinguish cases whether for some n5<n1, f4 at 2*n5 equals f4 at
; 2*n5+1.  If so, take 2*n1.  If not, let n be the result of applying
; pbar3 to the unzipped form of f4, and take 2*n+2*n1.

; [better: "and add n1" --> "and take the max of this number and n1"]

(add-var-name "pq" (py "boole@@boole"))


; "FanBound"
(set-goal
 (pf "all n,ss(
       all bc,n(n<=Lh bc -> ss(bc bar n) -> ss bc) -> 
       all gh(((([i]left(gh i))fbar n)=(([i]right(gh i))fbar n) -> F) ->
                ex m ss(gh fbar m)) -> 
       ex k
        all gh.((([i]left(gh i))fbar n)=(([i]right(gh i))fbar n) -> F) -> 
               ss(gh fbar k)) ->
      all t.Tree t ->
            all g,h,n(((g fbar n)=(h fbar n) -> F) -> 
              ex m.t(g fbar m) -> t(h fbar m) -> F) ->
            all n ex k.n<=k & 
                       all b,c.Lh b=k -> Lh c=k -> t b -> t c -> 
                       b bar n=c bar n"))
(assume "PFan" "t" "Tree t" "EffUniq t")
(assume "n")
; We apply PFan to ss_t = { bc | t b impb t c impb False }
; So we assert its conclusion
(assert (pf "ex k.
          all gh.
           ((([i]left(gh i))fbar n)=
            (([i]right(gh i))fbar n) -> F) -> 
           ([bc]t(([pq]left pq)map bc)impb t(([pq]right pq)map bc)impb False)
           (gh fbar k)"))
 (use-with
  "PFan"
  (pt "n")
  (pt "[bc]t(([pq]left pq)map bc)impb t(([pq]right pq)map bc)impb False")
  "?" "?")
 (drop "PFan")
 ; The first premise follows from Tree t
 (ng #t)
 (add-global-assumption "FanBoundAux1"
      (pf "all t.Tree t -> all bc,n.
        n<=Lh bc -> 
        t(([pq0]left pq0)map bc bar n)impb 
        t(([pq0]right pq0)map bc bar n)impb False -> 
        t(([pq0]left pq0)map bc)impb t(([pq0]right pq0)map bc)impb False"))
 (use-with "FanBoundAux1" (pt "t") "Tree t")
 ; (drop "Tree t")
 ; The second premise follows from EffUniq t.  We assert its conclusion
 (assume "gh" "ghdiff")
 (assert
  (pf "ex m.t(([i]left(gh i))fbar m) -> t(([i]right(gh i))fbar m) -> F"))
  (use-with "EffUniq t" (pt "[i]left(gh i)") (pt "[i]right(gh i)")
	    (pt "n") "ghdiff")
  (drop "EffUniq t")
 (assume "ExHyp")
 (by-assume-with "ExHyp" "m" "ExHypInst")
 (ex-intro (pt "m"))
 (ng #t)
 (assume "H1" "H2")
 (use "ExHypInst")
 (use "H1")
 (use "H2")
(assume "PFanConcl")
(drop "PFan" "EffUniq t")
(by-assume-with "PFanConcl" "k" "PFanBound k")
(ex-intro (pt "n max k"))
; (ex-intro (pt "n+k+1"))
(split)
(use "NatMaxUB1")
; (use "Truth-Axiom")
(assume "b" "c" "H1" "H2" "H3" "H4")
(inst-with-to
 "PFanBound k"
 (pt "[i][if (i<n+k+1) (b__i@c__i) (True@True)]")
 "H")
(ng "H")
(simphyp "H" "=FbarIf")
(simphyp 11 "=FbarIf")
(simphyp 12 "=FbarIf")
(simphyp 13 "=FbarIf")
(drop "H" 11 12 13)
(use "Stab")
(assume "NegEq")
(inst-with 14 "?" "?")
(use 16)
(add-global-assumption
 "FanBoundAux4" (pf "all t,k,b(Tree t -> k<=Lh b -> t b -> t(b bar k))"))
(use "FanBoundAux4")
(use "Tree t")
(simp "H2")
(use "NatMaxUB2")
(use "H4")
(use "NegEq")
(use "FanBoundAux4")
(use "Tree t")
(simp "H1")
(use "NatMaxUB2")
(use "H3")
; k<=Succ(n+k)
(add-global-assumption
 "FanBoundAux5" (pf "all n,k k<=Succ(n+k)"))
(use "FanBoundAux5")
(use "FanBoundAux5")
(add-global-assumption
 "FanBoundAux6" (pf "all n,k n<=Succ(n+k)"))
(use "FanBoundAux6")
(use "FanBoundAux6")
; Proof finished.
(save "FanBound")


(add-var-name
 "pfan"
 (py "nat=>(list(boole@@boole)=>boole)=>((nat=>boole@@boole)=>nat)=>nat"))

(add-var-name "uniq" (py "(nat=>boole)=>(nat=>boole)=>nat=>nat"))

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

; [pfan0,r1,uniq2,n3]
;  n3 max 
;  pfan0 n3
;  ([bc4]r1(([pq5]left pq5)map bc4)impb r1(([pq5]right pq5)map bc4)impb False)
;  ([gh4]uniq2([n5]left(gh4 n5))([n5]right(gh4 n5))n3)

; We are given a functional pfan0 realizing PFan, a tree r1, a
; realizer uniq2 of the effective uniqueness property and a number n3.
; Take the max of n3 and the result of applying pfan0 to this number,
; the set of all pair nodes whose left and right parts cannot both be
; in r1, and the functional mapping a pair path to the result of
; applying uniq2 to it and this number.


; Construction of the path

; "Path"
(set-goal
 (pf "all t,ks,as(
 Tree t -> 
 all n n<=ks n -> 
 all n,b,c(Lh b=ks n -> Lh c=ks n -> t b -> t c -> b bar n=c bar n) -> 
 all n ks n<=ks(n+1) -> 
 all n Lh(as n)=n -> all n t(as n) -> ex f all n t(f fbar n))"))
(assume "t" "ks" "as" "Tree t" "Incr" "FanBd" "Mon" "Inf1" "Inf2")

; Take f n := (b_{n+1})__n, with b_n := as(ks n)bar n.
(ex-intro (pt "[n](as(ks(Succ n))bar Succ n)__n"))

; We assert Path: all n f fbar n=b__n
(assert (pf "all n(([n](as(ks(Succ n))bar Succ n)__n)fbar n)=as(ks n)bar n"))
 (ind)
 (ng #t)
 (use "Truth-Axiom")
 (assume "n" "IH")
 (ng #t)
 (simp "IH")
 ; ?: as(ks n)bar n=as(ks(Succ n))bar n
 ; This follows from FanBd and (2)
 (add-global-assumption "ListBooleTrans"
      (pf "all a1,a2,a3(a1=a2 -> a2=a3 -> a1=a3)"))
 (use "ListBooleTrans" (pt "as(ks(Succ n))bar(Succ n) bar n"))
 ; ?: as(ks n)bar n=as(ks(Succ n))bar Succ n bar n 
 ; Now as(ks n)=as(ks(Succ n))bar(ks n) follows from FanBd, because both
 ; are of length (ks n) and in t
 (simp (pf "as(ks n)bar n=as(ks(Succ n))bar(ks n)bar n"))
 ; ?: as(ks(Succ n))bar ks n bar n=as(ks(Succ n))bar Succ n bar n
 ; We now need to apply ListBarBar twice
 (pp "ListBarBar")
 (assert (pf "ks n=n+((ks n)--n)"))
  (add-global-assumption "PathAux1" (pf "all n,m.n<=m -> m=n+(m--n)"))
  (use "PathAux1")
  (use "Incr")
 (assume "EqHyp1")
 (simp "EqHyp1")
 (simp "ListBarBar")
 (simp-with "<-" "ListBarBar" (pt "as(ks(Succ n))") (pt "n") (pt "1"))
 (assert (pf "n+1=Succ n"))
  (use "Truth-Axiom")
 (assume "EqHyp2")
 (simp "EqHyp2")
 (ng)
 (use "Truth-Axiom")
 (use "FanBd")
 (use "Inf1")
 (use "Truth-Axiom")
 (use "Inf2")
 (add-global-assumption
  "TreeClosed" (pf "all t,a,n(Tree t -> t a -> t(a bar n))"))
 (use "TreeClosed")
 (use "Tree t")
 (use "Inf2")
 (use "ListBarBarCor")
 (use "Truth-Axiom")

; ?_4: all n (([n](as(ks(Succ n))bar Succ n)__n)fbar n)=as(ks n)bar n -> 
;      all n t(([n](as(ks(Succ n))bar Succ n)__n)fbar n) from

(assume "H1")
(assume "n")
(simp "H1")

; ?_75: t(as(ks n)bar n) from
 (inversion "Tree t")
 (assume "t1" "H2" "EqHyp")
 (simphyp "H2" "<-" "EqHyp")
 (assert (pf "all a,n(n<Lh a -> t a impb t(a bar n))"))
 (assume "a" "n1")
 (use-with "AllBNatElim"
	   (pt "[n]t a impb t(a bar n)")
	   (pt "Lh a")
	   "?" (pt "n1"))
 (use 10)
 (drop 10)
 (assume "H3")
 (assert (pf "all a,n(n<=Lh a -> t a impb t(a bar n))"))
  (assume "a" "n1" "n1<=Lh a")
  (use "NatLeCases" (pt "Lh a") (pt "n1"))
  (use "n1<=Lh a")
  (use "H3")
  (assume "n1=Lh a")
  (simp "n1=Lh a")
  (simp "ListLhBar")
  (assume "t a")
  (use "t a")
  (use "Truth-Axiom")
 (assume "H4")
 (use "H4")
 (simp "Inf1")
 (use "Incr")
 (use "Inf2")
; Proof finished.
(save "Path")

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

; [r0,ns1,as2,n3]as2(ns1(Succ n3))__n3

; We are given a tree r0, a sequence ns1 of numbers provided by
; FanBound, a sequence as2 of nodes witnessing the infinity of r0, and
; an argument n3 for the path to be constructed.  Take the n3-th
; element of the sequence as2 applied to ns1(n3+1).

; (pp "Path")
; (pp "FanBound")
; (pp "FanImpPFan")

; We will need AC to construct ks and as

(add-global-assumption
 "ACNat" (pf "all n ex k (Pvar nat nat)^ n k ->
               ex ks all n (Pvar nat nat)^ n(ks n)") 1)

(add-global-assumption
 "ACListBoole"
 (pf "all n ex a (Pvar nat list boole)^ n a ->
       ex as all n (Pvar nat list boole)^ n(as n)") 1)

; We also need the canonical monotone upper bound (Mon ks0) of ks0

(add-program-constant "Mon" (py "(nat=>nat)=>nat=>nat") t-deg-one)

; To block later unfoldings have no rules for "Mon", but add its
; needed properties as global assumptions.

(add-global-assumption "MonIncr" (pf "all ns,n ns n<=Mon ns n"))
(add-global-assumption "MonMon" (pf "all ns,n Mon ns n<=Mon ns(Succ n)"))
 

; "FanImpWKL!"
(set-goal
 (pf "all s^(
all f ex m s^(f fbar m) -> ex k all f exca m(m<k+1 ! s^(f fbar m))) -> 
all t(
 Tree t -> 
 all n ex a(Lh a=n & t a) -> 
 all g,h,n(
  ((g fbar n)=(h fbar n) -> F) -> ex m(t(g fbar m) -> t(h fbar m) -> F)) -> 
 ex f all n t(f fbar n))"))
(assume "Fan" "t" "Tree t" "Inf t" "EffUniq t")
; We assert "Inf t" in the form "ex as ..."
(assert (pf "ex as all n(Lh(as n)=n & t(as n))"))
 (use-with "ACListBoole"
	   (make-cterm (pv "n") (pv "a") (pf "Lh a=n & t a")) "?")
 (use "Inf t")
(assume "Exas")
(by-assume-with "Exas" "as" "ExHyp1")
; We assert the conclusion of "FanBound" in the form "ex ks ..."
(assert
 (pf "ex ks all n(n<=ks n & all b,c(Lh b=ks n -> Lh c=ks n -> t b -> t c -> 
                                    b bar n=c bar n))"))
 (use-with
  "ACNat"
  (make-cterm (pv "n") (pv "k")
	      (pf "n<=k & all b,c(Lh b=k -> Lh c=k -> t b -> t c -> 
                                  b bar n=c bar n)")) "?")
 (use "FanBound")
 (use "FanImpPFan")
 (use "Fan")
 (use "Tree t")
 (use "EffUniq t")
(assume "Exks")
(by-assume-with "Exks" "ks0" "ExHyp2")
; ex f all n t(f fbar n)
; (pp "Path")
; all t,ks,as(
;  Tree t -> 
;  all n n<=ks n -> 
;  all n,b,c(Lh b=ks n -> Lh c=ks n -> t b -> t c -> b bar n=c bar n) -> 
;  all n ks n<=ks(n+1) -> 
;  all n Lh(as n)=n -> all n t(as n) -> ex f all n t(f fbar n))
(use "Path" (pt "Mon ks0") (pt "as"))
(use "Tree t")
(assume "n")
(use "NatLeTrans" (pt "ks0 n"))
(use "ExHyp2")
(use "MonIncr")
(assume "n")
(assume "b" "c" "Lh b=Mon ks0 n" "Lh c=Mon ks0 n" "t b" "t c")
(assert (pf "b bar(ks0 n)bar n=b bar n"))
 (use "ListBarBarCor")
 (use "ExHyp2")
(assume "EqHyp1")
(simp "<-" "EqHyp1")
(assert (pf "c bar(ks0 n)bar n=c bar n"))
 (use "ListBarBarCor")
 (use "ExHyp2")
(assume "EqHyp2")
(simp "<-" "EqHyp2")
(inst-with-to "ExHyp2" (pt "n") 'right "ExH2")
(use "ExH2")
(use "Truth-Axiom")
(use "Truth-Axiom")
(add-global-assumption
 "FanImpWKLUAux2"
 (pf "all t,b,n,m(Tree t -> t b -> Lh b=m -> n<=m -> t(b bar n))"))
(use "FanImpWKLUAux2" (pt "Mon ks0 n"))
(use "Tree t")
(use "t b")
(use "Lh b=Mon ks0 n")
(use "MonIncr")
(use "FanImpWKLUAux2" (pt "Mon ks0 n"))
(use "Tree t")
(use "t c")
(use "Lh c=Mon ks0 n")
(use "MonIncr")
(use "MonMon")
(assume "n")
(use "ExHyp1")
(assume "n")
(use "ExHyp1")
; Proof finished.
(save "FanImpWKLU")

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

; [fan0,r1,as2,uniq3]
;  cPath r1(Mon(cACNat(cFanBound(cFanImpPFan fan0)r1 uniq3)))
;  (cACListBoole as2)

; We can ignore "cACNat" and "cACListBoole", for they are identities.

; We can unfold the contents of the auxiliary propositions:

(animate "FanImpPFan")
(animate "FanBound")
(animate "Path")

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

; [fan0,r1,as2,uniq3,n4]
;  cACListBoole as2
;  (Mon
;   (cACNat
;    ([n6]
;      n6 max
;      (fan0
;       ([a7]
;         AllBNat n6
;         ([n8]
;           (a7__(n8+n8)=a7__Succ(n8+n8)impb False)impb 
;           r1(([pq9]left pq9)map Half Lh a7 unzip a7)impb 
;           r1(([pq9]right pq9)map Half Lh a7 unzip a7)impb False))
;       ([f7]
;         [if (AllBNat n6([n8]f7(n8+n8)=f7(Succ(n8+n8))))
;           (n6+n6)
;           (uniq3([n8]f7(n8+n8))([n8]f7(Succ(n8+n8)))n6+n6+
;           uniq3([n8]f7(n8+n8))([n8]f7(Succ(n8+n8)))n6+
;           n6)])+
;       n6)))
;   (Succ n4))__n4


; WKL! implies Fan
; ================

; prec is the tree ordering on boolean trees, based on True<False.  It
; suffices to have it work correctly on nodes on the same length only.

(add-program-constant "Prec" (py "list boole=>list boole=>boole") t-deg-one)

(add-token
 "prec" 'rel-op
 (lambda (x y)
   (mk-term-in-app-form
    (make-term-in-const-form (pconst-name-to-pconst "Prec")) x y)))

(add-display
 (py "boole")
 (lambda (x)
   (if (term-in-app-form? 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=? "Prec"
			    (const-to-name (term-in-const-form-to-const op)))
		  (= 2 (length args)))
	     (list 'rel-op "prec"
		   (term-to-token-tree (car args))
		   (term-to-token-tree (cadr args)))
	     #f))
       #f)))

(add-computation-rule (pt "(Nil boole)prec b") (pt "False"))
(add-computation-rule (pt "a::p prec (Nil boole)")  (pt "False"))

(add-computation-rule
 (pt "a::p prec b::q")
 (pt "(a=b impb p impb q)impb a prec b"))

; We need some recursive functions:

; (UL n r) (for "uppermost leftmost"): If n is big (i.e., all a with
; Lh a=n are in r), it is the uppermost leftmost node not in r.  So
; all b preceeding (UL n r) (hence of the same length) are in r, but
; (UL n r) is not.  Moreover all b of length Lh(UL n r)+1 are in r.
; If n is not big, UL n r can be arbitrary.

; LExt a n (for "left extension"): The extension of a by True's up to
; length n, if Lh a<=n, and an arbitrary node of length n otherwise.

; BMu n r (for "bounded mu operator"): The least b (w.r.t. prec) of
; length n such that b is not in r, if there is one, and arbitrary
; otherwise.

; Ext r (for "extension"): The extension of the complement of r, that
; is, the set of all b such that if b is in r, then b is big and b =
; LExt(UL(Lh b)r)(Lh b).

; Up s: The upwards closure of s.

(add-program-constant
 "UL" (py "nat=>(list boole=>boole)=>list boole") t-deg-one)

(add-program-constant "LExt" (py "list boole=>nat=>list boole") t-deg-one)

(add-program-constant
 "BMu" (py "nat=>(list boole=>boole)=>list boole") t-deg-one)

(add-program-constant
 "Ext" (py "(list boole=>boole)=>list boole=>boole") t-deg-one)

(add-program-constant
 "Up" (py "(list boole=>boole)=>list boole=>boole") t-deg-one)

; Properties

; "UpElim"
(add-global-assumption
 "UpElim" (pf "all s,a(Up s a -> exca m(m<Lh a+1 ! s(a bar m)))"))

; "UpExtends"
(add-global-assumption "UpExtends" (pf "all s,a(s a -> Up s a)"))

; "UpUpclosed"
(add-global-assumption
  "UpUpclosed" (pf "all s,f,n,m(n<=m -> Up s(f fbar n) -> Up s(f fbar m))"))

; "ExtProp"
(add-global-assumption
 "ExtProp" (pf "all r,b,m(Ext r b ->  r b -> Lh b=m -> AllBList m r)"))

; "ExtTree"
(add-global-assumption "ExtTree" (pf "all s Tree(Ext(Up s))"))

; "LhLExt"
(add-global-assumption "LhLExt" (pf "all a,n Lh(LExt a n)=n"))

; "ExtLExt"
(add-global-assumption
 "ExtLExt" (pf "all s,n(AllBList n(Up s) -> Ext(Up s)(LExt(UL n(Up s))n))"))

; "LhBMu"
(add-global-assumption "LhBMu" (pf "all r,n Lh(BMu n r)=n"))

; "ExtBMu"
(add-global-assumption
 "ExtBMu" (pf "all s,n((AllBList n(Up s) -> F) -> Ext(Up s)(BMu n(Up s)))"))

; "ExtUniqLext"
(add-global-assumption
 "ExtUniqLext" (pf "all r,b(Ext r b -> r b -> b=LExt(UL(Lh b)r)(Lh b))"))

; "ExtUniq"
(add-global-assumption
 "ExtUniq" (pf "all r,b,c(Ext r b -> Ext r c -> r b -> r c -> b=c)"))

; "ListFbarBar"
(add-global-assumption
 "ListFbarBar" (pf "all f,n,m(n<=m -> (f fbar m)bar n=(f fbar n))"))

; "ListFbarBarCor"
(add-global-assumption
 "ListFbarBarCor"
 (pf "all g,h,n,m(n<=m -> (g fbar m)bar n=(h fbar m)bar n -> 
                  (g fbar n)=(h fbar n))"))

; "ListBoole="
(add-global-assumption "ListBoole=" (pf "all a^(E a^ -> a^ =a^)"))


; "WKLUImpFan"
(set-goal
 (pf "all t(
 Tree t -> 
 all n ex a(Lh a=n & t a) -> 
 all g,h,n(
  ((g fbar n)=(h fbar n) -> F) -> ex m(t(g fbar m) -> t(h fbar m) -> F)) -> 
 ex f all n t(f fbar n)) -> 
all s(
 all f ex m s(f fbar m) ->
 ex k all f(all m(m<k+1 -> s(f fbar m) -> F) -> F))"))
(assume "WKL!" "s" "Bar s")
; It suffices to construct big k in (Up s)
(cut (pf "ex k AllBList k(Up s)"))
; (drop "WKL!")
(assume "ExBig")
(by-assume-with "ExBig" "k" "kBig")
(ex-intro (pt "k"))
(cut (pf "all a(Lh a=k -> exca m(m<Lh a+1 ! s(a bar m)))"))
; This will follows from kBig
(assume "kBigConseq" "f")
(inst-with-to "kBigConseq" (pt "f fbar k") "H")
(inst-with-to "H" "Truth-Axiom" "H0")
; (drop "H")
; (simphyp "H0" (pf "all m(m<k+1 -> ((f fbar k)bar m)=(f fbar m))"))
(assume "H1")
(use "H0")
(assume "m" "m<k+1")
(simp (pf "(f fbar k)bar m=(f fbar m)"))
(use "H1")
(use "m<k+1")
; (f fbar k)bar m=(f fbar m) from m<k+1
(add-global-assumption
 "WKL!ImpFanAux1" (pf "all f,k,m(m<k+1 -> (f fbar k)bar m=(f fbar m))"))
(use "WKL!ImpFanAux1")
(use "m<k+1")
 ; We now prove the claim cut in above from kBig
(assume "a" "Lh a=k")
(assert (pf "all a(Lh a=k -> Up s a)"))
 (use "AllBListElim")
 (use "kBig")
(assume "H1")
(inst-with-to "H1" (pt "a") "Lh a=k" "Up s a")
; (drop "H1")
; (drop "kBig")
(use "UpElim")
(use "Up s a")

; ?_4: ex k AllBList k(Up s).  That is, ex k Big_r k
(inst-with "WKL!" (pt "Ext(Up s)") "?" "?" "?")
(by-assume-with 3 "f" "fPath")
(inst-with-to "Bar s" (pt "f") "fHit")
; (drop "WKL!")
; (drop "Bar s")
(by-assume-with "fHit" "m" "s(f fbar m)")
; ...hence it hits (Up s)
(assert (pf "Up s(f fbar m)"))
 (use "UpExtends")
 (use "s(f fbar m)")
(assume "Up s(f fbar m)")
; ...and at this length we have the desired big k
(ex-intro (pt "m"))
(assert (pf "Ext(Up s)(f fbar m)"))
 (use "fPath")
(assume "Ext(Up s)(f fbar m)")
(use "ExtProp" (pt "f fbar m"))
(use "Ext(Up s)(f fbar m)")
(use "Up s(f fbar m)")
(use "Truth-Axiom")

(use "ExtTree")
; We now prove that Ext(Up s)a is infinite
; ?_33: all n ex a(Lh a=n & Ext(Up s)a)
(assume "n")
(ex-intro (pt "[if (AllBList n(Up s)) (LExt(UL n(Up s))n) (BMu n(Up s))]"))
(cases (pt "AllBList n(Up s)"))
(assume "Big n")
(ng #t)
(split)
(use "LhLExt")
(use "ExtLExt")
(use "Big n")
(assume "Big n -> F")
(ng #t)
(split)
(use "LhBMu")
(use "ExtBMu")
(use "Big n -> F")

; We now prove that Ext(Up s)a is infinite
; ?_34: all g,h,n(
;        ((g fbar n)=(h fbar n) -> F) -> 
;        ex m(Ext(Up s)(g fbar m) -> Ext(Up s)(h fbar m) -> F))
(assume "g" "h" "n" "ghdiff")
(inst-with-to "Bar s" (pt "g") "gHit")
(by-assume-with "gHit" "m1" "gBar")
(inst-with-to "Bar s" (pt "h") "hHit")
(by-assume-with "hHit" "m2" "hBar")
(ex-intro (pt "m1 max m2 max n"))
(assume "gmaxExt" "hmaxExt")
(use "ghdiff")
(assert (pf "Up s(g fbar m1 max m2 max n)"))
 (use "UpUpclosed" (pt "m1"))
 (use "NatLeTrans" (pt "m1 max m2"))
 (use "NatMaxUB1")
 (use "NatMaxUB1")
 (use "UpExtends")
 (use "gBar")
(assume "gBarMax")
(assert (pf "Up s(h fbar m1 max m2 max n)"))
 (use "UpUpclosed" (pt "m2"))
 (use "NatLeTrans" (pt "m1 max m2"))
 (use "NatMaxUB2")
 (use "NatMaxUB1")
 (use "UpExtends")
 (use "hBar")
(assume "hBarMax")
(assert (pf "(g fbar m1 max m2 max n)=(h fbar m1 max m2 max n)"))
 (use "ExtUniq" (pt "Up s"))
 (use "gmaxExt")
 (use "hmaxExt")
 (use "gBarMax")
 (use "hBarMax")
(assume "ghIdMax")
(use "ListFbarBarCor" (pt "m1 max m2 max n"))
(use "NatMaxUB2")
(simp "ghIdMax")
(use "ListBoole=")
(use "Truth-Axiom")
; Proof finished.
(save "WKLUImpFan")

(add-var-name
 "wklu"
 (py "(list boole=>boole)=>
       (nat=>list boole)=>
       ((nat=>boole)=>(nat=>boole)=>nat=>nat)=>
       nat=>boole"))

(add-var-name "hit" (py "(nat=>boole)=>nat"))

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

; [wklu0,r1,hit2]
;  hit2
;  (wklu0(Ext(Up r1))
;   ([n4][if (AllBList n4(Up r1)) (LExt(UL n4(Up r1))n4) (BMu n4(Up r1))])
;   ([f4,f5]NatMax(hit2 f4 max hit2 f5)))

; We are given a functional wklu0 realizing WKL!, a bar r1 and a
; witness hit2 that each path hits the bar.  Apply hit2 to the result
; of applying wklu0 to (1) the extension of the complement of the
; upwards closure of r1, (2) a witness for its infinity and (3) a
; witness for the effective uniqueness of its paths.  For (2), we are
; given n4.  If n4 it is big, take the left extension (by True's) of
; the uppermost leftmost node in the tree.  If n4 is not big, take the
; first node of length n4 in the tree.  For (3), we are given f4 and
; f5.  Take the function mapping n to the max of itself and what the
; witness for infinity gives at f4 and f5.

(deanimate "FanImpPFan")
(deanimate "FanBound")
(deanimate "Path")
