; $Id: hofmann.scm,v 1.2 2008/01/25 13:30:24 logik Exp $

; Proof of f continuous -> f circ f continuous, also with search 

(add-tvar-name "real" "open")
(add-var-name "x" "y" (py "real"))
(add-var-name "f" (py "real=>real"))
(add-var-name "U" "V" "W" (py "open"))
(add-predconst-name "ee" (make-arity (py "real") (py "open") (py "boole")))

(add-token
 "in"
 'pred-infix
 (lambda (x y)
   ((string-and-arity-to-predconst-parse-function
     "ee" (make-arity (py "real") (py "open")))
    (- 1) x y)))

(add-predconst-display "ee" 'pred-infix "in")

; An explicit proof,  with all steps shown.
; "ContLemma"
(set-goal
 (pf "all f.
      (all x,V.f x in V -> ex U.x in U & all y.y in U -> f y in V) -> 
      all x,W.f(f x)in W -> ex U.x in U & all y.y in U -> f(f y)in W"))
(assume "f" "fCont" "x" "W" "Hyp1")

(inst-with-to "fCont" (pt "f x") (pt "W") "Hyp2")
(inst-with-to "Hyp2" "Hyp1" "W-ExHyp")
(drop "Hyp2" "Hyp1")
(by-assume-with "W-ExHyp" "V" "VHyp")
; (search) would finish the proof here.

(inst-with-to "fCont" (pt "x") (pt "V") "Hyp3")
(assert (pf "ex U.x in U & all y.y in U -> f y in V"))
 (use "Hyp3")
 (use "VHyp")
 (assume "V-ExHyp")

; goal ex U.x in U & all y.y in U -> f(f y)in W

(by-assume-with "V-ExHyp" "U" "UHyp")
(ex-intro (pt "U"))
(split)
(use "UHyp")
(assume "y" "yHyp")
(use "VHyp")
(use "UHyp")
(use "yHyp")

(save "ContLemma")

; (check-and-display-proof (theorem-name-to-proof "ContLemma"))
; (proof-to-expr (np (theorem-name-to-proof "ContLemma")))

; This proof is constructive, hence has some computational content:
(add-var-name "M" (py "real=>open=>open")) ;M for modulus

(pp (nt (proof-to-extracted-term (theorem-name-to-proof "ContLemma"))))
; [f0,M1,x2,U3]M1 x2(M1(f0 x2)U3)

; (set! VERBOSE-SEARCH #t)

; One can also proof this for the classical existential quantifier excl.
(set-goal
 (pf "all f.
      (all x,V.f x in V -> excl U.x in U & all y.y in U -> f y in V) -> 
      all x,W.f(f x)in W -> excl U.x in U & all y.y in U -> f(f y)in W"))
(search) ;10 ms elapsed cpu time
; (display-normalized-proof)

; .....all x,V.(f x)in V -> excl U.x in U & (all y.y in U -> (f y)in V) |Hyp6
; .....f x
; ....all V.(f(f x))in V -> excl U.(f x)in U & (all y.y in U -> (f y)in V)|all-
; ....W
; ...(f(f x))in W -> excl U.(f x)in U & (all y.y in U -> (f y)in W) |all-
; ...(f(f x))in W |Hyp7
; ..excl U.(f x)in U & (all y.y in U -> (f y)in W) |imp-
; ........all x,V.(f x)in V -> excl U.x in U & (all y.y in U -> (f y)in V)|Hyp6
; ........x
; .......all V.(f x)in V -> excl U.x in U & (all y.y in U -> (f y)in V) |all-
; .......U
; ......(f x)in U -> excl U32.x in U32 & (all y.y in U32 -> (f y)in U) |all-
; .......(f x)in U & (all y.y in U -> (f y)in W) |Hyp9
; ......(f x)in U |and- left
; .....excl U32.x in U32 & (all y.y in U32 -> (f y)in U) |imp-
; .........all U.x in U & (all y.y in U -> (f(f y))in W) -> bot |Hyp8
; .........U31
; ........x in U31 & (all y.y in U31 -> (f(f y))in W) -> bot |all-
; ..........x in U31 & (all y.y in U31 -> (f y)in U) |Hyp10
; .........x in U31 |and- left
; ..............(f x)in U & (all y.y in U -> (f y)in W) |Hyp9
; .............all y.y in U -> (f y)in W |and- right
; .............f y
; ............(f y)in U -> (f(f y))in W |all-
; ...............x in U31 & (all y.y in U31 -> (f y)in U) |Hyp10
; ..............all y.y in U31 -> (f y)in U |and- right
; ..............y
; .............y in U31 -> (f y)in U |all-
; .............y in U31 |Hyp11
; ............(f y)in U |imp-
; ...........(f(f y))in W |imp-
; ..........y in U31 -> (f(f y))in W |imp+ Hyp11
; .........all y.y in U31 -> (f(f y))in W |all+
; ........x in U31 & (all y.y in U31 -> (f(f y))in W) |and+
; .......bot |imp-
; ......x in U31 & (all y.y in U31 -> (f y)in U) -> bot |imp+ Hyp10
; .....all U31.x in U31 & (all y.y in U31 -> (f y)in U) -> bot |all+
; ....bot |imp-
; ...(f x)in U & (all y.y in U -> (f y)in W) -> bot |imp+ Hyp9
; ..all U.(f x)in U & (all y.y in U -> (f y)in W) -> bot |all+
; .bot |imp-
; excl U.x in U & (all y.y in U -> (f(f y))in W) |imp+ Hyp8
