diff --git a/.github/workflows/regression-tests.yml b/.github/workflows/regression-tests.yml new file mode 100644 index 00000000..02f29ef9 --- /dev/null +++ b/.github/workflows/regression-tests.yml @@ -0,0 +1,14 @@ +name: Regression Tests + +on: + push: + branches: [master] + pull_request: + branches: [master] + +jobs: + test: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v6 + - run: ./test.sh \ No newline at end of file diff --git a/.gitignore b/.gitignore index e87eb6f8..8b0e4b53 100644 --- a/.gitignore +++ b/.gitignore @@ -31,4 +31,8 @@ cake-x64-64.tar.gz cake-x64-64 cake config_enc_str.txt -checkpoint \ No newline at end of file +checkpoint + +candle_boot.ml +types.txt +candle_insulate.ml \ No newline at end of file diff --git a/100/cubedissection.ml b/100/cubedissection.ml new file mode 100644 index 00000000..6f66d24c --- /dev/null +++ b/100/cubedissection.ml @@ -0,0 +1,1612 @@ +(* ========================================================================= *) +(* Impossibility of cube dissection into finitely many smaller cubes of *) +(* pairwise distinct sizes ("cubing the cube"), originally proved by *) +(* R. L. Brooks, C. A. B. Smith, A. H. Stone and W. T. Tutte, *) +(* "The Dissection of Rectangles into Squares", *) +(* Duke Mathematical Journal, vol. 7 (1940), pp. 312-340. *) +(* *) +(* The proof follows the elegant argument presented in J. E. Littlewood, *) +(* "A Mathematician's Miscellany" (CUP, 1953), revised edition *) +(* "Littlewood's Miscellany" (ed. B. Bollobas, CUP, 1986), pp. 28-29. *) +(* *) +(* Formalized in HOL Light by Claude Code (Opus 4.6), February 2026. *) +(* ========================================================================= *) + +needs "Multivariate/integration.ml";; + +(* ------------------------------------------------------------------------- *) +(* Cube-shaped boxes in R^N (we only really use it for R^3 here) *) +(* ------------------------------------------------------------------------- *) + +let cube = new_definition + `cube k <=> + ?a:real^N d. &0 < d /\ k = interval[a,a + d % vec 1]`;; + +let CUBE_IMP_NONEMPTY_INTERIOR = prove + (`!k:real^N->bool. cube k ==> ~(interior k = {})`, + SIMP_TAC[cube; LEFT_IMP_EXISTS_THM; INTERIOR_INTERVAL] THEN + SIMP_TAC[INTERVAL_NE_EMPTY; VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT] THEN + REWRITE_TAC[VEC_COMPONENT] THEN REAL_ARITH_TAC);; + +let CUBE_IMP_NONEMPTY = prove + (`!k:real^N->bool. cube k ==> ~(k = {})`, + MESON_TAC[CUBE_IMP_NONEMPTY_INTERIOR; INTERIOR_EMPTY]);; + +(* ------------------------------------------------------------------------- *) +(* The length of an interval (first component; we only use it for cubes). *) +(* ------------------------------------------------------------------------- *) + +let interval_length = new_definition + `interval_length (s:real^N->bool) = + if s = {} then &0 + else interval_upperbound s$1 - interval_lowerbound s$1`;; + +let INTERVAL_LENGTH_CUBE = prove + (`!(a:real^N) d. interval_length(interval[a,a + d % vec 1]) = max d (&0)`, + REPEAT GEN_TAC THEN REWRITE_TAC[interval_length] THEN + SIMP_TAC[INTERVAL_UPPERBOUND_NONEMPTY; INTERVAL_LOWERBOUND_NONEMPTY] THEN + REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VEC_COMPONENT; + INTERVAL_EQ_EMPTY; REAL_ADD_SUB; REAL_MUL_RID; + REAL_ARITH `max d (&0) = if d < &0 then &0 else d`] THEN + ASM_CASES_TAC `d:real < &0` THEN + ASM_REWRITE_TAC[REAL_ARITH `a + d < a <=> d < &0`] THEN + ASM_MESON_TAC[LE_REFL; DIMINDEX_GE_1]);; + +let INTERVAL_LENGTH_CUBE_COMPONENT = prove + (`!(k:real^N->bool) i. + cube k + ==> interval_upperbound k$i - interval_lowerbound k$i = + interval_length k`, + REWRITE_TAC[cube] THEN REPEAT STRIP_TAC THEN + REWRITE_TAC[interval_length] THEN ONCE_REWRITE_TAC[GSYM COND_SWAP] THEN + ASM_SIMP_TAC[INTERVAL_NE_EMPTY; VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID; REAL_LE_ADDR; REAL_LT_IMP_LE; + INTERVAL_LOWERBOUND; INTERVAL_UPPERBOUND] THEN REAL_ARITH_TAC);; + +let INTERVAL_LENGTH_CUBE_POS = prove + (`!(a:real^N) d. &0 < d ==> interval_length(interval[a, a + d % vec 1]) = d`, + REWRITE_TAC[INTERVAL_LENGTH_CUBE] THEN REAL_ARITH_TAC);; + +let VECTOR2_CUBE = prove + (`!c:real^3 s. vector[c$2 + s; c$3 + s]:real^2 = + vector[c$2; c$3] + s % vec 1`, + SIMP_TAC[CART_EQ; DIMINDEX_2; FORALL_2; VECTOR_ADD_COMPONENT; + VECTOR_MUL_COMPONENT; VEC_COMPONENT; VECTOR_2; REAL_MUL_RID]);; + +let CUBE_BOUNDS_TAC = + ASM_SIMP_TAC[INTERVAL_LOWERBOUND; INTERVAL_UPPERBOUND; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VEC_COMPONENT; + REAL_MUL_RID; REAL_LE_ADDR; REAL_LT_IMP_LE];; + +let MESON_ASSUME_TAC lemmas tm = + SUBGOAL_THEN tm ASSUME_TAC THENL [ASM_MESON_TAC lemmas; ALL_TAC];; + +(* ------------------------------------------------------------------------- *) +(* Dissection of a set into pairwise differently-sized nonempty cubes. *) +(* ------------------------------------------------------------------------- *) + +let cube_dissection = new_definition + `cube_dissection (d:(real^N->bool)->bool) <=> + d division_of UNIONS d /\ + (!k. k IN d ==> cube k) /\ + pairwise (\k k'. ~(interval_length k = interval_length k')) d`;; + +(* ------------------------------------------------------------------------- *) +(* A point on the boundary of a division element must belong to another. *) +(* ------------------------------------------------------------------------- *) + +let POINT_IN_MULTIPLE_DIVISION_OF_GEN = prove + (`!D a b u v (x:real^N) i. + D division_of UNIONS D /\ + interval[u,v] IN D /\ x IN interval[u,v] /\ + interval[a,b] SUBSET UNIONS D /\ + interval[u,v] SUBSET interval[a,b] /\ + 1 <= i /\ i <= dimindex(:N) /\ + a$i < x$i /\ x$i < b$i /\ (x$i = u$i \/ x$i = v$i) + ==> ?j'. j' IN D /\ ~(j' = interval[u,v]) /\ x IN j'`, + REPEAT GEN_TAC THEN DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC) THEN + SUBGOAL_THEN `(x:real^N) IN UNIONS(D DELETE interval[u,v])` MP_TAC THENL + [ALL_TAC; REWRITE_TAC[IN_UNIONS; IN_DELETE] THEN MESON_TAC[]] THEN + MATCH_MP_TAC(MESON[CLOSURE_CLOSED] + `closed (s:real^N->bool) /\ (x:real^N) IN closure s ==> x IN s`) THEN + CONJ_TAC THENL [MATCH_MP_TAC CLOSED_UNIONS THEN + ASM_MESON_TAC[FINITE_DELETE; IN_DELETE; division_of; CLOSED_INTERVAL]; + ALL_TAC] THEN MATCH_MP_TAC(MESON[SUBSET_CLOSURE; SUBSET] + `UNIONS (D:(real^N->bool)->bool) DIFF s SUBSET UNIONS(D DELETE s) /\ + (x:real^N) IN closure(UNIONS D DIFF s) + ==> x IN closure(UNIONS(D DELETE s))`) THEN + CONJ_TAC THENL [SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `interval[a:real^N,b] DIFF interval[u,v] SUBSET + UNIONS D DIFF interval[u:real^N,v]` MP_TAC THENL + [UNDISCH_TAC `interval[a:real^N,b] SUBSET UNIONS D` THEN SET_TAC[]; + ALL_TAC] THEN DISCH_THEN(MP_TAC o MATCH_MP SUBSET_CLOSURE) THEN + REWRITE_TAC[SUBSET] THEN DISCH_THEN MATCH_MP_TAC THEN + UNDISCH_TAC `interval[u:real^N,v] SUBSET interval[a:real^N,b]` THEN + UNDISCH_TAC `(x:real^N) IN interval[u:real^N,v]` THEN + REWRITE_TAC[SUBSET_INTERVAL; IN_INTERVAL] THEN DISCH_TAC THEN + ANTS_TAC THENL [ASM_MESON_TAC[REAL_LE_TRANS]; DISCH_TAC] THEN + REWRITE_TAC[CLOSURE_APPROACHABLE] THEN X_GEN_TAC `e:real` THEN + DISCH_TAC THEN REWRITE_TAC[IN_DIFF; IN_INTERVAL] THEN + FIRST_X_ASSUM DISJ_CASES_TAC THENL [EXISTS_TAC + `(lambda j. if j = i then max ((a:real^N)$i) ((u:real^N)$i - e / &2) + else (x:real^N)$j):real^N`; + EXISTS_TAC + `(lambda j. if j = i then min ((b:real^N)$i) ((v:real^N)$i + e / &2) + else (x:real^N)$j):real^N`] THEN SIMP_TAC[LAMBDA_BETA] THEN + (CONJ_TAC THENL [CONJ_TAC THENL + [X_GEN_TAC `j:num` THEN STRIP_TAC THEN + REPEAT(FIRST_X_ASSUM(MP_TAC o SPEC `j:num`)) THEN ASM_REWRITE_TAC[] THEN + COND_CASES_TAC THEN ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC; + DISCH_THEN(MP_TAC o SPEC `i:num`) THEN + ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC]; + ASM_REWRITE_TAC[dist; NORM_LT_SQUARE; dot; GSYM REAL_POW_2] THEN + SIMP_TAC[LAMBDA_BETA; VECTOR_SUB_COMPONENT; IN_NUMSEG] THEN + REWRITE_TAC[COND_RAND; COND_RATOR; REAL_SUB_REFL] THEN + CONV_TAC REAL_RAT_REDUCE_CONV THEN + ASM_SIMP_TAC[SUM_DELTA; IN_NUMSEG; GSYM REAL_LT_SQUARE_ABS] THEN + ASM_REAL_ARITH_TAC]));; + +(* Specialized version when D division_of interval[a,b] *) +let POINT_IN_MULTIPLE_DIVISION_OF = prove + (`!D a b u v (x:real^N) i. + D division_of interval[a,b] /\ + interval[u,v] IN D /\ x IN interval[u,v] /\ + 1 <= i /\ i <= dimindex(:N) /\ + a$i < x$i /\ x$i < b$i /\ (x$i = u$i \/ x$i = v$i) + ==> ?j'. j' IN D /\ ~(j' = interval[u,v]) /\ x IN j'`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + MATCH_MP_TAC POINT_IN_MULTIPLE_DIVISION_OF_GEN THEN + MAP_EVERY EXISTS_TAC [`a:real^N`; `b:real^N`; `i:num`] THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[division_of; SUBSET_REFL]);; + +let CUBE_EXISTS_FORM = prove + (`!D:(real^N->bool)->bool. + cube_dissection D /\ + (!(x:real^N) e. interval[x,x + e % vec 1] IN D /\ + P(interval[x,x + e % vec 1]) + ==> R x e) + ==> (?j. j IN D /\ P j) ==> (?(x:real^N) e. R x e)`, + GEN_TAC THEN STRIP_TAC THEN + DISCH_THEN(X_CHOOSE_THEN `j:real^N->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `cube(j:real^N->bool)` MP_TAC THENL + [ASM_MESON_TAC[cube_dissection]; REWRITE_TAC[cube; LEFT_IMP_EXISTS_THM]] THEN + MAP_EVERY X_GEN_TAC [`xx:real^N`; `ee:real`] THEN STRIP_TAC THEN + EXISTS_TAC `xx:real^N` THEN EXISTS_TAC `ee:real` THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_MESON_TAC[]);; + +let SQUARE_DISSECTION_NONEDGE = prove + (`!D a b j:real^2->bool. + cube_dissection D /\ UNIONS D = interval[a,b] /\ j IN D /\ + (!j'. j' IN D /\ ~(j' = j) + ==> interval_length(j) < interval_length j') + ==> j = interval[a,b] \/ j SUBSET interval(a,b)`, + let iterm n = match n with + 1 -> `interval[x1:real^2,x1 + e1 % vec 1]` + | 2 -> `interval[x2:real^2,x2 + e2 % vec 1]` + | 3 -> `interval[x3:real^2,x3 + e3 % vec 1]` + | 4 -> `interval[x4:real^2,x4 + e4 % vec 1]` in + let itspec [m;n] = SPECL[iterm m; iterm n] in + REPEAT STRIP_TAC THEN + SUBGOAL_THEN `cube(j:real^2->bool)` MP_TAC THENL + [ASM_MESON_TAC[cube_dissection]; REWRITE_TAC[cube; LEFT_IMP_EXISTS_THM]] THEN + MAP_EVERY X_GEN_TAC [`u:real^2`; `d:real`] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC SUBST_ALL_TAC) THEN + FIRST_X_ASSUM(MP_TAC o check(is_forall o concl)) THEN + ASM_SIMP_TAC[INTERVAL_LENGTH_CUBE; REAL_ARITH + `&0 < d ==> max d (&0) = d`] THEN DISCH_TAC THEN SUBGOAL_THEN + `~(interval[u:real^2,u + d % vec 1] = {}) /\ ~(interval[a:real^2,b] = {})` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[cube_dissection; division_of; SUBSET_EMPTY]; + ASM_REWRITE_TAC[EQ_INTERVAL; SUBSET_INTERVAL; CART_EQ; + DIMINDEX_2; FORALL_2]] THEN + SUBGOAL_THEN `interval[u:real^2,u + d % vec 1] SUBSET interval[a,b]` + MP_TAC THENL [ASM_MESON_TAC[cube_dissection; division_of]; ALL_TAC] THEN + ASM_REWRITE_TAC[SUBSET_INTERVAL; DIMINDEX_2; FORALL_2] THEN + UNDISCH_TAC `~(interval[u:real^2,u + d % vec 1] = {})` THEN + REWRITE_TAC[INTERVAL_NE_EMPTY; DIMINDEX_2; FORALL_2; VECTOR_ADD_COMPONENT; + VECTOR_MUL_COMPONENT; VEC_COMPONENT; REAL_MUL_RID] THEN STRIP_TAC THEN + ASM_REWRITE_TAC[REAL_LT_LE] THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + GEN_REWRITE_TAC (RAND_CONV o BINOP_CONV o LAND_CONV o RAND_CONV) + [EQ_SYM_EQ] THEN MP_TAC(ISPECL + [`D:(real^2->bool)->bool`; `a:real^2`; `b:real^2`; + `u:real^2`; `u + d % vec 1:real^2`] + POINT_IN_MULTIPLE_DIVISION_OF) THEN + REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM; DIMINDEX_2] THEN + ANTS_TAC THENL [ASM_MESON_TAC[cube_dissection]; ASM_REWRITE_TAC[]] THEN + REWRITE_TAC[RIGHT_IMP_FORALL_THM; IMP_IMP; GSYM CONJ_ASSOC] THEN + STRIP_TAC THEN SUBGOAL_THEN `(~((u:real^2)$1 = (a:real^2)$1) + ==> ?x1 e1. d < e1 /\ &0 < e1 /\ + interval[x1:real^2,x1 + e1 % vec 1] IN D /\ + a$1 <= x1$1 /\ x1$1 + e1 = u$1 /\ + a$2 <= x1$2 /\ x1$2 + e1 <= (b:real^2)$2 /\ + vector[u$1; u$2 + d / &2] IN + interval[x1:real^2,x1 + e1 % vec 1]) /\ + (~((u:real^2)$2 = (a:real^2)$2) + ==> ?x2 e2. d < e2 /\ &0 < e2 /\ + interval[x2:real^2,x2 + e2 % vec 1] IN D /\ + a$1 <= x2$1 /\ x2$1 + e2 <= (b:real^2)$1 /\ + a$2 <= x2$2 /\ x2$2 + e2 = u$2 /\ + vector[u$1 + d / &2; u$2] IN + interval[x2:real^2,x2 + e2 % vec 1]) /\ + (~((u + d % vec 1:real^2)$1 = (b:real^2)$1) + ==> ?x3 e3. d < e3 /\ &0 < e3 /\ + interval[x3:real^2,x3 + e3 % vec 1] IN D /\ + x3$1 = (u + d % vec 1)$1 /\ x3$1 + e3 <= b$1 /\ + (a:real^2)$2 <= x3$2 /\ x3$2 + e3 <= b$2 /\ + vector[u$1 + d; u$2 + d / &2] IN + interval[x3:real^2,x3 + e3 % vec 1]) /\ + (~((u + d % vec 1:real^2)$2 = (b:real^2)$2) + ==> ?x4 e4. d < e4 /\ &0 < e4 /\ + interval[x4:real^2,x4 + e4 % vec 1] IN D /\ + (a:real^2)$1 <= x4$1 /\ x4$1 + e4 <= b$1 /\ + x4$2 = (u + d % vec 1)$2 /\ x4$2 + e4 <= b$2 /\ + vector[u$1 + d / &2; u$2 + d] IN + interval[x4:real^2,x4 + e4 % vec 1])` + MP_TAC THENL [ASM_SIMP_TAC[CONJ_ASSOC; REAL_ARITH + `&0 < d ==> (d < e /\ &0 < e <=> d < e)`] THEN + REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + GSYM CONJ_ASSOC; VEC_COMPONENT; REAL_MUL_RID] THEN + REPEAT CONJ_TAC THEN DISCH_TAC THENL [FIRST_X_ASSUM(MP_TAC o SPECL + [`vector[(u:real^2)$1; u$2 + d / &2]:real^2`; `1`]); + FIRST_X_ASSUM(MP_TAC o SPECL + [`vector[(u:real^2)$1 + d / &2; u$2]:real^2`; `2`]); + FIRST_X_ASSUM(MP_TAC o SPECL + [`vector[(u:real^2)$1 + d; u$2 + d / &2]:real^2`; `1`]); + FIRST_X_ASSUM(MP_TAC o SPECL + [`vector[(u:real^2)$1 + d / &2; u$2 + d]:real^2`; `2`])] THEN + (ANTS_TAC THENL [REWRITE_TAC[IN_INTERVAL; VECTOR_2; DIMINDEX_2; FORALL_2; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VEC_COMPONENT] THEN + CONV_TAC NUM_REDUCE_CONV THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + MATCH_MP_TAC(ISPEC `D:(real^2->bool)->bool` CUBE_EXISTS_FORM) THEN + ASM_REWRITE_TAC[] THEN MAP_EVERY X_GEN_TAC [`x:real^2`; `e:real`] THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `interval[x:real^2,x + e % vec 1]`) THEN + ASM_REWRITE_TAC[INTERVAL_LENGTH_CUBE] THEN ASM_REAL_ARITH_TAC; + FIRST_X_ASSUM(MP_TAC o CONJUNCT1 o REWRITE_RULE[cube_dissection]) THEN + ASM_REWRITE_TAC[division_of; AND_FORALL_THM] THEN DISCH_THEN(MP_TAC o + SPEC `interval[x:real^2,x + e % vec 1]` o CONJUNCT2) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN(CONJUNCTS_THEN2 (MP_TAC o CONJUNCT1) + (MP_TAC o SPEC `interval[u:real^2,u + d % vec 1]`)) THEN + ASM_REWRITE_TAC[INTERIOR_INTERVAL; SUBSET_INTERVAL] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_INTERVAL]) THEN + REWRITE_TAC[DISJOINT_INTERVAL; DIMINDEX_2; FORALL_2; IN_INTERVAL; MESON[] + `(?(i:num). 1 <= i /\ i <= 2 /\ (P:num->bool) i) <=> + ~(!i. 1 <= i /\ i <= 2 ==> ~P i)`; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VECTOR_2; + VEC_COMPONENT; REAL_MUL_RID] THEN + ASM_REAL_ARITH_TAC]); ALL_TAC] THEN + REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; IN_INTERVAL; + VECTOR_2; DIMINDEX_2; FORALL_2; VEC_COMPONENT; REAL_MUL_RID] THEN + MAP_EVERY ASM_CASES_TAC + [`(u:real^2)$1 = (a:real^2)$1`; + `(u:real^2)$1 + d = (b:real^2)$1`; + `(u:real^2)$2 = (a:real^2)$2`; + `(u:real^2)$2 + d = (b:real^2)$2`] THEN + ASM_REWRITE_TAC[] THEN TRY ASM_REAL_ARITH_TAC THEN STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [cube_dissection]) THEN + REWRITE_TAC[division_of; GSYM CONJ_ASSOC] THEN + DISCH_THEN(MP_TAC o el 2 o CONJUNCTS) THENL + [DISCH_THEN(MP_TAC o itspec [3;4]); + DISCH_THEN(MP_TAC o itspec [2;3]); + DISCH_THEN(fun t -> MAP_EVERY (MP_TAC o C itspec t) [[2;3]; [2;4]; [3;4]]); + DISCH_THEN(MP_TAC o itspec [1;4]); + DISCH_THEN(MP_TAC o itspec [1;2]); + DISCH_THEN(fun t -> MAP_EVERY (MP_TAC o C itspec t) [[1;2]; [1;4]; [2;4]]); + DISCH_THEN(fun t -> MAP_EVERY (MP_TAC o C itspec t) [[1;3]; [1;4]; [3;4]]); + DISCH_THEN(fun t -> MAP_EVERY (MP_TAC o C itspec t) [[1;2]; [1;3]; [2;3]]) + ] THEN ASM_REWRITE_TAC[EQ_INTERVAL; INTERIOR_INTERVAL; DISJOINT_INTERVAL; + CART_EQ; DE_MORGAN_THM; DIMINDEX_2; FORALL_2; IN_INTERVAL; + INTERVAL_NE_EMPTY; MESON[] + `(?i. 1 <= i /\ i <= 2 /\ P i) <=> + ~(!i. 1 <= i /\ i <= 2 ==> ~P i)`] THEN + REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VECTOR_2; + VEC_COMPONENT; REAL_MUL_RID; DE_MORGAN_THM; + INTERVAL_NE_EMPTY] THEN + ASM_REWRITE_TAC[REAL_ARITH `a + e:real <= a <=> ~(&0 < e)`] THEN + REPEAT(ANTS_TAC THENL [ASM_REAL_ARITH_TAC; STRIP_TAC]) THEN + ASM_REAL_ARITH_TAC);; + +(* Minimum element of a finite set with pairwise distinct f-values *) +let FINITE_PAIRWISE_MINIMUM = prove + (`!(f:A->real) s. + FINITE s /\ ~(s = {}) /\ pairwise (\x y. ~(f x = f y)) s + ==> ?x. x IN s /\ !y. y IN s /\ ~(y = x) ==> f x < f y`, + REPEAT STRIP_TAC THEN + MP_TAC(ISPEC `IMAGE (f:A->real) s` INF_FINITE_LEMMA) THEN + ASM_SIMP_TAC[FINITE_IMAGE; IMAGE_EQ_EMPTY] THEN + DISCH_THEN(X_CHOOSE_THEN `b:real` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `?x0:A. x0 IN s /\ (f:A->real) x0 = b` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[IN_IMAGE]; ALL_TAC] THEN + EXISTS_TAC `x0:A` THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `y:A` THEN STRIP_TAC THEN + MATCH_MP_TAC(REAL_ARITH `x <= y /\ ~(x = y) ==> x < y`) THEN + CONJ_TAC THENL [SUBGOAL_THEN `b <= (f:A->real) y` MP_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN + REWRITE_TAC[IN_IMAGE] THEN EXISTS_TAC `y:A` THEN ASM_REWRITE_TAC[]; + ASM_REAL_ARITH_TAC]; + UNDISCH_TAC `pairwise (\x y:A. ~((f:A->real) x = f y)) s` THEN + REWRITE_TAC[pairwise] THEN + DISCH_THEN(MP_TAC o SPECL [`x0:A`; `y:A`]) THEN ASM_REWRITE_TAC[]]);; + +(* =================================================================== *) +(* Valley-based proof of cube dissection impossibility *) +(* Following the infinite descent approach of Brooks/Smith/Stone/Tutte *) +(* =================================================================== *) + +(* A valley for a dissection D is a cube v whose "top face" is *) +(* properly covered by cubes from D. The cubes sitting on v have *) +(* their footprint within v's and are strictly smaller than v. *) + +let valley = new_definition + `valley (D:(real^3->bool)->bool) (v:real^3->bool) <=> + cube v /\ + (!z:real^3. z$1 = interval_upperbound (v:real^3->bool) $ 1 /\ + interval_lowerbound (v:real^3->bool) $ 2 < z$2 /\ + z$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < z$3 /\ + z$3 < interval_upperbound (v:real^3->bool) $ 3 + ==> ?k. k IN D /\ z IN k /\ + interval_lowerbound k $ 1 = + interval_upperbound (v:real^3->bool) $ 1) /\ + (!k. k IN D /\ + interval_lowerbound k $ 1 = interval_upperbound (v:real^3->bool) $ 1 /\ + (?z:real^3. z IN k /\ + interval_lowerbound (v:real^3->bool) $ 2 < z$2 /\ + z$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < z$3 /\ + z$3 < interval_upperbound (v:real^3->bool) $ 3) + ==> interval_lowerbound (v:real^3->bool) $ 2 <= interval_lowerbound k $ 2 /\ + interval_upperbound k $ 2 <= interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 <= interval_lowerbound k $ 3 /\ + interval_upperbound k $ 3 <= interval_upperbound (v:real^3->bool) $ 3) /\ + (!k. k IN D /\ + interval_lowerbound k $ 1 = interval_upperbound (v:real^3->bool) $ 1 /\ + (?z:real^3. z IN k /\ + interval_lowerbound (v:real^3->bool) $ 2 < z$2 /\ + z$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < z$3 /\ + z$3 < interval_upperbound (v:real^3->bool) $ 3) + ==> interval_length k < interval_length v)`;; + +(* The initial valley: the bottom face of [a,b] is a valley. *) +(* More precisely, the cube shifted down below [a,b] is a valley. *) + +let DIVISION_WHOLE_IS_SINGLETON = prove + (`!D (a:real^3) b. + D division_of interval[a,b] /\ + (!k:real^3->bool. k IN D ==> cube k) /\ + interval[a,b] IN D + ==> D = {interval[a,b]}`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + GEN_REWRITE_TAC I [EXTENSION] THEN REWRITE_TAC[IN_SING] THEN + X_GEN_TAC `j:real^3->bool` THEN EQ_TAC THENL [DISCH_TAC THEN + ASM_CASES_TAC `j = interval[a:real^3,b]` THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `interior(j:real^3->bool) = {}` MP_TAC THENL [SUBGOAL_THEN + `interior(j:real^3->bool) SUBSET interior(interval[a:real^3,b])` + ASSUME_TAC THENL + [MATCH_MP_TAC SUBSET_INTERIOR THEN ASM_MESON_TAC[division_of]; + ALL_TAC] THEN MESON_ASSUME_TAC [division_of] + `interior(j:real^3->bool) INTER interior(interval[a:real^3,b]) = {}` THEN + ASM SET_TAC[]; ASM_MESON_TAC[CUBE_IMP_NONEMPTY_INTERIOR]]; + DISCH_THEN SUBST1_TAC THEN ASM_REWRITE_TAC[]]);; + +let VALLEY_INITIAL = prove + (`!D (a:real^3) d. + &0 < d /\ + cube_dissection D /\ + UNIONS D = interval[a, a + d % vec 1] /\ + ~(D = {interval[a, a + d % vec 1]}) + ==> valley D (interval[a - d % basis 1, a - d % basis 1 + d % vec 1])`, + REPEAT GEN_TAC THEN STRIP_TAC THEN REWRITE_TAC[valley] THEN + MESON_ASSUME_TAC [cube_dissection] + `D division_of interval[a:real^3, a + d % vec 1]` THEN + (* Nonemptiness of the virtual valley interval *) + SUBGOAL_THEN `!i. 1 <= i /\ i <= dimindex(:3) + ==> (a - d % basis 1:real^3)$i <= + (a - d % basis 1 + d % vec 1:real^3)$i` + ASSUME_TAC THENL [REWRITE_TAC[DIMINDEX_3; FORALL_3] THEN + SIMP_TAC[VECTOR_SUB_COMPONENT; VECTOR_ADD_COMPONENT; + VECTOR_MUL_COMPONENT; VEC_COMPONENT; + BASIS_COMPONENT; DIMINDEX_3] THEN + CONV_TAC NUM_REDUCE_CONV THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + (* Compute and rewrite bounds of the virtual valley interval *) + SUBGOAL_THEN `interval_upperbound(interval[a - d % basis 1:real^3, + a - d % basis 1 + d % vec 1]) $1 = + (a:real^3)$1 /\ + interval_lowerbound(interval[a - d % basis 1:real^3, + a - d % basis 1 + d % vec 1]) $2 = + a$2 /\ + interval_upperbound(interval[a - d % basis 1:real^3, + a - d % basis 1 + d % vec 1]) $2 = + a$2 + d /\ + interval_lowerbound(interval[a - d % basis 1:real^3, + a - d % basis 1 + d % vec 1]) $3 = + a$3 /\ + interval_upperbound(interval[a - d % basis 1:real^3, + a - d % basis 1 + d % vec 1]) $3 = + a$3 + d /\ + interval_length(interval[a - d % basis 1:real^3, + a - d % basis 1 + d % vec 1]) = d` + STRIP_ASSUME_TAC THENL + [ASM_SIMP_TAC[INTERVAL_UPPERBOUND; INTERVAL_LOWERBOUND] THEN + SIMP_TAC[VECTOR_SUB_COMPONENT; VECTOR_ADD_COMPONENT; + VECTOR_MUL_COMPONENT; VEC_COMPONENT; + BASIS_COMPONENT; DIMINDEX_3; + ARITH_RULE `1 <= 1`; ARITH_RULE `1 <= 2`; + ARITH_RULE `1 <= 3`; ARITH_RULE `2 <= 3`; + ARITH_RULE `3 <= 3`] THEN CONV_TAC NUM_REDUCE_CONV THEN + REWRITE_TAC[INTERVAL_LENGTH_CUBE] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + REPEAT CONJ_TAC THENL [(* Condition 1: cube *) + REWRITE_TAC[cube] THEN + MAP_EVERY EXISTS_TAC [`a - d % basis 1:real^3`; `d:real`] THEN + ASM_REWRITE_TAC[]; + (* Condition 2: covering - every point on right face is covered *) + X_GEN_TAC `z:real^3` THEN STRIP_TAC THEN + SUBGOAL_THEN `(z:real^3) IN interval[a:real^3, a + d % vec 1]` + ASSUME_TAC THENL [REWRITE_TAC[IN_INTERVAL; DIMINDEX_3; FORALL_3] THEN + SIMP_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VEC_COMPONENT] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `?k:real^3->bool. k IN D /\ (z:real^3) IN k` + STRIP_ASSUME_TAC THENL + [REWRITE_TAC[GSYM IN_UNIONS] THEN ASM SET_TAC[]; ALL_TAC] THEN + EXISTS_TAC `k:real^3->bool` THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `(k:real^3->bool) SUBSET interval[a:real^3, a + d % vec 1] /\ + ~(k = {}) /\ (?u v:real^3. k = interval[u,v])` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[division_of]; ALL_TAC] THEN + MESON_ASSUME_TAC [] `~(interval[u:real^3,v] = {})` THEN + SUBGOAL_THEN `interval_lowerbound(k:real^3->bool) = (u:real^3)` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_SIMP_TAC[INTERVAL_LOWERBOUND_NONEMPTY]; ALL_TAC] THEN + SUBGOAL_THEN `(u:real^3) IN interval[a:real^3, a + d % vec 1]` + ASSUME_TAC THENL + [SUBGOAL_THEN `(u:real^3) IN interval[u:real^3, v]` MP_TAC THENL + [REWRITE_TAC[IN_INTERVAL] THEN GEN_TAC THEN DISCH_TAC THEN + CONJ_TAC THENL [REAL_ARITH_TAC; ALL_TAC] THEN + UNDISCH_TAC `~(interval[u:real^3,v] = {})` THEN + REWRITE_TAC[INTERVAL_NE_EMPTY] THEN ASM_MESON_TAC[]; + ASM SET_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `(u:real^3)$1 <= (z:real^3)$1` ASSUME_TAC THENL + [UNDISCH_TAC `(z:real^3) IN (k:real^3->bool)` THEN + ASM_REWRITE_TAC[IN_INTERVAL; DIMINDEX_3; FORALL_3] THEN + REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(a:real^3)$1 <= (u:real^3)$1` ASSUME_TAC THENL + [UNDISCH_TAC `(u:real^3) IN interval[a:real^3, a + d % vec 1]` THEN + REWRITE_TAC[IN_INTERVAL; DIMINDEX_3; FORALL_3] THEN + SIMP_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VEC_COMPONENT] THEN + REAL_ARITH_TAC; ALL_TAC] THEN ASM_REAL_ARITH_TAC; + (* Condition 3: containment - touching cubes stay within bounds *) + X_GEN_TAC `k:real^3->bool` THEN STRIP_TAC THEN + MESON_ASSUME_TAC [division_of] + `(k:real^3->bool) SUBSET interval[a:real^3, a + d % vec 1]` THEN + SUBGOAL_THEN `?c:real^3 e. &0 < e /\ k = interval[c, c + e % vec 1]` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[cube_dissection; cube]; ALL_TAC] THEN + SUBGOAL_THEN `interval_lowerbound(k:real^3->bool) = (c:real^3) /\ + interval_upperbound(k:real^3->bool) = c + e % vec 1:real^3` STRIP_ASSUME_TAC THENL + [CUBE_BOUNDS_TAC; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `(k:real^3->bool) SUBSET interval[a:real^3, a + d % vec 1]` THEN + ASM_REWRITE_TAC[SUBSET_INTERVAL; INTERVAL_NE_EMPTY; DIMINDEX_3; FORALL_3] THEN + SIMP_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VEC_COMPONENT] THEN + ASM_REAL_ARITH_TAC; + (* Condition 4: size - touching cubes are strictly smaller *) + X_GEN_TAC `k:real^3->bool` THEN STRIP_TAC THEN + MESON_ASSUME_TAC [division_of] + `(k:real^3->bool) SUBSET interval[a:real^3, a + d % vec 1]` THEN + SUBGOAL_THEN `?c:real^3 e. &0 < e /\ k = interval[c, c + e % vec 1]` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[cube_dissection; cube]; ALL_TAC] THEN + SUBGOAL_THEN `interval_length(k:real^3->bool) = e` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_SIMP_TAC[INTERVAL_LENGTH_CUBE_POS]; ALL_TAC] THEN + SUBGOAL_THEN `e <= d` ASSUME_TAC THENL + [UNDISCH_TAC `(k:real^3->bool) SUBSET interval[a:real^3, a + d % vec 1]` THEN + ASM_REWRITE_TAC[SUBSET_INTERVAL; INTERVAL_NE_EMPTY; DIMINDEX_3; FORALL_3] THEN + SIMP_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VEC_COMPONENT] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + ASM_CASES_TAC `e:real = d` THENL + [SUBGOAL_THEN `c:real^3 = a` ASSUME_TAC THENL + [REWRITE_TAC[CART_EQ; DIMINDEX_3; FORALL_3] THEN UNDISCH_TAC + `(k:real^3->bool) SUBSET interval[a:real^3, a + d % vec 1]` THEN + ASM_REWRITE_TAC[SUBSET_INTERVAL; INTERVAL_NE_EMPTY; + DIMINDEX_3; FORALL_3] THEN + SIMP_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `k = interval[a:real^3, a + d % vec 1]` + ASSUME_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `D = {interval[a:real^3, a + d % vec 1]}` MP_TAC THENL + [MATCH_MP_TAC DIVISION_WHOLE_IS_SINGLETON THEN + ASM_MESON_TAC[cube_dissection]; ASM_MESON_TAC[]]; + ASM_REAL_ARITH_TAC]]);; + +(* If x is on k's face at coordinate 1 (x$1 = upperbound k$1) with *) +(* interior y,z in k, and j is a different element of a division *) +(* containing x, then j starts exactly at k's upper x-bound. *) + +let DIVISION_FACE_LOWERBOUND = prove + (`!D (k:real^3->bool) j (x:real^3). + D division_of UNIONS D /\ + ~(interior k = {}) /\ ~(interior j = {}) /\ + k IN D /\ j IN D /\ ~(j = k) /\ + x IN k /\ x IN j /\ + x$1 = interval_upperbound k $ 1 /\ + interval_lowerbound k $ 2 < x$2 /\ + x$2 < interval_upperbound k $ 2 /\ + interval_lowerbound k $ 3 < x$3 /\ + x$3 < interval_upperbound k $ 3 + ==> interval_lowerbound j $ 1 = interval_upperbound k $ 1`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN `?u v:real^3. k = interval[u,v] /\ ~(interval[u,v] = {})` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[division_of]; ALL_TAC] THEN + SUBGOAL_THEN `?p q:real^3. j = interval[p,q] /\ ~(interval[p,q] = {})` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[division_of]; ALL_TAC] THEN + SUBGOAL_THEN `interval_lowerbound k = (u:real^3) /\ + interval_upperbound k = (v:real^3) /\ + interval_lowerbound j = (p:real^3) /\ + interval_upperbound j = (q:real^3)` STRIP_ASSUME_TAC THENL + [ASM_SIMP_TAC[INTERVAL_LOWERBOUND_NONEMPTY; INTERVAL_UPPERBOUND_NONEMPTY]; + ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `interior(k:real^3->bool) INTER interior(j:real^3->bool) = {}` + MP_TAC THENL [ASM_MESON_TAC[division_of]; ALL_TAC] THEN + MAP_EVERY UNDISCH_TAC + [`~(interior(k:real^3->bool) = {})`; + `~(interior(j:real^3->bool) = {})`; + `(x:real^3) IN (j:real^3->bool)`; + `(x:real^3)$1 = interval_upperbound (k:real^3->bool) $ 1`; + `interval_lowerbound (k:real^3->bool) $ 2 < (x:real^3)$2`; + `(x:real^3)$2 < interval_upperbound (k:real^3->bool) $ 2`; + `interval_lowerbound (k:real^3->bool) $ 3 < (x:real^3)$3`; + `(x:real^3)$3 < interval_upperbound (k:real^3->bool) $ 3`] THEN + ASM_REWRITE_TAC[INTERIOR_INTERVAL; INTERVAL_NE_EMPTY; IN_INTERVAL; + DISJOINT_INTERVAL; DIMINDEX_3; MESON[] + `(?i. 1 <= i /\ i <= 3 /\ P i) <=> + ~(!i. 1 <= i /\ i <= 3 ==> ~P i)`; FORALL_3] THEN REAL_ARITH_TAC);; + +(* Shared setup for pairs of elements from the 2D face-projection set E. *) +(* Expands e1,e2 from E, gets 3D preimages m1,m2, proves m1!=m2, *) +(* extracts cube forms and interval bounds. *) +let E_PAIR_PREIMAGE_TAC = + UNDISCH_TAC `(e1:real^2->bool) IN E` THEN + EXPAND_TAC "E" THEN REWRITE_TAC[IN_IMAGE; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `m1:real^3->bool` STRIP_ASSUME_TAC) THEN + UNDISCH_TAC `(e2:real^2->bool) IN E` THEN + EXPAND_TAC "E" THEN REWRITE_TAC[IN_IMAGE; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `m2:real^3->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `~(m1:real^3->bool = m2)` ASSUME_TAC THENL + [DISCH_TAC THEN UNDISCH_TAC `~(e1:real^2->bool = e2)` THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(?c1:real^3 s1. &0 < s1 /\ m1 = interval[c1, c1 + s1 % vec 1]) /\ + (?c2:real^3 s2. &0 < s2 /\ m2 = interval[c2, c2 + s2 % vec 1])` STRIP_ASSUME_TAC THENL + [CONJ_TAC THEN ASM_MESON_TAC[cube_dissection; cube]; ALL_TAC] THEN + SUBGOAL_THEN `interval_lowerbound m1 = c1:real^3 /\ + interval_upperbound m1 = c1 + s1 % vec 1:real^3 /\ + interval_lowerbound m2 = c2:real^3 /\ + interval_upperbound m2 = c2 + s2 % vec 1:real^3` STRIP_ASSUME_TAC THENL + [REPEAT CONJ_TAC THEN CUBE_BOUNDS_TAC; ALL_TAC];; + +(* The smallest cube on v's face is strictly in v's y,z interior, *) +(* not touching v's face boundary. This is essential for the wall *) +(* argument: it ensures wall cubes exist on all sides of k. *) +(* Proof uses 2D projection onto v's face + SQUARE_DISSECTION_NONEDGE *) + +let VALLEY_FACE_INTERIOR = prove + (`!D (a:real^3) d (v:real^3->bool) k. + &0 < d /\ + cube_dissection D /\ + UNIONS D = interval[a, a + d % vec 1] /\ + valley D v /\ + k IN D /\ + interval_lowerbound k $ 1 = interval_upperbound (v:real^3->bool) $ 1 /\ + (?z:real^3. z IN k /\ + interval_lowerbound (v:real^3->bool) $ 2 < z$2 /\ z$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < z$3 /\ z$3 < interval_upperbound (v:real^3->bool) $ 3) /\ + (!j'. j' IN D /\ ~(j' = k) /\ + interval_lowerbound j' $ 1 = interval_upperbound (v:real^3->bool) $ 1 /\ + (?z:real^3. z IN j' /\ + interval_lowerbound (v:real^3->bool) $ 2 < z$2 /\ + z$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < z$3 /\ + z$3 < interval_upperbound (v:real^3->bool) $ 3) + ==> interval_length k < interval_length j') + ==> interval_lowerbound (v:real^3->bool) $ 2 < interval_lowerbound k $ 2 /\ + interval_upperbound k $ 2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < interval_lowerbound k $ 3 /\ + interval_upperbound k $ 3 < interval_upperbound (v:real^3->bool) $ 3`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Setup: extract valley properties *) + FIRST_ASSUM(fun th -> + let th' = GEN_REWRITE_RULE I [valley] th in + LABEL_TAC "vcub" (CONJUNCT1 th') THEN + LABEL_TAC "vcov" (CONJUNCT1(CONJUNCT2 th')) THEN + LABEL_TAC "vcont" (CONJUNCT1(CONJUNCT2(CONJUNCT2 th'))) THEN + LABEL_TAC "vsz" (CONJUNCT2(CONJUNCT2(CONJUNCT2 th')))) THEN + MESON_ASSUME_TAC [cube_dissection] `(D:(real^3->bool)->bool) division_of UNIONS D` THEN + MESON_ASSUME_TAC [division_of] `FINITE(D:(real^3->bool)->bool)` THEN + MESON_ASSUME_TAC [cube_dissection] `cube(k:real^3->bool)` THEN + SUBGOAL_THEN `?cv:real^3 sv. &0 < sv /\ v = interval[cv, cv + sv % vec 1]` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[valley; cube]; ALL_TAC] THEN + SUBGOAL_THEN `?ck:real^3 sk. &0 < sk /\ k = interval[ck, ck + sk % vec 1]` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[cube]; ALL_TAC] THEN + SUBGOAL_THEN `(interval_lowerbound(v:real^3->bool) = cv /\ + interval_upperbound v = cv + sv % vec 1:real^3) /\ + (interval_lowerbound(k:real^3->bool) = ck /\ + interval_upperbound k = ck + sk % vec 1:real^3)` STRIP_ASSUME_TAC THENL + [CONJ_TAC THEN CUBE_BOUNDS_TAC; ALL_TAC] THEN + ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID] THEN + (* Goal: cv$2 < ck$2 /\ ck$2+sk < cv$2+sv /\ + cv$3 < ck$3 /\ ck$3+sk < cv$3+sv *) + (* Establish the face condition: ck$1 = cv$1 + sv *) + SUBGOAL_THEN `(ck:real^3)$1 = (cv:real^3)$1 + sv` ASSUME_TAC THENL + [UNDISCH_TAC `interval_lowerbound(k:real^3->bool) $ 1 = + interval_upperbound(v:real^3->bool) $ 1` THEN + ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID]; ALL_TAC] THEN + (* Weak containment from valley *) + SUBGOAL_THEN `(cv:real^3)$2 <= (ck:real^3)$2 /\ ck$2 + sk <= cv$2 + sv /\ + cv$3 <= ck$3 /\ ck$3 + sk <= cv$3 + sv` STRIP_ASSUME_TAC THENL + [USE_THEN "vcont" (MP_TAC o SPEC `k:real^3->bool`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID]; ALL_TAC] THEN + (* sk < sv from valley size *) + SUBGOAL_THEN `sk < sv` ASSUME_TAC THENL + [USE_THEN "vsz" (MP_TAC o SPEC `k:real^3->bool`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + ASM_SIMP_TAC[INTERVAL_LENGTH_CUBE_POS]; ALL_TAC] THEN + (* Now use the 2D projection approach via SQUARE_DISSECTION_NONEDGE *) + (* Construct a 2D cube_dissection from the face cubes *) + ABBREV_TAC + `E = IMAGE (\m:real^3->bool. + interval[vector[(interval_lowerbound m)$2; + (interval_lowerbound m)$3]:real^2, + vector[(interval_upperbound m)$2; + (interval_upperbound m)$3]]) + {m | m IN D /\ + interval_lowerbound m $ 1 = (cv:real^3)$1 + sv /\ + (?z:real^3. z IN m /\ + cv$2 < z$2 /\ z$2 < cv$2 + sv /\ + cv$3 < z$3 /\ z$3 < cv$3 + sv)}` THEN ABBREV_TAC + `face_sq = interval[vector[(cv:real^3)$2; cv$3]:real^2, + vector[cv$2 + sv; cv$3 + sv]]` THEN ABBREV_TAC + `proj_k = interval[vector[(ck:real^3)$2; ck$3]:real^2, + vector[ck$2 + sk; ck$3 + sk]]` THEN + (* Key claim: E is a cube_dissection with UNIONS E = face_sq, + proj_k IN E, and proj_k is smallest *) + SUBGOAL_THEN `cube_dissection (E:(real^2->bool)->bool) /\ + UNIONS E = (face_sq:real^2->bool) /\ + (proj_k:real^2->bool) IN E /\ + (!e:real^2->bool. e IN E /\ ~(e = proj_k) + ==> interval_length proj_k < interval_length e)` + STRIP_ASSUME_TAC THENL [(* Prove the 4-conjunct claim about E *) + (* First, rewrite z-hypothesis into cv/sv form *) + SUBGOAL_THEN `?z:real^3. z IN k /\ (cv:real^3)$2 < z$2 /\ z$2 < cv$2 + sv /\ + cv$3 < z$3 /\ z$3 < cv$3 + sv` (LABEL_TAC "zk_cv") THENL + [EXISTS_TAC `z:real^3` THEN ASM_REWRITE_TAC[] THEN MAP_EVERY UNDISCH_TAC + [`interval_lowerbound(v:real^3->bool) $ 2 < (z:real^3)$2`; + `(z:real^3)$2 < interval_upperbound(v:real^3->bool) $ 2`; + `interval_lowerbound(v:real^3->bool) $ 3 < (z:real^3)$3`; + `(z:real^3)$3 < interval_upperbound(v:real^3->bool) $ 3`] THEN + ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID] THEN + REAL_ARITH_TAC; ALL_TAC] THEN + (* Conjunct 3: proj_k IN E *) + SUBGOAL_THEN `(proj_k:real^2->bool) IN E` ASSUME_TAC THENL + [EXPAND_TAC "E" THEN EXPAND_TAC "proj_k" THEN + REWRITE_TAC[IN_IMAGE; IN_ELIM_THM] THEN EXISTS_TAC `k:real^3->bool` THEN + ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID]; ALL_TAC] THEN + (* FINITE E *) + SUBGOAL_THEN `FINITE(E:(real^2->bool)->bool)` ASSUME_TAC THENL + [EXPAND_TAC "E" THEN MATCH_MP_TAC FINITE_IMAGE THEN + MATCH_MP_TAC FINITE_SUBSET THEN EXISTS_TAC `D:(real^3->bool)->bool` THEN + ASM_REWRITE_TAC[] THEN SET_TAC[]; ALL_TAC] THEN + (* Conjunct 1: cube_dissection E *) + (* Step A: All elements of E are cube *) + SUBGOAL_THEN `!e:real^2->bool. e IN E ==> cube e` + (LABEL_TAC "ecub") THENL [X_GEN_TAC `ea:real^2->bool` THEN + EXPAND_TAC "E" THEN REWRITE_TAC[IN_IMAGE; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `ma:real^3->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `?cma:real^3 sma. &0 < sma /\ ma = interval[cma, cma + sma % vec 1]` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[cube_dissection; cube]; ALL_TAC] THEN + SUBGOAL_THEN `interval_lowerbound(ma:real^3->bool) = cma /\ + interval_upperbound ma = cma + sma % vec 1:real^3` STRIP_ASSUME_TAC THENL + [CUBE_BOUNDS_TAC; ALL_TAC] THEN + ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID; cube] THEN + EXISTS_TAC `vector[(cma:real^3)$2; cma$3]:real^2` THEN + EXISTS_TAC `sma:real` THEN ASM_REWRITE_TAC[VECTOR2_CUBE]; ALL_TAC] THEN + (* Step B: Disjoint interiors *) + SUBGOAL_THEN `!e1 e2:real^2->bool. e1 IN E /\ e2 IN E /\ ~(e1 = e2) + ==> interior e1 INTER interior e2 = {}` (LABEL_TAC "edisj") THENL + [MAP_EVERY X_GEN_TAC [`e1:real^2->bool`; `e2:real^2->bool`] THEN + STRIP_TAC THEN E_PAIR_PREIMAGE_TAC THEN + MESON_ASSUME_TAC [] `(c1:real^3)$1 = (c2:real^3)$1` THEN + MESON_ASSUME_TAC [cube_dissection; division_of] + `interior(m1:real^3->bool) INTER interior m2 = {}` THEN + MATCH_MP_TAC(TAUT `(~p ==> F) ==> p`) THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + REWRITE_TAC[IN_INTER] THEN + DISCH_THEN(X_CHOOSE_THEN `y:real^2` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `vector[(c1:real^3)$1 + min s1 s2 / &2; + (y:real^2)$1; y$2]:real^3 IN interior m1 /\ + vector[(c1:real^3)$1 + min s1 s2 / &2; + (y:real^2)$1; y$2]:real^3 IN interior m2` + STRIP_ASSUME_TAC THENL + [ASM_REWRITE_TAC[INTERIOR_CLOSED_INTERVAL; IN_INTERVAL; + DIMINDEX_3; FORALL_3; VECTOR_3; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID] THEN + UNDISCH_TAC `(y:real^2) IN interior(e1:real^2->bool)` THEN + UNDISCH_TAC `(y:real^2) IN interior(e2:real^2->bool)` THEN + ASM_REWRITE_TAC[INTERIOR_CLOSED_INTERVAL; IN_INTERVAL; + DIMINDEX_2; FORALL_2; VECTOR_2; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + UNDISCH_TAC `interior(m1:real^3->bool) INTER interior m2 = {}` THEN + ASM SET_TAC[]; ALL_TAC] THEN + (* Step C: Pairwise distinct interval_lengths *) + SUBGOAL_THEN `pairwise (\k k':real^2->bool. + ~(interval_length k = interval_length k')) E` (LABEL_TAC "epw") THENL + [REWRITE_TAC[pairwise] THEN + MAP_EVERY X_GEN_TAC [`e1:real^2->bool`; `e2:real^2->bool`] THEN + STRIP_TAC THEN E_PAIR_PREIMAGE_TAC THEN + SUBGOAL_THEN `interval_length(e1:real^2->bool) = s1 /\ + interval_length(e2:real^2->bool) = s2` STRIP_ASSUME_TAC THENL + [CONJ_TAC THEN + ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID; VECTOR2_CUBE] THEN + ASM_SIMP_TAC[INTERVAL_LENGTH_CUBE_POS]; ALL_TAC] THEN + SUBGOAL_THEN `~(interval_length(m1:real^3->bool) = interval_length(m2:real^3->bool))` + MP_TAC THENL [ASM_MESON_TAC[cube_dissection; pairwise]; ALL_TAC] THEN + ASM_SIMP_TAC[INTERVAL_LENGTH_CUBE_POS]; ALL_TAC] THEN + (* Assemble cube_dissection *) + SUBGOAL_THEN `cube_dissection(E:(real^2->bool)->bool)` ASSUME_TAC THENL + [REWRITE_TAC[cube_dissection; division_of] THEN + REPEAT CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; + X_GEN_TAC `ef:real^2->bool` THEN DISCH_TAC THEN + REPEAT CONJ_TAC THENL [ASM SET_TAC[]; + ASM_MESON_TAC[CUBE_IMP_NONEMPTY]; + ASM_MESON_TAC[cube]]; + USE_THEN "edisj" ACCEPT_TAC; + USE_THEN "ecub" ACCEPT_TAC; + USE_THEN "epw" ACCEPT_TAC]; ALL_TAC] THEN + (* Conjunct 2: UNIONS E = face_sq *) + SUBGOAL_THEN + `UNIONS(E:(real^2->bool)->bool) = (face_sq:real^2->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [(* UNIONS E ⊆ face_sq *) + REWRITE_TAC[SUBSET; IN_UNIONS] THEN X_GEN_TAC `p:real^2` THEN + DISCH_THEN(X_CHOOSE_THEN `ep:real^2->bool` STRIP_ASSUME_TAC) THEN + UNDISCH_TAC `(ep:real^2->bool) IN E` THEN + EXPAND_TAC "E" THEN REWRITE_TAC[IN_IMAGE; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `mp:real^3->bool` STRIP_ASSUME_TAC) THEN + (* Valley containment for mp *) + SUBGOAL_THEN `(cv:real^3)$2 <= interval_lowerbound(mp:real^3->bool)$2 /\ + interval_upperbound(mp:real^3->bool)$2 <= cv$2 + sv /\ + cv$3 <= interval_lowerbound(mp:real^3->bool)$3 /\ + interval_upperbound(mp:real^3->bool)$3 <= cv$3 + sv` STRIP_ASSUME_TAC THENL + [USE_THEN "vcont" (MP_TAC o SPEC `mp:real^3->bool`) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID] THEN + ASM_MESON_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID]; ALL_TAC] THEN + UNDISCH_TAC `(p:real^2) IN ep` THEN ASM_REWRITE_TAC[] THEN + EXPAND_TAC "face_sq" THEN + REWRITE_TAC[IN_INTERVAL; DIMINDEX_2; FORALL_2; VECTOR_2] THEN + REPEAT STRIP_TAC THEN ASM_REAL_ARITH_TAC; + (* face_sq ⊆ UNIONS E via closure argument *) + SUBGOAL_THEN `closed(UNIONS(E:(real^2->bool)->bool))` ASSUME_TAC THENL + [MATCH_MP_TAC CLOSED_UNIONS THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `ef:real^2->bool` THEN DISCH_TAC THEN + ASM_MESON_TAC[cube_dissection; cube; CLOSED_INTERVAL]; + ALL_TAC] THEN + SUBGOAL_THEN `interval(vector[(cv:real^3)$2;cv$3]:real^2, + vector[cv$2 + sv;cv$3 + sv]) SUBSET + UNIONS(E:(real^2->bool)->bool)` + ASSUME_TAC THENL + [REWRITE_TAC[SUBSET; IN_INTERVAL; DIMINDEX_2; FORALL_2; + VECTOR_2] THEN X_GEN_TAC `y:real^2` THEN STRIP_TAC THEN + SUBGOAL_THEN `?mp2:real^3->bool. mp2 IN D /\ + vector[(cv:real^3)$1 + sv;(y:real^2)$1;y$2]:real^3 IN mp2 /\ + interval_lowerbound mp2$1 = interval_upperbound(v:real^3->bool)$1` + (X_CHOOSE_THEN `mp2:real^3->bool` STRIP_ASSUME_TAC) THENL + [USE_THEN "vcov" + (MATCH_MP_TAC o SPEC + `vector[(cv:real^3)$1 + sv;(y:real^2)$1;y$2]:real^3`) THEN + ASM_REWRITE_TAC[VECTOR_3; VECTOR_ADD_COMPONENT; + VECTOR_MUL_COMPONENT; VEC_COMPONENT; REAL_MUL_RID]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN EXISTS_TAC + `interval[vector[(interval_lowerbound(mp2:real^3->bool))$2; + (interval_lowerbound mp2)$3]:real^2, + vector[(interval_upperbound mp2)$2; + (interval_upperbound mp2)$3]]` THEN + CONJ_TAC THENL + [EXPAND_TAC "E" THEN REWRITE_TAC[IN_IMAGE; IN_ELIM_THM] THEN + EXISTS_TAC `mp2:real^3->bool` THEN + ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID] THEN EXISTS_TAC + `vector[(cv:real^3)$1+sv;(y:real^2)$1;y$2]:real^3` THEN + ASM_REWRITE_TAC[VECTOR_3]; ALL_TAC] THEN + (* y IN proj(mp2) via cube form *) + SUBGOAL_THEN `?cmp2:real^3 smp2. + &0 < smp2 /\ mp2 = interval[cmp2, cmp2 + smp2 % vec 1]` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[cube_dissection; cube]; ALL_TAC] THEN + SUBGOAL_THEN `interval_lowerbound mp2 = cmp2:real^3 /\ + interval_upperbound mp2 = cmp2 + smp2 % vec 1:real^3` + STRIP_ASSUME_TAC THENL [CUBE_BOUNDS_TAC; ALL_TAC] THEN + UNDISCH_TAC + `vector[(cv:real^3)$1+sv;(y:real^2)$1;y$2]:real^3 IN mp2` THEN + ASM_REWRITE_TAC[IN_INTERVAL; DIMINDEX_3; FORALL_3; DIMINDEX_2; + FORALL_2; VECTOR_3; VECTOR_2; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID] THEN MESON_TAC[]; ALL_TAC] THEN + (* Now: closed(UNIONS E), open interval ⊆ UNIONS E *) + EXPAND_TAC "face_sq" THEN + SUBGOAL_THEN `~(interval(vector[(cv:real^3)$2;cv$3]:real^2, + vector[cv$2 + sv;cv$3 + sv]) = {})` + ASSUME_TAC THENL + [REWRITE_TAC[INTERVAL_NE_EMPTY; DIMINDEX_2; FORALL_2; VECTOR_2] THEN + UNDISCH_TAC `&0 < sv` THEN REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `interval[vector[(cv:real^3)$2;cv$3]:real^2, + vector[cv$2 + sv;cv$3 + sv]] = + closure(interval(vector[(cv:real^3)$2;cv$3]:real^2, + vector[cv$2 + sv;cv$3 + sv]))` + SUBST1_TAC THENL + [MATCH_MP_TAC(GSYM CLOSURE_OPEN_INTERVAL) THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + MATCH_MP_TAC CLOSURE_MINIMAL THEN ASM_REWRITE_TAC[]]; ALL_TAC] THEN + (* Conjunct 4: minimality *) + SUBGOAL_THEN `!e:real^2->bool. e IN E /\ ~(e = proj_k) + ==> interval_length proj_k < interval_length e` ASSUME_TAC THENL + [X_GEN_TAC `e0:real^2->bool` THEN STRIP_TAC THEN + (* Unfold e0 IN E to get preimage m1 *) + UNDISCH_TAC `(e0:real^2->bool) IN E` THEN EXPAND_TAC "E" THEN + REWRITE_TAC[IN_IMAGE; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `m1:real^3->bool` STRIP_ASSUME_TAC) THEN + (* m1 is cube, get m1 = interval[cm1, cm1 + sm1 % vec 1] *) + SUBGOAL_THEN `?cm1:real^3 sm1. &0 < sm1 /\ m1 = interval[cm1, cm1 + sm1 % vec 1]` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[cube_dissection; cube]; ALL_TAC] THEN + (* m1 != k: if m1 = k then e0 = proj_k, contradiction *) + SUBGOAL_THEN `~(m1:real^3->bool = k)` ASSUME_TAC THENL + [DISCH_THEN SUBST_ALL_TAC THEN + UNDISCH_TAC `~(e0:real^2->bool = proj_k)` THEN + ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID]; ALL_TAC] THEN + SUBGOAL_THEN `interval_length(k:real^3->bool) < interval_length(m1:real^3->bool)` + ASSUME_TAC THENL [FIRST_ASSUM(fun th -> + if is_forall(concl th) then + let v,_ = dest_forall(concl th) in + if fst(dest_var v) = "j'" then + MP_TAC(SPEC `m1:real^3->bool` th) + else failwith "" + else failwith "") THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID] THEN ASM_MESON_TAC[]; + REWRITE_TAC[]]; ALL_TAC] THEN + (* interval_length k = sk, interval_length m1 = sm1 *) + SUBGOAL_THEN `interval_length(k:real^3->bool) = sk /\ + interval_length(m1:real^3->bool) = sm1` + STRIP_ASSUME_TAC THENL + [CONJ_TAC THEN ASM_SIMP_TAC[INTERVAL_LENGTH_CUBE_POS]; ALL_TAC] THEN + (* interval_length proj_k = sk *) + SUBGOAL_THEN `interval_length(proj_k:real^2->bool) = sk` + ASSUME_TAC THENL + [EXPAND_TAC "proj_k" THEN REWRITE_TAC[VECTOR2_CUBE] THEN + ASM_SIMP_TAC[INTERVAL_LENGTH_CUBE_POS]; ALL_TAC] THEN + (* interval_length e0 = sm1 *) + SUBGOAL_THEN `interval_length(e0:real^2->bool) = sm1` + ASSUME_TAC THENL + [SUBGOAL_THEN `interval_lowerbound(m1:real^3->bool) = cm1 /\ + interval_upperbound m1 = cm1 + sm1 % vec 1:real^3` STRIP_ASSUME_TAC THENL + [CUBE_BOUNDS_TAC; ALL_TAC] THEN + ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID; VECTOR2_CUBE] THEN + ASM_SIMP_TAC[INTERVAL_LENGTH_CUBE_POS]; ALL_TAC] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + MP_TAC(ISPECL [`E:(real^2->bool)->bool`; + `vector[(cv:real^3)$2; cv$3]:real^2`; + `vector[(cv:real^3)$2 + sv; cv$3 + sv]:real^2`; + `proj_k:real^2->bool`] + SQUARE_DISSECTION_NONEDGE) THEN + ANTS_TAC THENL [EXPAND_TAC "face_sq" THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN DISJ_CASES_TAC THENL + [(* proj_k = face_sq: contradiction since sk < sv *) + (* First establish nonemptiness for EQ_INTERVAL simplification *) + SUBGOAL_THEN `~(interval[vector[(ck:real^3)$2;ck$3]:real^2, + vector[ck$2 + sk;ck$3 + sk]] = {}) /\ + ~(interval[vector[(cv:real^3)$2;cv$3]:real^2, + vector[cv$2 + sv;cv$3 + sv]] = {})` STRIP_ASSUME_TAC THENL + [REWRITE_TAC[INTERVAL_NE_EMPTY; DIMINDEX_2; FORALL_2; VECTOR_2] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + (* Derive the concrete interval equality by transitivity *) + SUBGOAL_THEN `interval[vector[(ck:real^3)$2;ck$3]:real^2, + vector[ck$2 + sk;ck$3 + sk]] = + interval[vector[(cv:real^3)$2;cv$3]:real^2, + vector[cv$2 + sv;cv$3 + sv]]` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + (* EQ_INTERVAL + nonemptiness gives endpoint equality, + CART_EQ decomposes to components, yielding sk = sv *) + ASM_REWRITE_TAC[EQ_INTERVAL; CART_EQ; DIMINDEX_2; FORALL_2; + VECTOR_2] THEN ASM_REAL_ARITH_TAC; + (* proj_k SUBSET interior(face_sq) *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [SUBSET]) THEN + EXPAND_TAC "proj_k" THEN EXPAND_TAC "face_sq" THEN + REWRITE_TAC[INTERIOR_INTERVAL; IN_INTERVAL; DIMINDEX_2; FORALL_2; + VECTOR_2; VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID; INTERVAL_NE_EMPTY] THEN + DISCH_THEN(fun th -> + MP_TAC(SPEC `vector[(ck:real^3)$2; ck$3]:real^2` th) THEN + MP_TAC(SPEC `vector[(ck:real^3)$2 + sk; ck$3 + sk]:real^2` th)) THEN + REWRITE_TAC[VECTOR_2] THEN ASM_REAL_ARITH_TAC]);; + +(* Helper: a nonempty open real interval minus a finite set is nonempty *) +let REAL_OPEN_INTERVAL_AVOID_FINITE = prove + (`!s a b. FINITE s /\ a < b ==> ?x:real. a < x /\ x < b /\ ~(x IN s)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN `INFINITE({x:real | a < x /\ x < b} DIFF s)` MP_TAC THENL + [MATCH_MP_TAC INFINITE_DIFF_FINITE THEN + ASM_REWRITE_TAC[INFINITE; FINITE_REAL_INTERVAL] THEN ASM_REAL_ARITH_TAC; + ALL_TAC] THEN DISCH_THEN(MP_TAC o MATCH_MP INFINITE_NONEMPTY) THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_DIFF; IN_ELIM_THM] THEN MESON_TAC[]);; + +(* Containment: if k is the smallest on v's face, and j starts at k's *) +(* right face with a point in k's y,z interior, and m is an adjacent *) +(* cube on v's face forming a "wall", then j fits inside k. *) + +(* Get a real w2 (resp. w3) in an open interval (lo,hi) avoiding all *) +(* cube lowerbound/upperbound values in dimension 2 (resp. 3). *) +let AVOID_DIM2_TAC lo hi = + SUBGOAL_THEN (mk_binop `(<):real->real->bool` lo hi) ASSUME_TAC THENL + [REWRITE_TAC[REAL_MAX_LT; REAL_LT_MIN] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + MP_TAC(ISPECL [`IMAGE (\k':real^3->bool. interval_lowerbound k' $ 2) D UNION + IMAGE (\k':real^3->bool. interval_upperbound k' $ 2) D`; lo; hi] + REAL_OPEN_INTERVAL_AVOID_FINITE) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `w2:real` STRIP_ASSUME_TAC);; + +let AVOID_DIM3_TAC lo hi = + SUBGOAL_THEN (mk_binop `(<):real->real->bool` lo hi) ASSUME_TAC THENL + [REWRITE_TAC[REAL_MAX_LT; REAL_LT_MIN] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + MP_TAC(ISPECL [`IMAGE (\k':real^3->bool. interval_lowerbound k' $ 3) D UNION + IMAGE (\k':real^3->bool. interval_upperbound k' $ 3) D`; lo; hi] + REAL_OPEN_INTERVAL_AVOID_FINITE) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `w3:real` STRIP_ASSUME_TAC);; + +(* Common tactic for the 4 bound branches of VALLEY_DESCENT_CONTAINMENT *) +(* Given: valley v, witness vector[ub v$1; w2; w3] in face, + w2/w3 avoiding cube boundaries, various bounds on w2/w3 *) +(* Proves: contradiction via interior overlap with j *) +let BOUND_COMMON_TAC = + FIRST_ASSUM(MP_TAC o CONJUNCT1 o CONJUNCT2 o + GEN_REWRITE_RULE I [valley]) THEN DISCH_THEN(MP_TAC o SPEC + `vector[interval_upperbound (v:real^3->bool) $ 1; w2; w3]:real^3`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[VECTOR_3]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `m:real^3->bool` STRIP_ASSUME_TAC) THEN + (* m != k: the witness point is outside k by choice of w2 or w3 *) + SUBGOAL_THEN `~(m = k:real^3->bool)` ASSUME_TAC THENL + [DISCH_THEN SUBST_ALL_TAC THEN UNDISCH_TAC + `(vector[interval_upperbound (v:real^3->bool) $ 1; w2; w3]:real^3) IN + (k:real^3->bool)` THEN + ASM_REWRITE_TAC[IN_INTERVAL; DIMINDEX_3; FORALL_3; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID; VECTOR_3] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + (* m cube *) + MESON_ASSUME_TAC [cube_dissection] `cube(m:real^3->bool)` THEN + SUBGOAL_THEN `?cm:real^3 sm. &0 < sm /\ m = interval[cm, cm + sm % vec 1]` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[cube]; ALL_TAC] THEN + SUBGOAL_THEN `(cm + sm % vec 1:real^3)$2 = cm$2 + sm /\ + (cm + sm % vec 1:real^3)$3 = cm$3 + sm` STRIP_ASSUME_TAC THENL + [REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID]; ALL_TAC] THEN + SUBGOAL_THEN `interval_lowerbound m = (cm:real^3) /\ + interval_upperbound m = cm + sm % vec 1:real^3` STRIP_ASSUME_TAC THENL + [CUBE_BOUNDS_TAC; ALL_TAC] THEN + (* interval_length k < interval_length m *) + SUBGOAL_THEN `interval_length (k:real^3->bool) < interval_length (m:real^3->bool)` + ASSUME_TAC THENL [SUBGOAL_THEN + `m IN D /\ ~(m = k:real^3->bool) /\ + interval_lowerbound (m:real^3->bool) $ 1 = + interval_upperbound (v:real^3->bool) $ 1 /\ + (?zz:real^3. zz IN m /\ + interval_lowerbound (v:real^3->bool) $ 2 < zz$2 /\ + zz$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < zz$3 /\ + zz$3 < interval_upperbound (v:real^3->bool) $ 3)` + MP_TAC THENL [ASM_REWRITE_TAC[] THEN + EXISTS_TAC `vector[interval_upperbound (v:real^3->bool) $ 1; + w2; w3]:real^3` THEN ASM_REWRITE_TAC[VECTOR_3]; ALL_TAC] THEN + ASM_MESON_TAC[]; ALL_TAC] THEN + (* sk < sm *) + SUBGOAL_THEN `sk < sm` ASSUME_TAC THENL [UNDISCH_TAC + `interval_length (k:real^3->bool) < interval_length (m:real^3->bool)` THEN + ASM_SIMP_TAC[INTERVAL_LENGTH_CUBE_POS]; ALL_TAC] THEN + (* m != j *) + SUBGOAL_THEN `~(m = j:real^3->bool)` ASSUME_TAC THENL + [DISCH_THEN SUBST_ALL_TAC THEN + SUBGOAL_THEN `(cj:real^3)$1 = interval_upperbound (v:real^3->bool) $ 1` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + (* Strict bounds: wpt in m's open interior *) + SUBGOAL_THEN `interval_lowerbound (m:real^3->bool) $ 2 IN + IMAGE (\k':real^3->bool. interval_lowerbound k' $ 2) D /\ + interval_upperbound (m:real^3->bool) $ 2 IN + IMAGE (\k':real^3->bool. interval_upperbound k' $ 2) D /\ + interval_lowerbound (m:real^3->bool) $ 3 IN + IMAGE (\k':real^3->bool. interval_lowerbound k' $ 3) D /\ + interval_upperbound (m:real^3->bool) $ 3 IN + IMAGE (\k':real^3->bool. interval_upperbound k' $ 3) D` + STRIP_ASSUME_TAC THENL [REPEAT CONJ_TAC THEN REWRITE_TAC[IN_IMAGE] THEN + EXISTS_TAC `m:real^3->bool` THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `~(w2 = interval_lowerbound (m:real^3->bool) $ 2) /\ + ~(w2 = interval_upperbound (m:real^3->bool) $ 2) /\ + ~(w3 = interval_lowerbound (m:real^3->bool) $ 3) /\ + ~(w3 = interval_upperbound (m:real^3->bool) $ 3)` + STRIP_ASSUME_TAC THENL [REPEAT CONJ_TAC THEN DISCH_TAC THEN + ASM_MESON_TAC[IN_IMAGE; IN_UNION]; ALL_TAC] THEN + SUBGOAL_THEN `(cm:real^3)$2 < w2 /\ w2 < cm$2 + sm /\ + cm$3 < w3 /\ w3 < cm$3 + sm` STRIP_ASSUME_TAC THENL + [(* Non-strict from membership, then avoidance makes strict *) + SUBGOAL_THEN `(cm:real^3)$2 <= w2 /\ w2 <= cm$2 + sm /\ + cm$3 <= w3 /\ w3 <= cm$3 + sm` STRIP_ASSUME_TAC THENL + [SUBGOAL_THEN `(vector[interval_upperbound (v:real^3->bool) $ 1; + w2; w3]:real^3) IN interval[cm:real^3, cm + sm % vec 1]` + MP_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_INTERVAL; DIMINDEX_3; FORALL_3; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID; VECTOR_3] THEN + REAL_ARITH_TAC; ALL_TAC] THEN REPEAT CONJ_TAC THEN + MATCH_MP_TAC(REAL_ARITH `x <= y /\ ~(x = y) ==> x < y`) THEN + CONJ_TAC THEN TRY(FIRST_ASSUM ACCEPT_TAC) THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + (* Interior overlap: interior(m) ∩ interior(j) != {} *) + SUBGOAL_THEN `~(interior (m:real^3->bool) INTER interior j = {})` + MP_TAC THENL [REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + ASM_REWRITE_TAC[INTERIOR_INTERVAL] THEN + MESON_ASSUME_TAC [] `(cm:real^3)$1 = (ck:real^3)$1` THEN + EXISTS_TAC `vector[(ck:real^3)$1 + sk + (min (sm - sk) sj) / &2; + w2; w3]:real^3` THEN + REWRITE_TAC[IN_INTERVAL; DIMINDEX_3; FORALL_3; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID; VECTOR_3] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN DISCH_TAC THEN + UNDISCH_TAC `(D:(real^3->bool)->bool) division_of UNIONS D` THEN + DISCH_THEN(MP_TAC o CONJUNCT2 o CONJUNCT2 o + REWRITE_RULE[division_of]) THEN + DISCH_THEN(MP_TAC o SPECL [`m:real^3->bool`; `j:real^3->bool`]) THEN + ASM_REWRITE_TAC[];; + +let VALLEY_DESCENT_CONTAINMENT = prove + (`!D (a:real^3) d (v:real^3->bool) k j. + &0 < d /\ + cube_dissection D /\ + UNIONS D = interval[a, a + d % vec 1] /\ + valley D v /\ + k IN D /\ + interval_lowerbound k $ 1 = interval_upperbound (v:real^3->bool) $ 1 /\ + (?z:real^3. z IN k /\ + interval_lowerbound (v:real^3->bool) $ 2 < z$2 /\ z$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < z$3 /\ z$3 < interval_upperbound (v:real^3->bool) $ 3) /\ + (!j'. j' IN D /\ ~(j' = k) /\ + interval_lowerbound j' $ 1 = interval_upperbound (v:real^3->bool) $ 1 /\ + (?z:real^3. z IN j' /\ + interval_lowerbound (v:real^3->bool) $ 2 < z$2 /\ + z$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < z$3 /\ + z$3 < interval_upperbound (v:real^3->bool) $ 3) + ==> interval_length k < interval_length j') /\ + j IN D /\ + interval_lowerbound j $ 1 = interval_upperbound k $ 1 /\ + (?z:real^3. z IN j /\ + interval_lowerbound k $ 2 < z$2 /\ z$2 < interval_upperbound k $ 2 /\ + interval_lowerbound k $ 3 < z$3 /\ z$3 < interval_upperbound k $ 3) + ==> interval_lowerbound k $ 2 <= interval_lowerbound j $ 2 /\ + interval_upperbound j $ 2 <= interval_upperbound k $ 2 /\ + interval_lowerbound k $ 3 <= interval_lowerbound j $ 3 /\ + interval_upperbound j $ 3 <= interval_upperbound k $ 3`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Apply VALLEY_FACE_INTERIOR for strict containment of k in v *) + MP_TAC(ISPECL [`D:(real^3->bool)->bool`; `a:real^3`; `d:real`; + `v:real^3->bool`; `k:real^3->bool`] + VALLEY_FACE_INTERIOR) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + STRIP_TAC THEN + (* Common setup *) + MESON_ASSUME_TAC [cube_dissection] `(D:(real^3->bool)->bool) division_of UNIONS D` THEN + MESON_ASSUME_TAC [division_of] `FINITE(D:(real^3->bool)->bool)` THEN + MESON_ASSUME_TAC [cube_dissection] `cube(k:real^3->bool)` THEN + MESON_ASSUME_TAC [cube_dissection] `cube(j:real^3->bool)` THEN + (* Express k and j in cube form *) + SUBGOAL_THEN `?ck:real^3 sk. &0 < sk /\ k = interval[ck, ck + sk % vec 1]` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[cube]; ALL_TAC] THEN + SUBGOAL_THEN `?cj:real^3 sj. &0 < sj /\ j = interval[cj, cj + sj % vec 1]` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[cube]; ALL_TAC] THEN + SUBGOAL_THEN `(interval_lowerbound k = (ck:real^3) /\ + interval_upperbound k = ck + sk % vec 1:real^3) /\ + (interval_lowerbound j = (cj:real^3) /\ + interval_upperbound j = cj + sj % vec 1:real^3)` STRIP_ASSUME_TAC THENL + [CONJ_TAC THEN CUBE_BOUNDS_TAC; ALL_TAC] THEN + ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID] THEN + (* === Common setup for all four bounds === *) + SUBGOAL_THEN `(ck + sk % vec 1:real^3)$1 = ck$1 + sk /\ + (ck + sk % vec 1:real^3)$2 = ck$2 + sk /\ + (ck + sk % vec 1:real^3)$3 = ck$3 + sk /\ + (cj + sj % vec 1:real^3)$1 = cj$1 + sj /\ + (cj + sj % vec 1:real^3)$2 = cj$2 + sj /\ + (cj + sj % vec 1:real^3)$3 = cj$3 + sj` + STRIP_ASSUME_TAC THENL + [REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID]; ALL_TAC] THEN + MESON_ASSUME_TAC [] `(cj:real^3)$1 = (ck:real^3)$1 + sk` THEN + MESON_ASSUME_TAC [] `(ck:real^3)$1 = interval_upperbound (v:real^3->bool) $ 1` THEN + (* Explicit component equalities to avoid expensive MESON chaining *) + SUBGOAL_THEN `interval_lowerbound (k:real^3->bool) $ 2 = (ck:real^3)$2 /\ + interval_lowerbound k $ 3 = ck$3 /\ + interval_upperbound k $ 2 = ck$2 + sk /\ + interval_upperbound k $ 3 = ck$3 + sk` STRIP_ASSUME_TAC THENL + [ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT; REAL_MUL_RID]; ALL_TAC] THEN + SUBGOAL_THEN `(interval_lowerbound (v:real^3->bool) $ 2 < (ck:real^3)$2 /\ + ck$2 + sk < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < ck$3 /\ + ck$3 + sk < interval_upperbound (v:real^3->bool) $ 3) /\ + (ck$2 < (z':real^3)$2 /\ z'$2 < ck$2 + sk /\ + ck$3 < z'$3 /\ z'$3 < ck$3 + sk)` + STRIP_ASSUME_TAC THENL [CONJ_TAC THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(z':real^3) IN interval[cj:real^3, cj + sj % vec 1]` + ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(cj:real^3)$2 <= (z':real^3)$2 /\ z'$2 <= cj$2 + sj /\ + cj$3 <= z'$3 /\ z'$3 <= cj$3 + sj` STRIP_ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_INTERVAL]) THEN + REWRITE_TAC[DIMINDEX_3; FORALL_3; VECTOR_ADD_COMPONENT; + VECTOR_MUL_COMPONENT; VEC_COMPONENT; REAL_MUL_RID] THEN + REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `FINITE(IMAGE (\k':real^3->bool. interval_lowerbound k' $ 2) D UNION + IMAGE (\k':real^3->bool. interval_upperbound k' $ 2) D) /\ + FINITE(IMAGE (\k':real^3->bool. interval_lowerbound k' $ 3) D UNION + IMAGE (\k':real^3->bool. interval_upperbound k' $ 3) D)` STRIP_ASSUME_TAC THENL + [CONJ_TAC THEN REWRITE_TAC[FINITE_UNION] THEN + CONJ_TAC THEN MATCH_MP_TAC FINITE_IMAGE THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN SUBGOAL_THEN + `pairwise (\k:real^3->bool k'. ~(interval_length k = interval_length k')) D` + ASSUME_TAC THENL [ASM_MESON_TAC[cube_dissection]; ALL_TAC] THEN + (* === Prove each bound by contradiction === *) + REPEAT CONJ_TAC THENL [(* Bound 1: ck$2 <= cj$2 *) + REWRITE_TAC[GSYM REAL_NOT_LT] THEN DISCH_TAC THEN AVOID_DIM3_TAC + `max (interval_lowerbound (v:real^3->bool) $ 3) ((cj:real^3)$3)` + `min (interval_upperbound (v:real^3->bool) $ 3) ((cj:real^3)$3 + sj)` THEN + AVOID_DIM2_TAC + `max (interval_lowerbound (v:real^3->bool) $ 2) ((cj:real^3)$2)` + `(ck:real^3)$2` THEN SUBGOAL_THEN + `interval_lowerbound (v:real^3->bool) $ 2 < w2 /\ (cj:real^3)$2 < w2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < w3 /\ cj$3 < w3 /\ + w3 < interval_upperbound (v:real^3->bool) $ 3 /\ w3 < cj$3 + sj /\ + w2 < interval_upperbound (v:real^3->bool) $ 2` + STRIP_ASSUME_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + BOUND_COMMON_TAC; + + (* Bound 2: cj$2 + sj <= ck$2 + sk *) + REWRITE_TAC[GSYM REAL_NOT_LT] THEN DISCH_TAC THEN AVOID_DIM3_TAC + `max (interval_lowerbound (v:real^3->bool) $ 3) ((cj:real^3)$3)` + `min (interval_upperbound (v:real^3->bool) $ 3) ((cj:real^3)$3 + sj)` THEN + AVOID_DIM2_TAC `(ck:real^3)$2 + sk` + `min (interval_upperbound (v:real^3->bool) $ 2) ((cj:real^3)$2 + sj)` THEN + SUBGOAL_THEN + `interval_lowerbound (v:real^3->bool) $ 2 < w2 /\ + w2 < (cj:real^3)$2 + sj /\ + w2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < w3 /\ cj$3 < w3 /\ + w3 < interval_upperbound (v:real^3->bool) $ 3 /\ w3 < cj$3 + sj` + STRIP_ASSUME_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + BOUND_COMMON_TAC; + + (* Bound 3: ck$3 <= cj$3 *) + REWRITE_TAC[GSYM REAL_NOT_LT] THEN DISCH_TAC THEN AVOID_DIM2_TAC + `max (interval_lowerbound (v:real^3->bool) $ 2) ((cj:real^3)$2)` + `min (interval_upperbound (v:real^3->bool) $ 2) ((cj:real^3)$2 + sj)` THEN + AVOID_DIM3_TAC + `max (interval_lowerbound (v:real^3->bool) $ 3) ((cj:real^3)$3)` + `(ck:real^3)$3` THEN SUBGOAL_THEN + `interval_lowerbound (v:real^3->bool) $ 2 < w2 /\ (cj:real^3)$2 < w2 /\ + w2 < interval_upperbound (v:real^3->bool) $ 2 /\ w2 < cj$2 + sj /\ + interval_lowerbound (v:real^3->bool) $ 3 < w3 /\ cj$3 < w3 /\ + w3 < interval_upperbound (v:real^3->bool) $ 3` + STRIP_ASSUME_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + BOUND_COMMON_TAC; + + (* Bound 4: cj$3 + sj <= ck$3 + sk *) + REWRITE_TAC[GSYM REAL_NOT_LT] THEN DISCH_TAC THEN AVOID_DIM2_TAC + `max (interval_lowerbound (v:real^3->bool) $ 2) ((cj:real^3)$2)` + `min (interval_upperbound (v:real^3->bool) $ 2) ((cj:real^3)$2 + sj)` THEN + AVOID_DIM3_TAC `(ck:real^3)$3 + sk` + `min (interval_upperbound (v:real^3->bool) $ 3) ((cj:real^3)$3 + sj)` THEN + SUBGOAL_THEN + `interval_lowerbound (v:real^3->bool) $ 2 < w2 /\ (cj:real^3)$2 < w2 /\ + w2 < interval_upperbound (v:real^3->bool) $ 2 /\ w2 < cj$2 + sj /\ + interval_lowerbound (v:real^3->bool) $ 3 < w3 /\ + w3 < (cj:real^3)$3 + sj /\ + w3 < interval_upperbound (v:real^3->bool) $ 3` + STRIP_ASSUME_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + BOUND_COMMON_TAC]);; + +(* The smallest face cube has a neighbor: there must be another cube on v's face + that is distinct from k and also overlaps v's interior in dims 2,3 *) + +let VALLEY_FACE_EXISTS_ANOTHER = prove + (`!D (a:real^3) d (v:real^3->bool) (k:real^3->bool). + &0 < d /\ + cube_dissection D /\ + UNIONS D = interval[a, a + d % vec 1] /\ + valley D v /\ + k IN D /\ + interval_lowerbound k $ 1 = interval_upperbound (v:real^3->bool) $ 1 /\ + (?z. z IN k /\ + interval_lowerbound (v:real^3->bool) $ 2 < z$2 /\ + z$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < z$3 /\ + z$3 < interval_upperbound (v:real^3->bool) $ 3) /\ + (!j'. j' IN D /\ ~(j' = k) /\ + interval_lowerbound j' $ 1 = interval_upperbound (v:real^3->bool) $ 1 /\ + (?z. z IN j' /\ + interval_lowerbound (v:real^3->bool) $ 2 < z$2 /\ + z$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < z$3 /\ + z$3 < interval_upperbound (v:real^3->bool) $ 3) + ==> interval_length k < interval_length j') + ==> ?j0. j0 IN D /\ ~(j0 = k) /\ + interval_lowerbound j0 $ 1 = interval_upperbound (v:real^3->bool) $ 1 /\ + (?z'. z' IN j0 /\ + interval_lowerbound (v:real^3->bool) $ 2 < z'$2 /\ + z'$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < z'$3 /\ + z'$3 < interval_upperbound (v:real^3->bool) $ 3)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Step 1: Strict containment from VALLEY_FACE_INTERIOR *) + SUBGOAL_THEN `interval_lowerbound (v:real^3->bool) $ 2 < + interval_lowerbound (k:real^3->bool) $ 2 /\ + interval_upperbound k $ 2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < interval_lowerbound k $ 3 /\ + interval_upperbound k $ 3 < interval_upperbound (v:real^3->bool) $ 3` STRIP_ASSUME_TAC THENL + [MP_TAC(ISPECL [`D:(real^3->bool)->bool`; `a:real^3`; `d:real`; + `v:real^3->bool`; `k:real^3->bool`] + VALLEY_FACE_INTERIOR) THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + (* Step 2: Cubical form of k *) + SUBGOAL_THEN `?ck:real^3 sk. &0 < sk /\ k = interval[ck, ck + sk % vec 1]` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[cube_dissection; cube]; ALL_TAC] THEN + (* Step 3: Compute bounds of k *) + SUBGOAL_THEN `interval_lowerbound (k:real^3->bool) = (ck:real^3) /\ + interval_upperbound k = ck + sk % vec 1:real^3` STRIP_ASSUME_TAC THENL + [CUBE_BOUNDS_TAC; ALL_TAC] THEN + (* Step 4: Construct witness point in gap between v and k *) + ABBREV_TAC `zw = vector[interval_upperbound (v:real^3->bool) $ 1; + (interval_lowerbound (v:real^3->bool) $ 2 + (ck:real^3)$2) / &2; + (interval_lowerbound (v:real^3->bool) $ 3 + ck$3) / &2]:real^3` THEN + (* Step 5: Witness NOT in k (its $2 component < lb k$2) *) + SUBGOAL_THEN `~((zw:real^3) IN (k:real^3->bool))` ASSUME_TAC THENL + [ASM_REWRITE_TAC[] THEN SIMP_TAC[IN_INTERVAL; DIMINDEX_3; FORALL_3; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VEC_COMPONENT; + REAL_MUL_RID] THEN EXPAND_TAC "zw" THEN REWRITE_TAC[VECTOR_3] THEN + UNDISCH_TAC `interval_lowerbound (v:real^3->bool) $ 2 < + interval_lowerbound (k:real^3->bool) $ 2` THEN + ASM_REWRITE_TAC[] THEN REAL_ARITH_TAC; ALL_TAC] THEN + (* Step 6: Witness in v's face interior *) + SUBGOAL_THEN `(zw:real^3)$1 = interval_upperbound (v:real^3->bool) $ 1 /\ + interval_lowerbound (v:real^3->bool) $ 2 < zw$2 /\ + zw$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < zw$3 /\ + zw$3 < interval_upperbound (v:real^3->bool) $ 3` STRIP_ASSUME_TAC THENL + [EXPAND_TAC "zw" THEN REWRITE_TAC[VECTOR_3] THEN MAP_EVERY UNDISCH_TAC + [`&0 < sk`; + `interval_upperbound (k:real^3->bool) $ 3 < + interval_upperbound (v:real^3->bool) $ 3`; + `interval_lowerbound (v:real^3->bool) $ 3 < + interval_lowerbound (k:real^3->bool) $ 3`; + `interval_upperbound (k:real^3->bool) $ 2 < + interval_upperbound (v:real^3->bool) $ 2`; + `interval_lowerbound (v:real^3->bool) $ 2 < + interval_lowerbound (k:real^3->bool) $ 2`] THEN + ASM_REWRITE_TAC[VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT] THEN + SIMP_TAC[VEC_COMPONENT; DIMINDEX_3; ARITH; REAL_MUL_RID] THEN + REAL_ARITH_TAC; ALL_TAC] THEN + (* Step 7: Valley covering gives j0 containing zw *) + SUBGOAL_THEN `?j0:real^3->bool. j0 IN D /\ (zw:real^3) IN j0 /\ + interval_lowerbound j0 $ 1 = interval_upperbound (v:real^3->bool) $ 1` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[valley]; ALL_TAC] THEN + (* Step 8: j0 satisfies all conditions *) + EXISTS_TAC `j0:real^3->bool` THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [(* j0 != k: zw IN j0 but ~(zw IN k) *) + ASM_MESON_TAC[]; + (* zw witnesses j0 overlapping v's interior *) + EXISTS_TAC `zw:real^3` THEN ASM_REWRITE_TAC[]]);; + +(* Key descent: any valley produces a smaller valley on an element of D *) + +let VALLEY_DESCENT = prove + (`!D (a:real^3) d (v:real^3->bool). + &0 < d /\ + cube_dissection D /\ + UNIONS D = interval[a, a + d % vec 1] /\ + valley D v + ==> ?k. k IN D /\ interval_length k < interval_length v /\ + valley D k`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + MESON_ASSUME_TAC [cube_dissection] `(D:(real^3->bool)->bool) division_of UNIONS D` THEN + MESON_ASSUME_TAC [division_of] `FINITE(D:(real^3->bool)->bool)` THEN + MESON_ASSUME_TAC [valley] `cube(v:real^3->bool)` THEN + (* Face set is nonempty: v has a nonempty face covered by valley *) + SUBGOAL_THEN `?k0:real^3->bool. k0 IN D /\ + interval_lowerbound k0 $ 1 = interval_upperbound (v:real^3->bool) $ 1 /\ + (?z:real^3. z IN k0 /\ + interval_lowerbound (v:real^3->bool) $ 2 < z$2 /\ + z$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < z$3 /\ + z$3 < interval_upperbound (v:real^3->bool) $ 3)` + STRIP_ASSUME_TAC THENL + [(* v is cube with positive side, so face interior is nonempty *) + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [cube]) THEN + DISCH_THEN(X_CHOOSE_THEN `av:real^3` + (X_CHOOSE_THEN `dv:real` STRIP_ASSUME_TAC)) THEN + SUBGOAL_THEN `interval_upperbound (v:real^3->bool) $ 1 = (av:real^3)$1 + dv /\ + interval_lowerbound (v:real^3->bool) $ 2 = av$2 /\ + interval_upperbound (v:real^3->bool) $ 2 = av$2 + dv /\ + interval_lowerbound (v:real^3->bool) $ 3 = av$3 /\ + interval_upperbound (v:real^3->bool) $ 3 = av$3 + dv` STRIP_ASSUME_TAC THENL + [SUBGOAL_THEN `~(interval[av:real^3, av + dv % vec 1] = {})` + ASSUME_TAC THENL [ASM_MESON_TAC[CUBE_IMP_NONEMPTY]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN ASM_SIMP_TAC[INTERVAL_UPPERBOUND_NONEMPTY; + INTERVAL_LOWERBOUND_NONEMPTY; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; + VEC_COMPONENT] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + FIRST_ASSUM(MP_TAC o CONJUNCT1 o CONJUNCT2 o + GEN_REWRITE_RULE I [valley]) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC + `vector[(av:real^3)$1 + dv; av$2 + dv / &2; av$3 + dv / &2]:real^3`) THEN + REWRITE_TAC[VECTOR_3] THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `k1:real^3->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `k1:real^3->bool` THEN ASM_REWRITE_TAC[] THEN + EXISTS_TAC `vector[(av:real^3)$1 + dv; av$2 + dv / &2; av$3 + dv / &2]:real^3` THEN + ASM_REWRITE_TAC[VECTOR_3] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + MESON_ASSUME_TAC [cube_dissection] + `pairwise (\k:real^3->bool k'. ~(interval_length k = interval_length k')) D` THEN + (* Get smallest face cube using FINITE_PAIRWISE_MINIMUM *) + MP_TAC(ISPECL + [`interval_length:(real^3->bool)->real`; + `{k:real^3->bool | k IN D /\ + interval_lowerbound k $ 1 = interval_upperbound (v:real^3->bool) $ 1 /\ + (?z:real^3. z IN k /\ + interval_lowerbound (v:real^3->bool) $ 2 < z$2 /\ + z$2 < interval_upperbound (v:real^3->bool) $ 2 /\ + interval_lowerbound (v:real^3->bool) $ 3 < z$3 /\ + z$3 < interval_upperbound (v:real^3->bool) $ 3)}`] + FINITE_PAIRWISE_MINIMUM) THEN + ANTS_TAC THENL [REPEAT CONJ_TAC THENL + [MATCH_MP_TAC FINITE_RESTRICT THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + EXISTS_TAC `k0:real^3->bool` THEN ASM_REWRITE_TAC[] THEN + EXISTS_TAC `z:real^3` THEN ASM_REWRITE_TAC[]; + MATCH_MP_TAC PAIRWISE_MONO THEN EXISTS_TAC `D:(real^3->bool)->bool` THEN + ASM_REWRITE_TAC[] THEN SET_TAC[]]; ALL_TAC] THEN + REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `k:real^3->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `interval_length (k:real^3->bool) < interval_length (v:real^3->bool)` + ASSUME_TAC THENL [ASM_MESON_TAC[valley]; ALL_TAC] THEN + EXISTS_TAC `k:real^3->bool` THEN ASM_REWRITE_TAC[] THEN + (* valley D k *) + REWRITE_TAC[valley] THEN + MESON_ASSUME_TAC [cube_dissection] `cube(k:real^3->bool)` THEN + ASM_REWRITE_TAC[] THEN + REPEAT CONJ_TAC THENL [(* covering: forall z on k's face, exists j in D *) + X_GEN_TAC `zc:real^3` THEN STRIP_TAC THEN + (* Express k in interval form *) + SUBGOAL_THEN `?ck:real^3 sk. &0 < sk /\ k = interval[ck, ck + sk % vec 1]` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[cube]; ALL_TAC] THEN + MESON_ASSUME_TAC [CUBE_IMP_NONEMPTY] `~(k:real^3->bool = {})` THEN + MESON_ASSUME_TAC [] `~(interval[ck:real^3,ck + sk % vec 1] = {})` THEN + SUBGOAL_THEN `(k:real^3->bool) SUBSET interval[a:real^3, a + d % vec 1]` + ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + (* ub k$1 < a$1 + d *) + SUBGOAL_THEN `interval_upperbound (k:real^3->bool) $ 1 < (a + d % vec 1:real^3) $ 1` + ASSUME_TAC THENL + [SUBGOAL_THEN `interval_upperbound (k:real^3->bool) $ 1 = interval_lowerbound k $ 1 + interval_length k` + ASSUME_TAC THENL [MP_TAC(ISPECL [`k:real^3->bool`; `1`] + INTERVAL_LENGTH_CUBE_COMPONENT) THEN + ASM_REWRITE_TAC[] THEN REAL_ARITH_TAC; ALL_TAC] THEN + (* There exists another face cube j0 != k *) + MP_TAC(ISPECL [`D:(real^3->bool)->bool`; `a:real^3`; `d:real`; + `v:real^3->bool`; `k:real^3->bool`] + VALLEY_FACE_EXISTS_ANOTHER) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `j0:real^3->bool` STRIP_ASSUME_TAC) THEN + (* interval_length k < interval_length j0 *) + SUBGOAL_THEN `interval_length (k:real^3->bool) < interval_length (j0:real^3->bool)` + ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + MESON_ASSUME_TAC [cube_dissection] `cube(j0:real^3->bool)` THEN + SUBGOAL_THEN `interval_upperbound (j0:real^3->bool) $ 1 = interval_lowerbound j0 $ 1 + interval_length j0` + ASSUME_TAC THENL [MP_TAC(ISPECL [`j0:real^3->bool`; `1`] + INTERVAL_LENGTH_CUBE_COMPONENT) THEN + ASM_REWRITE_TAC[] THEN REAL_ARITH_TAC; ALL_TAC] THEN + (* j0 SUBSET big box *) + SUBGOAL_THEN `(j0:real^3->bool) SUBSET interval[a:real^3, a + d % vec 1]` + ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + MESON_ASSUME_TAC [CUBE_IMP_NONEMPTY] `~(j0:real^3->bool = {})` THEN + (* ub j0$1 <= (a+d%vec1)$1 *) + SUBGOAL_THEN `interval_upperbound (j0:real^3->bool) $ 1 <= (a + d % vec 1:real^3) $ 1` + ASSUME_TAC THENL [SUBGOAL_THEN + `?cj:real^3 sj. &0 < sj /\ j0 = interval[cj, cj + sj % vec 1]` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[cube]; ALL_TAC] THEN + SUBGOAL_THEN `~(interval[cj:real^3, cj + sj % vec 1] = {})` + ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `interval_upperbound (j0:real^3->bool) IN j0` + ASSUME_TAC THENL + [ASM_SIMP_TAC[INTERVAL_UPPERBOUND_NONEMPTY; IN_INTERVAL; + DIMINDEX_3; FORALL_3; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VEC_COMPONENT; + REAL_MUL_RID] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `interval_upperbound (j0:real^3->bool) IN interval[a:real^3, a + d % vec 1]` + MP_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + SIMP_TAC[IN_INTERVAL; DIMINDEX_3; FORALL_3; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VEC_COMPONENT; + REAL_MUL_RID] THEN REAL_ARITH_TAC; ALL_TAC] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + (* zc is in k (on its boundary in dim 1, interior in dims 2,3) *) + SUBGOAL_THEN `(zc:real^3) IN (k:real^3->bool)` ASSUME_TAC THENL + [MAP_EVERY UNDISCH_TAC + [`(zc:real^3)$1 = interval_upperbound (k:real^3->bool) $ 1`; + `interval_lowerbound (k:real^3->bool) $ 2 < (zc:real^3) $ 2`; + `(zc:real^3) $ 2 < interval_upperbound (k:real^3->bool) $ 2`; + `interval_lowerbound (k:real^3->bool) $ 3 < (zc:real^3) $ 3`; + `(zc:real^3) $ 3 < interval_upperbound (k:real^3->bool) $ 3`; + `&0 < sk`] THEN ASM_SIMP_TAC[IN_INTERVAL; DIMINDEX_3; FORALL_3; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VEC_COMPONENT; + REAL_MUL_RID; INTERVAL_LOWERBOUND_NONEMPTY; + INTERVAL_UPPERBOUND_NONEMPTY] THEN REAL_ARITH_TAC; ALL_TAC] THEN + (* a$1 < zc$1 *) + SUBGOAL_THEN `(a:real^3)$1 < (zc:real^3)$1` ASSUME_TAC THENL [UNDISCH_TAC + `(zc:real^3)$1 = interval_upperbound (k:real^3->bool)$1` THEN + UNDISCH_TAC + `(k:real^3->bool) SUBSET interval[a:real^3,a + d % vec 1]` THEN + UNDISCH_TAC `&0 < sk` THEN + ASM_SIMP_TAC[SUBSET_INTERVAL; INTERVAL_UPPERBOUND_NONEMPTY; + DIMINDEX_3; FORALL_3; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VEC_COMPONENT; + REAL_MUL_RID] THEN REAL_ARITH_TAC; ALL_TAC] THEN + (* Apply POINT_IN_MULTIPLE_DIVISION_OF_GEN with i=1 *) + MP_TAC(ISPECL + [`D:(real^3->bool)->bool`; `a:real^3`; `a + d % vec 1:real^3`; + `ck:real^3`; `ck + sk % vec 1:real^3`; `zc:real^3`; `1`] + POINT_IN_MULTIPLE_DIVISION_OF_GEN) THEN + ASM_REWRITE_TAC[ARITH_RULE `1 <= 1`; DIMINDEX_3; ARITH_RULE `1 <= 3`] THEN + ANTS_TAC THENL [UNDISCH_TAC + `interval_upperbound (k:real^3->bool)$1 < + (a + d % vec 1:real^3)$1` THEN + ASM_SIMP_TAC[SUBSET_REFL; INTERVAL_UPPERBOUND_NONEMPTY; + VECTOR_ADD_COMPONENT; VECTOR_MUL_COMPONENT; VEC_COMPONENT; + REAL_MUL_RID] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `jc:real^3->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `jc:real^3->bool` THEN + REPEAT CONJ_TAC THENL [ASM_MESON_TAC[]; ASM_MESON_TAC[]; + MATCH_MP_TAC(ISPECL + [`D:(real^3->bool)->bool`; `k:real^3->bool`; + `jc:real^3->bool`; `zc:real^3`] DIVISION_FACE_LOWERBOUND) THEN + ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[CUBE_IMP_NONEMPTY_INTERIOR; cube_dissection]]; + (* containment: face cubes of k fit in k's y,z footprint *) + X_GEN_TAC `j:real^3->bool` THEN STRIP_TAC THEN MATCH_MP_TAC(ISPECL + [`D:(real^3->bool)->bool`; `a:real^3`; `d:real`; + `v:real^3->bool`; `k:real^3->bool`; `j:real^3->bool`] + VALLEY_DESCENT_CONTAINMENT) THEN ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + (* smaller: face cubes of k have smaller interval_length *) + X_GEN_TAC `j:real^3->bool` THEN STRIP_TAC THEN + (* j != k since lowerbound j$1 = upperbound k$1 > lowerbound k$1 *) + SUBGOAL_THEN `~(j:real^3->bool = k)` ASSUME_TAC THENL + [DISCH_THEN SUBST_ALL_TAC THEN MP_TAC(ISPECL [`k:real^3->bool`; `1`] + INTERVAL_LENGTH_CUBE_COMPONENT) THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `&0 < interval_length(k:real^3->bool)` MP_TAC THENL + [UNDISCH_TAC `cube(k:real^3->bool)` THEN + REWRITE_TAC[cube] THEN STRIP_TAC THEN + ASM_REWRITE_TAC[INTERVAL_LENGTH_CUBE] THEN ASM_REAL_ARITH_TAC; + ASM_REAL_ARITH_TAC]; ALL_TAC] THEN + SUBGOAL_THEN `interval_lowerbound (k:real^3->bool) $ 2 <= + interval_lowerbound (j:real^3->bool) $ 2 /\ + interval_upperbound j $ 2 <= interval_upperbound k $ 2 /\ + interval_lowerbound k $ 3 <= interval_lowerbound j $ 3 /\ + interval_upperbound j $ 3 <= interval_upperbound k $ 3` STRIP_ASSUME_TAC THENL + [MATCH_MP_TAC(ISPECL + [`D:(real^3->bool)->bool`; `a:real^3`; `d:real`; + `v:real^3->bool`; `k:real^3->bool`; `j:real^3->bool`] + VALLEY_DESCENT_CONTAINMENT) THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + MESON_ASSUME_TAC [cube_dissection] `cube(j:real^3->bool)` THEN + MATCH_MP_TAC(REAL_ARITH `x <= y /\ ~(x = y) ==> x < y`) THEN + CONJ_TAC THENL [MP_TAC(ISPECL [`k:real^3->bool`; `2`] + INTERVAL_LENGTH_CUBE_COMPONENT) THEN + MP_TAC(ISPECL [`j:real^3->bool`; `2`] + INTERVAL_LENGTH_CUBE_COMPONENT) THEN + ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC; ASM_MESON_TAC[pairwise]]]);; + +(* Impossibility: no cube dissection of an interval can have a valley *) + +let VALLEY_IMPOSSIBLE = prove + (`!D (a:real^3) d (v:real^3->bool). + &0 < d /\ + cube_dissection D /\ + UNIONS D = interval[a, a + d % vec 1] /\ + valley D v ==> F`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + MESON_ASSUME_TAC [cube_dissection] `(D:(real^3->bool)->bool) division_of UNIONS D` THEN + MESON_ASSUME_TAC [division_of] `FINITE(D:(real^3->bool)->bool)` THEN + SUBGOAL_THEN `!n (v:real^3->bool). + CARD {k:real^3->bool | k IN (D:(real^3->bool)->bool) /\ + interval_length k < interval_length v} + = n /\ valley D v ==> F` + (fun th -> ASM_MESON_TAC[th]) THEN + MATCH_MP_TAC num_WF THEN X_GEN_TAC `n:num` THEN DISCH_TAC THEN + X_GEN_TAC `v':real^3->bool` THEN STRIP_TAC THEN + MP_TAC(ISPECL [`D:(real^3->bool)->bool`; `a:real^3`; `d:real`; + `v':real^3->bool`] + VALLEY_DESCENT) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `k:real^3->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o SPEC + `CARD {k':real^3->bool | k' IN (D:(real^3->bool)->bool) /\ + interval_length k' < interval_length (k:real^3->bool)}`) THEN + ANTS_TAC THENL [SUBGOAL_THEN + `{k':real^3->bool | k' IN (D:(real^3->bool)->bool) /\ + interval_length k' < interval_length (k:real^3->bool)} + PSUBSET + {k':real^3->bool | k' IN D /\ + interval_length k' < interval_length (v':real^3->bool)}` + MP_TAC THENL [REWRITE_TAC[PSUBSET; SUBSET; IN_ELIM_THM] THEN CONJ_TAC THENL + [ASM_MESON_TAC[REAL_LT_TRANS]; ALL_TAC] THEN + REWRITE_TAC[EXTENSION; IN_ELIM_THM] THEN + DISCH_THEN(MP_TAC o SPEC `k:real^3->bool`) THEN + ASM_REWRITE_TAC[REAL_LT_REFL]; + DISCH_TAC THEN + SUBGOAL_THEN `FINITE {k':real^3->bool | k' IN (D:(real^3->bool)->bool) /\ + interval_length k' < interval_length (v':real^3->bool)}` + ASSUME_TAC THENL + [MATCH_MP_TAC FINITE_RESTRICT THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `CARD {k':real^3->bool | k' IN (D:(real^3->bool)->bool) /\ + interval_length k' < interval_length (k:real^3->bool)} + < CARD {k':real^3->bool | k' IN D /\ + interval_length k' < interval_length (v':real^3->bool)}` + MP_TAC THENL [MATCH_MP_TAC CARD_PSUBSET THEN ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[]]]; + DISCH_THEN(MP_TAC o SPEC `k:real^3->bool`) THEN ASM_REWRITE_TAC[]]);; + +(* For the cube case: use VALLEY_INITIAL + VALLEY_IMPOSSIBLE *) +let ONLY_TRIVIAL_CUBE_DISSECTION_CUBE = prove + (`!(a:real^3) d D. + &0 < d /\ + cube_dissection D /\ + UNIONS D = interval[a, a + d % vec 1] + ==> D = {interval[a, a + d % vec 1]}`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + ASM_CASES_TAC `D = {interval[a:real^3, a + d % vec 1]}` THEN + ASM_REWRITE_TAC[] THEN + MP_TAC(ISPECL [`D:(real^3->bool)->bool`; `a:real^3`; `d:real`; + `interval[a - d % basis 1:real^3, + a - d % basis 1 + d % vec 1]`] + VALLEY_IMPOSSIBLE) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC VALLEY_INITIAL THEN ASM_REWRITE_TAC[]; REWRITE_TAC[]]);; + +(* Clean statement: a cube dissection of a cube is trivial *) + +let ONLY_TRIVIAL_CUBE_DISSECTION = prove + (`!D:(real^3->bool)->bool. + cube_dissection D /\ cube(UNIONS D) ==> D = {UNIONS D}`, + GEN_TAC THEN REWRITE_TAC[cube] THEN DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `a:real^3` + (X_CHOOSE_THEN `d:real` STRIP_ASSUME_TAC))) THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC ONLY_TRIVIAL_CUBE_DISSECTION_CUBE THEN ASM_REWRITE_TAC[]);; diff --git a/CHANGES b/CHANGES index 0a27dfa1..f3f79ff7 100644 --- a/CHANGES +++ b/CHANGES @@ -8,6 +8,465 @@ * page: https://github.com/jrh13/hol-light/commits/master * * ***************************************************************** +Thu 26th Feb 2026 Multivariate/metric.ml, Multivariate/paths.ml + +Added major new results about path-connectedness in general metric +spaces, together with generalizations of existing Euclidean-specific +theorems, almost entirely written by Claude Code (Opus 4.6). + +The Alexandroff-Hausdorff theorem (ALEXANDROFF_HAUSDORFF: every +compact metrizable space is a continuous image of the Cantor space) +and the Hahn-Mazurkiewicz theorem (HAHN_MAZURKIEWICZ: a metrizable +continuum is a Peano continuum iff it is a continuous image of the +unit interval) are entirely new results, not generalizations of +anything previously in HOL Light. Their proofs go through a chain +of substantial lemmas: the Alexandroff-Hausdorff embedding provides +dense maps from Cantor space into compact metric spaces, and a +gap-filling extension lemma (PEANO_GAP_FILLING_EXTENSION) for +locally connected continua then yields the full Hahn-Mazurkiewicz +characterization. + +From Hahn-Mazurkiewicz it follows that compact connected locally +connected metric spaces are path-connected +(COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED). This +is then extended to the locally compact case by expressing open +subsets as unions of compact connected locally connected sets +(LOCALLY_CONNECTED_CONTINUUM_SPACE), then to complete metric +spaces (MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED, +often called Menger's theorem). The existing Euclidean theorem +LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED assumed local +compactness; the new general version for complete metric spaces is +strictly stronger, since completeness is a weaker hypothesis than +local compactness. + +New Euclidean specializations in paths.ml include optimal G_delta +versions: GDELTA_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED +gives path-connectedness under the weakest natural hypothesis for +R^n, since G_delta is equivalent to completely metrizable in +Euclidean space. + +Supporting infrastructure includes: well-chained set refinements +in open covers (CHAIN_FROM_OPEN_COVER), connected chain unions +(CONNECTED_IN_CHAIN_UNIONS), compact nested intersections +(COMPACT_NESTED_INTERS), fine connected covers of open connected +sets (OPEN_CONNECTED_FINE_COVER), the full chain hierarchy +construction for dyadic approximation (CHAIN_HIERARCHY), and +closure of dyadic rationals in the unit interval +(CLOSURE_OF_DYADIC_RATIONALS_IN_UNIT_INTERVAL). New theorems in +Multivariate/metric.ml: + + ALEXANDROFF_HAUSDORFF + CHAIN_FROM_OPEN_COVER + CHAIN_HIERARCHY + CHAIN_IN_OPEN_CONNECTED_SET + CHAIN_REFINEMENT_STEP + CLOSURE_OF_DYADIC_RATIONALS_IN_UNIT_INTERVAL + COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED + COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE_ALT + COMPACT_LOCALLY_CONNECTED_NEARBY_PATH + COMPACT_METRIZABLE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED + COMPACT_METRIZABLE_PEANO_IMP_PATH_CONNECTED + COMPACT_NESTED_INTERS + COMPLETELY_METRIZABLE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED + COMPLETELY_METRIZABLE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED + CONNECTED_IN_CHAIN_UNIONS + DENSE_FUNCTION_ON_DYADIC + FCCOVERABLE_IN_COMPACT_LOCALLY_CONNECTED + FINITE_CONNECTED_COMPONENTS_CLOPEN_UNION + FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED + HAHN_MAZURKIEWICZ + HAHN_MAZURKIEWICZ_IMP + LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_SPACE + LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_SPACE + LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_SPACE + LOCALLY_COMPACT_SPACE_IMP_GDELTA_IN + LOCALLY_CONNECTED_CONTINUUM_SPACE + LOCALLY_CONSTANT_REFINEMENT + LOCALLY_FCCOVERABLE_SPACE + LOCALLY_FCCOVERABLE_SPACE_CHAIN + MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED + MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_IN + MCOMPLETE_DYADIC_APPROXIMATION + MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM + MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM_IN + MCOMPLETE_IN_LOCALLY_COMPACT_IMP_LOCALLY_COMPACT + MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED + MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED + OPEN_CONNECTED_FINE_COVER + PEANO_GAP_FILLING_EXTENSION + SECOND_COUNTABLE_CLOSED_MAP_IMAGE + SEMI_LOCALLY_CONNECTED_COMPACT_SPACE + SEMI_LOCALLY_CONNECTED_CONNECTED + SEMI_LOCALLY_CONNECTED_GEN_SPACE + SEPARABLE_METRIZABLE_IMP_SECOND_COUNTABLE + +New theorems in Multivariate/paths.ml: + + COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN + FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED_EUCLIDEAN + GDELTA_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED + GDELTA_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED + GDELTA_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED + LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN + LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN + LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN + LOCALLY_COMPACT_PATH_CONNECTED_EQ_CONNECTED_EUCLIDEAN + MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN + MCOMPLETE_IMP_LOCALLY_COMPACT_EUCLIDEAN + MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN + MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN + +In Multivariate/paths.ml, three existing long Euclidean-specific proofs +are replaced by short bridge derivations from the new general metric +space versions: SEMI_LOCALLY_CONNECTED (222 lines reduced to 19), +SEMI_LOCALLY_CONNECTED_GEN (65 lines reduced to 19), and +LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED (662 lines reduced to 15). +All theorem statements are preserved; only the proofs change. + +The general metric space versions in metric.ml use a _SPACE suffix to +distinguish them from existing Euclidean-specific theorems of the same +logical content in paths.ml. For example, the general version is +LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_SPACE while the +Euclidean version retains its original name +LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED. + +Thu 26th Feb 2026 lib.ml, metis.ml + +Incorporated a cleanup and rationalization of METIS from Daniel Nezamabadi. +The main changes are: + + * Applying the bug fixes from the upstream metis repo + + * Inlining various definitions, afterwards simplifying where reasonable + + * Removing duplicate and unused definitions + + * Replacing {foo=foo} pattern matching with {foo} + + * Removing the Order module in favor of OCaml's use of integers + +Wed 25th Feb 2026 Library/ringtheory.ml, Library/fieldtheory.ml + +Added some material about algebraically closed fields, with a definition + + algebraically_closed_field + +and new theorems + + ALGEBRAICALLY_CLOSED_FIELD_DECOMPOSE + ALGEBRAICALLY_CLOSED_FIELD_EQ_IRREDUCIBLES + ALGEBRAICALLY_CLOSED_FIELD_EQ_SPLITS + ALGEBRAICALLY_CLOSED_FIELD_IMP_FIELD + ALGEBRAICALLY_CLOSED_FIELD_IMP_INFINITE + ALGEBRAICALLY_CLOSED_FIELD_ISOMORPHIC_IMAGE + ALGEBRAICALLY_CLOSED_FIELD_NO_PROPER_ALGEBRAIC_EXTENSION + ALGEBRAIC_CLOSURE_EXISTS + ALGEBRAIC_CLOSURE_EXISTS_ID + ALGEBRAIC_CLOSURE_EXTEND_HOMOMORPHISM + ALGEBRAIC_CLOSURE_UNIQUE + ALGEBRAIC_CLOSURE_UNIQUE_EXPLICIT + FIELD_RING_HOMOMORPHISM_MONOMORPHISM + INFINITE_INTEGRAL_DOMAIN_POLY_EVAL_ALL_ZERO + ISOMORPHIC_RING_ALGEBRAICALLY_CLOSED_FIELD + POLY_COMPOSE_HOMOMORPHISM_ADD + POLY_COMPOSE_HOMOMORPHISM_CONST + POLY_COMPOSE_HOMOMORPHISM_MUL + POLY_COMPOSE_HOMOMORPHISM_NEG + POLY_COMPOSE_HOMOMORPHISM_POW + POLY_COMPOSE_HOMOMORPHISM_SUB + POLY_COMPOSE_HOMOMORPHISM_VAR + POLY_DEG_1_ROOT + POLY_DEG_MUL_X_MINUS_A + POLY_DEG_X_MINUS_A + POLY_EVALUATE_RING_PRODUCT + POLY_EVAL_RING_PRODUCT + POLY_EXTEND_RING_PRODUCT + POLY_X_MINUS_A_IN_CARRIER + POLY_X_MINUS_A_NONZERO + RING_HOMOMORPHISM_EPIMORPHISM_FACTOR + RING_POWERSERIES + SIMPLE_ALGEBRAIC_EXTEND_HOMOMORPHISM + +The existence proofs ALGEBRAIC_CLOSURE_EXISTS_ID and ALGEBRAIC_CLOSURE_EXISTS +were done by John Harrison following Jelonek's paper "A simple proof of the +existence of the algebraic closure of a field". The rest, such as various +alternative characterizations and the uniqueness up to isomorphism, were +written by Claude Opus 4.6. + +Sat 21st Feb 2026 100/cubedissection.ml [new file] + +Added a formalization of the impossibility of cube dissection into finitely +many smaller cubes of pairwise distinct sizes ("cubing the cube"), originally +proved by R. L. Brooks, C. A. B. Smith, A. H. Stone and W. T. Tutte, "The +Dissection of Rectangles into Squares", Duke Mathematical Journal, vol. 7 +(1940), pp. 312-340. The proof follows the elegant argument presented in J. E. +Littlewood, "A Mathematician's Miscellany" (CUP, 1953), revised edition +"Littlewood's Miscellany" (ed. B. Bollobas, CUP, 1986), pp. 28-29 and the HOL +Light formalization was almost entirely written by Claude Code (Opus 4.6). + +Thu 19th Feb 2026 Multivariate/metric.ml + +Added some basic definitions and theorems about the Cantor space. The +basic definition is as the product space (:num->bool), and this is +then shown to be homeomorphic to its realization as the usual Cantor +"excluded thirds" subset of [0,1]. New definitions: + + cantor_map + cantor_set + cantor_space + cantor_term + tendsto_real_def + +and theorems: + + CANTOR_MAP_CLOSED_IMAGE + CANTOR_MAP_CLOSED_IN_INTERVAL + CANTOR_MAP_CONTINUOUS + CANTOR_MAP_EMBEDDING + CANTOR_MAP_GE_PARTIAL_SUM + CANTOR_MAP_IMAGE_SUBSET_INTERVAL + CANTOR_MAP_INJECTIVE + CANTOR_MAP_LE_ONE + CANTOR_MAP_PARTIAL_SUM_BOUND + CANTOR_MAP_POS + CANTOR_MAP_RANGE + CANTOR_MAP_STRICT_LT + CANTOR_MAP_SUMMABLE + CANTOR_MAP_SUMS + CANTOR_PARTIAL_SUM_DIFF_AT_K + CANTOR_PARTIAL_SUM_MONO + CANTOR_SET_SUBSET_INTERVAL + CANTOR_SPACE_HOMEOMORPHIC_CANTOR_SET + CANTOR_TERM_BOUND + CANTOR_TERM_CONTINUOUS + CANTOR_TERM_POS + CLOSED_IN_CANTOR_SET + CLOSED_IN_CANTOR_SET_INTERVAL + COMPACT_SPACE_CANTOR_SPACE + HAUSDORFF_SPACE_CANTOR_SPACE + METRIZABLE_SPACE_CANTOR_SPACE + NONEMPTY_TOPSPACE_CANTOR_SPACE + PERFECT_CANTOR_SPACE + PERFECT_CANTOR_SPACE_EQ + SUM_TWOTHIRDS + TENDSTO_REAL_EPS_DELTA + TOPSPACE_CANTOR_SPACE + TWOTHIRDS_SUMS + ZERO_DIMENSIONAL_CANTOR_SPACE + +The new definition "tendsto_real_def" is just a more basic definition of +the usual notion of the sum of a real series, so that it can be used in +the general topology theories without the artificially circuitous +derivation via real^N. The former definition "tendsto_real" is now a +derived theorem rather than a definition, but is equivalent. + +Thu 19th Feb 2026 Multivariate/metric.ml, Multivariate/topology.ml, Multivariate/paths.ml + +Added general metric space versions of well-chainedness, connectedness +of chains, and the two uniform variants of local connectedness (ULC = +uniformly locally connected and FCCOVERABLE = fine connected coverable, +a.k.a. Whyburn's "Property S"), together with key results connecting +them to local connectedness and compactness. The Euclidean special cases +in paths.ml and topology.ml are then derived from the general versions. +New definitions: + + fccoverable_in + fccoverable_space + ulc_space + +and new theorems: + + COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE + COMPACT_IN_LOCALLY_CONNECTED_IMP_FCCOVERABLE_SPACE + COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE + COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE_ALT + CONNECTED_COMPONENT_OF_EQ_WELLCHAINED + CONNECTED_COMPONENT_OF_IMP_WELLCHAINED + CONNECTED_EQ_WELLCHAINED_IN + CONNECTED_IN_CHAIN + CONNECTED_IN_CHAIN_GEN + CONNECTED_IN_IFF_CONNECTED_COMPONENT_OF + CONNECTED_IN_IMP_WELLCHAINED + CONNECTED_IN_NEST + CONNECTED_IN_NEST_GEN + CONNECTED_IN_UNIONS_STRONG + EPSILON_ABSORBING_IMP_CLOPEN + FCCOVERABLE_IN_IMP_FCCOVERABLE_SPACE_SUBMETRIC + FCCOVERABLE_IN_IMP_LOCALLY_CONNECTED_SPACE + FCCOVERABLE_SPACE_EQ_FCCOVERABLE_IN_MSPACE + FCCOVERABLE_SPACE_IMP_LOCALLY_CONNECTED_SPACE + FCCOVERABLE_SPACE_INTERMEDIATE_CLOSURE + IN_CLOSURE_OF_IMP_SUBSET_MCBALL + MBALL_INTER_DSEPARATED_SINGLETON + MDIAMETER_SUBSET_MBALL + MDIAMETER_SUBMETRIC + MDIST_TRIANGLE_LT + NESTED_COMPACT_APPROX + TOTALLY_BOUNDED_IMP_DISCRETE_FINITE + TOTALLY_BOUNDED_ULC_SPACE_IMP_FCCOVERABLE_SPACE + ULC_SPACE_IMP_LOCALLY_CONNECTED_SPACE + WELLCHAINED_ELEMENTS + WELLCHAINED_INTERS + WELLCHAINED_SETS + +In Multivariate/topology.ml, the theorems CONNECTED_CHAIN, +CONNECTED_CHAIN_GEN, CONNECTED_NEST and CONNECTED_NEST_GEN are +rederived from their general topological counterparts. All theorem +statements are preserved. + +In Multivariate/paths.ml, the Euclidean-specific theorems about ULC and +FCCOVERABLE (FCCOVERABLE_IMP_LOCALLY_CONNECTED through +COMPACT_LOCALLY_CONNECTED_EQ_FCCCOVERABLE) are rederived from the +general metric space versions via a set of bridge lemmas connecting +submetric euclidean_metric to the Euclidean topology. The well-chained +theorems (CONNECTED_IMP_WELLCHAINED through +CONNECTED_COMPONENT_EQ_WELLCHAINED) are similarly rederived. All theorem +statements are preserved. + +Incompatible changes: In paths.ml, three Euclidean-specific theorems +have been renamed with a _EUCLIDEAN suffix to avoid clashing with the +new general versions in metric.ml that take the same names: + + WELLCHAINED_ELEMENTS -> WELLCHAINED_ELEMENTS_EUCLIDEAN + WELLCHAINED_SETS -> WELLCHAINED_SETS_EUCLIDEAN + WELLCHAINED_INTERS -> WELLCHAINED_INTERS_EUCLIDEAN + +These were not used outside their original block so the renaming +should not affect other files. Several new Euclidean bridge lemmas are +introduced in paths.ml (SUBMETRIC_EUCLIDEAN_METRIC, +MTOPOLOGY_SUBMETRIC_EUCLIDEAN, MBOUNDED_SUBMETRIC_EUCLIDEAN, +MDIAMETER_SUBMETRIC_EUCLIDEAN, and others) to support the derivations. + +The statements and proofs were almost entirely written by Claude Code +(Opus 4.6). + +Thu 19th Feb 2026 Library/ringtheory.ml, Library/rabin_test.ml [new file] + +Added a proof of Rabin's test for irreducibility of polynomials over +finite fields. The development, both statements and proofs, was +entirely written by Claude Code (Opus 4.6, running on AWS Bedrock). A +few lemmas have been slightly tweaked manually and placed in the ring +theory file, since they seem more broadly applicable: + + POLY_DEG_1_IMP_IRREDUCIBLE + POLY_DEG_EQ_0_UNIT + POLY_DEG_UNIT + RING_DIVIDES_SUB_POW + RING_PRODUCT_CONST + RING_PRODUCT_LMUL + RING_SUB_TELESCOPE + +These are the theorems in the main Library/rabin_test.ml file +culminating in RABIN_IRREDUCIBILITY_TEST: + + FIELD_NONZERO_PRODUCT_PERMUTE + FIELD_ROOTS_BOUND + FINITE_FIELD_ELEMENT_POW + FINITE_FIELD_POW_ITERATE + ING_DIVIDES_POW_ITERATE + IRREDUCIBLE_DIVIDES_DEGREE + IRREDUCIBLE_DIVIDES_DEGREE_BOUND + IRREDUCIBLE_DIVIDES_XQ_MINUS_X + IRREDUCIBLE_DIVIDES_XQ_MINUS_X_GEN + IRRED_DIVIDES_POLY_EVAL_MINUS + POLY_NONUNIT_DEGREE_GE_1 + QUOTIENT_POLY_RING_FINITE_CARD + RABIN_IRREDUCIBILITY_NECESSARY + RABIN_IRREDUCIBILITY_SUFFICIENT + RABIN_IRREDUCIBILITY_TEST + RING_DIVIDES_REDUCE + RING_ENDOMORPHISM_FROBENIUS_ITERATE + +Sun 15th Feb 2026 Multivariate/metric.ml, Multivariate/topology.ml, Multivariate/paracompact.ml [new file] + +Added a definition of paracompactness to the core general topology theory in +Multivariate/metric.ml, with a large number of typical results about it +including Stone's theorem that a metrizable space is paracompact and the +existence of subordinate partitions of unity. Some results that seemed more +specialized or obscure (e.g. Nagata-Smirnov metrization and Michael's +characterization of paracompactness) are placed in a separate file +Multivariate/paracompact.ml that is not part of the main Multivariate load +sequence. The vast majority of the proofs, including all those in the +Multivariate/paracompact.ml file, were automatically written by Claude Code +(two separate instances with a mix of Opus 4.5 and 4.6). + +Sun 15th Feb 2026 itab.ml, unit_tests.ml + +Added a new UNIFY_REFL_TAC tactic from June Lee, which unifies metavariables +in an equational goal ?- t = X where X is a metavariable by assigning X to t. + +Thu 29th Jan 2026 Multivariate/metric.ml, Multivariate/topology.ml, Multivariate/paths.ml + +Added a proof of Urysohn's metrization theorem and also a definition of set +diameter for a general metric space, "mdiameter", with basic properties +mirroring as appropriate those in the Euclidean special case "diameter". +New definition: + + mdiameter + +and theorems: + + EMBEDDING_INTO_METRIZABLE_IMP_METRIZABLE + LEBESGUE_COVERING_LEMMA + LEBESGUE_COVERING_LEMMA_GEN + MBOUNDED_AND_MDIAMETER_LE + MBOUNDED_IMP_IN_MSPACE + MDIAMETER_BOUNDED + MDIAMETER_BOUNDED_BOUND + MDIAMETER_CLOSURE + MDIAMETER_COMPACT_ATTAINED + MDIAMETER_EMPTY + MDIAMETER_EQ_0 + MDIAMETER_EUCLIDEAN + MDIAMETER_LE + MDIAMETER_POS_LE + MDIAMETER_SING + MDIAMETER_SUBSET + MDIAMETER_SUBSET_MCBALL + MDIAMETER_SUBSET_MCBALL_NONEMPTY + MDIAMETER_UNION_LE + METRIZABLE_PRODUCT_EUCLIDEANREAL_NUM + REGULAR_SECOND_COUNTABLE_HAUSDORFF_IMP_NORMAL_SPACE + SEPARATING_FUNCTIONS_INJECTIVE + URYSOHN_METRIZATION + URYSOHN_METRIZATION_EQ + +The two theorems LEBESGUE_COVERING_LEMMA / LEBESGUE_COVERING_LEMMA_GEN +simply replace and generalize the original Euclidean theorems of that name. +The sole current application now uses the more general versions. + +This update has the distinction of being almost entirely written by AI, +mainly Claude Opus 4.5 via AWS Bedrock. It completed the following +requests entirely autonomously: + + * Generalize the existing "diameter" theorems as appropriate + + * Autoformalize Urysohn Metrization starting from Munkres's book + +This was inspired by, and in the latter case largely reproduces, work +by Josef Urban reported in https://arxiv.org/abs/2601.03298, with +the HOL Light setup due to June Lee. + +Thu 8th Jan 2026 hol_4.14.sh, holtest.mk, holtest_parallel, TacticTrace/passim + +Adopted a patch from June Lee with many improvements focused on TacticTrace: + + - Fixes TacticTrace to support OCaml 5.4 + - Add an example to TacticTrace. This can be checked with `make test` + inside TacticTrace dir, as well as + make -f holtest.mk /tmp/hol-light-test/TacticTrace/make-test.ready`. + - For easier compilation and inlining of HOL Light proofs, add the + following options to hol_4.14.sh: + * hol.sh compile + * hol.sh link + * hol.sh inline-load + Updates to hol_4.sh is not necessary because OCaml 4.14 is the minimal + version that supports proof compilation. + - Also add `hol.sh -use-module` which prints 1 if HOLLIGHT_USE_MODULE was + set when built (0 otherwise) + - Slighly simplify TacticTrace by removing the usage of + TACLOGGER_DIR env variable. + Mon 8th Dec 2025 Library/words.ml, Examples/bitblast.ml Fixed a bug in bit-blasting where the conversion from arithmetical to word diff --git a/Examples/update_database.ml b/Examples/update_database.ml deleted file mode 100644 index c69c4567..00000000 --- a/Examples/update_database.ml +++ /dev/null @@ -1,181 +0,0 @@ -(* ========================================================================= *) -(* Create search database from OCaml / modify search database dynamically. *) -(* *) -(* This file assigns to "theorems", which is a list of name-theorem pairs. *) -(* The core system already has such a database set up. Use this file if you *) -(* want to update the database beyond the core, so you can search it. *) -(* *) -(* The trickery to get at the OCaml environment is due to oleg@pobox.com *) -(* (see his message to the caml-list on Tuesday 26th September 2006). *) -(* ========================================================================= *) - -(* !!!!!!! You must set this to point at the source directory in - !!!!!!! which OCaml was built. (And don't do "make clean" beforehand.) - *) - -let ocaml_source_dir = - Filename.concat (Sys.getenv "HOME") - ("software/ocaml-"^Sys.ocaml_version);; - -do_list (fun s -> Topdirs.dir_directory(Filename.concat ocaml_source_dir s)) - ["parsing"; "typing"; "toplevel"; "utils"];; - -(* This must be loaded first! It is stateful, and affects Predef *) -#load "ident.cmo";; - -#load "misc.cmo";; -#load "path.cmo";; -#load "types.cmo";; -#load "btype.cmo";; -#load "tbl.cmo";; -#load "subst.cmo";; -#load "predef.cmo";; -#load "datarepr.cmo";; -#load "config.cmo";; -#load "consistbl.cmo";; -#load "clflags.cmo";; -#load "env.cmo";; -#load "ctype.cmo";; -#load "printast.cmo";; -#load "oprint.cmo";; -#load "primitive.cmo";; -#load "printtyp.cmo";; - -(* ------------------------------------------------------------------------- *) -(* Get the toplevel environment as raw data. *) -(* ------------------------------------------------------------------------- *) - -let get_value_bindings env = - let rec get_val acc = function - | Env.Env_empty -> acc - | Env.Env_value (next, ident, val_descr) -> - get_val ((ident,val_descr)::acc) next - | Env.Env_type (next,_,_) -> get_val acc next - | Env.Env_exception (next,_,_) -> get_val acc next - | Env.Env_module (next,_,_) -> get_val acc next - | Env.Env_modtype (next,_,_) -> get_val acc next - | Env.Env_class (next,_,_) -> get_val acc next - | Env.Env_cltype (next,_,_) -> get_val acc next - | Env.Env_open (next,_) -> get_val acc next - in get_val [] (Env.summary env);; - -(* ------------------------------------------------------------------------- *) -(* Convert a type to a string, for ease of comparison. *) -(* ------------------------------------------------------------------------- *) - -let type_to_str (x : Types.type_expr) = - Printtyp.type_expr Format.str_formatter x; - Format.flush_str_formatter ();; - -(* ------------------------------------------------------------------------- *) -(* Put an assignment of a theorem database in the named file. *) -(* ------------------------------------------------------------------------- *) - -let make_database_assignment filename = - let all_bnds = get_value_bindings (!Toploop.toplevel_env) in - let thm_bnds = filter (fun (ident,val_descr) -> - type_to_str val_descr.Types.val_type = "thm") - all_bnds in - let names = - subtract (map (fun (ident,val_descr) -> Ident.name ident) thm_bnds) - ["it"] in - let entries = map (fun n -> "\""^n^"\","^n) (uniq(sort (<) names)) in - let text = "theorems :=\n[\n"^ - end_itlist (fun a b -> a^";\n"^b) entries^"\n];;\n" in - file_of_string filename text;; - -(* ------------------------------------------------------------------------- *) -(* Remove bindings in first list from second assoc list (all ordered). *) -(* ------------------------------------------------------------------------- *) - -let rec demerge s l = - match (s,l) with - u::t,(x,y as p)::m -> - if u = x then demerge t m - else if u < x then demerge t l - else p::(demerge s m) - | _ -> l;; - -(* ------------------------------------------------------------------------- *) -(* Incrementally update database. *) -(* ------------------------------------------------------------------------- *) - -let update_database = - let value_bindings_checked = ref 0 - and theorem_bindings_existing = ref undefined in - let listify l = if l = [] then "[]" - else "[\n"^end_itlist (fun a b -> a^";\n"^b) l^"\n]\n" in - let purenames = map (fun n -> "\""^n^"\"") - and pairnames = map (fun n -> "\""^n^"\","^n) in - fun () -> - let old_count = !value_bindings_checked - and old_ths = !theorem_bindings_existing in - let all_bnds = get_value_bindings (!Toploop.toplevel_env) in - let new_bnds = funpow old_count tl all_bnds in - let new_count = old_count + length new_bnds - and new_ths = - rev_itlist (fun (ident,val_descr) -> - let n = Ident.name ident in - if type_to_str val_descr.Types.val_type = "thm" && n <> "it" - then (n |-> ()) else undefine n) new_bnds old_ths in - value_bindings_checked := new_count; - if new_ths = old_ths then () else - (print_string "Updating search database\n"; - theorem_bindings_existing := new_ths; - let all_ths = combine (fun _ _ -> ()) (fun _ -> false) old_ths new_ths in - let del_ths = combine (fun _ _ -> ()) (fun _ -> true) all_ths new_ths - and add_ths = combine (fun _ _ -> ()) (fun _ -> true) all_ths old_ths in - let del_names = mergesort (<) (foldr (fun a _ l -> a::l) del_ths []) - and add_names = mergesort (<) (foldr (fun a _ l -> a::l) add_ths []) in - let exptext = - "theorems :=\n merge (increasing fst) (demerge "^ - (listify(purenames del_names))^ - " (!theorems)) "^ - (listify(pairnames add_names))^ - ";;\n" in - (let filename = Filename.temp_file "database" ".ml" in - file_of_string filename exptext; - loadt filename; - Sys.remove filename));; - -(* ------------------------------------------------------------------------- *) -(* Include a call to this on each search. *) -(* ------------------------------------------------------------------------- *) - -let search = - let rec immediatesublist l1 l2 = - match (l1,l2) with - [],_ -> true - | _,[] -> false - | (h1::t1,h2::t2) -> h1 = h2 && immediatesublist t1 t2 in - let rec sublist l1 l2 = - match (l1,l2) with - [],_ -> true - | _,[] -> false - | (h1::t1,h2::t2) -> immediatesublist l1 l2 || sublist l1 t2 in - let exists_subterm_satisfying p (n,th) = can (find_term p) (concl th) - and name_contains s (n,th) = sublist (explode s) (explode n) in - let rec filterpred tm = - match tm with - Comb(Var("",_),t) -> not o filterpred t - | Comb(Var("",_),Var(pat,_)) -> name_contains pat - | Comb(Var("",_),pat) -> exists_subterm_satisfying (aconv pat) - | pat -> exists_subterm_satisfying (can (term_match [] pat)) in - fun pats -> - update_database(); - let triv,nontriv = partition is_var pats in - (if triv <> [] then - warn true - ("Ignoring plain variables in search: "^ - end_itlist (fun s t -> s^", "^t) (map (fst o dest_var) triv)) - else ()); - (if nontriv = [] && triv <> [] then [] - else itlist (filter o filterpred) pats (!theorems));; - -(* ------------------------------------------------------------------------- *) -(* Update to bring things back to current state. *) -(* ------------------------------------------------------------------------- *) - -theorems := [];; - -update_database();; diff --git a/Help/UNIFY_ACCEPT_TAC.hlp b/Help/UNIFY_ACCEPT_TAC.hlp index 8cbc338f..06836d59 100644 --- a/Help/UNIFY_ACCEPT_TAC.hlp +++ b/Help/UNIFY_ACCEPT_TAC.hlp @@ -1,6 +1,6 @@ \DOC UNIFY_ACCEPT_TAC -\TYPE {UNIFY_ACCEPT_TAC : term list -> thm -> 'a * term -> ('b list * instantiation) * 'c list * (instantiation -> 'd list -> thm)} +\TYPE {UNIFY_ACCEPT_TAC : term list -> thm_tactic} \SYNOPSIS Unify free variables in theorem and metavariables in goal to accept theorem. @@ -75,6 +75,6 @@ in the remaining goal, which we can solve easily: Terminating proof search when using metavariables. Used in {ITAUT_TAC} \SEEALSO -ACCEPT_TAC, ITAUT, ITAUT_TAC, MATCH_ACCEPT_TAC. +ACCEPT_TAC, ITAUT, ITAUT_TAC, MATCH_ACCEPT_TAC, UNIFY_REFL_TAC. \ENDDOC diff --git a/Help/UNIFY_REFL_TAC.hlp b/Help/UNIFY_REFL_TAC.hlp new file mode 100644 index 00000000..94702f29 --- /dev/null +++ b/Help/UNIFY_REFL_TAC.hlp @@ -0,0 +1,57 @@ +\DOC UNIFY_REFL_TAC + +\TYPE {UNIFY_REFL_TAC : tactic} + +\SYNOPSIS +Unify term(s) and metavariable(s) in the equality of the goal. + +\DESCRIBE +Given a goal {_ ?- x = y} where {y} is a metavariable, the tactic +{UNIFY_REFL_TAC} attempts to unify {y} with {x}. +If {y} is function application {f a b c} and {f} is a metavariable, +{UNIFY_REFL_TAC} attemps to unify {f} with {\a b c. x} (the number of arguments +can vary). + +\FAILURE +Fails if no unification will work. + +\EXAMPLE +{ + # g `?x. 1 = x`;; + ... + + # e META_EXISTS_TAC;; + val it : goalstack = 1 subgoal (1 total) + + `1 = x` + + # e UNIFY_REFL_TAC;; + + val it : goalstack = No subgoals +} +\noindent If the RHS is function application: +{ + # g `?f. y + z = f y z`;; + ... + + # e (META_EXISTS_TAC THEN UNIFY_REFL_TAC);; + val it : goalstack = No subgoals +} +\noindent The arguments to {f} can be constants, but {UNIFY_REFL_TAC} will +print a warning. +{ + # g `?f. y + 1 = f y 0`;; + ... + + # e (META_EXISTS_TAC THEN UNIFY_REFL_TAC);; + UNIFY_REFL_TAC: warning: this isn't var: 0 + val it : goalstack = No subgoals +} + +\USES +Terminating proof search when using metavariables. + +\SEEALSO +UNIFY_ACCEPT_TAC + +\ENDDOC diff --git a/Library/calc_real.ml b/Library/calc_real.ml index 77fe99cf..1fe1cf71 100644 --- a/Library/calc_real.ml +++ b/Library/calc_real.ml @@ -1725,7 +1725,9 @@ let ELIMINATE_DEF = (* Overall conversion. *) (* ------------------------------------------------------------------------- *) -let realcalc_cache = ref [];; +type realcalc = + ((num * num) ref * (num -> num)) * ((num * thm) ref * (num -> thm)) +let realcalc_cache = ref ([] : (term * realcalc) list) let REALCALC_CONV,thm_eval,raw_eval,thm_wrap = let a_tm = `a:real` and n_tm = `n:num` and n'_tm = `n':num` @@ -2095,7 +2097,7 @@ let REALCALC_CONV,thm_eval,raw_eval,thm_wrap = let ax0 = abs_num x0 in let r = log2(ax0) -/ num 1 in let get_ek(acc) = - if r < num 0 then + if r + field k /\ + !p. p IN ring_carrier(poly_ring k (:1)) /\ ~(poly_deg k p = 0) + ==> ?x. x IN ring_carrier k /\ poly_eval k p x = ring_0 k`;; + +let ALGEBRAICALLY_CLOSED_FIELD_IMP_FIELD = prove + (`!k:A ring. algebraically_closed_field k ==> field k`, + SIMP_TAC[algebraically_closed_field]);; + +let ALGEBRAICALLY_CLOSED_FIELD_ISOMORPHIC_IMAGE = prove + (`!(k:A ring) (l:B ring) f. + ring_isomorphism(k,l) f /\ algebraically_closed_field k + ==> algebraically_closed_field l`, + REPEAT GEN_TAC THEN DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + FIRST_ASSUM(X_CHOOSE_THEN `g:B->A` MP_TAC o + GEN_REWRITE_RULE I [ring_isomorphism]) THEN + REWRITE_TAC[RING_ISOMORPHISMS_ISOMORPHISM] THEN STRIP_TAC THEN + REWRITE_TAC[algebraically_closed_field] THEN STRIP_TAC THEN CONJ_TAC THENL + [ASM_MESON_TAC[ISOMORPHIC_RING_FIELDNESS; isomorphic_ring]; ALL_TAC] THEN + X_GEN_TAC `p:(1->num)->B` THEN STRIP_TAC THEN SUBGOAL_THEN + `(g:B->A) o (p:(1->num)->B) IN ring_carrier(poly_ring k (:1)) /\ + poly_deg (k:A ring) ((g:B->A) o (p:(1->num)->B)) = + poly_deg (l:B ring) p` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[IN_RING_POLYNOMIAL_CARRIER_COMPOSE; + RING_ISOMORPHISM_IMP_HOMOMORPHISM; POLY_DEG_MONOMORPHIC_IMAGE; + RING_POLYNOMIAL; RING_ISOMORPHISM_IMP_MONOMORPHISM]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `(g:B->A) o (p:(1->num)->B)`) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `y:A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(f:A->B) y` THEN + SUBGOAL_THEN `(f:A->B) y IN ring_carrier l` ASSUME_TAC THENL + [ASM_MESON_TAC[RING_ISOMORPHISM_IMP_HOMOMORPHISM; + ring_homomorphism; SUBSET; FUN_IN_IMAGE]; + ASM_REWRITE_TAC[]] THEN + SUBGOAL_THEN `(f:A->B) o (g:B->A) o (p:(1->num)->B) = p` ASSUME_TAC THENL + [REWRITE_TAC[FUN_EQ_THM; o_THM] THEN + X_GEN_TAC `m:1->num` THEN FIRST_ASSUM MATCH_MP_TAC THEN UNDISCH_TAC + `(p:(1->num)->B) IN ring_carrier(poly_ring (l:B ring) (:1))` THEN + REWRITE_TAC[POLY_RING; IN_ELIM_THM; SUBSET_UNIV; + ring_polynomial; ring_powerseries] THEN + MESON_TAC[]; ALL_TAC] THEN MP_TAC(ISPECL + [`k:A ring`; `l:B ring`; `y:A`; `f:A->B`; `(g:B->A) o (p:(1->num)->B)`] + POLY_EVAL_HOMOMORPHIC_IMAGE) THEN ANTS_TAC THENL [REPEAT CONJ_TAC THEN + TRY(MATCH_MP_TAC RING_ISOMORPHISM_IMP_HOMOMORPHISM) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN(SUBST1_TAC o SYM) THEN + UNDISCH_TAC `ring_isomorphism(k:A ring,l:B ring) (f:A->B)` THEN + DISCH_THEN(fun th -> REWRITE_TAC[MATCH_MP RING_HOMOMORPHISM_0 + (MATCH_MP RING_ISOMORPHISM_IMP_HOMOMORPHISM th)]));; + +let ISOMORPHIC_RING_ALGEBRAICALLY_CLOSED_FIELD = prove + (`!(k:A ring) (l:B ring). k isomorphic_ring l + ==> (algebraically_closed_field k <=> algebraically_closed_field l)`, + REWRITE_TAC[isomorphic_ring] THEN REPEAT STRIP_TAC THEN + FIRST_ASSUM(X_CHOOSE_TAC `g:B->A` o + GEN_REWRITE_RULE I [ring_isomorphism]) THEN + FIRST_X_ASSUM(STRIP_ASSUME_TAC o + GEN_REWRITE_RULE I [RING_ISOMORPHISMS_ISOMORPHISM]) THEN + ASM_MESON_TAC[ALGEBRAICALLY_CLOSED_FIELD_ISOMORPHIC_IMAGE]);; + +let ALGEBRAICALLY_CLOSED_FIELD_IMP_INFINITE = prove + (`!k:A ring. algebraically_closed_field k ==> INFINITE(ring_carrier k)`, + GEN_TAC THEN REWRITE_TAC[algebraically_closed_field] THEN + STRIP_TAC THEN REWRITE_TAC[INFINITE] THEN DISCH_TAC THEN + SUBGOAL_THEN `~trivial_ring (k:A ring)` ASSUME_TAC THENL + [ASM_MESON_TAC[FIELD_IMP_NONTRIVIAL_RING]; ALL_TAC] THEN + ABBREV_TAC `P = ring_product (poly_ring (k:A ring) (:1)) (ring_carrier k) + (\a. poly_sub k (poly_var k one) (poly_const k a))` THEN SUBGOAL_THEN + `P IN ring_carrier(poly_ring (k:A ring) (:1))` ASSUME_TAC THENL + [EXPAND_TAC "P" THEN REWRITE_TAC[RING_PRODUCT]; ALL_TAC] THEN SUBGOAL_THEN + `~(P = ring_0(poly_ring (k:A ring) (:1)))` ASSUME_TAC THENL + [EXPAND_TAC "P" THEN ASM_SIMP_TAC[INTEGRAL_DOMAIN_PRODUCT_EQ_0; + INTEGRAL_DOMAIN_POLY_RING; FIELD_IMP_INTEGRAL_DOMAIN] THEN + REWRITE_TAC[NOT_EXISTS_THM; TAUT `~(p /\ q) <=> p ==> ~q`] THEN + X_GEN_TAC `a:A` THEN DISCH_TAC THEN REWRITE_TAC[POLY_RING_CLAUSES] THEN + ASM_SIMP_TAC[POLY_X_MINUS_A_NONZERO]; ALL_TAC] THEN SUBGOAL_THEN + `!x:A. x IN ring_carrier k ==> poly_eval k P x = ring_0 k` ASSUME_TAC THENL + [X_GEN_TAC `x:A` THEN DISCH_TAC THEN EXPAND_TAC "P" THEN + ASM_SIMP_TAC[POLY_EVAL_RING_PRODUCT; POLY_X_MINUS_A_IN_CARRIER] THEN + ASM_SIMP_TAC[INTEGRAL_DOMAIN_PRODUCT_EQ_0; FIELD_IMP_INTEGRAL_DOMAIN] THEN + EXISTS_TAC `x:A` THEN ASM_REWRITE_TAC[] THEN BETA_TAC THEN + ASM_SIMP_TAC[POLY_EVAL_SUB; RING_POLYNOMIAL_VAR; RING_POLYNOMIAL_CONST; + POLY_EVAL_VAR; POLY_EVAL_CONST; RING_SUB_REFL]; ALL_TAC] THEN + SUBGOAL_THEN `~(poly_deg (k:A ring) (P:(1->num)->A) = 0)` ASSUME_TAC THENL + [DISCH_TAC THEN + MP_TAC(ISPECL [`k:A ring`; `P:(1->num)->A`] POLY_DEG_EQ_0) THEN + ASM_REWRITE_TAC[RING_POLYNOMIAL] THEN + DISCH_THEN(X_CHOOSE_THEN `c:A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(c:A) = ring_0 k` SUBST_ALL_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `ring_0 (k:A ring)`) THEN + REWRITE_TAC[RING_0] THEN ASM_SIMP_TAC[POLY_EVAL_CONST]; + ASM_MESON_TAC[POLY_CONST_0; POLY_RING_CLAUSES]]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPEC + `poly_add (k:A ring) P (poly_1 k:(1->num)->A)`) THEN + REWRITE_TAC[NOT_IMP; NOT_EXISTS_THM] THEN CONJ_TAC THENL [CONJ_TAC THENL + [REWRITE_TAC[GSYM RING_POLYNOMIAL] THEN MATCH_MP_TAC + RING_POLYNOMIAL_ADD THEN ASM_REWRITE_TAC[RING_POLYNOMIAL; + RING_POLYNOMIAL_1]; + MP_TAC(ISPECL [`k:A ring`; `P:(1->num)->A`; + `poly_1 (k:A ring):(1->num)->A`] POLY_DEG_ADD) THEN + ASM_REWRITE_TAC[RING_POLYNOMIAL; RING_POLYNOMIAL_1; POLY_DEG_1] THEN + DISCH_THEN SUBST1_TAC THEN ASM_ARITH_TAC]; + X_GEN_TAC `x:A` THEN DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + ASM_SIMP_TAC[POLY_EVAL_ADD; RING_POLYNOMIAL; RING_POLYNOMIAL_1; + POLY_EVAL_1; RING_ADD_LZERO; RING_1; + GSYM TRIVIAL_RING_10]]);; + +let ALGEBRAICALLY_CLOSED_FIELD_NO_PROPER_ALGEBRAIC_EXTENSION = prove + (`!(k:A ring) (l:B ring) (f:A->B). + algebraically_closed_field k /\ algebraic_extension(k,l) f + ==> ring_isomorphism(k,l) f`, REPEAT GEN_TAC THEN + REWRITE_TAC[algebraically_closed_field; ALGEBRAIC_EXTENSION_ALT] THEN + STRIP_TAC THEN SUBGOAL_THEN + `ring_monomorphism(k:A ring,l:B ring) (f:A->B) /\ field(l:B ring) /\ + ring_homomorphism(k:A ring,l:B ring) (f:A->B)` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[field_extension; + RING_MONOMORPHISM_IMP_HOMOMORPHISM]; ALL_TAC] THEN SUBGOAL_THEN + `ring_homomorphism(poly_ring (k:A ring) (:1), poly_ring (l:B ring) (:1)) + (\p:(1->num)->A. (f:A->B) o p)` ASSUME_TAC THENL + [MATCH_MP_TAC RING_HOMOMORPHISM_POLY_RINGS THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[RING_ISOMORPHISM_MONOMORPHISM_ALT] THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `!n (x:B) (p:(1->num)->A). x IN ring_carrier l /\ + p IN ring_carrier(poly_ring (k:A ring) (:1)) /\ + ~(p = ring_0(poly_ring k (:1))) /\ + poly_eval (l:B ring) ((f:A->B) o p) x = ring_0 l /\ poly_deg k p = n + ==> x IN IMAGE f (ring_carrier k)` MP_TAC THENL + [MATCH_MP_TAC num_WF THEN X_GEN_TAC `n:num` THEN DISCH_TAC THEN + MAP_EVERY X_GEN_TAC [`x:B`; `p:(1->num)->A`] THEN STRIP_TAC THEN + SUBGOAL_THEN `ring_polynomial (k:A ring) (p:(1->num)->A)` ASSUME_TAC THENL + [ASM_REWRITE_TAC[RING_POLYNOMIAL]; ALL_TAC] THEN ASM_CASES_TAC `n = 0` THENL + [(* Base case: n = 0, p is nonzero constant, contradiction *) + FIRST_ASSUM(MP_TAC o MATCH_MP POLY_DEG_EQ_0) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `c:A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `~(c = ring_0 (k:A ring))` ASSUME_TAC THENL + [ASM_MESON_TAC[POLY_CONST_0; POLY_RING_CLAUSES]; ALL_TAC] THEN + SUBGOAL_THEN `(f:A->B) c = ring_0 (l:B ring)` ASSUME_TAC THENL + [UNDISCH_TAC `poly_eval (l:B ring) ((f:A->B) o (p:(1->num)->A)) (x:B) = + ring_0 l` THEN SUBGOAL_THEN + `(f:A->B) c IN ring_carrier (l:B ring)` ASSUME_TAC THENL + [ASM_MESON_TAC[ring_homomorphism; SUBSET; IN_IMAGE]; ALL_TAC] THEN + SUBGOAL_THEN + `(f:A->B) o (poly_const (k:A ring) c:(1->num)->A) = + (poly_const (l:B ring) (f c):(1->num)->B)` ASSUME_TAC THENL + [MATCH_MP_TAC POLY_COMPOSE_HOMOMORPHISM_CONST THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_SIMP_TAC[POLY_EVAL_CONST]; + ALL_TAC] THEN + MP_TAC(ISPECL [`k:A ring`; `l:B ring`; `f:A->B`; `c:A`] + RING_MONOMORPHISM_EQ_0) THEN ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN (* Inductive step: n >= 1 *) (* Get root from ACF *) + FIRST_ASSUM(MP_TAC o SPEC `p:(1->num)->A`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `y:A` STRIP_ASSUME_TAC) THEN + (* Factor p = (X-y) * q *) SUBGOAL_THEN `?q:(1->num)->A. + q IN ring_carrier(poly_ring (k:A ring) (:1)) /\ + p:(1->num)->A = poly_mul k + (poly_sub k (poly_var k one) (poly_const k (y:A))) q` + (X_CHOOSE_THEN `q:(1->num)->A` STRIP_ASSUME_TAC) THENL + [MP_TAC(ISPECL [`k:A ring`; `y:A`; `p:(1->num)->A`] + POLY_DIVIDES_X_MINUS_ROOT) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[ring_divides; POLY_RING_CLAUSES; + IN_ELIM_THM; SUBSET_UNIV] THEN + MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `ring_polynomial (k:A ring) (q:(1->num)->A) /\ + poly_sub k (poly_var k one) (poly_const k (y:A)):(1->num)->A + IN ring_carrier(poly_ring (k:A ring) (:1))` STRIP_ASSUME_TAC THENL + [CONJ_TAC THENL [ASM_MESON_TAC[RING_POLYNOMIAL]; + MATCH_MP_TAC POLY_X_MINUS_A_IN_CARRIER THEN ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + SUBGOAL_THEN `~(q:(1->num)->A = poly_0 (k:A ring))` ASSUME_TAC THENL + [DISCH_TAC THEN SUBGOAL_THEN + `(p:(1->num)->A) = poly_0 (k:A ring)` MP_TAC THENL + [ASM_REWRITE_TAC[POLY_CLAUSES] THEN + MATCH_MP_TAC RING_MUL_RZERO THEN MATCH_MP_TAC RING_SUB THEN + REWRITE_TAC[GSYM RING_POLYNOMIAL] THEN + ASM_SIMP_TAC[RING_POLYNOMIAL_VAR; RING_POLYNOMIAL_CONST]; + REWRITE_TAC[POLY_CLAUSES] THEN ASM_MESON_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `poly_deg (k:A ring) (q:(1->num)->A) < n` ASSUME_TAC THENL + [MP_TAC(ISPECL [`k:A ring`; `y:A`; `q:(1->num)->A`] + POLY_DEG_MUL_X_MINUS_A) THEN + ASM_SIMP_TAC[FIELD_IMP_INTEGRAL_DOMAIN] THEN + UNDISCH_TAC `poly_deg (k:A ring) (p:(1->num)->A) = n` THEN + ASM_REWRITE_TAC[] THEN ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(f:A->B) o (p:(1->num)->A) = poly_mul (l:B ring) + (f o poly_sub k (poly_var k one) (poly_const k (y:A))) + (f o (q:(1->num)->A))` ASSUME_TAC THENL + [ASM_REWRITE_TAC[] THEN MATCH_MP_TAC POLY_COMPOSE_HOMOMORPHISM_MUL THEN + ASM_SIMP_TAC[RING_POWERSERIES_SUB; RING_POWERSERIES_VAR; + RING_POWERSERIES_CONST; + RING_POLYNOMIAL_IMP_POWERSERIES]; ALL_TAC] THEN + (* f o (X-y) = X_l - const_l(f y) *) + SUBGOAL_THEN `(f:A->B) o poly_sub (k:A ring) (poly_var k one) + (poly_const k (y:A)) = + poly_sub (l:B ring) (poly_var l one) + (poly_const l ((f:A->B) y))` ASSUME_TAC THENL + [MP_TAC(ISPECL [`k:A ring`; `l:B ring`; `f:A->B`; + `poly_var k one:(1->num)->A`; `poly_const k (y:A):(1->num)->A`] + POLY_COMPOSE_HOMOMORPHISM_SUB) THEN + ASM_SIMP_TAC[RING_POWERSERIES_VAR; RING_POWERSERIES_CONST] THEN + DISCH_THEN SUBST1_TAC THEN + SUBGOAL_THEN + `((f:A->B) o (poly_var (k:A ring) one:(1->num)->A) = + (poly_var (l:B ring) one:(1->num)->B)) /\ + ((f:A->B) o (poly_const (k:A ring) (y:A):(1->num)->A) = + (poly_const (l:B ring) (f y):(1->num)->B))` + (fun th -> REWRITE_TAC[th]) THEN + CONJ_TAC THENL + [MATCH_MP_TAC POLY_COMPOSE_HOMOMORPHISM_VAR THEN + ASM_REWRITE_TAC[]; + MATCH_MP_TAC POLY_COMPOSE_HOMOMORPHISM_CONST THEN + ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + SUBGOAL_THEN `(f:A->B) y IN ring_carrier (l:B ring) /\ + ring_polynomial (l:B ring) ((f:A->B) o (q:(1->num)->A))` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[ring_homomorphism; SUBSET; IN_IMAGE; + RING_POLYNOMIAL; IN_RING_POLYNOMIAL_CARRIER_COMPOSE]; ALL_TAC] THEN + SUBGOAL_THEN `ring_sub (l:B ring) (x:B) ((f:A->B) y) = ring_0 l \/ + poly_eval (l:B ring) ((f:A->B) o (q:(1->num)->A)) (x:B) = ring_0 l` + MP_TAC THENL [MP_TAC(ISPECL [`l:B ring`; + `ring_sub (l:B ring) (x:B) ((f:A->B) y)`; + `poly_eval (l:B ring) ((f:A->B) o (q:(1->num)->A)) (x:B)`] + FIELD_MUL_EQ_0) THEN ASM_REWRITE_TAC[] THEN ANTS_TAC THENL + [CONJ_TAC THENL [MATCH_MP_TAC RING_SUB THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[POLY_EVAL]]; ALL_TAC] THEN + DISCH_THEN(fun th -> REWRITE_TAC[GSYM th]) THEN UNDISCH_TAC + `poly_eval (l:B ring) ((f:A->B) o (p:(1->num)->A)) (x:B) = + ring_0 l` THEN ASM_REWRITE_TAC[] THEN + ASM_SIMP_TAC[POLY_EVAL_MUL; POLY_EVAL_SUB; POLY_EVAL_VAR; + POLY_EVAL_CONST; RING_POLYNOMIAL_VAR; + RING_POLYNOMIAL_CONST; RING_POLYNOMIAL_SUB; + RING_POLYNOMIAL_MUL]; ALL_TAC] THEN + (* Case split *) DISCH_THEN(DISJ_CASES_TAC) THENL + [(* Case 1: ring_sub l x (f y) = 0, so x = f y *) + REWRITE_TAC[IN_IMAGE] THEN EXISTS_TAC `y:A` THEN ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[RING_SUB_EQ_0]; + FIRST_X_ASSUM(MP_TAC o SPEC `poly_deg (k:A ring) (q:(1->num)->A)`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPECL [`x:B`; `q:(1->num)->A`]) THEN + ASM_REWRITE_TAC[POLY_RING_CLAUSES]]; DISCH_TAC THEN + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `x:B` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `x:B`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `p0:(1->num)->A` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o SPECL + [`poly_deg (k:A ring) (p0:(1->num)->A)`; `x:B`; `p0:(1->num)->A`]) THEN + ASM_REWRITE_TAC[]]);; + +let ALGEBRAICALLY_CLOSED_FIELD_EQ_IRREDUCIBLES = prove + (`!k:A ring. + algebraically_closed_field k <=> + field k /\ + !p. ring_irreducible (poly_ring k (:1)) p ==> poly_deg k p = 1`, + GEN_TAC THEN EQ_TAC THENL + [(* Forward: ACF ==> field /\ irreducibles have degree 1 *) + DISCH_TAC THEN CONJ_TAC THENL + [ASM_MESON_TAC[ALGEBRAICALLY_CLOSED_FIELD_IMP_FIELD]; ALL_TAC] THEN + X_GEN_TAC `p:(1->num)->A` THEN + REWRITE_TAC[ring_irreducible; POLY_RING_CLAUSES; IN_ELIM_THM] THEN + STRIP_TAC THEN + SUBGOAL_THEN `field (k:A ring) /\ integral_domain (k:A ring) /\ + ~trivial_ring (k:A ring)` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[ALGEBRAICALLY_CLOSED_FIELD_IMP_FIELD; + FIELD_IMP_INTEGRAL_DOMAIN; FIELD_IMP_NONTRIVIAL_RING]; + ALL_TAC] THEN + SUBGOAL_THEN `~(poly_deg (k:A ring) (p:(1->num)->A) = 0)` ASSUME_TAC THENL + [DISCH_TAC THEN + UNDISCH_TAC `~ring_unit (poly_ring (k:A ring) (:1)) (p:(1->num)->A)` + THEN REWRITE_TAC[] THEN + ASM_SIMP_TAC[RING_UNIT_POLY_DOMAIN] THEN + MP_TAC(ISPECL [`k:A ring`; `p:(1->num)->A`] POLY_DEG_EQ_0) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `a:A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `a:A` THEN ASM_REWRITE_TAC[] THEN + ASM_SIMP_TAC[FIELD_UNIT] THEN ASM_MESON_TAC[POLY_CONST_0]; ALL_TAC] THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [algebraically_closed_field]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `p:(1->num)->A`)) THEN + ASM_REWRITE_TAC[POLY_RING_CLAUSES; IN_ELIM_THM; SUBSET_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `x:A` STRIP_ASSUME_TAC) THEN + (* (X - x) divides p *) MP_TAC(ISPECL [`k:A ring`; `x:A`; `p:(1->num)->A`] + POLY_DIVIDES_X_MINUS_ROOT) THEN + ASM_REWRITE_TAC[POLY_RING_CLAUSES; IN_ELIM_THM; SUBSET_UNIV] THEN + REWRITE_TAC[ring_divides; POLY_RING_CLAUSES; IN_ELIM_THM] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `q:(1->num)->A` STRIP_ASSUME_TAC))) THEN + FIRST_X_ASSUM(MP_TAC o SPECL + [`poly_sub (k:A ring) (poly_var k one) (poly_const k x)`; + `q:(1->num)->A`]) THEN + REWRITE_TAC[POLY_RING_CLAUSES; IN_ELIM_THM; SUBSET_UNIV] THEN + ASM_SIMP_TAC[RING_POLYNOMIAL_SUB; RING_POLYNOMIAL_VAR; + RING_POLYNOMIAL_CONST; POLY_VAR_UNIV] THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(DISJ_CASES_TAC) THENL + [(* Case: (X - x) is a unit - impossible since deg = 1 *) + UNDISCH_TAC `ring_unit (poly_ring (k:A ring) (:1)) + (poly_sub k (poly_var k one) (poly_const k (x:A)))` THEN + ASM_SIMP_TAC[RING_UNIT_POLY_DOMAIN] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A` STRIP_ASSUME_TAC) THEN + MP_TAC(SPECL [`k:A ring`; `x:A`] POLY_DEG_X_MINUS_A) THEN + ASM_REWRITE_TAC[POLY_DEG_CONST] THEN ARITH_TAC; ALL_TAC] THEN + (* Case: q is a unit, so p = (X - x) * unit, deg p = 1 *) UNDISCH_TAC + `ring_unit (poly_ring (k:A ring) (:1)) (q:(1->num)->A)` THEN + ASM_SIMP_TAC[RING_UNIT_POLY_DOMAIN] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(u:A) IN ring_carrier k` ASSUME_TAC THENL + [ASM_MESON_TAC[ring_unit]; ALL_TAC] THEN UNDISCH_TAC + `p:(1->num)->A = poly_mul k + (poly_sub k (poly_var k one) (poly_const k (x:A))) q` THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN MP_TAC(ISPECL [`k:A ring`; `x:A`; + `poly_const (k:A ring) (u:A):(1->num)->A`] + POLY_DEG_MUL_X_MINUS_A) THEN ASM_REWRITE_TAC[] THEN ANTS_TAC THENL + [CONJ_TAC THENL [REWRITE_TAC[GSYM RING_POLYNOMIAL] THEN + ASM_SIMP_TAC[RING_POLYNOMIAL_CONST]; + REWRITE_TAC[GSYM POLY_CONST_0; POLY_CONST_EQ] THEN + ASM_MESON_TAC[RING_UNIT_0; INTEGRAL_DOMAIN_IMP_NONTRIVIAL_RING]]; + ASM_REWRITE_TAC[POLY_DEG_CONST] THEN ARITH_TAC]; + STRIP_TAC THEN ASM_REWRITE_TAC[algebraically_closed_field] THEN + X_GEN_TAC `p:(1->num)->A` THEN STRIP_TAC THEN + SUBGOAL_THEN `integral_domain (k:A ring) /\ + ~((p:(1->num)->A) = ring_0 (poly_ring k (:1)))` STRIP_ASSUME_TAC THENL + [CONJ_TAC THENL [ASM_SIMP_TAC[FIELD_IMP_INTEGRAL_DOMAIN]; + ASM_MESON_TAC[POLY_DEG_0; POLY_RING_CLAUSES]]; ALL_TAC] THEN + SUBGOAL_THEN `~ring_unit (poly_ring (k:A ring) (:1)) (p:(1->num)->A)` + ASSUME_TAC THENL [ASM_SIMP_TAC[RING_UNIT_POLY_DOMAIN] THEN STRIP_TAC THEN + UNDISCH_TAC `~(poly_deg (k:A ring) (p:(1->num)->A) = 0)` THEN + ASM_REWRITE_TAC[POLY_DEG_CONST]; ALL_TAC] THEN + MP_TAC(ISPECL [`poly_ring (k:A ring) (:1)`; `p:(1->num)->A`] + NOETHERIAN_DOMAIN_IRREDUCIBLE_FACTOR_EXISTS) THEN + ASM_SIMP_TAC[INTEGRAL_DOMAIN_POLY_RING] THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN DISJ2_TAC THEN MATCH_MP_TAC PID_IMP_UFD THEN + ASM_SIMP_TAC[PID_POLY_RING]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `q:(1->num)->A` STRIP_ASSUME_TAC) THEN + MP_TAC(ISPECL [`k:A ring`; `q:(1->num)->A`] POLY_DEG_1_ROOT) THEN + ANTS_TAC THENL [ASM_MESON_TAC[ring_irreducible; RING_POLYNOMIAL; + POLY_RING_CLAUSES; IN_ELIM_THM]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `x:A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `x:A` THEN ASM_REWRITE_TAC[] THEN + MP_TAC(ISPECL [`poly_ring (k:A ring) (:1)`; `k:A ring`; + `\(pp:(1->num)->A). poly_eval (k:A ring) pp (x:A)`; + `q:(1->num)->A`; `p:(1->num)->A`] RING_DIVIDES_HOMOMORPHIC_IMAGE) THEN + ANTS_TAC THENL [ASM_SIMP_TAC[RING_HOMOMORPHISM_POLY_EVAL]; ALL_TAC] THEN + BETA_TAC THEN ASM_REWRITE_TAC[RING_DIVIDES_ZERO]]);; + +let ALGEBRAICALLY_CLOSED_FIELD_DECOMPOSE = prove + (`!k:A ring. + algebraically_closed_field k + ==> !p. p IN ring_carrier(poly_ring k (:1)) /\ ~(poly_deg k p = 0) + ==> ?a q. a IN ring_carrier k /\ + q IN ring_carrier(poly_ring k (:1)) /\ p = poly_mul k + (poly_sub k (poly_var k one) (poly_const k a)) q /\ + poly_deg k q + 1 = poly_deg k p`, + GEN_TAC THEN DISCH_TAC THEN X_GEN_TAC `p:(1->num)->A` THEN STRIP_TAC THEN + SUBGOAL_THEN `field (k:A ring)` ASSUME_TAC THENL + [ASM_MESON_TAC[ALGEBRAICALLY_CLOSED_FIELD_IMP_FIELD]; ALL_TAC] THEN + SUBGOAL_THEN `?a:A. a IN ring_carrier k /\ poly_eval k p a = ring_0 k` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[algebraically_closed_field]; ALL_TAC] THEN + MP_TAC(ISPECL [`k:A ring`; `a:A`; `p:(1->num)->A`] + POLY_DIVIDES_X_MINUS_ROOT) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[ring_divides; POLY_RING_CLAUSES; IN_ELIM_THM; SUBSET_UNIV] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `q:(1->num)->A` STRIP_ASSUME_TAC))) THEN + EXISTS_TAC `a:A` THEN EXISTS_TAC `q:(1->num)->A` THEN + ASM_REWRITE_TAC[POLY_RING_CLAUSES; IN_ELIM_THM; SUBSET_UNIV] THEN + SUBGOAL_THEN `~((q:(1->num)->A) = poly_0 (k:A ring))` ASSUME_TAC THENL + [DISCH_TAC THEN + SUBGOAL_THEN `(p:(1->num)->A) = poly_0 (k:A ring)` MP_TAC THENL + [ASM_REWRITE_TAC[POLY_CLAUSES] THEN + MATCH_MP_TAC RING_MUL_RZERO THEN MATCH_MP_TAC RING_SUB THEN + REWRITE_TAC[GSYM RING_POLYNOMIAL] THEN + ASM_SIMP_TAC[RING_POLYNOMIAL_VAR; RING_POLYNOMIAL_CONST]; + ASM_MESON_TAC[POLY_DEG_0]]; ALL_TAC] THEN + MP_TAC(ISPECL [`k:A ring`; `a:A`; `q:(1->num)->A`] + POLY_DEG_MUL_X_MINUS_A) THEN + ASM_SIMP_TAC[FIELD_IMP_INTEGRAL_DOMAIN; + POLY_RING_CLAUSES; IN_ELIM_THM; SUBSET_UNIV] THEN + ARITH_TAC);; + +let ALGEBRAICALLY_CLOSED_FIELD_EQ_SPLITS = prove + (`!k:A ring. + algebraically_closed_field k <=> + field k /\ + !p. p IN ring_carrier(poly_ring k (:1)) /\ ~(poly_deg k p = 0) + ==> ?c a. c IN ring_carrier k /\ ~(c = ring_0 k) /\ + (!i. 1 <= i /\ i <= poly_deg k p + ==> a(i) IN ring_carrier k) /\ + p = poly_mul k (poly_const k c) + (ring_product (poly_ring k (:1)) (1..poly_deg k p) + (\i. poly_sub k (poly_var k one) + (poly_const k (a i))))`, + GEN_TAC THEN EQ_TAC THENL [(* Forward: ACF ==> splits *) + DISCH_TAC THEN + SUBGOAL_THEN `field (k:A ring) /\ integral_domain (k:A ring)` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[ALGEBRAICALLY_CLOSED_FIELD_IMP_FIELD; + FIELD_IMP_INTEGRAL_DOMAIN]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `!n (p:(1->num)->A). + p IN ring_carrier(poly_ring k (:1)) /\ poly_deg k p = n /\ ~(n = 0) + ==> ?c a. c IN ring_carrier k /\ ~(c = ring_0 k) /\ + (!i. 1 <= i /\ i <= n ==> a(i) IN ring_carrier k) /\ + p = poly_mul k (poly_const k c) + (ring_product (poly_ring k (:1)) (1..n) + (\i. poly_sub k (poly_var k one) + (poly_const k (a i))))` + (fun th -> X_GEN_TAC `p:(1->num)->A` THEN STRIP_TAC THEN + MP_TAC(SPECL [`poly_deg (k:A ring) (p:(1->num)->A)`; + `p:(1->num)->A`] th) THEN + ASM_REWRITE_TAC[]) THEN + INDUCT_TAC THENL [REWRITE_TAC[]; ALL_TAC] THEN + X_GEN_TAC `p:(1->num)->A` THEN STRIP_TAC THEN + MP_TAC(SPEC `k:A ring` ALGEBRAICALLY_CLOSED_FIELD_DECOMPOSE) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN(MP_TAC o SPEC `p:(1->num)->A`) THEN + ASM_REWRITE_TAC[ARITH_RULE `~(SUC n = 0)`] THEN + DISCH_THEN(X_CHOOSE_THEN `a0:A` + (X_CHOOSE_THEN `q:(1->num)->A` STRIP_ASSUME_TAC)) THEN + SUBGOAL_THEN `poly_deg (k:A ring) (q:(1->num)->A) = n` ASSUME_TAC THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN + `poly_sub (k:A ring) (poly_var k one) (poly_const k (a0:A)) + IN ring_carrier(poly_ring k (:1))` ASSUME_TAC THENL + [MATCH_MP_TAC POLY_X_MINUS_A_IN_CARRIER THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + ASM_CASES_TAC `n = 0` THENL + [MP_TAC(ISPECL [`k:A ring`; `q:(1->num)->A`] POLY_DEG_EQ_0) THEN + ASM_REWRITE_TAC[RING_POLYNOMIAL] THEN + DISCH_THEN(X_CHOOSE_THEN `c:A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `c:A` THEN EXISTS_TAC `\i:num. a0:A` THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [DISCH_TAC THEN + SUBGOAL_THEN `(p:(1->num)->A) = poly_0 (k:A ring)` MP_TAC THENL + [ASM_REWRITE_TAC[POLY_CLAUSES; POLY_CONST_0] THEN + MATCH_MP_TAC RING_MUL_RZERO THEN MATCH_MP_TAC RING_SUB THEN + REWRITE_TAC[GSYM RING_POLYNOMIAL] THEN + ASM_SIMP_TAC[RING_POLYNOMIAL_VAR; RING_POLYNOMIAL_CONST]; + DISCH_THEN SUBST_ALL_TAC THEN + RULE_ASSUM_TAC(REWRITE_RULE[POLY_DEG_0]) THEN ASM_ARITH_TAC]; + CONV_TAC NUM_REDUCE_CONV THEN + REWRITE_TAC[NUMSEG_SING; RING_PRODUCT_SING] THEN + ASM_REWRITE_TAC[] THEN SUBGOAL_THEN `poly_mul (k:A ring) = ring_mul + (poly_ring k (:1))` SUBST1_TAC THENL + [REWRITE_TAC[POLY_RING_CLAUSES]; ALL_TAC] THEN + MATCH_MP_TAC RING_MUL_SYM THEN ASM_REWRITE_TAC[POLY_CONST]]; + ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `q:(1->num)->A`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `c':A` + (X_CHOOSE_THEN `a':num->A` STRIP_ASSUME_TAC)) THEN + EXISTS_TAC `c':A` THEN + EXISTS_TAC + `\i:num. if i = SUC n then (a0:A) else (a':num->A) i` THEN + ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL + [X_GEN_TAC `i:num` THEN STRIP_TAC THEN + COND_CASES_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `ring_product (poly_ring (k:A ring) (:1)) (1..SUC n) + (\i. poly_sub k (poly_var k one) + (poly_const k (if i = SUC n then a0 else (a':num->A) i))) + :(1->num)->A = poly_mul k + (poly_sub k (poly_var k one) (poly_const k (a0:A))) + (ring_product (poly_ring k (:1)) (1..n) + (\i. poly_sub k (poly_var k one) (poly_const k (a' i))))` + SUBST1_TAC THENL + [REWRITE_TAC[RING_PRODUCT_CLAUSES_NUMSEG_ALT; + ARITH_RULE `1 <= SUC n`] THEN + ASM_REWRITE_TAC[ARITH_RULE `~(SUC n <= n)`] THEN + REWRITE_TAC[POLY_RING_CLAUSES] THEN AP_TERM_TAC THEN + MATCH_MP_TAC RING_PRODUCT_EQ THEN REWRITE_TAC[IN_NUMSEG] THEN + X_GEN_TAC `j:num` THEN STRIP_TAC THEN + COND_CASES_TAC THEN ASM_REWRITE_TAC[] THEN ASM_ARITH_TAC; + ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN SUBGOAL_THEN `poly_mul (k:A ring) = ring_mul + (poly_ring k (:1))` SUBST1_TAC THENL + [REWRITE_TAC[POLY_RING_CLAUSES]; ALL_TAC] THEN + ASM_SIMP_TAC[RING_MUL_ASSOC; POLY_CONST; RING_PRODUCT] THEN + AP_THM_TAC THEN AP_TERM_TAC THEN MATCH_MP_TAC RING_MUL_SYM THEN + ASM_REWRITE_TAC[POLY_CONST; RING_PRODUCT]; + STRIP_TAC THEN ASM_REWRITE_TAC[algebraically_closed_field] THEN + X_GEN_TAC `p:(1->num)->A` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `p:(1->num)->A`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `c:A` + (X_CHOOSE_THEN `a:num->A` STRIP_ASSUME_TAC)) THEN + SUBGOAL_THEN `integral_domain (k:A ring)` ASSUME_TAC THENL + [ASM_SIMP_TAC[FIELD_IMP_INTEGRAL_DOMAIN]; ALL_TAC] THEN + SUBGOAL_THEN `1 <= poly_deg (k:A ring) (p:(1->num)->A)` ASSUME_TAC THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(a:num->A) 1 IN ring_carrier k` ASSUME_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[LE_REFL]; ALL_TAC] THEN + EXISTS_TAC `(a:num->A) 1` THEN ASM_REWRITE_TAC[] THEN ABBREV_TAC + `Q = ring_product (poly_ring (k:A ring) (:1)) + (1..poly_deg k (p:(1->num)->A)) (\i. poly_sub k (poly_var k + one) + (poly_const k ((a:num->A) i)))` THEN + SUBGOAL_THEN `ring_polynomial (k:A ring) (Q:(1->num)->A)` ASSUME_TAC THENL + [EXPAND_TAC "Q" THEN REWRITE_TAC[RING_POLYNOMIAL; RING_PRODUCT]; + ALL_TAC] THEN + ASM_SIMP_TAC[POLY_EVAL_MUL; RING_POLYNOMIAL_CONST; POLY_EVAL_CONST] THEN + (* Goal: ring_mul k c (poly_eval k Q (a 1)) = ring_0 k *) SUBGOAL_THEN + `poly_eval (k:A ring) (Q:(1->num)->A) ((a:num->A) 1) = ring_0 k` + SUBST1_TAC THENL [(* Step 1: Expand Q and apply POLY_EVAL_RING_PRODUCT *) + EXPAND_TAC "Q" THEN SUBGOAL_THEN `poly_eval (k:A ring) + (ring_product (poly_ring k (:1)) (1..poly_deg k (p:(1->num)->A)) + (\i. poly_sub k (poly_var k one) + (poly_const k ((a:num->A) i)))) ((a:num->A) 1) = + ring_product k (1..poly_deg k p) (\i. poly_eval k + (poly_sub k (poly_var k one) (poly_const k (a i))) + (a 1))` SUBST1_TAC THENL [MATCH_MP_TAC POLY_EVAL_RING_PRODUCT THEN + ASM_REWRITE_TAC[FINITE_NUMSEG; IN_NUMSEG] THEN + REPEAT STRIP_TAC THEN MATCH_MP_TAC POLY_X_MINUS_A_IN_CARRIER THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `ring_product (k:A ring) (1..poly_deg k (p:(1->num)->A)) + (\i. poly_eval k (poly_sub k (poly_var k one) + (poly_const k ((a:num->A) i))) ((a:num->A) 1)) = + ring_product k (1..poly_deg k p) + (\i. ring_sub k (a 1) (a i))` SUBST1_TAC THENL + [MATCH_MP_TAC RING_PRODUCT_EQ THEN + REWRITE_TAC[IN_NUMSEG] THEN X_GEN_TAC `j:num` THEN STRIP_TAC THEN + BETA_TAC THEN + SUBGOAL_THEN `(a:num->A) j IN ring_carrier k` ASSUME_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_SIMP_TAC[POLY_EVAL_SUB; RING_POLYNOMIAL_VAR; RING_POLYNOMIAL_CONST; + POLY_EVAL_VAR; POLY_EVAL_CONST]; ALL_TAC] THEN + MP_TAC(SPEC `\i:num. ring_sub (k:A ring) ((a:num->A) 1) (a i)` + (MATCH_MP (REWRITE_RULE[FINITE_NUMSEG] (ISPECL [`k:A ring`; + `1..poly_deg (k:A ring) (p:(1->num)->A)`] + INTEGRAL_DOMAIN_PRODUCT_EQ_0)) + (ASSUME `integral_domain (k:A ring)`))) THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + EXISTS_TAC `1` THEN REWRITE_TAC[IN_NUMSEG; LE_REFL] THEN + BETA_TAC THEN ASM_SIMP_TAC[RING_SUB_REFL] THEN ASM_REWRITE_TAC[]; + (* ring_mul k c (ring_0 k) = ring_0 k *) + ASM_SIMP_TAC[RING_MUL_RZERO]]]);; + +let SIMPLE_ALGEBRAIC_EXTEND_HOMOMORPHISM = prove + (`!(k:A ring) (l:B ring) (l':C ring) (f:A->B) (g:A->C) a. + field k /\ integral_domain l /\ + ring_monomorphism(k,l) f /\ a IN ring_carrier l /\ + algebraic_over(k,l) f a /\ algebraically_closed_field l' /\ + ring_monomorphism(k,l') g + ==> ?h. ring_homomorphism + (subring_generated l (a INSERT IMAGE f (ring_carrier k)), + l') h /\ + (!x. x IN ring_carrier k ==> h(f x) = g x)`, + REPEAT STRIP_TAC THEN + SUBGOAL_THEN `ring_homomorphism(k:A ring,l:B ring) (f:A->B) /\ + ring_homomorphism(k:A ring,l':C ring) (g:A->C)` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[ring_monomorphism]; ALL_TAC] THEN + SUBGOAL_THEN `ring_epimorphism(poly_ring (k:A ring) (:1), + subring_generated (l:B ring) + ((a:B) INSERT IMAGE (f:A->B) (ring_carrier k))) + (poly_extend(k,l) f (\v:1. a))` ASSUME_TAC THENL + [REWRITE_TAC[ring_epimorphism; RING_HOMOMORPHISM_INTO_SUBRING_EQ_GEN] THEN + ASM_SIMP_TAC[RING_HOMOMORPHISM_POLY_EXTEND; IN_UNIV] THEN + MP_TAC(ISPECL [`f:A->B`; `k:A ring`; `l:B ring`; `a:B`] + IMAGE_POLY_EXTEND_1) THEN ASM_REWRITE_TAC[] THEN SIMP_TAC[SUBSET_REFL]; + ALL_TAC] THEN + SUBGOAL_THEN `?a'. (a':C) IN ring_carrier l' /\ + ring_kernel(poly_ring (k:A ring) (:1), subring_generated (l:B ring) + (a INSERT IMAGE (f:A->B) (ring_carrier k))) + (poly_extend(k,l) f (\v:1. a)) SUBSET + ring_kernel(poly_ring (k:A ring) (:1), l':C ring) + (poly_extend(k,l') (g:A->C) (\v:1. a'))` STRIP_ASSUME_TAC THENL + [SUBGOAL_THEN `PID(poly_ring (k:A ring) (:1)) /\ + ring_ideal (poly_ring (k:A ring) (:1)) + (ring_kernel(poly_ring (k:A ring) (:1), subring_generated (l:B ring) + (a INSERT IMAGE (f:A->B) (ring_carrier k))) + (poly_extend(k,l) f (\v:1. a)))` STRIP_ASSUME_TAC THENL + [CONJ_TAC THENL [MATCH_MP_TAC PID_POLY_RING THEN ASM_REWRITE_TAC[]; + MATCH_MP_TAC RING_IDEAL_RING_KERNEL THEN + ASM_MESON_TAC[ring_epimorphism]]; ALL_TAC] THEN SUBGOAL_THEN + `principal_ideal (poly_ring (k:A ring) (:1)) + (ring_kernel(poly_ring (k:A ring) (:1), subring_generated (l:B ring) + (a INSERT IMAGE (f:A->B) (ring_carrier k))) + (poly_extend(k,l) f (\v:1. a)))` MP_TAC THENL + [FIRST_X_ASSUM(STRIP_ASSUME_TAC o GEN_REWRITE_RULE I [PID]) THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[principal_ideal] THEN DISCH_THEN(X_CHOOSE_THEN `m:(1->num)->A` + (CONJUNCTS_THEN2 ASSUME_TAC (ASSUME_TAC o SYM))) THEN + SUBGOAL_THEN `ring_polynomial (k:A ring) (m:(1->num)->A)` ASSUME_TAC THENL + [ASM_REWRITE_TAC[RING_POLYNOMIAL]; ALL_TAC] THEN + (* g o m is in poly_ring l' *) SUBGOAL_THEN `(g:A->C) o (m:(1->num)->A) IN + ring_carrier(poly_ring (l':C ring) (:1))` + ASSUME_TAC THENL [ASM_MESON_TAC[RING_POLYNOMIAL; RING_POLYNOMIAL_COMPOSE]; + ALL_TAC] THEN + ASM_CASES_TAC `poly_deg (k:A ring) (m:(1->num)->A) = 0` THENL + [(* poly_deg k m = 0: m is either 0 or a unit *) ASM_CASES_TAC + `m = ring_0(poly_ring (k:A ring) (:1)):(1->num)->A` THENL + [(* m = 0: kernel = {0}, any a' works *) + EXISTS_TAC `ring_0(l':C ring)` THEN + CONJ_TAC THENL [REWRITE_TAC[RING_0]; ALL_TAC] THEN + ASM_REWRITE_TAC[IDEAL_GENERATED_0] THEN + REWRITE_TAC[SING_SUBSET; ring_kernel; IN_ELIM_THM] THEN CONJ_TAC THENL + [REWRITE_TAC[RING_0]; + MATCH_MP_TAC RING_HOMOMORPHISM_0 THEN MATCH_MP_TAC + RING_HOMOMORPHISM_POLY_EXTEND THEN ASM_REWRITE_TAC[IN_UNIV; + RING_0]]; + SUBGOAL_THEN `ring_unit (poly_ring (k:A ring) (:1)) (m:(1->num)->A)` + ASSUME_TAC THENL + [MP_TAC(ISPECL [`k:A ring`; `m:(1->num)->A`] POLY_DEG_EQ_0) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `c:A` STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[RING_UNIT_POLY_CONST] THEN + ASM_SIMP_TAC[FIELD_UNIT] THEN DISCH_TAC THEN UNDISCH_TAC + `~(m = ring_0(poly_ring (k:A ring) (:1)):(1->num)->A)` THEN + ASM_REWRITE_TAC[POLY_RING_CLAUSES; GSYM POLY_CONST_0]; ALL_TAC] THEN + (* ideal_generated {m} = ring_carrier *) SUBGOAL_THEN + `ideal_generated (poly_ring (k:A ring) (:1)) {m:(1->num)->A} = + ring_carrier(poly_ring (k:A ring) (:1))` ASSUME_TAC THENL + [ASM_MESON_TAC[IDEAL_GENERATED_SING_EQ_CARRIER]; ALL_TAC] THEN + SUBGOAL_THEN `F` (fun th -> MESON_TAC[th]) THEN + SUBGOAL_THEN `poly_extend(k:A ring,l:B ring) (f:A->B) (\v:1. a:B) + (ring_1(poly_ring (k:A ring) (:1))) = + ring_0(subring_generated (l:B ring) + ((a:B) INSERT IMAGE (f:A->B) (ring_carrier (k:A ring))))` + ASSUME_TAC THENL [SUBGOAL_THEN `ring_1(poly_ring (k:A ring) (:1)) IN + ring_kernel(poly_ring (k:A ring) (:1), subring_generated (l:B + ring) + (a INSERT IMAGE (f:A->B) (ring_carrier k))) + (poly_extend(k,l) f (\v:1. a))` + MP_TAC THENL [ASM_REWRITE_TAC[RING_1]; ALL_TAC] THEN + REWRITE_TAC[ring_kernel; IN_ELIM_THM] THEN MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `poly_extend(k:A ring,l:B ring) (f:A->B) (\v:1. a:B) + (ring_1(poly_ring (k:A ring) (:1))) = + ring_1(subring_generated (l:B ring) + ((a:B) INSERT IMAGE (f:A->B) (ring_carrier (k:A ring))))` + ASSUME_TAC THENL [MATCH_MP_TAC RING_HOMOMORPHISM_1 THEN + ASM_MESON_TAC[ring_epimorphism]; ALL_TAC] THEN + SUBGOAL_THEN `ring_0 (l:B ring) = ring_1 (l:B ring)` ASSUME_TAC THENL + [SUBGOAL_THEN `ring_0(subring_generated (l:B ring) + ((a:B) INSERT IMAGE (f:A->B) (ring_carrier (k:A ring)))) = + ring_1(subring_generated (l:B ring) + ((a:B) INSERT IMAGE (f:A->B) (ring_carrier (k:A ring))))` + MP_TAC THENL [ASM_MESON_TAC[]; REWRITE_TAC[SUBRING_GENERATED]]; + ALL_TAC] THEN + ASM_MESON_TAC[INTEGRAL_DOMAIN_IMP_NONTRIVIAL_RING; TRIVIAL_RING_10]]; + SUBGOAL_THEN `~(poly_deg (l':C ring) ((g:A->C) o (m:(1->num)->A)) = 0)` + ASSUME_TAC THENL [ASM_MESON_TAC[POLY_DEG_MONOMORPHIC_IMAGE]; + ALL_TAC] THEN + MP_TAC(ISPEC `l':C ring` algebraically_closed_field) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPEC `(g:A->C) o (m:(1->num)->A)`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `a':C` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `a':C` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC IDEAL_GENERATED_MINIMAL THEN CONJ_TAC THENL + [REWRITE_TAC[SET_RULE `{x:(1->num)->A} SUBSET s <=> x IN s`] THEN + REWRITE_TAC[ring_kernel; IN_ELIM_THM] THEN CONJ_TAC THENL + [ASM_REWRITE_TAC[]; MP_TAC(ISPECL [`k:A ring`; `l':C ring`; `g:A->C`; + `(\v:1. a':C)`; `m:(1->num)->A`] + POLY_EXTEND_EVALUATE) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN SUBST1_TAC THEN + ASM_REWRITE_TAC[GSYM poly_eval]]; + MATCH_MP_TAC RING_IDEAL_RING_KERNEL THEN + MATCH_MP_TAC RING_HOMOMORPHISM_POLY_EXTEND THEN + ASM_REWRITE_TAC[IN_UNIV]]]; ALL_TAC] THEN + SUBGOAL_THEN `ring_homomorphism(poly_ring (k:A ring) (:1), l':C ring) + (poly_extend(k,l') (g:A->C) (\v:1. a':C))` ASSUME_TAC THENL + [MATCH_MP_TAC RING_HOMOMORPHISM_POLY_EXTEND THEN ASM_REWRITE_TAC[IN_UNIV]; + ALL_TAC] THEN (* Step 4: Apply RING_HOMOMORPHISM_EPIMORPHISM_FACTOR *) + MP_TAC(ISPECL [`poly_ring (k:A ring) (:1)`; `subring_generated (l:B ring) + ((a:B) INSERT IMAGE (f:A->B) (ring_carrier k))`; `l':C ring`; + `poly_extend(k:A ring,l:B ring) (f:A->B) (\v:1. a:B)`; + `poly_extend(k:A ring,l':C ring) (g:A->C) (\v:1. a':C)`] + RING_HOMOMORPHISM_EPIMORPHISM_FACTOR) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `h:B->C` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `h:B->C` THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN FIRST_X_ASSUM(MP_TAC o + SPEC `(poly_const (k:A ring) (x:A)):(1->num)->A`) THEN + ASM_REWRITE_TAC[POLY_CONST] THEN ASM_SIMP_TAC[POLY_EXTEND_CONST]);; + +let ALGEBRAIC_CLOSURE_EXTEND_HOMOMORPHISM = prove + (`!(k:A ring) (l:B ring) (l':C ring) (f:A->B) (g:A->C). + algebraic_extension(k,l) f /\ algebraically_closed_field l' /\ + ring_homomorphism(k,l') g + ==> ?h. ring_homomorphism(l,l') h /\ + (!x. x IN ring_carrier k ==> h(f x) = g x)`, + let SUBRING_OF_G0_FROM_CH_P = + MATCH_MP_TAC SUBFIELD_IMP_SUBRING_OF THEN USE_THEN "CH_P" (fun ch_p -> + FIRST_ASSUM(ACCEPT_TAC o CONJUNCT1 o CONJUNCT2 o + CONJUNCT2 o REWRITE_RULE[] o + MATCH_MP (SPEC `G0:(B#C)->bool` ch_p))) in + let HOM_CONST_TAC thm = + USE_THEN "HOM_U" (fun hom_u -> USE_THEN "GW" (fun gw -> + MP_TAC(REWRITE_RULE[CONJUNCT2 SUBRING_GENERATED] + (MATCH_MP thm (MATCH_MP hom_u gw))))) THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN REWRITE_TAC[] in + let G0_X0_IN_CC_TAC : tactic = + SUBGOAL_THEN `?G0:(B#C)->bool. G0 IN cc /\ x0:B IN IMAGE FST G0` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[IN_IMAGE; IN_UNIONS]; ALL_TAC] THEN + SUBGOAL_THEN `IMAGE FST (G0:(B#C)->bool) subring_of (l:B ring)` + ASSUME_TAC THENL [SUBRING_OF_G0_FROM_CH_P; ALL_TAC] THEN + SUBGOAL_THEN + `x0:B IN ring_carrier + (subring_generated (l:B ring) (IMAGE FST (G0:(B#C)->bool)))` + ASSUME_TAC THENL + [ASM_SIMP_TAC[CARRIER_SUBRING_GENERATED_SUBRING]; ALL_TAC] in + REPEAT STRIP_TAC THEN + SUBGOAL_THEN `field (k:A ring) /\ field (l:B ring) /\ field (l':C ring) /\ + ring_monomorphism(k:A ring,l:B ring) f /\ integral_domain (l:B ring) /\ + ring_monomorphism(k:A ring,l':C ring) g /\ + ring_homomorphism(k:A ring,l:B ring) (f:A->B)` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[algebraic_extension; field_extension; + ALGEBRAICALLY_CLOSED_FIELD_IMP_FIELD; FIELD_IMP_INTEGRAL_DOMAIN; + FIELD_RING_HOMOMORPHISM_MONOMORPHISM; FIELD_IMP_NONTRIVIAL_RING; + ring_monomorphism]; ALL_TAC] THEN + (* Apply Zorn's lemma on graphs (subsets of B x C) encoding partial + homomorphisms. P(G) says G is a functional relation whose domain is + a subfield of l containing IMAGE f (carrier k), and the induced + function is a ring homomorphism extending g. *) + MP_TAC(ISPEC `\G:(B#C)->bool. + G SUBSET (ring_carrier l CROSS ring_carrier l') /\ + (!x:B y1:C y2:C. (x,y1) IN G /\ (x,y2) IN G ==> y1 = y2) /\ + (IMAGE FST G) subfield_of (l:B ring) /\ + IMAGE (f:A->B) (ring_carrier k) SUBSET IMAGE FST G /\ ring_homomorphism + (subring_generated l (IMAGE FST G), l':C ring) + (\x:B. @y:C. (x,y) IN G) /\ (!x:A. x IN ring_carrier k + ==> (@y:C. ((f:A->B) x,y) IN G) = g x)` + ZL_SUBSETS_UNIONS_NONEMPTY) THEN ANTS_TAC THENL [CONJ_TAC THENL + [(* Existence: the graph {(f x, g x) | x in carrier k} works *) ABBREV_TAC + `G0 = {((f:A->B) x, (g:A->C) x) | x IN ring_carrier k}` THEN + EXISTS_TAC `G0:(B#C)->bool` THEN + SUBGOAL_THEN `!a1 a2:A. a1 IN ring_carrier k /\ a2 IN ring_carrier k /\ + (f:A->B) a1 = f a2 ==> a1 = a2` + (LABEL_TAC "INJ") THENL [ASM_MESON_TAC[ring_monomorphism]; + ALL_TAC] THEN + SUBGOAL_THEN `!a:A. a IN ring_carrier k + ==> (@y:C. ((f:A->B) a, y) IN G0) = (g:A->C) a` + (LABEL_TAC "SELECT") THENL [X_GEN_TAC `a:A` THEN DISCH_TAC THEN + MATCH_MP_TAC SELECT_UNIQUE THEN X_GEN_TAC `c:C` THEN + EXPAND_TAC "G0" THEN REWRITE_TAC[IN_ELIM_THM; PAIR_EQ] THEN + ASM_MESON_TAC[]; ALL_TAC] THEN SUBGOAL_THEN + `IMAGE FST (G0:(B#C)->bool) = IMAGE (f:A->B) (ring_carrier k)` + ASSUME_TAC THENL [EXPAND_TAC "G0" THEN + REWRITE_TAC[EXTENSION; IN_IMAGE; IN_ELIM_THM; + EXISTS_PAIR_THM; PAIR_EQ; FST] THEN + MESON_TAC[]; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [(* G0 SUBSET carrier l CROSS carrier l' *) + EXPAND_TAC "G0" THEN REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_CROSS] THEN + X_GEN_TAC `p:B#C` THEN + DISCH_THEN(X_CHOOSE_THEN `a0:A` STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[FST; SND; IN_CROSS] THEN CONJ_TAC THEN + FIRST_ASSUM(MATCH_MP_TAC o REWRITE_RULE[SUBSET; FORALL_IN_IMAGE] o + CONJUNCT1 o GEN_REWRITE_RULE I [ring_homomorphism]) THEN + ASM_REWRITE_TAC[]; EXPAND_TAC "G0" THEN + REWRITE_TAC[IN_ELIM_THM; PAIR_EQ] THEN ASM_MESON_TAC[]; + MATCH_MP_TAC SUBFIELD_OF_MONOMORPHIC_IMAGE THEN + EXISTS_TAC `k:A ring` THEN ASM_SIMP_TAC[CARRIER_SUBFIELD_OF]; + SET_TAC[]; + MP_TAC(ISPECL [`k:A ring`; `subring_generated (l:B ring) + (IMAGE (f:A->B) (ring_carrier k))`; `l':C ring`; + `f:A->B`; `g:A->C`] + RING_HOMOMORPHISM_EPIMORPHISM_FACTOR) THEN ANTS_TAC THENL + [REPEAT CONJ_TAC THENL + [(* ring_epimorphism(k, subring_generated l (IMAGE f carrier_k)) f + *) + REWRITE_TAC[ring_epimorphism] THEN CONJ_TAC THENL + [MATCH_MP_TAC RING_HOMOMORPHISM_INTO_SUBRING THEN + ASM_REWRITE_TAC[SUBSET_REFL]; + SUBGOAL_THEN `(IMAGE (f:A->B) (ring_carrier k)) subring_of l` + (fun th -> SIMP_TAC[th; + CARRIER_SUBRING_GENERATED_SUBRING]) THEN + MATCH_MP_TAC SUBFIELD_IMP_SUBRING_OF THEN + MATCH_MP_TAC SUBFIELD_OF_MONOMORPHIC_IMAGE THEN + EXISTS_TAC `k:A ring` THEN ASM_SIMP_TAC[CARRIER_SUBFIELD_OF]]; + (* ring_homomorphism(k, l') g *) ASM_REWRITE_TAC[]; + REWRITE_TAC[RING_KERNEL_TO_SUBRING_GENERATED] THEN SUBGOAL_THEN + `ring_kernel(k:A ring,l:B ring) f = {ring_0 k}` + SUBST1_TAC THENL [ASM_MESON_TAC[RING_MONOMORPHISM]; ALL_TAC] THEN + REWRITE_TAC[SING_SUBSET] THEN MATCH_MP_TAC RING_KERNEL_0 THEN + ASM_REWRITE_TAC[]]; + ALL_TAC] THEN (* Continuation: transfer from h' to the @-function *) + DISCH_THEN(X_CHOOSE_THEN `h':B->C` STRIP_ASSUME_TAC) THEN + MATCH_MP_TAC RING_HOMOMORPHISM_EQ THEN + EXISTS_TAC `h':B->C` THEN ASM_REWRITE_TAC[] THEN SUBGOAL_THEN + `(IMAGE (f:A->B) (ring_carrier k)) subring_of l` ASSUME_TAC THENL + [MATCH_MP_TAC SUBFIELD_IMP_SUBRING_OF THEN MATCH_MP_TAC + SUBFIELD_OF_MONOMORPHIC_IMAGE THEN + EXISTS_TAC `k:A ring` THEN ASM_SIMP_TAC[CARRIER_SUBFIELD_OF]; + ALL_TAC] THEN + ASM_SIMP_TAC[CARRIER_SUBRING_GENERATED_SUBRING] THEN + REWRITE_TAC[FORALL_IN_IMAGE] THEN X_GEN_TAC `a:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(@y:C. ((f:A->B) a,y) IN G0) = (g:A->C) a` + SUBST1_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN ASM_MESON_TAC[]]; + X_GEN_TAC `cc:((B#C)->bool)->bool` THEN BETA_TAC THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `G_w:(B#C)->bool` (LABEL_TAC "GW")) + (CONJUNCTS_THEN2 (LABEL_TAC "CH_P") (LABEL_TAC "CH_ORD"))) THEN + SUBGOAL_THEN `!G:(B#C)->bool. G IN cc ==> + !x:B y1:C y2:C. (x,y1) IN G /\ (x,y2) IN G ==> y1 = y2` + ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `!x:B y1:C y2:C. + (x,y1) IN UNIONS cc /\ (x,y2) IN UNIONS cc ==> y1 = y2` + (LABEL_TAC "UFUNC") THENL + [REWRITE_TAC[IN_UNIONS] THEN ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + SUBGOAL_THEN `!G:(B#C)->bool. G IN cc ==> !x:B. x IN IMAGE FST G ==> + (@y:C. (x,y) IN UNIONS cc) = (@y. (x,y) IN G)` + (LABEL_TAC "SELECT_UNION") THENL + [X_GEN_TAC `G0:(B#C)->bool` THEN DISCH_TAC THEN + X_GEN_TAC `x0:B` THEN DISCH_TAC THEN SUBGOAL_THEN + `!y0:C. (x0:B,y0) IN UNIONS cc <=> + (x0,y0) IN (G0:(B#C)->bool)` (fun th -> REWRITE_TAC[th]) THEN + X_GEN_TAC `y0:C` THEN EQ_TAC THENL [DISCH_TAC THEN + SUBGOAL_THEN `?y':C. (x0:B,y') IN (G0:(B#C)->bool)` + STRIP_ASSUME_TAC THENL + [MP_TAC(ASSUME `x0:B IN IMAGE FST (G0:(B#C)->bool)`) THEN + REWRITE_TAC[IN_IMAGE; EXISTS_PAIR_THM; FST; PAIR_EQ] THEN + MESON_TAC[]; ALL_TAC] THEN ASM_MESON_TAC[IN_UNIONS]; + ASM_MESON_TAC[IN_UNIONS]]; ALL_TAC] THEN + SUBGOAL_THEN `IMAGE FST (UNIONS cc:(B#C)->bool) subring_of (l:B ring)` + (LABEL_TAC "SR") THENL [REWRITE_TAC[IMAGE_UNIONS] THEN + MATCH_MP_TAC SUBRING_OF_UNIONS THEN REPEAT CONJ_TAC THENL + [REWRITE_TAC[IMAGE_EQ_EMPTY] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN USE_THEN "GW" (fun gw -> + EXISTS_TAC `G_w:(B#C)->bool` THEN ACCEPT_TAC gw); + REWRITE_TAC[FORALL_IN_IMAGE] THEN + X_GEN_TAC `G0:(B#C)->bool` THEN DISCH_TAC THEN + SUBRING_OF_G0_FROM_CH_P; REWRITE_TAC[IN_IMAGE] THEN + MAP_EVERY X_GEN_TAC [`s1:B->bool`; `s2:B->bool`] THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `G1:(B#C)->bool` STRIP_ASSUME_TAC) + (X_CHOOSE_THEN `G2:(B#C)->bool` STRIP_ASSUME_TAC)) THEN + FIRST_X_ASSUM SUBST1_TAC THEN FIRST_X_ASSUM SUBST1_TAC THEN + USE_THEN "CH_ORD" (fun ch_ord -> DISJ_CASES_TAC(MATCH_MP + (SPECL [`G1:(B#C)->bool`; `G2:(B#C)->bool`] ch_ord) + (CONJ (ASSUME `(G1:(B#C)->bool) IN cc`) + (ASSUME `(G2:(B#C)->bool) IN cc`)))) THENL + [DISJ1_TAC; DISJ2_TAC] THEN MATCH_MP_TAC IMAGE_SUBSET THEN + ASM_REWRITE_TAC[]]; + ALL_TAC] THEN REPEAT CONJ_TAC THENL + [(* 1. UNIONS cc SUBSET carrier l CROSS carrier l' *) + REWRITE_TAC[UNIONS_SUBSET] THEN ASM_MESON_TAC[]; + (* 2. Functional *) USE_THEN "UFUNC" ACCEPT_TAC; (* 3. subfield_of *) + REWRITE_TAC[subfield_of] THEN CONJ_TAC THENL [USE_THEN "SR" ACCEPT_TAC; + ASM_SIMP_TAC[field; CONJUNCT2 SUBRING_GENERATED; + CARRIER_SUBRING_GENERATED_SUBRING] THEN + CONJ_TAC THENL [ASM_MESON_TAC[FIELD_NONTRIVIAL]; ALL_TAC] THEN + X_GEN_TAC `x0:B` THEN STRIP_TAC THEN + SUBGOAL_THEN `?G0. (G0:(B#C)->bool) IN cc /\ (x0:B) IN IMAGE FST G0` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[IN_IMAGE; IN_UNIONS]; + ALL_TAC] THEN + SUBGOAL_THEN `IMAGE FST (G0:(B#C)->bool) subfield_of (l:B ring)` + ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN SUBGOAL_THEN + `ring_inv (l:B ring) (x0:B) IN IMAGE FST (G0:(B#C)->bool)` + ASSUME_TAC THENL [MATCH_MP_TAC IN_SUBFIELD_INV THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(x0:B) IN ring_carrier (l:B ring)` + ASSUME_TAC THENL [ASM_MESON_TAC[subring_of; SUBSET]; ALL_TAC] THEN + EXISTS_TAC `ring_inv (l:B ring) (x0:B)` THEN CONJ_TAC THENL + [ASM_MESON_TAC[IN_IMAGE; IN_UNIONS]; ASM_SIMP_TAC[FIELD_MUL_RINV]]]; + USE_THEN "CH_P" (fun ch_p -> USE_THEN "GW" (fun gw -> + STRIP_ASSUME_TAC(MATCH_MP (SPEC `G_w:(B#C)->bool` ch_p) gw))) THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `IMAGE FST (G_w:(B#C)->bool)` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC IMAGE_SUBSET THEN REWRITE_TAC[SUBSET; IN_UNIONS] THEN + USE_THEN "GW" (fun th -> MESON_TAC[th]); + (* 5. ring_homomorphism (per-G and for UNIONS) *) + SUBGOAL_THEN `!G. G IN cc ==> ring_homomorphism + (subring_generated (l:B ring) (IMAGE FST G), l':C ring) + (\x:B. @y:C. (x,y) IN UNIONS cc)` (LABEL_TAC "HOM_U") THENL + [X_GEN_TAC `G0:(B#C)->bool` THEN DISCH_TAC THEN SUBGOAL_THEN + `IMAGE FST (G0:(B#C)->bool) subring_of (l:B ring)` + ASSUME_TAC THENL [SUBRING_OF_G0_FROM_CH_P; ALL_TAC] THEN + MATCH_MP_TAC RING_HOMOMORPHISM_EQ THEN + EXISTS_TAC `\x:B. @y:C. (x,y) IN (G0:(B#C)->bool)` THEN + CONJ_TAC THENL + [ASM_MESON_TAC[]; + ASM_SIMP_TAC[CARRIER_SUBRING_GENERATED_SUBRING] THEN + X_GEN_TAC `x0:B` THEN DISCH_TAC THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + USE_THEN "SELECT_UNION" (fun su -> + FIRST_ASSUM(fun gin -> MP_TAC(SPEC `x0:B` + (MATCH_MP (SPEC `G0:(B#C)->bool` su) gin)))) THEN + ASM_REWRITE_TAC[]]; ALL_TAC] THEN + REWRITE_TAC[ring_homomorphism; CONJUNCT2 SUBRING_GENERATED] THEN + USE_THEN "SR" (fun sr -> + REWRITE_TAC[MATCH_MP CARRIER_SUBRING_GENERATED_SUBRING sr]) THEN + CONJ_TAC THENL + [(* 5a. IMAGE subset *) REWRITE_TAC[SUBSET] THEN X_GEN_TAC `c0:C` THEN + GEN_REWRITE_TAC LAND_CONV [IN_IMAGE] THEN + DISCH_THEN(X_CHOOSE_THEN `x0:B` + (CONJUNCTS_THEN2 SUBST1_TAC ASSUME_TAC)) THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN G0_X0_IN_CC_TAC THEN + USE_THEN "HOM_U" (fun hom_u -> + FIRST_ASSUM(fun gin -> FIRST_ASSUM(fun xin -> + MP_TAC(CONV_RULE(DEPTH_CONV BETA_CONV) + (MP (SPEC `x0:B` (CONJUNCT1(REWRITE_RULE + [ring_homomorphism; SUBSET; FORALL_IN_IMAGE] + (MATCH_MP hom_u gin)))) + xin))))) THEN SIMP_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL [HOM_CONST_TAC RING_HOMOMORPHISM_0; ALL_TAC] THEN + CONJ_TAC THENL [HOM_CONST_TAC RING_HOMOMORPHISM_1; ALL_TAC] THEN + CONJ_TAC THENL [(* 5d: ring_neg *) + X_GEN_TAC `x0:B` THEN DISCH_TAC THEN G0_X0_IN_CC_TAC THEN + USE_THEN "HOM_U" (fun hom_u -> + FIRST_ASSUM(fun gin -> FIRST_ASSUM(fun xin -> + MP_TAC(CONV_RULE(DEPTH_CONV BETA_CONV) + (REWRITE_RULE[CONJUNCT2 SUBRING_GENERATED] + (MATCH_MP (SPEC `x0:B` (MATCH_MP RING_HOMOMORPHISM_NEG + (MATCH_MP hom_u gin))) + xin)))))) THEN REWRITE_TAC[]; ALL_TAC] THEN + (let chain_binop_tac ring_hom_op = + MAP_EVERY X_GEN_TAC [`x0:B`; `y0:B`] THEN STRIP_TAC THEN SUBGOAL_THEN + `?G0:(B#C)->bool. G0 IN cc /\ + x0:B IN IMAGE FST G0 /\ y0:B IN IMAGE FST G0` + STRIP_ASSUME_TAC THENL [SUBGOAL_THEN + `(?G1:(B#C)->bool. G1 IN cc /\ x0:B IN IMAGE FST G1) /\ + (?G2:(B#C)->bool. G2 IN cc /\ y0:B IN IMAGE FST G2)` + (CONJUNCTS_THEN2 STRIP_ASSUME_TAC STRIP_ASSUME_TAC) THENL + [CONJ_TAC THEN ASM_MESON_TAC[IN_IMAGE; IN_UNIONS]; ALL_TAC] THEN + USE_THEN "CH_ORD" (fun ch_ord -> DISJ_CASES_TAC(MATCH_MP + (SPECL [`G1:(B#C)->bool`; `G2:(B#C)->bool`] ch_ord) + (CONJ (ASSUME `G1:(B#C)->bool IN cc`) + (ASSUME `G2:(B#C)->bool IN cc`)))) THENL + [EXISTS_TAC `G2:(B#C)->bool` THEN ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[SUBSET; IN_IMAGE]; + EXISTS_TAC `G1:(B#C)->bool` THEN ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[SUBSET; IN_IMAGE]]; + ALL_TAC] THEN SUBGOAL_THEN + `IMAGE FST (G0:(B#C)->bool) subring_of (l:B ring)` + ASSUME_TAC THENL [SUBRING_OF_G0_FROM_CH_P; ALL_TAC] THEN + SUBGOAL_THEN `x0:B IN ring_carrier (subring_generated (l:B ring) + (IMAGE FST (G0:(B#C)->bool))) /\ + y0:B IN ring_carrier (subring_generated (l:B ring) + (IMAGE FST (G0:(B#C)->bool)))` + ASSUME_TAC THENL [ASM_SIMP_TAC[CARRIER_SUBRING_GENERATED_SUBRING]; + ALL_TAC] THEN + USE_THEN "HOM_U" (fun hom_u -> + FIRST_ASSUM(fun gin -> FIRST_ASSUM(fun xyin -> + MP_TAC(CONV_RULE(DEPTH_CONV BETA_CONV) + (REWRITE_RULE[CONJUNCT2 SUBRING_GENERATED] + (MATCH_MP (SPECL [`x0:B`; `y0:B`] + (MATCH_MP ring_hom_op (MATCH_MP hom_u gin))) + xyin)))))) THEN REWRITE_TAC[] in + CONJ_TAC THENL [chain_binop_tac RING_HOMOMORPHISM_ADD; ALL_TAC] THEN + chain_binop_tac RING_HOMOMORPHISM_MUL); (* 6. extends g *) + X_GEN_TAC `a0:A` THEN DISCH_TAC THEN USE_THEN "CH_P" (fun ch_p -> + USE_THEN "GW" (fun gw -> STRIP_ASSUME_TAC(MATCH_MP + (SPEC `G_w:(B#C)->bool` ch_p) gw))) THEN + SUBGOAL_THEN `(f:A->B) a0 IN IMAGE FST (G_w:(B#C)->bool)` + ASSUME_TAC THENL [FIRST_X_ASSUM(MATCH_MP_TAC o + REWRITE_RULE[SUBSET; FORALL_IN_IMAGE]) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN USE_THEN "SELECT_UNION" (fun su -> + USE_THEN "GW" (fun gw -> MP_TAC(SPEC `(f:A->B) a0` + (MATCH_MP (SPEC `G_w:(B#C)->bool` su) gw)))) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN SUBST1_TAC THEN + ASM_MESON_TAC[]]]; (* end chain closure *) + DISCH_THEN(X_CHOOSE_THEN `G:(B#C)->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `IMAGE FST (G:(B#C)->bool) = ring_carrier (l:B ring)` + ASSUME_TAC THENL [(* Proof: IMAGE FST G = ring_carrier l *) + REWRITE_TAC[GSYM SUBSET_ANTISYM_EQ] THEN CONJ_TAC THENL + [(* Easy: IMAGE FST G SUBSET ring_carrier l *) + ASM_MESON_TAC[SUBFIELD_OF_IMP_SUBSET]; ALL_TAC] THEN + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `a:B` THEN DISCH_TAC THEN + ASM_CASES_TAC `(a:B) IN IMAGE FST (G:(B#C)->bool)` THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN SUBGOAL_THEN + `field(subring_generated (l:B ring) (IMAGE FST (G:(B#C)->bool))) /\ + IMAGE FST (G:(B#C)->bool) subring_of (l:B ring) /\ + ring_monomorphism (subring_generated (l:B ring) + (IMAGE FST (G:(B#C)->bool)), l) I` STRIP_ASSUME_TAC THENL + [REPEAT CONJ_TAC THENL + [ASM_MESON_TAC[subfield_of]; ASM_MESON_TAC[SUBFIELD_IMP_SUBRING_OF]; + REWRITE_TAC[I_DEF; RING_MONOMORPHISM_INCLUSION]]; ALL_TAC] THEN + SUBGOAL_THEN `ring_carrier(subring_generated (l:B ring) + (IMAGE FST (G:(B#C)->bool))) = IMAGE FST G` ASSUME_TAC THENL + [ASM_SIMP_TAC[CARRIER_SUBRING_GENERATED_SUBRING]; ALL_TAC] THEN + SUBGOAL_THEN `algebraic_over (subring_generated (l:B ring) + (IMAGE FST (G:(B#C)->bool)), l) I (a:B)` ASSUME_TAC THENL + [MATCH_MP_TAC ALGEBRAIC_OVER_SUBRING_GENERATED_MONO THEN + EXISTS_TAC `IMAGE (f:A->B) (ring_carrier k)` THEN CONJ_TAC THENL + [MP_TAC(ISPECL [`f:A->B`; `k:A ring`; `l:B ring`; `a:B`] + ALGEBRAIC_OVER_RANGE) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(fun th -> REWRITE_TAC[GSYM th]) THEN + ASM_MESON_TAC[algebraic_extension]; ASM_MESON_TAC[]]; ALL_TAC] THEN + (* Monomorphism of h_G *) SUBGOAL_THEN `ring_monomorphism + (subring_generated (l:B ring) (IMAGE FST (G:(B#C)->bool)), l':C ring) + (\x:B. @y:C. (x,y) IN G)` ASSUME_TAC THENL + [MATCH_MP_TAC FIELD_RING_HOMOMORPHISM_MONOMORPHISM THEN + ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[FIELD_IMP_NONTRIVIAL_RING]; ALL_TAC] THEN MP_TAC(ISPECL + [`subring_generated (l:B ring) (IMAGE FST (G:(B#C)->bool))`; + `l:B ring`; `l':C ring`; `I:B->B`; + `(\x:B. @y:C. (x,y) IN (G:(B#C)->bool)):B->C`; `a:B`] + SIMPLE_ALGEBRAIC_EXTEND_HOMOMORPHISM) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN ASM_REWRITE_TAC[IMAGE_I; I_DEF] THEN + DISCH_THEN(X_CHOOSE_THEN `h':B->C` STRIP_ASSUME_TAC) THEN + ABBREV_TAC `S' = ring_carrier(subring_generated (l:B ring) + ((a:B) INSERT IMAGE FST (G:(B#C)->bool)))` THEN + SUBGOAL_THEN `field(subring_generated (l:B ring) + ((a:B) INSERT IMAGE FST (G:(B#C)->bool)))` ASSUME_TAC THENL + [MP_TAC(ISPECL [`I:B->B`; + `subring_generated (l:B ring) (IMAGE FST (G:(B#C)->bool))`; + `l:B ring`; `a:B`] FIELD_SIMPLE_ALGEBRAIC_EXTENSION_GEN) THEN + ASM_REWRITE_TAC[IMAGE_I] THEN DISCH_THEN MATCH_MP_TAC THEN + ASM_MESON_TAC[ring_monomorphism]; ALL_TAC] THEN + SUBGOAL_THEN `(S':B->bool) subfield_of (l:B ring) /\ + (a:B) IN (S':B->bool)` STRIP_ASSUME_TAC THENL + [EXPAND_TAC "S'" THEN CONJ_TAC THENL + [ASM_REWRITE_TAC[subfield_of; SUBRING_SUBRING_GENERATED; + SUBRING_GENERATED_BY_SUBRING_GENERATED]; + MATCH_MP_TAC SUBRING_GENERATED_INC_GEN THEN + ASM_REWRITE_TAC[IN_INSERT]]; ALL_TAC] THEN + SUBGOAL_THEN `IMAGE FST (G:(B#C)->bool) SUBSET (S':B->bool) /\ + (S':B->bool) SUBSET ring_carrier (l:B ring)` STRIP_ASSUME_TAC THENL + [EXPAND_TAC "S'" THEN CONJ_TAC THENL [MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `(a:B) INSERT IMAGE FST (G:(B#C)->bool)` THEN + CONJ_TAC THENL [SET_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC SUBRING_GENERATED_SUBSET_CARRIER_SUBSET THEN + REWRITE_TAC[INSERT_SUBSET] THEN + ASM_MESON_TAC[SUBFIELD_OF_IMP_SUBSET; SUBSET]; + REWRITE_TAC[RING_CARRIER_SUBRING_GENERATED_SUBSET]]; ALL_TAC] THEN + SUBGOAL_THEN `(!x:B y1:C y2:C. + (x,y1) IN (G:(B#C)->bool) /\ (x,y2) IN G ==> y1 = y2) /\ + (!x:A. x IN ring_carrier k + ==> (@y:C. ((f:A->B) x,y) IN (G:(B#C)->bool)) = + (g:A->C) x)` STRIP_ASSUME_TAC THENL + [CONJ_TAC THEN ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `IMAGE FST (IMAGE (\x:B. (x, (h':B->C) x)) (S':B->bool)) + = (S':B->bool)` ASSUME_TAC THENL + [REWRITE_TAC[EXTENSION; IN_IMAGE; EXISTS_PAIR_THM; FST; PAIR_EQ] THEN + MESON_TAC[]; ALL_TAC] THEN SUBGOAL_THEN `!b:B. b IN S' + ==> (@c:C. (b,c) IN IMAGE (\x:B. (x, (h':B->C) x)) + (S':B->bool)) = h' b` ASSUME_TAC + THENL + [REPEAT STRIP_TAC THEN MATCH_MP_TAC SELECT_UNIQUE THEN + X_GEN_TAC `c':C` THEN + REWRITE_TAC[IN_IMAGE; PAIR_EQ] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + (* Apply maximality: G = IMAGE (\x. (x, h' x)) S' *) SUBGOAL_THEN + `(G:(B#C)->bool) = IMAGE (\x:B. (x, (h':B->C) x)) (S':B->bool)` + ASSUME_TAC THENL [FIRST_X_ASSUM(MP_TAC o SPEC + `IMAGE (\x:B. (x, (h':B->C) x)) (S':B->bool)`) THEN + REWRITE_TAC[] THEN + ANTS_TAC THENL [CONJ_TAC THENL [(* P(G') - 6 conditions *) + ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [(* 1 *) REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_CROSS] THEN + X_GEN_TAC `b':B` THEN DISCH_TAC THEN CONJ_TAC THENL + [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN EXPAND_TAC "S'" THEN + ASM_MESON_TAC[ring_homomorphism; SUBSET; IN_IMAGE]; + (* 2 *) REWRITE_TAC[IN_IMAGE; PAIR_EQ] THEN MESON_TAC[]; + (* 4 *) ASM_MESON_TAC[SUBSET_TRANS]; (* 5: ring_homomorphism *) + SUBGOAL_THEN `subring_generated (l:B ring) (S':B->bool) = + subring_generated l + ((a:B) INSERT IMAGE FST (G:(B#C)->bool))` SUBST1_TAC THENL + [UNDISCH_TAC `ring_carrier (subring_generated (l:B ring) + ((a:B) INSERT IMAGE FST (G:(B#C)->bool))) = S'` THEN + DISCH_THEN(SUBST1_TAC o SYM) THEN + REWRITE_TAC[SUBRING_GENERATED_BY_SUBRING_GENERATED]; + ALL_TAC] THEN + MATCH_MP_TAC RING_HOMOMORPHISM_EQ THEN EXISTS_TAC `h':B->C` THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN REPEAT STRIP_TAC THEN + CONV_TAC BETA_CONV THEN FIRST_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; X_GEN_TAC `x0:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(f:A->B) x0 IN (S':B->bool) /\ + (f:A->B) x0 IN IMAGE FST (G:(B#C)->bool)` STRIP_ASSUME_TAC + THENL + [CONJ_TAC THEN ASM_MESON_TAC[SUBSET; IN_IMAGE]; ALL_TAC] THEN + SUBGOAL_THEN `(@y:C. ((f:A->B) x0,y) IN + IMAGE (\x:B. (x,(h':B->C) x)) (S':B->bool)) = + (h':B->C) ((f:A->B) x0)` SUBST1_TAC THENL [ASM_MESON_TAC[]; + ALL_TAC] THEN + ASM_MESON_TAC[]]; (* G SUBSET G' *) + REWRITE_TAC[SUBSET; FORALL_PAIR_THM; IN_IMAGE; PAIR_EQ] THEN + MAP_EVERY X_GEN_TAC [`x0:B`; `y0:C`] THEN DISCH_TAC THEN + SUBGOAL_THEN `(x0:B) IN (S':B->bool)` ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET; IN_IMAGE; FST]; ALL_TAC] THEN + EXISTS_TAC `x0:B` THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `(h':B->C) x0 = + (@y:C. (x0,y) IN (G:(B#C)->bool))` SUBST1_TAC THENL + [ASM_MESON_TAC[IN_IMAGE; FST]; ALL_TAC] THEN + CONV_TAC SYM_CONV THEN MATCH_MP_TAC SELECT_UNIQUE THEN + X_GEN_TAC `z:C` THEN ASM_MESON_TAC[]]; + DISCH_THEN ACCEPT_TAC]; ALL_TAC] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + EXISTS_TAC `\x:B. @y:C. (x,y) IN (G:(B#C)->bool)` THEN + ASM_MESON_TAC[SUBRING_GENERATED_RING_CARRIER]]);; + +let ALGEBRAIC_CLOSURE_EXISTS_ID = prove + (`!k:A ring. + ring_carrier k <_c (:A) /\ (:num) <_c (:A) /\ field k + ==> ?l. algebraic_extension (k,l) I /\ algebraically_closed_field l`, + REPEAT STRIP_TAC THEN MP_TAC(ISPEC + `\(l:A ring) (l':A ring). algebraic_extension(k,l) I /\ + algebraic_extension(k,l') I /\ + field_extension(l,l') I` ZL_STRONG) THEN + REWRITE_TAC[] THEN MATCH_MP_TAC(TAUT + `(p /\ (p ==> (q ==> r) ==> s)) ==> (p /\ q ==> r) ==> s`) THEN + CONJ_TAC THENL + [MATCH_MP_TAC QOSET_RESTRICT THEN REWRITE_TAC[qoset; IN_FLD] THEN + MESON_TAC[FIELD_EXTENSION_REFL; field_extension; I_O_ID; + FIELD_EXTENSION_TRANS]; + SIMP_TAC[QOSET_FLD; IN_ELIM_THM] THEN DISCH_THEN(K ALL_TAC)] THEN + REWRITE_TAC[CONJ_ASSOC] THEN REWRITE_TAC[chain; GSYM CONJ_ASSOC] THEN + ANTS_TAC THENL [X_GEN_TAC `c:A ring->bool` THEN + ASM_CASES_TAC `c:A ring->bool = {}` THENL + [ASM_REWRITE_TAC[NOT_IN_EMPTY] THEN EXISTS_TAC `k:A ring` THEN + ASM_REWRITE_TAC[ALGEBRAIC_EXTENSION_REFL; FIELD_EXTENSION_REFL]; + STRIP_TAC] THEN + MP_TAC(ISPEC `c:A ring->bool` RING_DIRECT_LIMIT) THEN ANTS_TAC THENL + [RULE_ASSUM_TAC(REWRITE_RULE[field_extension]) THEN + ASM_MESON_TAC[RING_MONOMORPHISM_I]; + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `l:A ring` THEN STRIP_TAC] THEN + REWRITE_TAC[FIELD_EXTENSION_REFL] THEN SUBGOAL_THEN `!f:A ring. f IN c + ==> field f /\ ring_monomorphism(k,f) I /\ + algebraic_extension(k,f) I` ASSUME_TAC THENL + [ASM_MESON_TAC[ALGEBRAIC_EXTENSION; field_extension]; + FIRST_X_ASSUM(K ALL_TAC o SPECL [`k:A ring`; `k:A ring`])] THEN + SUBGOAL_THEN `field(l:A ring)` ASSUME_TAC THENL + [REWRITE_TAC[field; GSYM TRIVIAL_RING_10] THEN CONJ_TAC THENL + [ASM_MESON_TAC[MEMBER_NOT_EMPTY; + FIELD_IMP_NONTRIVIAL_RING; TRIVIAL_RING_MONOMORPHIC_IMAGE_EQ]; + ASM_REWRITE_TAC[IMP_CONJ; FORALL_IN_UNIONS; EXISTS_IN_UNIONS; + RIGHT_FORALL_IMP_THM; RIGHT_EXISTS_AND_THM; + FORALL_IN_GSPEC; EXISTS_IN_GSPEC]] THEN + X_GEN_TAC `f:A ring` THEN DISCH_TAC THEN + X_GEN_TAC `a:A` THEN REPEAT DISCH_TAC THEN + REPEAT(FIRST_X_ASSUM(MP_TAC o SPEC `f:A ring`)) THEN + ASM_REWRITE_TAC[ring_monomorphism; ring_homomorphism; I_THM] THEN + STRIP_TAC THEN DISCH_THEN(CONJUNCTS_THEN2 MP_TAC STRIP_ASSUME_TAC) THEN + REWRITE_TAC[field] THEN DISCH_THEN(MP_TAC o SPEC `a:A` o CONJUNCT2) THEN + ASM_MESON_TAC[]; ASM_SIMP_TAC[]] THEN + SUBGOAL_THEN `field_extension (k,l) (I:A->A)` ASSUME_TAC THENL + [GEN_REWRITE_TAC RAND_CONV [GSYM I_O_ID] THEN + MATCH_MP_TAC FIELD_EXTENSION_TRANS THEN + ASM_REWRITE_TAC[field_extension] THEN + FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + DISCH_THEN(X_CHOOSE_TAC `f0:A ring`) THEN + EXISTS_TAC `f0:A ring` THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + MATCH_MP_TAC(TAUT `(p ==> q) /\ p ==> p /\ q`) THEN CONJ_TAC THENL + [ASM_MESON_TAC[ALGEBRAIC_EXTENSION; field_extension]; + ASM_REWRITE_TAC[ALGEBRAIC_EXTENSION]] THEN + REWRITE_TAC[UNIONS_GSPEC; FORALL_IN_GSPEC] THEN X_GEN_TAC `z:A` THEN + DISCH_THEN(X_CHOOSE_THEN `f:A ring` STRIP_ASSUME_TAC) THEN + REPEAT(FIRST_X_ASSUM(MP_TAC o SPEC `f:A ring`)) THEN + ASM_REWRITE_TAC[] THEN REPEAT STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [ALGEBRAIC_EXTENSION]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `z:A`)) THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC MONO_EXISTS THEN + X_GEN_TAC `p:(1->num)->A` THEN + STRIP_TAC THEN FIRST_X_ASSUM(MP_TAC o AP_TERM `I:A->A`) THEN + ASM_REWRITE_TAC[] THEN MP_TAC(ISPECL + [`k:A ring`; `f:A ring`; `l:A ring`; `I:A->A`; `(:1)`; + `(\v. z):1->A`; `I:A->A`; `p:(1->num)->A`] + POLY_EXTEND_HOMOMORPHIC_IMAGE) THEN + ASM_SIMP_TAC[RING_MONOMORPHISM_IMP_HOMOMORPHISM] THEN + ASM_REWRITE_TAC[SUBSET; FORALL_IN_IMAGE] THEN DISCH_THEN SUBST1_TAC THEN + REWRITE_TAC[I_O_ID] THEN DISCH_THEN SUBST1_TAC THEN REWRITE_TAC[I_THM] THEN + RULE_ASSUM_TAC(REWRITE_RULE + [ring_monomorphism; ring_homomorphism; I_THM]) THEN ASM_MESON_TAC[]; + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `l:A ring` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[algebraically_closed_field] THEN + CONJ_TAC THENL + [ASM_MESON_TAC[ALGEBRAIC_EXTENSION; field_extension]; ALL_TAC]] THEN + SUBGOAL_THEN `ring_carrier(l:A ring) <_c (:A)` ASSUME_TAC THENL + [MP_TAC(ISPECL + [`I:A->A`; `k:A ring`; `l:A ring`; + `(ring_carrier k:A->bool) CROSS (:num)`] + CARD_LE_ALGEBRAIC_EXTENSION) THEN + ASM_REWRITE_TAC[INFINITE; FINITE_CROSS_EQ; UNIV_NOT_EMPTY] THEN + ANTS_TAC THENL [REWRITE_TAC[REWRITE_RULE[INFINITE] num_INFINITE; + RING_CARRIER_NONEMPTY] THEN + TRANS_TAC CARD_LE_TRANS `(ring_carrier k:A->bool) *_c {0}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC CARD_EQ_IMP_LE THEN MESON_TAC[CARD_EQ_SYM; CARD_MUL_RID]; + REWRITE_TAC[CROSS; GSYM mul_c] THEN MATCH_MP_TAC CARD_LE_MUL THEN + REWRITE_TAC[CARD_LE_UNIV; CARD_LE_REFL]]; + MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ_ALT] CARD_LET_TRANS) THEN + REWRITE_TAC[CROSS; GSYM mul_c] THEN + MATCH_MP_TAC CARD_MUL_LT_INFINITE THEN ASM_REWRITE_TAC[] THEN + ASM_SIMP_TAC[INFINITE_CARD_LE; CARD_LT_IMP_LE]]; ALL_TAC] THEN + X_GEN_TAC `p:(1->num)->A` THEN STRIP_TAC THEN + MATCH_MP_TAC(TAUT `(~p ==> F) ==> p`) THEN DISCH_TAC THEN + MP_TAC(ISPECL [`l:A ring`; `p:(1->num)->A`] + KRONECKER_SIMPLE_FIELD_EXTENSION) THEN + ANTS_TAC THENL [ASM_MESON_TAC[field_extension]; ALL_TAC] THEN + REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN MAP_EVERY X_GEN_TAC + [`m:(((1->num)->A)->bool)ring`; `h:A->((1->num)->A)->bool`; + `z:((1->num)->A)->bool`] THEN STRIP_TAC THEN + FIRST_ASSUM(STRIP_ASSUME_TAC o GEN_REWRITE_RULE I [field_extension]) THEN + FIRST_ASSUM(ASSUME_TAC o MATCH_MP RING_MONOMORPHISM_IMP_HOMOMORPHISM) THEN + MP_TAC(ISPECL + [`h:A->((1->num)->A)->bool`; `l:A ring`; `m:(((1->num)->A)->bool)ring`; + `z:((1->num)->A)->bool`] FINITE_SIMPLE_ALGEBRAIC_EXTENSION) THEN + ASM_REWRITE_TAC[NOT_IMP] THEN CONJ_TAC THENL + [ASM_REWRITE_TAC[algebraic_over] THEN EXISTS_TAC `p:(1->num)->A` THEN + ASM_SIMP_TAC[POLY_EXTEND_EVALUATE; GSYM poly_eval] THEN + ASM_MESON_TAC[POLY_DEG_0; POLY_RING]; DISCH_TAC] THEN SUBGOAL_THEN + `?h':(((1->num)->A)->bool)->A. + (!x y. x IN ring_carrier m /\ y IN ring_carrier m /\ h' x = h' y + ==> x = y) /\ + (!x. x IN ring_carrier l ==> h'(h x) = x)` STRIP_ASSUME_TAC THENL + [SUBGOAL_THEN + `ring_carrier(m:(((1->num)->A)->bool)ring) <=_c (:A) DIFF ring_carrier l` + MP_TAC THENL + [W(MP_TAC o PART_MATCH (lhand o rand) CARD_DIFF_ABSORB o rand o snd) THEN + ASM_SIMP_TAC[INFINITE_CARD_LE; CARD_LT_IMP_LE] THEN + GEN_REWRITE_TAC LAND_CONV [CARD_EQ_SYM] THEN + DISCH_THEN(MP_TAC o MATCH_MP CARD_EQ_IMP_LE) THEN + MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ] CARD_LE_TRANS) THEN MP_TAC(ISPECL + [`(h:A->((1->num)->A)->bool) o (I:A->A)`; + `k:A ring`; `m:(((1->num)->A)->bool)ring`; `(:A)`] + CARD_LE_ALGEBRAIC_EXTENSION) THEN DISCH_THEN MATCH_MP_TAC THEN + ASM_SIMP_TAC[INFINITE_CARD_LE; CARD_LT_IMP_LE] THEN + MATCH_MP_TAC ALGEBRAIC_EXTENSION_TRANS THEN + ASM_MESON_TAC[FINITE_IMP_ALGEBRAIC_EXTENSION]; + REWRITE_TAC[le_c; LEFT_IMP_EXISTS_THM]] THEN + X_GEN_TAC `h'':(((1->num)->A)->bool)->A` THEN + REWRITE_TAC[IN_DIFF; INJECTIVE_ON_ALT] THEN STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o CONJUNCT2 o + GEN_REWRITE_RULE I [ring_monomorphism]) THEN + REWRITE_TAC[INJECTIVE_ON_LEFT_INVERSE] THEN + DISCH_THEN(X_CHOOSE_TAC `h':(((1->num)->A)->bool)->A`) THEN EXISTS_TAC + `\x. if x IN IMAGE (h:A->((1->num)->A)->bool) (ring_carrier l) + then (h':(((1->num)->A)->bool)->A) x else h'' x` THEN + SIMP_TAC[] THEN REPEAT STRIP_TAC THEN TRY EQ_TAC THEN SIMP_TAC[] THEN + RULE_ASSUM_TAC(REWRITE_RULE[ring_homomorphism]) THEN ASM SET_TAC[]; + FIRST_X_ASSUM(MP_TAC o MATCH_MP ISOMORPHIC_TRANSPORT_OF_RING)] THEN + DISCH_THEN(X_CHOOSE_TAC `n:A ring`) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `n:A ring`) THEN + ASM_REWRITE_TAC[NOT_IMP] THEN CONJ_TAC THENL + [SUBGOAL_THEN `algebraic_extension(l,n) (I:A->A)` MP_TAC THENL + [MATCH_MP_TAC ALGEBRAIC_EXTENSION_EQ THEN EXISTS_TAC + `(h':(((1->num)->A)->bool)->A) o (h:A->((1->num)->A)->bool)` THEN + ASM_SIMP_TAC[o_THM; I_THM] THEN + MATCH_MP_TAC ALGEBRAIC_EXTENSION_TRANS THEN + EXISTS_TAC `m:(((1->num)->A)->bool)ring` THEN + ASM_SIMP_TAC[FINITE_IMP_ALGEBRAIC_EXTENSION; + ALGEBRAIC_EXTENSION_ISOMORPHISM]; + ASM_MESON_TAC[I_O_ID; algebraic_extension; ALGEBRAIC_EXTENSION_TRANS]]; + ALL_TAC] THEN + DISCH_THEN(MP_TAC o MATCH_MP FIELD_EXTENSION_IMP_SUBSET) THEN + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; I_THM] THEN + DISCH_THEN(MP_TAC o SPEC `(h':(((1->num)->A)->bool)->A) z`) THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE RAND_CONV [IN_IMAGE]) THEN + REWRITE_TAC[NOT_EXISTS_THM] THEN + DISCH_THEN(MP_TAC o SPEC`(h':(((1->num)->A)->bool)->A) z`) THEN + RULE_ASSUM_TAC(REWRITE_RULE + [field_extension; finite_extension; RING_ISOMORPHISM; + ring_monomorphism; IMAGE_I; ring_homomorphism]) THEN ASM SET_TAC[]);; + +let ALGEBRAIC_CLOSURE_EXISTS = prove + (`!k:A ring. + INFINITE(:B) /\ ring_carrier k <=_c (:B) /\ field k + ==> ?l (f:A->B). algebraic_extension (k,l) f /\ + algebraically_closed_field l`, + REPEAT STRIP_TAC THEN + SUBGOAL_THEN `(:A) <_c (:A#num->bool) /\ (:num) <_c (:A#num->bool)` + STRIP_ASSUME_TAC THENL [CONJ_TAC THEN + TRANS_TAC CARD_LET_TRANS `(:A#num)` THEN + REWRITE_TAC[CANTOR_THM_UNIV] THENL + [TRANS_TAC CARD_LE_TRANS `(:A) *_c {one}`; + TRANS_TAC CARD_LE_TRANS `{one} *_c (:num)`] THEN + SIMP_TAC[GSYM MUL_C_UNIV; CARD_LE_MUL; CARD_SING_LE; UNIV_NOT_EMPTY; + CARD_LE_REFL] THEN + MATCH_MP_TAC CARD_EQ_IMP_LE THEN ONCE_REWRITE_TAC[CARD_EQ_SYM] THEN + REWRITE_TAC[CARD_MUL_LID; CARD_MUL_RID]; ALL_TAC] THEN + MP_TAC(ISPECL [`k:A ring`; `(:A#num->bool)`] ISOMORPHIC_SUBCOPY_OF_RING) THEN + ANTS_TAC THENL [TRANS_TAC CARD_LE_TRANS `(:A)` THEN + ASM_SIMP_TAC[CARD_LE_SUBSET; CARD_LT_IMP_LE; SUBSET_UNIV]; + REWRITE_TAC[SUBSET_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `k':(A#num->bool)ring` STRIP_ASSUME_TAC)] THEN + FIRST_ASSUM(MP_TAC o MATCH_MP ISOMORPHIC_RING_FIELDNESS) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + MP_TAC(ISPEC `k':(A#num->bool)ring` ALGEBRAIC_CLOSURE_EXISTS_ID) THEN + ASM_REWRITE_TAC[] THEN ANTS_TAC THENL + [TRANS_TAC CARD_LET_TRANS `(:A)` THEN ASM_REWRITE_TAC[] THEN + TRANS_TAC CARD_LE_TRANS `ring_carrier(k:A ring)` THEN + ASM_SIMP_TAC[CARD_LE_SUBSET; SUBSET_UNIV] THEN + MATCH_MP_TAC CARD_EQ_IMP_LE THEN ONCE_REWRITE_TAC[CARD_EQ_SYM] THEN + MATCH_MP_TAC ISOMORPHIC_RING_CARD_EQ THEN ASM_REWRITE_TAC[]; + DISCH_THEN(X_CHOOSE_THEN `l':(A#num->bool)ring` + (STRIP_ASSUME_TAC o REWRITE_RULE[algebraically_closed_field]))] THEN + MP_TAC(ISPECL [`l':(A#num->bool)ring`; `(:B)`] + ISOMORPHIC_SUBCOPY_OF_RING) THEN + REWRITE_TAC[SUBSET_UNIV] THEN ANTS_TAC THENL + [MP_TAC(ISPECL [`I:(A#num->bool)->(A#num->bool)`; + `k':(A#num->bool)ring`; `l':(A#num->bool)ring`; `(:B)`] + CARD_LE_ALGEBRAIC_EXTENSION) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN MATCH_MP_TAC THEN + TRANS_TAC CARD_LE_TRANS `ring_carrier(k:A ring)` THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CARD_EQ_IMP_LE THEN ONCE_REWRITE_TAC[CARD_EQ_SYM] THEN + MATCH_MP_TAC ISOMORPHIC_RING_CARD_EQ THEN ASM_REWRITE_TAC[]; + MATCH_MP_TAC MONO_EXISTS] THEN X_GEN_TAC `l:B ring` THEN DISCH_TAC THEN + SUBGOAL_THEN `field(l:B ring)` ASSUME_TAC THENL + [ASM_MESON_TAC[ALGEBRAIC_EXTENSION; field_extension; + ISOMORPHIC_RING_FIELDNESS]; ALL_TAC] THEN + FIRST_ASSUM(X_CHOOSE_TAC `f:A->A#num->bool` o + GEN_REWRITE_RULE I [isomorphic_ring]) THEN + FIRST_ASSUM(X_CHOOSE_TAC `g:(A#num->bool)->B` o + GEN_REWRITE_RULE I [isomorphic_ring]) THEN + EXISTS_TAC `(g:(A#num->bool)->B) o (f:A->A#num->bool)` THEN CONJ_TAC THENL + [MATCH_MP_TAC ALGEBRAIC_EXTENSION_TRANS THEN + EXISTS_TAC `l':(A#num->bool)ring` THEN + ASM_SIMP_TAC[ALGEBRAIC_EXTENSION_ISOMORPHISM] THEN + GEN_REWRITE_TAC RAND_CONV [SYM(CONJUNCT1(SPEC_ALL I_O_ID))] THEN + MATCH_MP_TAC ALGEBRAIC_EXTENSION_TRANS THEN + EXISTS_TAC `k':(A#num->bool)ring` THEN + ASM_SIMP_TAC[ALGEBRAIC_EXTENSION_ISOMORPHISM]; + ASM_REWRITE_TAC[algebraically_closed_field] THEN + FIRST_ASSUM(X_CHOOSE_THEN `g':B->A#num->bool` MP_TAC o + GEN_REWRITE_RULE I [ring_isomorphism]) THEN + REWRITE_TAC[RING_ISOMORPHISMS_ISOMORPHISM] THEN STRIP_TAC THEN + X_GEN_TAC `p:(1->num)->B` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `(g':B->A#num->bool) o (p:(1->num)->B)`) THEN + MP_TAC(ISPECL + [`l:B ring`; `l':(A#num->bool)ring`; `g':B->A#num->bool`; `(:1)`] + IN_RING_POLYNOMIAL_CARRIER_COMPOSE) THEN + ASM_SIMP_TAC[RING_ISOMORPHISM_IMP_HOMOMORPHISM] THEN + DISCH_THEN(K ALL_TAC) THEN MP_TAC(ISPECL + [`l:B ring`; `l':(A#num->bool)ring`; `g':B->A#num->bool`; + `p:(1->num)->B`] + POLY_DEG_MONOMORPHIC_IMAGE) THEN + ASM_SIMP_TAC[RING_ISOMORPHISM_IMP_MONOMORPHISM; RING_POLYNOMIAL] THEN + DISCH_THEN(K ALL_TAC) THEN + DISCH_THEN(X_CHOOSE_THEN `w:A#num->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(g:(A#num->bool)->B) w` THEN + MATCH_MP_TAC(TAUT `p /\ (p ==> q) ==> p /\ q`) THEN CONJ_TAC THENL + [RULE_ASSUM_TAC(REWRITE_RULE[RING_ISOMORPHISM]) THEN ASM SET_TAC[]; + DISCH_TAC] THEN FIRST_X_ASSUM(MP_TAC o AP_TERM `g:(A#num->bool)->B`) THEN + MATCH_MP_TAC EQ_IMP THEN BINOP_TAC THENL + [ALL_TAC; ASM_MESON_TAC[RING_ISOMORPHISM; RING_HOMOMORPHISM_0]] THEN + MP_TAC(ISPECL [`l':(A#num->bool)ring`; `l:B ring`; `w:A#num->bool`; + `g:(A#num->bool)->B`; `(g':B->A#num->bool) o (p:(1->num)->B)`] + POLY_EVAL_HOMOMORPHIC_IMAGE) THEN MP_TAC(ISPECL + [`l:B ring`; `l':(A#num->bool)ring`; `g':B->A#num->bool`; `(:1)`] + IN_RING_POLYNOMIAL_CARRIER_COMPOSE) THEN + ASM_SIMP_TAC[RING_ISOMORPHISM_IMP_HOMOMORPHISM] THEN + DISCH_THEN(K ALL_TAC) THEN DISCH_THEN SUBST1_TAC THEN + AP_THM_TAC THEN AP_TERM_TAC THEN REWRITE_TAC[FUN_EQ_THM; o_THM] THEN + RULE_ASSUM_TAC(REWRITE_RULE + [POLY_RING; IN_ELIM_THM; ring_polynomial; ring_powerseries]) THEN + ASM_SIMP_TAC[]]);; + +let ALGEBRAIC_CLOSURE_UNIQUE_EXPLICIT = prove + (`!(k:A ring) (l:B ring) (l':C ring) (f:A->B) (g:A->C). + algebraic_extension(k,l) f /\ algebraically_closed_field l /\ + algebraic_extension(k,l') g /\ algebraically_closed_field l' + ==> ?h. ring_isomorphism(l,l') h /\ + (!x. x IN ring_carrier k ==> h(f x) = g x)`, + REPEAT STRIP_TAC THEN SUBGOAL_THEN `field (l:B ring) /\ field (l':C ring) /\ + ring_homomorphism(k:A ring,l':C ring) g /\ + field_extension(k:A ring,l:B ring) f` STRIP_ASSUME_TAC THENL + [REPEAT CONJ_TAC THEN ASM_MESON_TAC[ALGEBRAICALLY_CLOSED_FIELD_IMP_FIELD; + algebraic_extension; field_extension; ring_monomorphism]; ALL_TAC] THEN + MP_TAC(ISPECL [`k:A ring`; `l:B ring`; `l':C ring`; `f:A->B`; `g:A->C`] + ALGEBRAIC_CLOSURE_EXTEND_HOMOMORPHISM) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `h:B->C` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `h:B->C` THEN CONJ_TAC THENL [ALL_TAC; ASM_REWRITE_TAC[]] THEN + SUBGOAL_THEN `ring_monomorphism(l:B ring,l':C ring) (h:B->C)` ASSUME_TAC + THENL + [MATCH_MP_TAC FIELD_RING_HOMOMORPHISM_MONOMORPHISM THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[FIELD_IMP_NONTRIVIAL_RING]; + ALL_TAC] THEN + SUBGOAL_THEN `field_extension(l:B ring,l':C ring) (h:B->C)` ASSUME_TAC THENL + [ASM_REWRITE_TAC[field_extension]; ALL_TAC] THEN + MATCH_MP_TAC ALGEBRAICALLY_CLOSED_FIELD_NO_PROPER_ALGEBRAIC_EXTENSION THEN + ASM_REWRITE_TAC[algebraic_extension] THEN X_GEN_TAC `x:C` THEN DISCH_TAC THEN + MP_TAC(ISPECL [`f:A->B`; `h:B->C`; `k:A ring`; `l:B ring`; `l':C ring`; + `x:C`] ALGEBRAIC_OVER_ALGEBRAIC_EXTENSION) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(SUBST1_TAC o SYM) THEN + MATCH_MP_TAC(ISPECL [`k:A ring`; `l':C ring`; `x:C`; + `g:A->C`; `((h:B->C) o (f:A->B)):A->C`] ALGEBRAIC_OVER_EQ) THEN + ASM_REWRITE_TAC[o_THM] THEN ASM_MESON_TAC[algebraic_extension]);; + +let ALGEBRAIC_CLOSURE_UNIQUE = prove + (`!(k:A ring) (l:B ring) (l':C ring) (f:A->B) (g:A->C). + algebraic_extension(k,l) f /\ algebraically_closed_field l /\ + algebraic_extension(k,l') g /\ algebraically_closed_field l' + ==> l isomorphic_ring l'`, + REWRITE_TAC[isomorphic_ring] THEN + MESON_TAC[ALGEBRAIC_CLOSURE_UNIQUE_EXPLICIT]);; diff --git a/Library/grouptheory.ml b/Library/grouptheory.ml index c4647f03..30d5f81b 100644 --- a/Library/grouptheory.ml +++ b/Library/grouptheory.ml @@ -1017,7 +1017,7 @@ let GROUP_RULE = then (GROUP_ROTATE_CONV 1 THENC GROUP_EQ_HYPERNORM_CONV) tm else REFL tm in fun tm -> - let gvs = setify(find_terms (is_groupty o type_of) tm) in + let gvs = setify Term.(<=) (find_terms (is_groupty o type_of) tm) in if gvs = [] then MESON[] tm else if length gvs > 1 then failwith "GROUP_RULE: Several groups involved" else let g = hd gvs in @@ -1055,7 +1055,7 @@ let GROUP_RULE = DISCH asm (itlist PROVE_HYP (CONJUNCTS(ASSUME asm)) th2) in let th4 = GENL avs th3 in let bvs = frees(concl th4) in - GENL (sort (<) bvs) th4;; + GENL (sort Term.(<) bvs) th4;; let GROUP_TAC = REPEAT GEN_TAC THEN diff --git a/Library/pocklington.ml b/Library/pocklington.ml index 38c40ff9..bbe48ace 100755 --- a/Library/pocklington.ml +++ b/Library/pocklington.ml @@ -2443,7 +2443,7 @@ let certify_prime = general_certify_prime multifactor;; (* HOL checking of primality certificate, using Pocklington shortcut. *) (* ------------------------------------------------------------------------- *) -let prime_theorem_cache = ref [];; +let prime_theorem_cache = ref ([]: (num * thm) list);; let rec lookup_under_num n l = if l = [] then failwith "lookup_under_num" else diff --git a/Library/rabin_test.ml b/Library/rabin_test.ml new file mode 100644 index 00000000..1199fc5d --- /dev/null +++ b/Library/rabin_test.ml @@ -0,0 +1,1644 @@ +(* ======================================================================== *) +(* Rabin's test for irreducibility of polynomials over finite fields. *) +(* *) +(* All development (statements and proof) written by Claude Code, Opus 4.6 *) +(* ======================================================================== *) + +needs "Library/fieldtheory.ml";; + +(* ------------------------------------------------------------------------- *) +(* General lemmas. *) +(* ------------------------------------------------------------------------- *) + +(* Iteration lemma: if p | (x^m - x) in a ring, then p | (x^(m^k) - x) *) +let RING_DIVIDES_POW_ITERATE = prove + (`!r (p:A) x m k. + integral_domain r /\ + p IN ring_carrier r /\ x IN ring_carrier r /\ + ring_divides r p (ring_sub r (ring_pow r x m) x) /\ ~(k = 0) /\ + 1 <= m + ==> ring_divides r p (ring_sub r (ring_pow r x (m EXP k)) x)`, + GEN_TAC THEN GEN_TAC THEN GEN_TAC THEN GEN_TAC THEN + INDUCT_TAC THENL + [MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[NOT_SUC] THEN + DISCH_TAC THEN + ASM_CASES_TAC `k = 0` THENL + [ASM_REWRITE_TAC[EXP; EXP_1; MULT_CLAUSES]; + ALL_TAC] THEN + (* k != 0 case: use IH then telescope *) + SUBGOAL_THEN `ring_divides r (p:A) (ring_sub r (ring_pow r x (m EXP k)) x)` + ASSUME_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `ring_pow r (x:A) (m EXP k) IN ring_carrier r` + ASSUME_TAC THENL + [MATCH_MP_TAC RING_POW THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* x^(m^(SUC k)) = (x^(m^k))^m *) + SUBGOAL_THEN `ring_pow r (x:A) (m EXP (SUC k)) = + ring_pow r (ring_pow r x (m EXP k)) m` + SUBST1_TAC THENL + [REWRITE_TAC[EXP] THEN ONCE_REWRITE_TAC[MULT_SYM] THEN + ASM_SIMP_TAC[RING_POW_POW]; ALL_TAC] THEN + (* Telescope: (x^(m^k))^m - x = ((x^(m^k))^m - x^m) + (x^m - x) *) + SUBGOAL_THEN + `ring_sub r (ring_pow r (ring_pow r (x:A) (m EXP k)) m) x = + ring_add r + (ring_sub r (ring_pow r (ring_pow r x (m EXP k)) m) (ring_pow r x m)) + (ring_sub r (ring_pow r x m) x)` SUBST1_TAC THENL + [MATCH_MP_TAC(GSYM RING_SUB_TELESCOPE) THEN ASM_SIMP_TAC[RING_POW]; ALL_TAC] THEN + MATCH_MP_TAC RING_DIVIDES_ADD THEN CONJ_TAC THENL + [(* p | ((x^(m^k))^m - x^m): by p | (x^(m^k) - x) | ((x^(m^k))^m - x^m) *) + MATCH_MP_TAC RING_DIVIDES_TRANS THEN + EXISTS_TAC `ring_sub r (ring_pow r (x:A) (m EXP k)) x` THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC RING_DIVIDES_SUB_POW THEN + ASM_REWRITE_TAC[] THEN ASM_ARITH_TAC; + (* p | (x^m - x): direct hypothesis *) + ASM_REWRITE_TAC[]]);; + +(* Helper: non-unit non-zero polynomial over a field has degree >= 1 *) +let POLY_NONUNIT_DEGREE_GE_1 = prove + (`!f:A ring p (s:V->bool). + field f /\ + p IN ring_carrier(poly_ring f s) /\ + ~(p = ring_0(poly_ring f s)) /\ + ~(ring_unit (poly_ring f s) p) + ==> 1 <= poly_deg f p`, + REWRITE_TAC[IN_POLY_RING_CARRIER; ARITH_RULE `1 <= d <=> ~(d = 0)`] THEN + SIMP_TAC[POLY_DEG_EQ_0] THEN + MESON_TAC[RING_UNIT_POLY_CONST; FIELD_UNIT; POLY_CONST_0; POLY_RING]);; + +(* Helper: if p | (u - x) and p | (u^m - x) and m >= 1, then p | (x^m - x) *) +let RING_DIVIDES_REDUCE = prove + (`!r (p:A) u x m. + p IN ring_carrier r /\ u IN ring_carrier r /\ x IN ring_carrier r /\ + ring_divides r p (ring_sub r u x) /\ + ring_divides r p (ring_sub r (ring_pow r u m) x) /\ ~(m = 0) + ==> ring_divides r p (ring_sub r (ring_pow r x m) x)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Step 1: p | (u^m - x^m) via (u-x) | (u^m - x^m) *) + SUBGOAL_THEN `ring_divides r (p:A) + (ring_sub r (ring_pow r u m) (ring_pow r x m))` ASSUME_TAC THENL + [MATCH_MP_TAC RING_DIVIDES_TRANS THEN + EXISTS_TAC `ring_sub r (u:A) x` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC RING_DIVIDES_SUB_POW THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Step 2: p | (u^m - x) - (u^m - x^m) by RING_DIVIDES_SUB *) + SUBGOAL_THEN `ring_divides r (p:A) + (ring_sub r (ring_sub r (ring_pow r u m) x) + (ring_sub r (ring_pow r u m) (ring_pow r x m)))` MP_TAC THENL + [MATCH_MP_TAC RING_DIVIDES_SUB THEN + ASM_SIMP_TAC[RING_POW; RING_SUB]; + ALL_TAC] THEN + (* Step 3: (u^m - x) - (u^m - x^m) = x^m - x *) + SUBGOAL_THEN + `ring_sub r (ring_sub r (ring_pow r (u:A) m) x) + (ring_sub r (ring_pow r u m) (ring_pow r x m)) = + ring_sub r (ring_pow r x m) x` + (fun th -> REWRITE_TAC[th]) THEN + ASM_SIMP_TAC[RING_POW; RING_RULE + `ring_sub r (ring_sub r (a:A) b) (ring_sub r a c) = ring_sub r c b`]);; + +(* ------------------------------------------------------------------------- *) +(* Finite field Fermat / Frobenius *) +(* ------------------------------------------------------------------------- *) + +(* Product of nonzero elements is invariant under multiplication by nonzero x *) +let FIELD_NONZERO_PRODUCT_PERMUTE = prove + (`!f:A ring x. + field f /\ FINITE(ring_carrier f) /\ + x IN ring_carrier f /\ ~(x = ring_0 f) + ==> ring_product f (ring_carrier f DELETE ring_0 f) (\y. ring_mul f x y) = + ring_product f (ring_carrier f DELETE ring_0 f) (\y. y)`, + REPEAT STRIP_TAC THEN + MATCH_MP_TAC RING_PRODUCT_EQ_GENERAL_INVERSES THEN + EXISTS_TAC `\y:A. ring_mul f x y` THEN + EXISTS_TAC `\y:A. ring_mul f (ring_inv f x) y` THEN + SUBGOAL_THEN `ring_inv f (x:A) IN ring_carrier f /\ + ~(ring_inv f x = ring_0 f)` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[RING_INV; FIELD_UNIT; RING_UNIT_INV]; ALL_TAC] THEN + REWRITE_TAC[] THEN + CONJ_TAC THEN X_GEN_TAC `y:A` THEN REWRITE_TAC[IN_DELETE] THEN + STRIP_TAC THEN REPEAT CONJ_TAC THENL + [(* ring_mul f (inv x) y IN carrier *) + ASM_MESON_TAC[RING_MUL]; + (* ~(ring_mul f (inv x) y = 0) *) + ASM_SIMP_TAC[FIELD_MUL_EQ_0]; + (* ring_mul f x (ring_mul f (inv x) y) = y *) + ASM_SIMP_TAC[RING_MUL_ASSOC; FIELD_MUL_RINV; RING_MUL_LID]; + (* ring_mul f x y IN carrier *) + ASM_MESON_TAC[RING_MUL]; + (* ~(ring_mul f x y = 0) *) + ASM_SIMP_TAC[FIELD_MUL_EQ_0]; + (* ring_mul f (inv x) (ring_mul f x y) = y *) + ASM_SIMP_TAC[RING_MUL_ASSOC; FIELD_MUL_LINV; RING_MUL_LID]]);; + +(* Every element of a finite field satisfies x^q = x where q = CARD(carrier) *) +let FINITE_FIELD_ELEMENT_POW = prove + (`!f:A ring. + field f /\ FINITE(ring_carrier f) + ==> !x. x IN ring_carrier f + ==> ring_pow f x (CARD(ring_carrier f)) = x`, + REPEAT STRIP_TAC THEN + (* Case x = 0: x^q = 0 = x *) + ASM_CASES_TAC `x:A = ring_0 f` THENL + [ASM_SIMP_TAC[RING_POW_ZERO] THEN + COND_CASES_TAC THENL + [ASM_MESON_TAC[CARD_EQ_0; RING_CARRIER_NONEMPTY]; REFL_TAC]; + ALL_TAC] THEN + (* Rewrite q = (q-1) + 1, split x^q = x^(q-1) * x *) + SUBGOAL_THEN `CARD(ring_carrier(f:A ring)) = + (CARD(ring_carrier f) - 1) + 1` SUBST1_TAC THENL + [MATCH_MP_TAC(ARITH_RULE `~(n = 0) ==> n = (n - 1) + 1`) THEN + ASM_MESON_TAC[CARD_EQ_0; RING_CARRIER_NONEMPTY]; + ALL_TAC] THEN + ASM_SIMP_TAC[RING_POW_ADD; RING_POW] THEN + REWRITE_TAC[ring_pow; RING_MUL_RID] THEN + (* Reduce to showing x^(q-1) = 1 *) + SUBGOAL_THEN `ring_pow f x (CARD(ring_carrier(f:A ring)) - 1) = ring_1 f` + (fun th -> ASM_SIMP_TAC[th; RING_MUL_RID; RING_MUL_LID; + RING_POW_1; RING_POW]) THEN + (* Set up s = carrier \ {0} *) + ABBREV_TAC `s = ring_carrier f DELETE (ring_0 (f:A ring))` THEN + SUBGOAL_THEN `FINITE (s:A->bool)` ASSUME_TAC THENL + [EXPAND_TAC "s" THEN ASM_SIMP_TAC[FINITE_DELETE]; ALL_TAC] THEN + SUBGOAL_THEN `CARD(s:A->bool) = CARD(ring_carrier(f:A ring)) - 1` + ASSUME_TAC THENL + [EXPAND_TAC "s" THEN ASM_SIMP_TAC[CARD_DELETE; RING_0]; ALL_TAC] THEN + SUBGOAL_THEN `(x:A) IN s` ASSUME_TAC THENL + [EXPAND_TAC "s" THEN ASM_REWRITE_TAC[IN_DELETE]; ALL_TAC] THEN + SUBGOAL_THEN `!y:A. y IN s ==> y IN ring_carrier f /\ ~(y = ring_0 f)` + ASSUME_TAC THENL + [EXPAND_TAC "s" THEN SIMP_TAC[IN_DELETE]; ALL_TAC] THEN + (* Product P of all nonzero elements is nonzero *) + SUBGOAL_THEN `~(ring_product f s (\y:A. y) = ring_0 f)` ASSUME_TAC THENL + [ASM_SIMP_TAC[INTEGRAL_DOMAIN_PRODUCT_EQ_0; FIELD_IMP_INTEGRAL_DOMAIN] THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Product permutation: product of (x*y) = product of y *) + SUBGOAL_THEN + `ring_product f s (\y:A. ring_mul f x y) = + ring_product f s (\y:A. y)` ASSUME_TAC THENL + [EXPAND_TAC "s" THEN MATCH_MP_TAC FIELD_NONZERO_PRODUCT_PERMUTE THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* By RING_PRODUCT_LMUL: product of (x*y) = x^|s| * product of y *) + SUBGOAL_THEN + `ring_product f s (\y:A. ring_mul f x y) = + ring_mul f (ring_pow f x (CARD(s:A->bool))) + (ring_product f s (\y:A. y))` ASSUME_TAC THENL + [MATCH_MP_TAC RING_PRODUCT_LMUL THEN ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Cancel: x^|s| = 1 (using x^|s| * P = P from previous equalities) *) + SUBGOAL_THEN `ring_pow f x (CARD(s:A->bool)) = ring_1 (f:A ring)` + (fun th -> ASM_MESON_TAC[th]) THEN + MP_TAC (ISPECL [`f:A ring`; + `ring_product f s (\y:A. y)`; + `ring_pow f (x:A) (CARD(s:A->bool))`; + `ring_1 (f:A ring)`] + INTEGRAL_DOMAIN_MUL_RCANCEL) THEN + ASM_SIMP_TAC[FIELD_IMP_INTEGRAL_DOMAIN; RING_POW; RING_1; + RING_MUL_LID; RING_PRODUCT] THEN + ASM_MESON_TAC[]);; + +(* Helper: The quotient F[x]/(p) for irreducible p of degree d over a + finite field F with q elements is a finite field with q^d elements *) +let QUOTIENT_POLY_RING_FINITE_CARD = prove + (`!f:A ring p. + field f /\ FINITE(ring_carrier f) /\ + p IN ring_carrier(poly_ring f (:1)) /\ + ring_irreducible (poly_ring f (:1)) p + ==> field(quotient_ring (poly_ring f (:1)) + (ideal_generated (poly_ring f (:1)) {p})) /\ + FINITE(ring_carrier(quotient_ring (poly_ring f (:1)) + (ideal_generated (poly_ring f (:1)) {p}))) /\ + CARD(ring_carrier(quotient_ring (poly_ring f (:1)) + (ideal_generated (poly_ring f (:1)) {p}))) = + CARD(ring_carrier f) EXP (poly_deg f p)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + ABBREV_TAC `R = poly_ring (f:A ring) (:1)` THEN + ABBREV_TAC `J = ideal_generated R {p:(1->num)->A}` THEN + ABBREV_TAC `K = quotient_ring R (J:((1->num)->A)->bool)` THEN + ABBREV_TAC `h:A->((1->num)->A)->bool = + ring_coset R J o poly_const (f:A ring)` THEN + ABBREV_TAC `a:((1->num)->A)->bool = + ring_coset R J (poly_var (f:A ring) one)` THEN + SUBGOAL_THEN `PID (R:((1->num)->A)ring)` ASSUME_TAC THENL + [EXPAND_TAC "R" THEN ASM_MESON_TAC[PID_POLY_RING]; + ALL_TAC] THEN + SUBGOAL_THEN `maximal_ideal R (J:((1->num)->A)->bool) /\ + ring_ideal R (J:((1->num)->A)->bool)` STRIP_ASSUME_TAC THENL + [EXPAND_TAC "J" THEN + ASM_MESON_TAC[RING_IRREDUCIBLE_EQ_MAXIMAL_IDEAL; MAXIMAL_IMP_RING_IDEAL]; + ALL_TAC] THEN + (* field K *) + SUBGOAL_THEN `field (K:(((1->num)->A)->bool)ring)` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN ASM_MESON_TAC[FIELD_QUOTIENT_RING]; ALL_TAC] THEN + (* field_extension(f, K) h - expand all abbrevs for KRONECKER *) + SUBGOAL_THEN `field_extension + (f:A ring, K:(((1->num)->A)->bool)ring) + (h:A->((1->num)->A)->bool)` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN EXPAND_TAC "h" THEN EXPAND_TAC "J" THEN + EXPAND_TAC "R" THEN + MATCH_MP_TAC KRONECKER_FIELD_EXTENSION THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + (* ring_homomorphism(R, K)(ring_coset R J) *) + SUBGOAL_THEN `ring_homomorphism + (R:((1->num)->A)ring, K:(((1->num)->A)->bool)ring) + (ring_coset R (J:((1->num)->A)->bool))` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN ASM_MESON_TAC[RING_HOMOMORPHISM_RING_COSET]; + ALL_TAC] THEN + (* ring_homomorphism(f, K) h *) + SUBGOAL_THEN `ring_homomorphism + (f:A ring, K:(((1->num)->A)->bool)ring) + (h:A->((1->num)->A)->bool)` ASSUME_TAC THENL + [ASM_MESON_TAC[field_extension; RING_MONOMORPHISM_IMP_HOMOMORPHISM]; + ALL_TAC] THEN + (* a IN carrier K *) + SUBGOAL_THEN `(a:((1->num)->A)->bool) IN ring_carrier K` ASSUME_TAC THENL + [SUBGOAL_THEN `poly_var (f:A ring) one IN ring_carrier R` ASSUME_TAC THENL + [EXPAND_TAC "R" THEN REWRITE_TAC[POLY_VAR_UNIV]; ALL_TAC] THEN + ASM_MESON_TAC[ring_homomorphism; IN_IMAGE; SUBSET]; + ALL_TAC] THEN + (* poly_extend = ring_coset R J on carrier R *) + SUBGOAL_THEN + `!g. g IN ring_carrier R + ==> poly_extend (f:A ring,K:(((1->num)->A)->bool)ring) + h (\v:1. a) g = + ring_coset R (J:((1->num)->A)->bool) g` ASSUME_TAC THENL + [X_GEN_TAC `g:(1->num)->A` THEN DISCH_TAC THEN + MP_TAC(ISPECL [`f:A ring`; `K:(((1->num)->A)->bool)ring`; + `(:1)`; `h:A->((1->num)->A)->bool`; + `(\v:1. a:((1->num)->A)->bool)`; + `ring_coset R (J:((1->num)->A)->bool)`; + `g:(1->num)->A`] POLY_EXTEND_UNIQUE) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN MATCH_MP_TAC THEN + CONJ_TAC THENL + [X_GEN_TAC `c:A` THEN DISCH_TAC THEN EXPAND_TAC "h" THEN + REWRITE_TAC[o_THM]; + X_GEN_TAC `i:1` THEN REWRITE_TAC[IN_UNIV] THEN + SUBGOAL_THEN `i:1 = one` SUBST1_TAC THENL + [MESON_TAC[one]; ALL_TAC] THEN + EXPAND_TAC "a" THEN REFL_TAC]; + ALL_TAC] THEN + (* p IN J *) + SUBGOAL_THEN `p:(1->num)->A IN J` ASSUME_TAC THENL + [EXPAND_TAC "J" THEN REWRITE_TAC[IN_IDEAL_GENERATED_SELF] THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* ring_coset R J p = ring_0 K *) + SUBGOAL_THEN + `ring_coset R (J:((1->num)->A)->bool) (p:(1->num)->A) = + ring_0 (K:(((1->num)->A)->bool)ring)` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN ASM_SIMP_TAC[QUOTIENT_RING_0] THEN + ASM_MESON_TAC[RING_COSET_EQ_IDEAL]; + ALL_TAC] THEN + (* algebraic_over *) + SUBGOAL_THEN + `algebraic_over (f:A ring,K:(((1->num)->A)->bool)ring) + (h:A->((1->num)->A)->bool) (a:((1->num)->A)->bool)` ASSUME_TAC THENL + [REWRITE_TAC[algebraic_over] THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + EXISTS_TAC `p:(1->num)->A` THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL + [ASM_MESON_TAC[ring_irreducible; POLY_RING_CLAUSES]; ALL_TAC] THEN + SUBGOAL_THEN + `poly_extend (f:A ring,K:(((1->num)->A)->bool)ring) + h (\v:1. a) p = ring_coset R (J:((1->num)->A)->bool) p` + SUBST1_TAC THENL + [ASM_SIMP_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* subring_generated K (...) = K *) + SUBGOAL_THEN + `subring_generated K + ((a:((1->num)->A)->bool) INSERT + IMAGE (h:A->((1->num)->A)->bool) (ring_carrier f)) = K` + ASSUME_TAC THENL + [REWRITE_TAC[SUBRING_GENERATED_SUPERSET] THEN + MP_TAC(ISPECL [`h:A->((1->num)->A)->bool`; `f:A ring`; + `K:(((1->num)->A)->bool)ring`; + `a:((1->num)->A)->bool`] + IMAGE_POLY_EXTEND_1) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(fun th -> REWRITE_TAC[GSYM th]) THEN + (* Goal: ring_carrier K ⊆ IMAGE (poly_extend ...) (ring_carrier R) *) + SUBGOAL_THEN + `ring_carrier(K:(((1->num)->A)->bool)ring) = + {ring_coset R (J:((1->num)->A)->bool) x |x| x IN ring_carrier R}` + SUBST1_TAC THENL + [EXPAND_TAC "K" THEN ASM_SIMP_TAC[QUOTIENT_RING_CARRIER]; ALL_TAC] THEN + REWRITE_TAC[SUBSET; FORALL_IN_GSPEC; IN_IMAGE] THEN + X_GEN_TAC `g:(1->num)->A` THEN DISCH_TAC THEN + EXISTS_TAC `g:(1->num)->A` THEN ASM_SIMP_TAC[]; + ALL_TAC] THEN + (* finite_extension(f, K) h *) + SUBGOAL_THEN `finite_extension + (f:A ring, K:(((1->num)->A)->bool)ring) + (h:A->((1->num)->A)->bool)` ASSUME_TAC THENL + [MP_TAC(ISPECL [`h:A->((1->num)->A)->bool`; + `f:A ring`; `K:(((1->num)->A)->bool)ring`; + `a:((1->num)->A)->bool`] + FINITE_SIMPLE_ALGEBRAIC_EXTENSION) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Extract basis *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [FINITE_EXTENSION_BASIS]) THEN + DISCH_THEN(CONJUNCTS_THEN2 (fun _ -> ALL_TAC) + (X_CHOOSE_THEN `b:(((1->num)->A)->bool)->bool` STRIP_ASSUME_TAC)) THEN + (* field K already proved *) + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* FINITE + CARD *) + MP_TAC(ISPECL [`h:A->((1->num)->A)->bool`; + `f:A ring`; `K:(((1->num)->A)->bool)ring`; + `b:(((1->num)->A)->bool)->bool`] + HAS_SIZE_FINITE_EXTENSION) THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[HAS_SIZE] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (fun th -> REWRITE_TAC[th])) THEN + ASM_REWRITE_TAC[] THEN + (* Need: CARD(ring_carrier f) EXP CARD b = ... EXP poly_deg f p *) + (* Suffices to show CARD b = poly_deg f p *) + SUBGOAL_THEN `CARD (b:(((1->num)->A)->bool)->bool) = + poly_deg (f:A ring) (p:(1->num)->A)` + (fun th -> REWRITE_TAC[th]) THEN + ABBREV_TAC `d = poly_deg (f:A ring) (p:(1->num)->A)` THEN + REWRITE_TAC[GSYM LE_ANTISYM] THEN CONJ_TAC THENL + [(* Upper bound: CARD b <= d *) + (* Establish key facts *) + SUBGOAL_THEN `~(p:(1->num)->A = ring_0 R)` ASSUME_TAC THENL + [ASM_MESON_TAC[ring_irreducible]; ALL_TAC] THEN + SUBGOAL_THEN `poly_extend (f:A ring,K:(((1->num)->A)->bool)ring) + h (\v:1. a) p = ring_0 K` ASSUME_TAC THENL + [SUBGOAL_THEN `poly_extend (f:A ring,K:(((1->num)->A)->bool)ring) + h (\v:1. a) (p:(1->num)->A) = ring_coset R J p` SUBST1_TAC THENL + [ASM_SIMP_TAC[]; ALL_TAC] THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Upper bound: CARD b <= d *) + (* Extract ring_independent and b SUBSET from ring_basis *) + SUBGOAL_THEN `ring_independent (f:A ring,K:(((1->num)->A)->bool)ring) + (h:A->((1->num)->A)->bool) (b:(((1->num)->A)->bool)->bool)` + ASSUME_TAC THENL + [ASM_MESON_TAC[ring_basis]; ALL_TAC] THEN + SUBGOAL_THEN `(b:(((1->num)->A)->bool)->bool) SUBSET + ring_carrier (K:(((1->num)->A)->bool)ring)` ASSUME_TAC THENL + [ASM_MESON_TAC[ring_independent]; ALL_TAC] THEN + (* Powers {a^n | n < d} span K *) + MP_TAC(ISPECL [`h:A->((1->num)->A)->bool`; `f:A ring`; + `K:(((1->num)->A)->bool)ring`; `p:(1->num)->A`; + `a:((1->num)->A)->bool`] RING_SIMPLE_ALGEBRAIC_EXTENSION_SPAN) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + (* Apply RING_INDEPENDENT_LE_SPAN *) + MP_TAC(ISPECL [`h:A->((1->num)->A)->bool`; `f:A ring`; + `K:(((1->num)->A)->bool)ring`; + `b:(((1->num)->A)->bool)->bool`; + `{ring_pow (K:(((1->num)->A)->bool)ring) + (a:((1->num)->A)->bool) n | n < d}`] + RING_INDEPENDENT_LE_SPAN) THEN + ANTS_TAC THENL + [CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL + [(* t SUBSET ring_carrier K *) + REWRITE_TAC[SUBSET; FORALL_IN_GSPEC] THEN + X_GEN_TAC `n:num` THEN DISCH_TAC THEN + MATCH_MP_TAC RING_POW THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + CONJ_TAC THENL + [(* FINITE t *) + ONCE_REWRITE_TAC[SIMPLE_IMAGE_GEN] THEN + MATCH_MP_TAC FINITE_IMAGE THEN REWRITE_TAC[FINITE_NUMSEG_LT]; + ALL_TAC] THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* b SUBSET ring_span(f,K) h {ring_pow K a n | n < d} *) + SUBGOAL_THEN `ring_span (f:A ring,K:(((1->num)->A)->bool)ring) + (h:A->((1->num)->A)->bool) + {ring_pow K (a:((1->num)->A)->bool) n | n < d} = + ring_carrier (K:(((1->num)->A)->bool)ring)` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* FINITE b /\ CARD b <= CARD {ring_pow K a n | n < d} *) + DISCH_THEN(fun th -> MP_TAC(CONJUNCT2 th)) THEN + MATCH_MP_TAC(ARITH_RULE `b <= c ==> a <= b ==> a <= c`) THEN + ONCE_REWRITE_TAC[SIMPLE_IMAGE_GEN] THEN + TRANS_TAC LE_TRANS `CARD {n:num | n < d}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC CARD_IMAGE_LE THEN REWRITE_TAC[FINITE_NUMSEG_LT]; + REWRITE_TAC[CARD_NUMSEG_LT; LE_REFL]]; + (* Lower bound: d <= CARD b *) + SUBGOAL_THEN `ring_span (f:A ring,K:(((1->num)->A)->bool)ring) + (h:A->((1->num)->A)->bool) (b:(((1->num)->A)->bool)->bool) = + ring_carrier K` ASSUME_TAC THENL + [ASM_MESON_TAC[ring_basis; ring_spanning]; ALL_TAC] THEN + SUBGOAL_THEN `(b:(((1->num)->A)->bool)->bool) SUBSET + ring_carrier (K:(((1->num)->A)->bool)ring)` ASSUME_TAC THENL + [ASM_MESON_TAC[ring_basis; ring_independent]; ALL_TAC] THEN + MP_TAC(ISPECL [`h:A->((1->num)->A)->bool`; `f:A ring`; + `K:(((1->num)->A)->bool)ring`; + `a:((1->num)->A)->bool`; + `b:(((1->num)->A)->bool)->bool`; + `CARD (b:(((1->num)->A)->bool)->bool)`] + FINITE_IMP_ALGEBRAIC_EXTENSION_EXPLICIT) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[HAS_SIZE; SUBSET_REFL]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `q:(1->num)->A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(q:(1->num)->A) IN ring_carrier R` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `ring_coset R (J:((1->num)->A)->bool) (q:(1->num)->A) = + ring_0 (K:(((1->num)->A)->bool)ring)` ASSUME_TAC THENL + [FIRST_X_ASSUM(fun th -> MP_TAC(SPEC `q:(1->num)->A` th)) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN(SUBST1_TAC o SYM) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `(q:(1->num)->A) IN J` ASSUME_TAC THENL + [SUBGOAL_THEN `ring_kernel(R,K) (ring_coset R (J:((1->num)->A)->bool)) = J` + (SUBST1_TAC o SYM) THENL + [EXPAND_TAC "K" THEN ASM_MESON_TAC[RING_KERNEL_RING_COSET]; ALL_TAC] THEN + REWRITE_TAC[ring_kernel; IN_ELIM_THM] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `ring_divides R (p:(1->num)->A) q` ASSUME_TAC THENL + [MP_TAC(ISPECL [`R:((1->num)->A)ring`; `p:(1->num)->A`; + `q:(1->num)->A`] IN_IDEAL_GENERATED_SING_EQ) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(fun th -> ASM_REWRITE_TAC[GSYM th]); + ALL_TAC] THEN + TRANS_TAC LE_TRANS `poly_deg (f:A ring) (q:(1->num)->A)` THEN + CONJ_TAC THENL + [EXPAND_TAC "d" THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [ring_divides]) THEN + EXPAND_TAC "R" THEN + REWRITE_TAC[POLY_RING_CLAUSES; SUBSET_UNIV; IN_ELIM_THM] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `s:(1->num)->A` STRIP_ASSUME_TAC))) THEN + (* poly_deg f q = poly_deg f p + poly_deg f s *) + SUBGOAL_THEN `poly_deg (f:A ring) (q:(1->num)->A) = + poly_deg f (p:(1->num)->A) + poly_deg f (s:(1->num)->A)` MP_TAC THENL + [SUBGOAL_THEN `(q:(1->num)->A) = poly_mul (f:A ring) p s` + SUBST1_TAC THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC POLY_DEG_MUL THEN + ASM_SIMP_TAC[FIELD_IMP_INTEGRAL_DOMAIN] THEN + (* Remaining: p = poly_0 f <=> s = poly_0 f; both sides false *) + SUBGOAL_THEN `poly_0 (f:A ring) = ring_0 (R:((1->num)->A)ring)` + (fun th -> REWRITE_TAC[th]) THENL + [EXPAND_TAC "R" THEN REWRITE_TAC[POLY_RING_CLAUSES]; ALL_TAC] THEN + (* Goal: p = ring_0 R <=> s = ring_0 R *) + MATCH_MP_TAC(TAUT `~p /\ ~q ==> (p <=> q)`) THEN + FIRST_X_ASSUM(STRIP_ASSUME_TAC o + GEN_REWRITE_RULE I [ring_irreducible]) THEN + CONJ_TAC THENL + [ASM_REWRITE_TAC[]; + (* ~(s = ring_0 R): if s = 0 then q = p*0 = 0, contradicting q <> 0 *) + DISCH_TAC THEN + SUBGOAL_THEN `ring_mul (R:((1->num)->A)ring) (p:(1->num)->A) + (ring_0 R) = ring_0 R` ASSUME_TAC THENL + [MATCH_MP_TAC RING_MUL_RZERO THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `poly_mul (f:A ring) (p:(1->num)->A) + (ring_0 (R:((1->num)->A)ring)) = + ring_mul R p (ring_0 R)` ASSUME_TAC THENL + [EXPAND_TAC "R" THEN REWRITE_TAC[POLY_RING_CLAUSES]; ALL_TAC] THEN + ASM_MESON_TAC[]]; + ALL_TAC] THEN + EXPAND_TAC "d" THEN ARITH_TAC; + ASM_REWRITE_TAC[]]]);; + +(* Generalized: irreducible p with deg(p) | n implies p | x^(q^n) - x *) +let IRREDUCIBLE_DIVIDES_XQ_MINUS_X_GEN = prove + (`!f:A ring p n. + field f /\ FINITE(ring_carrier f) /\ + p IN ring_carrier(poly_ring f (:1)) /\ + ring_irreducible (poly_ring f (:1)) p /\ + (poly_deg f p) divides n + ==> ring_divides (poly_ring f (:1)) p + (ring_sub (poly_ring f (:1)) + (ring_pow (poly_ring f (:1)) (poly_var f one) + (CARD(ring_carrier f) EXP n)) + (poly_var f one))`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + ABBREV_TAC `R = poly_ring (f:A ring) (:1)` THEN + ABBREV_TAC `J = ideal_generated R {p:(1->num)->A}` THEN + ABBREV_TAC `K = quotient_ring R (J:((1->num)->A)->bool)` THEN + (* Step 1: J is maximal, hence a ring ideal *) + SUBGOAL_THEN `PID (R:((1->num)->A)ring)` ASSUME_TAC THENL + [EXPAND_TAC "R" THEN ASM_MESON_TAC[PID_POLY_RING]; + ALL_TAC] THEN + SUBGOAL_THEN `maximal_ideal R (J:((1->num)->A)->bool) /\ + ring_ideal R (J:((1->num)->A)->bool)` STRIP_ASSUME_TAC THENL + [EXPAND_TAC "J" THEN + ASM_MESON_TAC[RING_IRREDUCIBLE_EQ_MAXIMAL_IDEAL; MAXIMAL_IMP_RING_IDEAL]; + ALL_TAC] THEN + (* Step 2: K is a finite field with q^d elements *) + SUBGOAL_THEN + `field (K:(((1->num)->A)->bool) ring) /\ + FINITE(ring_carrier K) /\ + CARD(ring_carrier K) = + CARD(ring_carrier(f:A ring)) EXP (poly_deg f (p:(1->num)->A))` + STRIP_ASSUME_TAC THENL + [MP_TAC(ISPECL [`f:A ring`; `p:(1->num)->A`] QUOTIENT_POLY_RING_FINITE_CARD) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Step 3: ring_coset R J is a ring homomorphism R -> K *) + SUBGOAL_THEN `ring_homomorphism(R,K) + (ring_coset R (J:((1->num)->A)->bool))` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN ASM_MESON_TAC[RING_HOMOMORPHISM_RING_COSET]; + ALL_TAC] THEN + (* Step 4: poly_var f one IN carrier R *) + SUBGOAL_THEN `poly_var f one IN ring_carrier(R:((1->num)->A)ring)` + ASSUME_TAC THENL + [EXPAND_TAC "R" THEN REWRITE_TAC[POLY_VAR_UNIV]; ALL_TAC] THEN + (* Step 5: proj(x) IN carrier K *) + SUBGOAL_THEN + `ring_coset R (J:((1->num)->A)->bool) + (poly_var (f:A ring) one) IN ring_carrier K` ASSUME_TAC THENL + [ASM_MESON_TAC[ring_homomorphism; IN_IMAGE; SUBSET]; ALL_TAC] THEN + (* Step 6: proj(x)^(q^d) = proj(x) by FINITE_FIELD_ELEMENT_POW *) + SUBGOAL_THEN + `ring_pow K + (ring_coset R (J:((1->num)->A)->bool) (poly_var (f:A ring) one)) + (CARD(ring_carrier(f:A ring)) EXP + (poly_deg f (p:(1->num)->A))) = + ring_coset R J (poly_var f one)` ASSUME_TAC THENL + [SUBGOAL_THEN + `CARD(ring_carrier(f:A ring)) EXP (poly_deg f (p:(1->num)->A)) = + CARD(ring_carrier(K:(((1->num)->A)->bool) ring))` + SUBST1_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + MP_TAC(ISPEC `K:(((1->num)->A)->bool) ring` FINITE_FIELD_ELEMENT_POW) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC + `ring_coset R (J:((1->num)->A)->bool) (poly_var (f:A ring) one)`) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Step 7: proj(x^(q^d) - x) = 0 *) + SUBGOAL_THEN + `ring_coset R (J:((1->num)->A)->bool) + (ring_sub R + (ring_pow R (poly_var f one) + (CARD(ring_carrier(f:A ring)) EXP + (poly_deg f (p:(1->num)->A)))) + (poly_var f one)) = + ring_0 (K:(((1->num)->A)->bool) ring)` ASSUME_TAC THENL + [(* proj(a - b) = proj(a) - proj(b) *) + FIRST_ASSUM(fun hom -> + MP_TAC(MATCH_MP RING_HOMOMORPHISM_SUB hom)) THEN + DISCH_THEN(fun th -> + MP_TAC(SPECL [`ring_pow R (poly_var f one) + (CARD(ring_carrier(f:A ring)) EXP + (poly_deg f (p:(1->num)->A)))`; + `poly_var (f:A ring) one`] th)) THEN + ASM_SIMP_TAC[RING_POW] THEN DISCH_THEN SUBST1_TAC THEN + (* proj(x^n) = proj(x)^n *) + FIRST_ASSUM(fun hom -> + MP_TAC(MATCH_MP RING_HOMOMORPHISM_POW hom)) THEN + DISCH_THEN(fun th -> + MP_TAC(SPECL [`poly_var (f:A ring) one`; + `CARD(ring_carrier(f:A ring)) EXP + (poly_deg f (p:(1->num)->A))`] th)) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN SUBST1_TAC THEN + (* Now: ring_sub K (ring_pow K proj(x) (q^d)) proj(x) = ring_0 K *) + (* Use proj(x)^(|K|) = proj(x) and |K| = q^d *) + ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[RING_SUB_REFL]; + ALL_TAC] THEN + (* Step 8: x^(q^d) - x IN J (kernel of proj = J) *) + SUBGOAL_THEN + `ring_sub R + (ring_pow R (poly_var f one) + (CARD(ring_carrier(f:A ring)) EXP + (poly_deg f (p:(1->num)->A)))) + (poly_var (f:A ring) one) IN J` + ASSUME_TAC THENL + [SUBGOAL_THEN + `ring_kernel(R,K) (ring_coset R (J:((1->num)->A)->bool)) = J` + (SUBST1_TAC o SYM) THENL + [EXPAND_TAC "K" THEN ASM_MESON_TAC[RING_KERNEL_RING_COSET]; + ALL_TAC] THEN + REWRITE_TAC[ring_kernel; IN_ELIM_THM] THEN + CONJ_TAC THENL + [ASM_MESON_TAC[RING_SUB; RING_POW]; + ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + (* Step 9: p | x^(q^d) - x from membership in ideal_generated R {p} *) + SUBGOAL_THEN + `ring_divides R (p:(1->num)->A) + (ring_sub R + (ring_pow R (poly_var f one) + (CARD(ring_carrier(f:A ring)) EXP + (poly_deg f (p:(1->num)->A)))) + (poly_var f one))` ASSUME_TAC THENL + [MP_TAC(ISPECL [`R:((1->num)->A)ring`; `p:(1->num)->A`; + `ring_sub R + (ring_pow R (poly_var f one) + (CARD(ring_carrier(f:A ring)) EXP + (poly_deg f (p:(1->num)->A)))) + (poly_var (f:A ring) one)`] + IN_IDEAL_GENERATED_SING_EQ) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(fun th -> REWRITE_TAC[GSYM th]) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Step 10: Iterate for d | n *) + (* From d divides n, extract k with n = d * k *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [divides]) THEN + DISCH_THEN(X_CHOOSE_TAC `k:num`) THEN + ASM_CASES_TAC `k = 0` THENL + [(* k = 0 case: n = 0, x^(q^0) - x = x - x = 0, p | 0 *) + SUBGOAL_THEN `n = 0` SUBST_ALL_TAC THENL + [ASM_REWRITE_TAC[MULT_CLAUSES]; ALL_TAC] THEN + REWRITE_TAC[EXP] THEN + SUBGOAL_THEN + `ring_sub R + (ring_pow R (poly_var (f:A ring) one) 1) + (poly_var f one) = ring_0 R` + SUBST1_TAC THENL + [ASM_SIMP_TAC[RING_POW_1] THEN + ASM_MESON_TAC[RING_SUB_REFL]; + ALL_TAC] THEN + REWRITE_TAC[RING_DIVIDES_0] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + (* k > 0 case: use RING_DIVIDES_POW_ITERATE *) + SUBGOAL_THEN + `CARD(ring_carrier(f:A ring)) EXP n = + (CARD(ring_carrier f) EXP (poly_deg f (p:(1->num)->A))) EXP k` + SUBST1_TAC THENL + [REWRITE_TAC[EXP_EXP] THEN AP_TERM_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + MP_TAC(ISPECL + [`R:((1->num)->A)ring`; + `p:(1->num)->A`; + `poly_var (f:A ring) one`; + `CARD(ring_carrier(f:A ring)) EXP poly_deg f (p:(1->num)->A)`; + `k:num`] RING_DIVIDES_POW_ITERATE) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN MATCH_MP_TAC THEN + ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL + [ASM_MESON_TAC[FIELD_IMP_INTEGRAL_DOMAIN; INTEGRAL_DOMAIN_POLY_RING]; + ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + (* 1 <= q^d: field has >= 2 elements, so q >= 2, d >= 1, q^d >= 2 *) + SUBGOAL_THEN `2 <= CARD(ring_carrier(f:A ring))` ASSUME_TAC THENL + [SUBGOAL_THEN `~(ring_1 (f:A ring) = ring_0 f)` ASSUME_TAC THENL + [MP_TAC(ISPEC `f:A ring` FIELD_NONTRIVIAL) THEN + ASM_REWRITE_TAC[TRIVIAL_RING_10]; ALL_TAC] THEN + MP_TAC(ISPECL [`{ring_0 f, ring_1 (f:A ring)}`; `ring_carrier(f:A ring)`] + CARD_SUBSET) THEN + ASM_REWRITE_TAC[FINITE_INSERT; FINITE_EMPTY; + INSERT_SUBSET; EMPTY_SUBSET; RING_0; RING_1] THEN + SIMP_TAC[CARD_CLAUSES; FINITE_INSERT; FINITE_EMPTY; + IN_INSERT; NOT_IN_EMPTY] THEN + ASM_REWRITE_TAC[] THEN ARITH_TAC; + ALL_TAC] THEN + REWRITE_TAC[ARITH_RULE `1 <= n <=> ~(n = 0)`; EXP_EQ_0] THEN + ASM_ARITH_TAC);; + +(* Special case: p | x^(q^(deg p)) - x *) +let IRREDUCIBLE_DIVIDES_XQ_MINUS_X = prove + (`!f:A ring p. + field f /\ FINITE(ring_carrier f) /\ + p IN ring_carrier(poly_ring f (:1)) /\ + ring_irreducible (poly_ring f (:1)) p + ==> ring_divides (poly_ring f (:1)) p + (ring_sub (poly_ring f (:1)) + (ring_pow (poly_ring f (:1)) (poly_var f one) + (CARD(ring_carrier f) EXP (poly_deg f p))) + (poly_var f one))`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPECL [`f:A ring`; `p:(1->num)->A`; `poly_deg f (p:(1->num)->A)`] + IRREDUCIBLE_DIVIDES_XQ_MINUS_X_GEN) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN MATCH_MP_TAC THEN + MESON_TAC[divides; MULT_CLAUSES]);; + +(* Helper: x^(q^r) = x for elements of GF(q), for any r *) +let FINITE_FIELD_POW_ITERATE = prove + (`!f:A ring x r. field f /\ FINITE(ring_carrier f) /\ x IN ring_carrier f + ==> ring_pow f x (CARD(ring_carrier f) EXP r) = x`, + GEN_TAC THEN GEN_TAC THEN INDUCT_TAC THENL + [SIMP_TAC[EXP; RING_POW_1]; + STRIP_TAC THEN REWRITE_TAC[EXP] THEN + ASM_SIMP_TAC[RING_POW_MUL; FINITE_FIELD_ELEMENT_POW] THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]]);; + +(* Helper: iterated Frobenius x -> x^(p^k) is a ring endomorphism *) +let RING_ENDOMORPHISM_FROBENIUS_ITERATE = prove + (`!r:A ring k. prime(ring_char r) + ==> ring_endomorphism r (\x. ring_pow r x (ring_char r EXP k))`, + GEN_TAC THEN INDUCT_TAC THENL + [(* k = 0: x^1 = identity *) + DISCH_TAC THEN REWRITE_TAC[EXP] THEN + MP_TAC(ISPECL [`r:A ring`; `\x:A. x`; + `\x:A. ring_pow r x 1`] RING_ENDOMORPHISM_EQ) THEN + SIMP_TAC[ring_endomorphism; RING_HOMOMORPHISM_ID; RING_POW_1]; + (* k = SUC k: compose Frobenius with iterate *) + DISCH_TAC THEN + SUBGOAL_THEN + `ring_endomorphism (r:A ring) + ((\x. ring_pow r x (ring_char r)) o + (\x. ring_pow r x (ring_char r EXP k)))` + ASSUME_TAC THENL + [REWRITE_TAC[ring_endomorphism] THEN + MATCH_MP_TAC RING_HOMOMORPHISM_COMPOSE THEN + EXISTS_TAC `r:A ring` THEN + REWRITE_TAC[GSYM ring_endomorphism] THEN + CONJ_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + ASM_SIMP_TAC[RING_ENDOMORPHISM_FROBENIUS]]; + ALL_TAC] THEN + MP_TAC(ISPECL [`r:A ring`; + `(\x:A. ring_pow r x (ring_char r)) o + (\x. ring_pow r x (ring_char r EXP k))`; + `\x:A. ring_pow r x (ring_char r EXP (SUC k))`] + RING_ENDOMORPHISM_EQ) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN MATCH_MP_TAC THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + REWRITE_TAC[o_THM; EXP] THEN + ONCE_REWRITE_TAC[MULT_SYM] THEN + ASM_SIMP_TAC[RING_POW_POW]]);; + +(* Helper: in a field, if every element satisfies x^n = x, then |field| <= n *) +let FIELD_ROOTS_BOUND = prove + (`!r:A ring n. + field r /\ FINITE(ring_carrier r) /\ 2 <= n /\ + (!a. a IN ring_carrier r ==> ring_pow r a n = a) + ==> CARD(ring_carrier r) <= n`, + REPEAT STRIP_TAC THEN + SUBGOAL_THEN `~(ring_1 r:A = ring_0 r)` ASSUME_TAC THENL + [ASM_MESON_TAC[FIELD_NONTRIVIAL; TRIVIAL_RING_10]; ALL_TAC] THEN + ABBREV_TAC `P = poly_ring (r:A ring) (:1)` THEN + ABBREV_TAC `g = ring_sub P + (ring_pow P (poly_var r one) n) + (poly_var (r:A ring) one)` THEN + SUBGOAL_THEN `(g:(1->num)->A) IN ring_carrier P` ASSUME_TAC THENL + [EXPAND_TAC "g" THEN EXPAND_TAC "P" THEN + SIMP_TAC[RING_SUB; RING_POW; POLY_VAR_UNIV]; + ALL_TAC] THEN + SUBGOAL_THEN `~(g:(1->num)->A = ring_0 P)` ASSUME_TAC THENL + [DISCH_TAC THEN + SUBGOAL_THEN `ring_pow P (poly_var r one:(1->num)->A) n = + poly_var r one` MP_TAC THENL + [SUBGOAL_THEN `ring_sub P (ring_pow P (poly_var r one:(1->num)->A) n) + (poly_var r one) = ring_0 P` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + EXPAND_TAC "P" THEN + SIMP_TAC[RING_SUB_EQ_0; RING_POW; POLY_VAR_UNIV]; ALL_TAC] THEN + DISCH_THEN(MP_TAC o AP_TERM `poly_deg (r:A ring):((1->num)->A)->num`) THEN + EXPAND_TAC "P" THEN REWRITE_TAC[POLY_DEG_VAR_POW; POLY_DEG_VAR] THEN + ASM_REWRITE_TAC[] THEN ASM_ARITH_TAC; + ALL_TAC] THEN + SUBGOAL_THEN `poly_deg r (g:(1->num)->A) <= n` ASSUME_TAC THENL + [EXPAND_TAC "g" THEN EXPAND_TAC "P" THEN + MP_TAC(ISPECL [`r:A ring`; `ring_pow (poly_ring r (:1)) + (poly_var r one:(1->num)->A) n`; `poly_var (r:A ring) one`] + POLY_DEG_SUB_LE) THEN + ANTS_TAC THENL + [REWRITE_TAC[POLY_RING_CLAUSES; RING_POLYNOMIAL_VAR; IN_UNIV] THEN + MATCH_MP_TAC RING_POLYNOMIAL_POW THEN + REWRITE_TAC[RING_POLYNOMIAL_VAR; IN_UNIV]; ALL_TAC] THEN + REWRITE_TAC[POLY_RING_CLAUSES; POLY_DEG_VAR_POW; POLY_DEG_VAR] THEN + ASM_REWRITE_TAC[] THEN ASM_ARITH_TAC; + ALL_TAC] THEN + (* Every element of r is a root of g *) + SUBGOAL_THEN `ring_carrier r SUBSET + {x:A | x IN ring_carrier r /\ poly_eval r g x = ring_0 r}` + ASSUME_TAC THENL + [REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN X_GEN_TAC `a:A` THEN + DISCH_TAC THEN ASM_REWRITE_TAC[] THEN + EXPAND_TAC "g" THEN EXPAND_TAC "P" THEN + REWRITE_TAC[POLY_RING_CLAUSES] THEN + ASM_SIMP_TAC[POLY_EVAL_SUB; RING_POLYNOMIAL_VAR; IN_UNIV; + RING_POLYNOMIAL_POW; POLY_EVAL_POW; POLY_EVAL_VAR] THEN + ASM_SIMP_TAC[RING_SUB_EQ_0; RING_POW]; + ALL_TAC] THEN + (* POLY_ROOT_BOUND gives finite roots and CARD bound *) + MP_TAC(ISPECL [`r:A ring`; `g:(1->num)->A`] POLY_ROOT_BOUND) THEN + ANTS_TAC THENL + [ASM_SIMP_TAC[FIELD_IMP_INTEGRAL_DOMAIN] THEN + EXPAND_TAC "P" THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + STRIP_TAC THEN + MP_TAC(ISPECL [`ring_carrier r:A->bool`; + `{x:A | x IN ring_carrier r /\ poly_eval r g x = ring_0 r}`] + CARD_SUBSET) THEN + ASM_REWRITE_TAC[] THEN ASM_ARITH_TAC);; + +(* Helper: irreducible p of degree d divides a^(q^d) - a for ANY polynomial a *) +let IRRED_DIVIDES_POLY_EVAL_MINUS = prove + (`!f:A ring p a. + field f /\ FINITE(ring_carrier f) /\ + p IN ring_carrier(poly_ring f (:1)) /\ + ring_irreducible (poly_ring f (:1)) p /\ + a IN ring_carrier(poly_ring f (:1)) + ==> ring_divides (poly_ring f (:1)) p + (ring_sub (poly_ring f (:1)) + (ring_pow (poly_ring f (:1)) a + (CARD(ring_carrier f) EXP (poly_deg f p))) + a)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + ABBREV_TAC `R = poly_ring (f:A ring) (:1)` THEN + ABBREV_TAC `J = ideal_generated R {p:(1->num)->A}` THEN + ABBREV_TAC `K = quotient_ring R (J:((1->num)->A)->bool)` THEN + SUBGOAL_THEN `PID (R:((1->num)->A)ring)` ASSUME_TAC THENL + [EXPAND_TAC "R" THEN ASM_MESON_TAC[PID_POLY_RING]; + ALL_TAC] THEN + SUBGOAL_THEN `maximal_ideal R (J:((1->num)->A)->bool) /\ + ring_ideal R (J:((1->num)->A)->bool)` STRIP_ASSUME_TAC THENL + [EXPAND_TAC "J" THEN + ASM_MESON_TAC[RING_IRREDUCIBLE_EQ_MAXIMAL_IDEAL; MAXIMAL_IMP_RING_IDEAL]; + ALL_TAC] THEN + SUBGOAL_THEN + `field (K:(((1->num)->A)->bool) ring) /\ + FINITE(ring_carrier K) /\ + CARD(ring_carrier K) = + CARD(ring_carrier(f:A ring)) EXP (poly_deg f (p:(1->num)->A))` + STRIP_ASSUME_TAC THENL + [MP_TAC(ISPECL [`f:A ring`; `p:(1->num)->A`] QUOTIENT_POLY_RING_FINITE_CARD) + THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `ring_homomorphism(R,K) + (ring_coset R (J:((1->num)->A)->bool))` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN ASM_MESON_TAC[RING_HOMOMORPHISM_RING_COSET]; + ALL_TAC] THEN + (* proj(a) IN carrier K *) + SUBGOAL_THEN + `ring_coset R (J:((1->num)->A)->bool) (a:(1->num)->A) IN ring_carrier K` + ASSUME_TAC THENL + [ASM_MESON_TAC[ring_homomorphism; IN_IMAGE; SUBSET]; ALL_TAC] THEN + (* proj(a)^(q^d) = proj(a) by FINITE_FIELD_ELEMENT_POW *) + SUBGOAL_THEN + `ring_pow K + (ring_coset R (J:((1->num)->A)->bool) (a:(1->num)->A)) + (CARD(ring_carrier(f:A ring)) EXP (poly_deg f (p:(1->num)->A))) = + ring_coset R J a` ASSUME_TAC THENL + [SUBGOAL_THEN + `CARD(ring_carrier(f:A ring)) EXP (poly_deg f (p:(1->num)->A)) = + CARD(ring_carrier(K:(((1->num)->A)->bool) ring))` + SUBST1_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + MP_TAC(ISPEC `K:(((1->num)->A)->bool) ring` FINITE_FIELD_ELEMENT_POW) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* proj(a^(q^d) - a) = 0 *) + SUBGOAL_THEN + `ring_coset R (J:((1->num)->A)->bool) + (ring_sub R + (ring_pow R (a:(1->num)->A) + (CARD(ring_carrier(f:A ring)) EXP + (poly_deg f (p:(1->num)->A)))) + a) = + ring_0 (K:(((1->num)->A)->bool) ring)` ASSUME_TAC THENL + [FIRST_ASSUM(fun hom -> MP_TAC(MATCH_MP RING_HOMOMORPHISM_SUB hom)) THEN + DISCH_THEN(fun th -> + MP_TAC(SPECL [`ring_pow R (a:(1->num)->A) + (CARD(ring_carrier(f:A ring)) EXP + (poly_deg f (p:(1->num)->A)))`; + `a:(1->num)->A`] th)) THEN + ASM_SIMP_TAC[RING_POW] THEN DISCH_THEN SUBST1_TAC THEN + FIRST_ASSUM(fun hom -> MP_TAC(MATCH_MP RING_HOMOMORPHISM_POW hom)) THEN + DISCH_THEN(fun th -> + MP_TAC(SPECL [`a:(1->num)->A`; + `CARD(ring_carrier(f:A ring)) EXP + (poly_deg f (p:(1->num)->A))`] th)) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN SUBST1_TAC THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[RING_SUB_REFL]; + ALL_TAC] THEN + (* a^(q^d) - a IN J (kernel of proj) *) + SUBGOAL_THEN + `ring_sub R + (ring_pow R (a:(1->num)->A) + (CARD(ring_carrier(f:A ring)) EXP + (poly_deg f (p:(1->num)->A)))) + a IN J` + ASSUME_TAC THENL + [SUBGOAL_THEN + `ring_kernel(R,K) (ring_coset R (J:((1->num)->A)->bool)) = J` + (SUBST1_TAC o SYM) THENL + [EXPAND_TAC "K" THEN ASM_MESON_TAC[RING_KERNEL_RING_COSET]; ALL_TAC] THEN + REWRITE_TAC[ring_kernel; IN_ELIM_THM] THEN + ASM_MESON_TAC[RING_SUB; RING_POW]; + ALL_TAC] THEN + (* p | a^(q^d) - a from ideal membership *) + MP_TAC(ISPECL [`R:((1->num)->A)ring`; `p:(1->num)->A`; + `ring_sub R + (ring_pow R (a:(1->num)->A) + (CARD(ring_carrier(f:A ring)) EXP + (poly_deg f (p:(1->num)->A)))) + a`] + IN_IDEAL_GENERATED_SING_EQ) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(fun th -> REWRITE_TAC[GSYM th]) THEN + ASM_REWRITE_TAC[]);; + +(* Degree bound: if p | x^(q^n) - x with n >= 1, then deg(p) <= n *) +let IRREDUCIBLE_DIVIDES_DEGREE_BOUND = prove + (`!f:A ring p n. + field f /\ FINITE(ring_carrier f) /\ + p IN ring_carrier(poly_ring f (:1)) /\ + ring_irreducible (poly_ring f (:1)) p /\ + ring_divides (poly_ring f (:1)) p + (ring_sub (poly_ring f (:1)) + (ring_pow (poly_ring f (:1)) (poly_var f one) + (CARD(ring_carrier f) EXP n)) + (poly_var f one)) /\ + 1 <= n + ==> poly_deg f p <= n`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + ABBREV_TAC `R = poly_ring (f:A ring) (:1)` THEN + ABBREV_TAC `q = CARD(ring_carrier(f:A ring))` THEN + ABBREV_TAC `d = poly_deg f (p:(1->num)->A)` THEN + ABBREV_TAC `J = ideal_generated R {p:(1->num)->A}` THEN + ABBREV_TAC `K = quotient_ring R (J:((1->num)->A)->bool)` THEN + (* Setup: K is finite field, |K| = q^d *) + SUBGOAL_THEN `PID (R:((1->num)->A)ring)` ASSUME_TAC THENL + [EXPAND_TAC "R" THEN ASM_MESON_TAC[PID_POLY_RING]; + ALL_TAC] THEN + SUBGOAL_THEN `maximal_ideal R (J:((1->num)->A)->bool) /\ + ring_ideal R (J:((1->num)->A)->bool)` STRIP_ASSUME_TAC THENL + [EXPAND_TAC "J" THEN + ASM_MESON_TAC[RING_IRREDUCIBLE_EQ_MAXIMAL_IDEAL; MAXIMAL_IMP_RING_IDEAL]; + ALL_TAC] THEN + SUBGOAL_THEN + `field (K:(((1->num)->A)->bool) ring) /\ + FINITE(ring_carrier K) /\ + CARD(ring_carrier K) = + CARD(ring_carrier(f:A ring)) EXP (poly_deg f (p:(1->num)->A))` + STRIP_ASSUME_TAC THENL + [MP_TAC(ISPECL [`f:A ring`; `p:(1->num)->A`] QUOTIENT_POLY_RING_FINITE_CARD) + THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `CARD(ring_carrier(K:(((1->num)->A)->bool) ring)) = q EXP d` + ASSUME_TAC THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* ring_char f is prime *) + SUBGOAL_THEN `prime(ring_char(f:A ring))` ASSUME_TAC THENL + [MATCH_MP_TAC FINITE_INTEGRAL_DOMAIN_CHAR THEN + ASM_SIMP_TAC[FIELD_IMP_INTEGRAL_DOMAIN]; + ALL_TAC] THEN + (* ring_char K = ring_char f *) + SUBGOAL_THEN `ring_homomorphism(R,K) + (ring_coset R (J:((1->num)->A)->bool))` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN ASM_MESON_TAC[RING_HOMOMORPHISM_RING_COSET]; + ALL_TAC] THEN + SUBGOAL_THEN `ring_char(R:((1->num)->A)ring) = ring_char(f:A ring)` + ASSUME_TAC THENL + [MP_TAC(ISPECL [`f:A ring`; `(:1)`] RING_MONOMORPHISM_POLY_CONST) THEN + EXPAND_TAC "R" THEN + DISCH_THEN(fun th -> MP_TAC(MATCH_MP RING_CHAR_MONOMORPHIC_IMAGE th)) THEN + SIMP_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `ring_char(K:(((1->num)->A)->bool) ring) = + ring_char(f:A ring)` ASSUME_TAC THENL + [MP_TAC(ISPECL [`R:((1->num)->A)ring`; + `K:(((1->num)->A)->bool) ring`; + `ring_coset R (J:((1->num)->A)->bool)`] + RING_CHAR_HOMOMORPHIC_IMAGE) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + MP_TAC(ISPECL [`K:(((1->num)->A)->bool) ring`; + `ring_char(f:A ring)`] RING_CHAR_DIVIDES_PRIME) THEN + ANTS_TAC THENL [ASM_MESON_TAC[FIELD_IMP_INTEGRAL_DOMAIN]; ALL_TAC] THEN + DISCH_THEN(fun th -> REWRITE_TAC[GSYM th]) THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + (* q = ring_char(f)^e for some e >= 1 *) + SUBGOAL_THEN `?e. ~(e = 0) /\ q = ring_char(f:A ring) EXP e` + STRIP_ASSUME_TAC THENL + [MP_TAC(ISPEC `f:A ring` FINITE_INTEGRAL_DOMAIN_SIZE) THEN + ASM_SIMP_TAC[FIELD_IMP_INTEGRAL_DOMAIN] THEN + DISCH_THEN(X_CHOOSE_THEN `pp:num` + (X_CHOOSE_THEN `ee:num` STRIP_ASSUME_TAC)) THEN + EXISTS_TAC `ee:num` THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `ring_char(f:A ring) = pp` (fun th -> ASM_REWRITE_TAC[th]) THEN + ASM_MESON_TAC[DIVIDES_PRIME_PRIME; PRIME_DIVEXP; RING_CHAR_DIVIDES_ORDER]; + ALL_TAC] THEN + (* q^n = ring_char(K)^(e*n) *) + SUBGOAL_THEN `q EXP n = ring_char(K:(((1->num)->A)->bool) ring) EXP (e * n)` + ASSUME_TAC THENL + [ASM_REWRITE_TAC[EXP_EXP]; ALL_TAC] THEN + (* Frobenius y -> y^(q^n) is a ring endomorphism of K *) + ABBREV_TAC `frob = \y:(((1->num)->A)->bool). + ring_pow K y (q EXP n)` THEN + SUBGOAL_THEN `ring_endomorphism (K:(((1->num)->A)->bool) ring) frob` + ASSUME_TAC THENL + [SUBGOAL_THEN `frob = (\y:(((1->num)->A)->bool). + ring_pow K y (ring_char K EXP (e * n)))` SUBST1_TAC THENL + [EXPAND_TAC "frob" THEN + REWRITE_TAC[ASSUME `q EXP n = ring_char(K:(((1->num)->A)->bool) ring) EXP (e * n)`]; + ALL_TAC] THEN + MATCH_MP_TAC RING_ENDOMORPHISM_FROBENIUS_ITERATE THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* proj = ring_coset R J; proj is a surjection *) + ABBREV_TAC `proj = ring_coset R (J:((1->num)->A)->bool)` THEN + SUBGOAL_THEN `ring_epimorphism(R,K) + (proj:((1->num)->A) -> ((1->num)->A)->bool)` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN EXPAND_TAC "proj" THEN + MATCH_MP_TAC RING_EPIMORPHISM_RING_COSET THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* frob o proj is a ring homomorphism R -> K *) + SUBGOAL_THEN `ring_homomorphism(R,K) + ((frob:(((1->num)->A)->bool) -> ((1->num)->A)->bool) o + (proj:((1->num)->A) -> ((1->num)->A)->bool))` ASSUME_TAC THENL + [REWRITE_TAC[ring_endomorphism] THEN + MATCH_MP_TAC RING_HOMOMORPHISM_COMPOSE THEN + EXISTS_TAC `K:(((1->num)->A)->bool) ring` THEN + CONJ_TAC THENL + [ASM_MESON_TAC[ring_epimorphism]; ALL_TAC] THEN + ASM_REWRITE_TAC[GSYM ring_endomorphism]; + ALL_TAC] THEN + (* proj is a ring homomorphism R -> K *) + SUBGOAL_THEN `ring_homomorphism(R,K) + (proj:((1->num)->A) -> ((1->num)->A)->bool)` ASSUME_TAC THENL + [ASM_MESON_TAC[ring_epimorphism]; ALL_TAC] THEN + (* Agreement on constants: (frob o proj)(poly_const f c) = proj(poly_const f c) *) + SUBGOAL_THEN + `!c:A. c IN ring_carrier f + ==> ((frob:(((1->num)->A)->bool) -> ((1->num)->A)->bool) o + (proj:((1->num)->A) -> ((1->num)->A)->bool)) + (poly_const f c) = + proj (poly_const f c)` ASSUME_TAC THENL + [X_GEN_TAC `c:A` THEN DISCH_TAC THEN REWRITE_TAC[o_THM] THEN + (* Replace frob(proj(pc)) with ring_pow K (proj(pc)) (q^n) *) + SUBGOAL_THEN + `(frob:(((1->num)->A)->bool) -> ((1->num)->A)->bool) + ((proj:((1->num)->A) -> ((1->num)->A)->bool) (poly_const (f:A ring) c)) = + ring_pow K (proj (poly_const f c)) (q EXP n)` SUBST1_TAC THENL + [EXPAND_TAC "frob" THEN REWRITE_TAC[]; ALL_TAC] THEN + (* Now goal: ring_pow K (proj(poly_const f c)) (q^n) = proj(poly_const f c) *) + SUBGOAL_THEN `poly_const (f:A ring) c IN ring_carrier (R:((1->num)->A)ring)` ASSUME_TAC THENL + [EXPAND_TAC "R" THEN REWRITE_TAC[POLY_CONST] THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* proj(poly_const f c)^(q^n) = proj(ring_pow R (poly_const f c) (q^n)) *) + FIRST_ASSUM(fun hom -> MP_TAC(MATCH_MP RING_HOMOMORPHISM_POW hom)) THEN + DISCH_THEN(fun th -> + MP_TAC(SPECL [`(poly_const (f:A ring) c):(1->num)->A`; + `q EXP n`] th)) THEN + REWRITE_TAC[ASSUME `poly_const (f:A ring) c IN ring_carrier (R:((1->num)->A)ring)`] THEN + DISCH_THEN(SUBST1_TAC o SYM) THEN + (* ring_pow R (poly_const f c) (q^n) = poly_const f (ring_pow f c (q^n)) *) + MP_TAC(ISPECL [`f:A ring`; `(:1)`] RING_HOMOMORPHISM_POLY_CONST) THEN + EXPAND_TAC "R" THEN + DISCH_THEN(fun hom -> MP_TAC(MATCH_MP RING_HOMOMORPHISM_POW hom)) THEN + DISCH_THEN(fun th -> MP_TAC(SPECL [`c:A`; `q EXP n`] th)) THEN + REWRITE_TAC[ASSUME `(c:A) IN ring_carrier (f:A ring)`] THEN + DISCH_THEN(SUBST1_TAC o SYM) THEN + (* c^(q^n) = c by FINITE_FIELD_POW_ITERATE *) + AP_TERM_TAC THEN AP_TERM_TAC THEN + REWRITE_TAC[GSYM(ASSUME `CARD(ring_carrier(f:A ring)) = q`)] THEN + MATCH_MP_TAC FINITE_FIELD_POW_ITERATE THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Agreement on variable: (frob o proj)(poly_var f one) = proj(poly_var f one) *) + SUBGOAL_THEN + `((frob:(((1->num)->A)->bool) -> ((1->num)->A)->bool) o + (proj:((1->num)->A) -> ((1->num)->A)->bool)) + (poly_var (f:A ring) one) = proj (poly_var f one)` ASSUME_TAC THENL + [REWRITE_TAC[o_THM] THEN + (* Replace frob(proj(v)) with ring_pow K (proj v) (q^n) *) + SUBGOAL_THEN + `(frob:(((1->num)->A)->bool) -> ((1->num)->A)->bool) + ((proj:((1->num)->A) -> ((1->num)->A)->bool) (poly_var (f:A ring) one)) = + ring_pow K (proj (poly_var f one)) (q EXP n)` SUBST1_TAC THENL + [EXPAND_TAC "frob" THEN REWRITE_TAC[]; ALL_TAC] THEN + (* Goal: ring_pow K (proj v) (q^n) = proj v *) + SUBGOAL_THEN `poly_var (f:A ring) one IN ring_carrier (R:((1->num)->A)ring)` + ASSUME_TAC THENL + [EXPAND_TAC "R" THEN REWRITE_TAC[POLY_VAR_UNIV]; ALL_TAC] THEN + (* proj(ring_pow R v (q^n)) = ring_pow K (proj v) (q^n) by homomorphism *) + FIRST_ASSUM(fun hom -> MP_TAC(MATCH_MP RING_HOMOMORPHISM_POW hom)) THEN + DISCH_THEN(fun th -> + MP_TAC(SPECL [`poly_var (f:A ring) one`; `q EXP n`] th)) THEN + REWRITE_TAC[ASSUME `poly_var (f:A ring) one IN ring_carrier (R:((1->num)->A)ring)`] THEN + DISCH_THEN(SUBST1_TAC o SYM) THEN + (* Goal: proj(ring_pow R v (q^n)) = proj v *) + EXPAND_TAC "proj" THEN + (* Goal: ring_coset R J (ring_pow R v (q^n)) = ring_coset R J v *) + MP_TAC(ISPECL [`R:((1->num)->A)ring`; + `J:((1->num)->A)->bool`; + `ring_pow (R:((1->num)->A)ring) (poly_var (f:A ring) one) (q EXP n)`; + `poly_var (f:A ring) one`] RING_COSET_EQ) THEN + ANTS_TAC THENL + [ASM_SIMP_TAC[RING_POW]; ALL_TAC] THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + (* Goal: ring_sub R (ring_pow R v (q^n)) v IN J *) + EXPAND_TAC "J" THEN + MATCH_MP_TAC IN_IDEAL_GENERATED_SING THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Step 1: frob o proj = proj on all of R *) + MP_TAC(ISPECL [ + `(frob:(((1->num)->A)->bool) -> ((1->num)->A)->bool) o + (proj:((1->num)->A) -> ((1->num)->A)->bool)`; + `proj:((1->num)->A) -> ((1->num)->A)->bool`; + `f:A ring`; + `(:1)`; + `K:(((1->num)->A)->bool) ring` + ] RING_HOMOMORPHISMS_EQ_FROM_POLY_RING) THEN + REWRITE_TAC[ASSUME `poly_ring (f:A ring) (:1) = R`] THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[UNIV_1; FORALL_IN_INSERT; NOT_IN_EMPTY]; ALL_TAC] THEN + DISCH_TAC THEN + (* Step 2: every element of K satisfies y^(q^n) = y *) + SUBGOAL_THEN + `!y:(((1->num)->A)->bool). y IN ring_carrier K + ==> ring_pow K y (q EXP n) = y` ASSUME_TAC THENL + [X_GEN_TAC `y:(((1->num)->A)->bool)` THEN DISCH_TAC THEN + SUBGOAL_THEN `?x:(1->num)->A. x IN ring_carrier R /\ + (proj:((1->num)->A) -> ((1->num)->A)->bool) x = y` + STRIP_ASSUME_TAC THENL + [MP_TAC(ASSUME `ring_epimorphism (R:((1->num)->A)ring, + K:(((1->num)->A)->bool) ring) + (proj:((1->num)->A) -> ((1->num)->A)->bool)`) THEN + REWRITE_TAC[ring_epimorphism] THEN ASM SET_TAC[]; + ALL_TAC] THEN + FIRST_X_ASSUM(SUBST_ALL_TAC o SYM) THEN + SUBGOAL_THEN + `ring_pow K ((proj:((1->num)->A) -> ((1->num)->A)->bool) (x:(1->num)->A)) + (q EXP n) = + ((frob:(((1->num)->A)->bool) -> ((1->num)->A)->bool) o proj) x` + SUBST1_TAC THENL + [EXPAND_TAC "frob" THEN REWRITE_TAC[o_THM]; ALL_TAC] THEN + FIRST_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Step 3: 2 <= q *) + SUBGOAL_THEN `2 <= q` ASSUME_TAC THENL + [SUBGOAL_THEN `2 <= ring_char(f:A ring)` ASSUME_TAC THENL + [ASM_MESON_TAC[PRIME_GE_2]; ALL_TAC] THEN + MATCH_MP_TAC LE_TRANS THEN EXISTS_TAC `ring_char(f:A ring) EXP 1` THEN + CONJ_TAC THENL + [REWRITE_TAC[EXP_1] THEN ASM_ARITH_TAC; + REWRITE_TAC[ASSUME `q = ring_char(f:A ring) EXP e`; LE_EXP] THEN + COND_CASES_TAC THEN ASM_ARITH_TAC]; + ALL_TAC] THEN + (* Step 4: CARD K <= q^n *) + SUBGOAL_THEN `2 <= q EXP n` ASSUME_TAC THENL + [MATCH_MP_TAC LE_TRANS THEN EXISTS_TAC `q EXP 1` THEN + REWRITE_TAC[EXP_1; LE_EXP] THEN + CONJ_TAC THENL [ASM_ARITH_TAC; COND_CASES_TAC THEN ASM_ARITH_TAC]; + ALL_TAC] THEN + SUBGOAL_THEN `CARD(ring_carrier(K:(((1->num)->A)->bool) ring)) <= q EXP n` + ASSUME_TAC THENL + [MP_TAC(ISPECL [`K:(((1->num)->A)->bool) ring`; `q EXP n`] + FIELD_ROOTS_BOUND) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Step 5: q^d <= q^n implies d <= n *) + SUBGOAL_THEN `q EXP d <= q EXP n` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[LE_EXP] THEN + COND_CASES_TAC THEN ASM_ARITH_TAC);; + +(* Converse: if p is monic irreducible of degree d over GF(q) and + p divides x^(q^n) - x, then d divides n. + Proof: Write n = k*d + r with 0 <= r < d. Show p | x^(q^(k*d))-x + via IRREDUCIBLE_DIVIDES_XQ_MINUS_X_GEN, let u = x^(q^(k*d)), + then u^(q^r) = x^(q^n), so p | u^(q^r)-x. By RING_DIVIDES_REDUCE, + p | x^(q^r)-x. If r > 0, IRREDUCIBLE_DIVIDES_DEGREE_BOUND gives + d <= r < d, contradiction. So r = 0 and d | n. *) +let IRREDUCIBLE_DIVIDES_DEGREE = prove + (`!f:A ring p n. + field f /\ FINITE(ring_carrier f) /\ + p IN ring_carrier(poly_ring f (:1)) /\ + ring_irreducible (poly_ring f (:1)) p /\ + ring_divides (poly_ring f (:1)) p + (ring_sub (poly_ring f (:1)) + (ring_pow (poly_ring f (:1)) (poly_var f one) + (CARD(ring_carrier f) EXP n)) + (poly_var f one)) + ==> (poly_deg f p) divides n`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + ABBREV_TAC `R = poly_ring (f:A ring) (:1)` THEN + ABBREV_TAC `q = CARD(ring_carrier(f:A ring))` THEN + ABBREV_TAC `d = poly_deg (f:A ring) (p:(1->num)->A)` THEN + ABBREV_TAC `x = poly_var (f:A ring) one` THEN + (* Note: ABBREV_TAC modifies both goal AND existing assumptions. + So assumptions from STRIP_TAC are now in abbreviated form: + p IN ring_carrier R, ring_irreducible R p, + ring_divides R p (ring_sub R (ring_pow R x (q EXP n)) x) *) + (* Case n = 0 *) + ASM_CASES_TAC `n = 0` THENL + [ASM_REWRITE_TAC[DIVIDES_0]; ALL_TAC] THEN + (* d >= 1: irreducible polynomials have degree >= 1 *) + SUBGOAL_THEN `1 <= d` ASSUME_TAC THENL + [EXPAND_TAC "d" THEN + MP_TAC(ISPECL [`f:A ring`; `p:(1->num)->A`; `(:1)`] POLY_NONUNIT_DEGREE_GE_1) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[ring_irreducible]; + REWRITE_TAC[]]; + ALL_TAC] THEN + (* x IN ring_carrier R *) + SUBGOAL_THEN `(x:(1->num)->A) IN ring_carrier R` ASSUME_TAC THENL + [EXPAND_TAC "x" THEN EXPAND_TAC "R" THEN + REWRITE_TAC[POLY_VAR_UNIV]; + ALL_TAC] THEN + (* integral_domain R *) + SUBGOAL_THEN `integral_domain (R:((1->num)->A)ring)` ASSUME_TAC THENL + [EXPAND_TAC "R" THEN + ASM_MESON_TAC[INTEGRAL_DOMAIN_POLY_RING; FIELD_IMP_INTEGRAL_DOMAIN]; + ALL_TAC] THEN + (* ~(q = 0) *) + SUBGOAL_THEN `~(q = 0)` ASSUME_TAC THENL + [EXPAND_TAC "q" THEN ASM_MESON_TAC[CARD_EQ_0; RING_CARRIER_NONEMPTY]; + ALL_TAC] THEN + (* p | x^(q^d) - x by IRREDUCIBLE_DIVIDES_XQ_MINUS_X *) + SUBGOAL_THEN `ring_divides R (p:(1->num)->A) + (ring_sub R (ring_pow R x (q EXP d)) x)` ASSUME_TAC THENL + [MP_TAC(ISPECL [`f:A ring`; `p:(1->num)->A`] + IRREDUCIBLE_DIVIDES_XQ_MINUS_X) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Division: n = k*d + r, r < d *) + ABBREV_TAC `k = n DIV d` THEN + ABBREV_TAC `r = n MOD d` THEN + SUBGOAL_THEN `n = k * d + r` ASSUME_TAC THENL + [MAP_EVERY EXPAND_TAC ["k"; "r"] THEN + MESON_TAC[DIVISION_SIMP; ADD_SYM]; + ALL_TAC] THEN + SUBGOAL_THEN `r < d` ASSUME_TAC THENL + [EXPAND_TAC "r" THEN REWRITE_TAC[MOD_LT_EQ] THEN ASM_ARITH_TAC; + ALL_TAC] THEN + (* p | x^(q^(k*d)) - x via IRREDUCIBLE_DIVIDES_XQ_MINUS_X_GEN *) + SUBGOAL_THEN `ring_divides R (p:(1->num)->A) + (ring_sub R (ring_pow R x (q EXP (k * d))) x)` ASSUME_TAC THENL + [MP_TAC(ISPECL [`f:A ring`; `p:(1->num)->A`; `k * d`] + IRREDUCIBLE_DIVIDES_XQ_MINUS_X_GEN) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN MATCH_MP_TAC THEN + REWRITE_TAC[divides] THEN EXISTS_TAC `k:num` THEN ARITH_TAC; + ALL_TAC] THEN + (* Let u = x^(q^(k*d)). ABBREV_TAC modifies the ring_divides assumption + about x^(q^(k*d)) to use u, giving p | (u - x) automatically. *) + ABBREV_TAC `u = ring_pow R (x:(1->num)->A) (q EXP (k * d))` THEN + (* u IN ring_carrier R *) + SUBGOAL_THEN `(u:(1->num)->A) IN ring_carrier R` ASSUME_TAC THENL + [EXPAND_TAC "u" THEN MATCH_MP_TAC RING_POW THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* p | u^(q^r) - x: prove u^(q^r) = x^(q^n), then use original hyp *) + SUBGOAL_THEN `ring_divides R (p:(1->num)->A) + (ring_sub R (ring_pow R u (q EXP r)) x)` ASSUME_TAC THENL + [SUBGOAL_THEN `ring_pow R (u:(1->num)->A) (q EXP r) = + ring_pow R x (q EXP n)` SUBST1_TAC THENL + [EXPAND_TAC "u" THEN + MP_TAC(ISPECL [`R:((1->num)->A)ring`; `x:(1->num)->A`; + `q EXP (k * d)`; `q EXP r`] RING_POW_POW) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN SUBST1_TAC THEN + AP_TERM_TAC THEN REWRITE_TAC[GSYM EXP_ADD] THEN + AP_TERM_TAC THEN ASM_ARITH_TAC; + FIRST_ASSUM ACCEPT_TAC]; + ALL_TAC] THEN + (* ~(q EXP r = 0) *) + SUBGOAL_THEN `~(q EXP r = 0)` ASSUME_TAC THENL + [ASM_REWRITE_TAC[EXP_EQ_0]; ALL_TAC] THEN + (* p | x^(q^r) - x via RING_DIVIDES_REDUCE *) + SUBGOAL_THEN `ring_divides R (p:(1->num)->A) + (ring_sub R (ring_pow R x (q EXP r)) x)` ASSUME_TAC THENL + [MP_TAC(ISPECL [`R:((1->num)->A)ring`; `p:(1->num)->A`; + `u:(1->num)->A`; `x:(1->num)->A`; `q EXP r`] + RING_DIVIDES_REDUCE) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Case split on r *) + ASM_CASES_TAC `r = 0` THENL + [REWRITE_TAC[divides] THEN EXISTS_TAC `k:num` THEN ASM_ARITH_TAC; + ALL_TAC] THEN + (* r >= 1: IRREDUCIBLE_DIVIDES_DEGREE_BOUND gives d <= r, contradicting + r < d *) + MP_TAC(ISPECL [`f:A ring`; `p:(1->num)->A`; `r:num`] + IRREDUCIBLE_DIVIDES_DEGREE_BOUND) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[] THEN ASM_ARITH_TAC; ALL_TAC] THEN + ASM_ARITH_TAC);; + +(* ------------------------------------------------------------------------- *) +(* Rabin's Irreducibility Test *) +(* *) +(* Let f be a monic polynomial of degree n > 0 over GF(q). *) +(* Let n = p1^a1 * ... * pk^ak be the prime factorization of n. *) +(* Then f is irreducible over GF(q) if and only if: *) +(* (1) f divides x^(q^n) - x *) +(* (2) gcd(f, x^(q^(n/p)) - x) = 1 for each prime divisor p of n *) +(* *) +(* Note: condition (1) is equivalent to saying that all roots of f *) +(* lie in GF(q^n), and condition (2) says no root lies in a proper subfield. *) +(* ------------------------------------------------------------------------- *) + +(* Rabin's Test - forward direction: irreducible implies conditions *) +let RABIN_IRREDUCIBILITY_NECESSARY = prove + (`!f:A ring p n. + field f /\ FINITE(ring_carrier f) /\ + p IN ring_carrier(poly_ring f (:1)) /\ + poly_deg f p = n /\ ~(n = 0) /\ + ring_irreducible (poly_ring f (:1)) p + ==> ring_divides (poly_ring f (:1)) p + (ring_sub (poly_ring f (:1)) + (ring_pow (poly_ring f (:1)) (poly_var f one) + (CARD(ring_carrier f) EXP n)) + (poly_var f one)) /\ + !q. prime q /\ q divides n + ==> ring_coprime (poly_ring f (:1)) + (p, ring_sub (poly_ring f (:1)) + (ring_pow (poly_ring f (:1)) (poly_var f one) + (CARD(ring_carrier f) EXP (n DIV q))) + (poly_var f one))`, + let DIVIDES_DIV_PRIME_ABSURD = prove + (`!n q. prime q /\ q divides n /\ ~(n = 0) /\ n divides (n DIV q) ==> F`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN `2 <= q /\ ~(q = 0)` STRIP_ASSUME_TAC THENL + [MP_TAC(SPEC `q:num` PRIME_GE_2) THEN ASM_REWRITE_TAC[] THEN ARITH_TAC; + ALL_TAC] THEN + SUBGOAL_THEN `n = (n DIV q) * q` ASSUME_TAC THENL + [ASM_MESON_TAC[DIVIDES_DIV_MULT]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [divides]) THEN + DISCH_THEN(X_CHOOSE_TAC `k:num`) THEN + SUBGOAL_THEN `n * (k * q) = n * 1` MP_TAC THENL + [REWRITE_TAC[MULT_CLAUSES] THEN + UNDISCH_TAC `n = (n DIV q) * q` THEN + ASM_REWRITE_TAC[] THEN ARITH_TAC; + ALL_TAC] THEN + REWRITE_TAC[EQ_MULT_LCANCEL] THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + MP_TAC(SPECL [`k:num`; `q:num`] MULT_EQ_1) THEN + ASM_ARITH_TAC) in + REPEAT GEN_TAC THEN STRIP_TAC THEN CONJ_TAC THENL + [(* Part 1: p divides x^(q^n) - x, from IRREDUCIBLE_DIVIDES_XQ_MINUS_X *) + MP_TAC(ISPECL [`f:A ring`; `p:(1->num)->A`] + IRREDUCIBLE_DIVIDES_XQ_MINUS_X) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Part 2: coprimality for each prime divisor of n *) + X_GEN_TAC `q':num` THEN STRIP_TAC THEN + (* By RING_IRREDUCIBLE_DIVIDES_OR_COPRIME: divides or coprime *) + MP_TAC(ISPECL [`poly_ring (f:A ring) (:1)`; + `p:(1->num)->A`; + `ring_sub (poly_ring (f:A ring) (:1)) + (ring_pow (poly_ring (f:A ring) (:1)) + (poly_var f one) + (CARD(ring_carrier f) EXP (n DIV q'))) + (poly_var (f:A ring) one)`] + RING_IRREDUCIBLE_DIVIDES_OR_COPRIME) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC RING_SUB THEN + CONJ_TAC THENL [MATCH_MP_TAC RING_POW; ALL_TAC] THEN + REWRITE_TAC[POLY_VAR_UNIV]; + ALL_TAC] THEN + DISCH_THEN(DISJ_CASES_TAC) THENL + [(* Case: p divides x^(q^(n/q')) - x -- derive contradiction *) + (* By IRREDUCIBLE_DIVIDES_DEGREE: n divides (n DIV q') *) + MP_TAC(ISPECL [`f:A ring`; `p:(1->num)->A`; `n DIV q'`] + IRREDUCIBLE_DIVIDES_DEGREE) THEN + ASM_REWRITE_TAC[] THEN + DISCH_TAC THEN + MP_TAC(SPECL [`n:num`; `q':num`] DIVIDES_DIV_PRIME_ABSURD) THEN + ASM_REWRITE_TAC[]; + (* Case: coprime -- this is the goal *) + ASM_REWRITE_TAC[]]);; + +(* Rabin's Test - backward direction: conditions imply irreducible *) +let RABIN_IRREDUCIBILITY_SUFFICIENT = prove + (`!f:A ring p n. + field f /\ FINITE(ring_carrier f) /\ + p IN ring_carrier(poly_ring f (:1)) /\ + ~(p = ring_0(poly_ring f (:1))) /\ + poly_deg f p = n /\ ~(n = 0) /\ + ring_divides (poly_ring f (:1)) p + (ring_sub (poly_ring f (:1)) + (ring_pow (poly_ring f (:1)) (poly_var f one) + (CARD(ring_carrier f) EXP n)) + (poly_var f one)) /\ + (!q. prime q /\ q divides n + ==> ring_coprime (poly_ring f (:1)) + (p, ring_sub (poly_ring f (:1)) + (ring_pow (poly_ring f (:1)) (poly_var f one) + (CARD(ring_carrier f) EXP (n DIV q))) + (poly_var f one))) + ==> ring_irreducible (poly_ring f (:1)) p`, + let PROPER_DIVISOR_PRIME_FACTOR = prove + (`!d n. d divides n /\ 1 <= d /\ d < n + ==> ?q. prime q /\ q divides n /\ d divides (n DIV q)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN `~(n DIV d = 1)` ASSUME_TAC THENL + [DISCH_TAC THEN + MP_TAC(SPECL [`d:num`; `n:num`] DIVIDES_DIV_MULT) THEN + ASM_REWRITE_TAC[MULT_CLAUSES] THEN ASM_ARITH_TAC; + ALL_TAC] THEN + MP_TAC(SPEC `n DIV d` PRIME_FACTOR) THEN + ANTS_TAC THENL + [MP_TAC(SPECL [`d:num`; `n:num`] DIVIDES_DIV_MULT) THEN + ASM_REWRITE_TAC[] THEN ASM_ARITH_TAC; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `r:num` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `r:num` THEN + SUBGOAL_THEN `(d * r) divides n` ASSUME_TAC THENL + [ASM_REWRITE_TAC[GSYM DIVIDES_DIVIDES_DIV_EQ]; ALL_TAC] THEN + SUBGOAL_THEN `r divides n` ASSUME_TAC THENL + [ASM_MESON_TAC[DIVIDES_TRANS; DIVIDES_DIV_SELF]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + MP_TAC(SPECL [`n:num`; `r:num`; `d:num`] DIVIDES_DIVIDES_DIV) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN SUBST1_TAC THEN + ASM_MESON_TAC[MULT_SYM]) in + REPEAT GEN_TAC THEN STRIP_TAC THEN + ABBREV_TAC `R = poly_ring (f:A ring) (:1)` THEN + (* Step 1: integral_domain R *) + SUBGOAL_THEN `integral_domain (R:((1->num)->A)ring)` ASSUME_TAC THENL + [EXPAND_TAC "R" THEN + ASM_MESON_TAC[INTEGRAL_DOMAIN_POLY_RING; FIELD_IMP_INTEGRAL_DOMAIN]; + ALL_TAC] THEN + (* Step 2: p is not a unit (units have degree 0, but deg p = n > 0) *) + SUBGOAL_THEN `~(ring_unit R (p:(1->num)->A))` ASSUME_TAC THENL + [DISCH_TAC THEN + MP_TAC(ISPECL [`f:A ring`; `(:1)`; `p:(1->num)->A`] + RING_UNIT_POLY_DOMAIN) THEN + ANTS_TAC THENL [ASM_MESON_TAC[FIELD_IMP_INTEGRAL_DOMAIN]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `c:A` STRIP_ASSUME_TAC) THEN + ASM_MESON_TAC[POLY_DEG_CONST]; + ALL_TAC] THEN + (* Step 3: proof by contradiction *) + MATCH_MP_TAC(TAUT `(~p ==> F) ==> p`) THEN DISCH_TAC THEN + (* Step 4: extract non-trivial factorization from ~irreducible *) + SUBGOAL_THEN + `?a b:(1->num)->A. + a IN ring_carrier R /\ b IN ring_carrier R /\ + ring_mul R a b = p /\ + ~(ring_unit R a) /\ ~(ring_unit R b)` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `~ring_irreducible R (p:(1->num)->A)` THEN + REWRITE_TAC[ring_irreducible; DE_MORGAN_THM; NOT_FORALL_THM; + NOT_IMP] THEN + ASM_REWRITE_TAC[POLY_RING_CLAUSES] THEN + REWRITE_TAC[TAUT `~(a \/ b) <=> ~a /\ ~b`] THEN + STRIP_TAC THEN MAP_EVERY EXISTS_TAC + [`a:(1->num)->A`; `b:(1->num)->A`] THEN + ASM_REWRITE_TAC[GSYM POLY_RING_CLAUSES]; + ALL_TAC] THEN + (* Step 5: a and b are nonzero *) + SUBGOAL_THEN `~(a:(1->num)->A = ring_0 R) /\ ~(b:(1->num)->A = ring_0 R)` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[RING_MUL_LZERO; RING_MUL_RZERO]; ALL_TAC] THEN + (* Step 6: deg(a) + deg(b) = n *) + SUBGOAL_THEN `ring_polynomial f (a:(1->num)->A) /\ + ring_polynomial f (b:(1->num)->A)` STRIP_ASSUME_TAC THENL + [CONJ_TAC THENL + [UNDISCH_TAC `a:(1->num)->A IN ring_carrier R`; + UNDISCH_TAC `b:(1->num)->A IN ring_carrier R`] THEN + EXPAND_TAC "R" THEN REWRITE_TAC[POLY_RING_CLAUSES; IN_ELIM_THM] THEN + SIMP_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `poly_deg f (poly_mul f (a:(1->num)->A) (b:(1->num)->A)) = + poly_deg f a + poly_deg f b` ASSUME_TAC THENL + [MATCH_MP_TAC POLY_DEG_MUL THEN + ASM_SIMP_TAC[FIELD_IMP_INTEGRAL_DOMAIN] THEN + SUBGOAL_THEN `ring_0 (R:((1->num)->A)ring) = poly_0 (f:A ring)` + (SUBST1_TAC o SYM) THENL + [EXPAND_TAC "R" THEN REWRITE_TAC[POLY_RING_CLAUSES]; ALL_TAC] THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `poly_deg f (a:(1->num)->A) + poly_deg f (b:(1->num)->A) = n` + ASSUME_TAC THENL + [SUBGOAL_THEN `poly_mul f (a:(1->num)->A) (b:(1->num)->A) = p:(1->num)->A` + ASSUME_TAC THENL + [ASM_MESON_TAC[POLY_RING_CLAUSES]; ALL_TAC] THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Step 7: deg(a) >= 1 and deg(b) >= 1 *) + SUBGOAL_THEN `1 <= poly_deg f (a:(1->num)->A) /\ + 1 <= poly_deg f (b:(1->num)->A)` STRIP_ASSUME_TAC THENL + [CONJ_TAC THENL + [MP_TAC(ISPECL [`f:A ring`; `a:(1->num)->A`; `(:1)`] POLY_NONUNIT_DEGREE_GE_1); + MP_TAC(ISPECL [`f:A ring`; `b:(1->num)->A`; `(:1)`] POLY_NONUNIT_DEGREE_GE_1)] THEN + (ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[POLY_RING_CLAUSES]; SIMP_TAC[]]); + ALL_TAC] THEN + SUBGOAL_THEN `poly_deg f (a:(1->num)->A) < n` ASSUME_TAC THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + (* Step 8: a has an irreducible factor g *) + SUBGOAL_THEN `UFD (R:((1->num)->A)ring)` ASSUME_TAC THENL + [EXPAND_TAC "R" THEN ASM_MESON_TAC[PID_IMP_UFD; PID_POLY_RING]; + ALL_TAC] THEN + MP_TAC(ISPECL [`R:((1->num)->A)ring`; `a:(1->num)->A`] + NOETHERIAN_DOMAIN_IRREDUCIBLE_FACTOR_EXISTS) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `g:(1->num)->A` STRIP_ASSUME_TAC) THEN + (* Step 9: g | a | p, so g | p *) + SUBGOAL_THEN `ring_divides R (g:(1->num)->A) p` ASSUME_TAC THENL + [MATCH_MP_TAC RING_DIVIDES_TRANS THEN EXISTS_TAC `a:(1->num)->A` THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[ring_divides] THEN ASM_REWRITE_TAC[] THEN + EXISTS_TAC `b:(1->num)->A` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Step 10: g | x^(q^n) - x via transitivity *) + SUBGOAL_THEN `ring_divides R (g:(1->num)->A) + (ring_sub R (ring_pow R (poly_var f one) + (CARD(ring_carrier f) EXP n)) (poly_var f one))` + ASSUME_TAC THENL + [MATCH_MP_TAC RING_DIVIDES_TRANS THEN EXISTS_TAC `p:(1->num)->A` THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[POLY_RING_CLAUSES]; + ALL_TAC] THEN + (* Step 11: deg(g) | n by IRREDUCIBLE_DIVIDES_DEGREE *) + SUBGOAL_THEN `g:(1->num)->A IN ring_carrier R` ASSUME_TAC THENL + [ASM_MESON_TAC[ring_irreducible]; ALL_TAC] THEN + SUBGOAL_THEN `(poly_deg f (g:(1->num)->A)) divides n` ASSUME_TAC THENL + [MP_TAC(ISPECL [`f:A ring`; `g:(1->num)->A`; `n:num`] + IRREDUCIBLE_DIVIDES_DEGREE) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN MATCH_MP_TAC THEN + ASM_MESON_TAC[POLY_RING_CLAUSES]; + ALL_TAC] THEN + (* Step 12: deg(g) >= 1 (g is irreducible, hence nonzero non-unit) *) + SUBGOAL_THEN `1 <= poly_deg f (g:(1->num)->A)` ASSUME_TAC THENL + [MP_TAC(ISPECL [`f:A ring`; `g:(1->num)->A`; `(:1)`] POLY_NONUNIT_DEGREE_GE_1) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[ring_irreducible; POLY_RING_CLAUSES]; + SIMP_TAC[]]; + ALL_TAC] THEN + (* Step 13: deg(g) <= deg(a) < n, so deg(g) < n *) + SUBGOAL_THEN `poly_deg f (g:(1->num)->A) <= poly_deg f (a:(1->num)->A)` ASSUME_TAC THENL + [UNDISCH_TAC `ring_divides R (g:(1->num)->A) (a:(1->num)->A)` THEN + REWRITE_TAC[ring_divides] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `h:(1->num)->A` STRIP_ASSUME_TAC))) THEN + SUBGOAL_THEN `~(h:(1->num)->A = ring_0 R)` ASSUME_TAC THENL + [ASM_MESON_TAC[RING_MUL_RZERO]; ALL_TAC] THEN + SUBGOAL_THEN `poly_deg f (a:(1->num)->A) = + poly_deg f (g:(1->num)->A) + poly_deg f (h:(1->num)->A)` MP_TAC THENL + [SUBGOAL_THEN `poly_deg f (a:(1->num)->A) = + poly_deg f (poly_mul f (g:(1->num)->A) (h:(1->num)->A))` SUBST1_TAC THENL + [AP_TERM_TAC THEN ASM_MESON_TAC[POLY_RING_CLAUSES]; ALL_TAC] THEN + MATCH_MP_TAC POLY_DEG_MUL THEN + ASM_SIMP_TAC[FIELD_IMP_INTEGRAL_DOMAIN] THEN + CONJ_TAC THENL + [UNDISCH_TAC `g:(1->num)->A IN ring_carrier R` THEN + EXPAND_TAC "R" THEN REWRITE_TAC[POLY_RING_CLAUSES; IN_ELIM_THM] THEN + SIMP_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL + [UNDISCH_TAC `h:(1->num)->A IN ring_carrier R` THEN + EXPAND_TAC "R" THEN REWRITE_TAC[POLY_RING_CLAUSES; IN_ELIM_THM] THEN + SIMP_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `ring_0 (R:((1->num)->A)ring) = poly_0 (f:A ring)` + (SUBST1_TAC o SYM) THENL + [EXPAND_TAC "R" THEN REWRITE_TAC[POLY_RING_CLAUSES]; ALL_TAC] THEN + ASM_MESON_TAC[ring_irreducible]; + ARITH_TAC]; + ALL_TAC] THEN + SUBGOAL_THEN `poly_deg f (g:(1->num)->A) < n` ASSUME_TAC THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + (* Step 14: number theory: find prime l | n with deg(g) | (n DIV l) *) + MP_TAC(SPECL [`poly_deg f (g:(1->num)->A)`; `n:num`] + PROPER_DIVISOR_PRIME_FACTOR) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `l:num` STRIP_ASSUME_TAC) THEN + (* Step 15: g | x^(q^(n/l)) - x by IRREDUCIBLE_DIVIDES_XQ_MINUS_X_GEN *) + SUBGOAL_THEN `ring_divides R (g:(1->num)->A) + (ring_sub R (ring_pow R (poly_var f one) + (CARD(ring_carrier f) EXP (n DIV l))) (poly_var f one))` + ASSUME_TAC THENL + [MP_TAC(ISPECL [`f:A ring`; `g:(1->num)->A`; `n DIV l`] + IRREDUCIBLE_DIVIDES_XQ_MINUS_X_GEN) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN MATCH_MP_TAC THEN + ASM_MESON_TAC[POLY_RING_CLAUSES]; + ALL_TAC] THEN + (* Step 16: coprimality gives g is a unit *) + SUBGOAL_THEN `ring_unit R (g:(1->num)->A)` MP_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `l:num`) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[ring_coprime] THEN + DISCH_THEN(MP_TAC o CONJUNCT2 o CONJUNCT2) THEN + DISCH_THEN(MP_TAC o SPEC `g:(1->num)->A`) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN MATCH_MP_TAC THEN + ASM_MESON_TAC[POLY_RING_CLAUSES]; + ALL_TAC] THEN + (* Step 17: contradiction - g is irreducible hence not a unit *) + ASM_MESON_TAC[ring_irreducible]);; + +(* Combined Rabin's Test *) +let RABIN_IRREDUCIBILITY_TEST = prove + (`!f:A ring p n. + field f /\ FINITE(ring_carrier f) /\ + p IN ring_carrier(poly_ring f (:1)) /\ + ~(p = ring_0(poly_ring f (:1))) /\ + ~(ring_unit (poly_ring f (:1)) p) /\ + poly_deg f p = n /\ ~(n = 0) + ==> (ring_irreducible (poly_ring f (:1)) p <=> + ring_divides (poly_ring f (:1)) p + (ring_sub (poly_ring f (:1)) + (ring_pow (poly_ring f (:1)) (poly_var f one) + (CARD(ring_carrier f) EXP n)) + (poly_var f one)) /\ + !q. prime q /\ q divides n + ==> ring_coprime (poly_ring f (:1)) + (p, ring_sub (poly_ring f (:1)) + (ring_pow (poly_ring f (:1)) (poly_var f one) + (CARD(ring_carrier f) EXP (n DIV q))) + (poly_var f one)))`, + REPEAT GEN_TAC THEN STRIP_TAC THEN EQ_TAC THENL + [(* Forward: irreducible ==> conditions *) + DISCH_TAC THEN + MP_TAC(ISPECL [`f:A ring`; `p:(1->num)->A`; `n:num`] + RABIN_IRREDUCIBILITY_NECESSARY) THEN + ASM_REWRITE_TAC[]; + (* Backward: conditions ==> irreducible *) + STRIP_TAC THEN + MP_TAC(ISPECL [`f:A ring`; `p:(1->num)->A`; `n:num`] + RABIN_IRREDUCIBILITY_SUFFICIENT) THEN + ASM_REWRITE_TAC[]]);; diff --git a/Library/ringtheory.ml b/Library/ringtheory.ml index 321e121f..f6b6dd09 100644 --- a/Library/ringtheory.ml +++ b/Library/ringtheory.ml @@ -394,6 +394,17 @@ let RING_EQ_SUB_RADD = prove ==> (ring_sub r x y = z <=> x = ring_add r z y)`, MESON_TAC[RING_EQ_SUB_LADD]);; +let RING_SUB_TELESCOPE = prove + (`!r (a:A) b c. + a IN ring_carrier r /\ b IN ring_carrier r /\ c IN ring_carrier r + ==> ring_add r (ring_sub r a b) (ring_sub r b c) = + ring_sub r a c`, + REPEAT STRIP_TAC THEN REWRITE_TAC[ring_sub] THEN + ASM_SIMP_TAC[GSYM RING_ADD_ASSOC; RING_NEG; RING_ADD] THEN + AP_TERM_TAC THEN + ASM_SIMP_TAC[RING_ADD_ASSOC; RING_NEG; RING_ADD] THEN + ASM_SIMP_TAC[RING_ADD_LNEG; RING_ADD_LZERO; RING_NEG]);; + let RING_CARRIER_NONEMPTY = prove (`!r:A ring. ~(ring_carrier r = {})`, MESON_TAC[MEMBER_NOT_EMPTY; RING_0]);; @@ -1651,6 +1662,33 @@ let RING_PRODUCT_DELTA = prove ASM_SIMP_TAC[SET_RULE `i IN s ==> {j | j IN s /\ j = i} = {i}`] THEN ASM_REWRITE_TAC[RING_PRODUCT_SING]);; +let RING_PRODUCT_CONST = prove + (`!r (x:A) (s:K->bool). + FINITE s /\ x IN ring_carrier r + ==> ring_product r s (\i. x) = ring_pow r x (CARD s)`, + GEN_TAC THEN GEN_TAC THEN REWRITE_TAC[IMP_CONJ] THEN + MATCH_MP_TAC FINITE_INDUCT_STRONG THEN CONJ_TAC THENL + [REWRITE_TAC[RING_PRODUCT_CLAUSES; CARD_CLAUSES; ring_pow]; ALL_TAC] THEN + MAP_EVERY X_GEN_TAC [`a:K`; `t:K->bool`] THEN STRIP_TAC THEN + DISCH_TAC THEN + ASM_SIMP_TAC[RING_PRODUCT_CLAUSES; CARD_CLAUSES; ring_pow]);; + +let RING_PRODUCT_LMUL = prove + (`!r (x:A) (s:A->bool). + FINITE s /\ x IN ring_carrier r /\ + (!y. y IN s ==> y IN ring_carrier r) + ==> ring_product r s (\y. ring_mul r x y) = + ring_mul r (ring_pow r x (CARD s)) (ring_product r s (\y. y))`, + REPEAT STRIP_TAC THEN + SUBGOAL_THEN + `ring_product r s (\y:A. ring_mul r x y) = + ring_mul r (ring_product r s (\y:A. x)) (ring_product r s (\y:A. y))` + SUBST1_TAC THENL + [MATCH_MP_TAC RING_PRODUCT_MUL THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + AP_THM_TAC THEN AP_TERM_TAC THEN + MATCH_MP_TAC RING_PRODUCT_CONST THEN ASM_REWRITE_TAC[]]);; + let RING_PRODUCT_SWAP = prove (`!r (f:K->L->A) s t. FINITE s /\ FINITE t /\ @@ -2241,6 +2279,39 @@ let RING_DIVIDES_RMUL2 = prove ==> ring_divides r (ring_mul r a c) (ring_mul r b c)`, SIMP_TAC[RING_DIVIDES_MUL2; RING_DIVIDES_REFL]);; +let RING_DIVIDES_SUB_POW = prove + (`!r (a:A) b n. + a IN ring_carrier r /\ b IN ring_carrier r /\ ~(n = 0) + ==> ring_divides r (ring_sub r a b) + (ring_sub r (ring_pow r a n) (ring_pow r b n))`, + GEN_TAC THEN GEN_TAC THEN GEN_TAC THEN + INDUCT_TAC THEN REWRITE_TAC[NOT_SUC] THEN + DISCH_TAC THEN + ASM_CASES_TAC `n = 0` THENL + [ASM_REWRITE_TAC[ring_pow; RING_POW] THEN + ASM_SIMP_TAC[RING_MUL_RID] THEN REWRITE_TAC[RING_DIVIDES_REFL] THEN + ASM_SIMP_TAC[RING_SUB]; + ALL_TAC] THEN + (* a^(SUC n) - b^(SUC n) = a*(a^n - b^n) + (a-b)*b^n *) + SUBGOAL_THEN + `ring_sub r (ring_pow r (a:A) (SUC n)) (ring_pow r b (SUC n)) = + ring_add r (ring_mul r a (ring_sub r (ring_pow r a n) (ring_pow r b n))) + (ring_mul r (ring_sub r a b) (ring_pow r b n))` + SUBST1_TAC THENL + [REWRITE_TAC[ring_pow] THEN + ASM_SIMP_TAC[RING_SUB_LDISTRIB; RING_POW; + RING_SUB_RDISTRIB; RING_MUL; RING_SUB] THEN + MATCH_MP_TAC(GSYM RING_SUB_TELESCOPE) THEN + ASM_SIMP_TAC[RING_MUL; RING_POW]; + ALL_TAC] THEN + MATCH_MP_TAC RING_DIVIDES_ADD THEN + ASM_SIMP_TAC[RING_MUL; RING_POW; RING_SUB] THEN CONJ_TAC THENL + [MATCH_MP_TAC RING_DIVIDES_LMUL THEN + ASM_SIMP_TAC[RING_POW; RING_SUB] THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + MATCH_MP_TAC RING_DIVIDES_RMUL THEN + ASM_SIMP_TAC[RING_POW; RING_SUB; RING_DIVIDES_REFL]]);; + let RING_DIVIDES_PRODUCT_SUBSET = prove (`!r (f:K->A) s t. FINITE t /\ s SUBSET t @@ -4834,7 +4905,7 @@ let RING_POLY_UNIVERSAL_CONV = SEMIRING_NORMALIZERS_CONV pth sth (is_ringconst, RING_INT_ADD_CONV,RING_INT_MUL_CONV,RING_INT_POW_CONV) - (<) in + Term.(<) in GEN_REWRITE_CONV ONCE_DEPTH_CONV [ith; GSYM RING_OF_INT_OF_NUM] THENC RING_POLY_CONV;; @@ -6773,6 +6844,91 @@ let ISOMORPHIC_RING_FIELDNESS = prove REPEAT STRIP_TAC THEN ASM_MESON_TAC[FIELD_EPIMORPHIC_IMAGE; RING_ISOMORPHISM_IMP_EPIMORPHISM]);; +let RING_HOMOMORPHISM_EPIMORPHISM_FACTOR = prove + (`!r1 r2 r3 (f:A->B) (g:A->C). + ring_epimorphism(r1,r2) f /\ ring_homomorphism(r1,r3) g /\ + ring_kernel(r1,r2) f SUBSET ring_kernel(r1,r3) g + ==> ?h. ring_homomorphism(r2,r3) h /\ + !x. x IN ring_carrier r1 ==> h(f x) = g x`, + let hom_f th = MP_TAC(ISPECL [`r1:A ring`; `r2:B ring`; `f:A->B`] th) THEN + ASM_REWRITE_TAC[] + and hom_g th = MP_TAC(ISPECL [`r1:A ring`; `r3:C ring`; `g:A->C`] th) THEN + ASM_REWRITE_TAC[] in + REPEAT GEN_TAC THEN REWRITE_TAC[ring_epimorphism] THEN STRIP_TAC THEN + FIRST_ASSUM(ASSUME_TAC o REWRITE_RULE[SUBSET; FORALL_IN_IMAGE] o CONJUNCT1 o + GEN_REWRITE_RULE I [ring_homomorphism]) THEN SUBGOAL_THEN + `(!x:A. x IN ring_carrier r1 ==> (f:A->B) x IN ring_carrier r2)` + ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `!x y:A. x IN ring_carrier r1 /\ y IN ring_carrier r1 /\ + (f:A->B) x = f y ==> (g:A->C) x = g y` + ASSUME_TAC THENL + [REPEAT STRIP_TAC THEN + SUBGOAL_THEN `(f:A->B)(ring_sub r1 x y) = ring_0 r2` ASSUME_TAC THENL + [MP_TAC(ISPECL [`r1:A ring`; `r2:B ring`; `f:A->B`] + RING_HOMOMORPHISM_SUB) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPECL [`x:A`; `y:A`]) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN SUBST1_TAC THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC RING_SUB_REFL THEN ASM_SIMP_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN + `ring_sub r1 (x:A) y IN ring_kernel(r1:A ring,r2:B ring) (f:A->B)` + ASSUME_TAC THENL + [REWRITE_TAC[ring_kernel; IN_ELIM_THM] THEN ASM_SIMP_TAC[RING_SUB]; + ALL_TAC] THEN + SUBGOAL_THEN + `ring_sub r1 (x:A) y IN ring_kernel(r1:A ring,r3:C ring) (g:A->C)` + MP_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + REWRITE_TAC[ring_kernel; IN_ELIM_THM] THEN STRIP_TAC THEN + MP_TAC(ISPECL [`r1:A ring`; `r3:C ring`; `g:A->C`] + RING_HOMOMORPHISM_SUB) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN(MP_TAC o SPECL [`x:A`; `y:A`]) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(fun th -> MP_TAC(SYM th)) THEN + ASM_SIMP_TAC[RING_SUB_EQ_0]; + ALL_TAC] THEN + SUBGOAL_THEN + `?h:B->C. !x:A. x IN ring_carrier r1 ==> (g:A->C) x = h((f:A->B) x)` + MP_TAC THENL + [REWRITE_TAC[GSYM FUNCTION_FACTORS_LEFT_GEN] THEN + FIRST_X_ASSUM ACCEPT_TAC; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `h:B->C` (ASSUME_TAC o GSYM)) THEN + EXISTS_TAC `h:B->C` THEN CONJ_TAC THENL + [ALL_TAC; FIRST_ASSUM ACCEPT_TAC] THEN + REWRITE_TAC[ring_homomorphism] THEN + UNDISCH_TAC `IMAGE (f:A->B) (ring_carrier r1) = ring_carrier r2` THEN + DISCH_THEN(fun th -> REWRITE_TAC[SYM th]) THEN + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN + REPEAT CONJ_TAC THENL + [X_GEN_TAC `x:A` THEN DISCH_TAC THEN ASM_SIMP_TAC[]; + SUBGOAL_THEN `ring_0 (r2:B ring) = (f:A->B)(ring_0 r1)` SUBST1_TAC THENL + [CONV_TAC SYM_CONV THEN hom_f RING_HOMOMORPHISM_0; + ASM_SIMP_TAC[RING_0] THEN hom_g RING_HOMOMORPHISM_0]; + SUBGOAL_THEN `ring_1 (r2:B ring) = (f:A->B)(ring_1 r1)` SUBST1_TAC THENL + [CONV_TAC SYM_CONV THEN hom_f RING_HOMOMORPHISM_1; + ASM_SIMP_TAC[RING_1] THEN hom_g RING_HOMOMORPHISM_1]; + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `ring_neg r2 ((f:A->B) x) = f(ring_neg r1 x)` SUBST1_TAC + THENL + [CONV_TAC SYM_CONV THEN hom_f RING_HOMOMORPHISM_NEG THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[]; + ASM_SIMP_TAC[RING_NEG] THEN hom_g RING_HOMOMORPHISM_NEG THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[]]; + X_GEN_TAC `x1:A` THEN DISCH_TAC THEN X_GEN_TAC `x2:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `ring_add r2 ((f:A->B) x1) (f x2) = f(ring_add r1 x1 x2)` + SUBST1_TAC THENL [CONV_TAC SYM_CONV THEN hom_f RING_HOMOMORPHISM_ADD THEN + DISCH_THEN(MP_TAC o SPECL [`x1:A`; `x2:A`]) THEN ASM_REWRITE_TAC[]; + ASM_SIMP_TAC[RING_ADD] THEN hom_g RING_HOMOMORPHISM_ADD THEN + DISCH_THEN(MP_TAC o SPECL [`x1:A`; `x2:A`]) THEN ASM_REWRITE_TAC[]]; + X_GEN_TAC `x1:A` THEN DISCH_TAC THEN X_GEN_TAC `x2:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `ring_mul r2 ((f:A->B) x1) (f x2) = f(ring_mul r1 x1 x2)` + SUBST1_TAC THENL + [CONV_TAC SYM_CONV THEN hom_f RING_HOMOMORPHISM_MUL THEN + DISCH_THEN(MP_TAC o SPECL [`x1:A`; `x2:A`]) THEN ASM_REWRITE_TAC[]; + ASM_SIMP_TAC[RING_MUL] THEN hom_g RING_HOMOMORPHISM_MUL THEN + DISCH_THEN(MP_TAC o SPECL [`x1:A`; `x2:A`]) THEN ASM_REWRITE_TAC[]]]);; + (* ------------------------------------------------------------------------- *) (* Direct products of rings, binary and general. *) (* ------------------------------------------------------------------------- *) @@ -11469,6 +11625,17 @@ let RING_EPIMORPHISM_ONTO_FIELD_EXISTS = prove ASM_SIMP_TAC[FIELD_QUOTIENT_RING; MAXIMAL_IMP_RING_IDEAL; RING_EPIMORPHISM_RING_COSET]);; +let FIELD_RING_HOMOMORPHISM_MONOMORPHISM = prove + (`!(k:A ring) (l:B ring) (h:A->B). + field k /\ ring_homomorphism(k,l) h /\ ~(trivial_ring l) + ==> ring_monomorphism(k,l) h`, + REPEAT STRIP_TAC THEN + MP_TAC(ISPECL [`k:A ring`; `l:B ring`; `h:A->B`] + FIELD_HOMOMORPHISM_IMP_MONOMORPHISM) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(DISJ_CASES_THEN2 ASSUME_TAC ACCEPT_TAC) THEN + ASM_MESON_TAC[RING_HOMOMORPHISM_1; RING_1; TRIVIAL_RING_10]);; + (* ------------------------------------------------------------------------- *) (* The radical ideal and in particular the nilradical *) (* ------------------------------------------------------------------------- *) @@ -16595,6 +16762,11 @@ let RING_POLYNOMIAL = prove (`!(r:A ring) p. ring_polynomial r p <=> p IN ring_carrier(poly_ring r (:V))`, REWRITE_TAC[FUN_EQ_THM; POLY_RING; SUBSET_UNIV; IN_ELIM_THM]);; +let RING_POWERSERIES = prove + (`!(r:A ring) p. + ring_powerseries r p <=> p IN ring_carrier(powser_ring r (:V))`, + REWRITE_TAC[POWSER_RING_CLAUSES; IN_ELIM_THM; SUBSET_UNIV]);; + let IN_POLY_RING_CARRIER = prove (`!(r:A ring) (s:V->bool). p IN ring_carrier(poly_ring r s) <=> @@ -17389,6 +17561,29 @@ let RING_HOMOMORPHISM_POLY_EXTEND = prove REPEAT STRIP_TAC THEN MATCH_MP_TAC POLY_EXTEND_MUL THEN ASM SET_TAC[]);; +let POLY_EXTEND_RING_PRODUCT = prove + (`!(r:A ring) (r':B ring) h (v:V->bool) (s:W->bool) f x. + ring_homomorphism(r,r') h /\ + (!i. i IN v ==> x i IN ring_carrier r') /\ + FINITE s /\ + (!a. a IN s ==> f a IN ring_carrier(poly_ring r v)) + ==> poly_extend (r,r') h x + (ring_product (poly_ring r v) s f) = + ring_product r' s + (\a. poly_extend (r,r') h x (f a))`, + REPEAT STRIP_TAC THEN SUBGOAL_THEN + `poly_extend (r:A ring,r':B ring) (h:A->B) (x:V->B) + (ring_product (poly_ring r (v:V->bool)) (s:W->bool) + (f:W->(V->num)->A)) = + ring_product r' s + (poly_extend (r,r') h x o f)` MP_TAC THENL + [MATCH_MP_TAC(REWRITE_RULE[IMP_IMP; RIGHT_IMP_FORALL_THM] + RING_HOMOMORPHISM_PRODUCT) THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC RING_HOMOMORPHISM_POLY_EXTEND THEN + ASM_REWRITE_TAC[]; + REWRITE_TAC[o_DEF] THEN + DISCH_THEN(fun th -> REWRITE_TAC[th])]);; + let POLY_EXTEND_UNIQUE = prove (`!r r' s (h:A->B) (x:V->B) k p. ring_homomorphism(r,r') h /\ @@ -20241,6 +20436,19 @@ let POLY_EVALUATE_POW = prove ring_pow r (poly_evaluate r p x) n`, SIMP_TAC[poly_evaluate; POLY_EXTEND_POW; I_THM; RING_HOMOMORPHISM_I]);; +let POLY_EVALUATE_RING_PRODUCT = prove + (`!(r:A ring) (v:V->bool) (s:W->bool) f x. + (!i. i IN v ==> x i IN ring_carrier r) /\ + FINITE s /\ + (!a. a IN s ==> f a IN ring_carrier(poly_ring r v)) + ==> poly_evaluate r + (ring_product (poly_ring r v) s f) x = + ring_product r s + (\a. poly_evaluate r (f a) x)`, + REPEAT STRIP_TAC THEN REWRITE_TAC[poly_evaluate] THEN + MATCH_MP_TAC POLY_EXTEND_RING_PRODUCT THEN + ASM_REWRITE_TAC[RING_HOMOMORPHISM_I] THEN ASM SET_TAC[]);; + let RING_HOMOMORPHISM_POLY_EVALUATE = prove (`!r s (x:V->A). IMAGE x s SUBSET ring_carrier r @@ -20381,6 +20589,17 @@ let POLY_EVAL_POW = prove ring_pow r (poly_eval r p x) n`, SIMP_TAC[poly_eval; POLY_EVALUATE_POW]);; +let POLY_EVAL_RING_PRODUCT = prove + (`!(r:A ring) (s:W->bool) (f:W->(1->num)->A) (x:A). + x IN ring_carrier r /\ FINITE s /\ + (!a. a IN s ==> f a IN ring_carrier(poly_ring r (:1))) + ==> poly_eval r + (ring_product (poly_ring r (:1)) s f) x = + ring_product r s (\a. poly_eval r (f a) x)`, + REPEAT STRIP_TAC THEN REWRITE_TAC[poly_eval] THEN + MATCH_MP_TAC POLY_EVALUATE_RING_PRODUCT THEN + ASM_REWRITE_TAC[SUBSET; FORALL_IN_IMAGE]);; + let RING_HOMOMORPHISM_POLY_EVAL = prove (`!r s x:A. x IN ring_carrier r @@ -20659,6 +20878,89 @@ let RING_ISOMORPHISM_POLY_RINGS = prove REWRITE_TAC[GSYM RING_MONOMORPHISM_EPIMORPHISM] THEN SIMP_TAC[RING_MONOMORPHISM_POLY_RINGS; RING_EPIMORPHISM_POLY_RINGS]);; +let POLY_COMPOSE_HOMOMORPHISM_VAR = prove + (`!(r:A ring) (r':B ring) (f:A->B) (i:V). + ring_homomorphism(r,r') f + ==> f o poly_var r i = poly_var r' i`, + REPEAT STRIP_TAC THEN REWRITE_TAC[FUN_EQ_THM; o_THM; poly_var] THEN + X_GEN_TAC `m:V->num` THEN COND_CASES_TAC THENL + [ASM_MESON_TAC[RING_HOMOMORPHISM_1]; + ASM_MESON_TAC[RING_HOMOMORPHISM_0]]);; + +let POLY_COMPOSE_HOMOMORPHISM_CONST = prove + (`!(r:A ring) (r':B ring) (f:A->B) (c:A). + ring_homomorphism(r,r') f /\ c IN ring_carrier r + ==> f o (poly_const r c:(V->num)->A) = poly_const r' (f c)`, + REPEAT STRIP_TAC THEN REWRITE_TAC[FUN_EQ_THM; o_THM; poly_const] THEN + X_GEN_TAC `m:V->num` THEN + COND_CASES_TAC THEN ASM_MESON_TAC[RING_HOMOMORPHISM_0]);; + +let POLY_COMPOSE_HOMOMORPHISM_NEG = prove + (`!(r:A ring) (r':B ring) (f:A->B) (p:(V->num)->A). + ring_homomorphism(r,r') f /\ ring_powerseries r p + ==> f o poly_neg r p = poly_neg r' (f o p)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPECL [`r:A ring`; `r':B ring`; `f:A->B`; `(:V)`] + RING_HOMOMORPHISM_POWSER_RINGS) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o MATCH_MP RING_HOMOMORPHISM_NEG) THEN + DISCH_THEN(MP_TAC o SPEC `p:(V->num)->A`) THEN + ASM_REWRITE_TAC[GSYM RING_POWERSERIES] THEN + REWRITE_TAC[POWSER_RING_CLAUSES] THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN DISCH_THEN ACCEPT_TAC);; + +let [POLY_COMPOSE_HOMOMORPHISM_MUL; + POLY_COMPOSE_HOMOMORPHISM_SUB; + POLY_COMPOSE_HOMOMORPHISM_ADD] = (CONJUNCTS o prove) + (`(!(r:A ring) (r':B ring) (f:A->B) + (p:(V->num)->A) (q:(V->num)->A). + ring_homomorphism(r,r') f /\ + ring_powerseries r p /\ ring_powerseries r q + ==> f o poly_mul r p q = + poly_mul r' (f o p) (f o q)) /\ + (!(r:A ring) (r':B ring) (f:A->B) + (p:(V->num)->A) (q:(V->num)->A). + ring_homomorphism(r,r') f /\ + ring_powerseries r p /\ ring_powerseries r q + ==> f o poly_sub r p q = + poly_sub r' (f o p) (f o q)) /\ + (!(r:A ring) (r':B ring) (f:A->B) + (p:(V->num)->A) (q:(V->num)->A). + ring_homomorphism(r,r') f /\ + ring_powerseries r p /\ ring_powerseries r q + ==> f o poly_add r p q = + poly_add r' (f o p) (f o q))`, + let POLY_COMPOSE_HOM_TAC thm : tactic = + REPEAT GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPECL [`r:A ring`; `r':B ring`; `f:A->B`; `(:V)`] + RING_HOMOMORPHISM_POWSER_RINGS) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o MATCH_MP thm) THEN + DISCH_THEN(MP_TAC o SPECL + [`p:(V->num)->A`; `q:(V->num)->A`]) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[GSYM RING_POWERSERIES]; + ALL_TAC] THEN + REWRITE_TAC[POWSER_RING_CLAUSES] THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + DISCH_THEN ACCEPT_TAC in + REPEAT CONJ_TAC THENL + [POLY_COMPOSE_HOM_TAC RING_HOMOMORPHISM_MUL; + POLY_COMPOSE_HOM_TAC RING_HOMOMORPHISM_SUB; + POLY_COMPOSE_HOM_TAC RING_HOMOMORPHISM_ADD]);; + +let POLY_COMPOSE_HOMOMORPHISM_POW = prove + (`!(r:A ring) (r':B ring) (f:A->B) (p:(V->num)->A) n. + ring_homomorphism(r,r') f /\ ring_powerseries r p + ==> f o poly_pow r p n = poly_pow r' (f o p) n`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPECL [`r:A ring`; `r':B ring`; `f:A->B`; `(:V)`] + RING_HOMOMORPHISM_POWSER_RINGS) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o MATCH_MP RING_HOMOMORPHISM_POW) THEN + DISCH_THEN(MP_TAC o SPECL [`p:(V->num)->A`; `n:num`]) THEN + ASM_REWRITE_TAC[GSYM RING_POWERSERIES] THEN + REWRITE_TAC[POWSER_RING_CLAUSES] THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN DISCH_THEN ACCEPT_TAC);; + (* ------------------------------------------------------------------------- *) (* Zerodivisors, nilpotents and units in polynomial and power series rings. *) (* ------------------------------------------------------------------------- *) @@ -20879,6 +21181,42 @@ let FIELD_POLY_RING = prove REWRITE_TAC[POLY_RING; GSYM POLY_CONST_0; POLY_VAR_EQ_CONST] THEN ASM_SIMP_TAC[poly_var; MONOMIAL_VAR_1; NOT_IMP; RING_UNIT_0]);; +let POLY_DEG_UNIT = prove + (`!(r:A ring) (s:V->bool) p. + integral_domain r /\ ring_unit (poly_ring r s) p ==> poly_deg r p = 0`, + MESON_TAC[RING_UNIT_POLY_DOMAIN; POLY_DEG_CONST]);; + +let POLY_DEG_EQ_0_UNIT = prove + (`!(f:A ring) (s:V->bool) p. + field f /\ ring_polynomial f p + ==> (poly_deg f p = 0 <=> + ring_unit(poly_ring f s) p \/ p = ring_0(poly_ring f s))`, + SIMP_TAC[POLY_DEG_EQ_0; RING_UNIT_POLY_DOMAIN; FIELD_IMP_INTEGRAL_DOMAIN; + FIELD_UNIT] THEN + MESON_TAC[POLY_CONST_0; RING_0; POLY_RING]);; + +let POLY_DEG_1_IMP_IRREDUCIBLE = prove + (`!(f:A ring) (s:V->bool) p. + field f /\ p IN ring_carrier(poly_ring f s) /\ poly_deg f p = 1 + ==> ring_irreducible (poly_ring f s) p`, + REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[ring_irreducible] THEN + MATCH_MP_TAC(TAUT `(p /\ q) /\ (p /\ q ==> r) ==> p /\ q /\ r`) THEN + CONJ_TAC THENL + [ASM_MESON_TAC[IN_POLY_RING_CARRIER; POLY_DEG_EQ_0_UNIT; + ARITH_RULE `~(1 = 0)`]; + REWRITE_TAC[IN_POLY_RING_CARRIER] THEN STRIP_TAC] THEN + RULE_ASSUM_TAC(REWRITE_RULE[IN_POLY_RING_CARRIER; POLY_RING]) THEN + MAP_EVERY X_GEN_TAC [`q:(V->num)->A`; `r:(V->num)->A`] THEN + REPEAT(DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) THEN + ASM_CASES_TAC `q:(V->num)->A = poly_0 f` THEN + ASM_SIMP_TAC[POLY_MUL_0; POLY_RING] THEN + ASM_CASES_TAC `r:(V->num)->A = poly_0 f` THEN + ASM_SIMP_TAC[POLY_MUL_0; POLY_RING] THEN DISCH_TAC THEN + UNDISCH_TAC `poly_deg f (p:(V->num)->A) = 1` THEN EXPAND_TAC "p" THEN + ASM_SIMP_TAC[POLY_DEG_MUL; FIELD_IMP_INTEGRAL_DOMAIN] THEN + DISCH_THEN(MP_TAC o MATCH_MP(ARITH_RULE `a + b = 1 ==> a = 0 \/ b = 0`)) THEN + ASM_SIMP_TAC[POLY_DEG_EQ_0_UNIT] THEN ASM_MESON_TAC[POLY_RING]);; + let RING_UNIT_POWSER_RING = prove (`!(r:A ring) (s:V->bool) p. ring_unit (powser_ring r s) p <=> @@ -20993,6 +21331,34 @@ let LOCAL_POWSER_RING = prove (* X - a divides p(X) - p(a) and consequences like finiteness of roots. *) (* ------------------------------------------------------------------------- *) +let POLY_DEG_X_MINUS_A = prove + (`!r (a:A). + ~trivial_ring r /\ a IN ring_carrier r + ==> poly_deg r (poly_sub r (poly_var r (one:1)) (poly_const r a)) = 1`, + REPEAT STRIP_TAC THEN MP_TAC(ISPECL [`r:A ring`; + `poly_var (r:A ring) (one:1):(1->num)->A`; + `poly_const (r:A ring) (a:A):(1->num)->A`] POLY_DEG_SUB) THEN + ASM_REWRITE_TAC[RING_POLYNOMIAL_VAR; RING_POLYNOMIAL_CONST; + POLY_DEG_VAR; POLY_DEG_CONST; + GSYM TRIVIAL_RING_10] THEN ARITH_TAC);; + +let POLY_X_MINUS_A_NONZERO = prove + (`!r (a:A). + ~trivial_ring r /\ a IN ring_carrier r + ==> ~(poly_sub r (poly_var r (one:1)) + (poly_const r a) = poly_0 r)`, REPEAT STRIP_TAC THEN + MP_TAC(SPECL [`r:A ring`; `a:A`] POLY_DEG_X_MINUS_A) THEN + ASM_REWRITE_TAC[POLY_DEG_0] THEN ARITH_TAC);; + +let POLY_X_MINUS_A_IN_CARRIER = prove + (`!r (a:A). + a IN ring_carrier r + ==> poly_sub r (poly_var r (one:1)) (poly_const r a) + IN ring_carrier(poly_ring r (:1))`, + REPEAT STRIP_TAC THEN REWRITE_TAC[GSYM RING_POLYNOMIAL] THEN + MATCH_MP_TAC RING_POLYNOMIAL_SUB THEN + ASM_SIMP_TAC[RING_POLYNOMIAL_VAR; RING_POLYNOMIAL_CONST]);; + let POLY_DIVIDES_X_MINUS_A = prove (`!r (a:A) p. a IN ring_carrier r /\ p IN ring_carrier(poly_ring r (:1)) @@ -21062,6 +21428,26 @@ let POLY_DIVIDES_X_MINUS_ROOT_EQ = prove RULE_ASSUM_TAC(REWRITE_RULE[POLY_CLAUSES]) THEN ASM_SIMP_TAC[RING_SUB_REFL; RING_MUL_LZERO; POLY_EVAL]);; +let POLY_DEG_MUL_X_MINUS_A = prove + (`!r (a:A) (q:(1->num)->A). + integral_domain r /\ a IN ring_carrier r /\ + q IN ring_carrier(poly_ring r (:1)) /\ ~(q = poly_0 r) + ==> poly_deg r + (poly_mul r (poly_sub r (poly_var r (one:1)) (poly_const r a)) q) = + poly_deg r q + 1`, REPEAT STRIP_TAC THEN + SUBGOAL_THEN `~trivial_ring (r:A ring)` ASSUME_TAC THENL + [ASM_MESON_TAC[INTEGRAL_DOMAIN_IMP_NONTRIVIAL_RING]; ALL_TAC] THEN + MP_TAC(ISPECL [`r:A ring`; `poly_sub (r:A ring) (poly_var r (one:1)) + (poly_const r (a:A)):(1->num)->A`; + `q:(1->num)->A`] POLY_DEG_MUL) THEN ANTS_TAC THENL + [ASM_MESON_TAC[POLY_X_MINUS_A_NONZERO; + RING_POLYNOMIAL; RING_POLYNOMIAL_SUB; + RING_POLYNOMIAL_VAR; RING_POLYNOMIAL_CONST]; + DISCH_THEN SUBST1_TAC THEN SUBGOAL_THEN `poly_deg (r:A ring) + (poly_sub r (poly_var r (one:1)) (poly_const r (a:A))) = 1` + SUBST1_TAC THENL + [MATCH_MP_TAC POLY_DEG_X_MINUS_A THEN ASM_REWRITE_TAC[]; ARITH_TAC]]);; + let POLY_ROOT_BOUND = prove (`!(r:A ring) p. integral_domain r /\ @@ -21123,6 +21509,22 @@ let POLY_ROOT_BOUND = prove REWRITE_TAC[DISJ_ACI]; ASM_SIMP_TAC[FINITE_INSERT; CARD_CLAUSES] THEN ASM_ARITH_TAC]);; +let INFINITE_INTEGRAL_DOMAIN_POLY_EVAL_ALL_ZERO = prove + (`!r:A ring p. + integral_domain r /\ INFINITE(ring_carrier r) /\ + p IN ring_carrier(poly_ring r (:1)) /\ + (!x. x IN ring_carrier r ==> poly_eval r p x = ring_0 r) + ==> p = ring_0 (poly_ring r (:1))`, REPEAT STRIP_TAC THEN + MATCH_MP_TAC(TAUT `(~p ==> F) ==> p`) THEN DISCH_TAC THEN + MP_TAC(ISPECL [`r:A ring`; `p:(1->num)->A`] POLY_ROOT_BOUND) THEN + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `{x:A | x IN ring_carrier r /\ poly_eval r p x = ring_0 r} = + ring_carrier (r:A ring)` + SUBST1_TAC THENL [REWRITE_TAC[EXTENSION; IN_ELIM_THM] THEN + ASM_MESON_TAC[]; ALL_TAC] THEN + STRIP_TAC THEN UNDISCH_TAC `INFINITE(ring_carrier (r:A ring))` THEN + ASM_REWRITE_TAC[INFINITE]);; + (* ------------------------------------------------------------------------- *) (* More general Euclidean division of univariate polynomials. *) (* ------------------------------------------------------------------------- *) @@ -21350,6 +21752,79 @@ let PID_POLY_RING = prove ASM_SIMP_TAC[EUCLIDEAN_POLY_RING; INTEGRAL_DOMAIN_POLY_RING] THEN ASM_SIMP_TAC[FIELD_IMP_INTEGRAL_DOMAIN]);; +let POLY_DEG_1_ROOT = prove + (`!k (p:(1->num)->A). field k /\ + p IN ring_carrier(poly_ring k (:1)) /\ poly_deg k p = 1 + ==> ?x. x IN ring_carrier k /\ poly_eval k p x = ring_0 k`, + REPEAT STRIP_TAC THEN SUBGOAL_THEN `integral_domain (k:A ring) /\ + ~trivial_ring (k:A ring)` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[FIELD_IMP_INTEGRAL_DOMAIN; + FIELD_IMP_NONTRIVIAL_RING]; ALL_TAC] THEN + SUBGOAL_THEN `~(p = ring_0(poly_ring (k:A ring) (:1)))` ASSUME_TAC THENL + [DISCH_THEN SUBST_ALL_TAC THEN + RULE_ASSUM_TAC(REWRITE_RULE[POLY_RING_CLAUSES; POLY_DEG_0]) THEN + ASM_ARITH_TAC; ALL_TAC] THEN MP_TAC(ISPECL [`k:A ring`; + `poly_var (k:A ring) (one:1):(1->num)->A`; + `p:(1->num)->A`] POLY_DIVISION) THEN + ASM_REWRITE_TAC[POLY_VAR_UNIV] THEN REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`q:(1->num)->A`; `t:(1->num)->A`] THEN + REWRITE_TAC[POLY_RING_CLAUSES] THEN + DISCH_THEN(fun th -> MAP_EVERY ASSUME_TAC (CONJUNCTS th)) THEN + RULE_ASSUM_TAC(REWRITE_RULE[POLY_RING_CLAUSES; IN_ELIM_THM]) THEN + SUBGOAL_THEN `poly_deg (k:A ring) (t:(1->num)->A) = 0` ASSUME_TAC THENL + [FIRST_X_ASSUM(DISJ_CASES_TAC) THENL + [ASM_ARITH_TAC; ASM_REWRITE_TAC[POLY_DEG_0]]; ALL_TAC] THEN SUBGOAL_THEN + `?c:A. c IN ring_carrier k /\ (t:(1->num)->A) = poly_const (k:A ring) c` + STRIP_ASSUME_TAC THENL + [MP_TAC(ISPECL [`k:A ring`; `t:(1->num)->A`] POLY_DEG_EQ_0) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `~(q:(1->num)->A = poly_0 k)` ASSUME_TAC THENL [DISCH_TAC THEN + UNDISCH_TAC `poly_add (k:A ring) (poly_mul k q p) t = + poly_var k (one:1)` THEN ASM_REWRITE_TAC[] THEN + ASM_SIMP_TAC[CONJUNCT2 POLY_MUL_0; POLY_ADD_LZERO; + RING_POLYNOMIAL_IMP_POWERSERIES; RING_POLYNOMIAL_CONST] THEN + DISCH_THEN(MP_TAC o AP_TERM + `\(pp:(1->num)->A). poly_deg (k:A ring) pp`) THEN + BETA_TAC THEN REWRITE_TAC[POLY_DEG_VAR; POLY_DEG_CONST; + GSYM TRIVIAL_RING_10] THEN + ASM_REWRITE_TAC[] THEN ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `poly_deg (k:A ring) (q:(1->num)->A) = 0` ASSUME_TAC THENL + [SUBGOAL_THEN `poly_deg (k:A ring) (poly_mul k q p:(1->num)->A) = + poly_deg k q + poly_deg k p` + ASSUME_TAC THENL [MATCH_MP_TAC POLY_DEG_MUL THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `poly_deg (k:A ring) + (poly_add k (poly_mul k q p) (t:(1->num)->A)) = + MAX (poly_deg k (poly_mul k q p)) (poly_deg k t)` ASSUME_TAC THENL + [MATCH_MP_TAC POLY_DEG_ADD THEN + ASM_SIMP_TAC[RING_POLYNOMIAL_MUL] THEN ASM_ARITH_TAC; ALL_TAC] THEN + UNDISCH_TAC `poly_add (k:A ring) (poly_mul k q p) (t:(1->num)->A) = + poly_var k (one:1)` THEN DISCH_THEN(MP_TAC o AP_TERM + `\(pp:(1->num)->A). poly_deg (k:A ring) pp`) THEN + BETA_TAC THEN ASM_REWRITE_TAC[POLY_DEG_VAR; + GSYM TRIVIAL_RING_10] THEN ASM_ARITH_TAC; + ALL_TAC] THEN + SUBGOAL_THEN + `?d:A. d IN ring_carrier k /\ (q:(1->num)->A) = poly_const (k:A ring) d` + STRIP_ASSUME_TAC THENL + [MP_TAC(ISPECL [`k:A ring`; `q:(1->num)->A`] POLY_DEG_EQ_0) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `~(d:A = ring_0 k)` ASSUME_TAC THENL + [ASM_MESON_TAC[POLY_CONST_0]; ALL_TAC] THEN + EXISTS_TAC `c:A` THEN ASM_REWRITE_TAC[] THEN UNDISCH_TAC + `poly_add (k:A ring) (poly_mul k q p) (t:(1->num)->A) = + poly_var k (one:1)` THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o AP_TERM + `\(pp:(1->num)->A). poly_eval (k:A ring) pp (c:A)`) THEN BETA_TAC THEN + ASM_SIMP_TAC[POLY_EVAL_ADD; POLY_EVAL_MUL; POLY_EVAL_CONST; + POLY_EVAL_VAR; RING_POLYNOMIAL_MUL; RING_POLYNOMIAL_CONST] THEN + DISCH_TAC THEN SUBGOAL_THEN + `ring_mul (k:A ring) (d:A) (poly_eval k (p:(1->num)->A) (c:A)) = + ring_0 k` ASSUME_TAC THENL + [ASM_MESON_TAC[RING_ADD_RCANCEL; RING_ADD_LZERO; RING_MUL; RING_0; + POLY_EVAL]; ALL_TAC] THEN + ASM_MESON_TAC[INTEGRAL_DOMAIN_MUL_EQ_0; RING_MUL; POLY_EVAL]);; + (* ------------------------------------------------------------------------- *) (* The Frobenius automorphism. *) (* ------------------------------------------------------------------------- *) diff --git a/Multivariate/complex_database.ml b/Multivariate/complex_database.ml index cf8ae137..8eb6462e 100644 --- a/Multivariate/complex_database.ml +++ b/Multivariate/complex_database.ml @@ -555,6 +555,7 @@ theorems := "ALEXANDER_SUBBASE_THEOREM_ALT",ALEXANDER_SUBBASE_THEOREM_ALT; "ALEXANDROFF_COMPACTIFICATION_DENSE",ALEXANDROFF_COMPACTIFICATION_DENSE; "ALEXANDROFF_COMPACTIFICATION_UNIQUE",ALEXANDROFF_COMPACTIFICATION_UNIQUE; +"ALEXANDROFF_HAUSDORFF",ALEXANDROFF_HAUSDORFF; "ALL",ALL; "ALL2",ALL2; "ALL2_ALL",ALL2_ALL; @@ -1453,6 +1454,27 @@ theorems := "CANTOR_BAIRE_STATIONARY_PRINCIPLE",CANTOR_BAIRE_STATIONARY_PRINCIPLE; "CANTOR_BENDIXSON",CANTOR_BENDIXSON; "CANTOR_BENDIXSON_GEN",CANTOR_BENDIXSON_GEN; +"CANTOR_MAP_CLOSED_IMAGE",CANTOR_MAP_CLOSED_IMAGE; +"CANTOR_MAP_CLOSED_IN_INTERVAL",CANTOR_MAP_CLOSED_IN_INTERVAL; +"CANTOR_MAP_CONTINUOUS",CANTOR_MAP_CONTINUOUS; +"CANTOR_MAP_EMBEDDING",CANTOR_MAP_EMBEDDING; +"CANTOR_MAP_GE_PARTIAL_SUM",CANTOR_MAP_GE_PARTIAL_SUM; +"CANTOR_MAP_IMAGE_SUBSET_INTERVAL",CANTOR_MAP_IMAGE_SUBSET_INTERVAL; +"CANTOR_MAP_INJECTIVE",CANTOR_MAP_INJECTIVE; +"CANTOR_MAP_LE_ONE",CANTOR_MAP_LE_ONE; +"CANTOR_MAP_PARTIAL_SUM_BOUND",CANTOR_MAP_PARTIAL_SUM_BOUND; +"CANTOR_MAP_POS",CANTOR_MAP_POS; +"CANTOR_MAP_RANGE",CANTOR_MAP_RANGE; +"CANTOR_MAP_STRICT_LT",CANTOR_MAP_STRICT_LT; +"CANTOR_MAP_SUMMABLE",CANTOR_MAP_SUMMABLE; +"CANTOR_MAP_SUMS",CANTOR_MAP_SUMS; +"CANTOR_PARTIAL_SUM_DIFF_AT_K",CANTOR_PARTIAL_SUM_DIFF_AT_K; +"CANTOR_PARTIAL_SUM_MONO",CANTOR_PARTIAL_SUM_MONO; +"CANTOR_SET_SUBSET_INTERVAL",CANTOR_SET_SUBSET_INTERVAL; +"CANTOR_SPACE_HOMEOMORPHIC_CANTOR_SET",CANTOR_SPACE_HOMEOMORPHIC_CANTOR_SET; +"CANTOR_TERM_BOUND",CANTOR_TERM_BOUND; +"CANTOR_TERM_CONTINUOUS",CANTOR_TERM_CONTINUOUS; +"CANTOR_TERM_POS",CANTOR_TERM_POS; "CANTOR_THM",CANTOR_THM; "CANTOR_THM_UNIV",CANTOR_THM_UNIV; "CAPPED_METRIC",CAPPED_METRIC; @@ -2029,11 +2051,14 @@ theorems := "CHAIN_BOUNDARY_SINGULAR_SUBDIVISION",CHAIN_BOUNDARY_SINGULAR_SUBDIVISION; "CHAIN_BOUNDARY_SUB",CHAIN_BOUNDARY_SUB; "CHAIN_BOUNDARY_SUM",CHAIN_BOUNDARY_SUM; +"CHAIN_FROM_OPEN_COVER",CHAIN_FROM_OPEN_COVER; "CHAIN_GROUP",CHAIN_GROUP; +"CHAIN_HIERARCHY",CHAIN_HIERARCHY; "CHAIN_HOMOTOPIC_IMP_HOMOLOGOUS_REL",CHAIN_HOMOTOPIC_IMP_HOMOLOGOUS_REL; "CHAIN_HOMOTOPIC_ITERATED_SINGULAR_SUBDIVISION",CHAIN_HOMOTOPIC_ITERATED_SINGULAR_SUBDIVISION; "CHAIN_HOMOTOPIC_SIMPLICIAL_SUBDIVISION",CHAIN_HOMOTOPIC_SIMPLICIAL_SUBDIVISION; "CHAIN_HOMOTOPIC_SINGULAR_SUBDIVISION",CHAIN_HOMOTOPIC_SINGULAR_SUBDIVISION; +"CHAIN_IN_OPEN_CONNECTED_SET",CHAIN_IN_OPEN_CONNECTED_SET; "CHAIN_MAP_0",CHAIN_MAP_0; "CHAIN_MAP_ADD",CHAIN_MAP_ADD; "CHAIN_MAP_CMUL",CHAIN_MAP_CMUL; @@ -2047,6 +2072,7 @@ theorems := "CHAIN_MAP_SIMPLICIAL_CONE",CHAIN_MAP_SIMPLICIAL_CONE; "CHAIN_MAP_SUB",CHAIN_MAP_SUB; "CHAIN_MAP_SUM",CHAIN_MAP_SUM; +"CHAIN_REFINEMENT_STEP",CHAIN_REFINEMENT_STEP; "CHAIN_SUBSET",CHAIN_SUBSET; "CHARACTERISTIC_POLYNOMIAL",CHARACTERISTIC_POLYNOMIAL; "CHINESE_REMAINDER",CHINESE_REMAINDER; @@ -2175,6 +2201,8 @@ theorems := "CLOSED_IN_ALEXANDROFF_COMPACTIFICATION_IMAGE_INL",CLOSED_IN_ALEXANDROFF_COMPACTIFICATION_IMAGE_INL; "CLOSED_IN_ANALYTIC",CLOSED_IN_ANALYTIC; "CLOSED_IN_BOREL",CLOSED_IN_BOREL; +"CLOSED_IN_CANTOR_SET",CLOSED_IN_CANTOR_SET; +"CLOSED_IN_CANTOR_SET_INTERVAL",CLOSED_IN_CANTOR_SET_INTERVAL; "CLOSED_IN_CARTESIAN_PRODUCT",CLOSED_IN_CARTESIAN_PRODUCT; "CLOSED_IN_CLOSED",CLOSED_IN_CLOSED; "CLOSED_IN_CLOSED_EQ",CLOSED_IN_CLOSED_EQ; @@ -2457,6 +2485,7 @@ theorems := "CLOSURE_OF_CLOSURE_OF",CLOSURE_OF_CLOSURE_OF; "CLOSURE_OF_COMPLEMENT",CLOSURE_OF_COMPLEMENT; "CLOSURE_OF_CROSS",CLOSURE_OF_CROSS; +"CLOSURE_OF_DYADIC_RATIONALS_IN_UNIT_INTERVAL",CLOSURE_OF_DYADIC_RATIONALS_IN_UNIT_INTERVAL; "CLOSURE_OF_EMPTY",CLOSURE_OF_EMPTY; "CLOSURE_OF_EQ",CLOSURE_OF_EQ; "CLOSURE_OF_EQ_EMPTY",CLOSURE_OF_EQ_EMPTY; @@ -2642,6 +2671,8 @@ theorems := "COMPACT_CLOSURE_OF_IMP_TOTALLY_BOUNDED_IN",COMPACT_CLOSURE_OF_IMP_TOTALLY_BOUNDED_IN; "COMPACT_COMPONENTS",COMPACT_COMPONENTS; "COMPACT_CONNECTED_COMPONENT",COMPACT_CONNECTED_COMPONENT; +"COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED",COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED; +"COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN",COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN; "COMPACT_CONTINUOUS_IMAGE",COMPACT_CONTINUOUS_IMAGE; "COMPACT_CONTINUOUS_IMAGE_EQ",COMPACT_CONTINUOUS_IMAGE_EQ; "COMPACT_CONVEX_COLLINEAR_SEGMENT",COMPACT_CONVEX_COLLINEAR_SEGMENT; @@ -2676,6 +2707,7 @@ theorems := "COMPACT_IMP_K_SPACE",COMPACT_IMP_K_SPACE; "COMPACT_IMP_LINDELOF_SPACE",COMPACT_IMP_LINDELOF_SPACE; "COMPACT_IMP_LOCALLY_COMPACT_SPACE",COMPACT_IMP_LOCALLY_COMPACT_SPACE; +"COMPACT_IMP_PARACOMPACT_SPACE",COMPACT_IMP_PARACOMPACT_SPACE; "COMPACT_IMP_PERFECT_MAP",COMPACT_IMP_PERFECT_MAP; "COMPACT_IMP_PROPER_MAP",COMPACT_IMP_PROPER_MAP; "COMPACT_IMP_PROPER_MAP_GEN",COMPACT_IMP_PROPER_MAP_GEN; @@ -2707,6 +2739,11 @@ theorems := "COMPACT_IN_IMP_TOTALLY_BOUNDED_IN_EXPLICIT",COMPACT_IN_IMP_TOTALLY_BOUNDED_IN_EXPLICIT; "COMPACT_IN_INTER",COMPACT_IN_INTER; "COMPACT_IN_KIFICATION",COMPACT_IN_KIFICATION; +"COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE",COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE; +"COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE_ALT",COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE_ALT; +"COMPACT_IN_LOCALLY_CONNECTED_IMP_FCCOVERABLE_SPACE",COMPACT_IN_LOCALLY_CONNECTED_IMP_FCCOVERABLE_SPACE; +"COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE",COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE; +"COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE_ALT",COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE_ALT; "COMPACT_IN_MSPACE_CFUNSPACE",COMPACT_IN_MSPACE_CFUNSPACE; "COMPACT_IN_PATH_IMAGE",COMPACT_IN_PATH_IMAGE; "COMPACT_IN_PROPER_MAP_PREIMAGE",COMPACT_IN_PROPER_MAP_PREIMAGE; @@ -2715,13 +2752,16 @@ theorems := "COMPACT_IN_SEQUENTIALLY",COMPACT_IN_SEQUENTIALLY; "COMPACT_IN_SING",COMPACT_IN_SING; "COMPACT_IN_STANDARD_SIMPLEX",COMPACT_IN_STANDARD_SIMPLEX; +"COMPACT_IN_SUBMETRIC_EUCLIDEAN_MSPACE",COMPACT_IN_SUBMETRIC_EUCLIDEAN_MSPACE; "COMPACT_IN_SUBSET_TOPSPACE",COMPACT_IN_SUBSET_TOPSPACE; "COMPACT_IN_SUBSPACE",COMPACT_IN_SUBSPACE; "COMPACT_IN_SUBTOPOLOGY",COMPACT_IN_SUBTOPOLOGY; +"COMPACT_IN_SUBTOPOLOGY_EUCLIDEAN",COMPACT_IN_SUBTOPOLOGY_EUCLIDEAN; "COMPACT_IN_SUBTOPOLOGY_IMP_COMPACT",COMPACT_IN_SUBTOPOLOGY_IMP_COMPACT; "COMPACT_IN_UNION",COMPACT_IN_UNION; "COMPACT_IN_UNIONS",COMPACT_IN_UNIONS; "COMPACT_KC_EQ_MAXIMAL_COMPACT_SPACE",COMPACT_KC_EQ_MAXIMAL_COMPACT_SPACE; +"COMPACT_LF_OPEN_NEIGHBORHOOD",COMPACT_LF_OPEN_NEIGHBORHOOD; "COMPACT_LINEAR_IMAGE",COMPACT_LINEAR_IMAGE; "COMPACT_LINEAR_IMAGE_EQ",COMPACT_LINEAR_IMAGE_EQ; "COMPACT_LOCALLY_CONNECTED_EQ_FCCCOVERABLE",COMPACT_LOCALLY_CONNECTED_EQ_FCCCOVERABLE; @@ -2729,8 +2769,12 @@ theorems := "COMPACT_LOCALLY_CONNECTED_IMP_FCCOVERABLE",COMPACT_LOCALLY_CONNECTED_IMP_FCCOVERABLE; "COMPACT_LOCALLY_CONNECTED_IMP_ULC",COMPACT_LOCALLY_CONNECTED_IMP_ULC; "COMPACT_LOCALLY_CONNECTED_IMP_ULC_ALT",COMPACT_LOCALLY_CONNECTED_IMP_ULC_ALT; +"COMPACT_LOCALLY_CONNECTED_NEARBY_PATH",COMPACT_LOCALLY_CONNECTED_NEARBY_PATH; +"COMPACT_METRIZABLE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED",COMPACT_METRIZABLE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED; +"COMPACT_METRIZABLE_PEANO_IMP_PATH_CONNECTED",COMPACT_METRIZABLE_PEANO_IMP_PATH_CONNECTED; "COMPACT_NEGATIONS",COMPACT_NEGATIONS; "COMPACT_NEST",COMPACT_NEST; +"COMPACT_NESTED_INTERS",COMPACT_NESTED_INTERS; "COMPACT_OPEN",COMPACT_OPEN; "COMPACT_PARTITION_CONTAINING_CLOSED",COMPACT_PARTITION_CONTAINING_CLOSED; "COMPACT_PARTITION_CONTAINING_POINTS",COMPACT_PARTITION_CONTAINING_POINTS; @@ -2754,6 +2798,7 @@ theorems := "COMPACT_SPACE",COMPACT_SPACE; "COMPACT_SPACE_ALEXANDROFF_COMPACTIFICATION",COMPACT_SPACE_ALEXANDROFF_COMPACTIFICATION; "COMPACT_SPACE_ALT",COMPACT_SPACE_ALT; +"COMPACT_SPACE_CANTOR_SPACE",COMPACT_SPACE_CANTOR_SPACE; "COMPACT_SPACE_CONTRACTIVE",COMPACT_SPACE_CONTRACTIVE; "COMPACT_SPACE_DISCRETE_TOPOLOGY",COMPACT_SPACE_DISCRETE_TOPOLOGY; "COMPACT_SPACE_EQ_BOLZANO_WEIERSTRASS",COMPACT_SPACE_EQ_BOLZANO_WEIERSTRASS; @@ -2781,6 +2826,7 @@ theorems := "COMPACT_SUP_MAXDISTANCE",COMPACT_SUP_MAXDISTANCE; "COMPACT_TRANSLATION",COMPACT_TRANSLATION; "COMPACT_TRANSLATION_EQ",COMPACT_TRANSLATION_EQ; +"COMPACT_TUBE_COVER",COMPACT_TUBE_COVER; "COMPACT_UNIFORMLY_CONTINUOUS",COMPACT_UNIFORMLY_CONTINUOUS; "COMPACT_UNIFORMLY_EQUICONTINUOUS",COMPACT_UNIFORMLY_EQUICONTINUOUS; "COMPACT_UNION",COMPACT_UNION; @@ -2795,8 +2841,10 @@ theorems := "COMPLEMENT_PATH_COMPONENTS_OF_UNIONS",COMPLEMENT_PATH_COMPONENTS_OF_UNIONS; "COMPLEMENT_PATH_COMPONENT_UNIONS",COMPLEMENT_PATH_COMPONENT_UNIONS; "COMPLEMENT_QUASI_COMPONENTS_OF_UNIONS",COMPLEMENT_QUASI_COMPONENTS_OF_UNIONS; +"COMPLETELY_METRIZABLE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED",COMPLETELY_METRIZABLE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED; "COMPLETELY_METRIZABLE_EUCLIDEAN_SPACE",COMPLETELY_METRIZABLE_EUCLIDEAN_SPACE; "COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE",COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE; +"COMPLETELY_METRIZABLE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED",COMPLETELY_METRIZABLE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED; "COMPLETELY_METRIZABLE_SPACE_CLOSED_IN",COMPLETELY_METRIZABLE_SPACE_CLOSED_IN; "COMPLETELY_METRIZABLE_SPACE_DISCRETE_TOPOLOGY",COMPLETELY_METRIZABLE_SPACE_DISCRETE_TOPOLOGY; "COMPLETELY_METRIZABLE_SPACE_EQ_GDELTA_IN",COMPLETELY_METRIZABLE_SPACE_EQ_GDELTA_IN; @@ -3284,7 +3332,9 @@ theorems := "CONNECTED_COMPONENT_OF_EQUIV",CONNECTED_COMPONENT_OF_EQUIV; "CONNECTED_COMPONENT_OF_EQ_EMPTY",CONNECTED_COMPONENT_OF_EQ_EMPTY; "CONNECTED_COMPONENT_OF_EQ_OVERLAP",CONNECTED_COMPONENT_OF_EQ_OVERLAP; +"CONNECTED_COMPONENT_OF_EQ_WELLCHAINED",CONNECTED_COMPONENT_OF_EQ_WELLCHAINED; "CONNECTED_COMPONENT_OF_EUCLIDEAN",CONNECTED_COMPONENT_OF_EUCLIDEAN; +"CONNECTED_COMPONENT_OF_IMP_WELLCHAINED",CONNECTED_COMPONENT_OF_IMP_WELLCHAINED; "CONNECTED_COMPONENT_OF_MAXIMAL",CONNECTED_COMPONENT_OF_MAXIMAL; "CONNECTED_COMPONENT_OF_MONO",CONNECTED_COMPONENT_OF_MONO; "CONNECTED_COMPONENT_OF_NONOVERLAP",CONNECTED_COMPONENT_OF_NONOVERLAP; @@ -3347,6 +3397,7 @@ theorems := "CONNECTED_EQ_CONNECTED_COMPONENT_EQ",CONNECTED_EQ_CONNECTED_COMPONENT_EQ; "CONNECTED_EQ_NONSEPARATED_CLOSED_COMPLEMENT_COMPONENT",CONNECTED_EQ_NONSEPARATED_CLOSED_COMPLEMENT_COMPONENT; "CONNECTED_EQ_WELLCHAINED",CONNECTED_EQ_WELLCHAINED; +"CONNECTED_EQ_WELLCHAINED_IN",CONNECTED_EQ_WELLCHAINED_IN; "CONNECTED_EUCLIDEAN_SPACE",CONNECTED_EUCLIDEAN_SPACE; "CONNECTED_FINITE_EQ_LOWDIM",CONNECTED_FINITE_EQ_LOWDIM; "CONNECTED_FINITE_IFF_COUNTABLE",CONNECTED_FINITE_IFF_COUNTABLE; @@ -3384,6 +3435,9 @@ theorems := "CONNECTED_INTER_RELATIVE_FRONTIER",CONNECTED_INTER_RELATIVE_FRONTIER; "CONNECTED_IN_ABSOLUTE",CONNECTED_IN_ABSOLUTE; "CONNECTED_IN_CARTESIAN_PRODUCT",CONNECTED_IN_CARTESIAN_PRODUCT; +"CONNECTED_IN_CHAIN",CONNECTED_IN_CHAIN; +"CONNECTED_IN_CHAIN_GEN",CONNECTED_IN_CHAIN_GEN; +"CONNECTED_IN_CHAIN_UNIONS",CONNECTED_IN_CHAIN_UNIONS; "CONNECTED_IN_CLOPEN_CASES",CONNECTED_IN_CLOPEN_CASES; "CONNECTED_IN_CLOSED_IN",CONNECTED_IN_CLOSED_IN; "CONNECTED_IN_CLOSURE_OF",CONNECTED_IN_CLOSURE_OF; @@ -3400,11 +3454,15 @@ theorems := "CONNECTED_IN_EUCLIDEANREAL",CONNECTED_IN_EUCLIDEANREAL; "CONNECTED_IN_EUCLIDEANREAL_INTERVAL",CONNECTED_IN_EUCLIDEANREAL_INTERVAL; "CONNECTED_IN_EUCLIDEAN_COMPLEMENTS",CONNECTED_IN_EUCLIDEAN_COMPLEMENTS; +"CONNECTED_IN_IFF_CONNECTED_COMPONENT_OF",CONNECTED_IN_IFF_CONNECTED_COMPONENT_OF; "CONNECTED_IN_IMP_PERFECT",CONNECTED_IN_IMP_PERFECT; "CONNECTED_IN_IMP_PERFECT_GEN",CONNECTED_IN_IMP_PERFECT_GEN; +"CONNECTED_IN_IMP_WELLCHAINED",CONNECTED_IN_IMP_WELLCHAINED; "CONNECTED_IN_INTERMEDIATE_CLOSURE_OF",CONNECTED_IN_INTERMEDIATE_CLOSURE_OF; "CONNECTED_IN_INTER_FRONTIER_OF",CONNECTED_IN_INTER_FRONTIER_OF; "CONNECTED_IN_MONOTONE_QUOTIENT_MAP_PREIMAGE",CONNECTED_IN_MONOTONE_QUOTIENT_MAP_PREIMAGE; +"CONNECTED_IN_NEST",CONNECTED_IN_NEST; +"CONNECTED_IN_NEST_GEN",CONNECTED_IN_NEST_GEN; "CONNECTED_IN_NONSEPARATED_UNION",CONNECTED_IN_NONSEPARATED_UNION; "CONNECTED_IN_PATH_IMAGE",CONNECTED_IN_PATH_IMAGE; "CONNECTED_IN_SEPARATION",CONNECTED_IN_SEPARATION; @@ -3412,12 +3470,16 @@ theorems := "CONNECTED_IN_SING",CONNECTED_IN_SING; "CONNECTED_IN_SPHERE_DELETE_INTERIOR_POINT_EQ",CONNECTED_IN_SPHERE_DELETE_INTERIOR_POINT_EQ; "CONNECTED_IN_STANDARD_SIMPLEX",CONNECTED_IN_STANDARD_SIMPLEX; +"CONNECTED_IN_SUBMETRIC_EUCLIDEAN",CONNECTED_IN_SUBMETRIC_EUCLIDEAN; +"CONNECTED_IN_SUBMETRIC_EUCLIDEAN_MSPACE",CONNECTED_IN_SUBMETRIC_EUCLIDEAN_MSPACE; "CONNECTED_IN_SUBSET_SEPARATED_UNION",CONNECTED_IN_SUBSET_SEPARATED_UNION; "CONNECTED_IN_SUBSET_TOPSPACE",CONNECTED_IN_SUBSET_TOPSPACE; "CONNECTED_IN_SUBTOPOLOGY",CONNECTED_IN_SUBTOPOLOGY; +"CONNECTED_IN_SUBTOPOLOGY_EUCLIDEAN",CONNECTED_IN_SUBTOPOLOGY_EUCLIDEAN; "CONNECTED_IN_TOPSPACE",CONNECTED_IN_TOPSPACE; "CONNECTED_IN_UNION",CONNECTED_IN_UNION; "CONNECTED_IN_UNIONS",CONNECTED_IN_UNIONS; +"CONNECTED_IN_UNIONS_STRONG",CONNECTED_IN_UNIONS_STRONG; "CONNECTED_IVT_COMPONENT",CONNECTED_IVT_COMPONENT; "CONNECTED_IVT_HYPERPLANE",CONNECTED_IVT_HYPERPLANE; "CONNECTED_JACOBIAN_GRAPH",CONNECTED_JACOBIAN_GRAPH; @@ -3859,6 +3921,7 @@ theorems := "CONTINUOUS_MAP_SQRT",CONTINUOUS_MAP_SQRT; "CONTINUOUS_MAP_SQUARE_ROOT",CONTINUOUS_MAP_SQUARE_ROOT; "CONTINUOUS_MAP_SUM",CONTINUOUS_MAP_SUM; +"CONTINUOUS_MAP_SUM_LOCALLY_FINITE",CONTINUOUS_MAP_SUM_LOCALLY_FINITE; "CONTINUOUS_MAP_SUP",CONTINUOUS_MAP_SUP; "CONTINUOUS_MAP_TO_METRIC",CONTINUOUS_MAP_TO_METRIC; "CONTINUOUS_MAP_UNIFORMLY_CAUCHY_LIMIT",CONTINUOUS_MAP_UNIFORMLY_CAUCHY_LIMIT; @@ -4595,6 +4658,7 @@ theorems := "COUNTABLE_IMP_DISCONNECTED",COUNTABLE_IMP_DISCONNECTED; "COUNTABLE_IMP_FSIGMA",COUNTABLE_IMP_FSIGMA; "COUNTABLE_IMP_LINDELOF_SPACE",COUNTABLE_IMP_LINDELOF_SPACE; +"COUNTABLE_IMP_SIGMA_LOCALLY_FINITE_IN",COUNTABLE_IMP_SIGMA_LOCALLY_FINITE_IN; "COUNTABLE_INSERT",COUNTABLE_INSERT; "COUNTABLE_INTEGER",COUNTABLE_INTEGER; "COUNTABLE_INTEGER_COORDINATES",COUNTABLE_INTEGER_COORDINATES; @@ -4912,6 +4976,7 @@ theorems := "DENSE_COMPLEMENT_CONVEX_CLOSED",DENSE_COMPLEMENT_CONVEX_CLOSED; "DENSE_COMPLEMENT_OPEN_IN_AFFINE_HULL",DENSE_COMPLEMENT_OPEN_IN_AFFINE_HULL; "DENSE_COMPLEMENT_SUBSPACE",DENSE_COMPLEMENT_SUBSPACE; +"DENSE_FUNCTION_ON_DYADIC",DENSE_FUNCTION_ON_DYADIC; "DENSE_GDELTA_IMP_LARGE",DENSE_GDELTA_IMP_LARGE; "DENSE_IMP_PERFECT",DENSE_IMP_PERFECT; "DENSE_INTERSECTS_OPEN",DENSE_INTERSECTS_OPEN; @@ -5686,6 +5751,7 @@ theorems := "EMBEDDING_IMP_MONOTONE_MAP",EMBEDDING_IMP_MONOTONE_MAP; "EMBEDDING_IMP_OPEN_MAP",EMBEDDING_IMP_OPEN_MAP; "EMBEDDING_IMP_OPEN_MAP_EQ",EMBEDDING_IMP_OPEN_MAP_EQ; +"EMBEDDING_INTO_METRIZABLE_IMP_METRIZABLE",EMBEDDING_INTO_METRIZABLE_IMP_METRIZABLE; "EMBEDDING_MAP_COMPONENT_INJECTION",EMBEDDING_MAP_COMPONENT_INJECTION; "EMBEDDING_MAP_COMPOSE",EMBEDDING_MAP_COMPOSE; "EMBEDDING_MAP_EQ",EMBEDDING_MAP_EQ; @@ -5780,6 +5846,7 @@ theorems := "ENR_TRANSLATION",ENR_TRANSLATION; "ENR_TRIANGULATION",ENR_TRIANGULATION; "ENR_UNIV",ENR_UNIV; +"EPSILON_ABSORBING_IMP_CLOPEN",EPSILON_ABSORBING_IMP_CLOPEN; "EPSILON_DELTA_MINIMAL",EPSILON_DELTA_MINIMAL; "EQUIINTEGRABLE_ADD",EQUIINTEGRABLE_ADD; "EQUIINTEGRABLE_CLOSED_INTERVAL_RESTRICTIONS",EQUIINTEGRABLE_CLOSED_INTERVAL_RESTRICTIONS; @@ -6058,6 +6125,8 @@ theorems := "EXISTS_VECTOR_4",EXISTS_VECTOR_4; "EXP",EXP; "EXPAND_CLOSED_OPEN_INTERVAL",EXPAND_CLOSED_OPEN_INTERVAL; +"EXPANSION_SET_CONTAINS",EXPANSION_SET_CONTAINS; +"EXPANSION_SET_OPEN",EXPANSION_SET_OPEN; "EXPLICIT_SUBSET_INTERIOR_CONVEX_HULL",EXPLICIT_SUBSET_INTERIOR_CONVEX_HULL; "EXPLICIT_SUBSET_INTERIOR_CONVEX_HULL_MINIMAL",EXPLICIT_SUBSET_INTERIOR_CONVEX_HULL_MINIMAL; "EXPLICIT_SUBSET_RELATIVE_INTERIOR_CONVEX_HULL",EXPLICIT_SUBSET_RELATIVE_INTERIOR_CONVEX_HULL; @@ -6260,6 +6329,14 @@ theorems := "FATOU_STRONG",FATOU_STRONG; "FCCOVERABLE_IMP_LOCALLY_CONNECTED",FCCOVERABLE_IMP_LOCALLY_CONNECTED; "FCCOVERABLE_INTERMEDIATE_CLOSURE",FCCOVERABLE_INTERMEDIATE_CLOSURE; +"FCCOVERABLE_IN_COMPACT_LOCALLY_CONNECTED",FCCOVERABLE_IN_COMPACT_LOCALLY_CONNECTED; +"FCCOVERABLE_IN_EUCLIDEAN_METRIC",FCCOVERABLE_IN_EUCLIDEAN_METRIC; +"FCCOVERABLE_IN_IMP_FCCOVERABLE_SPACE_SUBMETRIC",FCCOVERABLE_IN_IMP_FCCOVERABLE_SPACE_SUBMETRIC; +"FCCOVERABLE_IN_IMP_LOCALLY_CONNECTED_SPACE",FCCOVERABLE_IN_IMP_LOCALLY_CONNECTED_SPACE; +"FCCOVERABLE_SPACE_EQ_FCCOVERABLE_IN_MSPACE",FCCOVERABLE_SPACE_EQ_FCCOVERABLE_IN_MSPACE; +"FCCOVERABLE_SPACE_IMP_LOCALLY_CONNECTED_SPACE",FCCOVERABLE_SPACE_IMP_LOCALLY_CONNECTED_SPACE; +"FCCOVERABLE_SPACE_INTERMEDIATE_CLOSURE",FCCOVERABLE_SPACE_INTERMEDIATE_CLOSURE; +"FCCOVERABLE_SPACE_SUBMETRIC_EUCLIDEAN",FCCOVERABLE_SPACE_SUBMETRIC_EUCLIDEAN; "FCONS",FCONS; "FCONS_UNDO",FCONS_UNDO; "FGSIGMA_BAIRE_PREIMAGE_OPEN_ALT",FGSIGMA_BAIRE_PREIMAGE_OPEN_ALT; @@ -6334,6 +6411,9 @@ theorems := "FINITE_COMPONENTS_PUNCTURED_CONNECTED_SUBSET_SPHERE",FINITE_COMPONENTS_PUNCTURED_CONNECTED_SUBSET_SPHERE; "FINITE_COMPONENTS_PUNCTURED_CONVEX",FINITE_COMPONENTS_PUNCTURED_CONVEX; "FINITE_COMPONENTS_UNION",FINITE_COMPONENTS_UNION; +"FINITE_CONNECTED_COMPONENTS_CLOPEN_UNION",FINITE_CONNECTED_COMPONENTS_CLOPEN_UNION; +"FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED",FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED; +"FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED_EUCLIDEAN",FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED_EUCLIDEAN; "FINITE_CONNECTED_COMPONENTS_OF_FINITE",FINITE_CONNECTED_COMPONENTS_OF_FINITE; "FINITE_CROSS",FINITE_CROSS; "FINITE_CROSS_EQ",FINITE_CROSS_EQ; @@ -7019,6 +7099,7 @@ theorems := "GDELTA_BAIRE_PREIMAGE_CLOSED",GDELTA_BAIRE_PREIMAGE_CLOSED; "GDELTA_BAIRE_PREIMAGE_CLOSED_GEN",GDELTA_BAIRE_PREIMAGE_CLOSED_GEN; "GDELTA_COMPLEMENT",GDELTA_COMPLEMENT; +"GDELTA_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED",GDELTA_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED; "GDELTA_CONTINUOUS_FUNCTION_MINIMA",GDELTA_CONTINUOUS_FUNCTION_MINIMA; "GDELTA_DESCENDING",GDELTA_DESCENDING; "GDELTA_DIFF",GDELTA_DIFF; @@ -7051,8 +7132,10 @@ theorems := "GDELTA_IN_UNION",GDELTA_IN_UNION; "GDELTA_LINEAR_IMAGE",GDELTA_LINEAR_IMAGE; "GDELTA_LOCALLY_COMPACT",GDELTA_LOCALLY_COMPACT; +"GDELTA_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED",GDELTA_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED; "GDELTA_LOCALLY_EQ",GDELTA_LOCALLY_EQ; "GDELTA_LOCALLY_GEN",GDELTA_LOCALLY_GEN; +"GDELTA_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED",GDELTA_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED; "GDELTA_LOCALLY_TRANS",GDELTA_LOCALLY_TRANS; "GDELTA_PCROSS",GDELTA_PCROSS; "GDELTA_PCROSS_EQ",GDELTA_PCROSS_EQ; @@ -7712,6 +7795,8 @@ theorems := "HADAMARD_THREE_LINE_EXPLICIT_RE",HADAMARD_THREE_LINE_EXPLICIT_RE; "HADAMARD_THREE_LINE_IM",HADAMARD_THREE_LINE_IM; "HADAMARD_THREE_LINE_RE",HADAMARD_THREE_LINE_RE; +"HAHN_MAZURKIEWICZ",HAHN_MAZURKIEWICZ; +"HAHN_MAZURKIEWICZ_IMP",HAHN_MAZURKIEWICZ_IMP; "HAIRY_BALL_THEOREM",HAIRY_BALL_THEOREM; "HAIRY_BALL_THEOREM_ALT",HAIRY_BALL_THEOREM_ALT; "HALFSPACE_EQ_EMPTY_GE",HALFSPACE_EQ_EMPTY_GE; @@ -8536,6 +8621,7 @@ theorems := "HAUSDORFF_NORMAL_SPACE_CLOSED_CONTINUOUS_MAP_IMAGE",HAUSDORFF_NORMAL_SPACE_CLOSED_CONTINUOUS_MAP_IMAGE; "HAUSDORFF_SPACE_ALEXANDROFF_COMPACTIFICATION",HAUSDORFF_SPACE_ALEXANDROFF_COMPACTIFICATION; "HAUSDORFF_SPACE_ALEXANDROFF_COMPACTIFICATION_ASYMMETRIC_PROD",HAUSDORFF_SPACE_ALEXANDROFF_COMPACTIFICATION_ASYMMETRIC_PROD; +"HAUSDORFF_SPACE_CANTOR_SPACE",HAUSDORFF_SPACE_CANTOR_SPACE; "HAUSDORFF_SPACE_CLOSED_CONTINUOUS_MAP_IMAGE",HAUSDORFF_SPACE_CLOSED_CONTINUOUS_MAP_IMAGE; "HAUSDORFF_SPACE_CLOSED_CONTINUOUS_MAP_IMAGE_EQ",HAUSDORFF_SPACE_CLOSED_CONTINUOUS_MAP_IMAGE_EQ; "HAUSDORFF_SPACE_CLOSED_IN_DIAGONAL",HAUSDORFF_SPACE_CLOSED_IN_DIAGONAL; @@ -8849,6 +8935,7 @@ theorems := "HOMEOMORPHIC_OPEN_INTERVALS_1",HOMEOMORPHIC_OPEN_INTERVALS_1; "HOMEOMORPHIC_OPEN_INTERVAL_UNIV",HOMEOMORPHIC_OPEN_INTERVAL_UNIV; "HOMEOMORPHIC_OPEN_INTERVAL_UNIV_1",HOMEOMORPHIC_OPEN_INTERVAL_UNIV_1; +"HOMEOMORPHIC_PARACOMPACT_SPACE",HOMEOMORPHIC_PARACOMPACT_SPACE; "HOMEOMORPHIC_PATH_CONNECTEDNESS",HOMEOMORPHIC_PATH_CONNECTEDNESS; "HOMEOMORPHIC_PATH_CONNECTED_SPACE",HOMEOMORPHIC_PATH_CONNECTED_SPACE; "HOMEOMORPHIC_PCROSS",HOMEOMORPHIC_PCROSS; @@ -10553,6 +10640,7 @@ theorems := "IN_CLOSURE_CONNECTED_COMPONENT",IN_CLOSURE_CONNECTED_COMPONENT; "IN_CLOSURE_DELETE",IN_CLOSURE_DELETE; "IN_CLOSURE_OF",IN_CLOSURE_OF; +"IN_CLOSURE_OF_IMP_SUBSET_MCBALL",IN_CLOSURE_OF_IMP_SUBSET_MCBALL; "IN_COMPONENTS",IN_COMPONENTS; "IN_COMPONENTS_CONNECTED",IN_COMPONENTS_CONNECTED; "IN_COMPONENTS_MAXIMAL",IN_COMPONENTS_MAXIMAL; @@ -11311,6 +11399,9 @@ theorems := "LE_SUC",LE_SUC; "LE_SUC_LT",LE_SUC_LT; "LE_TRANS",LE_TRANS; +"LF_CLOSED_PERFECT_MAP_IMAGE",LF_CLOSED_PERFECT_MAP_IMAGE; +"LF_COVERING_IMP_LF_CLOSED",LF_COVERING_IMP_LF_CLOSED; +"LF_COVERING_IMP_LF_OPEN",LF_COVERING_IMP_LF_OPEN; "LHOSPITAL",LHOSPITAL; "LIEB",LIEB; "LIFT_ADD",LIFT_ADD; @@ -11647,6 +11738,7 @@ theorems := "LIM_ZERO_POSINFINITY",LIM_ZERO_POSINFINITY; "LIM_Z_TIMES_CLOG",LIM_Z_TIMES_CLOG; "LINDELOF",LINDELOF; +"LINDELOF_HAUSDORFF_REGULAR_EQ_PARACOMPACT",LINDELOF_HAUSDORFF_REGULAR_EQ_PARACOMPACT; "LINDELOF_OPEN_IN",LINDELOF_OPEN_IN; "LINDELOF_SPACE_ALT",LINDELOF_SPACE_ALT; "LINDELOF_SPACE_CLOSED_IN_SUBTOPOLOGY",LINDELOF_SPACE_CLOSED_IN_SUBTOPOLOGY; @@ -11884,6 +11976,8 @@ theorems := "LOCALLY_COMPACT_COMPACT_ALT",LOCALLY_COMPACT_COMPACT_ALT; "LOCALLY_COMPACT_COMPACT_SUBOPEN",LOCALLY_COMPACT_COMPACT_SUBOPEN; "LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED",LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED; +"LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN",LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN; +"LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_SPACE",LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_SPACE; "LOCALLY_COMPACT_DELETE",LOCALLY_COMPACT_DELETE; "LOCALLY_COMPACT_EUCLIDEAN_SPACE",LOCALLY_COMPACT_EUCLIDEAN_SPACE; "LOCALLY_COMPACT_HAUSDORFF_IMP_REGULAR_SPACE",LOCALLY_COMPACT_HAUSDORFF_IMP_REGULAR_SPACE; @@ -11903,12 +11997,17 @@ theorems := "LOCALLY_COMPACT_KC_SPACE_ALT",LOCALLY_COMPACT_KC_SPACE_ALT; "LOCALLY_COMPACT_LINEAR_IMAGE_EQ",LOCALLY_COMPACT_LINEAR_IMAGE_EQ; "LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED",LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED; +"LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN",LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN; +"LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_SPACE",LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_SPACE; "LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED",LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED; +"LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN",LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN; +"LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_SPACE",LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_SPACE; "LOCALLY_COMPACT_OPEN_IN",LOCALLY_COMPACT_OPEN_IN; "LOCALLY_COMPACT_OPEN_INTER_CLOSURE",LOCALLY_COMPACT_OPEN_INTER_CLOSURE; "LOCALLY_COMPACT_OPEN_UNION",LOCALLY_COMPACT_OPEN_UNION; "LOCALLY_COMPACT_OPEN_UNIONS",LOCALLY_COMPACT_OPEN_UNIONS; "LOCALLY_COMPACT_PATH_CONNECTED_EQ_CONNECTED",LOCALLY_COMPACT_PATH_CONNECTED_EQ_CONNECTED; +"LOCALLY_COMPACT_PATH_CONNECTED_EQ_CONNECTED_EUCLIDEAN",LOCALLY_COMPACT_PATH_CONNECTED_EQ_CONNECTED_EUCLIDEAN; "LOCALLY_COMPACT_PCROSS",LOCALLY_COMPACT_PCROSS; "LOCALLY_COMPACT_PCROSS_EQ",LOCALLY_COMPACT_PCROSS_EQ; "LOCALLY_COMPACT_PROPER_CONTINUOUS_PREIMAGE",LOCALLY_COMPACT_PROPER_CONTINUOUS_PREIMAGE; @@ -11923,6 +12022,7 @@ theorems := "LOCALLY_COMPACT_SPACE_CONTINUOUS_OPEN_MAP_IMAGE",LOCALLY_COMPACT_SPACE_CONTINUOUS_OPEN_MAP_IMAGE; "LOCALLY_COMPACT_SPACE_DISCRETE_TOPOLOGY",LOCALLY_COMPACT_SPACE_DISCRETE_TOPOLOGY; "LOCALLY_COMPACT_SPACE_EUCLIDEANREAL",LOCALLY_COMPACT_SPACE_EUCLIDEANREAL; +"LOCALLY_COMPACT_SPACE_IMP_GDELTA_IN",LOCALLY_COMPACT_SPACE_IMP_GDELTA_IN; "LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE",LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE; "LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE_CLOSED_IN",LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE_CLOSED_IN; "LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE_CLOSURE_OF",LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE_CLOSURE_OF; @@ -11934,6 +12034,7 @@ theorems := "LOCALLY_COMPACT_SPACE_PRODUCT_TOPOLOGY",LOCALLY_COMPACT_SPACE_PRODUCT_TOPOLOGY; "LOCALLY_COMPACT_SPACE_PROD_TOPOLOGY",LOCALLY_COMPACT_SPACE_PROD_TOPOLOGY; "LOCALLY_COMPACT_SPACE_RETRACTION_MAP_IMAGE",LOCALLY_COMPACT_SPACE_RETRACTION_MAP_IMAGE; +"LOCALLY_COMPACT_SPACE_SUBMETRIC_EUCLIDEAN",LOCALLY_COMPACT_SPACE_SUBMETRIC_EUCLIDEAN; "LOCALLY_COMPACT_SPACE_SUBTOPOLOGY_EUCLIDEAN",LOCALLY_COMPACT_SPACE_SUBTOPOLOGY_EUCLIDEAN; "LOCALLY_COMPACT_SPACE_SUM_TOPOLOGY",LOCALLY_COMPACT_SPACE_SUM_TOPOLOGY; "LOCALLY_COMPACT_SUBSPACE_CLOSED_INTER_OPEN_IN",LOCALLY_COMPACT_SUBSPACE_CLOSED_INTER_OPEN_IN; @@ -11951,6 +12052,7 @@ theorems := "LOCALLY_CONNECTED_CONNECTED_COMPONENT",LOCALLY_CONNECTED_CONNECTED_COMPONENT; "LOCALLY_CONNECTED_CONTINUOUS_IMAGE_COMPACT",LOCALLY_CONNECTED_CONTINUOUS_IMAGE_COMPACT; "LOCALLY_CONNECTED_CONTINUUM",LOCALLY_CONNECTED_CONTINUUM; +"LOCALLY_CONNECTED_CONTINUUM_SPACE",LOCALLY_CONNECTED_CONTINUUM_SPACE; "LOCALLY_CONNECTED_EUCLIDEAN_SPACE",LOCALLY_CONNECTED_EUCLIDEAN_SPACE; "LOCALLY_CONNECTED_FROM_UNION_AND_INTER",LOCALLY_CONNECTED_FROM_UNION_AND_INTER; "LOCALLY_CONNECTED_FROM_UNION_AND_INTER_GEN",LOCALLY_CONNECTED_FROM_UNION_AND_INTER_GEN; @@ -11980,6 +12082,7 @@ theorems := "LOCALLY_CONNECTED_SPACE_PROD_TOPOLOGY",LOCALLY_CONNECTED_SPACE_PROD_TOPOLOGY; "LOCALLY_CONNECTED_SPACE_QUOTIENT_MAP_IMAGE",LOCALLY_CONNECTED_SPACE_QUOTIENT_MAP_IMAGE; "LOCALLY_CONNECTED_SPACE_RETRACTION_MAP_IMAGE",LOCALLY_CONNECTED_SPACE_RETRACTION_MAP_IMAGE; +"LOCALLY_CONNECTED_SPACE_SUBMETRIC_EUCLIDEAN",LOCALLY_CONNECTED_SPACE_SUBMETRIC_EUCLIDEAN; "LOCALLY_CONNECTED_SPACE_SUBTOPOLOGY_EUCLIDEAN",LOCALLY_CONNECTED_SPACE_SUBTOPOLOGY_EUCLIDEAN; "LOCALLY_CONNECTED_SPACE_SUM_TOPOLOGY",LOCALLY_CONNECTED_SPACE_SUM_TOPOLOGY; "LOCALLY_CONNECTED_SPHERE",LOCALLY_CONNECTED_SPHERE; @@ -11989,6 +12092,7 @@ theorems := "LOCALLY_CONNECTED_UNIV",LOCALLY_CONNECTED_UNIV; "LOCALLY_CONSTANT",LOCALLY_CONSTANT; "LOCALLY_CONSTANT_IMP_CONSTANT",LOCALLY_CONSTANT_IMP_CONSTANT; +"LOCALLY_CONSTANT_REFINEMENT",LOCALLY_CONSTANT_REFINEMENT; "LOCALLY_CONTINUOUS_ON",LOCALLY_CONTINUOUS_ON; "LOCALLY_CONTINUOUS_ON_ALT",LOCALLY_CONTINUOUS_ON_ALT; "LOCALLY_CONTINUOUS_ON_EXPLICIT",LOCALLY_CONTINUOUS_ON_EXPLICIT; @@ -12003,14 +12107,18 @@ theorems := "LOCALLY_EQ_COMPACTLY",LOCALLY_EQ_COMPACTLY; "LOCALLY_FCCOVERABLE",LOCALLY_FCCOVERABLE; "LOCALLY_FCCOVERABLE_ALT",LOCALLY_FCCOVERABLE_ALT; +"LOCALLY_FCCOVERABLE_SPACE",LOCALLY_FCCOVERABLE_SPACE; +"LOCALLY_FCCOVERABLE_SPACE_CHAIN",LOCALLY_FCCOVERABLE_SPACE_CHAIN; "LOCALLY_FINE_COVERING_COMPACT",LOCALLY_FINE_COVERING_COMPACT; "LOCALLY_FINITE_COVER_OF_COMPACT_SPACE",LOCALLY_FINITE_COVER_OF_COMPACT_SPACE; "LOCALLY_FINITE_COVER_OF_LINDELOF_SPACE",LOCALLY_FINITE_COVER_OF_LINDELOF_SPACE; "LOCALLY_FINITE_IN_CLOSURES",LOCALLY_FINITE_IN_CLOSURES; +"LOCALLY_FINITE_IN_HOMEOMORPHIC_IMAGE",LOCALLY_FINITE_IN_HOMEOMORPHIC_IMAGE; "LOCALLY_FINITE_IN_REFINEMENT",LOCALLY_FINITE_IN_REFINEMENT; "LOCALLY_FINITE_IN_SUBSET",LOCALLY_FINITE_IN_SUBSET; "LOCALLY_FINITE_IN_SUBTOPOLOGY",LOCALLY_FINITE_IN_SUBTOPOLOGY; "LOCALLY_FINITE_IN_SUBTOPOLOGY_EQ",LOCALLY_FINITE_IN_SUBTOPOLOGY_EQ; +"LOCALLY_FINITE_PRODUCT_TUBES",LOCALLY_FINITE_PRODUCT_TUBES; "LOCALLY_IMP_COUNTABLE_UNION_OF",LOCALLY_IMP_COUNTABLE_UNION_OF; "LOCALLY_IMP_FINITE_UNION_OF",LOCALLY_IMP_FINITE_UNION_OF; "LOCALLY_INJECTIVE_LINEAR_IMAGE",LOCALLY_INJECTIVE_LINEAR_IMAGE; @@ -12535,6 +12643,7 @@ theorems := "MBALL_EMPTY_ALT",MBALL_EMPTY_ALT; "MBALL_EQ_EMPTY",MBALL_EQ_EMPTY; "MBALL_EUCLIDEAN",MBALL_EUCLIDEAN; +"MBALL_INTER_DSEPARATED_SINGLETON",MBALL_INTER_DSEPARATED_SINGLETON; "MBALL_PROD_METRIC_SUBSET",MBALL_PROD_METRIC_SUBSET; "MBALL_REAL_INTERVAL",MBALL_REAL_INTERVAL; "MBALL_SUBMETRIC",MBALL_SUBMETRIC; @@ -12553,12 +12662,14 @@ theorems := "MBOUNDED",MBOUNDED; "MBOUNDED_ALT",MBOUNDED_ALT; "MBOUNDED_ALT_POS",MBOUNDED_ALT_POS; +"MBOUNDED_AND_MDIAMETER_LE",MBOUNDED_AND_MDIAMETER_LE; "MBOUNDED_CLOSURE_OF",MBOUNDED_CLOSURE_OF; "MBOUNDED_CLOSURE_OF_EQ",MBOUNDED_CLOSURE_OF_EQ; "MBOUNDED_CROSS",MBOUNDED_CROSS; "MBOUNDED_DISCRETE_METRIC",MBOUNDED_DISCRETE_METRIC; "MBOUNDED_EMPTY",MBOUNDED_EMPTY; "MBOUNDED_EUCLIDEAN",MBOUNDED_EUCLIDEAN; +"MBOUNDED_IMP_IN_MSPACE",MBOUNDED_IMP_IN_MSPACE; "MBOUNDED_INSERT",MBOUNDED_INSERT; "MBOUNDED_INTER",MBOUNDED_INTER; "MBOUNDED_LIPSCHITZ_CONTINUOUS_IMAGE",MBOUNDED_LIPSCHITZ_CONTINUOUS_IMAGE; @@ -12568,6 +12679,7 @@ theorems := "MBOUNDED_PROD_METRIC",MBOUNDED_PROD_METRIC; "MBOUNDED_REAL_EUCLIDEAN_METRIC",MBOUNDED_REAL_EUCLIDEAN_METRIC; "MBOUNDED_SUBMETRIC",MBOUNDED_SUBMETRIC; +"MBOUNDED_SUBMETRIC_EUCLIDEAN",MBOUNDED_SUBMETRIC_EUCLIDEAN; "MBOUNDED_SUBSET",MBOUNDED_SUBSET; "MBOUNDED_SUBSET_MSPACE",MBOUNDED_SUBSET_MSPACE; "MBOUNDED_UNION",MBOUNDED_UNION; @@ -12590,15 +12702,27 @@ theorems := "MCOMPLETE_ALT",MCOMPLETE_ALT; "MCOMPLETE_CAPPED_METRIC",MCOMPLETE_CAPPED_METRIC; "MCOMPLETE_CFUNSPACE",MCOMPLETE_CFUNSPACE; +"MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED",MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED; +"MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN",MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN; +"MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_IN",MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_IN; "MCOMPLETE_DISCRETE_METRIC",MCOMPLETE_DISCRETE_METRIC; +"MCOMPLETE_DYADIC_APPROXIMATION",MCOMPLETE_DYADIC_APPROXIMATION; "MCOMPLETE_EMPTY_MSPACE",MCOMPLETE_EMPTY_MSPACE; "MCOMPLETE_EUCLIDEAN",MCOMPLETE_EUCLIDEAN; "MCOMPLETE_FIP",MCOMPLETE_FIP; "MCOMPLETE_FIP_SING",MCOMPLETE_FIP_SING; "MCOMPLETE_FUNSPACE",MCOMPLETE_FUNSPACE; +"MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM",MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM; +"MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM_IN",MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM_IN; "MCOMPLETE_IMP_CLOSED_IN",MCOMPLETE_IMP_CLOSED_IN; +"MCOMPLETE_IMP_LOCALLY_COMPACT_EUCLIDEAN",MCOMPLETE_IMP_LOCALLY_COMPACT_EUCLIDEAN; "MCOMPLETE_INTER",MCOMPLETE_INTER; "MCOMPLETE_INTERS",MCOMPLETE_INTERS; +"MCOMPLETE_IN_LOCALLY_COMPACT_IMP_LOCALLY_COMPACT",MCOMPLETE_IN_LOCALLY_COMPACT_IMP_LOCALLY_COMPACT; +"MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED",MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED; +"MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN",MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN; +"MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED",MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED; +"MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN",MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN; "MCOMPLETE_NEST",MCOMPLETE_NEST; "MCOMPLETE_NEST_SING",MCOMPLETE_NEST_SING; "MCOMPLETE_PROD_METRIC",MCOMPLETE_PROD_METRIC; @@ -12607,6 +12731,23 @@ theorems := "MCOMPLETE_SUBMETRIC_REAL_EUCLIDEAN_METRIC",MCOMPLETE_SUBMETRIC_REAL_EUCLIDEAN_METRIC; "MCOMPLETE_UNION",MCOMPLETE_UNION; "MCOMPLETE_UNIONS",MCOMPLETE_UNIONS; +"MDIAMETER_BOUNDED",MDIAMETER_BOUNDED; +"MDIAMETER_BOUNDED_BOUND",MDIAMETER_BOUNDED_BOUND; +"MDIAMETER_CLOSURE",MDIAMETER_CLOSURE; +"MDIAMETER_COMPACT_ATTAINED",MDIAMETER_COMPACT_ATTAINED; +"MDIAMETER_EMPTY",MDIAMETER_EMPTY; +"MDIAMETER_EQ_0",MDIAMETER_EQ_0; +"MDIAMETER_EUCLIDEAN",MDIAMETER_EUCLIDEAN; +"MDIAMETER_LE",MDIAMETER_LE; +"MDIAMETER_POS_LE",MDIAMETER_POS_LE; +"MDIAMETER_SING",MDIAMETER_SING; +"MDIAMETER_SUBMETRIC",MDIAMETER_SUBMETRIC; +"MDIAMETER_SUBMETRIC_EUCLIDEAN",MDIAMETER_SUBMETRIC_EUCLIDEAN; +"MDIAMETER_SUBSET",MDIAMETER_SUBSET; +"MDIAMETER_SUBSET_MBALL",MDIAMETER_SUBSET_MBALL; +"MDIAMETER_SUBSET_MCBALL",MDIAMETER_SUBSET_MCBALL; +"MDIAMETER_SUBSET_MCBALL_NONEMPTY",MDIAMETER_SUBSET_MCBALL_NONEMPTY; +"MDIAMETER_UNION_LE",MDIAMETER_UNION_LE; "MDIST",MDIST; "MDIST_0",MDIST_0; "MDIST_CAPPED",MDIST_CAPPED; @@ -12620,6 +12761,7 @@ theorems := "MDIST_REVERSE_TRIANGLE",MDIST_REVERSE_TRIANGLE; "MDIST_SYM",MDIST_SYM; "MDIST_TRIANGLE",MDIST_TRIANGLE; +"MDIST_TRIANGLE_LT",MDIST_TRIANGLE_LT; "MEASURABLE",MEASURABLE; "MEASURABLE_ABSOLUTELY_CONTINUOUS_IMAGE",MEASURABLE_ABSOLUTELY_CONTINUOUS_IMAGE; "MEASURABLE_ADDITIVE_IMP_LINEAR",MEASURABLE_ADDITIVE_IMP_LINEAR; @@ -12947,6 +13089,7 @@ theorems := "METRIC_COMPLETION",METRIC_COMPLETION; "METRIC_COMPLETION_EXPLICIT",METRIC_COMPLETION_EXPLICIT; "METRIC_CONTINUOUS_MAP",METRIC_CONTINUOUS_MAP; +"METRIC_COVER_SIGMA_LOCALLY_FINITE",METRIC_COVER_SIGMA_LOCALLY_FINITE; "METRIC_DERIVED_SET_OF",METRIC_DERIVED_SET_OF; "METRIC_INJECTIVE_IMAGE",METRIC_INJECTIVE_IMAGE; "METRIC_INTERIOR_OF",METRIC_INTERIOR_OF; @@ -12959,8 +13102,11 @@ theorems := "METRIZABLE_IMP_KC_SPACE",METRIZABLE_IMP_KC_SPACE; "METRIZABLE_IMP_K_SPACE",METRIZABLE_IMP_K_SPACE; "METRIZABLE_IMP_NORMAL_SPACE",METRIZABLE_IMP_NORMAL_SPACE; +"METRIZABLE_IMP_PARACOMPACT_SPACE",METRIZABLE_IMP_PARACOMPACT_SPACE; "METRIZABLE_IMP_REGULAR_SPACE",METRIZABLE_IMP_REGULAR_SPACE; "METRIZABLE_IMP_T1_SPACE",METRIZABLE_IMP_T1_SPACE; +"METRIZABLE_PRODUCT_EUCLIDEANREAL_NUM",METRIZABLE_PRODUCT_EUCLIDEANREAL_NUM; +"METRIZABLE_SPACE_CANTOR_SPACE",METRIZABLE_SPACE_CANTOR_SPACE; "METRIZABLE_SPACE_COMPLETION",METRIZABLE_SPACE_COMPLETION; "METRIZABLE_SPACE_DISCRETE_TOPOLOGY",METRIZABLE_SPACE_DISCRETE_TOPOLOGY; "METRIZABLE_SPACE_EUCLIDEAN",METRIZABLE_SPACE_EUCLIDEAN; @@ -12971,6 +13117,7 @@ theorems := "METRIZABLE_SPACE_RETRACTION_MAP_IMAGE",METRIZABLE_SPACE_RETRACTION_MAP_IMAGE; "METRIZABLE_SPACE_SEPARATION",METRIZABLE_SPACE_SEPARATION; "METRIZABLE_SPACE_SUBTOPOLOGY",METRIZABLE_SPACE_SUBTOPOLOGY; +"MICHAEL_LEMMA",MICHAEL_LEMMA; "MIDPOINTS_IN_CONVEX_HULL",MIDPOINTS_IN_CONVEX_HULL; "MIDPOINT_BETWEEN",MIDPOINT_BETWEEN; "MIDPOINT_COLLINEAR",MIDPOINT_COLLINEAR; @@ -13116,6 +13263,7 @@ theorems := "MTOPOLOGY_PROD_METRIC",MTOPOLOGY_PROD_METRIC; "MTOPOLOGY_REAL_EUCLIDEAN_METRIC",MTOPOLOGY_REAL_EUCLIDEAN_METRIC; "MTOPOLOGY_SUBMETRIC",MTOPOLOGY_SUBMETRIC; +"MTOPOLOGY_SUBMETRIC_EUCLIDEAN",MTOPOLOGY_SUBMETRIC_EUCLIDEAN; "MULT",MULT; "MULTIPART_MEASURES",MULTIPART_MEASURES; "MULTIPLES_EQ",MULTIPLES_EQ; @@ -13326,6 +13474,7 @@ theorems := "NEIGHBOURHOOD_BASE_OF_UNLOCALIZED",NEIGHBOURHOOD_BASE_OF_UNLOCALIZED; "NEIGHBOURHOOD_BASE_OF_WITH_SUBSET",NEIGHBOURHOOD_BASE_OF_WITH_SUBSET; "NEIGHBOURHOOD_EXTENSION_INTO_ANR",NEIGHBOURHOOD_EXTENSION_INTO_ANR; +"NESTED_COMPACT_APPROX",NESTED_COMPACT_APPROX; "NET",NET; "NETLIMITS_ATPOINTOF",NETLIMITS_ATPOINTOF; "NETLIMITS_AT_INFINITY",NETLIMITS_AT_INFINITY; @@ -13365,6 +13514,7 @@ theorems := "NONEMPTY_SIMPLE_PATH_ENDLESS",NONEMPTY_SIMPLE_PATH_ENDLESS; "NONEMPTY_SPAN",NONEMPTY_SPAN; "NONEMPTY_STANDARD_SIMPLEX",NONEMPTY_STANDARD_SIMPLEX; +"NONEMPTY_TOPSPACE_CANTOR_SPACE",NONEMPTY_TOPSPACE_CANTOR_SPACE; "NONNEGATIVE_ABSOLUTELY_INTEGRABLE",NONNEGATIVE_ABSOLUTELY_INTEGRABLE; "NONNEGATIVE_ABSOLUTELY_INTEGRABLE_AE",NONNEGATIVE_ABSOLUTELY_INTEGRABLE_AE; "NONNEGATIVE_ABSOLUTELY_REAL_INTEGRABLE",NONNEGATIVE_ABSOLUTELY_REAL_INTEGRABLE; @@ -13850,6 +14000,7 @@ theorems := "OPEN_COMPONENTS",OPEN_COMPONENTS; "OPEN_CONIC_HULL",OPEN_CONIC_HULL; "OPEN_CONNECTED_COMPONENT",OPEN_CONNECTED_COMPONENT; +"OPEN_CONNECTED_FINE_COVER",OPEN_CONNECTED_FINE_COVER; "OPEN_CONTAINS_BALL",OPEN_CONTAINS_BALL; "OPEN_CONTAINS_BALL_EQ",OPEN_CONTAINS_BALL_EQ; "OPEN_CONTAINS_CBALL",OPEN_CONTAINS_CBALL; @@ -14349,8 +14500,25 @@ theorems := "PAIR_EXISTS_THM",PAIR_EXISTS_THM; "PAIR_SURJECTIVE",PAIR_SURJECTIVE; "PARACOMPACT",PARACOMPACT; -"PARACOMPACT_CLOSED",PARACOMPACT_CLOSED; -"PARACOMPACT_CLOSED_IN",PARACOMPACT_CLOSED_IN; +"PARACOMPACT_HAUSDORFF_CLOSURE_REFINEMENT",PARACOMPACT_HAUSDORFF_CLOSURE_REFINEMENT; +"PARACOMPACT_HAUSDORFF_EXPANSION_LEMMA",PARACOMPACT_HAUSDORFF_EXPANSION_LEMMA; +"PARACOMPACT_HAUSDORFF_IMP_NORMAL_SPACE",PARACOMPACT_HAUSDORFF_IMP_NORMAL_SPACE; +"PARACOMPACT_HAUSDORFF_IMP_REGULAR_SPACE",PARACOMPACT_HAUSDORFF_IMP_REGULAR_SPACE; +"PARACOMPACT_HAUSDORFF_INDEXED_SHRINKING",PARACOMPACT_HAUSDORFF_INDEXED_SHRINKING; +"PARACOMPACT_PARTITION_OF_UNITY",PARACOMPACT_PARTITION_OF_UNITY; +"PARACOMPACT_SPACE_CLOSED_SUBSET",PARACOMPACT_SPACE_CLOSED_SUBSET; +"PARACOMPACT_SPACE_DISCRETE_TOPOLOGY",PARACOMPACT_SPACE_DISCRETE_TOPOLOGY; +"PARACOMPACT_SPACE_EQ_CLOSED_REFINEMENT",PARACOMPACT_SPACE_EQ_CLOSED_REFINEMENT; +"PARACOMPACT_SPACE_EQ_LOCALLY_FINITE_REFINEMENT",PARACOMPACT_SPACE_EQ_LOCALLY_FINITE_REFINEMENT; +"PARACOMPACT_SPACE_EUCLIDEAN",PARACOMPACT_SPACE_EUCLIDEAN; +"PARACOMPACT_SPACE_EUCLIDEAN_SUBTOPOLOGY",PARACOMPACT_SPACE_EUCLIDEAN_SUBTOPOLOGY; +"PARACOMPACT_SPACE_FSIGMA_SUBSET",PARACOMPACT_SPACE_FSIGMA_SUBSET; +"PARACOMPACT_SPACE_MTOPOLOGY",PARACOMPACT_SPACE_MTOPOLOGY; +"PARACOMPACT_SPACE_PERFECT_MAP_IMAGE",PARACOMPACT_SPACE_PERFECT_MAP_IMAGE; +"PARACOMPACT_SPACE_PERFECT_MAP_PREIMAGE",PARACOMPACT_SPACE_PERFECT_MAP_PREIMAGE; +"PARACOMPACT_SPACE_PRODUCT_COMPACT_LEFT",PARACOMPACT_SPACE_PRODUCT_COMPACT_LEFT; +"PARACOMPACT_SPACE_PRODUCT_COMPACT_RIGHT",PARACOMPACT_SPACE_PRODUCT_COMPACT_RIGHT; +"PARACOMPACT_SPACE_RETRACTION_MAP_IMAGE",PARACOMPACT_SPACE_RETRACTION_MAP_IMAGE; "PARTIAL_DIVISION_EXTEND",PARTIAL_DIVISION_EXTEND; "PARTIAL_DIVISION_EXTEND_1",PARTIAL_DIVISION_EXTEND_1; "PARTIAL_DIVISION_EXTEND_INTERVAL",PARTIAL_DIVISION_EXTEND_INTERVAL; @@ -14727,6 +14895,9 @@ theorems := "PCROSS_UNION",PCROSS_UNION; "PCROSS_UNIONS",PCROSS_UNIONS; "PCROSS_UNIONS_UNIONS",PCROSS_UNIONS_UNIONS; +"PEANO_GAP_FILLING_EXTENSION",PEANO_GAP_FILLING_EXTENSION; +"PERFECT_CANTOR_SPACE",PERFECT_CANTOR_SPACE; +"PERFECT_CANTOR_SPACE_EQ",PERFECT_CANTOR_SPACE_EQ; "PERFECT_FROM_CLOSURE",PERFECT_FROM_CLOSURE; "PERFECT_IMP_CLOSED_MAP",PERFECT_IMP_CLOSED_MAP; "PERFECT_IMP_CONTINUOUS_MAP",PERFECT_IMP_CONTINUOUS_MAP; @@ -17012,11 +17183,13 @@ theorems := "REGULAR_CLOSURE_INTERIOR",REGULAR_CLOSURE_INTERIOR; "REGULAR_CLOSURE_OF_IMP_THIN_FRONTIER_OF",REGULAR_CLOSURE_OF_IMP_THIN_FRONTIER_OF; "REGULAR_CLOSURE_OF_INTERIOR_OF",REGULAR_CLOSURE_OF_INTERIOR_OF; +"REGULAR_CLOSURE_REFINEMENT_COVERS",REGULAR_CLOSURE_REFINEMENT_COVERS; "REGULAR_INTERIOR_CLOSURE",REGULAR_INTERIOR_CLOSURE; "REGULAR_INTERIOR_IMP_THIN_FRONTIER",REGULAR_INTERIOR_IMP_THIN_FRONTIER; "REGULAR_INTERIOR_OF_CLOSURE_OF",REGULAR_INTERIOR_OF_CLOSURE_OF; "REGULAR_INTERIOR_OF_IMP_THIN_FRONTIER_OF",REGULAR_INTERIOR_OF_IMP_THIN_FRONTIER_OF; "REGULAR_LINDELOF_IMP_NORMAL_SPACE",REGULAR_LINDELOF_IMP_NORMAL_SPACE; +"REGULAR_LINDELOF_IMP_PARACOMPACT_SPACE",REGULAR_LINDELOF_IMP_PARACOMPACT_SPACE; "REGULAR_OPEN",REGULAR_OPEN; "REGULAR_OPEN_IN",REGULAR_OPEN_IN; "REGULAR_OPEN_INTER",REGULAR_OPEN_INTER; @@ -17024,6 +17197,7 @@ theorems := "REGULAR_POLYTOPE_EXISTS",REGULAR_POLYTOPE_EXISTS; "REGULAR_POLYTOPE_WITH_BARYCENTRE_EXISTS",REGULAR_POLYTOPE_WITH_BARYCENTRE_EXISTS; "REGULAR_POLYTOPE_WITH_BARYCENTRE_EXISTS_ALT",REGULAR_POLYTOPE_WITH_BARYCENTRE_EXISTS_ALT; +"REGULAR_SECOND_COUNTABLE_HAUSDORFF_IMP_NORMAL_SPACE",REGULAR_SECOND_COUNTABLE_HAUSDORFF_IMP_NORMAL_SPACE; "REGULAR_SECOND_COUNTABLE_IMP_HEREDITARILY_NORMAL_SPACE",REGULAR_SECOND_COUNTABLE_IMP_HEREDITARILY_NORMAL_SPACE; "REGULAR_SPACE",REGULAR_SPACE; "REGULAR_SPACE_ALEXANDROFF_COMPACTIFICATION",REGULAR_SPACE_ALEXANDROFF_COMPACTIFICATION; @@ -17438,13 +17612,16 @@ theorems := "SCHWARZ_REFLECTION_UNIQUE",SCHWARZ_REFLECTION_UNIQUE; "SECOND_CARTAN_THM_DIM_1",SECOND_CARTAN_THM_DIM_1; "SECOND_COUNTABLE",SECOND_COUNTABLE; +"SECOND_COUNTABLE_CLOSED_MAP_IMAGE",SECOND_COUNTABLE_CLOSED_MAP_IMAGE; "SECOND_COUNTABLE_DISCRETE_TOPOLOGY",SECOND_COUNTABLE_DISCRETE_TOPOLOGY; "SECOND_COUNTABLE_IMP_FIRST_COUNTABLE",SECOND_COUNTABLE_IMP_FIRST_COUNTABLE; "SECOND_COUNTABLE_IMP_LINDELOF_SPACE",SECOND_COUNTABLE_IMP_LINDELOF_SPACE; "SECOND_COUNTABLE_IMP_SEPARABLE_SPACE",SECOND_COUNTABLE_IMP_SEPARABLE_SPACE; +"SECOND_COUNTABLE_LOCALLY_COMPACT_HAUSDORFF_IMP_PARACOMPACT",SECOND_COUNTABLE_LOCALLY_COMPACT_HAUSDORFF_IMP_PARACOMPACT; "SECOND_COUNTABLE_NEIGHBOURHOOD_BASE",SECOND_COUNTABLE_NEIGHBOURHOOD_BASE; "SECOND_COUNTABLE_NEIGHBOURHOOD_BASE_ALT",SECOND_COUNTABLE_NEIGHBOURHOOD_BASE_ALT; "SECOND_COUNTABLE_OPEN_MAP_IMAGE",SECOND_COUNTABLE_OPEN_MAP_IMAGE; +"SECOND_COUNTABLE_REGULAR_IMP_PARACOMPACT_SPACE",SECOND_COUNTABLE_REGULAR_IMP_PARACOMPACT_SPACE; "SECOND_COUNTABLE_RETRACTION_MAP_IMAGE",SECOND_COUNTABLE_RETRACTION_MAP_IMAGE; "SECOND_COUNTABLE_SUBTOPOLOGY",SECOND_COUNTABLE_SUBTOPOLOGY; "SECOND_MEAN_VALUE_THEOREM",SECOND_MEAN_VALUE_THEOREM; @@ -17504,8 +17681,12 @@ theorems := "SELF_ADJOINT_ORTHOGONAL_EIGENVECTORS",SELF_ADJOINT_ORTHOGONAL_EIGENVECTORS; "SEMI_LOCALLY_CONNECTED",SEMI_LOCALLY_CONNECTED; "SEMI_LOCALLY_CONNECTED_COMPACT",SEMI_LOCALLY_CONNECTED_COMPACT; +"SEMI_LOCALLY_CONNECTED_COMPACT_SPACE",SEMI_LOCALLY_CONNECTED_COMPACT_SPACE; +"SEMI_LOCALLY_CONNECTED_CONNECTED",SEMI_LOCALLY_CONNECTED_CONNECTED; "SEMI_LOCALLY_CONNECTED_GEN",SEMI_LOCALLY_CONNECTED_GEN; +"SEMI_LOCALLY_CONNECTED_GEN_SPACE",SEMI_LOCALLY_CONNECTED_GEN_SPACE; "SEPARABLE",SEPARABLE; +"SEPARABLE_METRIZABLE_IMP_SECOND_COUNTABLE",SEPARABLE_METRIZABLE_IMP_SECOND_COUNTABLE; "SEPARABLE_SPACE_CONTINUOUS_MAP_IMAGE",SEPARABLE_SPACE_CONTINUOUS_MAP_IMAGE; "SEPARABLE_SPACE_DISCRETE_TOPOLOGY",SEPARABLE_SPACE_DISCRETE_TOPOLOGY; "SEPARABLE_SPACE_OPEN_SUBSET",SEPARABLE_SPACE_OPEN_SUBSET; @@ -17561,6 +17742,7 @@ theorems := "SEPARATE_CLOSED_CONES",SEPARATE_CLOSED_CONES; "SEPARATE_COMPACT_CLOSED",SEPARATE_COMPACT_CLOSED; "SEPARATE_POINT_CLOSED",SEPARATE_POINT_CLOSED; +"SEPARATING_FUNCTIONS_INJECTIVE",SEPARATING_FUNCTIONS_INJECTIVE; "SEPARATING_HYPERPLANE_AFFINE_AFFINE",SEPARATING_HYPERPLANE_AFFINE_AFFINE; "SEPARATING_HYPERPLANE_AFFINE_HULLS",SEPARATING_HYPERPLANE_AFFINE_HULLS; "SEPARATING_HYPERPLANE_CLOSED_0",SEPARATING_HYPERPLANE_CLOSED_0; @@ -17782,6 +17964,7 @@ theorems := "SHORT_FIVE_LEMMA_EPI",SHORT_FIVE_LEMMA_EPI; "SHORT_FIVE_LEMMA_MONO",SHORT_FIVE_LEMMA_MONO; "SIGMA_COMPACT",SIGMA_COMPACT; +"SIGMA_LOCALLY_FINITE_IMP_LOCALLY_FINITE_COVERING",SIGMA_LOCALLY_FINITE_IMP_LOCALLY_FINITE_COVERING; "SIGN_CARTESIAN_PRODUCT",SIGN_CARTESIAN_PRODUCT; "SIGN_COMPOSE",SIGN_COMPOSE; "SIGN_CYCLIC",SIGN_CYCLIC; @@ -18342,6 +18525,7 @@ theorems := "SUBMATROID_SPAN",SUBMATROID_SPAN; "SUBMATROID_SUBSET",SUBMATROID_SUBSET; "SUBMETRIC",SUBMETRIC; +"SUBMETRIC_EUCLIDEAN_METRIC",SUBMETRIC_EUCLIDEAN_METRIC; "SUBMETRIC_MSPACE",SUBMETRIC_MSPACE; "SUBMETRIC_PROD_METRIC",SUBMETRIC_PROD_METRIC; "SUBMETRIC_RESTRICT",SUBMETRIC_RESTRICT; @@ -18685,6 +18869,7 @@ theorems := "SUM_SWAP",SUM_SWAP; "SUM_SWAP_NUMSEG",SUM_SWAP_NUMSEG; "SUM_TRIV_NUMSEG",SUM_TRIV_NUMSEG; +"SUM_TWOTHIRDS",SUM_TWOTHIRDS; "SUM_UNION",SUM_UNION; "SUM_UNIONS_NONZERO",SUM_UNIONS_NONZERO; "SUM_UNION_EQ",SUM_UNION_EQ; @@ -18920,6 +19105,7 @@ theorems := "TENDSTO_ALT_WITHIN",TENDSTO_ALT_WITHIN; "TENDSTO_LIM",TENDSTO_LIM; "TENDSTO_REAL",TENDSTO_REAL; +"TENDSTO_REAL_EPS_DELTA",TENDSTO_REAL_EPS_DELTA; "THETA_CURVE_INSIDE_CASES",THETA_CURVE_INSIDE_CASES; "THIN_FRONTIER_CIC",THIN_FRONTIER_CIC; "THIN_FRONTIER_ICI",THIN_FRONTIER_ICI; @@ -18956,6 +19142,7 @@ theorems := "TOPOLOGY_FINER_SUBTOPOLOGY",TOPOLOGY_FINER_SUBTOPOLOGY; "TOPSPACE_ALEXANDROFF_COMPACTIFICATION",TOPSPACE_ALEXANDROFF_COMPACTIFICATION; "TOPSPACE_ALEXANDROFF_COMPACTIFICATION_DELETE",TOPSPACE_ALEXANDROFF_COMPACTIFICATION_DELETE; +"TOPSPACE_CANTOR_SPACE",TOPSPACE_CANTOR_SPACE; "TOPSPACE_DISCRETE_TOPOLOGY",TOPSPACE_DISCRETE_TOPOLOGY; "TOPSPACE_EUCLIDEAN",TOPSPACE_EUCLIDEAN; "TOPSPACE_EUCLIDEANREAL",TOPSPACE_EUCLIDEANREAL; @@ -18992,6 +19179,7 @@ theorems := "TOSET_TRIVIAL",TOSET_TRIVIAL; "TOSET_num",TOSET_num; "TOTALLY_BOUNDED_HAUSDIST",TOTALLY_BOUNDED_HAUSDIST; +"TOTALLY_BOUNDED_IMP_DISCRETE_FINITE",TOTALLY_BOUNDED_IMP_DISCRETE_FINITE; "TOTALLY_BOUNDED_IN_ABSOLUTE",TOTALLY_BOUNDED_IN_ABSOLUTE; "TOTALLY_BOUNDED_IN_CAUCHY_CONTINUOUS_IMAGE",TOTALLY_BOUNDED_IN_CAUCHY_CONTINUOUS_IMAGE; "TOTALLY_BOUNDED_IN_CAUCHY_SEQUENCE",TOTALLY_BOUNDED_IN_CAUCHY_SEQUENCE; @@ -19010,6 +19198,7 @@ theorems := "TOTALLY_BOUNDED_IN_SUBSET",TOTALLY_BOUNDED_IN_SUBSET; "TOTALLY_BOUNDED_IN_UNION",TOTALLY_BOUNDED_IN_UNION; "TOTALLY_BOUNDED_IN_UNIONS",TOTALLY_BOUNDED_IN_UNIONS; +"TOTALLY_BOUNDED_ULC_SPACE_IMP_FCCOVERABLE_SPACE",TOTALLY_BOUNDED_ULC_SPACE_IMP_FCCOVERABLE_SPACE; "TRACE_0",TRACE_0; "TRACE_ADD",TRACE_ADD; "TRACE_CMUL",TRACE_CMUL; @@ -19185,10 +19374,13 @@ theorems := "TUBE_LEMMA_RIGHT",TUBE_LEMMA_RIGHT; "TUKEY",TUKEY; "TWO",TWO; +"TWOTHIRDS_SUMS",TWOTHIRDS_SUMS; "TWO_SIDED_LIMIT_AT",TWO_SIDED_LIMIT_AT; "TWO_SIDED_LIMIT_WITHIN",TWO_SIDED_LIMIT_WITHIN; "T_DEF",T_DEF; "ULC_IMP_LOCALLY_CONNECTED",ULC_IMP_LOCALLY_CONNECTED; +"ULC_SPACE_IMP_LOCALLY_CONNECTED_SPACE",ULC_SPACE_IMP_LOCALLY_CONNECTED_SPACE; +"ULC_SPACE_SUBMETRIC_EUCLIDEAN",ULC_SPACE_SUBMETRIC_EUCLIDEAN; "UNBOUNDED_COMPLEMENT_COMPONENT_CONVEX",UNBOUNDED_COMPLEMENT_COMPONENT_CONVEX; "UNBOUNDED_COMPLEMENT_CONVEX",UNBOUNDED_COMPLEMENT_CONVEX; "UNBOUNDED_COMPONENTS_COMPLEMENT_ABSOLUTE_RETRACT",UNBOUNDED_COMPONENTS_COMPLEMENT_ABSOLUTE_RETRACT; @@ -19392,6 +19584,8 @@ theorems := "URYSOHN_LEMMA_ALT",URYSOHN_LEMMA_ALT; "URYSOHN_LOCAL",URYSOHN_LOCAL; "URYSOHN_LOCAL_STRONG",URYSOHN_LOCAL_STRONG; +"URYSOHN_METRIZATION",URYSOHN_METRIZATION; +"URYSOHN_METRIZATION_EQ",URYSOHN_METRIZATION_EQ; "URYSOHN_STRONG",URYSOHN_STRONG; "VALID_PATH_CIRCLEPATH",VALID_PATH_CIRCLEPATH; "VALID_PATH_COMPOSE",VALID_PATH_COMPOSE; @@ -19674,8 +19868,11 @@ theorems := "WEAKLY_LOCALLY_PATH_CONNECTED_IMP_WEAKLY_LOCALLY_CONNECTED_AT",WEAKLY_LOCALLY_PATH_CONNECTED_IMP_WEAKLY_LOCALLY_CONNECTED_AT; "WEAK_LEBESGUE_POINTS_IMP_IVT",WEAK_LEBESGUE_POINTS_IMP_IVT; "WELLCHAINED_ELEMENTS",WELLCHAINED_ELEMENTS; +"WELLCHAINED_ELEMENTS_EUCLIDEAN",WELLCHAINED_ELEMENTS_EUCLIDEAN; "WELLCHAINED_INTERS",WELLCHAINED_INTERS; +"WELLCHAINED_INTERS_EUCLIDEAN",WELLCHAINED_INTERS_EUCLIDEAN; "WELLCHAINED_SETS",WELLCHAINED_SETS; +"WELLCHAINED_SETS_EUCLIDEAN",WELLCHAINED_SETS_EUCLIDEAN; "WF",WF; "WF_ANTISYM",WF_ANTISYM; "WF_CARD_LT",WF_CARD_LT; @@ -19834,6 +20031,7 @@ theorems := "ZERO_AE_DERIVATIVE_IMP_CONSTANT",ZERO_AE_DERIVATIVE_IMP_CONSTANT; "ZERO_AE_DERIVATIVE_IMP_CONSTANT_GEN",ZERO_AE_DERIVATIVE_IMP_CONSTANT_GEN; "ZERO_DEF",ZERO_DEF; +"ZERO_DIMENSIONAL_CANTOR_SPACE",ZERO_DIMENSIONAL_CANTOR_SPACE; "ZERO_DIMENSIONAL_IMP_COMPLETELY_REGULAR_SPACE",ZERO_DIMENSIONAL_IMP_COMPLETELY_REGULAR_SPACE; "ZERO_DIMENSIONAL_IMP_REGULAR_SPACE",ZERO_DIMENSIONAL_IMP_REGULAR_SPACE; "ZERO_ONE_OR_PRIME",ZERO_ONE_OR_PRIME; @@ -19905,6 +20103,10 @@ theorems := "brouwer_degree1",brouwer_degree1; "brouwer_degree2",brouwer_degree2; "cacs",cacs; +"cantor_map",cantor_map; +"cantor_set",cantor_set; +"cantor_space",cantor_space; +"cantor_term",cantor_term; "capped_metric",capped_metric; "cart_tybij",cart_tybij; "cartesian_product",cartesian_product; @@ -20034,6 +20236,8 @@ theorems := "extreme_point_of",extreme_point_of; "face_of",face_of; "facet_of",facet_of; +"fccoverable_in",fccoverable_in; +"fccoverable_space",fccoverable_space; "fine",fine; "finite_diff_tybij",finite_diff_tybij; "finite_image_tybij",finite_image_tybij; @@ -20291,6 +20495,7 @@ theorems := "mbounded",mbounded; "mcball",mcball; "mcomplete",mcomplete; +"mdiameter",mdiameter; "mdist",mdist; "measurable",measurable; "measurable_on",measurable_on; @@ -20391,6 +20596,7 @@ theorems := "pair_INDUCT",pair_INDUCT; "pair_RECURSION",pair_RECURSION; "pairwise",pairwise; +"paracompact_space",paracompact_space; "partcirclepath",partcirclepath; "pastecart",pastecart; "path",path; @@ -20541,6 +20747,7 @@ theorems := "setdist",setdist; "shiftpath",shiftpath; "short_exact_sequence",short_exact_sequence; +"sigma_locally_finite_in",sigma_locally_finite_in; "sign",sign; "simple_path",simple_path; "simplex",simplex; @@ -20608,6 +20815,7 @@ theorems := "tan_def",tan_def; "tendsto",tendsto; "tendsto_real",tendsto_real; +"tendsto_real_def",tendsto_real_def; "topcontinuous_at",topcontinuous_at; "topology_tybij",topology_tybij; "topology_tybij_th",topology_tybij_th; @@ -20631,6 +20839,7 @@ theorems := "tybit0_RECURSION",tybit0_RECURSION; "tybit1_INDUCT",tybit1_INDUCT; "tybit1_RECURSION",tybit1_RECURSION; +"ulc_space",ulc_space; "unicoherent",unicoherent; "uniformly_continuous_map",uniformly_continuous_map; "uniformly_continuous_on",uniformly_continuous_on; diff --git a/Multivariate/metric.ml b/Multivariate/metric.ml index 2cca33f8..d22950b0 100644 --- a/Multivariate/metric.ml +++ b/Multivariate/metric.ml @@ -12081,7 +12081,7 @@ let METRIC_ARITH : term -> thm = and MDIST_SYM_CONV = let pconv = IMP_REWR_CONV (ISPEC mtm MDIST_SYM) in fun tm -> let x,y = dest_pair (rand tm) in - if x <= y then failwith "MDIST_SYM_CONV" else + if Term.(<=) x y then failwith "MDIST_SYM_CONV" else MP_CONV in_mspace2_conv (pconv tm) and MBOUNDED_CONV = let conv0 = REWR_CONV (EQT_INTRO (ISPEC mtm MBOUNDED_EMPTY)) in @@ -12465,6 +12465,208 @@ let METRIZABLE_IMP_FIRST_COUNTABLE = prove (`!top:A topology. metrizable_space top ==> first_countable top`, REWRITE_TAC[FORALL_METRIZABLE_SPACE; FIRST_COUNTABLE_MTOPOLOGY]);; +(* ------------------------------------------------------------------------- *) +(* Separable metrizable spaces are second-countable. Additional *) +(* second-countability results including closed map images. *) +(* ------------------------------------------------------------------------- *) + +let SEPARABLE_METRIZABLE_IMP_SECOND_COUNTABLE = prove + (`!top:A topology. + separable_space top /\ metrizable_space top ==> second_countable top`, + GEN_TAC THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [metrizable_space]) THEN + DISCH_THEN(X_CHOOSE_THEN `m:A metric` SUBST_ALL_TAC) THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [separable_space]) THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN + DISCH_THEN(X_CHOOSE_THEN `D:A->bool` STRIP_ASSUME_TAC) THEN + REWRITE_TAC[second_countable] THEN + EXISTS_TAC + `IMAGE (\(d:A,r:real). mball m (d,r)) + (D CROSS {r | rational r /\ &0 < r})` THEN + REPEAT CONJ_TAC THENL + [MATCH_MP_TAC COUNTABLE_IMAGE THEN + MATCH_MP_TAC COUNTABLE_CROSS THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC COUNTABLE_SUBSET THEN + EXISTS_TAC `rational` THEN + REWRITE_TAC[COUNTABLE_RATIONAL] THEN SET_TAC[]; + REWRITE_TAC[FORALL_IN_IMAGE; FORALL_PAIR_THM; + IN_CROSS; IN_ELIM_THM] THEN + SIMP_TAC[OPEN_IN_MBALL]; + MAP_EVERY X_GEN_TAC [`u:A->bool`; `x:A`] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [OPEN_IN_MTOPOLOGY]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPEC `x:A`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `r:real` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `x:A IN mspace m` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `?d:A. d IN D /\ d IN mball m (x, r / &2)` + STRIP_ASSUME_TAC THENL + [MP_TAC(ISPECL [`mtopology m:A topology`; + `D:A->bool`; `x:A`] IN_CLOSURE_OF) THEN + ASM_REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN + DISCH_THEN(MP_TAC o SPEC `mball m (x:A, r / &2)`) THEN + ASM_SIMP_TAC[OPEN_IN_MBALL; CENTRE_IN_MBALL; + REAL_HALF] THEN + MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `d:A IN mspace m` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + ABBREV_TAC `delta = mdist m (x:A,d)` THEN + SUBGOAL_THEN `delta < r / &2` ASSUME_TAC THENL + [UNDISCH_TAC `(d:A) IN mball m (x:A, r / &2)` THEN + REWRITE_TAC[IN_MBALL] THEN EXPAND_TAC "delta" THEN + MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `delta < r - delta` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + MP_TAC(SPECL [`delta:real`; `r - delta:real`] + RATIONAL_BETWEEN) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `q:real` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `&0 < q` ASSUME_TAC THENL + [SUBGOAL_THEN `&0 <= delta` MP_TAC THENL + [EXPAND_TAC "delta" THEN MATCH_MP_TAC MDIST_POS_LE THEN + ASM_REWRITE_TAC[]; + ASM_REAL_ARITH_TAC]; ALL_TAC] THEN + SUBGOAL_THEN `mdist m (d:A,x) = mdist m (x,d)` ASSUME_TAC THENL + [MATCH_MP_TAC MDIST_SYM THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[EXISTS_IN_IMAGE; EXISTS_PAIR_THM; IN_CROSS; + IN_ELIM_THM] THEN + EXISTS_TAC `d:A` THEN EXISTS_TAC `q:real` THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [REWRITE_TAC[IN_MBALL] THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[SUBSET; IN_MBALL] THEN + X_GEN_TAC `y:A` THEN ASM_REWRITE_TAC[] THEN + STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [SUBSET]) THEN + DISCH_THEN MATCH_MP_TAC THEN + REWRITE_TAC[IN_MBALL] THEN ASM_REWRITE_TAC[] THEN + TRANS_TAC REAL_LET_TRANS + `mdist m (x:A,d) + mdist m (d,y)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC MDIST_TRIANGLE THEN ASM_REWRITE_TAC[]; + ASM_REAL_ARITH_TAC]]]);; + +let SECOND_COUNTABLE_CLOSED_MAP_IMAGE = prove + (`!(f:B->C) top top'. + continuous_map(top,top') f /\ + closed_map(top,top') f /\ + compact_space top /\ + hausdorff_space top' /\ + IMAGE f (topspace top) = topspace top' /\ + second_countable top + ==> second_countable top'`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [second_countable]) THEN + DISCH_THEN(X_CHOOSE_THEN `B:(B->bool)->bool` + STRIP_ASSUME_TAC) THEN + REWRITE_TAC[second_countable] THEN EXISTS_TAC + `IMAGE (\G. topspace top' DIFF + IMAGE (f:B->C) (topspace top DIFF UNIONS G)) + {G:(B->bool)->bool | G SUBSET B /\ FINITE G}` THEN + REPEAT CONJ_TAC THENL + [MATCH_MP_TAC COUNTABLE_IMAGE THEN + MATCH_MP_TAC COUNTABLE_FINITE_SUBSETS THEN + ASM_REWRITE_TAC[]; + REWRITE_TAC[FORALL_IN_IMAGE; IN_ELIM_THM] THEN + X_GEN_TAC `G:(B->bool)->bool` THEN STRIP_TAC THEN + MATCH_MP_TAC OPEN_IN_DIFF THEN + REWRITE_TAC[OPEN_IN_TOPSPACE] THEN + FIRST_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [closed_map]) THEN + DISCH_THEN MATCH_MP_TAC THEN + MATCH_MP_TAC CLOSED_IN_DIFF THEN + REWRITE_TAC[CLOSED_IN_TOPSPACE] THEN + MATCH_MP_TAC OPEN_IN_UNIONS THEN ASM_MESON_TAC[SUBSET]; + MAP_EVERY X_GEN_TAC [`v:C->bool`; `y:C`] THEN + STRIP_TAC THEN + REWRITE_TAC[EXISTS_IN_IMAGE; IN_ELIM_THM] THEN + SUBGOAL_THEN `y:C IN topspace top'` ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; ALL_TAC] THEN + SUBGOAL_THEN + `closed_in top + {x:B | x IN topspace top /\ (f:B->C) x IN {y:C}}` + ASSUME_TAC THENL + [MATCH_MP_TAC CLOSED_IN_CONTINUOUS_MAP_PREIMAGE THEN + EXISTS_TAC `top':C topology` THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CLOSED_IN_T1_SING THEN + ASM_SIMP_TAC[HAUSDORFF_IMP_T1_SPACE]; ALL_TAC] THEN + ABBREV_TAC + `fib = {x:B | x IN topspace top /\ + (f:B->C) x IN {y:C}}` THEN + SUBGOAL_THEN `compact_in top (fib:B->bool)` ASSUME_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_COMPACT_SPACE]; ALL_TAC] THEN + ABBREV_TAC + `preim = {x:B | x IN topspace top /\ + (f:B->C) x IN v}` THEN + SUBGOAL_THEN `open_in top (preim:B->bool)` ASSUME_TAC THENL + [EXPAND_TAC "preim" THEN + MATCH_MP_TAC OPEN_IN_CONTINUOUS_MAP_PREIMAGE THEN + EXISTS_TAC `top':C topology` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `fib SUBSET (preim:B->bool)` ASSUME_TAC THENL + [EXPAND_TAC "fib" THEN EXPAND_TAC "preim" THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_SING] THEN + ASM SET_TAC[]; ALL_TAC] THEN + ABBREV_TAC + `cov = {w:B->bool | w IN B /\ w SUBSET preim}` THEN + SUBGOAL_THEN + `fib SUBSET UNIONS (cov:(B->bool)->bool)` + ASSUME_TAC THENL + [REWRITE_TAC[SUBSET; IN_UNIONS] THEN + X_GEN_TAC `a:B` THEN DISCH_TAC THEN + SUBGOAL_THEN `(a:B) IN preim` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o + SPECL [`preim:B->bool`; `a:B`]) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `w:B->bool` + STRIP_ASSUME_TAC) THEN + EXISTS_TAC `w:B->bool` THEN ASM_REWRITE_TAC[] THEN + EXPAND_TAC "cov" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `!w:B->bool. w IN cov ==> open_in top w` + ASSUME_TAC THENL + [EXPAND_TAC "cov" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_MESON_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [compact_in]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPEC `cov:(B->bool)->bool`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `G:(B->bool)->bool` + STRIP_ASSUME_TAC) THEN + EXISTS_TAC `G:(B->bool)->bool` THEN + SUBGOAL_THEN `(G:(B->bool)->bool) SUBSET B` ASSUME_TAC THENL + [EXPAND_TAC "cov" THEN ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `UNIONS G SUBSET (preim:B->bool)` ASSUME_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET] THEN + X_GEN_TAC `w:B->bool` THEN DISCH_TAC THEN + SUBGOAL_THEN `(w:B->bool) IN cov` MP_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + EXPAND_TAC "cov" THEN REWRITE_TAC[IN_ELIM_THM] THEN + MESON_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL + [REWRITE_TAC[IN_DIFF; IN_IMAGE; NOT_EXISTS_THM] THEN + ASM_REWRITE_TAC[] THEN X_GEN_TAC `a:B` THEN + REWRITE_TAC[IN_DIFF] THEN STRIP_TAC THEN + SUBGOAL_THEN `(a:B) IN fib` MP_TAC THENL + [EXPAND_TAC "fib" THEN ASM SET_TAC[]; ALL_TAC] THEN + ASM SET_TAC[]; ALL_TAC] THEN + REWRITE_TAC[SUBSET; IN_DIFF] THEN + X_GEN_TAC `z:C` THEN STRIP_TAC THEN + SUBGOAL_THEN `?a:B. a IN topspace top /\ (f:B->C) a = z` + STRIP_ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(a:B) IN UNIONS G` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + EXPAND_TAC "preim" THEN ASM SET_TAC[]]);; + (* ------------------------------------------------------------------------- *) (* Connected topological spaces. *) (* ------------------------------------------------------------------------- *) @@ -12825,6 +13027,283 @@ let CONNECTED_IN_NONSEPARATED_UNION = prove SEPARATED_IN_MONO)) THEN ASM SET_TAC[]);; +let CONNECTED_IN_UNIONS_STRONG = prove + (`!(top:A topology) f:(A->bool)->bool. + (!s. s IN f ==> connected_in top s) /\ + ~(UNIONS f INTER INTERS {top closure_of s | s IN f} = {}) + ==> connected_in top (UNIONS f)`, + REPEAT GEN_TAC THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER; IN_UNIONS; INTERS_GSPEC] THEN + REWRITE_TAC[IN_ELIM_THM] THEN STRIP_TAC THEN + (* Now we have assumptions: + 0: !s. s IN f ==> connected_in top s + 1: t IN f + 2: x IN t + 3: !s. s IN f ==> x IN top closure_of s *) + (* Define g = {t UNION s | s IN f} where t is our witness set containing x *) + SUBGOAL_THEN + `UNIONS f :A->bool = UNIONS {(t:A->bool) UNION s | s IN f}` + SUBST1_TAC THENL + [MATCH_MP_TAC(SET_RULE + `(t:A->bool) IN f /\ (!s. s IN f ==> s SUBSET t UNION s) /\ + (!s. s IN f ==> t UNION s SUBSET UNIONS f) + ==> UNIONS f = UNIONS {t UNION s | s IN f}`) THEN + ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [SET_TAC[]; ALL_TAC] THEN + X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN + REWRITE_TAC[UNION_SUBSET] THEN + CONJ_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN ASM SET_TAC[]; + ALL_TAC] THEN + MATCH_MP_TAC CONNECTED_IN_UNIONS THEN CONJ_TAC THENL + [(* Each t UNION s is connected *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC CONNECTED_IN_NONSEPARATED_UNION THEN + REPEAT CONJ_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[separated_in; DE_MORGAN_THM] THEN + DISJ2_TAC THEN DISJ2_TAC THEN DISJ1_TAC THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN EXISTS_TAC `x:A` THEN + ASM_REWRITE_TAC[IN_INTER] THEN FIRST_X_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]]; + (* INTERS {t UNION s | s IN f} is non-empty *) + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; INTERS_GSPEC; IN_ELIM_THM] THEN + EXISTS_TAC `x:A` THEN X_GEN_TAC `v:A->bool` THEN + DISCH_TAC THEN ASM_REWRITE_TAC[IN_UNION]]);; + +(* ------------------------------------------------------------------------- *) +(* Connectedness of the intersection of a chain of compact connected sets. *) +(* This is the general topology version of CONNECTED_CHAIN from topology.ml. *) +(* Hausdorff is needed to separate disjoint compact sets. *) +(* ------------------------------------------------------------------------- *) + +let CONNECTED_IN_CHAIN = prove + (`!top (f:(A->bool)->bool). + hausdorff_space top /\ + ~(f = {}) /\ + (!s. s IN f ==> compact_in top s /\ connected_in top s) /\ + (!s t. s IN f /\ t IN f ==> s SUBSET t \/ t SUBSET s) + ==> connected_in top (INTERS f)`, + REPEAT STRIP_TAC THEN + ABBREV_TAC `c:A->bool = INTERS f` THEN + SUBGOAL_THEN `?k:A->bool. k IN f` STRIP_ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `!s:A->bool. s IN f ==> s SUBSET topspace top` + ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBSET_TOPSPACE]; ALL_TAC] THEN + SUBGOAL_THEN `!s:A->bool. s IN f ==> closed_in top s` ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_IMP_CLOSED_IN]; ALL_TAC] THEN + SUBGOAL_THEN `compact_in top (c:A->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC CLOSED_COMPACT_IN THEN EXISTS_TAC `k:A->bool` THEN + REPEAT CONJ_TAC THENL + [ASM_MESON_TAC[]; + EXPAND_TAC "c" THEN MATCH_MP_TAC INTERS_SUBSET_STRONG THEN + EXISTS_TAC `k:A->bool` THEN ASM_REWRITE_TAC[SUBSET_REFL]; + EXPAND_TAC "c" THEN MATCH_MP_TAC CLOSED_IN_INTERS THEN + CONJ_TAC THENL [ASM SET_TAC[]; ASM_MESON_TAC[]]]; + ALL_TAC] THEN + SUBGOAL_THEN `(c:A->bool) SUBSET topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBSET_TOPSPACE]; ALL_TAC] THEN + REWRITE_TAC[CONNECTED_IN_CLOSED_IN; NOT_EXISTS_THM] THEN + ASM_REWRITE_TAC[] THEN + MAP_EVERY X_GEN_TAC [`e1:A->bool`; `e2:A->bool`] THEN STRIP_TAC THEN + ABBREV_TAC `a:A->bool = c INTER e1` THEN + ABBREV_TAC `b:A->bool = c INTER e2` THEN + SUBGOAL_THEN + `compact_in top (a:A->bool) /\ compact_in top (b:A->bool)` + STRIP_ASSUME_TAC THENL + [MAP_EVERY EXPAND_TAC ["a"; "b"] THEN + CONJ_TAC THEN MATCH_MP_TAC COMPACT_INTER_CLOSED_IN THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN + `DISJOINT (a:A->bool) b /\ ~(a = {}) /\ ~(b = {})` + STRIP_ASSUME_TAC THENL + [MAP_EVERY EXPAND_TAC ["a"; "b"] THEN ASM SET_TAC[]; + ALL_TAC] THEN + MP_TAC(ISPECL [`top:A topology`; `a:A->bool`; `b:A->bool`] + HAUSDORFF_SPACE_COMPACT_SEPARATION) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` + (X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC)) THEN + SUBGOAL_THEN `(c:A->bool) SUBSET u UNION v` ASSUME_TAC THENL + [MAP_EVERY EXPAND_TAC ["a"; "b"] THEN ASM SET_TAC[]; + ALL_TAC] THEN + (* Cover k with (u UNION v) and complements of elements of f *) + SUBGOAL_THEN `compact_in top (k:A->bool)` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[compact_in] THEN DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPEC + `(u UNION v:A->bool) INSERT IMAGE (\s:A->bool. topspace top DIFF s) f`)) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_INSERT; FORALL_IN_IMAGE] THEN + ASM_MESON_TAC[OPEN_IN_UNION; OPEN_IN_DIFF; OPEN_IN_TOPSPACE]; + REWRITE_TAC[UNIONS_INSERT; SUBSET; IN_UNION] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + ASM_CASES_TAC `(x:A) IN c` THENL + [DISJ1_TAC THEN + UNDISCH_TAC `(c:A->bool) SUBSET u UNION v` THEN ASM SET_TAC[]; + DISJ2_TAC THEN REWRITE_TAC[UNIONS_IMAGE; IN_ELIM_THM] THEN + UNDISCH_TAC `~((x:A) IN c)` THEN EXPAND_TAC "c" THEN + REWRITE_TAC[IN_INTERS; NOT_FORALL_THM; NOT_IMP] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `r:A->bool` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[IN_DIFF] THEN + UNDISCH_TAC `(x:A) IN k` THEN + UNDISCH_TAC `!s:A->bool. s IN f ==> s SUBSET topspace top` THEN + UNDISCH_TAC `(k:A->bool) IN f` THEN + POP_ASSUM_LIST(K ALL_TAC) THEN SET_TAC[]]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `g:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN + `?f':(A->bool)->bool. FINITE f' /\ f' SUBSET f /\ + g DELETE (u UNION v:A->bool) = + IMAGE (\s:A->bool. topspace top DIFF s) f'` + STRIP_ASSUME_TAC THENL + [REWRITE_TAC[GSYM FINITE_SUBSET_IMAGE] THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[FINITE_DELETE]; ALL_TAC] THEN + UNDISCH_TAC `g SUBSET (u UNION v:A->bool) INSERT + IMAGE (\s:A->bool. topspace top DIFF s) f` THEN + SET_TAC[]; + ALL_TAC] THEN + (* Find minimum element j in f' *) + SUBGOAL_THEN + `?j:A->bool. j IN f /\ + UNIONS(IMAGE (\s. topspace top DIFF s) f') SUBSET + (topspace top DIFF j)` + STRIP_ASSUME_TAC THENL + [ASM_CASES_TAC `f':(A->bool)->bool = {}` THEN + ASM_REWRITE_TAC[IMAGE_CLAUSES; UNIONS_0; EMPTY_SUBSET] THENL + [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `?j:A->bool. j IN f' /\ + UNIONS(IMAGE (\s. topspace top DIFF s) f') SUBSET + (topspace top DIFF j)` + MP_TAC THENL [ALL_TAC; ASM_MESON_TAC[SUBSET]] THEN + SUBGOAL_THEN + `!s t:A->bool. s IN f' /\ t IN f' ==> s SUBSET t \/ t SUBSET s` + MP_TAC THENL [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + UNDISCH_TAC `~(f':(A->bool)->bool = {})` THEN + UNDISCH_TAC `FINITE(f':(A->bool)->bool)` THEN + SPEC_TAC(`f':(A->bool)->bool`,`f':(A->bool)->bool`) THEN + MATCH_MP_TAC FINITE_INDUCT_STRONG THEN REWRITE_TAC[] THEN + REWRITE_TAC[EXISTS_IN_INSERT; IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN + REWRITE_TAC[FORALL_IN_INSERT] THEN POP_ASSUM_LIST(K ALL_TAC) THEN + MAP_EVERY X_GEN_TAC [`i:A->bool`; `ff:(A->bool)->bool`] THEN + ASM_CASES_TAC `ff:(A->bool)->bool = {}` THEN + ASM_REWRITE_TAC[IMAGE_CLAUSES; UNIONS_INSERT; NOT_IN_EMPTY; + UNIONS_0; UNION_EMPTY; SUBSET_REFL] THEN + DISCH_THEN(fun th -> REPEAT DISCH_TAC THEN MP_TAC th) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `j:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(topspace top DIFF j) SUBSET (topspace top DIFF i) \/ + (topspace top DIFF i:A->bool) SUBSET (topspace top DIFF j)` + STRIP_ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `j:A->bool` o CONJUNCT2) THEN + ASM SET_TAC[]; + DISJ1_TAC THEN ASM SET_TAC[]; + DISJ2_TAC THEN EXISTS_TAC `j:A->bool` THEN ASM SET_TAC[]]; + ALL_TAC] THEN + (* j INTER k SUBSET u UNION v *) + SUBGOAL_THEN `(j INTER k:A->bool) SUBSET (u UNION v)` ASSUME_TAC THENL + [MATCH_MP_TAC(SET_RULE + `(k:A->bool) SUBSET (u UNION v) UNION (topspace top DIFF j) + ==> (j INTER k) SUBSET (u UNION v)`) THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `UNIONS g:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC + `UNIONS((u UNION v:A->bool) INSERT (g DELETE (u UNION v)))` THEN + CONJ_TAC THENL + [MATCH_MP_TAC SUBSET_UNIONS THEN SET_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN ONCE_REWRITE_TAC[UNIONS_INSERT] THEN + ASM SET_TAC[]; + ALL_TAC] THEN + (* c SUBSET j INTER k *) + SUBGOAL_THEN `(c:A->bool) SUBSET j INTER k` ASSUME_TAC THENL + [EXPAND_TAC "c" THEN REWRITE_TAC[SUBSET_INTER] THEN + CONJ_TAC THEN MATCH_MP_TAC INTERS_SUBSET_STRONG THEN + ASM_REWRITE_TAC[SUBSET_REFL] THEN ASM SET_TAC[]; + ALL_TAC] THEN + (* j INTER k is connected *) + SUBGOAL_THEN `connected_in top (j INTER k:A->bool)` MP_TAC THENL + [UNDISCH_TAC `(j:A->bool) IN f` THEN + UNDISCH_TAC `(k:A->bool) IN f` THEN + UNDISCH_TAC + `!s t:A->bool. s IN f /\ t IN f ==> s SUBSET t \/ t SUBSET s` THEN + UNDISCH_TAC + `!s:A->bool. s IN f ==> compact_in top s /\ connected_in top s` THEN + POP_ASSUM_LIST(K ALL_TAC) THEN + MESON_TAC[SET_RULE `(s:A->bool) SUBSET t ==> s INTER t = s`; + SET_RULE `(t:A->bool) SUBSET s ==> s INTER t = t`]; + ALL_TAC] THEN + (* Contradiction: connected but split by u, v *) + REWRITE_TAC[CONNECTED_IN; NOT_EXISTS_THM] THEN + DISCH_THEN(CONJUNCTS_THEN2 (K ALL_TAC) + (MP_TAC o SPECL [`u:A->bool`; `v:A->bool`])) THEN + REWRITE_TAC[TAUT `(~p ==> F) <=> p`] THEN + REPEAT CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; + FIRST_ASSUM ACCEPT_TAC; + FIRST_ASSUM ACCEPT_TAC; + UNDISCH_TAC `DISJOINT (u:A->bool) v` THEN SET_TAC[]; + MAP_EVERY EXPAND_TAC ["a"] THEN ASM SET_TAC[]; + MAP_EVERY EXPAND_TAC ["b"] THEN ASM SET_TAC[]]);; + +let CONNECTED_IN_CHAIN_GEN = prove + (`!top (f:(A->bool)->bool). + hausdorff_space top /\ + (!s. s IN f ==> closed_in top s /\ connected_in top s) /\ + (?s. s IN f /\ compact_in top s) /\ + (!s t. s IN f /\ t IN f ==> s SUBSET t \/ t SUBSET s) + ==> connected_in top (INTERS f)`, + REPEAT GEN_TAC THEN + DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC) THEN + FIRST_X_ASSUM(X_CHOOSE_THEN `s:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN + `INTERS f = INTERS(IMAGE (\t:A->bool. s INTER t) f)` + SUBST1_TAC THENL + [REWRITE_TAC[EXTENSION; INTERS_IMAGE] THEN ASM SET_TAC[]; + MATCH_MP_TAC CONNECTED_IN_CHAIN THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM; FORALL_IN_IMAGE] THEN + CONJ_TAC THENL [REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; EXISTS_IN_IMAGE] THEN + ASM SET_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL + [X_GEN_TAC `t:A->bool` THEN DISCH_TAC THEN CONJ_TAC THENL + [MATCH_MP_TAC COMPACT_INTER_CLOSED_IN THEN ASM_MESON_TAC[]; + SUBGOAL_THEN `s INTER t:A->bool = s \/ s INTER t = t` + (DISJ_CASES_THEN SUBST1_TAC) THEN ASM_MESON_TAC[SET_RULE + `(s:A->bool) SUBSET t ==> s INTER t = s`; + SET_RULE `(t:A->bool) SUBSET s ==> s INTER t = t`]]; + ASM SET_TAC[]]]);; + +let CONNECTED_IN_NEST = prove + (`!top (s:num->A->bool). + hausdorff_space top /\ + (!n. compact_in top (s n) /\ connected_in top (s n)) /\ + (!m n. m <= n ==> s n SUBSET s m) + ==> connected_in top (INTERS {s n | n IN (:num)})`, + REPEAT GEN_TAC THEN STRIP_TAC THEN MATCH_MP_TAC CONNECTED_IN_CHAIN THEN + ASM_SIMP_TAC[FORALL_IN_GSPEC; IN_UNIV; IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN + CONJ_TAC THENL + [REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN EXISTS_TAC `(s:num->A->bool) 0` THEN + REWRITE_TAC[IN_ELIM_THM] THEN EXISTS_TAC `0` THEN REWRITE_TAC[IN_UNIV]; + MATCH_MP_TAC WLOG_LE THEN ASM_MESON_TAC[]]);; + +let CONNECTED_IN_NEST_GEN = prove + (`!top (s:num->A->bool). + hausdorff_space top /\ + (!n. closed_in top (s n) /\ connected_in top (s n)) /\ + (?n. compact_in top (s n)) /\ + (!m n. m <= n ==> s n SUBSET s m) + ==> connected_in top (INTERS {s n | n IN (:num)})`, + REPEAT GEN_TAC THEN + DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC) THEN + MATCH_MP_TAC CONNECTED_IN_CHAIN_GEN THEN + ASM_SIMP_TAC[FORALL_IN_GSPEC; IN_UNIV; IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN + CONJ_TAC THENL + [REWRITE_TAC[EXISTS_IN_GSPEC; IN_UNIV] THEN ASM_MESON_TAC[]; + MATCH_MP_TAC WLOG_LE THEN ASM_MESON_TAC[]]);; + let CONNECTED_IN_EQ_SUBSET_SEPARATED_UNION = prove (`!top c:A->bool. connected_in top c <=> @@ -13967,6 +14446,25 @@ let CONNECTED_COMPONENTS_OF_OVERLAP = prove REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM; connected_components_of] THEN SIMP_TAC[FORALL_IN_GSPEC; DISJOINT; CONNECTED_COMPONENT_OF_NONOVERLAP]);; +let CONNECTED_IN_IFF_CONNECTED_COMPONENT_OF = prove + (`!top s:A->bool. + connected_in top s <=> + s SUBSET topspace top /\ + !x y. x IN s /\ y IN s ==> connected_component_of (subtopology top s) x y`, + REPEAT GEN_TAC THEN EQ_TAC THENL + [DISCH_TAC THEN CONJ_TAC THENL + [ASM_MESON_TAC[connected_in]; ALL_TAC] THEN + REPEAT STRIP_TAC THEN + MP_TAC(ISPEC `subtopology top s:A topology` CONNECTED_SPACE_IFF_CONNECTED_COMPONENT) THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [connected_in]) THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY] THEN + STRIP_TAC THEN ASM_SIMP_TAC[SET_RULE `(s:A->bool) SUBSET t ==> t INTER s = s`]; + STRIP_TAC THEN REWRITE_TAC[connected_in] THEN + ASM_REWRITE_TAC[] THEN + MP_TAC(ISPEC `subtopology top s:A topology` CONNECTED_SPACE_IFF_CONNECTED_COMPONENT) THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY] THEN + ASM_SIMP_TAC[SET_RULE `(s:A->bool) SUBSET t ==> t INTER s = s`]]);; + let PAIRWISE_SEPARATED_CONNECTED_COMPONENTS_OF = prove (`!top:A topology. pairwise (separated_in top) (connected_components_of top)`, @@ -19534,6 +20032,70 @@ let TOTALLY_BOUNDED_IN_CLOSURE_OF_EQ = prove MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ_ALT] TOTALLY_BOUNDED_IN_SUBSET) THEN ASM_SIMP_TAC[CLOSURE_OF_SUBSET; TOPSPACE_MTOPOLOGY]);; +let MBALL_INTER_DSEPARATED_SINGLETON = prove + (`!m:A metric s t d x y. + t SUBSET s /\ s SUBSET mspace m /\ &0 < d /\ + (!a b. a IN t /\ b IN t /\ ~(a = b) ==> mdist m (a,b) >= d) /\ + x IN mspace m /\ y IN mball m (x, d / &2) INTER t + ==> mball m (x, d / &2) INTER t = {y}`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [(* mball INTER t SUBSET {y} *) + REWRITE_TAC[SUBSET; IN_SING] THEN X_GEN_TAC `z:A` THEN + REWRITE_TAC[IN_INTER; IN_MBALL] THEN STRIP_TAC THEN + (* Prove z = y by contradiction: triangle gives mdist(y,z) < d, + but y,z IN t and y =/= z gives mdist(y,z) >= d *) + MATCH_MP_TAC(TAUT `(~p ==> F) ==> p`) THEN DISCH_TAC THEN + RULE_ASSUM_TAC(REWRITE_RULE[IN_INTER; IN_MBALL]) THEN + SUBGOAL_THEN `mdist m (y:A, z) >= d` MP_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `mdist m (y:A, z) <= mdist m (x,y) + mdist m (x,z)` + MP_TAC THENL + [ASM_MESON_TAC[MDIST_TRIANGLE; MDIST_SYM]; ASM_REAL_ARITH_TAC]; + (* {y} SUBSET mball INTER t *) + REWRITE_TAC[SING_SUBSET] THEN ASM_REWRITE_TAC[]]);; + +let TOTALLY_BOUNDED_IMP_DISCRETE_FINITE = prove + (`!m:A metric s t d. + totally_bounded_in m s /\ t SUBSET s /\ &0 < d /\ + (!x y. x IN t /\ y IN t /\ ~(x = y) ==> mdist m (x,y) >= d) + ==> FINITE t`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Get s SUBSET mspace m from totally_bounded_in *) + SUBGOAL_THEN `(s:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [MATCH_MP_TAC TOTALLY_BOUNDED_IN_IMP_SUBSET THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Use totally_bounded_in with e = d/2 to get finite cover *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [totally_bounded_in]) THEN + DISCH_THEN(MP_TAC o SPEC `d / &2`) THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `k:A->bool` STRIP_ASSUME_TAC) THEN + (* t = UNIONS {mball m (x, d/2) INTER t | x IN k} *) + SUBGOAL_THEN `t = UNIONS {mball m (x:A, d / &2) INTER t | x IN k}` + SUBST1_TAC THENL + [SUBGOAL_THEN `(t:A->bool) SUBSET UNIONS {mball m (x, d / &2) | x IN k}` + MP_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + REWRITE_TAC[EXTENSION; UNIONS_GSPEC; IN_ELIM_THM; IN_INTER; SUBSET] THEN + MESON_TAC[]; + ALL_TAC] THEN + (* Apply FINITE_FINITE_UNIONS *) + SUBGOAL_THEN `FINITE {mball m (x:A, d / &2) INTER t | x IN k}` ASSUME_TAC THENL + [REWRITE_TAC[SIMPLE_IMAGE] THEN MATCH_MP_TAC FINITE_IMAGE THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + FIRST_X_ASSUM(fun th -> REWRITE_TAC[MATCH_MP FINITE_FINITE_UNIONS th]) THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + (* Each mball(x, d/2) INTER t is empty or singleton, hence finite *) + ASM_CASES_TAC `mball m (x:A, d / &2) INTER t = {}` THENL + [ASM_REWRITE_TAC[FINITE_EMPTY]; ALL_TAC] THEN + (* Non-empty case: use MBALL_INTER_DSEPARATED_SINGLETON *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + DISCH_THEN(X_CHOOSE_TAC `y:A`) THEN + SUBGOAL_THEN `mball m (x:A, d / &2) INTER t = {y}` SUBST1_TAC THENL + [MATCH_MP_TAC MBALL_INTER_DSEPARATED_SINGLETON THEN + EXISTS_TAC `s:A->bool` THEN ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + REWRITE_TAC[FINITE_SING]]);; + let TOTALLY_BOUNDED_IN_CAUCHY_SEQUENCE = prove (`!m x:num->A. cauchy_in m x ==> totally_bounded_in m (IMAGE x (:num))`, @@ -20678,6 +21240,180 @@ let CONTINUOUS_MAP_CASES_LT = prove ASM_REWRITE_TAC[REAL_ARITH `p - q <= &0 <=> p <= q`] THEN ASM_MESON_TAC[]);; +(* ------------------------------------------------------------------------- *) +(* Some elementary results on real limits, proved here for convenience. *) +(* ------------------------------------------------------------------------- *) + +parse_as_infix("--->",(12,"right"));; + +let tendsto_real_def = new_definition + `(f ---> l) (net:A net) <=> limit euclideanreal f l net`;; + +let reallim = new_definition + `reallim net (f:A->real) = @l. (f ---> l) net`;; + +(* Epsilon-delta characterization (named to avoid clash with TENDSTO_REAL + in realanalysis.ml, which is the lift/drop bridge theorem) *) +let TENDSTO_REAL_EPS_DELTA = prove + (`!(f:A->real) l net. + (f ---> l) net <=> + !e. &0 < e ==> eventually (\x. abs(f x - l) < e) net`, + REPEAT GEN_TAC THEN + REWRITE_TAC[tendsto_real_def; GSYM MTOPOLOGY_REAL_EUCLIDEAN_METRIC; + LIMIT_METRIC; REAL_EUCLIDEAN_METRIC; IN_UNIV] THEN + REWRITE_TAC[REAL_ARITH `abs(y - x) = abs(x - y)`]);; + +let REALLIM_CONST = prove + (`!net:A net a. ((\x. a) ---> a) net`, + REWRITE_TAC[tendsto_real_def; LIMIT_REAL_CONST]);; + +let REALLIM_SUB = prove + (`!net (f:A->real) g l m. + (f ---> l) net /\ (g ---> m) net + ==> ((\x. f x - g x) ---> l - m) net`, + REWRITE_TAC[tendsto_real_def; LIMIT_REAL_SUB]);; + +let REALLIM_UBOUND = prove + (`!net (f:A->real) l b. + (f ---> l) net /\ ~trivial_limit net /\ + eventually (\x. f x <= b) net + ==> l <= b`, + REPEAT GEN_TAC THEN REWRITE_TAC[tendsto_real_def] THEN STRIP_TAC THEN + MP_TAC(ISPECL + [`net:A net`; `euclideanreal`; `{x:real | x <= b}`; `f:A->real`; `l:real`] + LIMIT_IN_CLOSED_IN) THEN + ASM_REWRITE_TAC[IN_ELIM_THM; GSYM REAL_CLOSED_IN; REAL_CLOSED_HALFSPACE_LE]);; + +let REALLIM_LBOUND = prove + (`!net (f:A->real) l b. + (f ---> l) net /\ ~trivial_limit net /\ + eventually (\x. b <= f x) net + ==> b <= l`, + REPEAT GEN_TAC THEN REWRITE_TAC[tendsto_real_def] THEN STRIP_TAC THEN + MP_TAC(ISPECL + [`net:A net`; `euclideanreal`; `{x:real | x >= b}`; `f:A->real`; `l:real`] + LIMIT_IN_CLOSED_IN) THEN + ASM_REWRITE_TAC[IN_ELIM_THM; GSYM REAL_CLOSED_IN; + REAL_CLOSED_HALFSPACE_GE; real_ge]);; + +let REALLIM_LE = prove + (`!net (f:A->real) g l m. + (f ---> l) net /\ (g ---> m) net /\ ~trivial_limit net /\ + eventually (\x. f x <= g x) net + ==> l <= m`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + MATCH_MP_TAC(REAL_ARITH `&0 <= m - l ==> l <= m`) THEN + MATCH_MP_TAC(ISPEC `net:A net` REALLIM_LBOUND) THEN + EXISTS_TAC `\x:A. (g:A->real) x - f x` THEN + ASM_SIMP_TAC[REALLIM_SUB] THEN FIRST_X_ASSUM + (MP_TAC o MATCH_MP (REWRITE_RULE[IMP_CONJ_ALT] EVENTUALLY_MONO)) THEN + DISCH_THEN MATCH_MP_TAC THEN REAL_ARITH_TAC);; + +let REALLIM_SEQUENTIALLY = prove + (`!(f:num->real) l. + (f ---> l) sequentially <=> + !e. &0 < e ==> ?N. !n. N <= n ==> abs(f n - l) < e`, + REWRITE_TAC[TENDSTO_REAL_EPS_DELTA; EVENTUALLY_SEQUENTIALLY]);; + +(* ------------------------------------------------------------------------- *) +(* Similar elementary results for infinite series of reals. *) +(* ------------------------------------------------------------------------- *) + +parse_as_infix("real_sums",(12,"right"));; + +let real_sums = new_definition + `(f real_sums l) s <=> + ((\n. sum (s INTER (0..n)) f) ---> l) sequentially`;; + +let real_infsum = new_definition + `real_infsum s f = @l. (f real_sums l) s`;; + +let real_summable = new_definition + `real_summable s f <=> ?l. (f real_sums l) s`;; + +let REAL_SUMS_SUMMABLE = prove + (`!f l s. (f real_sums l) s ==> real_summable s f`, + REWRITE_TAC[real_summable] THEN MESON_TAC[]);; + +let REAL_SUMS_INFSUM = prove + (`!f s. (f real_sums (real_infsum s f)) s <=> real_summable s f`, + REWRITE_TAC[real_infsum; real_summable] THEN MESON_TAC[]);; + +let REAL_SERIES_FROM = prove + (`!f l k. (f real_sums l) (from k) <=> + ((\n. sum(k..n) f) ---> l) sequentially`, + REWRITE_TAC[real_sums; FROM_INTER_NUMSEG]);; + +(* Cauchy criterion for real summation *) +let REAL_SUMMABLE_CAUCHY = prove + (`!f s. + real_summable s f <=> + !e. &0 < e + ==> ?N. !m n. m >= N ==> abs(sum(s INTER (m..n)) f) < e`, + let lemma = prove + (`!f k m n. + m <= n + ==> sum(k INTER (0..n)) f - sum(k INTER (0..m)) f = + sum(k INTER (m+1..n)) f`, + SIMP_TAC[LE_EXISTS; LEFT_IMP_EXISTS_THM; NUMSEG_ADD_SPLIT; LE_0] THEN + SIMP_TAC[SUM_UNION; FINITE_INTER; FINITE_NUMSEG; DISJOINT_NUMSEG; + UNION_OVER_INTER; ARITH_RULE `n < n + 1`; SET_RULE + `DISJOINT (u:num->bool) v ==> DISJOINT (s INTER u) (s INTER v)`] THEN + REAL_ARITH_TAC) in + REWRITE_TAC[GE] THEN REPEAT STRIP_TAC THEN + ONCE_REWRITE_TAC[MESON[ARITH_RULE `N:num <= m ==> N <= m + 1`; + ARITH_RULE `N + 1 <= m ==> N <= m - 1 /\ (m - 1) + 1 = m`] + `(?N. !m n:num. N <= m ==> P m n) <=> ?N. !m n. N <= m ==> P(m + 1) n`] THEN + MP_TAC(REWRITE_RULE[MCOMPLETE_ALT] MCOMPLETE_REAL_EUCLIDEAN_METRIC) THEN + REWRITE_TAC[real_summable; MTOPOLOGY_REAL_EUCLIDEAN_METRIC; real_sums] THEN + REWRITE_TAC[tendsto_real_def; REAL_EUCLIDEAN_METRIC; IN_UNIV] THEN + DISCH_THEN(fun th -> REWRITE_TAC[GSYM th]) THEN + REWRITE_TAC[cauchy_in; REAL_EUCLIDEAN_METRIC; IN_UNIV] THEN + ONCE_REWRITE_TAC[MESON[LE_CASES; REAL_ABS_SUB] + `(!x y:num. P x /\ P y ==> abs(f y - f x):real < e) <=> + (!x y. x <= y ==> P x /\ P y ==> abs(f y - f x) < e)`] THEN + SIMP_TAC[lemma; MESON[NUMSEG_EMPTY; INTER_EMPTY; SUM_CLAUSES; REAL_ABS_0] + `!e. &0 < e ==> (P ==> abs(sum (s INTER (m..n)) f) < e <=> + P ==> n < m \/ abs(sum (s INTER (m..n)) f) < e)`] THEN + REWRITE_TAC[GE; NOT_LT; IMP_IMP; TAUT `a ==> b \/ c <=> a /\ ~b ==> c`] THEN + REWRITE_TAC[ARITH_RULE + `(n <= m /\ N <= n /\ N <= m) /\ n + 1 <= m <=> N <= n /\ n + 1 <= m`]);; + +(* Comparison test *) +let REAL_SUMMABLE_COMPARISON = prove + (`!f g s. real_summable s g /\ + (?N. !n. n >= N /\ n IN s ==> abs(f n) <= g n) + ==> real_summable s f`, + REPEAT GEN_TAC THEN REWRITE_TAC[REAL_SUMMABLE_CAUCHY] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (X_CHOOSE_TAC `N1:num`)) THEN + X_GEN_TAC `e:real` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `e:real`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_TAC `N2:num`) THEN EXISTS_TAC `N1 + N2:num` THEN + MAP_EVERY X_GEN_TAC [`m:num`; `n:num`] THEN DISCH_TAC THEN + MATCH_MP_TAC REAL_LET_TRANS THEN + EXISTS_TAC `abs(sum(s INTER (m..n)) g)` THEN CONJ_TAC THENL + [MATCH_MP_TAC(REAL_ARITH `abs x <= a ==> abs x <= abs a`) THEN + MATCH_MP_TAC SUM_ABS_LE THEN + REWRITE_TAC[FINITE_INTER_NUMSEG; IN_INTER; IN_NUMSEG] THEN + X_GEN_TAC `k:num` THEN STRIP_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[GE] THEN ASM_ARITH_TAC; + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC]);; + +let REAL_SERIES_LE = prove + (`!f g s y z. + (f real_sums y) s /\ (g real_sums z) s /\ + (!i. i IN s ==> f i <= g i) + ==> y <= z`, + REPEAT STRIP_TAC THEN + MATCH_MP_TAC(ISPEC `sequentially` REALLIM_LE) THEN + MAP_EVERY EXISTS_TAC + [`\n. sum(s INTER (0..n)) (f:num->real)`; + `\n. sum(s INTER (0..n)) (g:num->real)`] THEN + ASM_REWRITE_TAC[GSYM real_sums; TRIVIAL_LIMIT_SEQUENTIALLY] THEN + REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN EXISTS_TAC `0` THEN + REPEAT STRIP_TAC THEN MATCH_MP_TAC SUM_LE THEN + REWRITE_TAC[FINITE_INTER_NUMSEG; IN_INTER] THEN ASM_MESON_TAC[]);; + (* ------------------------------------------------------------------------- *) (* Paths and path-connectedness. *) (* ------------------------------------------------------------------------- *) @@ -23418,6 +24154,13 @@ let REGULAR_SECOND_COUNTABLE_IMP_HEREDITARILY_NORMAL_SPACE = prove MATCH_MP_TAC SECOND_COUNTABLE_IMP_LINDELOF_SPACE THEN ASM_SIMP_TAC[SECOND_COUNTABLE_SUBTOPOLOGY]);; +let REGULAR_SECOND_COUNTABLE_HAUSDORFF_IMP_NORMAL_SPACE = prove + (`!top:A topology. + regular_space top /\ second_countable top /\ hausdorff_space top + ==> normal_space top`, + MESON_TAC[REGULAR_LINDELOF_IMP_NORMAL_SPACE; + SECOND_COUNTABLE_IMP_LINDELOF_SPACE]);; + (* ------------------------------------------------------------------------- *) (* Completely regular spaces. *) (* ------------------------------------------------------------------------- *) @@ -31249,1455 +31992,6724 @@ let LAVRENTIEV_EXTENSION = prove ASM_MESON_TAC[SUBSET_TRANS; GDELTA_IN_SUBSET]]);; (* ------------------------------------------------------------------------- *) -(* "Capped" equivalent bounded metrics and general product metrics. *) +(* Diameter of a set in a metric space. *) (* ------------------------------------------------------------------------- *) -let capped_metric = new_definition - `capped_metric d (m:A metric) = - if d <= &0 then m - else metric(mspace m,(\(x,y). min d (mdist m (x,y))))`;; +let mdiameter = new_definition + `mdiameter (m:A metric) (s:A->bool) = + if s = {} then &0 + else sup {mdist m (x,y) | x IN s /\ y IN s}`;; -let CAPPED_METRIC = prove - (`!d m:A metric. - mspace (capped_metric d m) = mspace m /\ - mdist (capped_metric d m) = - \(x,y). if d <= &0 then mdist m (x,y) else min d (mdist m (x,y))`, - REPEAT GEN_TAC THEN ASM_CASES_TAC `d:real <= &0` THEN - ASM_REWRITE_TAC[capped_metric; PAIRED_ETA_THM; ETA_AX] THEN - REWRITE_TAC[capped_metric; mspace; mdist; GSYM PAIR_EQ] THEN - REWRITE_TAC[GSYM(CONJUNCT2 metric_tybij)] THEN - REWRITE_TAC[is_metric_space; GSYM mspace; GSYM mdist] THEN - ASM_SIMP_TAC[REAL_ARITH `~(d <= &0) ==> (&0 <= min d x <=> &0 <= x)`] THEN - ASM_SIMP_TAC[MDIST_POS_LE; MDIST_0; REAL_ARITH - `~(d <= &0) /\ &0 <= x ==> (min d x = &0 <=> x = &0)`] THEN - CONJ_TAC THENL [MESON_TAC[MDIST_SYM]; REPEAT STRIP_TAC] THEN - MATCH_MP_TAC(REAL_ARITH - `~(d <= &0) /\ &0 <= y /\ &0 <= z /\ x <= y + z - ==> min d x <= min d y + min d z`) THEN - ASM_MESON_TAC[MDIST_POS_LE; MDIST_TRIANGLE]);; +let MDIAMETER_EMPTY = prove + (`!m:A metric. mdiameter m {} = &0`, + REWRITE_TAC[mdiameter]);; -let MDIST_CAPPED = prove - (`!d m x y:A. &0 < d ==> mdist(capped_metric d m) (x,y) <= d`, - SIMP_TAC[CAPPED_METRIC; GSYM REAL_NOT_LT] THEN REAL_ARITH_TAC);; +let MDIAMETER_SING = prove + (`!m:A metric. !x. x IN mspace m ==> mdiameter m {x} = &0`, + REPEAT STRIP_TAC THEN + REWRITE_TAC[mdiameter; NOT_INSERT_EMPTY; IN_SING] THEN + REWRITE_TAC[SET_RULE `{f x y | x = a /\ y = a} = {f a a}`] THEN + ASM_SIMP_TAC[SUP_SING; MDIST_REFL]);; + +let MDIAMETER_POS_LE = prove + (`!m s:A->bool. mbounded m s ==> &0 <= mdiameter m s`, + REPEAT GEN_TAC THEN REWRITE_TAC[MBOUNDED_POS; LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`c:A`; `B:real`] THEN + REWRITE_TAC[SUBSET; IN_MCBALL] THEN STRIP_TAC THEN + REWRITE_TAC[mdiameter] THEN + COND_CASES_TAC THEN ASM_REWRITE_TAC[REAL_LE_REFL] THEN + MP_TAC(SPEC `{mdist m (x:A,y) | x IN s /\ y IN s}` SUP) THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN ANTS_TAC THENL + [CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + EXISTS_TAC `&2 * B` THEN + ASM_MESON_TAC[METRIC_ARITH + `c IN mspace m /\ x IN mspace m /\ y IN mspace m /\ + mdist m (c:A,x) <= B /\ mdist m (c,y) <= B + ==> mdist m (x,y) <= &2 * B`]; + ASM_MESON_TAC[MEMBER_NOT_EMPTY; MDIST_REFL]]);; + +let MDIAMETER_BOUNDED = prove + (`!m s:A->bool. + mbounded m s + ==> (!x y. x IN s /\ y IN s ==> mdist m (x,y) <= mdiameter m s) /\ + (!d. &0 <= d /\ d < mdiameter m s + ==> ?x y. x IN s /\ y IN s /\ mdist m (x,y) > d)`, + REPEAT GEN_TAC THEN REWRITE_TAC[MBOUNDED_POS; LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`c:A`; `B:real`] THEN + REWRITE_TAC[SUBSET; IN_MCBALL] THEN DISCH_TAC THEN + ASM_CASES_TAC `s:A->bool = {}` THEN + ASM_REWRITE_TAC[mdiameter; NOT_IN_EMPTY; REAL_LET_ANTISYM] THEN + MP_TAC(SPEC `{mdist m (x:A,y) | x IN s /\ y IN s}` SUP) THEN + ABBREV_TAC `b = sup {mdist m (x:A,y) | x IN s /\ y IN s}` THEN + REWRITE_TAC[EXTENSION; IN_ELIM_THM] THEN + REWRITE_TAC[NOT_IN_EMPTY; real_gt] THEN ANTS_TAC THENL + [CONJ_TAC THENL [ASM_MESON_TAC[MEMBER_NOT_EMPTY]; ALL_TAC] THEN + EXISTS_TAC `&2 * B` THEN + ASM_MESON_TAC[METRIC_ARITH + `c IN mspace m /\ x IN mspace m /\ y IN mspace m /\ + mdist m (c:A,x) <= B /\ mdist m (c,y) <= B + ==> mdist m (x,y) <= &2 * B`]; + MESON_TAC[REAL_NOT_LE]]);; + +let MDIAMETER_BOUNDED_BOUND = prove + (`!m s:A->bool x y. + mbounded m s /\ x IN s /\ y IN s + ==> mdist m (x,y) <= mdiameter m s`, + MESON_TAC[MDIAMETER_BOUNDED]);; + +let MDIAMETER_LE = prove + (`!m s:A->bool d. + s SUBSET mspace m /\ + (~(s = {}) \/ &0 <= d) /\ + (!x y. x IN s /\ y IN s ==> mdist m (x,y) <= d) + ==> mdiameter m s <= d`, + REPEAT GEN_TAC THEN REWRITE_TAC[mdiameter] THEN + COND_CASES_TAC THEN ASM_SIMP_TAC[] THEN + STRIP_TAC THEN MATCH_MP_TAC REAL_SUP_LE THEN + CONJ_TAC THENL [ASM SET_TAC[]; ASM_SIMP_TAC[FORALL_IN_GSPEC]]);; + +let MBOUNDED_AND_MDIAMETER_LE = prove + (`!m (s:A->bool) r. + s SUBSET mspace m + ==> (mbounded m s /\ mdiameter m s <= r <=> + &0 <= r /\ !x y. x IN s /\ y IN s ==> mdist m(x,y) <= r)`, + REPEAT STRIP_TAC THEN ASM_CASES_TAC `&0 <= r` THENL + [ASM_REWRITE_TAC[]; ASM_MESON_TAC[MDIAMETER_POS_LE; REAL_LE_TRANS]] THEN + EQ_TAC THENL + [MESON_TAC[MDIAMETER_BOUNDED_BOUND; REAL_LE_TRANS]; ALL_TAC] THEN + REPEAT STRIP_TAC THENL + [ALL_TAC; MATCH_MP_TAC MDIAMETER_LE THEN ASM_REWRITE_TAC[]] THEN + ASM_CASES_TAC `s:A->bool = {}` THEN ASM_REWRITE_TAC[MBOUNDED_EMPTY] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + DISCH_THEN(X_CHOOSE_TAC `a:A`) THEN + MATCH_MP_TAC MBOUNDED_SUBSET THEN EXISTS_TAC `mcball m (a:A,r)` THEN + ASM_SIMP_TAC[MBOUNDED_MCBALL; SUBSET; IN_MCBALL] THEN ASM SET_TAC[]);; -let MTOPOLOGY_CAPPED_METRIC = prove - (`!d m:A metric. mtopology(capped_metric d m) = mtopology m`, - REPEAT GEN_TAC THEN ASM_CASES_TAC `d <= &0` THENL - [ASM_MESON_TAC[capped_metric]; - RULE_ASSUM_TAC(REWRITE_RULE[REAL_NOT_LE])] THEN - REWRITE_TAC[TOPOLOGY_EQ] THEN - X_GEN_TAC `s:A->bool` THEN ASM_REWRITE_TAC[OPEN_IN_MTOPOLOGY] THEN - ASM_CASES_TAC `(s:A->bool) SUBSET mspace m` THEN - ASM_REWRITE_TAC[CAPPED_METRIC] THEN - AP_TERM_TAC THEN GEN_REWRITE_TAC I [FUN_EQ_THM] THEN - X_GEN_TAC `a:A` THEN ASM_CASES_TAC `(a:A) IN s` THEN ASM_REWRITE_TAC[] THEN - ASM_REWRITE_TAC[SUBSET; IN_MBALL] THEN - ASM_CASES_TAC `(a:A) IN mspace m` THENL - [ASM_REWRITE_TAC[CAPPED_METRIC]; ASM SET_TAC[]] THEN - EQ_TAC THEN - DISCH_THEN(X_CHOOSE_THEN `r:real` STRIP_ASSUME_TAC) THEN - EXISTS_TAC `min (d / &2) r` THEN - ASM_REWRITE_TAC[REAL_LT_MIN; REAL_HALF] THEN - REPEAT STRIP_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN - ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC);; +let MDIAMETER_SUBSET = prove + (`!m s t:A->bool. + s SUBSET t /\ mbounded m t ==> mdiameter m s <= mdiameter m t`, + REPEAT STRIP_TAC THEN + ASM_CASES_TAC `s:A->bool = {}` THEN + ASM_SIMP_TAC[MDIAMETER_EMPTY; MDIAMETER_POS_LE] THEN + ASM_REWRITE_TAC[mdiameter] THEN + COND_CASES_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC REAL_SUP_LE_SUBSET THEN + REPEAT(CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC]) THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [MBOUNDED_POS]) THEN + REWRITE_TAC[SUBSET; IN_MCBALL] THEN + MESON_TAC[METRIC_ARITH + `c IN mspace m /\ x IN mspace m /\ y IN mspace m /\ + mdist m (c:A,x) <= B /\ mdist m (c,y) <= B + ==> mdist m (x,y) <= &2 * B`]);; -let CAUCHY_IN_CAPPED_METRIC = prove - (`!d (m:A metric) x. - cauchy_in (capped_metric d m) x <=> cauchy_in m x`, - REPEAT GEN_TAC THEN ASM_CASES_TAC `d <= &0` THENL - [ASM_MESON_TAC[capped_metric]; ALL_TAC] THEN - ASM_REWRITE_TAC[cauchy_in; CAPPED_METRIC; REAL_MIN_LT] THEN - ASM_MESON_TAC[REAL_ARITH `~(d < min d e)`; REAL_LT_MIN; REAL_NOT_LE]);; - -let MCOMPLETE_CAPPED_METRIC = prove - (`!d (m:A metric). mcomplete(capped_metric d m) <=> mcomplete m`, - REWRITE_TAC[mcomplete; CAUCHY_IN_CAPPED_METRIC; MTOPOLOGY_CAPPED_METRIC]);; +let MBOUNDED_IMP_IN_MSPACE = prove + (`!m:A metric s x. mbounded m s /\ x IN s ==> x IN mspace m`, + REWRITE_TAC[mbounded; LEFT_IMP_EXISTS_THM; SUBSET] THEN + MESON_TAC[MCBALL_SUBSET_MSPACE; SUBSET]);; -let BOUNDED_EQUIVALENT_METRIC = prove - (`!m:A metric d. - &0 < d - ==> ?m'. mspace m' = mspace m /\ - mtopology m' = mtopology m /\ - !x y. mdist m' (x,y) < d`, - REPEAT STRIP_TAC THEN EXISTS_TAC `capped_metric (d / &2) m:A metric` THEN - ASM_REWRITE_TAC[MTOPOLOGY_CAPPED_METRIC; CAPPED_METRIC] THEN - ASM_REAL_ARITH_TAC);; +let MDIAMETER_CLOSURE = prove + (`!m s:A->bool. + mbounded m s + ==> mdiameter m (mtopology m closure_of s) = mdiameter m s`, + REPEAT STRIP_TAC THEN REWRITE_TAC[GSYM REAL_LE_ANTISYM] THEN CONJ_TAC THENL + [(* Direction: diam(closure s) <= diam(s) *) + ASM_CASES_TAC `s:A->bool = {}` THENL + [ASM_SIMP_TAC[CLOSURE_OF_EMPTY; MDIAMETER_EMPTY; REAL_LE_REFL]; + ALL_TAC] THEN + SUBGOAL_THEN `s SUBSET mspace (m:A metric)` ASSUME_TAC THENL + [ASM_MESON_TAC[MBOUNDED_SUBSET_MSPACE]; ALL_TAC] THEN + MATCH_MP_TAC MDIAMETER_LE THEN REPEAT CONJ_TAC THENL + [(* First conjunct: closure SUBSET mspace *) + REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY; CLOSURE_OF_SUBSET_TOPSPACE]; + (* Second conjunct: closure nonempty or 0 <= diam s *) + DISJ1_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + DISCH_THEN(X_CHOOSE_TAC `a:A`) THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN EXISTS_TAC `a:A` THEN + MP_TAC(ISPECL [`mtopology (m:A metric)`; `s:A->bool`] + CLOSURE_OF_SUBSET) THEN + ASM_SIMP_TAC[TOPSPACE_MTOPOLOGY] THEN ASM SET_TAC[]; + (* Third conjunct: distances in closure bounded by diam s *) + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN + REWRITE_TAC[METRIC_CLOSURE_OF; IN_ELIM_THM] THEN + DISCH_THEN(CONJUNCTS_THEN2 + (CONJUNCTS_THEN2 ASSUME_TAC (LABEL_TAC "Hx")) + (CONJUNCTS_THEN2 ASSUME_TAC (LABEL_TAC "Hy"))) THEN + (* Proof by contradiction: assume mdist(x,y) > diam(s) *) + REWRITE_TAC[GSYM REAL_NOT_LT] THEN DISCH_TAC THEN + ABBREV_TAC `e = mdist m (x:A,y) - mdiameter m s` THEN + SUBGOAL_THEN `&0 < e` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + (* Find x' in s close to x *) + REMOVE_THEN "Hx" (MP_TAC o SPEC `e / &4`) THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[IN_MBALL] THEN + DISCH_THEN(X_CHOOSE_THEN `x':A` STRIP_ASSUME_TAC) THEN + (* Find y' in s close to y *) + REMOVE_THEN "Hy" (MP_TAC o SPEC `e / &4`) THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[IN_MBALL] THEN + DISCH_THEN(X_CHOOSE_THEN `y':A` STRIP_ASSUME_TAC) THEN + (* Get membership facts *) + SUBGOAL_THEN `(x':A) IN mspace m /\ (y':A) IN mspace m` + STRIP_ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + (* Get the key bounds *) + SUBGOAL_THEN `mdist m (x':A,y') <= mdiameter m s` ASSUME_TAC THENL + [MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Triangle inequality *) + SUBGOAL_THEN + `mdist m (x:A,y) <= mdist m (x,x') + mdist m (x',y') + mdist m (y',y)` + ASSUME_TAC THENL + [ASM_MESON_TAC[METRIC_ARITH + `x IN mspace m /\ x' IN mspace m /\ y' IN mspace m /\ y IN mspace m + ==> mdist m (x:A,y) <= + mdist m (x,x') + mdist m (x',y') + mdist m (y',y)`]; + ALL_TAC] THEN + (* Symmetry *) + SUBGOAL_THEN `mdist m (y':A,y) = mdist m (y,y')` ASSUME_TAC THENL + [ASM_MESON_TAC[MDIST_SYM]; ALL_TAC] THEN + (* Derive contradiction *) + ASM_REAL_ARITH_TAC]; + (* Direction: diam(s) <= diam(closure s) *) + MATCH_MP_TAC MDIAMETER_SUBSET THEN + ASM_SIMP_TAC[CLOSURE_OF_SUBSET; TOPSPACE_MTOPOLOGY; + MBOUNDED_CLOSURE_OF; MBOUNDED_SUBSET_MSPACE]]);; -let SUP_METRIC_CARTESIAN_PRODUCT = prove - (`!k (m:K->(A)metric) m'. - metric(cartesian_product k (mspace o m), - \(x,y). sup {mdist(m i) (x i,y i) | i IN k}) = m' /\ - ~(k = {}) /\ - (?c. !i x y. i IN k /\ x IN mspace(m i) /\ y IN mspace(m i) - ==> mdist(m i) (x,y) <= c) - ==> mspace m' = cartesian_product k (mspace o m) /\ - mdist m' = (\(x,y). sup {mdist(m i) (x i,y i) | i IN k}) /\ - !x y b. x IN cartesian_product k (mspace o m) /\ - y IN cartesian_product k (mspace o m) - ==> (mdist m' (x,y) <= b <=> - !i. i IN k ==> mdist (m i) (x i,y i) <= b)`, - REPEAT GEN_TAC THEN DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC) THEN - ABBREV_TAC `M = \(x,y). sup {mdist(m i) (x i:A,y i) | (i:K) IN k}` THEN +let MDIAMETER_COMPACT_ATTAINED = prove + (`!m:A metric s. + compact_in (mtopology m) s /\ ~(s = {}) + ==> ?x y. x IN s /\ y IN s /\ mdist m (x,y) = mdiameter m s`, + REPEAT STRIP_TAC THEN + SUBGOAL_THEN `s SUBSET mspace (m:A metric)` ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN SUBGOAL_THEN - `!x (y:K->A) b. - x IN cartesian_product k (mspace o m) /\ - y IN cartesian_product k (mspace o m) - ==> (M(x,y) <= b <=> !i. i IN k ==> mdist (m i) (x i,y i) <= b)` - ASSUME_TAC THENL - [REWRITE_TAC[cartesian_product; o_DEF; IN_ELIM_THM] THEN - REPEAT STRIP_TAC THEN EXPAND_TAC "M" THEN REWRITE_TAC[] THEN - W(MP_TAC o PART_MATCH (lhand o rand) REAL_SUP_LE_EQ o lhand o snd) THEN - REWRITE_TAC[FORALL_IN_GSPEC] THEN ASM SET_TAC[]; + `compact_in euclideanreal (IMAGE (mdist (m:A metric)) (s CROSS s))` + ASSUME_TAC THENL + [MATCH_MP_TAC IMAGE_COMPACT_IN THEN + EXISTS_TAC `prod_topology (mtopology m) (mtopology (m:A metric))` THEN + ASM_REWRITE_TAC[COMPACT_IN_CROSS; CONTINUOUS_MAP_METRIC]; ALL_TAC] THEN - FIRST_ASSUM(MP_TAC o MATCH_MP (MESON[] - `m = m' ==> mspace m = mspace m' /\ mdist m = mdist m'`)) THEN - REWRITE_TAC[GSYM PAIR_EQ; mspace; mdist] THEN - W(MP_TAC o PART_MATCH (lhand o rand) (CONJUNCT2 metric_tybij) o - lhand o lhand o snd) THEN - DISCH_THEN(MP_TAC o fst o EQ_IMP_RULE) THEN ANTS_TAC THENL - [ALL_TAC; - DISCH_THEN SUBST1_TAC THEN DISCH_THEN(SUBST1_TAC o SYM) THEN - ASM_REWRITE_TAC[GSYM mdist]] THEN - REWRITE_TAC[is_metric_space] THEN - MATCH_MP_TAC(TAUT `p /\ (p ==> q) ==> p /\ q`) THEN CONJ_TAC THENL - [REPEAT STRIP_TAC THEN EXPAND_TAC "M" THEN REWRITE_TAC[] THEN - MATCH_MP_TAC REAL_LE_SUP THEN - ASM_SIMP_TAC[FORALL_IN_GSPEC; EXISTS_IN_GSPEC] THEN - RULE_ASSUM_TAC(REWRITE_RULE[cartesian_product; IN_ELIM_THM; o_THM]) THEN - FIRST_X_ASSUM(X_CHOOSE_TAC `c:real`) THEN EXISTS_TAC `c:real` THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN - MATCH_MP_TAC MONO_EXISTS THEN ASM_SIMP_TAC[MDIST_POS_LE]; - DISCH_TAC] THEN - REPEAT CONJ_TAC THENL - [ASM_SIMP_TAC[GSYM REAL_LE_ANTISYM] THEN REPEAT GEN_TAC THEN - DISCH_THEN(fun th -> - SUBST1_TAC(MATCH_MP CARTESIAN_PRODUCT_EQ_MEMBERS_EQ th) THEN - MP_TAC th) THEN - REWRITE_TAC[cartesian_product; o_THM; IN_ELIM_THM] THEN - SIMP_TAC[METRIC_ARITH - `x IN mspace m /\ y IN mspace m ==> (mdist m (x,y) <= &0 <=> x = y)`]; - REPEAT STRIP_TAC THEN EXPAND_TAC "M" THEN REWRITE_TAC[IN_ELIM_THM] THEN - AP_TERM_TAC THEN MATCH_MP_TAC(SET_RULE - `(!i. i IN w ==> f i = g i) ==> {f i | i IN w} = {g i | i IN w}`) THEN - RULE_ASSUM_TAC(REWRITE_RULE[cartesian_product; IN_ELIM_THM; o_THM]) THEN - ASM_MESON_TAC[MDIST_SYM]; - MAP_EVERY X_GEN_TAC [`x:K->A`; `y:K->A`; `z:K->A`] THEN - ASM_SIMP_TAC[] THEN STRIP_TAC THEN X_GEN_TAC `i:K` THEN DISCH_TAC THEN - TRANS_TAC REAL_LE_TRANS - `mdist (m i) ((x:K->A) i,y i) + mdist (m i) (y i,z i)` THEN - CONJ_TAC THENL - [MATCH_MP_TAC MDIST_TRIANGLE THEN - RULE_ASSUM_TAC(REWRITE_RULE[cartesian_product; IN_ELIM_THM; o_THM]) THEN - ASM_SIMP_TAC[]; - MATCH_MP_TAC REAL_LE_ADD2 THEN EXPAND_TAC "M" THEN - REWRITE_TAC[] THEN CONJ_TAC THEN MATCH_MP_TAC ELEMENT_LE_SUP THEN - RULE_ASSUM_TAC(REWRITE_RULE[cartesian_product; IN_ELIM_THM; o_THM]) THEN - ASM SET_TAC[]]]);; + SUBGOAL_THEN `real_compact (IMAGE (mdist (m:A metric)) (s CROSS s))` + ASSUME_TAC THENL [ASM_REWRITE_TAC[real_compact_def]; ALL_TAC] THEN + SUBGOAL_THEN `~(IMAGE (mdist (m:A metric)) (s CROSS s) = {})` ASSUME_TAC THENL + [ASM_SIMP_TAC[IMAGE_EQ_EMPTY; CROSS_EQ_EMPTY]; ALL_TAC] THEN + SUBGOAL_THEN `sup (IMAGE (mdist (m:A metric)) (s CROSS s)) + IN IMAGE (mdist m) (s CROSS s)` ASSUME_TAC THENL + [ASM_MESON_TAC[REAL_COMPACT_CONTAINS_SUP]; ALL_TAC] THEN + SUBGOAL_THEN `mdiameter m (s:A->bool) = + sup (IMAGE (mdist m) (s CROSS s))` ASSUME_TAC THENL + [ASM_REWRITE_TAC[mdiameter] THEN AP_TERM_TAC THEN + REWRITE_TAC[EXTENSION; IN_IMAGE; IN_ELIM_THM; IN_CROSS; + EXISTS_PAIR_THM] THEN MESON_TAC[]; + ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_IMAGE]) THEN + REWRITE_TAC[IN_CROSS; EXISTS_PAIR_THM] THEN ASM_MESON_TAC[]);; -let (METRIZABLE_SPACE_PRODUCT_TOPOLOGY, - COMPLETELY_METRIZABLE_SPACE_PRODUCT_TOPOLOGY) = (CONJ_PAIR o prove) - (`(!(tops:K->A topology) k. - metrizable_space (product_topology k tops) <=> - topspace (product_topology k tops) = {} \/ - COUNTABLE {i | i IN k /\ ~(?a. topspace(tops i) SUBSET {a})} /\ - !i. i IN k ==> metrizable_space (tops i)) /\ - (!(tops:K->A topology) k. - completely_metrizable_space (product_topology k tops) <=> - topspace (product_topology k tops) = {} \/ - COUNTABLE {i | i IN k /\ ~(?a. topspace(tops i) SUBSET {a})} /\ - !i. i IN k ==> completely_metrizable_space (tops i))`, - REWRITE_TAC[AND_FORALL_THM] THEN REPEAT GEN_TAC THEN - MATCH_MP_TAC(TAUT - `(n ==> m) /\ (t ==> n) /\ (m ==> t \/ m') /\ (n ==> t \/ n') /\ - (~t ==> m /\ m' ==> c) /\ (~t ==> c ==> (m' ==> m) /\ (n' ==> n)) - ==> (m <=> t \/ c /\ m') /\ (n <=> t \/ c /\ n')`) THEN - REWRITE_TAC[COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE] THEN CONJ_TAC THENL - [SIMP_TAC[GSYM SUBTOPOLOGY_EQ_DISCRETE_TOPOLOGY_EMPTY] THEN - REWRITE_TAC[COMPLETELY_METRIZABLE_SPACE_DISCRETE_TOPOLOGY]; - GEN_REWRITE_TAC I [CONJ_ASSOC]] THEN - CONJ_TAC THENL - [CONJ_TAC THEN MATCH_MP_TAC TOPOLOGICAL_PROPERTY_OF_PRODUCT_COMPONENT THEN - REWRITE_TAC[HOMEOMORPHIC_COMPLETELY_METRIZABLE_SPACE; - HOMEOMORPHIC_METRIZABLE_SPACE] THEN - ASM_SIMP_TAC[METRIZABLE_SPACE_SUBTOPOLOGY] THEN REPEAT STRIP_TAC THEN - MATCH_MP_TAC COMPLETELY_METRIZABLE_SPACE_CLOSED_IN THEN - ASM_REWRITE_TAC[CLOSED_IN_CARTESIAN_PRODUCT] THEN - DISJ2_TAC THEN REPEAT STRIP_TAC THEN - COND_CASES_TAC THEN ASM_REWRITE_TAC[CLOSED_IN_TOPSPACE] THEN - FIRST_ASSUM(MP_TAC o - MATCH_MP COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE) THEN - DISCH_THEN(MP_TAC o MATCH_MP METRIZABLE_IMP_T1_SPACE) THEN - REWRITE_TAC[T1_SPACE_PRODUCT_TOPOLOGY] THEN - REWRITE_TAC[T1_SPACE_CLOSED_IN_SING; RIGHT_IMP_FORALL_THM; IMP_IMP] THEN - STRIP_TAC THENL [ASM SET_TAC[]; FIRST_X_ASSUM MATCH_MP_TAC] THEN - RULE_ASSUM_TAC(REWRITE_RULE - [TOPSPACE_PRODUCT_TOPOLOGY; cartesian_product; o_DEF; IN_ELIM_THM]) THEN - ASM SET_TAC[]; +let MDIAMETER_SUBSET_MCBALL_NONEMPTY = prove + (`!m:A metric s. + mbounded m s /\ ~(s = {}) + ==> ?z. z IN s /\ s SUBSET mcball m (z,mdiameter m s)`, + REPEAT STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `z:A` THEN DISCH_TAC THEN + ASM_REWRITE_TAC[SUBSET; IN_MCBALL] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + ASM_MESON_TAC[MDIAMETER_BOUNDED_BOUND; MBOUNDED_IMP_IN_MSPACE]);; + +let MDIAMETER_SUBSET_MCBALL = prove + (`!m:A metric s. + mbounded m s ==> ?z. s SUBSET mcball m (z,mdiameter m s)`, + REPEAT STRIP_TAC THEN + ASM_CASES_TAC `s:A->bool = {}` THENL + [ASM_REWRITE_TAC[EMPTY_SUBSET]; + MP_TAC(ISPECL [`m:A metric`; `s:A->bool`] + MDIAMETER_SUBSET_MCBALL_NONEMPTY) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]]);; + +let MDIAMETER_EQ_0 = prove + (`!m:A metric s. + mbounded m s + ==> (mdiameter m s = &0 <=> s = {} \/ ?a. s = {a})`, + REPEAT STRIP_TAC THEN EQ_TAC THENL + [DISCH_TAC THEN REWRITE_TAC[SET_RULE + `s = {} \/ (?a. s = {a}) <=> !a b. a IN s /\ b IN s ==> a = b`] THEN + MAP_EVERY X_GEN_TAC [`a:A`; `b:A`] THEN STRIP_TAC THEN + SUBGOAL_THEN `mdist m (a:A,b) <= &0` MP_TAC THENL + [ASM_MESON_TAC[MDIAMETER_BOUNDED_BOUND]; ALL_TAC] THEN + ASM_MESON_TAC[MBOUNDED_IMP_IN_MSPACE; MDIST_0; MDIST_POS_LE; + REAL_LE_ANTISYM]; + STRIP_TAC THEN ASM_REWRITE_TAC[MDIAMETER_EMPTY] THEN + ASM_MESON_TAC[MDIAMETER_SING; MBOUNDED_IMP_IN_MSPACE; IN_SING]]);; + +let MDIAMETER_UNION_LE = prove + (`!m:A metric s t. + mbounded m s /\ mbounded m t /\ ~(s INTER t = {}) + ==> mdiameter m (s UNION t) <= mdiameter m s + mdiameter m t`, + REPEAT STRIP_TAC THEN + FIRST_X_ASSUM(X_CHOOSE_TAC `z:A` o REWRITE_RULE[GSYM MEMBER_NOT_EMPTY]) THEN + RULE_ASSUM_TAC(REWRITE_RULE[IN_INTER]) THEN + SUBGOAL_THEN `mbounded m (s UNION t:A->bool)` ASSUME_TAC THENL + [ASM_MESON_TAC[MBOUNDED_UNION]; ALL_TAC] THEN + MATCH_MP_TAC MDIAMETER_LE THEN + ASM_SIMP_TAC[MBOUNDED_SUBSET_MSPACE] THEN + CONJ_TAC THENL [DISJ1_TAC THEN ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(z:A) IN mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[MBOUNDED_IMP_IN_MSPACE]; ALL_TAC] THEN + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN + REWRITE_TAC[IN_UNION] THEN STRIP_TAC THENL + [MP_TAC(ISPECL [`m:A metric`; `s:A->bool`; `x:A`; `y:A`] + MDIAMETER_BOUNDED_BOUND) THEN + MP_TAC(ISPECL [`m:A metric`; `t:A->bool`] MDIAMETER_POS_LE) THEN + ASM_REWRITE_TAC[] THEN REAL_ARITH_TAC; + (* Mixed cases: use triangle inequality via z *) + SUBGOAL_THEN `x IN mspace m /\ y IN mspace (m:A metric)` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[MBOUNDED_IMP_IN_MSPACE]; ALL_TAC] THEN + MP_TAC(ISPECL [`m:A metric`; `x:A`; `z:A`; `y:A`] MDIST_TRIANGLE) THEN + MP_TAC(ISPECL [`m:A metric`; `s:A->bool`; `x:A`; `z:A`] + MDIAMETER_BOUNDED_BOUND) THEN + MP_TAC(ISPECL [`m:A metric`; `t:A->bool`; `z:A`; `y:A`] + MDIAMETER_BOUNDED_BOUND) THEN + ASM_REWRITE_TAC[] THEN REAL_ARITH_TAC; + SUBGOAL_THEN `x IN mspace m /\ y IN mspace (m:A metric)` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[MBOUNDED_IMP_IN_MSPACE]; ALL_TAC] THEN + MP_TAC(ISPECL [`m:A metric`; `x:A`; `z:A`; `y:A`] MDIST_TRIANGLE) THEN + MP_TAC(ISPECL [`m:A metric`; `t:A->bool`; `x:A`; `z:A`] + MDIAMETER_BOUNDED_BOUND) THEN + MP_TAC(ISPECL [`m:A metric`; `s:A->bool`; `z:A`; `y:A`] + MDIAMETER_BOUNDED_BOUND) THEN + ASM_REWRITE_TAC[] THEN REAL_ARITH_TAC; + MP_TAC(ISPECL [`m:A metric`; `t:A->bool`; `x:A`; `y:A`] + MDIAMETER_BOUNDED_BOUND) THEN + MP_TAC(ISPECL [`m:A metric`; `s:A->bool`] MDIAMETER_POS_LE) THEN + ASM_REWRITE_TAC[] THEN REAL_ARITH_TAC]);; + +(* ------------------------------------------------------------------------- *) +(* Submetric preserves mdiameter (mdist is the same). *) +(* ------------------------------------------------------------------------- *) + +let MDIAMETER_SUBMETRIC = prove + (`!m:A metric s t. mdiameter (submetric m s) t = mdiameter m t`, + REWRITE_TAC[mdiameter; SUBMETRIC]);; + +let LEBESGUE_COVERING_LEMMA = prove + (`!m:A metric s c. + compact_in (mtopology m) s /\ ~(c = {}) /\ + s SUBSET UNIONS c /\ (!b. b IN c ==> open_in (mtopology m) b) + ==> ?d. &0 < d /\ + !t. t SUBSET s /\ mdiameter m t <= d + ==> ?b. b IN c /\ t SUBSET b`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPECL [`m:A metric`; `s:A->bool`; `c:(A->bool)->bool`] + LEBESGUE_NUMBER) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `e:real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `e / &2` THEN CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + X_GEN_TAC `t:A->bool` THEN STRIP_TAC THEN + ASM_CASES_TAC `t:A->bool = {}` THENL + [ASM_MESON_TAC[MEMBER_NOT_EMPTY; EMPTY_SUBSET]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + DISCH_THEN(X_CHOOSE_TAC `x0:A`) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `x0:A`) THEN + ANTS_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `u:A->bool` THEN STRIP_TAC THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `mball m (x0:A,e)` THEN ASM_REWRITE_TAC[SUBSET; IN_MBALL] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `mbounded m (t:A->bool)` ASSUME_TAC THENL + [ASM_MESON_TAC[MBOUNDED_SUBSET; COMPACT_IN_IMP_MBOUNDED]; ALL_TAC] THEN + SUBGOAL_THEN `(y:A) IN mspace m /\ x0 IN mspace m` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[MBOUNDED_IMP_IN_MSPACE]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `mdist m (x0:A,y) <= mdiameter m t` MP_TAC THENL + [ASM_MESON_TAC[MDIAMETER_BOUNDED_BOUND]; ASM_REAL_ARITH_TAC]);; + +let LEBESGUE_COVERING_LEMMA_GEN = prove + (`!m:A metric u s c. + compact_in (mtopology m) s /\ ~(c = {}) /\ + s SUBSET UNIONS c /\ + (!b. b IN c ==> open_in (subtopology (mtopology m) u) b) + ==> ?d. &0 < d /\ + !t. t SUBSET s /\ mdiameter m t <= d + ==> ?b. b IN c /\ t SUBSET b`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Form lifted cover c' from subtopology opens to full opens *) + ABBREV_TAC + `c' = {v:A->bool | ?b. b IN c /\ open_in (mtopology m) v /\ b = v INTER u}` + THEN + (* s SUBSET UNIONS c' because each b in c lifts to some v in c' *) + SUBGOAL_THEN `s SUBSET UNIONS (c':(A->bool)->bool)` ASSUME_TAC THENL + [REWRITE_TAC[SUBSET; IN_UNIONS] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN UNIONS c` MP_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN DISCH_THEN(X_CHOOSE_TAC `b:A->bool`) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `b:A->bool`) THEN + ASM_REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `v:A->bool` THEN CONJ_TAC THENL + [EXPAND_TAC "c'" THEN REWRITE_TAC[IN_ELIM_THM] THEN ASM_MESON_TAC[]; + ASM SET_TAC[]]; + ALL_TAC] THEN + (* c' is nonempty since c is nonempty *) + SUBGOAL_THEN `~(c':(A->bool)->bool = {})` ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + DISCH_THEN(X_CHOOSE_TAC `b0:A->bool`) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `b0:A->bool`) THEN + ASM_REWRITE_TAC[OPEN_IN_SUBTOPOLOGY; GSYM MEMBER_NOT_EMPTY] THEN + DISCH_THEN(X_CHOOSE_THEN `v0:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `v0:A->bool` THEN EXPAND_TAC "c'" THEN + REWRITE_TAC[IN_ELIM_THM] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Elements of c' are open in mtopology *) + SUBGOAL_THEN `!v:A->bool. v IN c' ==> open_in (mtopology m) v` + ASSUME_TAC THENL + [EXPAND_TAC "c'" THEN REWRITE_TAC[IN_ELIM_THM] THEN MESON_TAC[]; + ALL_TAC] THEN + (* Apply LEBESGUE_COVERING_LEMMA to c' *) + MP_TAC(ISPECL [`m:A metric`; `s:A->bool`; `c':(A->bool)->bool`] + LEBESGUE_COVERING_LEMMA) THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC MONO_EXISTS THEN + X_GEN_TAC `d:real` THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `t:A->bool` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `t:A->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC) THEN + (* Extract b from c such that v witnesses b = v INTER u *) + UNDISCH_TAC `(v:A->bool) IN c'` THEN EXPAND_TAC "c'" THEN + REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `b:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `b:A->bool` THEN ASM_REWRITE_TAC[] THEN + (* t SUBSET b = v INTER u: need t SUBSET v and t SUBSET u *) + MATCH_MP_TAC(SET_RULE + `t SUBSET v /\ t SUBSET u /\ b = v INTER u ==> t SUBSET b`) THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `s:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC `UNIONS c:A->bool` THEN + ASM_REWRITE_TAC[UNIONS_SUBSET] THEN X_GEN_TAC `b':A->bool` THEN + DISCH_TAC THEN + UNDISCH_TAC `!b:A->bool. b IN c ==> open_in (subtopology (mtopology m) u) b` + THEN DISCH_THEN(MP_TAC o SPEC `b':A->bool`) THEN + ASM_REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN SET_TAC[]);; + +(* ------------------------------------------------------------------------- *) +(* Well-chained sets in metric spaces (epsilon-chains). *) +(* Generalizes the Euclidean well-chained theory from paths.ml. *) +(* ------------------------------------------------------------------------- *) + +let WELLCHAINED_ELEMENTS = prove + (`!m:A metric s a (b:A) e. + (?p n. p 0 = a /\ p n = b /\ + (!i. i <= n ==> p i IN s) /\ + (!i. i < n ==> mdist m (p i,p(SUC i)) < e)) <=> + a IN s /\ b IN s /\ + (!c. c SUBSET s /\ a IN c /\ + (!x y. x IN c /\ y IN s /\ mdist m (x,y) < e ==> y IN c) + ==> b IN c)`, + REPEAT GEN_TAC THEN + ASM_CASES_TAC `(a:A) IN s` THENL + [ALL_TAC; ASM_MESON_TAC[LE_0]] THEN + ASM_CASES_TAC `(b:A) IN s` THENL + [ALL_TAC; ASM_MESON_TAC[LE_REFL]] THEN + ASM_REWRITE_TAC[] THEN EQ_TAC THENL + [REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`p:num->A`; `n:num`] THEN STRIP_TAC THEN + X_GEN_TAC `c:A->bool` THEN STRIP_TAC THEN + SUBGOAL_THEN `!k. k <= n ==> (p:num->A) k IN c` + (fun th -> ASM_MESON_TAC[th; LE_REFL]) THEN + INDUCT_TAC THEN ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN EXISTS_TAC `(p:num->A) k` THEN + REPEAT CONJ_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; + DISCH_THEN(MP_TAC o SPEC + `{x:A | ?p n. p 0 = a /\ p n = x /\ + (!i. i <= n ==> p i IN s) /\ + (!i. i < n ==> mdist m (p i,p(SUC i)) < e)}`) THEN + ANTS_TAC THENL [ALL_TAC; REWRITE_TAC[IN_ELIM_THM]] THEN + REPEAT CONJ_TAC THENL + [REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN ASM_MESON_TAC[LE_REFL]; + REWRITE_TAC[IN_ELIM_THM] THEN + MAP_EVERY EXISTS_TAC [`(\n. a):num->A`; `0`] THEN + ASM_REWRITE_TAC[LT]; + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN + DISCH_THEN(CONJUNCTS_THEN2 MP_TAC STRIP_ASSUME_TAC) THEN + REWRITE_TAC[IN_ELIM_THM; LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`p:num->A`; `n:num`] THEN STRIP_TAC THEN + EXISTS_TAC `\i. if i <= n then (p:num->A) i else y` THEN + EXISTS_TAC `SUC n` THEN + ASM_REWRITE_TAC[LE_0; ARITH_RULE `~(SUC n <= n)`] THEN + REWRITE_TAC[LE; LT; TAUT `p \/ q ==> r <=> (p ==> r) /\ (q ==> r)`; + FORALL_AND_THM; FORALL_UNWIND_THM2] THEN + REWRITE_TAC[LE_REFL; LE_SUC_LT; LT_REFL] THEN + ASM_SIMP_TAC[LT_IMP_LE]]]);; + +let WELLCHAINED_SETS = prove + (`!m:A metric s e. + (!a b. a IN s /\ b IN s + ==> ?p n. p 0 = a /\ p n = b /\ + (!i. i <= n ==> p i IN s) /\ + (!i. i < n ==> mdist m (p i,p(SUC i)) < e)) <=> + (!c. c SUBSET s /\ ~(c = {}) /\ + (!x y. x IN c /\ y IN s /\ mdist m (x,y) < e ==> y IN c) + ==> c = s)`, + REPEAT GEN_TAC THEN + REWRITE_TAC[WELLCHAINED_ELEMENTS] THEN SIMP_TAC[] THEN + REWRITE_TAC[MESON[] + `(!(a:A) b. P a /\ P b ==> !(c:A->bool). Q a b c ==> R a b c) <=> + (!c a b. Q a b c /\ P a /\ P b ==> R a b c)`] THEN + AP_TERM_TAC THEN ABS_TAC THEN + SIMP_TAC[GSYM MEMBER_NOT_EMPTY; GSYM SUBSET_ANTISYM_EQ] THEN + REWRITE_TAC[SUBSET] THEN REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN + MESON_TAC[]);; + +(* Helper: epsilon-absorbing subsets are clopen in subtopology *) +let EPSILON_ABSORBING_IMP_CLOPEN = prove + (`!m:A metric s c e. + s SUBSET mspace m /\ c SUBSET s /\ &0 < e /\ + (!x y. x IN c /\ y IN s /\ mdist m (x,y) < e ==> y IN c) + ==> open_in (subtopology (mtopology m) s) c /\ + closed_in (subtopology (mtopology m) s) c`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN + `!d:A->bool. d SUBSET s /\ + (!x y. x IN d /\ y IN s /\ mdist m (x,y) < e ==> y IN d) + ==> open_in (subtopology (mtopology m) (s:A->bool)) d` + ASSUME_TAC THENL + [X_GEN_TAC `d:A->bool` THEN STRIP_TAC THEN + SUBGOAL_THEN `d:A->bool = s INTER UNIONS {mball m (z:A,e) | z IN d}` + SUBST1_TAC THENL + [REWRITE_TAC[EXTENSION; IN_INTER; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `w:A` THEN EQ_TAC THENL + [DISCH_TAC THEN + SUBGOAL_THEN `(w:A) IN mspace m` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + EXISTS_TAC `mball m (w:A,e)` THEN CONJ_TAC THENL + [EXISTS_TAC `w:A` THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_SIMP_TAC[CENTRE_IN_MBALL]; + REWRITE_TAC[IN_MBALL] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `t:A->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_THEN `z:A` STRIP_ASSUME_TAC) + ASSUME_TAC))) THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`z:A`; `w:A`]) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN MATCH_MP_TAC THEN + ASM SET_TAC[]]; + MATCH_MP_TAC OPEN_IN_SUBTOPOLOGY_INTER_OPEN THEN + MATCH_MP_TAC OPEN_IN_UNIONS THEN + REWRITE_TAC[FORALL_IN_GSPEC; OPEN_IN_MBALL]]; ALL_TAC] THEN CONJ_TAC THENL - [REPEAT STRIP_TAC THEN ABBREV_TAC - `l = {i:K | i IN k /\ ~(?a:A. topspace(tops i) SUBSET {a})}` THEN - SUBGOAL_THEN - `!i:K. ?p q:A. - i IN l ==> p IN topspace(tops i) /\ q IN topspace(tops i) /\ ~(p = q)` - MP_TAC THENL [EXPAND_TAC "l" THEN SET_TAC[]; ALL_TAC] THEN - REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`a:K->A`; `b:K->A`] THEN STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN - REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; o_DEF; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `z:K->A` THEN DISCH_TAC THEN - ABBREV_TAC `p:K->A = \i. if i IN l then a i else z i` THEN - ABBREV_TAC `q:K->K->A = \i j. if j = i then b i else p j` THEN - SUBGOAL_THEN - `p IN topspace(product_topology k (tops:K->A topology)) /\ - (!i:K. i IN l - ==> q i IN topspace(product_topology k (tops:K->A topology)))` - STRIP_ASSUME_TAC THENL - [UNDISCH_TAC `(z:K->A) IN cartesian_product k (\x. topspace(tops x))` THEN - MAP_EVERY EXPAND_TAC ["q"; "p"] THEN - REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; cartesian_product; o_THM] THEN - REWRITE_TAC[EXTENSIONAL; IN_ELIM_THM] THEN ASM SET_TAC[]; + [FIRST_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[closed_in; TOPSPACE_SUBTOPOLOGY; TOPSPACE_MTOPOLOGY] THEN + SUBGOAL_THEN `mspace m INTER s = s:A->bool` SUBST1_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN + CONJ_TAC THENL [SET_TAC[]; ALL_TAC] THEN + MAP_EVERY X_GEN_TAC [`u:A`; `v:A`] THEN + REWRITE_TAC[IN_DIFF] THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[MDIST_SYM; SUBSET]]) + +let CONNECTED_IN_IMP_WELLCHAINED = prove + (`!m:A metric s e a b. + connected_in (mtopology m) s /\ &0 < e /\ a IN s /\ b IN s + ==> ?p n. p 0 = a /\ p n = b /\ + (!i. i <= n ==> p i IN s) /\ + (!i. i < n ==> mdist m (p i,p(SUC i)) < e)`, + REPEAT GEN_TAC THEN + REWRITE_TAC[connected_in; TOPSPACE_MTOPOLOGY] THEN + STRIP_TAC THEN + REWRITE_TAC[WELLCHAINED_ELEMENTS] THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `c:A->bool` THEN STRIP_TAC THEN + MP_TAC(ISPECL [`m:A metric`; `s:A->bool`; `c:A->bool`; `e:real`] + EPSILON_ABSORBING_IMP_CLOPEN) THEN + ASM_REWRITE_TAC[] THEN STRIP_TAC THEN + MP_TAC(ISPEC `subtopology (mtopology (m:A metric)) (s:A->bool)` + CONNECTED_SPACE_CLOPEN_IN) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC `c:A->bool`) THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; TOPSPACE_MTOPOLOGY] THEN + ASM SET_TAC[]);; + +let CONNECTED_COMPONENT_OF_IMP_WELLCHAINED = prove + (`!m:A metric s a (b:A) e. + &0 < e /\ connected_component_of (subtopology (mtopology m) s) a b + ==> ?p n. p 0 = a /\ p n = b /\ + (!i. i <= n ==> p i IN s) /\ + (!i. i < n ==> mdist m (p i,p (SUC i)) < e)`, + REPEAT GEN_TAC THEN + REWRITE_TAC[connected_component_of; CONNECTED_IN_SUBTOPOLOGY] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `t:A->bool` STRIP_ASSUME_TAC)) THEN + MP_TAC(ISPECL [`m:A metric`; `t:A->bool`; `e:real`; + `a:A`; `b:A`] CONNECTED_IN_IMP_WELLCHAINED) THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `p:num->A` THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `n:num` THEN + ASM SET_TAC[]);; + +let CONNECTED_EQ_WELLCHAINED_IN = prove + (`!m:A metric s. + compact_in (mtopology m) s + ==> (connected_in (mtopology m) s <=> + !e. &0 < e + ==> !a b. a IN s /\ b IN s + ==> ?p n. p 0 = a /\ p n = b /\ + (!i. i <= n ==> p i IN s) /\ + (!i. i < n ==> mdist m (p i,p(SUC i)) < e))`, + GEN_TAC THEN GEN_TAC THEN DISCH_TAC THEN EQ_TAC THENL + [(* Forward: connected ==> wellchained *) + DISCH_TAC THEN REPEAT STRIP_TAC THEN + MATCH_MP_TAC CONNECTED_IN_IMP_WELLCHAINED THEN ASM_REWRITE_TAC[]; + (* Backward: wellchained for all eps ==> connected *) + DISCH_TAC THEN + SUBGOAL_THEN `(s:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + REWRITE_TAC[connected_in; TOPSPACE_MTOPOLOGY] THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[CONNECTED_SPACE_CLOPEN_IN] THEN + ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY; TOPSPACE_MTOPOLOGY; + SET_RULE `(s:A->bool) SUBSET u ==> u INTER s = s`] THEN + X_GEN_TAC `c:A->bool` THEN STRIP_TAC THEN + ASM_CASES_TAC `c:A->bool = {}` THEN ASM_REWRITE_TAC[] THEN + (* Get open set u with c = s INTER u *) + UNDISCH_TAC + `open_in (subtopology (mtopology (m:A metric)) s) (c:A->bool)` THEN + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + (* Get open set v with s DIFF c = s INTER v *) SUBGOAL_THEN - `!u:(K->A)->bool. - open_in (product_topology k tops) u /\ p IN u - ==> FINITE {i:K | i IN l /\ ~(q i IN u)}` - ASSUME_TAC THENL - [X_GEN_TAC `u:(K->A)->bool` THEN - DISCH_THEN(CONJUNCTS_THEN2 MP_TAC ASSUME_TAC) THEN - REWRITE_TAC[OPEN_IN_PRODUCT_TOPOLOGY_ALT] THEN - DISCH_THEN(MP_TAC o SPEC `p:K->A`) THEN - ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `v:K->A->bool` THEN - DISCH_THEN(CONJUNCTS_THEN2 MP_TAC STRIP_ASSUME_TAC) THEN - MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ_ALT] FINITE_SUBSET) THEN - REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN X_GEN_TAC `i:K` THEN - MATCH_MP_TAC(TAUT - `(l ==> k) /\ (k /\ l ==> p ==> q) ==> l /\ ~q ==> k /\ ~p`) THEN - CONJ_TAC THENL [ASM SET_TAC[]; REPEAT STRIP_TAC] THEN - FIRST_X_ASSUM(MATCH_MP_TAC o GEN_REWRITE_RULE I [SUBSET]) THEN - EXPAND_TAC "q" THEN UNDISCH_TAC `(p:K->A) IN cartesian_product k v` THEN - REWRITE_TAC[cartesian_product; IN_ELIM_THM; EXTENSIONAL] THEN - ASM SET_TAC[]; + `open_in (subtopology (mtopology (m:A metric)) s) (s DIFF c :A->bool)` + MP_TAC THENL + [UNDISCH_TAC + `closed_in (subtopology (mtopology (m:A metric)) s) (c:A->bool)` THEN + ASM_SIMP_TAC[closed_in; TOPSPACE_SUBTOPOLOGY; TOPSPACE_MTOPOLOGY; + SET_RULE `(s:A->bool) SUBSET u ==> u INTER s = s`] THEN + MESON_TAC[]; + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC)] THEN + (* Apply Lebesgue number lemma *) + MP_TAC(ISPECL [`m:A metric`; `s:A->bool`; `{u:A->bool, v}`] + LEBESGUE_NUMBER) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [REWRITE_TAC[IN_INSERT; NOT_IN_EMPTY] THEN ASM_MESON_TAC[]; + REWRITE_TAC[UNIONS_INSERT; UNIONS_0; UNION_EMPTY] THEN + ASM SET_TAC[]]; ALL_TAC] THEN - FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [metrizable_space]) THEN - DISCH_THEN(X_CHOOSE_TAC `m:(K->A)metric`) THEN - MATCH_MP_TAC COUNTABLE_SUBSET THEN - EXISTS_TAC `UNIONS {{i | i IN l /\ - ~((q:K->K->A) i IN mball m (p,inv(&n + &1)))} | - n IN (:num)}` THEN - CONJ_TAC THENL - [MATCH_MP_TAC COUNTABLE_UNIONS THEN REWRITE_TAC[SIMPLE_IMAGE] THEN - SIMP_TAC[COUNTABLE_IMAGE; NUM_COUNTABLE; FORALL_IN_IMAGE] THEN - X_GEN_TAC `n:num` THEN DISCH_THEN(K ALL_TAC) THEN - MATCH_MP_TAC FINITE_IMP_COUNTABLE THEN FIRST_X_ASSUM MATCH_MP_TAC THEN - ASM_REWRITE_TAC[OPEN_IN_MBALL] THEN MATCH_MP_TAC CENTRE_IN_MBALL THEN - REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`] THEN - ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]; - REWRITE_TAC[SUBSET; UNIONS_GSPEC; IN_ELIM_THM; IN_UNIV] THEN - X_GEN_TAC `i:K` THEN DISCH_TAC THEN MP_TAC(snd(EQ_IMP_RULE(ISPEC - `mdist (m:(K->A)metric) (p,q(i:K))` ARCH_EVENTUALLY_INV1))) THEN - ANTS_TAC THENL - [MATCH_MP_TAC MDIST_POS_LT THEN REPEAT - (CONJ_TAC THENL [ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]; ALL_TAC]) THEN - DISCH_THEN(MP_TAC o C AP_THM `i:K`) THEN - MAP_EVERY EXPAND_TAC ["q"; "p"] THEN REWRITE_TAC[] THEN - ASM_SIMP_TAC[]; - DISCH_THEN(MP_TAC o MATCH_MP EVENTUALLY_HAPPENS_SEQUENTIALLY) THEN - MATCH_MP_TAC MONO_EXISTS THEN - ASM_REWRITE_TAC[IN_MBALL] THEN REAL_ARITH_TAC]]; + DISCH_THEN(X_CHOOSE_THEN `eps:real` STRIP_ASSUME_TAC) THEN + (* Use wellchainedness for eps, rewrite via WELLCHAINED_SETS *) + FIRST_X_ASSUM(MP_TAC o SPEC `eps:real`) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[WELLCHAINED_SETS] THEN DISCH_TAC THEN + FIRST_X_ASSUM(MATCH_MP_TAC o SPEC `c:A->bool`) THEN + REPEAT(CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC]) THEN + (* c is eps-closed in s *) + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN + SUBGOAL_THEN `(x:A) IN s` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + UNDISCH_TAC `(w:A->bool) IN {u:A->bool, v}` THEN + REWRITE_TAC[IN_INSERT; NOT_IN_EMPTY] THEN + DISCH_THEN(DISJ_CASES_THEN SUBST_ALL_TAC) THENL + [(* w = u: y IN mball(x,eps) SUBSET u, so y IN s INTER u = c *) + SUBGOAL_THEN `(y:A) IN mball m (x:A,eps)` MP_TAC THENL + [REWRITE_TAC[IN_MBALL] THEN ASM_MESON_TAC[SUBSET]; + ASM SET_TAC[]]; + (* w = v: x IN mball(x,eps) SUBSET v, contradiction with x IN c *) + SUBGOAL_THEN `(x:A) IN mball m (x:A,eps)` MP_TAC THENL + [MATCH_MP_TAC CENTRE_IN_MBALL THEN ASM SET_TAC[]; + ASM SET_TAC[]]]]);; + +(* In a compact metric space, connected components = well-chained components. + Points a and b are in the same connected component of K iff they can be + epsilon-chained in K for every epsilon > 0. Uses the fact that in compact + Hausdorff spaces, quasi-components = connected components. *) + +let CONNECTED_COMPONENT_OF_EQ_WELLCHAINED = prove + (`!m:A metric K a b. + compact_in (mtopology m) K + ==> (connected_component_of (subtopology (mtopology m) K) a b <=> + a IN K /\ b IN K /\ + !e. &0 < e + ==> ?p n. p 0 = a /\ p n = b /\ + (!i. i <= n ==> p i IN K) /\ + (!i. i < n ==> mdist m (p i,p (SUC i)) < e))`, + REPEAT STRIP_TAC THEN + ABBREV_TAC `top = subtopology (mtopology (m:A metric)) K` THEN + SUBGOAL_THEN `(K:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN - DISCH_TAC THEN DISCH_TAC THEN - ASM_CASES_TAC `k:K->bool = {}` THENL - [ASM_REWRITE_TAC[NOT_IN_EMPTY; EMPTY_GSPEC; COUNTABLE_EMPTY] THEN - REWRITE_TAC[PRODUCT_TOPOLOGY_EMPTY_DISCRETE; - METRIZABLE_SPACE_DISCRETE_TOPOLOGY; - COMPLETELY_METRIZABLE_SPACE_DISCRETE_TOPOLOGY]; + SUBGOAL_THEN `topspace top = (K:A->bool)` ASSUME_TAC THENL + [EXPAND_TAC "top" THEN + ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY; TOPSPACE_MTOPOLOGY; + SET_RULE `(s:A->bool) SUBSET u ==> u INTER s = s`]; ALL_TAC] THEN - REWRITE_TAC[metrizable_space; completely_metrizable_space] THEN - GEN_REWRITE_TAC (BINOP_CONV o LAND_CONV o BINDER_CONV) - [RIGHT_IMP_EXISTS_THM] THEN - REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM; AND_FORALL_THM] THEN - X_GEN_TAC `m:K->A metric` THEN ONCE_REWRITE_TAC[EQ_SYM_EQ] THEN - ASM_CASES_TAC `!i. i IN k ==> mtopology(m i) = (tops:K->A topology) i` THEN - ASM_SIMP_TAC[] THENL [ALL_TAC; ASM_MESON_TAC[]] THEN MATCH_MP_TAC(MESON[] - `!m. P m /\ (Q ==> C m) ==> (?m. P m) /\ (Q ==> ?m. C m /\ P m)`) THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I - [COUNTABLE_AS_INJECTIVE_IMAGE_SUBSET]) THEN - REWRITE_TAC[LEFT_IMP_EXISTS_THM; INJECTIVE_ON_LEFT_INVERSE] THEN - MAP_EVERY X_GEN_TAC [`nk:num->K`; `c:num->bool`] THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (X_CHOOSE_TAC `kn:K->num`)) THEN - MP_TAC(ISPECL - [`k:K->bool`; `\i. capped_metric (inv(&(kn i) + &1)) ((m:K->A metric) i)`] - SUP_METRIC_CARTESIAN_PRODUCT) THEN - REWRITE_TAC[o_DEF; CONJUNCT1(SPEC_ALL CAPPED_METRIC)] THEN - MATCH_MP_TAC(MESON[] - `Q /\ (!m. P m ==> R m) - ==> (!m. a = m /\ Q ==> P m) ==> ?m. R m`) THEN - CONJ_TAC THENL - [ASM_REWRITE_TAC[] THEN EXISTS_TAC `&1:real` THEN - REWRITE_TAC[CAPPED_METRIC; GSYM REAL_NOT_LT] THEN - REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`] THEN - REWRITE_TAC[REAL_NOT_LT; REAL_MIN_LE] THEN REPEAT STRIP_TAC THEN - DISJ1_TAC THEN MATCH_MP_TAC REAL_INV_LE_1 THEN REAL_ARITH_TAC; - X_GEN_TAC `M:(K->A)metric`] THEN - SUBGOAL_THEN - `cartesian_product k (\i. mspace (m i)) = - topspace(product_topology k (tops:K->A topology))` - SUBST1_TAC THENL - [REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; CARTESIAN_PRODUCT_EQ] THEN - ASM_SIMP_TAC[GSYM TOPSPACE_MTOPOLOGY; o_THM]; - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN - DISCH_THEN(CONJUNCTS_THEN2 (ASSUME_TAC o SYM) ASSUME_TAC)] THEN - MATCH_MP_TAC(TAUT `p /\ (p ==> q) ==> p /\ q`) THEN CONJ_TAC THENL - [REWRITE_TAC[MTOPOLOGY_BASE; product_topology] THEN - REWRITE_TAC[GSYM TOPSPACE_PRODUCT_TOPOLOGY_ALT] THEN - REWRITE_TAC[PRODUCT_TOPOLOGY_BASE_ALT] THEN - MATCH_MP_TAC TOPOLOGY_BASES_EQ THEN - REWRITE_TAC[SET_RULE `GSPEC P x <=> x IN GSPEC P`] THEN - REWRITE_TAC[EXISTS_IN_GSPEC; IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN - REWRITE_TAC[FORALL_IN_GSPEC; GSYM CONJ_ASSOC; IN_MBALL] THEN CONJ_TAC THENL - [MAP_EVERY X_GEN_TAC [`z:K->A`; `r:real`] THEN STRIP_TAC THEN - X_GEN_TAC `x:K->A` THEN STRIP_TAC THEN - SUBGOAL_THEN - `(!i. i IN k ==> (z:K->A) i IN topspace(tops i)) /\ - (!i. i IN k ==> (x:K->A) i IN topspace(tops i))` - STRIP_ASSUME_TAC THENL - [MAP_EVERY UNDISCH_TAC - [`(z:K->A) IN mspace M`; `(x:K->A) IN mspace M`] THEN - ASM_SIMP_TAC[TOPSPACE_PRODUCT_TOPOLOGY; cartesian_product; o_DEF] THEN - SET_TAC[]; + EQ_TAC THENL + [(* Forward: connected_component_of ==> membership + wellchaining *) + DISCH_TAC THEN + SUBGOAL_THEN `(a:A) IN K /\ (b:A) IN K` STRIP_ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o MATCH_MP CONNECTED_COMPONENT_IN_TOPSPACE) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN REPEAT STRIP_TAC THEN + EXPAND_TAC "top" THEN + MATCH_MP_TAC CONNECTED_COMPONENT_OF_IMP_WELLCHAINED THEN + ASM_REWRITE_TAC[]; + (* Backward: membership + wellchaining ==> connected_component_of *) + STRIP_TAC THEN + (* Use quasi = connected in compact Hausdorff *) + SUBGOAL_THEN `compact_space (top:A topology)` ASSUME_TAC THENL + [EXPAND_TAC "top" THEN + MATCH_MP_TAC COMPACT_SPACE_SUBTOPOLOGY THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `hausdorff_space (top:A topology)` ASSUME_TAC THENL + [EXPAND_TAC "top" THEN + MATCH_MP_TAC HAUSDORFF_SPACE_SUBTOPOLOGY THEN + REWRITE_TAC[HAUSDORFF_SPACE_MTOPOLOGY]; + ALL_TAC] THEN + SUBGOAL_THEN + `quasi_component_of top (a:A) = connected_component_of top a` + (fun th -> REWRITE_TAC[GSYM th]) THENL + [MATCH_MP_TAC QUASI_EQ_CONNECTED_COMPONENT_OF THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Now show quasi_component_of top a b *) + REWRITE_TAC[quasi_component_of] THEN ASM_REWRITE_TAC[] THEN + (* For every clopen t with a IN t, show b IN t *) + X_GEN_TAC `t:A->bool` THEN STRIP_TAC THEN + SUBGOAL_THEN `(t:A->bool) SUBSET K` ASSUME_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET]; ALL_TAC] THEN + (* t is compact via closed in compact subtopology *) + SUBGOAL_THEN `compact_in (mtopology m) (t:A->bool)` ASSUME_TAC THENL + [SUBGOAL_THEN `compact_in top (t:A->bool)` MP_TAC THENL + [MATCH_MP_TAC CLOSED_IN_COMPACT_SPACE THEN ASM_REWRITE_TAC[]; + EXPAND_TAC "top" THEN + REWRITE_TAC[COMPACT_IN_SUBTOPOLOGY] THEN MESON_TAC[]]; + ALL_TAC] THEN + (* K DIFF t is compact via open_in ==> complement closed ==> compact *) + SUBGOAL_THEN + `compact_in (mtopology m) (K DIFF t:A->bool)` ASSUME_TAC THENL + [SUBGOAL_THEN `compact_in top (K DIFF t:A->bool)` MP_TAC THENL + [MATCH_MP_TAC CLOSED_IN_COMPACT_SPACE THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `K DIFF t = topspace top DIFF t:A->bool` + SUBST1_TAC THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[OPEN_IN_CLOSED_IN]; + EXPAND_TAC "top" THEN + REWRITE_TAC[COMPACT_IN_SUBTOPOLOGY] THEN + SIMP_TAC[] THEN SET_TAC[]]; + ALL_TAC] THEN + (* Get disjoint open sets separating t and K DIFF t *) + MP_TAC(ISPECL [`mtopology (m:A metric)`; `t:A->bool`; + `K DIFF t:A->bool`] + HAUSDORFF_SPACE_COMPACT_SEPARATION) THEN + ASM_REWRITE_TAC[HAUSDORFF_SPACE_MTOPOLOGY] THEN + ANTS_TAC THENL [SET_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` + (X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC)) THEN + (* Apply Lebesgue number to K with cover {u, v} *) + MP_TAC(ISPECL [`m:A metric`; `K:A->bool`; `{u:A->bool, v}`] + LEBESGUE_NUMBER) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [REWRITE_TAC[IN_INSERT; NOT_IN_EMPTY] THEN ASM_MESON_TAC[]; + REWRITE_TAC[UNIONS_INSERT; UNIONS_0; UNION_EMPTY] THEN + ASM SET_TAC[]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `delta:real` STRIP_ASSUME_TAC) THEN + POP_ASSUM(LABEL_TAC "lebesgue") THEN + (* Use wellchaining for delta *) + FIRST_X_ASSUM(MP_TAC o SPEC `delta:real`) THEN ASM_REWRITE_TAC[] THEN + (* Convert chain via WELLCHAINED_ELEMENTS to closure form *) + DISCH_THEN(MP_TAC o GEN_REWRITE_RULE I [WELLCHAINED_ELEMENTS]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 ASSUME_TAC (LABEL_TAC "chain_closure"))) THEN + (* t and K DIFF t are both delta-absorbing in K *) + let delta_absorbing_tac = + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN + SUBGOAL_THEN `(x:A) IN K` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + USE_THEN "lebesgue" (fun th -> + MP_TAC(MP (SPEC `x:A` th) (ASSUME `(x:A) IN K`))) THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(x:A) IN mball m (x:A,delta)` ASSUME_TAC THENL + [MATCH_MP_TAC CENTRE_IN_MBALL THEN ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN - SUBGOAL_THEN `?R. &0 < R /\ mdist M (z:K->A,x) < R /\ R < r` + SUBGOAL_THEN `(y:A) IN mball m (x:A,delta)` ASSUME_TAC THENL + [REWRITE_TAC[IN_MBALL] THEN ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + UNDISCH_TAC `(w:A->bool) IN {u:A->bool, v}` THEN + REWRITE_TAC[IN_INSERT; NOT_IN_EMPTY] THEN + DISCH_THEN(DISJ_CASES_THEN SUBST_ALL_TAC) THEN ASM SET_TAC[] in + SUBGOAL_THEN + `(!x y:A. x IN t /\ y IN K /\ mdist m (x,y) < delta ==> y IN t) /\ + (!x y:A. x IN K DIFF t /\ y IN K /\ mdist m (x,y) < delta + ==> y IN K DIFF t)` STRIP_ASSUME_TAC THENL - [ASM_MESON_TAC[REAL_LT_BETWEEN; REAL_LET_TRANS; MDIST_POS_LE]; - ALL_TAC] THEN - EXISTS_TAC - `\i. if R <= inv(&(kn i) + &1) then mball (m i) (z i,R) - else topspace((tops:K->A topology) i)` THEN - REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL - [MP_TAC(ASSUME `&0 < R`) THEN DISCH_THEN(MP_TAC o - SPEC `&1:real` o MATCH_MP REAL_ARCH) THEN - DISCH_THEN(X_CHOOSE_TAC `n:num`) THEN - MATCH_MP_TAC FINITE_SUBSET THEN - EXISTS_TAC `IMAGE (nk:num->K) (c INTER (0..n))` THEN - SIMP_TAC[FINITE_IMAGE; FINITE_INTER; FINITE_NUMSEG] THEN - REWRITE_TAC[SUBSET; IN_ELIM_THM; MESON[] - `~((if p then x else y) = y) <=> p /\ ~(x = y)`] THEN - FIRST_ASSUM(MATCH_MP_TAC o MATCH_MP (SET_RULE - `{i | i IN k /\ P i} = IMAGE nk c - ==> (!i. i IN k /\ Q i ==> P i) /\ - (!n. n IN c ==> Q(nk n) ==> n IN s) - ==> !i. i IN k /\ Q i ==> i IN IMAGE nk (c INTER s)`)) THEN - CONJ_TAC THENL - [X_GEN_TAC `i:K` THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN - MATCH_MP_TAC(SET_RULE - `!x. b SUBSET u /\ x IN b - ==> P /\ ~(b = u) ==> ~(?a. u SUBSET {a})`) THEN - EXISTS_TAC `(z:K->A) i` THEN CONJ_TAC THENL - [REWRITE_TAC[SUBSET; IN_MBALL]; - MATCH_MP_TAC CENTRE_IN_MBALL] THEN - ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]; - X_GEN_TAC `m:num` THEN ASM_SIMP_TAC[IN_NUMSEG; LE_0] THEN - DISCH_TAC THEN DISCH_THEN(CONJUNCTS_THEN2 MP_TAC ASSUME_TAC) THEN - GEN_REWRITE_TAC I [GSYM CONTRAPOS_THM] THEN - REWRITE_TAC[NOT_LE; REAL_NOT_LE] THEN DISCH_TAC THEN - REWRITE_TAC[REAL_ARITH `inv x < y <=> &1 / x < y`] THEN - ASM_SIMP_TAC[REAL_LT_LDIV_EQ; REAL_ARITH `&0 < &n + &1`] THEN - FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (REAL_ARITH - `&1 < n * r ==> r * n < r * m ==> &1 < r * m`)) THEN - ASM_SIMP_TAC[REAL_LT_LMUL_EQ; REAL_OF_NUM_ADD; REAL_OF_NUM_LT] THEN - ASM_ARITH_TAC]; - ASM_MESON_TAC[OPEN_IN_MBALL; OPEN_IN_TOPSPACE]; - SUBGOAL_THEN `(x:K->A) IN cartesian_product k (topspace o tops)` - MP_TAC THENL [ASM_MESON_TAC[TOPSPACE_PRODUCT_TOPOLOGY]; ALL_TAC] THEN - REWRITE_TAC[cartesian_product; o_DEF; IN_ELIM_THM] THEN - STRIP_TAC THEN ASM_REWRITE_TAC[] THEN X_GEN_TAC `i:K` THEN - DISCH_TAC THEN COND_CASES_TAC THEN ASM_SIMP_TAC[IN_MBALL] THEN - REPEAT(CONJ_TAC THENL - [ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]; ALL_TAC]) THEN - FIRST_X_ASSUM(MP_TAC o SPECL - [`z:K->A`; `x:K->A`; `mdist M (z:K->A,x)`]) THEN - ANTS_TAC THENL [ASM_MESON_TAC[]; REWRITE_TAC[REAL_LE_REFL]] THEN - DISCH_THEN(MP_TAC o SPEC `i:K`) THEN - ASM_REWRITE_TAC[CAPPED_METRIC] THEN ASM_REAL_ARITH_TAC; - REWRITE_TAC[SUBSET] THEN X_GEN_TAC `y:K->A` THEN - DISCH_THEN(LABEL_TAC "*") THEN - SUBGOAL_THEN `(y:K->A) IN mspace M` ASSUME_TAC THENL - [ASM_REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY] THEN - REMOVE_THEN "*" MP_TAC THEN REWRITE_TAC[cartesian_product] THEN - REWRITE_TAC[IN_ELIM_THM; o_THM] THEN - MATCH_MP_TAC MONO_AND THEN REWRITE_TAC[] THEN - MATCH_MP_TAC MONO_FORALL THEN X_GEN_TAC `i:K` THEN - ASM_CASES_TAC `(i:K) IN k` THEN ASM_REWRITE_TAC[] THEN - COND_CASES_TAC THEN ASM_REWRITE_TAC[IN_MBALL] THEN - MATCH_MP_TAC(SET_RULE - `s SUBSET t ==> P /\ x IN s /\ Q ==> x IN t`) THEN - ASM_SIMP_TAC[GSYM TOPSPACE_MTOPOLOGY; SUBSET_REFL]; - ALL_TAC] THEN - ASM_REWRITE_TAC[IN_MBALL] THEN - TRANS_TAC REAL_LET_TRANS `R:real` THEN ASM_REWRITE_TAC[] THEN - FIRST_X_ASSUM(MP_TAC o SPECL - [`z:K->A`; `y:K->A`; `R:real`]) THEN - ANTS_TAC THENL [ASM_MESON_TAC[]; DISCH_THEN SUBST1_TAC] THEN - REWRITE_TAC[CAPPED_METRIC; REAL_ARITH `x <= &0 <=> ~(&0 < x)`] THEN - REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`] THEN - REWRITE_TAC[REAL_MIN_LE] THEN X_GEN_TAC `i:K` THEN DISCH_TAC THEN - MATCH_MP_TAC(REAL_ARITH - `(a <= b ==> c <= d) ==> b <= a \/ c <= d`) THEN - DISCH_TAC THEN REMOVE_THEN "*" MP_TAC THEN - ASM_REWRITE_TAC[cartesian_product; IN_ELIM_THM] THEN - DISCH_THEN(MP_TAC o SPEC `i:K` o CONJUNCT2) THEN - ASM_REWRITE_TAC[IN_MBALL] THEN REAL_ARITH_TAC]; - X_GEN_TAC `u:K->A->bool` THEN STRIP_TAC THEN - X_GEN_TAC `z:K->A` THEN DISCH_TAC THEN - SUBGOAL_THEN `(z:K->A) IN mspace M` ASSUME_TAC THENL - [UNDISCH_TAC `(z:K->A) IN cartesian_product k u` THEN - ASM_REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; cartesian_product] THEN - REWRITE_TAC[IN_ELIM_THM; o_THM] THEN - ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; - EXISTS_TAC `z:K->A` THEN ASM_SIMP_TAC[MDIST_REFL; CONJ_ASSOC]] THEN - SUBGOAL_THEN - `!i. ?r. i IN k ==> &0 < r /\ mball (m i) ((z:K->A) i,r) SUBSET u i` + [CONJ_TAC THENL [delta_absorbing_tac; delta_absorbing_tac]; + ALL_TAC] THEN + (* Now prove the biconditional a IN t <=> b IN t *) + EQ_TAC THENL + [(* a IN t ==> b IN t: use chain closure with c = t *) + DISCH_TAC THEN + USE_THEN "chain_closure" (MP_TAC o SPEC `t:A->bool`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; SIMP_TAC[]]; + (* b IN t ==> a IN t: by contradiction, if ~(a IN t), K DIFF t + is delta-closed and contains a, so b IN K DIFF t, contradiction *) + DISCH_TAC THEN + ASM_CASES_TAC `(a:A) IN t` THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + USE_THEN "chain_closure" (MP_TAC o SPEC `K DIFF t:A->bool`) THEN + ASM SET_TAC[]]]);; + +(* Helper: for nested compact sets, every point of s(N) is close to k *) +let NESTED_COMPACT_APPROX = prove + (`!m:A metric s. + (!n. compact_in (mtopology m) (s n)) /\ + (!n. s(SUC n) SUBSET s n) + ==> !e. &0 < e + ==> ?N. !x. x IN s N + ==> ?y. y IN INTERS {s n | n IN (:num)} /\ + mdist m (x,y) < e`, + REPEAT STRIP_TAC THEN + ABBREV_TAC `k:A->bool = INTERS {s n | n IN (:num)}` THEN + ABBREV_TAC + `w:A->bool = UNIONS {mball m (y:A,e) | y IN k}` THEN + SUBGOAL_THEN `open_in (mtopology m) (w:A->bool)` ASSUME_TAC THENL + [EXPAND_TAC "w" THEN MATCH_MP_TAC OPEN_IN_UNIONS THEN + REWRITE_TAC[FORALL_IN_GSPEC; OPEN_IN_MBALL]; + ALL_TAC] THEN + SUBGOAL_THEN `!n. (s:num->A->bool) n SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN + SUBGOAL_THEN `(k:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [EXPAND_TAC "k" THEN REWRITE_TAC[INTERS_GSPEC; SUBSET; IN_ELIM_THM] THEN + ASM_MESON_TAC[IN_UNIV; SUBSET]; + ALL_TAC] THEN + ABBREV_TAC `d = \n:num. (s:num->A->bool) n DIFF (w:A->bool)` THEN + SUBGOAL_THEN + `!n. closed_in (subtopology (mtopology m) (s 0:A->bool)) ((d:num->A->bool) n)` + ASSUME_TAC THENL + [X_GEN_TAC `n:num` THEN EXPAND_TAC "d" THEN + SUBGOAL_THEN `(s:num->A->bool) n DIFF w = s 0 INTER (s n DIFF w:A->bool)` + SUBST1_TAC THENL + [SUBGOAL_THEN `(s:num->A->bool) n SUBSET s 0` MP_TAC THENL + [SPEC_TAC (`n:num`,`n:num`) THEN INDUCT_TAC THEN + ASM_REWRITE_TAC[SUBSET_REFL] THEN ASM SET_TAC[]; + SET_TAC[]]; + MATCH_MP_TAC CLOSED_IN_SUBTOPOLOGY_INTER_CLOSED THEN + MATCH_MP_TAC CLOSED_IN_DIFF THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC COMPACT_IN_IMP_CLOSED_IN THEN + ASM_REWRITE_TAC[HAUSDORFF_SPACE_MTOPOLOGY]]; + ALL_TAC] THEN + SUBGOAL_THEN `!n. (d:num->A->bool) (SUC n) SUBSET d n` ASSUME_TAC THENL + [EXPAND_TAC "d" THEN ASM SET_TAC[]; ALL_TAC] THEN + ASM_CASES_TAC `?N. (d:num->A->bool) N = {}` THENL + [FIRST_X_ASSUM(X_CHOOSE_TAC `N:num`) THEN EXISTS_TAC `N:num` THEN + (* First prove s(N) SUBSET w *) + SUBGOAL_THEN `(s:num->A->bool) N SUBSET w` ASSUME_TAC THENL + [MATCH_MP_TAC(SET_RULE `(s:A->bool) DIFF t = {} ==> s SUBSET t`) THEN + SUBGOAL_THEN `(d:num->A->bool) N = (s:num->A->bool) N DIFF w` + (fun th -> ASM_REWRITE_TAC[SYM th]) THEN + EXPAND_TAC "d" THEN REWRITE_TAC[]; + ALL_TAC] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + (* x IN s N and s N SUBSET w, so x IN w *) + SUBGOAL_THEN `(x:A) IN w` MP_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + (* Unfold w to get y IN k with x IN mball(y,e) *) + EXPAND_TAC "w" THEN REWRITE_TAC[UNIONS_GSPEC; IN_ELIM_THM; IN_MBALL] THEN + DISCH_THEN(X_CHOOSE_THEN `y:A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `y:A` THEN CONJ_TAC THENL + [EXPAND_TAC "k" THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[MDIST_SYM]; + (* Second branch: all d(n) nonempty -> contradiction *) + (* INTERS {d n} is nonempty by nested intersection *) + SUBGOAL_THEN `!m' n. m' <= n ==> (d:num->A->bool) n SUBSET d m'` + ASSUME_TAC THENL + [MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN + ASM_REWRITE_TAC[SUBSET_REFL] THEN SET_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `compact_space (subtopology (mtopology m) ((s:num->A->bool) 0))` + ASSUME_TAC THENL + [MATCH_MP_TAC COMPACT_SPACE_SUBTOPOLOGY THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `~(INTERS {(d:num->A->bool) n | n IN (:num)} = {})` MP_TAC THENL - [X_GEN_TAC `i:K` THEN REWRITE_TAC[RIGHT_EXISTS_IMP_THM] THEN - DISCH_TAC THEN - SUBGOAL_THEN `open_in(mtopology(m i)) ((u:K->A->bool) i)` MP_TAC THENL - [ASM_MESON_TAC[]; REWRITE_TAC[OPEN_IN_MTOPOLOGY]] THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MATCH_MP_TAC) THEN - UNDISCH_TAC `(z:K->A) IN cartesian_product k u` THEN - ASM_SIMP_TAC[cartesian_product; IN_ELIM_THM]; - REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM]] THEN - X_GEN_TAC `r:K->real` THEN DISCH_TAC THEN - SUBGOAL_THEN `?a:K. a IN k` STRIP_ASSUME_TAC THENL - [ASM SET_TAC[]; ALL_TAC] THEN - EXISTS_TAC - `inf (IMAGE (\i. min (r i) (inv(&(kn i) + &1))) - (a INSERT {i | i IN k /\ - ~(u i = topspace ((tops:K->A topology) i))})) / - &2` THEN - ASM_SIMP_TAC[REAL_LT_INF_FINITE; FINITE_INSERT; NOT_INSERT_EMPTY; - REAL_HALF; FINITE_IMAGE; IMAGE_EQ_EMPTY; FORALL_IN_IMAGE] THEN - REWRITE_TAC[REAL_LT_MIN; REAL_LT_INV_EQ] THEN - REWRITE_TAC[REAL_ARITH `&0 < &n + &1`] THEN - ASM_SIMP_TAC[FORALL_IN_INSERT; IN_ELIM_THM] THEN - REWRITE_TAC[SUBSET; IN_MBALL] THEN X_GEN_TAC `x:K->A` THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC o CONJUNCT2) THEN - DISCH_THEN(MP_TAC o MATCH_MP REAL_LT_IMP_LE) THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`z:K->A`; `x:K->A`]) THEN - REWRITE_TAC[RIGHT_FORALL_IMP_THM] THEN - ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN - DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN - SUBGOAL_THEN `(x:K->A) IN topspace(product_topology k tops)` MP_TAC THENL - [ASM_MESON_TAC[]; REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY]] THEN - REWRITE_TAC[cartesian_product; o_THM; IN_ELIM_THM] THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN - ASM_REWRITE_TAC[IMP_IMP; AND_FORALL_THM] THEN - MATCH_MP_TAC MONO_FORALL THEN X_GEN_TAC `i:K` THEN - ASM_CASES_TAC `(i:K) IN k` THEN ASM_REWRITE_TAC[] THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN - REWRITE_TAC[REAL_ARITH `x <= y / &2 <=> &2 * x <= y`] THEN - ASM_SIMP_TAC[REAL_LE_INF_FINITE; FINITE_INSERT; NOT_INSERT_EMPTY; - REAL_HALF; FINITE_IMAGE; IMAGE_EQ_EMPTY; FORALL_IN_IMAGE] THEN - REWRITE_TAC[FORALL_IN_INSERT] THEN - DISCH_THEN(MP_TAC o SPEC `i:K` o CONJUNCT2) THEN - ASM_CASES_TAC `(u:K->A->bool) i = topspace(tops i)` THEN - ASM_REWRITE_TAC[IN_ELIM_THM] THEN - REWRITE_TAC[CAPPED_METRIC; REAL_ARITH `x <= &0 <=> ~(&0 < x)`] THEN - REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`] THEN - DISCH_THEN(MP_TAC o MATCH_MP (REAL_ARITH - `&2 * min a b <= min c a ==> &0 < a /\ &0 < c ==> b < c`)) THEN - REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`] THEN - ASM_SIMP_TAC[] THEN DISCH_TAC THEN - REPEAT(FIRST_X_ASSUM(MP_TAC o SPEC `i:K`)) THEN - ASM_REWRITE_TAC[] THEN REPEAT STRIP_TAC THEN - FIRST_X_ASSUM(MATCH_MP_TAC o GEN_REWRITE_RULE I [SUBSET]) THEN - ASM_REWRITE_TAC[IN_MBALL] THEN - CONJ_TAC THENL [ALL_TAC; ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]] THEN - UNDISCH_TAC `(z:K->A) IN mspace M` THEN - ASM_REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; cartesian_product] THEN - REWRITE_TAC[IN_ELIM_THM; o_DEF] THEN - ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]]; - DISCH_TAC THEN REWRITE_TAC[mcomplete] THEN DISCH_THEN(LABEL_TAC "*") THEN - X_GEN_TAC `x:num->K->A` THEN ASM_REWRITE_TAC[cauchy_in] THEN STRIP_TAC THEN - ASM_REWRITE_TAC[LIMIT_COMPONENTWISE] THEN - SUBGOAL_THEN - `!i. ?y. i IN k ==> limit (tops i) (\n. (x:num->K->A) n i) y sequentially` + [MATCH_MP_TAC COMPACT_SPACE_IMP_NEST THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + REWRITE_TAC[INTERS_GSPEC; IN_ELIM_THM; IN_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `z:A` (LABEL_TAC "zd")) THEN + (* z is in all d(n) = s(n) DIFF w, so z IN k and z NOT IN w *) + SUBGOAL_THEN `(z:A) IN k` ASSUME_TAC THENL + [EXPAND_TAC "k" THEN REWRITE_TAC[INTERS_GSPEC; IN_ELIM_THM; IN_UNIV] THEN + X_GEN_TAC `nn:num` THEN + REMOVE_THEN "zd" (MP_TAC o SPEC `nn:num`) THEN + EXPAND_TAC "d" THEN SET_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `~((z:A) IN w)` ASSUME_TAC THENL + [REMOVE_THEN "zd" (MP_TAC o SPEC `0`) THEN EXPAND_TAC "d" THEN + SET_TAC[]; + ALL_TAC] THEN + (* But z IN k implies z IN w, contradicting ~(z IN w) *) + SUBGOAL_THEN `(z:A) IN w` MP_TAC THENL + [EXPAND_TAC "w" THEN REWRITE_TAC[UNIONS_GSPEC; IN_ELIM_THM] THEN + EXISTS_TAC `z:A` THEN CONJ_TAC THENL + [ASM_REWRITE_TAC[]; + MATCH_MP_TAC CENTRE_IN_MBALL THEN ASM_MESON_TAC[SUBSET]]; + ASM_MESON_TAC[]]]);; + +(* Triangle inequality with strict bounds on both legs *) +let MDIST_TRIANGLE_LT = prove + (`!m x y z:A a b. + x IN mspace m /\ y IN mspace m /\ z IN mspace m /\ + mdist m (x,y) < a /\ mdist m (y,z) < b + ==> mdist m (x,z) < a + b`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + MATCH_MP_TAC REAL_LET_TRANS THEN + EXISTS_TAC `mdist (m:A metric) (x:A,y) + mdist m (y:A,z:A)` THEN + ASM_SIMP_TAC[MDIST_TRIANGLE] THEN ASM_REAL_ARITH_TAC);; + +(* Well-chained inters for nested compact sets *) +let WELLCHAINED_INTERS = prove + (`!m:A metric (s:num->A->bool) d e. + d < e /\ + (!n. compact_in (mtopology m) (s n)) /\ + (!n. s(SUC n) SUBSET s n) /\ + (!n a b. + a IN s n /\ b IN s n + ==> ?p k. p 0 = a /\ p k = b /\ + (!i. i <= k ==> p i IN s n) /\ + (!i. i < k ==> mdist m (p i,p (SUC i)) < d)) + ==> !a b. a IN INTERS {s n | n IN (:num)} /\ + b IN INTERS {s n | n IN (:num)} + ==> ?p k. p 0 = a /\ p k = b /\ + (!i. i <= k ==> p i IN INTERS {s n | n IN (:num)}) /\ + (!i. i < k ==> mdist m (p i,p (SUC i)) < e)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + ABBREV_TAC `t:A->bool = INTERS {s n | n IN (:num)}` THEN + (* Handle empty intersection *) + ASM_CASES_TAC `t:A->bool = {}` THENL + [UNDISCH_TAC `t:A->bool = {}` THEN EXPAND_TAC "t" THEN + REWRITE_TAC[INTERS_GSPEC; EXTENSION; IN_ELIM_THM; NOT_IN_EMPTY; IN_UNIV] THEN + MESON_TAC[]; + ALL_TAC] THEN + MAP_EVERY X_GEN_TAC [`a:A`; `b:A`] THEN STRIP_TAC THEN + (* Get N from NESTED_COMPACT_APPROX *) + MP_TAC(ISPECL [`m:A metric`; `s:num->A->bool`] NESTED_COMPACT_APPROX) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC `(e - d) / &2`) THEN + ASM_REWRITE_TAC[REAL_HALF; REAL_SUB_LT] THEN + DISCH_THEN(X_CHOOSE_TAC `N:num`) THEN + (* a and b are in s N *) + SUBGOAL_THEN `(a:A) IN (s:num->A->bool) N /\ b IN s N` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `(a:A) IN t` THEN UNDISCH_TAC `(b:A) IN t` THEN + EXPAND_TAC "t" THEN + REWRITE_TAC[INTERS_GSPEC; IN_ELIM_THM; IN_UNIV] THEN MESON_TAC[]; + ALL_TAC] THEN + (* Get d-chain from a to b in s(N) *) + FIRST_X_ASSUM(MP_TAC o SPECL [`N:num`; `a:A`; `b:A`]) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `p:num->A` + (X_CHOOSE_THEN `n:num` STRIP_ASSUME_TAC)) THEN + (* For each chain point, find a nearby point in t *) + SUBGOAL_THEN + `!i. ?y. i <= n + ==> y IN t /\ mdist m ((p:num->A) i,y:A) < (e - d) / &2` MP_TAC THENL - [X_GEN_TAC `i:K` THEN ASM_CASES_TAC `(i:K) IN k` THEN - ASM_REWRITE_TAC[] THEN REMOVE_THEN "*" (MP_TAC o SPEC `i:K`) THEN - ASM_SIMP_TAC[] THEN DISCH_THEN MATCH_MP_TAC THEN - REWRITE_TAC[cauchy_in; GSYM TOPSPACE_MTOPOLOGY] THEN CONJ_TAC THENL - [RULE_ASSUM_TAC(REWRITE_RULE[TOPSPACE_PRODUCT_TOPOLOGY; - cartesian_product; IN_ELIM_THM; o_DEF]) THEN ASM_MESON_TAC[]; - X_GEN_TAC `e:real` THEN DISCH_TAC] THEN - FIRST_X_ASSUM(MP_TAC o SPEC `min e (inv(&(kn(i:K)) + &1)) / &2`) THEN - REWRITE_TAC[REAL_HALF; REAL_LT_MIN; REAL_LT_INV_EQ] THEN - ANTS_TAC THENL [ASM_REAL_ARITH_TAC; MATCH_MP_TAC MONO_EXISTS] THEN - X_GEN_TAC `N:num` THEN DISCH_TAC THEN - MAP_EVERY X_GEN_TAC [`m:num`; `n:num`] THEN STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`m:num`; `n:num`]) THEN - ASM_REWRITE_TAC[] THEN DISCH_THEN(MP_TAC o MATCH_MP REAL_LT_IMP_LE) THEN - ASM_SIMP_TAC[] THEN DISCH_THEN(MP_TAC o SPEC `i:K`) THEN - ASM_REWRITE_TAC[CAPPED_METRIC; REAL_ARITH `x <= &0 <=> ~(&0 < x)`] THEN - REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`] THEN - MATCH_MP_TAC(REAL_ARITH - `&0 < d /\ &0 < e ==> min d x <= min e d / &2 ==> x < e`) THEN - ASM_REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`]; - REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM]] THEN - X_GEN_TAC `y:K->A` THEN DISCH_TAC THEN - EXISTS_TAC `RESTRICTION k (y:K->A)` THEN - ASM_REWRITE_TAC[REWRITE_RULE[IN] RESTRICTION_IN_EXTENSIONAL] THEN - SIMP_TAC[RESTRICTION; EVENTUALLY_TRUE] THEN ASM_REWRITE_TAC[]]);; + [X_GEN_TAC `j:num` THEN REWRITE_TAC[RIGHT_EXISTS_IMP_THM] THEN + DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `(p:num->A) j`) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `y:A` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM]] THEN + X_GEN_TAC `q:num->A` THEN DISCH_TAC THEN + (* Chain points and nearby points are in mspace *) + SUBGOAL_THEN `(t:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [EXPAND_TAC "t" THEN REWRITE_TAC[INTERS_GSPEC; SUBSET; IN_ELIM_THM; IN_UNIV] THEN + ASM_MESON_TAC[COMPACT_IN_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY; SUBSET]; + ALL_TAC] THEN + SUBGOAL_THEN + `!i:num. i <= n ==> (p:num->A) i IN mspace m /\ (q:num->A) i IN mspace m` + ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY; SUBSET]; + ALL_TAC] THEN + (* Construct chain: keep endpoints (p), replace interior with nearby t-points (q) *) + EXISTS_TAC `\i. if 0 < i /\ i < n then (q:num->A) i else p i` THEN + EXISTS_TAC `n:num` THEN + REWRITE_TAC[LT_REFL] THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [(* All chain points in t *) + X_GEN_TAC `i:num` THEN DISCH_TAC THEN + ASM_CASES_TAC `i = 0` THENL + [ASM_REWRITE_TAC[ARITH_RULE `~(0 < 0)`]; ALL_TAC] THEN + ASM_CASES_TAC `i:num = n` THENL + [ASM_REWRITE_TAC[LT_REFL]; ALL_TAC] THEN + SUBGOAL_THEN `0 < i /\ i < n` (fun th -> REWRITE_TAC[th]) THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + ASM_MESON_TAC[]; + (* Pre-establish symmetric distance bound q->p *) + SUBGOAL_THEN + `!j:num. j <= n + ==> mdist m ((q:num->A) j,(p:num->A) j) < (e - d) / &2` + ASSUME_TAC THENL + [ASM_MESON_TAC[MDIST_SYM]; ALL_TAC] THEN + (* Distance bounds for consecutive chain elements *) + X_GEN_TAC `i:num` THEN DISCH_TAC THEN + SUBGOAL_THEN `0 < SUC i` (fun th -> REWRITE_TAC[th]) THENL + [ARITH_TAC; ALL_TAC] THEN + ASM_CASES_TAC `i = 0` THENL + [ASM_REWRITE_TAC[ARITH_RULE `~(0 < 0)`] THEN COND_CASES_TAC THENL + [(* SUC 0 < n: p 0 -> q(SUC 0), use MDIST_TRIANGLE_LT *) + MATCH_MP_TAC REAL_LT_TRANS THEN EXISTS_TAC `d + (e - d) / &2` THEN + CONJ_TAC THENL + [MATCH_MP_TAC(ISPEC `m:A metric` MDIST_TRIANGLE_LT) THEN + EXISTS_TAC `(p:num->A)(SUC 0)` THEN + ASM_MESON_TAC[LE_0; ARITH_RULE `SUC 0 < n ==> SUC 0 <= n`]; + ASM_REAL_ARITH_TAC]; + (* ~(SUC 0 < n): mdist(p 0, p(SUC 0)) < d < e *) + ASM_MESON_TAC[REAL_LT_TRANS]]; + ALL_TAC] THEN + (* 0 < i: first point is q i *) + SUBGOAL_THEN `0 < i /\ i < n` (fun th -> REWRITE_TAC[th]) THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + COND_CASES_TAC THENL + [(* SUC i < n: q i -> q(SUC i), use two MDIST_TRIANGLE_LT steps *) + MATCH_MP_TAC REAL_LTE_TRANS THEN + EXISTS_TAC `(e - d) / &2 + (d + (e - d) / &2)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC(ISPEC `m:A metric` MDIST_TRIANGLE_LT) THEN + EXISTS_TAC `(p:num->A) i` THEN REPEAT CONJ_TAC THENL + [ASM_MESON_TAC[LT_IMP_LE]; + ASM_MESON_TAC[LT_IMP_LE]; + ASM_MESON_TAC[LT_IMP_LE; ARITH_RULE `SUC i < n ==> SUC i <= n`]; + ASM_MESON_TAC[LT_IMP_LE]; + MATCH_MP_TAC(ISPEC `m:A metric` MDIST_TRIANGLE_LT) THEN + EXISTS_TAC `(p:num->A)(SUC i)` THEN + ASM_MESON_TAC[LT_IMP_LE; + ARITH_RULE `SUC i < n ==> SUC i <= n`]]; + ASM_REAL_ARITH_TAC]; + (* ~(SUC i < n): q i -> p(SUC i), use MDIST_TRIANGLE_LT *) + MATCH_MP_TAC REAL_LT_TRANS THEN EXISTS_TAC `(e - d) / &2 + d` THEN + CONJ_TAC THENL + [MATCH_MP_TAC(ISPEC `m:A metric` MDIST_TRIANGLE_LT) THEN + EXISTS_TAC `(p:num->A) i` THEN + ASM_MESON_TAC[LT_IMP_LE; ARITH_RULE `i < n ==> SUC i <= n`]; + ASM_REAL_ARITH_TAC]]]);; (* ------------------------------------------------------------------------- *) -(* A perfect set in common cases must have cardinality >= c. *) +(* Uniformly locally connected and Property S for metric spaces *) (* ------------------------------------------------------------------------- *) -let CARD_GE_PERFECT_SET = prove - (`!top s:A->bool. - (completely_metrizable_space top \/ - locally_compact_space top /\ hausdorff_space top) /\ - top derived_set_of s = s /\ ~(s = {}) - ==> (:real) <=_c s`, - REWRITE_TAC[TAUT `(p \/ q) /\ r ==> s <=> - (p ==> r ==> s) /\ (q /\ r ==> s)`] THEN - REWRITE_TAC[FORALL_AND_THM; RIGHT_FORALL_IMP_THM] THEN - REWRITE_TAC[GSYM FORALL_MCOMPLETE_TOPOLOGY] THEN - REWRITE_TAC[RIGHT_IMP_FORALL_THM; IMP_IMP; GSYM CONJ_ASSOC] THEN - CONJ_TAC THENL - [REPEAT STRIP_TAC THEN - TRANS_TAC CARD_LE_TRANS `(:num->bool)` THEN - SIMP_TAC[CARD_EQ_REAL; CARD_EQ_IMP_LE] THEN - SUBGOAL_THEN `(s:A->bool) SUBSET mspace m` ASSUME_TAC THENL - [ASM_MESON_TAC[DERIVED_SET_OF_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY]; - ALL_TAC] THEN - SUBGOAL_THEN - `!x e. x IN s /\ &0 < e - ==> ?y z d. y IN s /\ z IN s /\ &0 < d /\ d < e / &2 /\ - mcball m (y,d) SUBSET mcball m (x,e) /\ - mcball m (z,d) SUBSET mcball m (x,e) /\ - DISJOINT (mcball m (y:A,d)) (mcball m (z,d))` - MP_TAC THENL - [REPEAT STRIP_TAC THEN - MP_TAC(ISPECL [`m:A metric`; `s:A->bool`] - DERIVED_SET_OF_INFINITE_MBALL) THEN - ASM_REWRITE_TAC[EXTENSION; IN_ELIM_THM] THEN - DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `e / &4`)) THEN - ASM_REWRITE_TAC[INFINITE; REAL_ARITH `&0 < e / &4 <=> &0 < e`] THEN - DISCH_THEN(MP_TAC o SPEC `x:A` o MATCH_MP - (MESON[FINITE_RULES; FINITE_SUBSET] - `~FINITE s ==> !a b c. ~(s SUBSET {a,b,c})`)) THEN - DISCH_THEN(MP_TAC o MATCH_MP (SET_RULE - `(!b c. ~(s SUBSET {a,b,c})) - ==> ?b c. b IN s /\ c IN s /\ ~(c = a) /\ ~(b = a) /\ ~(b = c)`)) THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `l:A` THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `r:A` THEN - REWRITE_TAC[IN_INTER] THEN STRIP_TAC THEN - EXISTS_TAC `mdist m (l:A,r) / &3` THEN - REPEAT(FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_MBALL])) THEN - UNDISCH_TAC `~(l:A = r)` THEN - REWRITE_TAC[DISJOINT; SUBSET; EXTENSION; IN_INTER; NOT_IN_EMPTY] THEN - ASM_SIMP_TAC[IN_MCBALL] THEN UNDISCH_TAC `(x:A) IN mspace m` THEN - POP_ASSUM_LIST(K ALL_TAC) THEN - REPEAT(DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC)) THEN - ONCE_REWRITE_TAC[CONJ_ASSOC] THEN CONJ_TAC THENL - [REPEAT(POP_ASSUM MP_TAC) THEN CONV_TAC METRIC_ARITH; ALL_TAC] THEN - REWRITE_TAC[AND_FORALL_THM] THEN X_GEN_TAC `y:A` THEN - REWRITE_TAC[CONJ_ASSOC] THEN CONJ_TAC THENL - [ALL_TAC; REPEAT(POP_ASSUM MP_TAC) THEN CONV_TAC METRIC_ARITH] THEN - REPEAT STRIP_TAC THEN FIRST_ASSUM(MP_TAC o SPEC `e:real` o MATCH_MP - (REAL_ARITH `x <= y / &3 ==> !e. y < e / &2 ==> x < e / &6`)) THEN - (ANTS_TAC THENL - [REPEAT(POP_ASSUM MP_TAC) THEN CONV_TAC METRIC_ARITH; ALL_TAC]) - THENL - [UNDISCH_TAC `mdist m (x:A,l) < e / &4`; - UNDISCH_TAC `mdist m (x:A,r) < e / &4`] THEN - MAP_EVERY UNDISCH_TAC - [`(x:A) IN mspace m`; `(y:A) IN mspace m`; - `(l:A) IN mspace m`; `(r:A) IN mspace m`] THEN - CONV_TAC METRIC_ARITH; - REWRITE_TAC[RIGHT_IMP_EXISTS_THM; SKOLEM_THM; LEFT_IMP_EXISTS_THM]] THEN - MAP_EVERY X_GEN_TAC - [`l:A->real->A`; `r:A->real->A`; `d:A->real->real`] THEN - DISCH_TAC THEN FIRST_X_ASSUM(X_CHOOSE_TAC `a:A` o - REWRITE_RULE[GSYM MEMBER_NOT_EMPTY]) THEN - SUBGOAL_THEN - `!b. ?xe. xe 0 = (a:A,&1) /\ - !n. xe(SUC n) = (if b(n) then r else l) (FST(xe n)) (SND(xe n)), - d (FST(xe n)) (SND(xe n))` - MP_TAC THENL - [GEN_TAC THEN - W(ACCEPT_TAC o prove_recursive_functions_exist num_RECURSION o - snd o dest_exists o snd); - REWRITE_TAC[EXISTS_PAIR_FUN_THM; PAIR_EQ] THEN - REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM; FORALL_AND_THM]] THEN - MAP_EVERY X_GEN_TAC - [`x:(num->bool)->num->A`; `r:(num->bool)->num->real`] THEN - STRIP_TAC THEN - SUBGOAL_THEN `mcomplete (submetric m s:A metric)` MP_TAC THENL - [MATCH_MP_TAC CLOSED_IN_MCOMPLETE_IMP_MCOMPLETE THEN - ASM_REWRITE_TAC[CLOSED_IN_CONTAINS_DERIVED_SET; TOPSPACE_MTOPOLOGY] THEN - ASM SET_TAC[]; - REWRITE_TAC[MCOMPLETE_NEST_SING]] THEN - DISCH_THEN(MP_TAC o MATCH_MP MONO_FORALL o GEN `b:num->bool` o - SPEC `\n. mcball (submetric m s) - ((x:(num->bool)->num->A) b n,r b n)`) THEN - REWRITE_TAC[SKOLEM_THM] THEN - SUBGOAL_THEN `(!b n. (x:(num->bool)->num->A) b n IN s) /\ - (!b n. &0 < (r:(num->bool)->num->real) b n)` +(* Property S (Fine Connected Coverable): For every e > 0, there exists + a finite cover of the space by connected sets of diameter <= e *) +let fccoverable_space = new_definition + `fccoverable_space (m:A metric) <=> + !e. &0 < e + ==> ?c. FINITE c /\ + UNIONS c = mspace m /\ + (!t. t IN c + ==> connected_in (mtopology m) t /\ + mbounded m t /\ + mdiameter m t <= e)`;; + +(* Uniformly Locally Connected: For every e > 0, there exists d > 0 such that + any two points at distance < d can be connected within the space by a + connected set of diameter <= e *) +let ulc_space = new_definition + `ulc_space (m:A metric) <=> + !e. &0 < e + ==> ?d. &0 < d /\ + !x y. x IN mspace m /\ y IN mspace m /\ mdist m (x,y) < d + ==> ?c. x IN c /\ y IN c /\ + c SUBSET mspace m /\ + connected_in (mtopology m) c /\ + mbounded m c /\ + mdiameter m c <= e`;; + +(* Property S for a subset s of the metric space *) +let fccoverable_in = new_definition + `fccoverable_in (m:A metric) s <=> + s SUBSET mspace m /\ + !e. &0 < e + ==> ?c. FINITE c /\ + UNIONS c = s /\ + (!t. t IN c + ==> connected_in (mtopology m) t /\ + mbounded m t /\ + mdiameter m t <= e)`;; + +(* ------------------------------------------------------------------------- *) +(* Main theorems *) +(* ------------------------------------------------------------------------- *) + +(* Helper: if x is in closure of t, then t is contained in a ball around x *) +let IN_CLOSURE_OF_IMP_SUBSET_MCBALL = prove + (`!m:A metric x t. + x IN mspace m /\ mbounded m t /\ x IN mtopology m closure_of t + ==> t SUBSET mcball m (x, mdiameter m t)`, + REPEAT STRIP_TAC THEN + REWRITE_TAC[SUBSET; IN_MCBALL] THEN X_GEN_TAC `y:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(y:A) IN mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[MBOUNDED_IMP_IN_MSPACE]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + ASM_CASES_TAC `t:A->bool = {}` THENL [ASM SET_TAC[]; ALL_TAC] THEN + (* Proof by contradiction: if d(x,y) > diameter(t), derive contradiction *) + REWRITE_TAC[GSYM REAL_NOT_LT] THEN DISCH_TAC THEN + ABBREV_TAC `eps = (mdist m (x:A,y) - mdiameter m t) / &2` THEN + SUBGOAL_THEN `&0 < eps` ASSUME_TAC THENL + [EXPAND_TAC "eps" THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + UNDISCH_TAC `x IN mtopology m closure_of (t:A->bool)` THEN + REWRITE_TAC[METRIC_CLOSURE_OF; IN_ELIM_THM] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `eps:real`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `z:A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(z:A) IN mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[MBOUNDED_IMP_IN_MSPACE]; ALL_TAC] THEN + (* d(x,y) <= d(x,z) + d(z,y) < eps + diameter(t) *) + SUBGOAL_THEN `mdist m (x:A,y) <= mdist m (x,z) + mdist m (z,y) /\ + mdist m (z:A,y) <= mdiameter m t` MP_TAC THENL + [ASM_MESON_TAC[MDIST_TRIANGLE; MDIAMETER_BOUNDED_BOUND]; ALL_TAC] THEN + UNDISCH_TAC `z IN mball m (x:A,eps)` THEN REWRITE_TAC[IN_MBALL] THEN + UNDISCH_TAC `mdiameter m (t:A->bool) < mdist m (x,y)` THEN + EXPAND_TAC "eps" THEN REAL_ARITH_TAC);; + +let FCCOVERABLE_SPACE_IMP_LOCALLY_CONNECTED_SPACE = prove + (`!m:A metric. + fccoverable_space m ==> locally_connected_space (mtopology m)`, + GEN_TAC THEN REWRITE_TAC[fccoverable_space; LOCALLY_CONNECTED_SPACE_IM_KLEINEN] THEN + DISCH_TAC THEN + MAP_EVERY X_GEN_TAC [`v:A->bool`; `x:A`] THEN STRIP_TAC THEN + SUBGOAL_THEN `(x:A) IN mspace m /\ ?e. &0 < e /\ mball m (x:A,e) SUBSET v` STRIP_ASSUME_TAC THENL - [REWRITE_TAC[AND_FORALL_THM] THEN GEN_TAC THEN - INDUCT_TAC THEN ASM_REWRITE_TAC[REAL_LT_01] THEN ASM_MESON_TAC[]; - ALL_TAC] THEN - SUBGOAL_THEN `(!b n. (x:(num->bool)->num->A) b n IN mspace m)` - ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - ANTS_TAC THENL - [X_GEN_TAC `b:num->bool` THEN REWRITE_TAC[CLOSED_IN_MCBALL] THEN - ASM_REWRITE_TAC[MCBALL_EQ_EMPTY; SUBMETRIC; IN_INTER] THEN - ASM_SIMP_TAC[REAL_ARITH `&0 < x ==> ~(x < &0)`] THEN CONJ_TAC THENL - [MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN - REPEAT(CONJ_TAC THENL [SET_TAC[]; ALL_TAC]) THEN - ASM_REWRITE_TAC[MCBALL_SUBMETRIC_EQ] THEN ASM SET_TAC[]; - X_GEN_TAC `e:real` THEN DISCH_TAC THEN - MP_TAC(ISPECL [`inv(&2)`; `e:real`] REAL_ARCH_POW_INV) THEN - ASM_REWRITE_TAC[REAL_POW_INV] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `n:num` THEN - DISCH_TAC THEN EXISTS_TAC `(x:(num->bool)->num->A) b n` THEN - MATCH_MP_TAC MCBALL_SUBSET_CONCENTRIC THEN - TRANS_TAC REAL_LE_TRANS `inv(&2 pow n)` THEN - ASM_SIMP_TAC[REAL_LT_IMP_LE] THEN - SPEC_TAC(`n:num`,`n:num`) THEN - MATCH_MP_TAC num_INDUCTION THEN ASM_REWRITE_TAC[real_pow] THEN - CONV_TAC REAL_RAT_REDUCE_CONV THEN REWRITE_TAC[REAL_INV_MUL] THEN - GEN_TAC THEN MATCH_MP_TAC(REAL_ARITH - `d < e / &2 ==> e <= i ==> d <= inv(&2) * i`) THEN - ASM_SIMP_TAC[]]; - REWRITE_TAC[SKOLEM_THM; le_c; IN_UNIV] THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `z:(num->bool)->A` THEN - SIMP_TAC[SUBMETRIC; IN_INTER; FORALL_AND_THM] THEN STRIP_TAC THEN - MAP_EVERY X_GEN_TAC [`b:num->bool`; `c:num->bool`] THEN - GEN_REWRITE_TAC I [GSYM CONTRAPOS_THM] THEN - REWRITE_TAC[FUN_EQ_THM; NOT_FORALL_THM] THEN - GEN_REWRITE_TAC LAND_CONV [num_WOP] THEN - REWRITE_TAC[LEFT_IMP_EXISTS_THM; TAUT `~(p <=> q) <=> p <=> ~q`] THEN - X_GEN_TAC `n:num` THEN REPEAT STRIP_TAC THEN FIRST_ASSUM(MP_TAC o - GEN_REWRITE_RULE (BINDER_CONV o LAND_CONV) [INTERS_GSPEC]) THEN - DISCH_THEN(fun th -> - MP_TAC(SPEC `c:num->bool` th) THEN MP_TAC(SPEC `b:num->bool` th)) THEN - ASM_REWRITE_TAC[TAUT `p ==> ~q <=> ~(p /\ q)`] THEN - DISCH_THEN(MP_TAC o MATCH_MP (SET_RULE - `s = {a} /\ t = {a} ==> a IN s INTER t`)) THEN - REWRITE_TAC[IN_INTER; IN_ELIM_THM; AND_FORALL_THM] THEN - DISCH_THEN(MP_TAC o SPEC `SUC n`) THEN ASM_REWRITE_TAC[COND_SWAP] THEN + [ASM_MESON_TAC[OPEN_IN_MTOPOLOGY; SUBSET]; ALL_TAC] THEN + (* Cover mspace with connected bounded sets of diameter <= e/3 *) + FIRST_X_ASSUM(MP_TAC o SPEC `e / &3`) THEN + ASM_SIMP_TAC[REAL_LT_DIV; REAL_OF_NUM_LT; ARITH] THEN + DISCH_THEN(X_CHOOSE_THEN `c:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + (* K = union of pieces whose closure contains x (Whyburn's construction) *) + ABBREV_TAC + `K = UNIONS {t:A->bool | t IN c /\ x IN mtopology m closure_of t}` THEN + (* x IN K *) + SUBGOAL_THEN `(x:A) IN K` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + SUBGOAL_THEN `?t0:A->bool. t0 IN c /\ x IN t0` MP_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[CLOSURE_OF_SUBSET; TOPSPACE_MTOPOLOGY; SUBSET; + CONNECTED_IN_SUBSET_TOPSPACE]; + ALL_TAC] THEN + (* K is connected via CONNECTED_IN_UNIONS_STRONG *) + SUBGOAL_THEN `connected_in (mtopology m) (K:A->bool)` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN MATCH_MP_TAC CONNECTED_IN_UNIONS_STRONG THEN + CONJ_TAC THENL + [REWRITE_TAC[IN_ELIM_THM] THEN ASM_MESON_TAC[]; + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER; IN_UNIONS; + INTERS_GSPEC; IN_ELIM_THM] THEN + EXISTS_TAC `x:A` THEN CONJ_TAC THENL + [UNDISCH_TAC `(x:A) IN K` THEN EXPAND_TAC "K" THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN MESON_TAC[]; + X_GEN_TAC `y:A->bool` THEN STRIP_TAC THEN ASM_REWRITE_TAC[]]]; + ALL_TAC] THEN + (* K SUBSET v via mcball chain *) + SUBGOAL_THEN `(K:A->bool) SUBSET v` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN REWRITE_TAC[UNIONS_SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `t:A->bool` THEN STRIP_TAC THEN + SUBGOAL_THEN `mdiameter m (t:A->bool) <= e / &3` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + TRANS_TAC SUBSET_TRANS `mball m (x:A, e)` THEN ASM_REWRITE_TAC[] THEN + TRANS_TAC SUBSET_TRANS `mcball m (x:A, mdiameter m t)` THEN CONJ_TAC THENL + [MATCH_MP_TAC IN_CLOSURE_OF_IMP_SUBSET_MCBALL THEN ASM_MESON_TAC[]; + MATCH_MP_TAC MCBALL_SUBSET_MBALL_CONCENTRIC THEN ASM_REAL_ARITH_TAC]; + ALL_TAC] THEN + (* x is in the interior of K: the "bad" closures form a closed set missing x *) + ABBREV_TAC + `F' = UNIONS {(mtopology m:(A)topology) closure_of t | t | + t IN c /\ ~(x IN mtopology m closure_of t)}` THEN + SUBGOAL_THEN `closed_in (mtopology m) (F':A->bool)` ASSUME_TAC THENL + [EXPAND_TAC "F'" THEN MATCH_MP_TAC CLOSED_IN_UNIONS THEN CONJ_TAC THENL + [MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `IMAGE (\t. (mtopology m:(A)topology) closure_of t) c` THEN + ASM_SIMP_TAC[FINITE_IMAGE] THEN SET_TAC[]; + REWRITE_TAC[FORALL_IN_GSPEC; CLOSED_IN_CLOSURE_OF]]; + ALL_TAC] THEN + SUBGOAL_THEN `~((x:A) IN F')` ASSUME_TAC THENL + [EXPAND_TAC "F'" THEN REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Get ball around x in complement of F' *) + SUBGOAL_THEN + `?d. &0 < d /\ mball m (x:A, d) SUBSET mspace m DIFF F'` + STRIP_ASSUME_TAC THENL + [SUBGOAL_THEN `open_in (mtopology m) (mspace m DIFF F':A->bool)` MP_TAC THENL + [REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY] THEN + ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_TOPSPACE]; + ASM_MESON_TAC[OPEN_IN_MTOPOLOGY; TOPSPACE_MTOPOLOGY; IN_DIFF]]; + ALL_TAC] THEN + (* Witness: u = mball(x, min(d, e/3)), connecting set = K for all y *) + EXISTS_TAC `mball m (x:A, min d (e / &3))` THEN + ASM_SIMP_TAC[OPEN_IN_MBALL; CENTRE_IN_MBALL; REAL_LT_MIN; + REAL_LT_DIV; REAL_OF_NUM_LT; ARITH] THEN + CONJ_TAC THENL + [TRANS_TAC SUBSET_TRANS `mball m (x:A, e)` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC MBALL_SUBSET_CONCENTRIC THEN ASM_REAL_ARITH_TAC; + ALL_TAC] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + EXISTS_TAC `K:A->bool` THEN ASM_REWRITE_TAC[] THEN + (* y IN K: y is in some t IN c; t is not bad since y is close to x *) + EXPAND_TAC "K" THEN REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + SUBGOAL_THEN `(y:A) IN mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[IN_MBALL]; ALL_TAC] THEN + SUBGOAL_THEN `?ty:A->bool. ty IN c /\ y IN ty` STRIP_ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + EXISTS_TAC `ty:A->bool` THEN ASM_REWRITE_TAC[] THEN + ASM_CASES_TAC `x IN mtopology m closure_of (ty:A->bool)` THEN + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `(ty:A->bool) SUBSET F'` MP_TAC THENL + [EXPAND_TAC "F'" THEN + MP_TAC(ISPECL [`mtopology m:(A)topology`; `ty:A->bool`] + CLOSURE_OF_SUBSET) THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN ASM SET_TAC[]; + SUBGOAL_THEN `mball m (x:A, min d (e / &3)) SUBSET mball m (x, d)` + MP_TAC THENL + [MATCH_MP_TAC MBALL_SUBSET_CONCENTRIC THEN REAL_ARITH_TAC; + ASM SET_TAC[]]]);; + +let ULC_SPACE_IMP_LOCALLY_CONNECTED_SPACE = prove + (`!m:A metric. + ulc_space m ==> locally_connected_space (mtopology m)`, + GEN_TAC THEN REWRITE_TAC[ulc_space] THEN + REWRITE_TAC[LOCALLY_CONNECTED_SPACE_IM_KLEINEN] THEN + DISCH_TAC THEN MAP_EVERY X_GEN_TAC [`v:A->bool`; `x:A`] THEN + DISCH_THEN(CONJUNCTS_THEN2 MP_TAC ASSUME_TAC) THEN + GEN_REWRITE_TAC LAND_CONV [OPEN_IN_MTOPOLOGY] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `x:A`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `e:real` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `e / &2`) THEN + ASM_SIMP_TAC[REAL_LT_DIV; REAL_OF_NUM_LT; ARITH] THEN + DISCH_THEN(X_CHOOSE_THEN `d:real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `mball m (x:A, min d e)` THEN + SUBGOAL_THEN `(x:A) IN mspace m` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + ASM_SIMP_TAC[OPEN_IN_MBALL; CENTRE_IN_MBALL; REAL_LT_MIN] THEN CONJ_TAC THENL + [TRANS_TAC SUBSET_TRANS `mball m (x:A, e)` THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC MBALL_SUBSET_CONCENTRIC THEN + REAL_ARITH_TAC; + ALL_TAC] THEN + X_GEN_TAC `y:A` THEN REWRITE_TAC[IN_MBALL] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`x:A`; `y:A`]) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC; + ALL_TAC] THEN + MATCH_MP_TAC MONO_EXISTS THEN + X_GEN_TAC `c:A->bool` THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + TRANS_TAC SUBSET_TRANS `mball m (x:A, e)` THEN + ASM_REWRITE_TAC[SUBSET; IN_MBALL] THEN X_GEN_TAC `z:A` THEN DISCH_TAC THEN + CONJ_TAC THENL + [ASM_MESON_TAC[MBOUNDED_IMP_IN_MSPACE]; + SUBGOAL_THEN `mdist m (x:A, z) <= mdiameter m c` MP_TAC THENL + [MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN ASM_REWRITE_TAC[]; + ASM_REAL_ARITH_TAC]]);; + +(* ------------------------------------------------------------------------- *) +(* Property S for intermediate sets between s and closure s *) +(* ------------------------------------------------------------------------- *) + +let FCCOVERABLE_SPACE_EQ_FCCOVERABLE_IN_MSPACE = prove + (`!m:A metric. fccoverable_space m <=> fccoverable_in m (mspace m)`, + REWRITE_TAC[fccoverable_space; fccoverable_in; SUBSET_REFL]);; + +let FCCOVERABLE_SPACE_INTERMEDIATE_CLOSURE = prove + (`!m:A metric s t. + s SUBSET t /\ t SUBSET (mtopology m closure_of s) /\ fccoverable_in m s + ==> fccoverable_in m t`, + REPEAT GEN_TAC THEN REWRITE_TAC[fccoverable_in] THEN + REPEAT(DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) THEN + DISCH_TAC THEN CONJ_TAC THENL + [ASM_MESON_TAC[SUBSET_TRANS; CLOSURE_OF_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN + X_GEN_TAC `e:real` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `e:real`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `c:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `{t INTER (mtopology m closure_of k):A->bool | k IN c}` THEN + ASM_SIMP_TAC[SIMPLE_IMAGE; FINITE_IMAGE; UNIONS_IMAGE; FORALL_IN_IMAGE] THEN + CONJ_TAC THENL + [MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_IMAGE; SUBSET; IN_ELIM_THM] THEN SET_TAC[]; SUBGOAL_THEN - `(x:(num->bool)->num->A) b n = x c n /\ - (r:(num->bool)->num->real) b n = r c n` - (CONJUNCTS_THEN SUBST1_TAC) - THENL - [UNDISCH_TAC `!m:num. m < n ==> (b m <=> c m)` THEN - SPEC_TAC(`n:num`,`p:num`) THEN - INDUCT_TAC THEN ASM_SIMP_TAC[LT_SUC_LE; LE_REFL; LT_IMP_LE]; - COND_CASES_TAC THEN ASM_REWRITE_TAC[MCBALL_SUBMETRIC_EQ; IN_INTER] THEN - ASM SET_TAC[]]]; - SUBGOAL_THEN - `!top:A topology. - locally_compact_space top /\ hausdorff_space top /\ - top derived_set_of topspace top = topspace top /\ ~(topspace top = {}) - ==> (:real) <=_c topspace top` - ASSUME_TAC THENL - [REPEAT STRIP_TAC; - MAP_EVERY X_GEN_TAC [`top:A topology`; `s:A->bool`] THEN STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPEC `subtopology top (s:A->bool)`) THEN - SUBGOAL_THEN `(s:A->bool) SUBSET topspace top` ASSUME_TAC THENL - [ASM_MESON_TAC[DERIVED_SET_OF_SUBSET_TOPSPACE]; ALL_TAC] THEN - ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY; HAUSDORFF_SPACE_SUBTOPOLOGY; - DERIVED_SET_OF_SUBTOPOLOGY; SET_RULE `s INTER s = s`; - SET_RULE `s SUBSET u ==> u INTER s = s`] THEN - DISCH_THEN MATCH_MP_TAC THEN - MATCH_MP_TAC LOCALLY_COMPACT_SPACE_CLOSED_SUBSET THEN - ASM_REWRITE_TAC[CLOSED_IN_CONTAINS_DERIVED_SET; SUBSET_REFL]] THEN - TRANS_TAC CARD_LE_TRANS `(:num->bool)` THEN - SIMP_TAC[CARD_EQ_REAL; CARD_EQ_IMP_LE] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN - DISCH_THEN(X_CHOOSE_TAC `z:A`) THEN - FIRST_ASSUM(MP_TAC o SPEC `z:A` o REWRITE_RULE[locally_compact_space]) THEN - ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`u:A->bool`; `k:A->bool`] THEN STRIP_TAC THEN - SUBGOAL_THEN `~(u:A->bool = {})` ASSUME_TAC THENL - [ASM SET_TAC[]; - REPEAT(FIRST_X_ASSUM(K ALL_TAC o check (free_in `z:A`) o concl))] THEN - SUBGOAL_THEN - `!c. closed_in top c /\ c SUBSET k /\ ~(top interior_of c = {}) - ==> ?d e. closed_in top d /\ d SUBSET k /\ - ~(top interior_of d = {}) /\ - closed_in top e /\ e SUBSET k /\ - ~(top interior_of e = {}) /\ - DISJOINT d e /\ d SUBSET c /\ e SUBSET (c:A->bool)` - MP_TAC THENL - [REPEAT STRIP_TAC THEN - UNDISCH_TAC `~(top interior_of c:A->bool = {})` THEN - ASM_REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `z:A` THEN DISCH_TAC THEN - SUBGOAL_THEN `(z:A) IN topspace top` ASSUME_TAC THENL - [ASM_MESON_TAC[SUBSET; INTERIOR_OF_SUBSET_TOPSPACE]; ALL_TAC] THEN - MP_TAC(ISPECL [`top:A topology`; `topspace top:A->bool`] - DERIVED_SET_OF_INFINITE_OPEN_IN) THEN - ASM_REWRITE_TAC[] THEN DISCH_THEN(MP_TAC o AP_TERM `\s. (z:A) IN s`) THEN - ASM_REWRITE_TAC[IN_ELIM_THM] THEN - DISCH_THEN(MP_TAC o SPEC `top interior_of c:A->bool`) THEN - ASM_SIMP_TAC[OPEN_IN_INTERIOR_OF; INTERIOR_OF_SUBSET_TOPSPACE; - SET_RULE `s SUBSET u ==> u INTER s = s`] THEN - DISCH_THEN(MP_TAC o MATCH_MP (MESON[INFINITE; FINITE_SING; FINITE_SUBSET] - `INFINITE s ==> !a. ~(s SUBSET {a})`)) THEN - DISCH_THEN(MP_TAC o MATCH_MP (SET_RULE - `(!a. ~(s SUBSET {a})) ==> ?a b. a IN s /\ b IN s /\ ~(a = b)`)) THEN - REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN - SUBGOAL_THEN `(x:A) IN topspace top /\ y IN topspace top` - STRIP_ASSUME_TAC THENL - [ASM_MESON_TAC[SUBSET; INTERIOR_OF_SUBSET_TOPSPACE]; ALL_TAC] THEN - FIRST_ASSUM(MP_TAC o SPECL [`x:A`; `y:A`] o - REWRITE_RULE[hausdorff_space]) THEN - ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`v:A->bool`; `w:A->bool`] THEN STRIP_TAC THEN - MP_TAC(ISPEC `top:A topology` - LOCALLY_COMPACT_HAUSDORFF_IMP_REGULAR_SPACE) THEN - ASM_REWRITE_TAC[GSYM NEIGHBOURHOOD_BASE_OF_CLOSED_IN] THEN - REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN DISCH_THEN(fun th -> - MP_TAC(SPECL [`top interior_of c INTER w:A->bool`; `y:A`] th) THEN - MP_TAC(SPECL [`top interior_of c INTER v:A->bool`; `x:A`] th)) THEN - ASM_SIMP_TAC[IN_INTER; OPEN_IN_INTER; OPEN_IN_INTERIOR_OF] THEN - REWRITE_TAC[LEFT_IMP_EXISTS_THM; SUBSET_INTER] THEN - MAP_EVERY X_GEN_TAC [`m:A->bool`; `d:A->bool`] THEN STRIP_TAC THEN - MAP_EVERY X_GEN_TAC [`n:A->bool`; `e:A->bool`] THEN STRIP_TAC THEN - MAP_EVERY EXISTS_TAC [`d:A->bool`; `e:A->bool`] THEN - ASM_REWRITE_TAC[] THEN ONCE_REWRITE_TAC[TAUT - `p /\ q /\ r /\ s /\ t <=> (q /\ s) /\ p /\ r /\ t`] THEN - CONJ_TAC THENL - [CONJ_TAC THENL [EXISTS_TAC `x:A`; EXISTS_TAC `y:A`] THEN - REWRITE_TAC[interior_of; IN_ELIM_THM] THEN ASM_MESON_TAC[]; - MP_TAC(ISPECL [`top:A topology`; `c:A->bool`] INTERIOR_OF_SUBSET) THEN - ASM SET_TAC[]]; - ALL_TAC] THEN - REWRITE_TAC[RIGHT_IMP_EXISTS_THM; SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`l:(A->bool)->A->bool`; `r:(A->bool)->A->bool`] THEN - DISCH_TAC THEN - SUBGOAL_THEN - `!b. ?d:num->A->bool. - d 0 = k /\ - (!n. d(SUC n) = (if b(n) then r else l) (d n))` - MP_TAC THENL - [GEN_TAC THEN - W(ACCEPT_TAC o prove_recursive_functions_exist num_RECURSION o - snd o dest_exists o snd); - REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM; FORALL_AND_THM]] THEN - X_GEN_TAC `d:(num->bool)->num->A->bool` THEN STRIP_TAC THEN - SUBGOAL_THEN - `!b n. closed_in top (d b n) /\ d b n SUBSET k /\ - ~(top interior_of ((d:(num->bool)->num->A->bool) b n) = {})` - MP_TAC THENL - [GEN_TAC THEN INDUCT_TAC THENL - [ASM_SIMP_TAC[SUBSET_REFL; COMPACT_IN_IMP_CLOSED_IN] THEN - FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (SET_RULE - `~(u = {}) ==> u SUBSET i ==> ~(i = {})`)) THEN - ASM_SIMP_TAC[INTERIOR_OF_MAXIMAL_EQ]; - ASM_REWRITE_TAC[] THEN COND_CASES_TAC THEN ASM_SIMP_TAC[]]; - REWRITE_TAC[FORALL_AND_THM] THEN STRIP_TAC] THEN - SUBGOAL_THEN - `!b. ~(INTERS {(d:(num->bool)->num->A->bool) b n | n IN (:num)} = {})` - MP_TAC THENL - [X_GEN_TAC `b:num->bool` THEN MATCH_MP_TAC COMPACT_SPACE_IMP_NEST THEN - EXISTS_TAC `subtopology top (k:A->bool)` THEN - ASM_SIMP_TAC[CLOSED_IN_SUBSET_TOPSPACE; COMPACT_SPACE_SUBTOPOLOGY] THEN - CONJ_TAC THENL [ASM_MESON_TAC[INTERIOR_OF_EMPTY]; ALL_TAC] THEN - MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN - REPEAT(CONJ_TAC THENL [SET_TAC[]; ALL_TAC]) THEN - ASM_SIMP_TAC[] THEN GEN_TAC THEN COND_CASES_TAC THEN - ASM_SIMP_TAC[]; - REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; SKOLEM_THM; LEFT_IMP_EXISTS_THM]] THEN - X_GEN_TAC `x:(num->bool)->A` THEN - REWRITE_TAC[INTERS_GSPEC; IN_ELIM_THM; IN_UNIV] THEN DISCH_TAC THEN - REWRITE_TAC[le_c; IN_UNIV] THEN EXISTS_TAC `x:(num->bool)->A` THEN - CONJ_TAC THENL [ASM_MESON_TAC[CLOSED_IN_SUBSET; SUBSET]; ALL_TAC] THEN - MAP_EVERY X_GEN_TAC [`b:num->bool`; `c:num->bool`] THEN - GEN_REWRITE_TAC I [GSYM CONTRAPOS_THM] THEN - REWRITE_TAC[FUN_EQ_THM; NOT_FORALL_THM] THEN - GEN_REWRITE_TAC LAND_CONV [num_WOP] THEN - REWRITE_TAC[LEFT_IMP_EXISTS_THM; TAUT `~(p <=> q) <=> p <=> ~q`] THEN - X_GEN_TAC `n:num` THEN REPEAT STRIP_TAC THEN - SUBGOAL_THEN - `DISJOINT ((d:(num->bool)->num->A->bool) b (SUC n)) (d c (SUC n))` - MP_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN - ASM_SIMP_TAC[COND_SWAP] THEN - SUBGOAL_THEN `(d:(num->bool)->num->A->bool) b n = d c n` SUBST1_TAC THENL - [ALL_TAC; ASM_MESON_TAC[DISJOINT_SYM]] THEN - UNDISCH_TAC `!m:num. m < n ==> (b m <=> c m)` THEN - SPEC_TAC(`n:num`,`p:num`) THEN - INDUCT_TAC THEN ASM_SIMP_TAC[LT_SUC_LE; LE_REFL; LT_IMP_LE]]);; + `mtopology m closure_of s:A->bool = + UNIONS {mtopology m closure_of k | k IN c}` + MP_TAC THENL + [FIRST_X_ASSUM(SUBST1_TAC o SYM) THEN + ASM_SIMP_TAC[CLOSURE_OF_UNIONS; SIMPLE_IMAGE]; + REWRITE_TAC[SIMPLE_IMAGE; UNIONS_IMAGE] THEN ASM SET_TAC[]]]; + ALL_TAC] THEN + X_GEN_TAC `k:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `k:A->bool`) THEN + ASM_REWRITE_TAC[] THEN STRIP_TAC THEN + SUBGOAL_THEN `(k:A->bool) SUBSET s /\ k SUBSET mspace m` + STRIP_ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + REPEAT CONJ_TAC THENL + [MATCH_MP_TAC CONNECTED_IN_INTERMEDIATE_CLOSURE_OF THEN + EXISTS_TAC `k:A->bool` THEN ASM_REWRITE_TAC[INTER_SUBSET] THEN + ASM_SIMP_TAC[SUBSET_INTER; CLOSURE_OF_SUBSET; TOPSPACE_MTOPOLOGY] THEN + ASM SET_TAC[]; + ASM_MESON_TAC[MBOUNDED_SUBSET; INTER_SUBSET; MBOUNDED_CLOSURE_OF]; + TRANS_TAC REAL_LE_TRANS `mdiameter m (mtopology m closure_of k:A->bool)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_SUBSET THEN + ASM_SIMP_TAC[INTER_SUBSET; MBOUNDED_CLOSURE_OF]; + ASM_SIMP_TAC[MDIAMETER_CLOSURE]]]);; (* ------------------------------------------------------------------------- *) -(* Euclidean space and n-spheres, as subtopologies of infinite product R^N. *) +(* fccoverable_in is equivalent to fccoverable_space on the submetric. *) (* ------------------------------------------------------------------------- *) -let euclidean_space = new_definition - `euclidean_space n = subtopology (product_topology (:num) (\i. euclideanreal)) - {x | !i. ~(i IN 1..n) ==> x i = &0}`;; +let FCCOVERABLE_IN_IMP_FCCOVERABLE_SPACE_SUBMETRIC = prove + (`!m:A metric s. fccoverable_in m s ==> fccoverable_space (submetric m s)`, + REPEAT GEN_TAC THEN REWRITE_TAC[fccoverable_in; fccoverable_space] THEN + STRIP_TAC THEN + ASM_SIMP_TAC[SUBMETRIC; + SET_RULE `(s:A->bool) SUBSET t ==> s INTER t = s`] THEN + X_GEN_TAC `e:real` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `e:real`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `c:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `c:(A->bool)->bool` THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `t:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `t:A->bool`) THEN ASM_REWRITE_TAC[] THEN + STRIP_TAC THEN + SUBGOAL_THEN `(t:A->bool) SUBSET s` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[MTOPOLOGY_SUBMETRIC; CONNECTED_IN_SUBTOPOLOGY; + MBOUNDED_SUBMETRIC; MDIAMETER_SUBMETRIC] THEN + ASM_SIMP_TAC[SET_RULE `(t:A->bool) SUBSET s ==> s INTER t = t`]);; -let TOPSPACE_EUCLIDEAN_SPACE = prove - (`!n. topspace(euclidean_space n) = {x | !i. ~(i IN 1..n) ==> x i = &0}`, - REWRITE_TAC[euclidean_space; TOPSPACE_SUBTOPOLOGY; - TOPSPACE_PRODUCT_TOPOLOGY] THEN - REWRITE_TAC[o_DEF; TOPSPACE_EUCLIDEANREAL; CARTESIAN_PRODUCT_UNIV] THEN - REWRITE_TAC[INTER_UNIV]);; +(* ------------------------------------------------------------------------- *) +(* fccoverable_in implies locally_connected_space on subtopology *) +(* ------------------------------------------------------------------------- *) -let NONEMPTY_EUCLIDEAN_SPACE = prove - (`!n. ~(topspace(euclidean_space n) = {})`, - GEN_TAC THEN REWRITE_TAC[TOPSPACE_EUCLIDEAN_SPACE] THEN - REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN - EXISTS_TAC `(\i. &0):num->real` THEN REWRITE_TAC[]);; +let FCCOVERABLE_IN_IMP_LOCALLY_CONNECTED_SPACE = prove + (`!m:A metric (s:A->bool). + fccoverable_in m s + ==> locally_connected_space (subtopology (mtopology m) s)`, + SIMP_TAC[FCCOVERABLE_IN_IMP_FCCOVERABLE_SPACE_SUBMETRIC; GSYM MTOPOLOGY_SUBMETRIC; + FCCOVERABLE_SPACE_IMP_LOCALLY_CONNECTED_SPACE]);; + +let MDIAMETER_SUBSET_MBALL = prove + (`!m:A metric x r t. + x IN mspace m /\ &0 < r /\ t SUBSET mball m (x,r) + ==> mdiameter m t <= &2 * r`, + REPEAT STRIP_TAC THEN MATCH_MP_TAC MDIAMETER_LE THEN REPEAT CONJ_TAC THENL + [TRANS_TAC SUBSET_TRANS `mball m (x:A, r)` THEN + ASM_REWRITE_TAC[MBALL_SUBSET_MSPACE]; + DISJ2_TAC THEN ASM_REAL_ARITH_TAC; + MAP_EVERY X_GEN_TAC [`p:A`; `q:A`] THEN STRIP_TAC THEN + SUBGOAL_THEN `(p:A) IN mball m (x,r) /\ q IN mball m (x,r)` MP_TAC THENL + [ASM SET_TAC[]; REWRITE_TAC[IN_MBALL]] THEN STRIP_TAC THEN + SUBGOAL_THEN `mdist m (p:A,q) <= mdist m (x,p) + mdist m (x,q)` + MP_TAC THENL + [ASM_MESON_TAC[MDIST_TRIANGLE; MDIST_SYM]; ASM_REAL_ARITH_TAC]]);; -let SUBSET_EUCLIDEAN_SPACE = prove - (`!m n. topspace(euclidean_space m) SUBSET topspace(euclidean_space n) <=> - m <= n`, - REPEAT GEN_TAC THEN - REWRITE_TAC[TOPSPACE_EUCLIDEAN_SPACE; SUBSET; IN_ELIM_THM; IN_NUMSEG] THEN - EQ_TAC THENL [ALL_TAC; MESON_TAC[LE_TRANS]] THEN - GEN_REWRITE_TAC I [GSYM CONTRAPOS_THM] THEN - REWRITE_TAC[NOT_LE] THEN DISCH_TAC THEN - DISCH_THEN(MP_TAC o SPEC `(\i. if i = m then &1 else &0):num->real`) THEN - REWRITE_TAC[NOT_IMP] THEN CONJ_TAC THENL - [REPEAT STRIP_TAC THEN COND_CASES_TAC THEN ASM_REWRITE_TAC[] THEN - ASM_ARITH_TAC; - DISCH_THEN(MP_TAC o SPEC `m:num`) THEN - REWRITE_TAC[] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN ASM_ARITH_TAC]);; +(* ------------------------------------------------------------------------- *) +(* Compact + locally connected implies ULC *) +(* ------------------------------------------------------------------------- *) -let CLOSED_IN_EUCLIDEAN_SPACE = prove - (`!n. closed_in (product_topology (:num) (\i. euclideanreal)) - (topspace(euclidean_space n))`, - GEN_TAC THEN +let COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE = prove + (`!m:A metric. + compact_in (mtopology m) (mspace m) /\ + locally_connected_space (mtopology m) + ==> ulc_space m`, + GEN_TAC THEN STRIP_TAC THEN + REWRITE_TAC[ulc_space] THEN + X_GEN_TAC `e:real` THEN DISCH_TAC THEN + (* Build the open cover: for each x, use locally connected to get u(x) *) SUBGOAL_THEN - `topspace(euclidean_space n) = - INTERS {{x | x IN topspace(product_topology (:num) (\i. euclideanreal)) /\ - x i IN {&0}} - | ~(i IN 1..n)}` - SUBST1_TAC THENL - [REWRITE_TAC[TOPSPACE_EUCLIDEAN_SPACE; INTERS_GSPEC; IN_ELIM_THM] THEN - REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; o_DEF] THEN - REWRITE_TAC[TOPSPACE_EUCLIDEANREAL; CARTESIAN_PRODUCT_UNIV] THEN - SET_TAC[]; - MATCH_MP_TAC CLOSED_IN_INTERS THEN REWRITE_TAC[FORALL_IN_GSPEC] THEN - REWRITE_TAC[SET_RULE `~({f x | P x} = {}) <=> ?x. P x`; IN_NUMSEG] THEN - REPEAT STRIP_TAC THENL [EXISTS_TAC `0` THEN ARITH_TAC; ALL_TAC] THEN - MATCH_MP_TAC CLOSED_IN_CONTINUOUS_MAP_PREIMAGE THEN - EXISTS_TAC `euclideanreal` THEN - SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV] THEN - REWRITE_TAC[GSYM REAL_CLOSED_IN; REAL_CLOSED_SING]]);; - -let COMPLETELY_METRIZABLE_EUCLIDEAN_SPACE = prove - (`!n. completely_metrizable_space(euclidean_space n)`, - GEN_TAC THEN REWRITE_TAC[euclidean_space] THEN - MATCH_MP_TAC COMPLETELY_METRIZABLE_SPACE_CLOSED_IN THEN - REWRITE_TAC[GSYM TOPSPACE_EUCLIDEAN_SPACE; CLOSED_IN_EUCLIDEAN_SPACE] THEN - REWRITE_TAC[COMPLETELY_METRIZABLE_SPACE_PRODUCT_TOPOLOGY] THEN - REWRITE_TAC[COMPLETELY_METRIZABLE_SPACE_EUCLIDEANREAL] THEN - REWRITE_TAC[COUNTABLE_SUBSET_NUM]);; - -let METRIZABLE_EUCLIDEAN_SPACE = prove - (`!n. metrizable_space(euclidean_space n)`, - SIMP_TAC[COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE; - COMPLETELY_METRIZABLE_EUCLIDEAN_SPACE]);; - -let CONTINUOUS_MAP_COMPONENTWISE_EUCLIDEAN_SPACE = prove - (`!top (f:A->num->real) n. - continuous_map (top,euclidean_space n) - (\x i. if 1 <= i /\ i <= n then f x i else &0) <=> - !i. 1 <= i /\ i <= n ==> continuous_map(top,euclideanreal) (\x. f x i)`, - REWRITE_TAC[euclidean_space; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN - SIMP_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM; IN_NUMSEG] THEN - REPEAT GEN_TAC THEN REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN - EQ_TAC THEN MATCH_MP_TAC MONO_FORALL THEN X_GEN_TAC `i:num` THEN - ASM_CASES_TAC `1 <= i /\ i <= n` THEN - ASM_REWRITE_TAC[CONTINUOUS_MAP_REAL_CONST]);; + `?U:(A->bool)->bool. + (!u. u IN U ==> open_in (mtopology m) u) /\ + (!u. u IN U ==> connected_in (mtopology m) u) /\ + (!u. u IN U ==> mbounded m u /\ mdiameter m u <= e) /\ + mspace m SUBSET UNIONS U` + (X_CHOOSE_THEN `U:(A->bool)->bool` STRIP_ASSUME_TAC) THENL + [(* Witness: all connected open sets contained in some mball(x, e/2) *) + EXISTS_TAC + `{u:A->bool | open_in (mtopology m) u /\ connected_in (mtopology m) u /\ + ?x. x IN mspace m /\ x IN u /\ + u SUBSET mball m (x, e / &2)}` THEN + REWRITE_TAC[IN_ELIM_THM] THEN REPEAT CONJ_TAC THENL + [(* Each u is open - immediate from definition *) + MESON_TAC[]; + (* Each u is connected - immediate from definition *) + MESON_TAC[]; + (* Each u is bounded with diameter <= e *) + X_GEN_TAC `u:A->bool` THEN STRIP_TAC THEN CONJ_TAC THENL + [ASM_MESON_TAC[MBOUNDED_SUBSET; MBOUNDED_MBALL]; + MATCH_MP_TAC(REAL_ARITH `x <= &2 * (e / &2) ==> x <= e`) THEN + MATCH_MP_TAC MDIAMETER_SUBSET_MBALL THEN + ASM_MESON_TAC[REAL_HALF]]; + (* mspace m covered by UNIONS U - use locally_connected_space *) + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [LOCALLY_CONNECTED_SPACE]) THEN + DISCH_THEN(MP_TAC o SPECL [`mball m (y:A, e / &2)`; `y:A`]) THEN + ANTS_TAC THENL + [ASM_SIMP_TAC[OPEN_IN_MBALL; CENTRE_IN_MBALL; REAL_HALF]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `u:A->bool` THEN ASM_REWRITE_TAC[] THEN + EXISTS_TAC `y:A` THEN ASM_REWRITE_TAC[GSYM SUBSET]]; + ALL_TAC] THEN + (* Apply Lebesgue number lemma to get d > 0 *) + MP_TAC(ISPECL [`m:A metric`; `mspace m:A->bool`; `U:(A->bool)->bool`] + LEBESGUE_NUMBER) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `d:real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `d:real` THEN ASM_REWRITE_TAC[] THEN + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN + (* x has an enclosing u IN U *) + FIRST_X_ASSUM(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `v:A->bool` THEN + SUBGOAL_THEN `(x:A) IN v /\ y IN v` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET; CENTRE_IN_MBALL; IN_MBALL]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `(v:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[CONNECTED_IN_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + FIRST_X_ASSUM(MP_TAC o SPEC `v:A->bool`) THEN ASM_REWRITE_TAC[] THEN + SIMP_TAC[]]);; -let CONTINUOUS_MAP_EUCLIDEAN_SPACE_ADD = prove - (`!f g:A->num->real. - continuous_map(top,euclidean_space n) f /\ - continuous_map(top,euclidean_space n) g - ==> continuous_map(top,euclidean_space n) (\x i. f x i + g x i)`, - REWRITE_TAC[euclidean_space; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN - SIMP_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM; REAL_ADD_LID] THEN - REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN - SIMP_TAC[CONTINUOUS_MAP_REAL_ADD; EXTENSIONAL_UNIV]);; +(* Alternative: connecting sets lie in balls around both endpoints *) +let COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE_ALT = prove + (`!m:A metric. + compact_in (mtopology m) (mspace m) /\ + locally_connected_space (mtopology m) + ==> !e. &0 < e + ==> ?d. &0 < d /\ d < e /\ + !x y. x IN mspace m /\ y IN mspace m /\ mdist m (x,y) < d + ==> ?c. connected_in (mtopology m) c /\ + x IN c /\ y IN c /\ + c SUBSET mspace m INTER mball m (x,e) INTER + mball m (y,e)`, + GEN_TAC THEN STRIP_TAC THEN X_GEN_TAC `e:real` THEN DISCH_TAC THEN + (* Use COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE with e/2 *) + MP_TAC(ISPEC `m:A metric` COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE) THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[ulc_space] THEN + DISCH_THEN(MP_TAC o SPEC `e / &2`) THEN + ASM_SIMP_TAC[REAL_HALF] THEN + DISCH_THEN(X_CHOOSE_THEN `d':real` STRIP_ASSUME_TAC) THEN + (* Take d = min(d', e/2) *) + EXISTS_TAC `min d' (e / &2)` THEN + ASM_REWRITE_TAC[REAL_LT_MIN; REAL_MIN_LT] THEN + REPEAT(CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC]) THEN + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN + REWRITE_TAC[REAL_LT_MIN] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`x:A`; `y:A`]) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `c:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `c:A->bool` THEN ASM_REWRITE_TAC[] THEN + (* Show c SUBSET mspace m INTER mball m (x,e) INTER mball m (y,e) *) + REWRITE_TAC[SUBSET; IN_INTER; IN_MBALL] THEN + X_GEN_TAC `z:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(z:A) IN mspace m /\ + mdist m (x:A,z) <= mdiameter m c /\ mdist m (y,z) <= mdiameter m c` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[MDIAMETER_BOUNDED_BOUND; MDIST_SYM; SUBSET]; + ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC]);; -let CONTINUOUS_MAP_EUCLIDEAN_SPACE_SUB = prove - (`!f g:A->num->real. - continuous_map(top,euclidean_space n) f /\ - continuous_map(top,euclidean_space n) g - ==> continuous_map(top,euclidean_space n) (\x i. f x i - g x i)`, - REWRITE_TAC[euclidean_space; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN - SIMP_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM; REAL_SUB_RZERO] THEN - REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN - SIMP_TAC[CONTINUOUS_MAP_REAL_SUB; EXTENSIONAL_UNIV]);; +(* ------------------------------------------------------------------------- *) +(* Totally bounded + ULC implies Property S *) +(* ------------------------------------------------------------------------- *) -let HOMEOMORPHIC_EUCLIDEAN_SPACE_PRODUCT_TOPOLOGY = prove - (`!n. euclidean_space n homeomorphic_space - product_topology (1..n) (\i. euclideanreal)`, - GEN_TAC THEN REWRITE_TAC[homeomorphic_space; homeomorphic_maps] THEN - EXISTS_TAC `\f:num->real. RESTRICTION (1..n) f` THEN - EXISTS_TAC `\(f:num->real) i. if i IN 1..n then f i else &0` THEN - REWRITE_TAC[TOPSPACE_EUCLIDEAN_SPACE; TOPSPACE_PRODUCT_TOPOLOGY] THEN - REWRITE_TAC[cartesian_product; o_THM; TOPSPACE_EUCLIDEANREAL] THEN - REWRITE_TAC[IN_ELIM_THM; EXTENSION; euclidean_space] THEN - REPEAT CONJ_TAC THENL - [MATCH_MP_TAC CONTINUOUS_MAP_FROM_SUBTOPOLOGY THEN - REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE] THEN - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; RESTRICTION_IN_EXTENSIONAL] THEN - SIMP_TAC[RESTRICTION; CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV]; - REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN - SIMP_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM] THEN - REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE] THEN - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_UNIV] THEN - CONJ_TAC THENL [MESON_TAC[IN; EXTENSIONAL_UNIV; IN_UNIV]; ALL_TAC] THEN - X_GEN_TAC `i:num` THEN ASM_CASES_TAC `i IN 1..n` THEN - ASM_REWRITE_TAC[CONTINUOUS_MAP_REAL_CONST] THEN - ASM_SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION]; - REPEAT STRIP_TAC THEN GEN_REWRITE_TAC I [FUN_EQ_THM] THEN - SIMP_TAC[RESTRICTION] THEN ASM_MESON_TAC[]; - REWRITE_TAC[EXTENSIONAL; FUN_EQ_THM; IN_UNIV; IN_ELIM_THM] THEN - REWRITE_TAC[RESTRICTION] THEN MESON_TAC[]]);; +(* Note: For general metric spaces, we need totally_bounded_in rather than + just mbounded, since bounded + discrete doesn't imply finite in general. *) -let CONTRACTIBLE_EUCLIDEAN_SPACE = prove - (`!n. contractible_space(euclidean_space n)`, +let TOTALLY_BOUNDED_ULC_SPACE_IMP_FCCOVERABLE_SPACE = prove + (`!m:A metric. + totally_bounded_in m (mspace m) /\ ulc_space m + ==> fccoverable_space m`, GEN_TAC THEN - MP_TAC(SPEC `n:num` HOMEOMORPHIC_EUCLIDEAN_SPACE_PRODUCT_TOPOLOGY) THEN - DISCH_THEN(SUBST1_TAC o MATCH_MP HOMEOMORPHIC_SPACE_CONTRACTIBILITY) THEN - REWRITE_TAC[CONTRACTIBLE_SPACE_PRODUCT_TOPOLOGY] THEN - REWRITE_TAC[CONTRACTIBLE_SPACE_EUCLIDEANREAL]);; + REWRITE_TAC[ulc_space; fccoverable_space] THEN + STRIP_TAC THEN X_GEN_TAC `e:real` THEN DISCH_TAC THEN + (* Use ULC with e/2 to get d *) + FIRST_X_ASSUM(MP_TAC o SPEC `e / &2`) THEN + ASM_SIMP_TAC[REAL_HALF] THEN + DISCH_THEN(X_CHOOSE_THEN `d:real` STRIP_ASSUME_TAC) THEN + (* Define M(p) = points reachable from p by connected sets of diam <= e/2 *) + ABBREV_TAC + `M = \p:A. {x | x IN mspace m /\ + ?c. p IN c /\ x IN c /\ c SUBSET mspace m /\ + connected_in (mtopology m) c /\ mbounded m c /\ + mdiameter m c <= e / &2}` THEN + (* Key subgoal 1: mball(p,d) INTER mspace m SUBSET M(p) *) + SUBGOAL_THEN `!p:A. p IN mspace m ==> mball m (p,d) INTER mspace m SUBSET M p` + ASSUME_TAC THENL + [X_GEN_TAC `p:A` THEN DISCH_TAC THEN EXPAND_TAC "M" THEN + REWRITE_TAC[SUBSET; IN_INTER; IN_MBALL; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`p:A`; `x:A`]) THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC MONO_EXISTS THEN + X_GEN_TAC `c:A->bool` THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + ASM SET_TAC[]; + ALL_TAC] THEN + (* Get finite k from totally_bounded_in with d-balls *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [totally_bounded_in]) THEN + DISCH_THEN(MP_TAC o SPEC `d:real`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `k:A->bool` STRIP_ASSUME_TAC) THEN + (* Witness: IMAGE M k *) + EXISTS_TAC `IMAGE (M:A->A->bool) k` THEN + ASM_SIMP_TAC[FINITE_IMAGE] THEN + CONJ_TAC THENL + [(* UNIONS (IMAGE M k) = mspace m *) + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_IMAGE] THEN + GEN_TAC THEN DISCH_TAC THEN + EXPAND_TAC "M" THEN SIMP_TAC[SUBSET; IN_ELIM_THM]; + REWRITE_TAC[SUBSET; IN_UNIONS; EXISTS_IN_IMAGE] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o SPEC `y:A` o GEN_REWRITE_RULE I [SUBSET]) THEN + ASM_REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `b:A->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_THEN `p:A` STRIP_ASSUME_TAC) + ASSUME_TAC)) THEN + EXISTS_TAC `p:A` THEN ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `p:A`) THEN ASM SET_TAC[]]; + ALL_TAC] THEN + (* Now prove each M(p) is connected, bounded, and has diameter <= e *) + REWRITE_TAC[FORALL_IN_IMAGE] THEN X_GEN_TAC `p:A` THEN DISCH_TAC THEN + (* First establish p IN mspace m from p IN k and k SUBSET mspace m *) + SUBGOAL_THEN `(p:A) IN mspace m` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + (* M(p) SUBSET mspace m (easy from definition) *) + SUBGOAL_THEN `(M:A->A->bool) p SUBSET mspace m` ASSUME_TAC THENL + [EXPAND_TAC "M" THEN REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN SIMP_TAC[]; + ALL_TAC] THEN + (* p IN M(p) using {p} as witness *) + SUBGOAL_THEN `(p:A) IN M p` ASSUME_TAC THENL + [EXPAND_TAC "M" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_REWRITE_TAC[] THEN EXISTS_TAC `{p:A}` THEN + ASM_SIMP_TAC[IN_SING; SING_SUBSET; CONNECTED_IN_SING; + TOPSPACE_MTOPOLOGY; MBOUNDED_INSERT; + MBOUNDED_EMPTY; MDIAMETER_SING] THEN + ASM_REAL_ARITH_TAC; + ALL_TAC] THEN + (* Key: M(p) SUBSET mcball m (p, e/2) *) + SUBGOAL_THEN `(M:A->A->bool) p SUBSET mcball m (p, e / &2)` ASSUME_TAC THENL + [EXPAND_TAC "M" THEN REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_MCBALL] THEN + X_GEN_TAC `x:A` THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + (* Need: mdist m (p,x) <= e/2. Have: p IN c, x IN c, mbounded m c, mdiameter m c <= e/2 *) + MATCH_MP_TAC REAL_LE_TRANS THEN EXISTS_TAC `mdiameter m (c:A->bool)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + (* Now prove the three properties *) + REPEAT CONJ_TAC THENL + [(* M(p) is connected *) + (* M(p) = UNIONS of connected sets containing p *) + SUBGOAL_THEN + `(M:A->A->bool) p = + UNIONS {c | c SUBSET mspace m /\ connected_in (mtopology m) c /\ + mbounded m c /\ mdiameter m c <= e / &2 /\ p IN c}` + SUBST1_TAC THENL + [EXPAND_TAC "M" THEN + REWRITE_TAC[EXTENSION; IN_UNIONS; IN_ELIM_THM] THEN + MESON_TAC[SUBSET]; + ALL_TAC] THEN + MATCH_MP_TAC CONNECTED_IN_UNIONS THEN CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_GSPEC] THEN SIMP_TAC[]; + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; INTERS_GSPEC; IN_ELIM_THM] THEN + EXISTS_TAC `p:A` THEN X_GEN_TAC `c:A->bool` THEN STRIP_TAC THEN + ASM_REWRITE_TAC[]]; + (* M(p) is bounded *) + MATCH_MP_TAC MBOUNDED_SUBSET THEN + EXISTS_TAC `mcball m (p:A, e / &2)` THEN + ASM_REWRITE_TAC[MBOUNDED_MCBALL]; + (* mdiameter M(p) <= e *) + (* For any x, y in M(p): d(p,x) <= e/2 and d(p,y) <= e/2, so d(x,y) <= e *) + MATCH_MP_TAC MDIAMETER_LE THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL + [DISJ2_TAC THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN + SUBGOAL_THEN + `(x:A) IN mcball m (p,e / &2) /\ y IN mcball m (p,e / &2)` MP_TAC THENL + [ASM SET_TAC[]; REWRITE_TAC[IN_MCBALL]] THEN STRIP_TAC THEN + SUBGOAL_THEN `mdist m (x:A,y) <= mdist m (p,x) + mdist m (p,y)` MP_TAC THENL + [ASM_MESON_TAC[MDIST_TRIANGLE; MDIST_SYM]; ASM_REAL_ARITH_TAC]]);; -let PATH_CONNECTED_EUCLIDEAN_SPACE = prove - (`!n. path_connected_space(euclidean_space n)`, - SIMP_TAC[CONTRACTIBLE_IMP_PATH_CONNECTED_SPACE; - CONTRACTIBLE_EUCLIDEAN_SPACE]);; +(* Note: For general metric spaces, mbounded does NOT imply totally bounded. + The Euclidean version BOUNDED_ULC_SPACE_IMP_FCCOVERABLE_SPACE relies on + DISCRETE_BOUNDED_IMP_FINITE which is specific to R^n. + The correct general statement is TOTALLY_BOUNDED_ULC_SPACE_IMP_FCCOVERABLE_SPACE above. *) -let CONNECTED_EUCLIDEAN_SPACE = prove - (`!n. connected_space(euclidean_space n)`, - SIMP_TAC[PATH_CONNECTED_EUCLIDEAN_SPACE; - PATH_CONNECTED_IMP_CONNECTED_SPACE]);; +let COMPACT_IN_LOCALLY_CONNECTED_IMP_FCCOVERABLE_SPACE = prove + (`!m:A metric. + compact_in (mtopology m) (mspace m) /\ + locally_connected_space (mtopology m) + ==> fccoverable_space m`, + REPEAT STRIP_TAC THEN + MATCH_MP_TAC TOTALLY_BOUNDED_ULC_SPACE_IMP_FCCOVERABLE_SPACE THEN CONJ_TAC THENL + [MATCH_MP_TAC COMPACT_IN_IMP_TOTALLY_BOUNDED_IN THEN ASM_REWRITE_TAC[]; + MATCH_MP_TAC COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE THEN ASM_REWRITE_TAC[]]);; -let LOCALLY_COMPACT_EUCLIDEAN_SPACE = prove - (`!n. locally_compact_space(euclidean_space n)`, - X_GEN_TAC `n:num` THEN - MP_TAC(SPEC `n:num` HOMEOMORPHIC_EUCLIDEAN_SPACE_PRODUCT_TOPOLOGY) THEN - DISCH_THEN(SUBST1_TAC o MATCH_MP HOMEOMORPHIC_LOCALLY_COMPACT_SPACE) THEN - REWRITE_TAC[LOCALLY_COMPACT_SPACE_PRODUCT_TOPOLOGY] THEN - DISJ2_TAC THEN REWRITE_TAC[LOCALLY_COMPACT_SPACE_EUCLIDEANREAL] THEN - SIMP_TAC[FINITE_NUMSEG; FINITE_RESTRICT]);; +let COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE = prove + (`!m:A metric. + compact_in (mtopology m) (mspace m) /\ + locally_connected_space (mtopology m) <=> + (!e. &0 < e + ==> ?c. FINITE c /\ UNIONS c = mspace m /\ + !t. t IN c + ==> connected_in (mtopology m) t /\ + compact_in (mtopology m) t /\ + mdiameter m t <= e)`, + GEN_TAC THEN EQ_TAC THENL + [(* Forward: compact + locally connected => covering *) + DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o MATCH_MP + COMPACT_IN_LOCALLY_CONNECTED_IMP_FCCOVERABLE_SPACE) THEN + REWRITE_TAC[fccoverable_space] THEN + MATCH_MP_TAC MONO_FORALL THEN X_GEN_TAC `e:real` THEN + DISCH_THEN(fun th -> DISCH_TAC THEN MP_TAC th) THEN + ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `c:(A->bool)->bool` THEN STRIP_TAC THEN + EXISTS_TAC `IMAGE (\s. mtopology m closure_of s) (c:(A->bool)->bool)` THEN + ASM_SIMP_TAC[FINITE_IMAGE; FORALL_IN_IMAGE] THEN CONJ_TAC THENL + [ASM_SIMP_TAC[GSYM SIMPLE_IMAGE; GSYM CLOSURE_OF_UNIONS; + CLOSURE_OF_EQ; HAUSDORFF_SPACE_MTOPOLOGY; + COMPACT_IN_IMP_CLOSED_IN; TOPSPACE_MTOPOLOGY]; + X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `s:A->bool`) THEN ASM_REWRITE_TAC[] THEN + STRIP_TAC THEN REPEAT CONJ_TAC THENL + [MATCH_MP_TAC CONNECTED_IN_CLOSURE_OF THEN ASM_REWRITE_TAC[]; + MATCH_MP_TAC CLOSED_IN_COMPACT_SPACE THEN + ASM_REWRITE_TAC[compact_space; TOPSPACE_MTOPOLOGY; + CLOSED_IN_CLOSURE_OF]; + ASM_SIMP_TAC[MDIAMETER_CLOSURE]]]; + (* Backward: covering => compact + locally connected *) + DISCH_TAC THEN CONJ_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `&1`) THEN REWRITE_TAC[REAL_LT_01] THEN + DISCH_THEN(X_CHOOSE_THEN `c:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `mspace m:A->bool = UNIONS c` SUBST1_TAC THENL + [ASM_REWRITE_TAC[]; + MATCH_MP_TAC COMPACT_IN_UNIONS THEN ASM_MESON_TAC[]]; + MATCH_MP_TAC FCCOVERABLE_SPACE_IMP_LOCALLY_CONNECTED_SPACE THEN + REWRITE_TAC[fccoverable_space] THEN X_GEN_TAC `e:real` THEN + DISCH_TAC THEN FIRST_X_ASSUM(MP_TAC o SPEC `e:real`) THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC MONO_EXISTS THEN GEN_TAC THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[COMPACT_IN_IMP_MBOUNDED]]]);; -let LOCALLY_PATH_CONNECTED_EUCLIDEAN_SPACE = prove - (`!n. locally_path_connected_space(euclidean_space n)`, - X_GEN_TAC `n:num` THEN - MP_TAC(SPEC `n:num` HOMEOMORPHIC_EUCLIDEAN_SPACE_PRODUCT_TOPOLOGY) THEN - DISCH_THEN(SUBST1_TAC o - MATCH_MP HOMEOMORPHIC_LOCALLY_PATH_CONNECTED_SPACE) THEN - REWRITE_TAC[LOCALLY_PATH_CONNECTED_SPACE_PRODUCT_TOPOLOGY] THEN - DISJ2_TAC THEN REWRITE_TAC[LOCALLY_PATH_CONNECTED_SPACE_EUCLIDEANREAL] THEN - SIMP_TAC[FINITE_NUMSEG; FINITE_RESTRICT]);; +(* ------------------------------------------------------------------------- *) +(* Localization of Property S (fccoverability). *) +(* Whyburn, Analytic Topology, Ch. I Sec. 15; H-Y exercises 3-6 to 3-9. *) +(* ------------------------------------------------------------------------- *) -let LOCALLY_CONNECTED_EUCLIDEAN_SPACE = prove - (`!n. locally_connected_space(euclidean_space n)`, - SIMP_TAC[LOCALLY_PATH_CONNECTED_EUCLIDEAN_SPACE; - LOCALLY_PATH_CONNECTED_IMP_LOCALLY_CONNECTED_SPACE]);; +(* Common chain construction for LOCALLY_FCCOVERABLE_SPACE *) +let LOCALLY_FCCOVERABLE_SPACE_CHAIN = prove + (`!m:A metric s u a r. + s SUBSET mspace m /\ a IN s /\ a IN mspace m /\ &0 < r /\ + s INTER mcball m (a, &2 * r) SUBSET u /\ + locally_connected_space (subtopology (mtopology m) s) /\ + (!e. &0 < e ==> ?c. FINITE c /\ + (!w. w IN c ==> w SUBSET s /\ + connected_in (mtopology m) w /\ + mbounded m w /\ mdiameter m w <= e) /\ + (!x. x IN s /\ x IN mball m (a, &2 * r) + ==> ?w. w IN c /\ x IN w)) + ==> ?v. open_in (subtopology (mtopology m) s) v /\ + connected_in (subtopology (mtopology m) s) v /\ + a IN v /\ v SUBSET u /\ fccoverable_in m v`, + let CHAIN_DISTANCE_BOUND = prove + (`!m:A metric s (a:A) r. a IN mspace m /\ s SUBSET mspace m /\ &0 < r + ==> !k x (f:num->A->bool). x IN mspace m /\ + (!i. i <= k ==> + connected_in (mtopology m) (f i) /\ + f i SUBSET s /\ + mbounded m (f i) /\ + mdiameter m (f i) < r / &2 pow i) /\ + a IN f 0 /\ x IN f k /\ + (!i. i < k ==> ~(f i INTER f(SUC i) = {})) + ==> mdist m (a,x) < (&2 - inv(&2 pow k)) * r`, + REPEAT GEN_TAC THEN STRIP_TAC THEN INDUCT_TAC THENL + [REWRITE_TAC[LE; LT; FORALL_UNWIND_THM2] THEN + REPEAT STRIP_TAC THEN + CONV_TAC REAL_RAT_REDUCE_CONV THEN + REWRITE_TAC[REAL_MUL_LID] THEN + TRANS_TAC REAL_LET_TRANS + `mdiameter m ((f:num->A->bool) 0)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN + ASM_REWRITE_TAC[]; + UNDISCH_TAC + `mdiameter m ((f:num->A->bool) 0) < r / &2 pow 0` THEN + REWRITE_TAC[real_pow; REAL_DIV_1]]; + X_GEN_TAC `c:A` THEN X_GEN_TAC `g:num->A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 (LABEL_TAC "gchain") + (CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 ASSUME_TAC + (LABEL_TAC "goverlap"))))) THEN + SUBGOAL_THEN + `~((g:num->A->bool) k INTER g(SUC k) = {})` MP_TAC THENL + [USE_THEN "goverlap" (MP_TAC o SPEC `k:num`) THEN + ANTS_TAC THENL [ARITH_TAC; SIMP_TAC[]]; + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER]] THEN + DISCH_THEN(X_CHOOSE_THEN `b:A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(b:A) IN mspace m` ASSUME_TAC THENL + [USE_THEN "gchain" (MP_TAC o SPEC `k:num`) THEN + REWRITE_TAC[ARITH_RULE `k <= SUC k`] THEN + ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + SUBGOAL_THEN + `mdist m (a:A,b) < (&2 - inv (&2 pow k)) * r` + ASSUME_TAC THENL + [FIRST_X_ASSUM + (MP_TAC o SPECL [`b:A`; `g:num->A->bool`]) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [X_GEN_TAC `j:num` THEN DISCH_TAC THEN + USE_THEN "gchain" (MP_TAC o SPEC `j:num`) THEN + ANTS_TAC THENL [ASM_ARITH_TAC; SIMP_TAC[]]; + X_GEN_TAC `j:num` THEN DISCH_TAC THEN + USE_THEN "goverlap" (MP_TAC o SPEC `j:num`) THEN + ANTS_TAC THENL [ASM_ARITH_TAC; SIMP_TAC[]]]; + SIMP_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN + `mdist m (b:A,c) < r / &2 pow (SUC k)` ASSUME_TAC THENL + [TRANS_TAC REAL_LET_TRANS + `mdiameter m ((g:num->A->bool) (SUC k))` THEN + USE_THEN "gchain" (MP_TAC o SPEC `SUC k`) THEN + REWRITE_TAC[LE_REFL] THEN STRIP_TAC THEN CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN + ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[]]; ALL_TAC] THEN + TRANS_TAC REAL_LET_TRANS + `mdist m (a:A,b) + mdist m (b,c)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC MDIST_TRIANGLE THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + TRANS_TAC REAL_LTE_TRANS + `(&2 - inv(&2 pow k)) * r + r / &2 pow (SUC k)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC REAL_LT_ADD2 THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[real_pow] THEN + MP_TAC(SPEC `k:num` REAL_LT_POW2) THEN + CONV_TAC REAL_FIELD]]) + and REAL_LT_DIV_POW2 = prove + (`!r a b. &0 < r /\ b < a + ==> r / &2 pow a < r / &2 pow b`, + REPEAT STRIP_TAC THEN REWRITE_TAC[real_div] THEN + ASM_SIMP_TAC[REAL_LT_LMUL_EQ] THEN + MATCH_MP_TAC REAL_LT_INV2 THEN + REWRITE_TAC[REAL_LT_POW2] THEN + MATCH_MP_TAC REAL_POW_MONO_LT THEN + CONV_TAC REAL_RAT_REDUCE_CONV THEN ASM_ARITH_TAC) + and REAL_DOUBLE_DIV_POW2 = prove + (`!r k. r / &2 pow (k + 3) + r / &2 pow (k + 3) = + r / &2 pow (k + 2)`, + REPEAT GEN_TAC THEN + REWRITE_TAC[ARITH_RULE `k + 3 = SUC(k + 2)`; real_pow] THEN + MATCH_MP_TAC(REAL_FIELD + `~(y = &0) + ==> x / (&2 * y) + x / (&2 * y) = x / y`) THEN + MP_TAC(SPEC `k + 2` REAL_LT_POW2) THEN REAL_ARITH_TAC) in + REPEAT GEN_TAC THEN REWRITE_TAC[IMP_CONJ] THEN + DISCH_TAC THEN DISCH_TAC THEN DISCH_TAC THEN + DISCH_TAC THEN DISCH_TAC THEN DISCH_TAC THEN + DISCH_THEN(LABEL_TAC "cover") THEN (* Define chain-reachable sets t(k) *) + ABBREV_TAC `t = \k. {x:A | x IN mspace m /\ + (?f. (!i. i <= k ==> connected_in (mtopology m) (f i) /\ (f i) SUBSET s /\ + mbounded m (f i) /\ mdiameter m (f i) < r / &2 pow i) /\ + a IN f 0 /\ x IN f k /\ + (!i. i < k ==> ~(f i INTER f(SUC i) = {})))}` THEN + EXISTS_TAC `UNIONS {(t:num->A->bool) k | k IN (:num)}` THEN + (* Key property: a IN t(k) for all k *) + SUBGOAL_THEN `!k. (a:A) IN (t:num->A->bool) k` ASSUME_TAC THENL + [X_GEN_TAC `k:num` THEN EXPAND_TAC "t" THEN + ASM_REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `\i:num. {a:A}` THEN + ASM_REWRITE_TAC[IN_SING; CONNECTED_IN_SING; TOPSPACE_MTOPOLOGY] THEN + CONJ_TAC THENL + [X_GEN_TAC `i:num` THEN DISCH_TAC THEN ASM_REWRITE_TAC[] THEN + REPEAT CONJ_TAC THENL [UNDISCH_TAC `(a:A) IN s` THEN SET_TAC[]; + ASM_REWRITE_TAC[MBOUNDED_INSERT; MBOUNDED_EMPTY]; + ASM_SIMP_TAC[MDIAMETER_SING; REAL_LT_DIV; REAL_LT_POW2]]; + REWRITE_TAC[INTER_IDEMPOT] THEN GEN_TAC THEN DISCH_TAC THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN EXISTS_TAC `a:A` THEN + REWRITE_TAC[IN_SING]]; ALL_TAC] THEN (* Key property: t(k) SUBSET s *) + SUBGOAL_THEN `!k. (t:num->A->bool) k SUBSET s` ASSUME_TAC THENL + [X_GEN_TAC `k:num` THEN EXPAND_TAC "t" THEN + REWRITE_TAC[IN_ELIM_THM; SUBSET] THEN X_GEN_TAC `x:A` THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + DISCH_THEN(X_CHOOSE_THEN `f:num->A->bool` + (CONJUNCTS_THEN2 (MP_TAC o SPEC `k:num`) STRIP_ASSUME_TAC)) THEN + REWRITE_TAC[LE_REFL] THEN + UNDISCH_TAC `(x:A) IN (f:num->A->bool) k` THEN SET_TAC[]; ALL_TAC] THEN + (* Key property: t(k) SUBSET mball(a, 2r) *) + SUBGOAL_THEN `!k. (t:num->A->bool) k SUBSET mball m (a:A, &2 * r)` + ASSUME_TAC THENL [X_GEN_TAC `k:num` THEN REWRITE_TAC[SUBSET; IN_MBALL] THEN + X_GEN_TAC `x':A` THEN EXPAND_TAC "t" THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `f':num->A->bool` STRIP_ASSUME_TAC)) THEN + ASM_REWRITE_TAC[] THEN + TRANS_TAC REAL_LTE_TRANS `(&2 - inv(&2 pow k)) * r` THEN CONJ_TAC THENL + [MP_TAC(ISPECL [`m:A metric`; `s:A->bool`; `a:A`; `r:real`] + CHAIN_DISTANCE_BOUND) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPECL [`k:num`; `x':A`; `f':num->A->bool`]) THEN + ASM_REWRITE_TAC[]; MATCH_MP_TAC REAL_LE_RMUL THEN + CONJ_TAC THENL [REWRITE_TAC[REAL_ARITH `x - y <= x <=> &0 <= y`] THEN + SIMP_TAC[REAL_LE_INV_EQ; REAL_POW_LE; REAL_POS]; + MATCH_MP_TAC REAL_LT_IMP_LE THEN ASM_REWRITE_TAC[]]]; ALL_TAC] THEN + (* Chain extension lemma *) + SUBGOAL_THEN `!k z c. (z:A) IN (t:num->A->bool) k /\ z IN c /\ + c SUBSET s /\ connected_in (mtopology m) c /\ + mbounded m c /\ mdiameter m c < r / &2 pow (SUC k) + ==> c SUBSET t(SUC k)` + (LABEL_TAC "extend") THENL [REPEAT GEN_TAC THEN STRIP_TAC THEN + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `x':A` THEN DISCH_TAC THEN + UNDISCH_TAC `(z:A) IN (t:num->A->bool) k` THEN + EXPAND_TAC "t" THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (X_CHOOSE_THEN `f':num->A->bool` + (CONJUNCTS_THEN2 (LABEL_TAC "fc") STRIP_ASSUME_TAC))) THEN + EXPAND_TAC "t" THEN REWRITE_TAC[IN_ELIM_THM] THEN + CONJ_TAC THENL [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + EXISTS_TAC `\i:num. if i <= k then (f':num->A->bool) i else c` THEN + ASM_REWRITE_TAC[LE_0; ARITH_RULE `~(SUC k <= k)`] THEN CONJ_TAC THENL + [X_GEN_TAC `i':num` THEN + ASM_CASES_TAC `i':num <= k` THEN ASM_REWRITE_TAC[] THENL + [DISCH_TAC THEN USE_THEN "fc" (MP_TAC o SPEC `i':num`) THEN + ASM_SIMP_TAC[]; DISCH_TAC THEN + SUBGOAL_THEN `i' = SUC k` SUBST_ALL_TAC THENL + [ASM_ARITH_TAC; ASM_REWRITE_TAC[]]]; + X_GEN_TAC `i':num` THEN DISCH_TAC THEN + SUBGOAL_THEN `i':num <= k` (fun th -> REWRITE_TAC[th]) THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + ASM_CASES_TAC `SUC i' <= k` THEN ASM_REWRITE_TAC[] THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; + SUBGOAL_THEN `i' = k:num` SUBST_ALL_TAC THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + EXISTS_TAC `z:A` THEN ASM_REWRITE_TAC[]]]; ALL_TAC] THEN + (* Key property: t(k) SUBSET t(SUC k) *) + SUBGOAL_THEN `!k. (t:num->A->bool) k SUBSET t(SUC k)` ASSUME_TAC THENL + [X_GEN_TAC `k':num` THEN REWRITE_TAC[SUBSET] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN mspace m /\ x IN s` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN REWRITE_TAC[GSYM SING_SUBSET] THEN + USE_THEN "extend" + (MP_TAC o SPECL [`k':num`; `x:A`; `{x:A}`]) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[IN_SING; SING_SUBSET] THEN + ASM_SIMP_TAC[CONNECTED_IN_SING; TOPSPACE_MTOPOLOGY; + MBOUNDED_INSERT; MBOUNDED_EMPTY; + MDIAMETER_SING; REAL_LT_DIV; REAL_LT_POW2]; SIMP_TAC[]]; + ALL_TAC] THEN (* Key property: t(k) is connected *) + SUBGOAL_THEN `!k. connected_in (mtopology m) ((t:num->A->bool) k)` + ASSUME_TAC THENL [X_GEN_TAC `k:num` THEN + REWRITE_TAC[CONNECTED_IN_IFF_CONNECTED_COMPONENT_OF] THEN CONJ_TAC THENL + [ASM_MESON_TAC[SUBSET_TRANS; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + MATCH_MP_TAC(MESON[CONNECTED_COMPONENT_OF_SYM; + CONNECTED_COMPONENT_OF_TRANS] + `!(a:A). (!x. x IN s ==> connected_component_of (subtopology top s) a x) + ==> (!x y. x IN s /\ y IN s + ==> connected_component_of (subtopology top s) x y)`) THEN + EXISTS_TAC `a:A` THEN SPEC_TAC(`k:num`,`k:num`) THEN + MATCH_MP_TAC num_INDUCTION THEN CONJ_TAC THENL [(* Base case: k = 0 *) + X_GEN_TAC `x:A` THEN EXPAND_TAC "t" THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `f:num->A->bool` STRIP_ASSUME_TAC)) THEN SUBGOAL_THEN + `connected_component_of + (subtopology (mtopology m) ((f:num->A->bool) 0)) (a:A) x` + MP_TAC THENL + [REWRITE_TAC[connected_component_of; CONNECTED_IN_SUBTOPOLOGY] THEN + EXISTS_TAC `(f:num->A->bool) 0` THEN + ASM_SIMP_TAC[LE_REFL; SUBSET_REFL]; ALL_TAC] THEN + MATCH_MP_TAC(MESON[CONNECTED_COMPONENT_OF_MONO] `(s:A->bool) SUBSET t + ==> connected_component_of (subtopology top s) a x + ==> connected_component_of (subtopology top t) a x`) THEN + EXPAND_TAC "t" THEN REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `c:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(c:A) IN mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET; LE_REFL]; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + EXISTS_TAC `f:num->A->bool` THEN ASM_REWRITE_TAC[GSYM SUBSET] THEN + CONJ_TAC THENL [ASM_MESON_TAC[LE_REFL]; ALL_TAC] THEN + REWRITE_TAC[LT] THEN MESON_TAC[]; ALL_TAC] THEN (* Inductive case *) + X_GEN_TAC `k':num` THEN DISCH_TAC THEN X_GEN_TAC `c:A` THEN DISCH_TAC THEN + (* Extract chain info from c IN t(SUC k') *) + SUBGOAL_THEN `(c:A) IN mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN SUBGOAL_THEN `?f:num->A->bool. + (!i. i <= SUC k' + ==> connected_in (mtopology m) (f i) /\ (f i) SUBSET s /\ + mbounded m (f i) /\ mdiameter m (f i) < r / &2 pow i) /\ + (a:A) IN f 0 /\ c IN f (SUC k') /\ + (!i. i < SUC k' ==> ~(f i INTER f (SUC i) = {}))` + (X_CHOOSE_THEN `f:num->A->bool` STRIP_ASSUME_TAC) THENL + [UNDISCH_TAC `(c:A) IN (t:num->A->bool) (SUC k')` THEN + EXPAND_TAC "t" THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(ACCEPT_TAC o CONJUNCT2); ALL_TAC] THEN (* Get bridge point *) + SUBGOAL_THEN `~((f:num->A->bool) k' INTER f(SUC k') = {})` MP_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ARITH_TAC; + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER]] THEN + DISCH_THEN(X_CHOOSE_THEN `b:A` STRIP_ASSUME_TAC) THEN + (* Show b IN t(k') to use IH *) + SUBGOAL_THEN `(b:A) IN (t:num->A->bool) k'` ASSUME_TAC THENL + [EXPAND_TAC "t" THEN REWRITE_TAC[IN_ELIM_THM] THEN CONJ_TAC THENL + [ASM_MESON_TAC[SUBSET; LE_REFL; + ARITH_RULE `k' <= SUC k'`]; ALL_TAC] THEN + EXISTS_TAC `f:num->A->bool` THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THEN GEN_TAC THEN DISCH_TAC THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; ALL_TAC] THEN + (* Apply IH to get connected_component_of ... a b *) + FIRST_X_ASSUM(MP_TAC o SPEC `b:A`) THEN ASM_REWRITE_TAC[] THEN + (* Lift from t(k') to t(SUC k') and bridge via f(SUC k') *) + MATCH_MP_TAC(MESON + [CONNECTED_COMPONENT_OF_MONO; CONNECTED_COMPONENT_OF_TRANS] + `(s:A->bool) SUBSET t' /\ connected_component_of (subtopology top t') b c + ==> connected_component_of (subtopology top s) a b + ==> connected_component_of (subtopology top t') a c`) THEN + ASM_REWRITE_TAC[connected_component_of; CONNECTED_IN_SUBTOPOLOGY] THEN + EXISTS_TAC `(f:num->A->bool) (SUC k')` THEN ASM_SIMP_TAC[LE_REFL] THEN + USE_THEN "extend" + (MP_TAC o SPECL [`k':num`; `b:A`; `(f:num->A->bool) (SUC k')`]) THEN + ANTS_TAC THENL [ASM_SIMP_TAC[LE_REFL]; SIMP_TAC[]]; ALL_TAC] THEN + (* Now prove the 5 conjuncts *) REPEAT CONJ_TAC THENL + [(* open_in (subtopology top s) (UNIONS {t k | k IN UNIV}) *) + ONCE_REWRITE_TAC[OPEN_IN_SUBOPEN] THEN + REWRITE_TAC[FORALL_IN_UNIONS; FORALL_IN_GSPEC; + IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN + X_GEN_TAC `k:num` THEN DISCH_THEN(K ALL_TAC) THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN (* x IN t(k), extract chain info *) + SUBGOAL_THEN `(x:A) IN s /\ x IN mspace m` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + (* Use locally connected space to get connected open neighborhood *) + MP_TAC(ASSUME + `locally_connected_space (subtopology (mtopology m) (s:A->bool))`) THEN + REWRITE_TAC[LOCALLY_CONNECTED_SPACE_ALT; NEIGHBOURHOOD_BASE_OF] THEN + DISCH_THEN(MP_TAC o SPECL + [`s INTER mball m (x:A, r / &2 pow (k + 3))`; `x:A`]) THEN ANTS_TAC THENL + [CONJ_TAC THENL [REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN + EXISTS_TAC `mball m (x:A, r / &2 pow (k + 3))` THEN + REWRITE_TAC[OPEN_IN_MBALL; INTER_COMM]; ALL_TAC] THEN + REWRITE_TAC[IN_INTER; IN_MBALL] THEN + ASM_SIMP_TAC[MDIST_REFL; REAL_LT_DIV; REAL_LT_POW2]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `u':A->bool` + (X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC)) THEN + EXISTS_TAC `u':A->bool` THEN ASM_REWRITE_TAC[] THEN + (* Show v SUBSET t(SUC k) via extend lemma *) + SUBGOAL_THEN `(v:A->bool) SUBSET (t:num->A->bool)(SUC k)` + ASSUME_TAC THENL [SUBGOAL_THEN + `connected_in (mtopology m) (v:A->bool) /\ v SUBSET s` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[CONNECTED_IN_SUBTOPOLOGY]; ALL_TAC] THEN + SUBGOAL_THEN `(v:A->bool) SUBSET mball m (x:A, r / &2 pow (k + 3))` + ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN USE_THEN "extend" + (MP_TAC o SPECL [`k:num`; `x:A`; `v:A->bool`]) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL [MATCH_MP_TAC MBOUNDED_SUBSET THEN + EXISTS_TAC `mball m (x:A, r / &2 pow (k + 3))` THEN + ASM_REWRITE_TAC[MBOUNDED_MBALL]; ALL_TAC] THEN + TRANS_TAC REAL_LET_TRANS `&2 * (r / &2 pow (k + 3))` THEN + CONJ_TAC THENL [MATCH_MP_TAC MDIAMETER_SUBSET_MBALL THEN + ASM_MESON_TAC[REAL_LT_DIV; REAL_LT_POW2; SUBSET]; + REWRITE_TAC[REAL_ARITH `&2 * x = x + x`; REAL_DOUBLE_DIV_POW2] THEN + REWRITE_TAC[ARITH_RULE `SUC k = k + 1`] THEN + MATCH_MP_TAC REAL_LT_DIV_POW2 THEN ASM_REWRITE_TAC[] THEN ARITH_TAC]; + SIMP_TAC[]]; ALL_TAC] THEN + REWRITE_TAC[SUBSET; IN_UNIONS] THEN X_GEN_TAC `y:A` THEN DISCH_TAC THEN + EXISTS_TAC `(t:num->A->bool)(SUC k)` THEN CONJ_TAC THENL + [REWRITE_TAC[IN_ELIM_THM; IN_UNIV] THEN EXISTS_TAC `SUC k` THEN REFL_TAC; + ASM SET_TAC[]]; + (* connected_in (subtopology top s) (UNIONS {t k | k IN UNIV}) *) + REWRITE_TAC[CONNECTED_IN_SUBTOPOLOGY] THEN CONJ_TAC THENL + [MATCH_MP_TAC CONNECTED_IN_UNIONS THEN CONJ_TAC THENL + [ASM_REWRITE_TAC[FORALL_IN_GSPEC; IN_UNIV]; + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; INTERS_GSPEC; IN_ELIM_THM] THEN + EXISTS_TAC `a:A` THEN ASM_REWRITE_TAC[IN_UNIV]]; + ASM_REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC; IN_UNIV]]; + (* a IN UNIONS {t k | k IN UNIV} *) + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `(t:num->A->bool) 0` THEN ASM_REWRITE_TAC[] THEN + EXISTS_TAC `0` THEN REWRITE_TAC[IN_UNIV]; + (* UNIONS {t k | k IN UNIV} SUBSET u *) + REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC; IN_UNIV] THEN + X_GEN_TAC `k:num` THEN + TRANS_TAC SUBSET_TRANS `s INTER mcball m (a:A, &2 * r)` THEN + ASM_REWRITE_TAC[SUBSET_INTER] THEN + TRANS_TAC SUBSET_TRANS `mball m (a:A, &2 * r)` THEN + ASM_REWRITE_TAC[MBALL_SUBSET_MCBALL]; + (* fccoverable_in m (UNIONS {t k | k IN UNIV}) *) + REWRITE_TAC[fccoverable_in] THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC; IN_UNIV] THEN + ASM_MESON_TAC[SUBSET_TRANS]; ALL_TAC] THEN + X_GEN_TAC `e:real` THEN DISCH_TAC THEN + SUBGOAL_THEN `?k:num. r / &2 pow k < e / &4` STRIP_ASSUME_TAC THENL + [REWRITE_TAC[ONCE_REWRITE_RULE[REAL_MUL_SYM] real_div] THEN + ASM_SIMP_TAC[REAL_INV_POW; GSYM REAL_LT_RDIV_EQ] THEN + MATCH_MP_TAC REAL_ARCH_POW_INV THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN + REWRITE_TAC[REAL_ARITH `&0 < (&1 / &4 * x) / y <=> &0 < x / y`] THEN + ASM_SIMP_TAC[REAL_LT_DIV]; ALL_TAC] THEN + (* Use cover hypothesis to get ws0 *) + USE_THEN "cover" (MP_TAC o SPEC `r / &2 pow (k + 2)`) THEN ANTS_TAC THENL + [ASM_SIMP_TAC[REAL_LT_DIV; REAL_LT_POW2]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `ws0:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + ABBREV_TAC + `ws = {w:A->bool | w IN ws0 /\ ~((t:num->A->bool) k INTER w = {})}` THEN + SUBGOAL_THEN `FINITE (ws:(A->bool)->bool)` ASSUME_TAC THENL + [EXPAND_TAC "ws" THEN MATCH_MP_TAC FINITE_RESTRICT THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `(t:num->A->bool) k SUBSET UNIONS ws` ASSUME_TAC THENL + [REWRITE_TAC[SUBSET] THEN X_GEN_TAC `y:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(y:A) IN s /\ y IN mball m (a:A, &2 * r)` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `y:A`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `w0:A->bool` STRIP_ASSUME_TAC) THEN + REWRITE_TAC[IN_UNIONS] THEN EXISTS_TAC `w0:A->bool` THEN + EXPAND_TAC "ws" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + EXISTS_TAC `y:A` THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN SUBGOAL_THEN + `!w:A->bool. w IN ws + ==> w SUBSET s /\ ~((t:num->A->bool) k INTER w = {}) /\ + connected_in (mtopology m) w /\ mbounded m w /\ + mdiameter m w <= r / &2 pow (k + 2)` + ASSUME_TAC THENL [X_GEN_TAC `w:A->bool` THEN EXPAND_TAC "ws" THEN + REWRITE_TAC[IN_ELIM_THM] THEN STRIP_TAC THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `!w:A->bool. w IN ws ==> w SUBSET (t:num->A->bool)(SUC k)` + ASSUME_TAC THENL [X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN SUBGOAL_THEN + `(w:A->bool) SUBSET s /\ ~((t:num->A->bool) k INTER w = {}) /\ + connected_in (mtopology m) w /\ mbounded m w /\ + mdiameter m w <= r / &2 pow (k + 2)` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `?b:A. b IN (t:num->A->bool) k /\ b IN w` + STRIP_ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN USE_THEN "extend" + (MP_TAC o SPECL [`k:num`; `b:A`; `w:A->bool`]) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN + TRANS_TAC REAL_LET_TRANS `r / &2 pow (k + 2)` THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LT_DIV_POW2 THEN + ASM_REWRITE_TAC[] THEN ARITH_TAC; SIMP_TAC[]]; ALL_TAC] THEN ABBREV_TAC + `q = \w:A->bool. {x:A | ?c. connected_in (mtopology m) c /\ + c SUBSET UNIONS {(t:num->A->bool) k | k IN (:num)} /\ + mbounded m c /\ mdiameter m c < e / &4 /\ + ~(w INTER c = {}) /\ x IN c}` THEN + EXISTS_TAC `IMAGE (q:(A->bool)->(A->bool)) ws` THEN CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL + [(* Coverage equality: UNIONS(IMAGE q ws) = UNIONS {t k | k IN UNIV} *) + REWRITE_TAC[GSYM SUBSET_ANTISYM_EQ; UNIONS_SUBSET] THEN + REWRITE_TAC[FORALL_IN_IMAGE; FORALL_IN_GSPEC] THEN CONJ_TAC THENL + [(* SUBSET direction: each q(w) SUBSET UNIONS {t k | k IN UNIV} *) + X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN EXPAND_TAC "q" THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN X_GEN_TAC `x:A` THEN + DISCH_THEN(X_CHOOSE_THEN `c:A->bool` STRIP_ASSUME_TAC) THEN + ASM SET_TAC[]; + (* SUPERSET direction: each t(n) SUBSET UNIONS(IMAGE q ws) *) + REWRITE_TAC[IN_UNIV] THEN X_GEN_TAC `n:num` THEN + DISJ_CASES_TAC(ARITH_RULE `n:num <= k \/ k < n`) THENL [(* n <= k *) + TRANS_TAC SUBSET_TRANS `(t:num->A->bool) k` THEN CONJ_TAC THENL + [UNDISCH_TAC `n:num <= k` THEN + MAP_EVERY (fun t -> SPEC_TAC(t,t)) [`k:num`; `n:num`] THEN + MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN + ASM_REWRITE_TAC[] THEN SET_TAC[]; + TRANS_TAC SUBSET_TRANS `UNIONS ws:A->bool` THEN + ASM_REWRITE_TAC[] THEN + GEN_REWRITE_TAC (LAND_CONV o RAND_CONV) [GSYM IMAGE_ID] THEN + MATCH_MP_TAC UNIONS_MONO_IMAGE THEN + X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN REWRITE_TAC[SUBSET] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + EXPAND_TAC "q" THEN REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `{x:A}` THEN + REWRITE_TAC[CONNECTED_IN_SING; TOPSPACE_MTOPOLOGY; + MBOUNDED_INSERT; MBOUNDED_EMPTY; IN_SING] THEN + SUBGOAL_THEN `(x:A) IN mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET; SUBSET_TRANS]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [REWRITE_TAC[SING_SUBSET; IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + EXISTS_TAC `(t:num->A->bool) (SUC k)` THEN + CONJ_TAC THENL [MESON_TAC[]; ASM_MESON_TAC[SUBSET]]; + ALL_TAC] THEN CONJ_TAC THENL + [ASM_SIMP_TAC[MDIAMETER_SING] THEN ASM_REAL_ARITH_TAC; + ASM SET_TAC[]]]; (* k < n *) + REWRITE_TAC[SUBSET] THEN EXPAND_TAC "t" THEN + REWRITE_TAC[IN_ELIM_THM] THEN X_GEN_TAC `x:A` THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `f:num->A->bool` STRIP_ASSUME_TAC)) THEN + REWRITE_TAC[UNIONS_IMAGE; IN_ELIM_THM] THEN + EXPAND_TAC "q" THEN REWRITE_TAC[IN_ELIM_THM] THEN + (* Bridge point b *) + SUBGOAL_THEN `?b:A. b IN (f:num->A->bool) k /\ b IN f(SUC k)` + STRIP_ASSUME_TAC THENL + [SUBGOAL_THEN `~((f:num->A->bool) k INTER f(SUC k) = {})` + MP_TAC THENL [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN MESON_TAC[]]; + ALL_TAC] THEN (* b in t(k) *) + SUBGOAL_THEN `(b:A) IN (t:num->A->bool) k` ASSUME_TAC THENL + [EXPAND_TAC "t" THEN REWRITE_TAC[IN_ELIM_THM] THEN CONJ_TAC THENL + [ASM_MESON_TAC[SUBSET; SUBSET_TRANS; LT_IMP_LE]; ALL_TAC] THEN + EXISTS_TAC `f:num->A->bool` THEN + ASM_MESON_TAC[LT_TRANS; LE_TRANS; LT_IMP_LE]; ALL_TAC] THEN + (* b in UNIONS ws, get w *) + SUBGOAL_THEN `(b:A) IN UNIONS ws` MP_TAC THENL + [ASM SET_TAC[]; REWRITE_TAC[IN_UNIONS]] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `w:A->bool` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN (* Connecting set *) + EXISTS_TAC `UNIONS (IMAGE (f:num->A->bool) (k+1..n))` THEN + REPEAT CONJ_TAC THENL [(* connected - by induction *) + SUBGOAL_THEN `!i. i <= n ==> connected_in (mtopology m) + (UNIONS(IMAGE (f:num->A->bool) (k+1..i)))` + (fun th -> SIMP_TAC[th; LE_REFL]) THEN + MATCH_MP_TAC num_INDUCTION THEN + SUBGOAL_THEN `k+1..0 = {}` SUBST1_TAC THENL + [REWRITE_TAC[NUMSEG_EMPTY] THEN ARITH_TAC; + REWRITE_TAC[IMAGE_CLAUSES; UNIONS_0; CONNECTED_IN_EMPTY]] THEN + X_GEN_TAC `j:num` THEN + DISCH_THEN(fun th -> DISCH_TAC THEN MP_TAC th) THEN + ANTS_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + ASM_CASES_TAC `j:num = k` THENL + [ASM_REWRITE_TAC[ADD1; NUMSEG_SING; IMAGE_CLAUSES; UNIONS_1] THEN + ASM_MESON_TAC[ADD1; LT_SUC_LE]; REWRITE_TAC[NUMSEG_CLAUSES] THEN + COND_CASES_TAC THEN REWRITE_TAC[] THEN DISCH_TAC THEN + REWRITE_TAC[IMAGE_CLAUSES; UNIONS_INSERT] THEN + MATCH_MP_TAC CONNECTED_IN_UNION THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[INTER_UNIONS; EMPTY_UNIONS; FORALL_IN_GSPEC] THEN + REWRITE_TAC[FORALL_IN_IMAGE; IN_NUMSEG] THEN + DISCH_THEN(MP_TAC o SPEC `j:num`) THEN + REWRITE_TAC[NOT_IMP] THEN CONJ_TAC THENL [ASM_ARITH_TAC; + ONCE_REWRITE_TAC[INTER_COMM] THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC]]; + (* subset of UNIONS {t j | j IN UNIV} *) MATCH_MP_TAC(SET_RULE + `(!x:num. x IN s0 ==> (ff:num->A->bool) x SUBSET gg x) /\ + s0 SUBSET (uu:num->bool) ==> UNIONS(IMAGE ff s0) SUBSET + UNIONS {gg x | x IN uu}`) THEN + REWRITE_TAC[IN_NUMSEG; SUBSET_UNIV] THEN + X_GEN_TAC `i:num` THEN STRIP_TAC THEN + REWRITE_TAC[SUBSET] THEN EXPAND_TAC "t" THEN + REWRITE_TAC[IN_ELIM_THM] THEN X_GEN_TAC `y:A` THEN DISCH_TAC THEN + CONJ_TAC THENL + [ASM_MESON_TAC[SUBSET; SUBSET_TRANS; LE_TRANS; LT_IMP_LE]; + ALL_TAC] THEN + EXISTS_TAC `f:num->A->bool` THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THEN GEN_TAC THEN DISCH_TAC THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; (* bounded *) + MATCH_MP_TAC MBOUNDED_UNIONS THEN CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN REWRITE_TAC[FINITE_NUMSEG]; + ALL_TAC] THEN REWRITE_TAC[FORALL_IN_IMAGE; IN_NUMSEG] THEN + ASM_MESON_TAC[]; (* diameter *) + SUBGOAL_THEN `!d j. j + d = n ==> mdiameter m + (UNIONS (IMAGE (f:num->A->bool) (j..n))) + < &2 * r / &2 pow j` + (MP_TAC o SPECL [`n - (k + 1)`; `k + 1`]) + THENL [ALL_TAC; ANTS_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ_ALT] REAL_LTE_TRANS) THEN + SUBGOAL_THEN `&2 * r / &2 pow (k + 1) = r / &2 pow k` + (fun th -> ASM_SIMP_TAC[th; REAL_LT_IMP_LE]) THEN + REWRITE_TAC[ARITH_RULE `k + 1 = SUC k`; CONJUNCT2 real_pow] THEN + SUBGOAL_THEN `~(&2 pow k = &0)` MP_TAC THENL + [REWRITE_TAC[REAL_POW_EQ_0] THEN REAL_ARITH_TAC; + CONV_TAC REAL_FIELD]] THEN MATCH_MP_TAC num_INDUCTION THEN + REWRITE_TAC[ADD_CLAUSES; FORALL_UNWIND_THM2] THEN + REWRITE_TAC[NUMSEG_SING; UNIONS_1; IMAGE_CLAUSES] THEN + CONJ_TAC THENL [MATCH_MP_TAC(REAL_ARITH + `&0 <= x /\ x < n ==> x < &2 * n`) THEN CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_POS_LE THEN ASM_MESON_TAC[LE_REFL]; + ASM_MESON_TAC[LE_REFL]]; ALL_TAC] THEN + X_GEN_TAC `d:num` THEN DISCH_THEN(LABEL_TAC "*") THEN + X_GEN_TAC `j:num` THEN DISCH_TAC THEN + SUBGOAL_THEN `j:num < n` ASSUME_TAC THENL [ASM_ARITH_TAC; + ASM_SIMP_TAC[LT_IMP_LE; GSYM NUMSEG_LREC]] THEN + REWRITE_TAC[IMAGE_CLAUSES; UNIONS_INSERT] THEN MP_TAC(ISPECL + [`m:A metric`; `(f:num->A->bool) j`; + `UNIONS(IMAGE (f:num->A->bool) ((j+1)..n))`] + MDIAMETER_UNION_LE) THEN ANTS_TAC THENL + [REPEAT CONJ_TAC THENL [ASM_MESON_TAC[LT_IMP_LE]; + MATCH_MP_TAC MBOUNDED_UNIONS THEN CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN REWRITE_TAC[FINITE_NUMSEG]; + REWRITE_TAC[FORALL_IN_IMAGE; IN_NUMSEG] THEN + ASM_MESON_TAC[LE_TRANS; LT_IMP_LE]]; + REWRITE_TAC[INTER_UNIONS; EMPTY_UNIONS; FORALL_IN_GSPEC] THEN + REWRITE_TAC[FORALL_IN_IMAGE; IN_NUMSEG] THEN + DISCH_THEN(MP_TAC o SPEC `SUC j`) THEN + REWRITE_TAC[NOT_IMP] THEN CONJ_TAC THENL [ASM_ARITH_TAC; + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC]]; + MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ_ALT] REAL_LET_TRANS)] THEN + REMOVE_THEN "*" (MP_TAC o SPEC `j + 1`) THEN + ANTS_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + MATCH_MP_TAC(REAL_ARITH `d1 < rj /\ &2 * rj' = rj + ==> d2 < &2 * rj' ==> d1 + d2 < &2 * rj`) THEN CONJ_TAC THENL + [ASM_MESON_TAC[LT_IMP_LE]; REWRITE_TAC[ARITH_RULE `j + 1 = SUC j`; + CONJUNCT2 real_pow] THEN + SUBGOAL_THEN `~(&2 pow j = &0)` MP_TAC THENL + [REWRITE_TAC[REAL_POW_EQ_0] THEN REAL_ARITH_TAC; + CONV_TAC REAL_FIELD]]; (* intersection with w *) + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN EXISTS_TAC `b:A` THEN + ASM_REWRITE_TAC[UNIONS_IMAGE; IN_ELIM_THM; + IN_NUMSEG; IN_INTER] THEN + EXISTS_TAC `SUC k` THEN ASM_REWRITE_TAC[] THEN ASM_ARITH_TAC; + (* x in connecting set *) + REWRITE_TAC[UNIONS_IMAGE; IN_ELIM_THM] THEN EXISTS_TAC `n:num` THEN + ASM_REWRITE_TAC[IN_NUMSEG] THEN ASM_ARITH_TAC]]]; ALL_TAC] THEN + REWRITE_TAC[FORALL_IN_IMAGE] THEN X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN + (* connected_in (mtopology m) (q w) *) + SUBGOAL_THEN `(w:A->bool) SUBSET s /\ ~((t:num->A->bool) k INTER w = {}) /\ + connected_in (mtopology m) w /\ mbounded m w /\ + mdiameter m w <= r / &2 pow (k + 2)` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(w:A->bool) SUBSET (q:(A->bool)->(A->bool)) w` + ASSUME_TAC THENL + [REWRITE_TAC[SUBSET] THEN X_GEN_TAC `y:A` THEN DISCH_TAC THEN + EXPAND_TAC "q" THEN REWRITE_TAC[IN_ELIM_THM] THEN EXISTS_TAC `{y:A}` THEN + REWRITE_TAC[CONNECTED_IN_SING; TOPSPACE_MTOPOLOGY; + MBOUNDED_INSERT; MBOUNDED_EMPTY; IN_SING] THEN + SUBGOAL_THEN `(y:A) IN mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET; SUBSET_TRANS]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [REWRITE_TAC[SING_SUBSET; IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + EXISTS_TAC `(t:num->A->bool) (SUC k)` THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ASM SET_TAC[]]; ALL_TAC] THEN + CONJ_TAC THENL [ASM_SIMP_TAC[MDIAMETER_SING] THEN ASM_REAL_ARITH_TAC; + ASM SET_TAC[]]; ALL_TAC] THEN SUBGOAL_THEN + `(q:(A->bool)->(A->bool)) w SUBSET + UNIONS {(t:num->A->bool) k | k IN (:num)}` + ASSUME_TAC THENL [EXPAND_TAC "q" THEN REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `z:A` THEN + DISCH_THEN(X_CHOOSE_THEN `c0:A->bool` STRIP_ASSUME_TAC) THEN + ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(q:(A->bool)->(A->bool)) w SUBSET mspace m` ASSUME_TAC THENL + [TRANS_TAC SUBSET_TRANS `UNIONS {(t:num->A->bool) k | k IN (:num)}` THEN + ASM_REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC; IN_UNIV] THEN + ASM_MESON_TAC[SUBSET_TRANS]; ALL_TAC] THEN + CONJ_TAC THENL [REWRITE_TAC[CONNECTED_IN_IFF_CONNECTED_COMPONENT_OF] THEN + ASM_REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN + SUBGOAL_THEN `?b:A. b IN w` STRIP_ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC(MESON[CONNECTED_COMPONENT_OF_SYM; + CONNECTED_COMPONENT_OF_TRANS] + `!a0:A. (!x0:A. x0 IN s0 ==> connected_component_of top0 a0 x0) + ==> (!x0 y0. x0 IN s0 /\ y0 IN s0 + ==> connected_component_of top0 x0 y0)`) THEN + EXISTS_TAC `b:A` THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN SUBGOAL_THEN + `?c:A->bool. connected_in (mtopology m) c /\ + c SUBSET UNIONS {(t:num->A->bool) k | k IN (:num)} /\ + mbounded m c /\ mdiameter m c < e / &4 /\ + ~((w:A->bool) INTER c = {}) /\ x:A IN c` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `x:A IN (q:(A->bool)->(A->bool)) w` THEN + EXPAND_TAC "q" THEN REWRITE_TAC[IN_ELIM_THM]; ALL_TAC] THEN + REWRITE_TAC[connected_component_of; CONNECTED_IN_SUBTOPOLOGY] THEN + EXISTS_TAC `w UNION c:A->bool` THEN CONJ_TAC THENL [CONJ_TAC THENL + [MATCH_MP_TAC CONNECTED_IN_UNION THEN ASM_REWRITE_TAC[] THEN + ASM SET_TAC[]; REWRITE_TAC[UNION_SUBSET] THEN CONJ_TAC THENL + [ASM_MESON_TAC[]; + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `z:A` THEN DISCH_TAC THEN + EXPAND_TAC "q" THEN REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `c:A->bool` THEN ASM_REWRITE_TAC[]]]; + ASM_REWRITE_TAC[IN_UNION]]; ALL_TAC] THEN + CONJ_TAC THENL [(* mbounded m (q w) *) + MATCH_MP_TAC MBOUNDED_SUBSET THEN EXISTS_TAC `mball m (a:A, &2 * r)` THEN + REWRITE_TAC[MBOUNDED_MBALL] THEN + TRANS_TAC SUBSET_TRANS `UNIONS {(t:num->A->bool) k | k IN (:num)}` THEN + ASM_REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC; IN_UNIV] THEN + ASM_MESON_TAC[]; (* mdiameter m (q w) <= e *) + MATCH_MP_TAC MDIAMETER_LE THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [DISJ2_TAC THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + MAP_EVERY X_GEN_TAC [`p1:A`; `p2:A`] THEN STRIP_TAC THEN SUBGOAL_THEN + `?c1:A->bool. connected_in (mtopology m) c1 /\ + c1 SUBSET UNIONS {(t:num->A->bool) k | k IN (:num)} /\ + mbounded m c1 /\ mdiameter m c1 < e / &4 /\ + ~((w:A->bool) INTER c1 = {}) /\ p1:A IN c1` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `p1:A IN (q:(A->bool)->(A->bool)) w` THEN + EXPAND_TAC "q" THEN REWRITE_TAC[IN_ELIM_THM]; ALL_TAC] THEN + SUBGOAL_THEN `?c2:A->bool. connected_in (mtopology m) c2 /\ + c2 SUBSET UNIONS {(t:num->A->bool) k | k IN (:num)} /\ + mbounded m c2 /\ mdiameter m c2 < e / &4 /\ + ~((w:A->bool) INTER c2 = {}) /\ p2:A IN c2` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `p2:A IN (q:(A->bool)->(A->bool)) w` THEN + EXPAND_TAC "q" THEN REWRITE_TAC[IN_ELIM_THM]; ALL_TAC] THEN + SUBGOAL_THEN + `(?z1:A. z1 IN w /\ z1 IN c1) /\ (?z2:A. z2 IN w /\ z2 IN c2)` + STRIP_ASSUME_TAC THENL [CONJ_TAC THEN ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `p1:A IN mspace m /\ p2 IN mspace m /\ z1 IN mspace m /\ z2 IN mspace m` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET; SUBSET_TRANS]; ALL_TAC] THEN SUBGOAL_THEN + `mdist m (p1:A, p2) <= mdist m (p1, z1) + mdist m (z1, p2) /\ + mdist m (z1:A, p2) <= mdist m (z1, z2) + mdist m (z2, p2)` + STRIP_ASSUME_TAC THENL + [CONJ_TAC THEN MATCH_MP_TAC MDIST_TRIANGLE THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN SUBGOAL_THEN `mdist m (p1:A, z1) <= mdiameter m c1 /\ + mdist m (z1:A, z2) <= mdiameter m w /\ + mdist m (z2:A, p2) <= mdiameter m c2` STRIP_ASSUME_TAC THENL + [REPEAT CONJ_TAC THEN MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `mdiameter m (w:A->bool) < e / &4` ASSUME_TAC THENL + [TRANS_TAC REAL_LET_TRANS `r / &2 pow (k + 2)` THEN + ASM_REWRITE_TAC[] THEN TRANS_TAC REAL_LT_TRANS `r / &2 pow k` THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LT_DIV_POW2 THEN + ASM_REWRITE_TAC[] THEN ARITH_TAC; ALL_TAC] THEN ASM_REAL_ARITH_TAC]]);; + +(* Helper: compact + locally connected implies fccoverable_in *) +let FCCOVERABLE_IN_COMPACT_LOCALLY_CONNECTED = prove + (`!m:A metric K. + compact_in (mtopology m) K /\ + locally_connected_space (subtopology (mtopology m) K) + ==> fccoverable_in m K`, + REPEAT STRIP_TAC THEN + SUBGOAL_THEN `(K:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[compact_in; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + ASM_REWRITE_TAC[fccoverable_in] THEN X_GEN_TAC `e:real` THEN DISCH_TAC THEN + MP_TAC(ISPEC `submetric m (K:A->bool)` + COMPACT_IN_LOCALLY_CONNECTED_IMP_FCCOVERABLE_SPACE) THEN ANTS_TAC THENL + [REWRITE_TAC[MTOPOLOGY_SUBMETRIC; SUBMETRIC] THEN ASM_SIMP_TAC[SET_RULE + `(K:A->bool) SUBSET s ==> K INTER s = K`] THEN + ASM_REWRITE_TAC[COMPACT_IN_SUBTOPOLOGY; SUBSET_REFL]; ALL_TAC] THEN + REWRITE_TAC[fccoverable_space; SUBMETRIC; MTOPOLOGY_SUBMETRIC] THEN + ASM_SIMP_TAC[SET_RULE `(K:A->bool) SUBSET s ==> K INTER s = K`] THEN + DISCH_THEN(MP_TAC o SPEC `e:real`) THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `c:(A->bool)->bool` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `t:A->bool` THEN DISCH_TAC THEN + SUBGOAL_THEN `(t:A->bool) SUBSET K` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `t:A->bool`) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[CONNECTED_IN_SUBTOPOLOGY; MBOUNDED_SUBMETRIC] THEN + ASM_SIMP_TAC[SET_RULE + `(t:A->bool) SUBSET K ==> K INTER t = t`] THEN STRIP_TAC THEN + RULE_ASSUM_TAC(REWRITE_RULE[MDIAMETER_SUBMETRIC]) THEN ASM_REWRITE_TAC[]);; + +let LOCALLY_FCCOVERABLE_SPACE = prove + (`!m:A metric s u a. + locally_compact_space (subtopology (mtopology m) s) /\ + locally_connected_space (subtopology (mtopology m) s) /\ + open_in (subtopology (mtopology m) s) u /\ a IN u + ==> ?v. open_in (subtopology (mtopology m) s) v /\ + connected_in (subtopology (mtopology m) s) v /\ + a IN v /\ v SUBSET u /\ fccoverable_in m v`, + REPEAT GEN_TAC THEN + (* Reduce to s SUBSET mspace m using SUBTOPOLOGY_RESTRICT *) + ONCE_REWRITE_TAC[SUBTOPOLOGY_RESTRICT] THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN + SUBGOAL_THEN `mspace m INTER (s:A->bool) SUBSET mspace m` + MP_TAC THENL [SET_TAC[]; ALL_TAC] THEN + SPEC_TAC(`mspace m INTER (s:A->bool)`, `s:A->bool`) THEN + X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN STRIP_TAC THEN + (* Step 1: Basic facts *) + SUBGOAL_THEN `(a:A) IN s /\ (a:A) IN mspace m` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; TOPSPACE_SUBTOPOLOGY; + TOPSPACE_MTOPOLOGY; SUBSET; IN_INTER]; ALL_TAC] THEN + (* Step 2: Get r > 0 with s INTER mcball(a,2r) compact and SUBSET u *) + SUBGOAL_THEN `?r. &0 < r /\ + compact_in (mtopology m) (s INTER mcball m (a:A, &2 * r)) /\ + s INTER mcball m (a, &2 * r) SUBSET u` + (X_CHOOSE_THEN `r:real` STRIP_ASSUME_TAC) THENL + [(* Use locally_compact neighbourhood base to get compact K, open V *) + MP_TAC(ISPEC `subtopology (mtopology m) (s:A->bool)` + LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE) THEN ANTS_TAC THENL + [DISJ1_TAC THEN MATCH_MP_TAC HAUSDORFF_SPACE_SUBTOPOLOGY THEN + REWRITE_TAC[HAUSDORFF_SPACE_MTOPOLOGY]; ALL_TAC] THEN + ASM_REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN + DISCH_THEN(MP_TAC o SPECL [`u:A->bool`; `a:A`]) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `V:A->bool` + (X_CHOOSE_THEN `K:A->bool` STRIP_ASSUME_TAC)) THEN + (* K compact in mtopology, K SUBSET s *) + SUBGOAL_THEN `compact_in (mtopology m) (K:A->bool) /\ K SUBSET s` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBTOPOLOGY]; ALL_TAC] THEN + SUBGOAL_THEN `(K:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[compact_in; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + (* V open in subtop s, get W open in mtopology with V = W INTER s *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [OPEN_IN_SUBTOPOLOGY]) THEN + DISCH_THEN(X_CHOOSE_THEN `W:A->bool` STRIP_ASSUME_TAC) THEN + (* Get e > 0 with mball(a,e) SUBSET W *) + MP_TAC(ISPECL [`m:A metric`; `W:A->bool`] OPEN_IN_MTOPOLOGY) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `a:A`)) THEN + ANTS_TAC THENL [UNDISCH_TAC `(a:A) IN V` THEN ASM SET_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `e:real` STRIP_ASSUME_TAC) THEN (* Take r = e/3 *) + EXISTS_TAC `e / &3` THEN CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + (* s INTER mcball(a, 2e/3) SUBSET K SUBSET u *) + SUBGOAL_THEN `mcball m (a:A, &2 * (e / &3)) SUBSET mball m (a,e)` + ASSUME_TAC THENL [MATCH_MP_TAC MCBALL_SUBSET_MBALL_CONCENTRIC THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `s INTER mcball m (a:A, &2 * (e / &3)) SUBSET K` + ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL [(* compact: closed subset of compact K *) + SUBGOAL_THEN `compact_in (subtopology (mtopology m) K) + (s INTER mcball m (a:A, &2 * (e / &3)))` + MP_TAC THENL [MATCH_MP_TAC(ISPEC `subtopology (mtopology m) (K:A->bool)` + CLOSED_IN_COMPACT_SPACE) THEN CONJ_TAC THENL + [ASM_MESON_TAC[COMPACT_SPACE_SUBTOPOLOGY]; ALL_TAC] THEN + REWRITE_TAC[CLOSED_IN_SUBTOPOLOGY] THEN + EXISTS_TAC `mcball m (a:A, &2 * (e / &3))` THEN + REWRITE_TAC[CLOSED_IN_MCBALL] THEN ASM SET_TAC[]; + SIMP_TAC[COMPACT_IN_SUBTOPOLOGY]]; (* SUBSET u *) + ASM SET_TAC[]]; ALL_TAC] THEN (* Apply LOCALLY_FCCOVERABLE_SPACE_CHAIN *) + MATCH_MP_TAC LOCALLY_FCCOVERABLE_SPACE_CHAIN THEN + EXISTS_TAC `r:real` THEN ASM_REWRITE_TAC[] THEN + (* Prove cover hypothesis from locally_connected + compactness *) + X_GEN_TAC `e0:real` THEN DISCH_TAC THEN + (* For each x in s, get connected neighborhood of size e0/2 *) MP_TAC(ASSUME + `locally_connected_space (subtopology (mtopology m) (s:A->bool))`) THEN + REWRITE_TAC[LOCALLY_CONNECTED_SPACE_ALT; NEIGHBOURHOOD_BASE_OF] THEN + DISCH_TAC THEN SUBGOAL_THEN `!x:A. x IN s + ==> ?u' v. open_in (subtopology (mtopology m) s) u' /\ + connected_in (subtopology (mtopology m) s) v /\ + x IN u' /\ u' SUBSET v /\ + v SUBSET s INTER mball m (x, e0 / &2)` + MP_TAC THENL [X_GEN_TAC `x:A` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL + [`s INTER mball m (x:A, e0 / &2)`; `x:A`]) THEN ANTS_TAC THENL + [CONJ_TAC THENL [REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN + EXISTS_TAC `mball m (x:A, e0 / &2)` THEN + REWRITE_TAC[OPEN_IN_MBALL; INTER_COMM]; ALL_TAC] THEN + REWRITE_TAC[IN_INTER; IN_MBALL] THEN + SUBGOAL_THEN `(x:A) IN mspace m` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + ASM_SIMP_TAC[MDIST_REFL] THEN ASM_REAL_ARITH_TAC; + REPEAT(MATCH_MP_TAC MONO_EXISTS THEN GEN_TAC) THEN SIMP_TAC[]]; + ALL_TAC] THEN + GEN_REWRITE_TAC (LAND_CONV o REDEPTH_CONV) [RIGHT_IMP_EXISTS_THM] THEN + REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`uf:A->A->bool`; `vf:A->A->bool`] THEN DISCH_TAC THEN + (* Apply compactness of s INTER mcball(a, 2r) *) SUBGOAL_THEN + `compact_in (subtopology (mtopology m) s) (s INTER mcball m (a:A, &2 * r))` + MP_TAC THENL [REWRITE_TAC[COMPACT_IN_SUBTOPOLOGY] THEN + ASM_REWRITE_TAC[INTER_SUBSET]; ALL_TAC] THEN + GEN_REWRITE_TAC LAND_CONV [compact_in] THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; TOPSPACE_MTOPOLOGY] THEN + SUBGOAL_THEN `mspace m INTER (s:A->bool) = s` + (fun th -> REWRITE_TAC[th]) THENL [ASM SET_TAC[]; ALL_TAC] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC + `IMAGE (uf:A->A->bool) (s INTER mcball m (a:A, &2 * r))`)) THEN + ANTS_TAC THENL [CONJ_TAC THENL [REWRITE_TAC[FORALL_IN_IMAGE] THEN + X_GEN_TAC `x:A` THEN REWRITE_TAC[IN_INTER] THEN + STRIP_TAC THEN ASM_MESON_TAC[]; + REWRITE_TAC[SUBSET; UNIONS_IMAGE; IN_ELIM_THM; IN_INTER] THEN + X_GEN_TAC `x:A` THEN STRIP_TAC THEN + EXISTS_TAC `x:A` THEN ASM_REWRITE_TAC[IN_INTER] THEN ASM_MESON_TAC[]]; + ALL_TAC] THEN REWRITE_TAC[EXISTS_FINITE_SUBSET_IMAGE] THEN + DISCH_THEN(X_CHOOSE_THEN `pts:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `IMAGE (vf:A->A->bool) pts` THEN + ASM_SIMP_TAC[FINITE_IMAGE] THEN CONJ_TAC THENL + [(* Properties of each piece *) + REWRITE_TAC[FORALL_IN_IMAGE] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN s` ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `connected_in (subtopology (mtopology m) s) ((vf:A->A->bool) x) /\ + vf x SUBSET s INTER mball m (x:A, e0 / &2)` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + REPEAT CONJ_TAC THENL [ASM SET_TAC[]; + ASM_MESON_TAC[CONNECTED_IN_SUBTOPOLOGY]; + MATCH_MP_TAC MBOUNDED_SUBSET THEN + EXISTS_TAC `mball m (x:A, e0 / &2)` THEN + REWRITE_TAC[MBOUNDED_MBALL] THEN ASM SET_TAC[]; + TRANS_TAC REAL_LE_TRANS `&2 * (e0 / &2)` THEN CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_SUBSET_MBALL THEN + ASM_MESON_TAC[REAL_ARITH `&0 < e ==> &0 < e / &2`; + SUBSET; INTER_SUBSET; SUBSET_TRANS]; REAL_ARITH_TAC]]; + (* Coverage of s INTER mball(a, 2r) *) X_GEN_TAC `x:A` THEN STRIP_TAC THEN + (* x IN s INTER mcball(a,2r) since mball SUBSET mcball *) + SUBGOAL_THEN `(x:A) IN s INTER mcball m (a:A, &2 * r)` ASSUME_TAC THENL + [ASM_REWRITE_TAC[IN_INTER] THEN + ASM_MESON_TAC[MBALL_SUBSET_MCBALL; SUBSET]; ALL_TAC] THEN + (* x is covered by UNIONS(IMAGE uf pts) *) + SUBGOAL_THEN `(x:A) IN UNIONS(IMAGE (uf:A->A->bool) pts)` MP_TAC THENL + [ASM SET_TAC[]; REWRITE_TAC[UNIONS_IMAGE; IN_ELIM_THM]] THEN + DISCH_THEN(X_CHOOSE_THEN `y:A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(vf:A->A->bool) y` THEN ASM_REWRITE_TAC[FUN_IN_IMAGE] THEN + SUBGOAL_THEN `(y:A) IN s` ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(uf:A->A->bool) y SUBSET (vf:A->A->bool) y` + MP_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN ASM SET_TAC[]]);; + +let LOCALLY_CONNECTED_CONTINUUM_SPACE = prove + (`!m:A metric s. + neighbourhood_base_of + (\c. compact_in (subtopology (mtopology m) s) c /\ + connected_in (subtopology (mtopology m) s) c /\ + locally_connected_space (subtopology (mtopology m) c)) + (subtopology (mtopology m) s) <=> + locally_compact_space (subtopology (mtopology m) s) /\ + locally_connected_space (subtopology (mtopology m) s)`, + REPEAT GEN_TAC THEN EQ_TAC THENL + [(* => direction: extract locally_compact and locally_connected *) + STRIP_TAC THEN CONJ_TAC THENL + [MP_TAC(ISPEC `subtopology (mtopology m) (s:A->bool)` + LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE) THEN + ASM_SIMP_TAC[HAUSDORFF_SPACE_SUBTOPOLOGY; HAUSDORFF_SPACE_MTOPOLOGY] THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]); + REWRITE_TAC[locally_connected_space]] THEN + FIRST_ASSUM(fun th -> MATCH_MP_TAC(MATCH_MP + (REWRITE_RULE[IMP_CONJ_ALT] NEIGHBOURHOOD_BASE_OF_MONO) th)) THEN + SIMP_TAC[]; (* <= direction *) + STRIP_TAC THEN GEN_REWRITE_TAC I [NEIGHBOURHOOD_BASE_OF] THEN + MAP_EVERY X_GEN_TAC [`w:A->bool`; `x:A`] THEN STRIP_TAC THEN SUBGOAL_THEN + `?v k:A->bool. open_in (subtopology (mtopology m) s) v /\ + compact_in (subtopology (mtopology m) s) k /\ + x IN v /\ v SUBSET k /\ k SUBSET w` + STRIP_ASSUME_TAC THENL + [MP_TAC(ISPEC `subtopology (mtopology m) (s:A->bool)` + LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE) THEN ANTS_TAC THENL + [ASM_MESON_TAC[HAUSDORFF_SPACE_SUBTOPOLOGY; HAUSDORFF_SPACE_MTOPOLOGY]; + ASM_REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN + DISCH_THEN(MP_TAC o SPECL [`w:A->bool`; `x:A`]) THEN + ASM_REWRITE_TAC[] THEN + REPEAT(MATCH_MP_TAC MONO_EXISTS THEN GEN_TAC) THEN SIMP_TAC[]]; + ALL_TAC] THEN MP_TAC(ISPECL + [`m:A metric`; `s:A->bool`; `v:A->bool`; `x:A`] + LOCALLY_FCCOVERABLE_SPACE) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `w':A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `w':A->bool` THEN + EXISTS_TAC `mtopology m closure_of w':A->bool` THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN + `compact_in (mtopology m) (k:A->bool) /\ (k:A->bool) SUBSET s /\ + (w':A->bool) SUBSET mspace m` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBTOPOLOGY; fccoverable_in]; ALL_TAC] THEN + SUBGOAL_THEN `(mtopology m closure_of w':A->bool) SUBSET k` + ASSUME_TAC THENL [MATCH_MP_TAC CLOSURE_OF_MINIMAL THEN CONJ_TAC THENL + [ASM SET_TAC[]; MATCH_MP_TAC COMPACT_IN_IMP_CLOSED_IN THEN + ASM_REWRITE_TAC[HAUSDORFF_SPACE_MTOPOLOGY]]; ALL_TAC] THEN + CONJ_TAC THENL [REPEAT CONJ_TAC THENL + [REWRITE_TAC[COMPACT_IN_SUBTOPOLOGY] THEN CONJ_TAC THENL + [MATCH_MP_TAC CLOSED_COMPACT_IN THEN EXISTS_TAC `k:A->bool` THEN + ASM_REWRITE_TAC[CLOSED_IN_CLOSURE_OF]; ASM SET_TAC[]]; + REWRITE_TAC[CONNECTED_IN_SUBTOPOLOGY] THEN CONJ_TAC THENL + [MATCH_MP_TAC CONNECTED_IN_CLOSURE_OF THEN + ASM_MESON_TAC[CONNECTED_IN_SUBTOPOLOGY]; ASM SET_TAC[]]; + MATCH_MP_TAC FCCOVERABLE_IN_IMP_LOCALLY_CONNECTED_SPACE THEN + MP_TAC(ISPECL + [`m:A metric`; `w':A->bool`; `mtopology m closure_of w':A->bool`] + FCCOVERABLE_SPACE_INTERMEDIATE_CLOSURE) THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[SUBSET_REFL] THEN + MATCH_MP_TAC CLOSURE_OF_SUBSET THEN + ASM_REWRITE_TAC[TOPSPACE_MTOPOLOGY]]; CONJ_TAC THENL + [MATCH_MP_TAC CLOSURE_OF_SUBSET THEN + ASM_REWRITE_TAC[TOPSPACE_MTOPOLOGY]; ASM SET_TAC[]]]]);; -let HAUSDORFF_EUCLIDEAN_SPACE = prove - (`!n. hausdorff_space (euclidean_space n)`, - GEN_TAC THEN REWRITE_TAC[euclidean_space] THEN - MATCH_MP_TAC HAUSDORFF_SPACE_SUBTOPOLOGY THEN - REWRITE_TAC[HAUSDORFF_SPACE_PRODUCT_TOPOLOGY; - HAUSDORFF_SPACE_EUCLIDEANREAL]);; +let COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE_ALT = prove + (`!m:A metric. + compact_in (mtopology m) (mspace m) /\ + locally_connected_space (mtopology m) <=> + (!e. &0 < e + ==> ?c. FINITE c /\ UNIONS c = mspace m /\ + !t. t IN c + ==> connected_in (mtopology m) t /\ + compact_in (mtopology m) t /\ + locally_connected_space + (subtopology (mtopology m) t) /\ + mdiameter m t <= e)`, + GEN_TAC THEN EQ_TAC THENL + [(* Forward direction - use LOCALLY_CONNECTED_CONTINUUM_SPACE + compactness *) + STRIP_TAC THEN X_GEN_TAC `e:real` THEN DISCH_TAC THEN + (* Get neighbourhood base from LOCALLY_CONNECTED_CONTINUUM_SPACE *) + MP_TAC(ISPECL [`m:A metric`; `mspace m:A->bool`] + LOCALLY_CONNECTED_CONTINUUM_SPACE) THEN REWRITE_TAC[SUBTOPOLOGY_MSPACE] THEN + DISCH_THEN(MP_TAC o snd o EQ_IMP_RULE) THEN ANTS_TAC THENL + [CONJ_TAC THENL [MATCH_MP_TAC COMPACT_IMP_LOCALLY_COMPACT_SPACE THEN + ASM_REWRITE_TAC[compact_space; TOPSPACE_MTOPOLOGY]; ASM_REWRITE_TAC[]]; + ALL_TAC] THEN REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN DISCH_TAC THEN + (* For each x, get P-set in mball(x, e/2) *) + SUBGOAL_THEN `!x:A. x IN mspace m ==> ?u v. open_in (mtopology m) u /\ + compact_in (mtopology m) v /\ + connected_in (mtopology m) v /\ locally_connected_space + (subtopology (mtopology m) v) /\ + x IN u /\ u SUBSET v /\ v SUBSET mball m (x, e / &2)` + MP_TAC THENL [X_GEN_TAC `x:A` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`mball m (x:A, e / &2)`; `x:A`]) THEN + ASM_SIMP_TAC[OPEN_IN_MBALL; CENTRE_IN_MBALL; REAL_HALF] THEN + REPEAT(MATCH_MP_TAC MONO_EXISTS THEN GEN_TAC) THEN SIMP_TAC[]; + ALL_TAC] THEN + GEN_REWRITE_TAC (LAND_CONV o REDEPTH_CONV) [RIGHT_IMP_EXISTS_THM] THEN + REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`uf:A->A->bool`; `vf:A->A->bool`] THEN DISCH_TAC THEN + (* Apply compactness to the open cover {uf(x) | x in mspace m} *) + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [compact_in]) THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPEC `IMAGE (uf:A->A->bool) (mspace m)`)) THEN ANTS_TAC THENL + [REWRITE_TAC[FORALL_IN_IMAGE; SUBSET; UNIONS_IMAGE; IN_ELIM_THM] THEN + ASM_MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[EXISTS_FINITE_SUBSET_IMAGE] THEN + DISCH_THEN(X_CHOOSE_THEN `pts:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `IMAGE (vf:A->A->bool) pts` THEN ASM_SIMP_TAC[FINITE_IMAGE] THEN + (* Extract useful facts for x in pts *) SUBGOAL_THEN `!x:A. x IN pts + ==> compact_in (mtopology m) ((vf:A->A->bool) x) /\ + connected_in (mtopology m) (vf x) /\ + locally_connected_space (subtopology (mtopology m) (vf x)) /\ + vf x SUBSET mball m (x, e / &2) /\ uf x SUBSET vf x` + ASSUME_TAC THENL [X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN mspace m` ASSUME_TAC THENL + [ASM SET_TAC[]; ASM_MESON_TAC[]]; ALL_TAC] THEN + CONJ_TAC THENL [(* UNIONS(IMAGE vf pts) = mspace m *) + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_IMAGE] THEN + ASM_MESON_TAC[SUBSET_TRANS; MBALL_SUBSET_MSPACE]; + FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP + (REWRITE_RULE[IMP_CONJ] SUBSET_TRANS)) THEN + REWRITE_TAC[UNIONS_IMAGE; SUBSET; IN_ELIM_THM] THEN + ASM_MESON_TAC[SUBSET]]; (* Properties of each piece *) + REWRITE_TAC[FORALL_IN_IMAGE] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + REPEAT CONJ_TAC THEN TRY(ASM_MESON_TAC[]) THEN + (* mdiameter m (vf x) <= e *) + MATCH_MP_TAC(REAL_ARITH `x <= &2 * (e / &2) ==> x <= e`) THEN + MATCH_MP_TAC MDIAMETER_SUBSET_MBALL THEN + ASM_MESON_TAC[REAL_HALF; SUBSET]]; + (* Backward direction - drop locally_connected_space condition *) + REWRITE_TAC[COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE] THEN + MESON_TAC[]]);; -let COMPACT_EUCLIDEAN_SPACE = prove - (`!n. compact_space(euclidean_space n) <=> n = 0`, - X_GEN_TAC `n:num` THEN - MP_TAC(SPEC `n:num` HOMEOMORPHIC_EUCLIDEAN_SPACE_PRODUCT_TOPOLOGY) THEN - DISCH_THEN(SUBST1_TAC o MATCH_MP HOMEOMORPHIC_COMPACT_SPACE) THEN - REWRITE_TAC[COMPACT_SPACE_PRODUCT_TOPOLOGY] THEN - REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; CARTESIAN_PRODUCT_EQ_EMPTY] THEN - REWRITE_TAC[NOT_COMPACT_SPACE_EUCLIDEANREAL] THEN - REWRITE_TAC[o_DEF; TOPSPACE_EUCLIDEANREAL; UNIV_NOT_EMPTY] THEN - REWRITE_TAC[GSYM NOT_EXISTS_THM; MEMBER_NOT_EMPTY] THEN - REWRITE_TAC[NUMSEG_EMPTY] THEN ARITH_TAC);; +(* ------------------------------------------------------------------------- *) +(* Compact locally connected spaces have finitely many connected components *) +(* ------------------------------------------------------------------------- *) -let nsphere = new_definition - `nsphere n = subtopology (euclidean_space (n + 1)) - { x | sum(1..n+1) (\i. x i pow 2) = &1 }`;; +let FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED = prove + (`!m:A metric. + compact_in (mtopology m) (mspace m) /\ + locally_connected_space (mtopology m) + ==> FINITE(connected_components_of(mtopology m))`, + GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN `compact_space(mtopology m:A topology)` MP_TAC THENL + [ASM_REWRITE_TAC[compact_space; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + REWRITE_TAC[COMPACT_SPACE_ALT; TOPSPACE_MTOPOLOGY] THEN DISCH_THEN(MP_TAC o + SPEC `connected_components_of(mtopology m:A topology)`) THEN ANTS_TAC THENL + [CONJ_TAC THENL [GEN_TAC THEN DISCH_TAC THEN MATCH_MP_TAC + OPEN_IN_CONNECTED_COMPONENTS_OF_LOCALLY_CONNECTED_SPACE THEN + ASM_REWRITE_TAC[]; REWRITE_TAC[UNIONS_CONNECTED_COMPONENTS_OF; + TOPSPACE_MTOPOLOGY; SUBSET_REFL]]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `V:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + MATCH_MP_TAC FINITE_SUBSET THEN EXISTS_TAC `V:(A->bool)->bool` THEN + ASM_REWRITE_TAC[SUBSET] THEN X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o MATCH_MP NONEMPTY_CONNECTED_COMPONENTS_OF) THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN DISCH_THEN(X_CHOOSE_TAC `x:A`) THEN + FIRST_ASSUM(MP_TAC o MATCH_MP CONNECTED_COMPONENTS_OF_SUBSET) THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN UNIONS V` MP_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `d:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `d IN connected_components_of(mtopology m:A topology)` + ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `c:A->bool = d` (fun th -> ASM_REWRITE_TAC[th]) THEN + MP_TAC(ISPECL [`mtopology m:A topology`; `c:A->bool`; `d:A->bool`] + CONNECTED_COMPONENTS_OF_OVERLAP) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(fun th -> REWRITE_TAC[GSYM th]) THEN ASM SET_TAC[]);; -let NSPHERE = prove - (`!n. nsphere n = subtopology (product_topology (:num) (\i. euclideanreal)) - {x | sum(1..n+1) (\i. x i pow 2) = &1 /\ - !i. ~(i IN 1..n+1) ==> x i = &0}`, - REWRITE_TAC[nsphere; euclidean_space; SUBTOPOLOGY_SUBTOPOLOGY] THEN - GEN_TAC THEN AP_TERM_TAC THEN SET_TAC[]);; +(* ------------------------------------------------------------------------- *) +(* Semi-locally connected spaces (finitely many components in complements). *) +(* Whyburn, Analytic Topology, Ch. I Sec. 13. *) +(* ------------------------------------------------------------------------- *) -let NONEMPTY_NSPHERE = prove - (`!n. ~(topspace(nsphere n) = {})`, - GEN_TAC THEN REWRITE_TAC[nsphere; GSYM MEMBER_NOT_EMPTY] THEN - EXISTS_TAC `(\n. if n = 1 then &1 else &0):num->real` THEN - REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; TOPSPACE_EUCLIDEAN_SPACE] THEN - REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN CONJ_TAC THENL - [GEN_TAC THEN COND_CASES_TAC THEN ASM_REWRITE_TAC[IN_NUMSEG] THEN ARITH_TAC; - ONCE_REWRITE_TAC[COND_RAND] THEN ONCE_REWRITE_TAC[COND_RATOR] THEN - CONV_TAC REAL_RAT_REDUCE_CONV THEN REWRITE_TAC[SUM_DELTA] THEN - REWRITE_TAC[IN_NUMSEG; ARITH_RULE `1 <= 1 /\ 1 <= n + 1`]]);; +(* Helper lemma for SEMI_LOCALLY_CONNECTED_GEN_SPACE finiteness argument *) +let FINITE_CONNECTED_COMPONENTS_CLOPEN_UNION = prove + (`!top C s:A->bool. + locally_connected_space top /\ + open_in top C /\ closed_in top C /\ C SUBSET topspace top /\ + s SUBSET C /\ FINITE(connected_components_of top) /\ + FINITE(connected_components_of (subtopology top (C DIFF s))) + ==> FINITE(connected_components_of + (subtopology top (topspace top DIFF s)))`, + REPEAT STRIP_TAC THEN MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `connected_components_of(subtopology top (C DIFF s)) UNION + {d:A->bool | d IN connected_components_of top /\ + DISJOINT d C}` THEN CONJ_TAC THENL + [ASM_REWRITE_TAC[FINITE_UNION] THEN MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `connected_components_of (top:A topology)` THEN + ASM_REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[SUBSET; IN_UNION; IN_ELIM_THM] THEN + X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN + SUBGOAL_THEN `connected_in (top:A topology) c` ASSUME_TAC THENL + [FIRST_ASSUM(MP_TAC o MATCH_MP CONNECTED_IN_CONNECTED_COMPONENTS_OF) THEN + REWRITE_TAC[CONNECTED_IN_SUBTOPOLOGY] THEN MESON_TAC[]; ALL_TAC] THEN + FIRST_ASSUM(MP_TAC o MATCH_MP NONEMPTY_CONNECTED_COMPONENTS_OF) THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN DISCH_THEN(X_CHOOSE_TAC `x:A`) THEN + MP_TAC(ISPECL [`top:A topology`; `c:A->bool`; `C:A->bool`] + CONNECTED_IN_CLOPEN_CASES) THEN ASM_REWRITE_TAC[] THEN STRIP_TAC THENL + [(* Case 1: c SUBSET C *) DISJ1_TAC THEN + (* c SUBSET C, c SUBSET topspace\s DIFF s => c SUBSET C DIFF s *) + SUBGOAL_THEN `(c:A->bool) SUBSET C DIFF s` ASSUME_TAC THENL + [FIRST_ASSUM(MP_TAC o MATCH_MP CONNECTED_COMPONENTS_OF_SUBSET) THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY] THEN ASM SET_TAC[]; ALL_TAC] THEN + (* c is connected in subtopology top (C DIFF s) *) + SUBGOAL_THEN `connected_in (subtopology top (C DIFF s)) (c:A->bool)` + ASSUME_TAC THENL [ASM_REWRITE_TAC[CONNECTED_IN_SUBTOPOLOGY]; + ALL_TAC] THEN (* c is maximal in subtopology top (C DIFF s) *) + REWRITE_TAC[connected_components_of; IN_ELIM_THM] THEN + FIRST_ASSUM(MP_TAC o MATCH_MP NONEMPTY_CONNECTED_COMPONENTS_OF) THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; TOPSPACE_SUBTOPOLOGY] THEN + DISCH_THEN(X_CHOOSE_TAC `y:A`) THEN EXISTS_TAC `y:A` THEN + SUBGOAL_THEN `(y:A) IN topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[connected_in; SUBSET]; ALL_TAC] THEN + CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[SUBSET; IN; connected_component_of] THEN + X_GEN_TAC `z:A` THEN STRIP_TAC THEN + (* z IN c; need connected_component_of ... y z *) + (* Use the connected set c containing both y and z *) + EXISTS_TAC `c:A->bool` THEN ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + (* connected_component_of (subtopology top (C DIFF s)) y SUBSET c *) + REWRITE_TAC[SUBSET; IN; connected_component_of] THEN X_GEN_TAC `z:A` THEN + DISCH_THEN(X_CHOOSE_THEN `t:A->bool` STRIP_ASSUME_TAC) THEN + (* Promote connected_in from C DIFF s to topspace top DIFF s *) + SUBGOAL_THEN `connected_in (subtopology top (topspace top DIFF s)) + (t:A->bool)` ASSUME_TAC THENL [FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [CONNECTED_IN_SUBTOPOLOGY]) THEN + REWRITE_TAC[CONNECTED_IN_SUBTOPOLOGY; TOPSPACE_SUBTOPOLOGY] THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; ALL_TAC] THEN + (* Now use maximality of connected component c *) + MP_TAC(ISPECL [`subtopology top (topspace top DIFF s):A topology`; + `t:A->bool`; `c:A->bool`] + CONNECTED_COMPONENTS_OF_MAXIMAL) THEN ASM_REWRITE_TAC[] THEN + ANTS_TAC THEN REWRITE_TAC[SUBSET; IN] THEN ASM SET_TAC[]]; + (* Case 2: DISJOINT c C *) DISJ2_TAC THEN + (* Need: c IN connected_components_of top /\ DISJOINT c C *) + (* We have DISJOINT c C, so just need c IN connected_components_of top *) + ASM_REWRITE_TAC[] THEN (* Show c = connected_component_of top x *) + REWRITE_TAC[connected_components_of; IN_ELIM_THM] THEN + EXISTS_TAC `x:A` THEN (* First show x IN topspace top *) + SUBGOAL_THEN `(x:A) IN topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[connected_in; SUBSET]; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + (* Now show c = connected_component_of top x via SUBSET_ANTISYM *) + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [(* c SUBSET connected_component_of top x *) + (* c is connected in top and contains x *) + REWRITE_TAC[SUBSET; IN; connected_component_of] THEN + X_GEN_TAC `z:A` THEN DISCH_TAC THEN + EXISTS_TAC `c:A->bool` THEN ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + (* connected_component_of top x SUBSET c *) + (* Key: connected_component_of top x is disjoint *) + (* from C (since C is clopen) *) + (* Hence it's in topspace top DIFF s, so SUBSET c by maximality *) + REWRITE_TAC[SUBSET; IN; connected_component_of] THEN X_GEN_TAC `z:A` THEN + DISCH_THEN(X_CHOOSE_THEN `t:A->bool` STRIP_ASSUME_TAC) THEN + (* t connected in subtopology top (topspace top DIFF s) via clopen case *) + SUBGOAL_THEN + `connected_in (subtopology top (topspace top DIFF s)) (t:A->bool)` + ASSUME_TAC THENL [ASM_REWRITE_TAC[CONNECTED_IN_SUBTOPOLOGY] THEN + MP_TAC(ISPECL [`top:A topology`; `t:A->bool`; `C:A->bool`] + CONNECTED_IN_CLOPEN_CASES) THEN ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o MATCH_MP CONNECTED_IN_SUBSET_TOPSPACE) THEN + ASM SET_TAC[]; ALL_TAC] THEN + (* Use maximality of c: t is connected, contains x IN c, so t SUBSET c *) + MP_TAC(ISPECL [`subtopology top (topspace top DIFF s):A topology`; + `t:A->bool`; `c:A->bool`] + CONNECTED_COMPONENTS_OF_MAXIMAL) THEN ASM_REWRITE_TAC[] THEN + ANTS_TAC THEN REWRITE_TAC[SUBSET; IN] THEN ASM SET_TAC[]]]);; + +(* Helper: Semi-local connectedness for connected spaces *) +let SEMI_LOCALLY_CONNECTED_CONNECTED = prove + (`!m:A metric. connected_in (mtopology m) (mspace m) /\ + locally_compact_space (mtopology m) /\ + locally_connected_space (mtopology m) + ==> !x v. open_in (mtopology m) v /\ x IN v + ==> ?u. open_in (mtopology m) u /\ x IN u /\ u SUBSET v /\ + FINITE(connected_components_of(subtopology (mtopology m) + (mspace m DIFF u)))`, + REPEAT STRIP_TAC THEN ABBREV_TAC `top = mtopology m:A topology` THEN + ABBREV_TAC `s = mspace m:A->bool` THEN + SUBGOAL_THEN `topspace top = (s:A->bool)` ASSUME_TAC THENL + [EXPAND_TAC "top" THEN EXPAND_TAC "s" THEN REWRITE_TAC[TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN + SUBGOAL_THEN `hausdorff_space (top:A topology)` ASSUME_TAC THENL + [EXPAND_TAC "top" THEN REWRITE_TAC[HAUSDORFF_SPACE_MTOPOLOGY]; ALL_TAC] THEN + (* Step 1: Get two nested compact closed neighborhoods of x *) + MP_TAC(SPEC `top:A topology` + LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE_CLOSED_IN) THEN + ASM_REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN + DISCH_THEN(MP_TAC o SPECL [`v:A->bool`; `x:A`]) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `d:A->bool` + (X_CHOOSE_THEN `c:A->bool` STRIP_ASSUME_TAC)) THEN + MP_TAC(SPEC `top:A topology` + LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE_CLOSED_IN) THEN + ASM_REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN + DISCH_THEN(MP_TAC o SPECL [`d:A->bool`; `x:A`]) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u':A->bool` + (X_CHOOSE_THEN `k:A->bool` STRIP_ASSUME_TAC)) THEN + (* Establish basic subset relations *) + SUBGOAL_THEN `c SUBSET (s:A->bool) /\ k SUBSET (s:A->bool)` + STRIP_ASSUME_TAC THENL + [CONJ_TAC THEN ASM_MESON_TAC[COMPACT_IN_SUBSET_TOPSPACE]; ALL_TAC] THEN + SUBGOAL_THEN `open_in top (s DIFF k:A->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC OPEN_IN_DIFF THEN ASM_MESON_TAC[OPEN_IN_TOPSPACE]; + ALL_TAC] THEN + SUBGOAL_THEN `(c DIFF d:A->bool) SUBSET s DIFF k` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + (* Step 2: For each y in c DIFF d, get open connected *) + (* neighborhood in s DIFF k *) SUBGOAL_THEN `!y:A. y IN c DIFF d + ==> ?t. open_in top t /\ connected_in top t /\ + y IN t /\ t SUBSET s DIFF k` + MP_TAC THENL [X_GEN_TAC `y:A` THEN REWRITE_TAC[IN_DIFF] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [LOCALLY_CONNECTED_SPACE]) THEN + DISCH_THEN(MP_TAC o SPECL [`s DIFF k:A->bool`; `y:A`]) THEN + ASM_REWRITE_TAC[] THEN ANTS_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `t:A->bool` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + GEN_REWRITE_TAC (LAND_CONV o TOP_DEPTH_CONV) + [RIGHT_IMP_EXISTS_THM; SKOLEM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `t:A->A->bool` STRIP_ASSUME_TAC) THEN + (* Step 3: c DIFF d is compact, so finitely many t(y) cover it *) + SUBGOAL_THEN `compact_in top (c DIFF d:A->bool)` MP_TAC THENL + [MATCH_MP_TAC CLOSED_COMPACT_IN THEN EXISTS_TAC `c:A->bool` THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL [SET_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC CLOSED_IN_DIFF THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[compact_in]] THEN DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPEC `IMAGE (t:A->A->bool) (c DIFF d)`)) THEN + ASM_SIMP_TAC[FORALL_IN_IMAGE] THEN + ANTS_TAC THENL [REWRITE_TAC[UNIONS_IMAGE] THEN ASM SET_TAC[]; ALL_TAC] THEN + REWRITE_TAC[EXISTS_FINITE_SUBSET_IMAGE] THEN + DISCH_THEN(X_CHOOSE_THEN `q:A->bool` STRIP_ASSUME_TAC) THEN + (* Step 4: Define r and the final u *) ABBREV_TAC `r = (s DIFF d) UNION + UNIONS(IMAGE (\y. s INTER top closure_of ((t:A->A->bool) y)) q)` THEN + EXISTS_TAC `s DIFF r:A->bool` THEN (* Show r SUBSET s *) + SUBGOAL_THEN `(r:A->bool) SUBSET s` ASSUME_TAC THENL + [EXPAND_TAC "r" THEN REWRITE_TAC[UNION_SUBSET] THEN + CONJ_TAC THENL [SET_TAC[]; ALL_TAC] THEN + REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_IMAGE] THEN SET_TAC[]; ALL_TAC] THEN + (* Goal: open_in top (s DIFF r) /\ x IN (s DIFF r) *) + (* /\ (s DIFF r) SUBSET v /\ FINITE(...) *) + (* First conjunct: open_in top (s DIFF r) *) + CONJ_TAC THENL [MATCH_MP_TAC OPEN_IN_DIFF THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [ASM_MESON_TAC[OPEN_IN_TOPSPACE]; ALL_TAC] THEN + EXPAND_TAC "r" THEN MATCH_MP_TAC CLOSED_IN_UNION THEN CONJ_TAC THENL + [SUBGOAL_THEN `s DIFF d:A->bool = topspace top DIFF d` SUBST1_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC CLOSED_IN_DIFF THEN REWRITE_TAC[CLOSED_IN_TOPSPACE] THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC CLOSED_IN_UNIONS THEN ASM_SIMP_TAC[FINITE_IMAGE] THEN + REWRITE_TAC[FORALL_IN_IMAGE] THEN X_GEN_TAC `y:A` THEN DISCH_TAC THEN + MATCH_MP_TAC CLOSED_IN_INTER THEN CONJ_TAC THENL + [SUBGOAL_THEN `(s:A->bool) = topspace top` SUBST1_TAC THENL + [ASM_MESON_TAC[]; REWRITE_TAC[CLOSED_IN_TOPSPACE]]; + REWRITE_TAC[CLOSED_IN_CLOSURE_OF]]; ALL_TAC] THEN + (* Second conjunct: x IN s DIFF r *) + CONJ_TAC THENL [ASM_REWRITE_TAC[IN_DIFF] THEN CONJ_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; ALL_TAC] THEN EXPAND_TAC "r" THEN + REWRITE_TAC[IN_UNION; UNIONS_IMAGE; IN_DIFF; IN_ELIM_THM; IN_INTER; + DE_MORGAN_THM; NOT_EXISTS_THM] THEN + CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + X_GEN_TAC `y:A` THEN REWRITE_TAC[DE_MORGAN_THM] THEN + ASM_CASES_TAC `(y:A) IN q` THEN ASM_REWRITE_TAC[] THEN + (* Need: x NOTIN s INTER closure t(y) *) + (* Use: t(y) SUBSET s DIFF k, and x IN u' SUBSET k *) + SUBGOAL_THEN `top closure_of ((t:A->A->bool) y) SUBSET s DIFF u'` + MP_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN + MATCH_MP_TAC CLOSURE_OF_MINIMAL THEN + SUBGOAL_THEN `s DIFF u':A->bool = topspace top DIFF u'` SUBST1_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + ASM_SIMP_TAC[CLOSED_IN_DIFF; CLOSED_IN_TOPSPACE] THEN + SUBGOAL_THEN `(y:A) IN c DIFF d` MP_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + DISCH_TAC THEN FIRST_X_ASSUM(MP_TAC o SPEC `y:A`) THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; ALL_TAC] THEN + (* Third conjunct: (s DIFF r) SUBSET v *) + CONJ_TAC THENL [SUBGOAL_THEN `(s DIFF r:A->bool) SUBSET d` MP_TAC THENL + [EXPAND_TAC "r" THEN SET_TAC[]; ASM SET_TAC[]]; ALL_TAC] THEN + (* Fourth conjunct: FINITE(connected_components_of *) + (* (subtopology top (s DIFF (s DIFF r)))) *) + (* Note: s DIFF (s DIFF r) = s INTER r = r when r SUBSET s *) + SUBGOAL_THEN `s DIFF (s DIFF r):A->bool = r` SUBST1_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + (* Goal: FINITE(connected_components_of(subtopology top r)) *) + SUBGOAL_THEN `connected_space (top:A topology)` + ASSUME_TAC THENL + [EXPAND_TAC "top" THEN + ASM_REWRITE_TAC[GSYM CONNECTED_IN_TOPSPACE; + TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN + SUBGOAL_THEN `~((c:A->bool) = {})` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + (* Pre-prove SUBSET facts while EXPAND_TAC "r" still works correctly *) + SUBGOAL_THEN `s DIFF d SUBSET (r:A->bool)` ASSUME_TAC THENL + [EXPAND_TAC "r" THEN SET_TAC[]; ALL_TAC] THEN SUBGOAL_THEN + `!w:A. w IN q ==> top closure_of ((t:A->A->bool) w) SUBSET r` + ASSUME_TAC THENL [X_GEN_TAC `w:A` THEN DISCH_TAC THEN + EXPAND_TAC "r" THEN REWRITE_TAC[SUBSET; IN_UNION] THEN + X_GEN_TAC `a:A` THEN DISCH_TAC THEN DISJ2_TAC THEN + REWRITE_TAC[UNIONS_IMAGE; IN_ELIM_THM] THEN + EXISTS_TAC `w:A` THEN ASM_REWRITE_TAC[IN_INTER] THEN + ASM_MESON_TAC[CLOSURE_OF_SUBSET_TOPSPACE; SUBSET]; + ALL_TAC] THEN + SUBGOAL_THEN `!z:A. z IN q ==> z IN r` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + (* Now bound components by IMAGE of q *) + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC + `IMAGE (\z:A. connected_component_of (subtopology top r) z) q` THEN + CONJ_TAC THENL [ASM_SIMP_TAC[FINITE_IMAGE]; ALL_TAC] THEN + SUBGOAL_THEN `topspace(subtopology top (r:A->bool)) = r` ASSUME_TAC THENL + [REWRITE_TAC[TOPSPACE_SUBTOPOLOGY] THEN ASM SET_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[connected_components_of; SUBSET; FORALL_IN_GSPEC] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN REWRITE_TAC[IN_IMAGE] THEN + (* Case: is y in some closure(t w) for w IN q? *) ASM_CASES_TAC + `?w:A. w IN q /\ y IN top closure_of ((t:A->A->bool) w)` THENL + [(* CASE 1: y IN closure(t w) for some w IN q *) + FIRST_X_ASSUM(X_CHOOSE_THEN `w:A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `w:A` THEN ASM_REWRITE_TAC[CONNECTED_COMPONENT_OF_EQ] THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + (* Use closure(t w) as connecting set *) MP_TAC(ISPECL + [`subtopology top (r:A->bool)`; `top closure_of ((t:A->A->bool) w)`; + `y:A`] CONNECTED_COMPONENT_OF_MAXIMAL) THEN ANTS_TAC THENL + [CONJ_TAC THENL [REWRITE_TAC[CONNECTED_IN_SUBTOPOLOGY] THEN CONJ_TAC THENL + [MATCH_MP_TAC CONNECTED_IN_CLOSURE_OF THEN + SUBGOAL_THEN `(w:A) IN c DIFF d` MP_TAC THENL + [ASM SET_TAC[]; ASM_MESON_TAC[]]; + (* closure(t w) SUBSET r: use pre-proved fact *) + ASM_MESON_TAC[]]; ASM_REWRITE_TAC[]]; ALL_TAC] THEN DISCH_TAC THEN + SUBGOAL_THEN `(w:A) IN connected_component_of (subtopology top r) y` + MP_TAC THENL [FIRST_X_ASSUM(MATCH_MP_TAC o REWRITE_RULE[SUBSET]) THEN + (* Goal: w IN top closure_of t w *) + SUBGOAL_THEN `(w:A) IN c DIFF d /\ (t:A->A->bool) w SUBSET topspace top` + STRIP_ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[CLOSURE_OF_SUBSET; SUBSET]; REWRITE_TAC[IN]]; ALL_TAC] THEN + (* CASE 2: y NOT in any closure(t w) for w IN q *) + (* y must be in s DIFF d *) + SUBGOAL_THEN `(y:A) IN s DIFF d` ASSUME_TAC THENL [SUBGOAL_THEN + `(y:A) IN (s DIFF d) UNION + UNIONS(IMAGE (\y:A. s INTER top closure_of ((t:A->A->bool) y)) q)` + MP_TAC THENL [ASM_MESON_TAC[SUBSET; IN]; ALL_TAC] THEN + REWRITE_TAC[IN_UNION; UNIONS_IMAGE; IN_ELIM_THM; IN_INTER] THEN + ASM_MESON_TAC[]; ALL_TAC] THEN (* y is not in c *) + SUBGOAL_THEN `~((y:A) IN c)` ASSUME_TAC THENL [DISCH_TAC THEN UNDISCH_TAC + `~(?w:A. w IN q /\ y IN top closure_of ((t:A->A->bool) w))` THEN + REWRITE_TAC[] THEN + SUBGOAL_THEN `(y:A) IN UNIONS(IMAGE (t:A->A->bool) q)` MP_TAC THENL + [ASM SET_TAC[]; REWRITE_TAC[UNIONS_IMAGE; IN_ELIM_THM]] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `w:A` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `(w:A) IN c DIFF d` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(t:A->A->bool) w SUBSET topspace top` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN ASM_MESON_TAC[CLOSURE_OF_SUBSET; SUBSET]; + ALL_TAC] THEN (* Define K = connected component of y in s DIFF c *) + ABBREV_TAC + `K = connected_component_of (subtopology top (s DIFF c)) (y:A)` THEN + SUBGOAL_THEN `open_in top (s DIFF c:A->bool)` ASSUME_TAC THENL + [SUBGOAL_THEN `s DIFF c:A->bool = topspace top DIFF c` + SUBST1_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC OPEN_IN_DIFF THEN ASM_REWRITE_TAC[OPEN_IN_TOPSPACE]; + ALL_TAC] THEN SUBGOAL_THEN `open_in top (K:A->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC OPEN_IN_TRANS_FULL THEN + EXISTS_TAC `s DIFF c:A->bool` THEN ASM_REWRITE_TAC[] THEN + EXPAND_TAC "K" THEN + MATCH_MP_TAC OPEN_IN_CONNECTED_COMPONENT_OF_LOCALLY_CONNECTED_SPACE THEN + MATCH_MP_TAC LOCALLY_CONNECTED_SPACE_OPEN_SUBSET THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN SUBGOAL_THEN `(y:A) IN K` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN REWRITE_TAC[IN] THEN + REWRITE_TAC[CONNECTED_COMPONENT_OF_REFL] THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; IN_INTER] THEN ASM SET_TAC[]; + ALL_TAC] THEN SUBGOAL_THEN `(K:A->bool) SUBSET s DIFF c` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN + MP_TAC(ISPECL [`subtopology top (s DIFF c:A->bool)`; `y:A`] + CONNECTED_COMPONENT_OF_SUBSET_TOPSPACE) THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY] THEN ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `connected_in top (K:A->bool)` ASSUME_TAC THENL + [MP_TAC(ISPECL [`subtopology top (s DIFF c:A->bool)`; `y:A`] + CONNECTED_IN_CONNECTED_COMPONENT_OF) THEN + REWRITE_TAC[CONNECTED_IN_SUBTOPOLOGY] THEN EXPAND_TAC "K" THEN SIMP_TAC[]; + ALL_TAC] THEN (* Key claim: closure(K) meets c *) + SUBGOAL_THEN `~(top closure_of (K:A->bool) INTER c = {})` + ASSUME_TAC THENL [DISCH_TAC THEN + SUBGOAL_THEN `top closure_of (K:A->bool) SUBSET s DIFF c` + ASSUME_TAC THENL [MP_TAC(ISPECL [`top:A topology`; `K:A->bool`] + CLOSURE_OF_SUBSET_TOPSPACE) THEN ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `top closure_of (K:A->bool) = K` ASSUME_TAC THENL + [MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL [EXPAND_TAC "K" THEN + MATCH_MP_TAC CONNECTED_COMPONENT_OF_MAXIMAL THEN CONJ_TAC THENL + [ASM_REWRITE_TAC[CONNECTED_IN_SUBTOPOLOGY] THEN + MATCH_MP_TAC CONNECTED_IN_CLOSURE_OF THEN ASM_REWRITE_TAC[]; + SUBGOAL_THEN `(K:A->bool) SUBSET topspace top` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[CLOSURE_OF_SUBSET; SUBSET]]; + MATCH_MP_TAC CLOSURE_OF_SUBSET THEN ASM SET_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `closed_in top (K:A->bool)` ASSUME_TAC THENL + [ASM_REWRITE_TAC[GSYM CLOSURE_OF_EQ]; ALL_TAC] THEN + MP_TAC(ISPEC `top:A topology` CONNECTED_SPACE_CLOPEN_IN) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN(MP_TAC o SPEC `K:A->bool`) THEN + ASM_REWRITE_TAC[] THEN STRIP_TAC THEN ASM SET_TAC[]; ALL_TAC] THEN + (* Pick z IN closure(K) INTER c *) FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN REWRITE_TAC[IN_INTER] THEN + DISCH_THEN(X_CHOOSE_THEN `z:A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `~((z:A) IN d)` ASSUME_TAC THENL [DISCH_TAC THEN + MP_TAC(ISPECL [`top:A topology`; `d:A->bool`; `K:A->bool`] + OPEN_IN_INTER_CLOSURE_OF_EQ_EMPTY) THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(z:A) IN UNIONS(IMAGE (t:A->A->bool) q)` MP_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN REWRITE_TAC[UNIONS_IMAGE; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `w':A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `~(K INTER (t:A->A->bool) w' = {})` ASSUME_TAC THENL + [MP_TAC(ISPECL [`top:A topology`; `(t:A->A->bool) w'`; `K:A->bool`] + OPEN_IN_INTER_CLOSURE_OF_EQ_EMPTY) THEN ANTS_TAC THENL + [SUBGOAL_THEN `(w':A) IN c DIFF d` MP_TAC THENL + [ASM SET_TAC[]; ASM_MESON_TAC[]]; ALL_TAC] THEN + ASM SET_TAC[]; ALL_TAC] THEN (* Conclusion: w' IN q connects y to w' *) + EXISTS_TAC `w':A` THEN ASM_REWRITE_TAC[CONNECTED_COMPONENT_OF_EQ] THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + (* Use K UNION t(w') as connecting set *) MP_TAC(ISPECL + [`subtopology top (r:A->bool)`; `K UNION (t:A->A->bool) w'`; + `y:A`] CONNECTED_COMPONENT_OF_MAXIMAL) THEN ANTS_TAC THENL + [CONJ_TAC THENL [REWRITE_TAC[CONNECTED_IN_SUBTOPOLOGY] THEN CONJ_TAC THENL + [MATCH_MP_TAC CONNECTED_IN_UNION THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `(w':A) IN c DIFF d` MP_TAC THENL + [ASM SET_TAC[]; ASM_MESON_TAC[]]; (* K UNION t(w') SUBSET r *) + REWRITE_TAC[UNION_SUBSET] THEN CONJ_TAC THENL + [(* K SUBSET r: K SUBSET s DIFF c SUBSET s DIFF d SUBSET r *) + ASM SET_TAC[]; (* t(w') SUBSET r: use pre-proved closure fact *) + TRANS_TAC SUBSET_TRANS `top closure_of ((t:A->A->bool) w')` THEN + CONJ_TAC THENL [MATCH_MP_TAC CLOSURE_OF_SUBSET THEN ASM SET_TAC[]; + ASM_MESON_TAC[]]]]; ASM_REWRITE_TAC[IN_UNION]]; + ALL_TAC] THEN DISCH_TAC THEN SUBGOAL_THEN + `(w':A) IN connected_component_of (subtopology top r) y` + MP_TAC THENL [FIRST_X_ASSUM(MATCH_MP_TAC o REWRITE_RULE[SUBSET]) THEN + REWRITE_TAC[IN_UNION] THEN DISJ2_TAC THEN + SUBGOAL_THEN `(w':A) IN c DIFF d` MP_TAC THENL + [ASM SET_TAC[]; ASM_MESON_TAC[]]; REWRITE_TAC[IN]]);; + +(* SEMI_LOCALLY_CONNECTED_GEN_SPACE: Use *) +(* SEMI_LOCALLY_CONNECTED_CONNECTED on each component *) +let SEMI_LOCALLY_CONNECTED_GEN_SPACE = prove + (`!m:A metric. FINITE(connected_components_of(mtopology m)) /\ + locally_compact_space (mtopology m) /\ + locally_connected_space (mtopology m) + ==> !x v. open_in (mtopology m) v /\ x IN v + ==> ?u. open_in (mtopology m) u /\ x IN u /\ u SUBSET v /\ + FINITE(connected_components_of(subtopology (mtopology m) + (mspace m DIFF u)))`, + REPEAT STRIP_TAC THEN ABBREV_TAC `top = mtopology m:A topology` THEN + ABBREV_TAC `s = mspace m:A->bool` THEN + SUBGOAL_THEN `topspace top = (s:A->bool)` ASSUME_TAC THENL + [EXPAND_TAC "top" THEN EXPAND_TAC "s" THEN REWRITE_TAC[TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN ABBREV_TAC `C = connected_component_of top (x:A)` THEN + SUBGOAL_THEN `open_in top (C:A->bool) /\ closed_in top C` + STRIP_ASSUME_TAC THENL [EXPAND_TAC "C" THEN + ASM_SIMP_TAC[OPEN_IN_CONNECTED_COMPONENT_OF_LOCALLY_CONNECTED_SPACE; + CLOSED_IN_CONNECTED_COMPONENT_OF]; ALL_TAC] THEN + SUBGOAL_THEN `(x:A) IN topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; ALL_TAC] THEN + SUBGOAL_THEN `(x:A) IN C` ASSUME_TAC THENL + [EXPAND_TAC "C" THEN ONCE_REWRITE_TAC[IN] THEN + ASM_REWRITE_TAC[CONNECTED_COMPONENT_OF_REFL]; ALL_TAC] THEN + SUBGOAL_THEN `C SUBSET (s:A->bool)` ASSUME_TAC THENL [EXPAND_TAC "C" THEN + MP_TAC(ISPECL [`top:A topology`; `x:A`] + CONNECTED_COMPONENT_OF_SUBSET_TOPSPACE) THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `mtopology (submetric m (C:A->bool)) = subtopology top C` + (LABEL_TAC "mtop_eq") THENL [EXPAND_TAC "top" THEN + MP_TAC(ISPECL [`m:A metric`; `C:A->bool`] MTOPOLOGY_SUBMETRIC) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `mspace (submetric m (C:A->bool)) = C` (LABEL_TAC "msp_eq") + THENL + [REWRITE_TAC[SUBMETRIC] THEN ASM SET_TAC[]; ALL_TAC] THEN + MP_TAC(ISPEC `submetric m (C:A->bool)` SEMI_LOCALLY_CONNECTED_CONNECTED) THEN + USE_THEN "mtop_eq" SUBST_ALL_TAC THEN USE_THEN "msp_eq" SUBST_ALL_TAC THEN + ANTS_TAC THENL [REPEAT CONJ_TAC THENL + [REWRITE_TAC[CONNECTED_IN_SUBTOPOLOGY; SUBSET_REFL] THEN + SUBGOAL_THEN `C = connected_component_of top (x:A)` SUBST1_TAC THENL + [ASM_MESON_TAC[]; REWRITE_TAC[CONNECTED_IN_CONNECTED_COMPONENT_OF]]; + MATCH_MP_TAC LOCALLY_COMPACT_SPACE_OPEN_SUBSET THEN + ASM_REWRITE_TAC[] THEN DISJ1_TAC THEN + ASM_MESON_TAC[HAUSDORFF_SPACE_MTOPOLOGY]; + MATCH_MP_TAC LOCALLY_CONNECTED_SPACE_OPEN_SUBSET THEN ASM_REWRITE_TAC[]]; + ALL_TAC] THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`x:A`; `v INTER C:A->bool`]) THEN + ANTS_TAC THENL [CONJ_TAC THENL + [REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN EXISTS_TAC `v:A->bool` THEN + ASM_REWRITE_TAC[] THEN SET_TAC[]; ASM SET_TAC[]]; + ALL_TAC] THEN DISCH_THEN(X_CHOOSE_THEN `u':A->bool` MP_TAC) THEN + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) + STRIP_ASSUME_TAC) THEN EXISTS_TAC `u':A->bool` THEN REPEAT CONJ_TAC THENL + [ASM_REWRITE_TAC[] THEN MATCH_MP_TAC OPEN_IN_INTER THEN ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[]; ASM SET_TAC[]; + ALL_TAC] THEN SUBGOAL_THEN `u' SUBSET (C:A->bool)` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `s DIFF u' = topspace top DIFF u':A->bool` SUBST1_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC FINITE_CONNECTED_COMPONENTS_CLOPEN_UNION THEN + EXISTS_TAC `C:A->bool` THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `subtopology top (C DIFF w INTER C) = + subtopology (subtopology top C) (C DIFF u'):A topology` + SUBST1_TAC THENL + [REWRITE_TAC[SUBTOPOLOGY_SUBTOPOLOGY] THEN AP_TERM_TAC THEN + ASM_REWRITE_TAC[] THEN SET_TAC[]; ASM_REWRITE_TAC[]]);; -let SUBTOPOLOGY_NSPHERE_EQUATOR = prove - (`!n. subtopology (nsphere (n + 1)) {x | x(n+2) = &0} = nsphere n`, - GEN_TAC THEN - REWRITE_TAC[NSPHERE; SUBTOPOLOGY_SUBTOPOLOGY] THEN AP_TERM_TAC THEN - GEN_REWRITE_TAC I [EXTENSION] THEN X_GEN_TAC `x:num->real` THEN - REWRITE_TAC[IN_INTER; IN_ELIM_THM; GSYM CONJ_ASSOC] THEN - REWRITE_TAC[ARITH_RULE `(n + 1) + 1 = SUC(n + 1)`; SUM_CLAUSES_NUMSEG] THEN - REWRITE_TAC[ARITH_RULE `1 <= SUC n`; NUMSEG_CLAUSES] THEN - REWRITE_TAC[ARITH_RULE `SUC(n + 1) = n + 2`; IN_INSERT; IN_NUMSEG] THEN - ASM_CASES_TAC `(x:num->real)(n + 2) = &0` THENL - [ALL_TAC; ASM_MESON_TAC[ARITH_RULE `~(n + 2 <= n + 1)`]] THEN - ASM_REWRITE_TAC[] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN - REWRITE_TAC[REAL_ADD_RID] THEN ASM_MESON_TAC[]);; +let SEMI_LOCALLY_CONNECTED_COMPACT_SPACE = prove + (`!m:A metric. + compact_in (mtopology m) (mspace m) /\ + locally_connected_space (mtopology m) + ==> !x v. open_in (mtopology m) v /\ x IN v + ==> ?u. open_in (mtopology m) u /\ x IN u /\ u SUBSET v /\ + FINITE(connected_components_of(subtopology (mtopology m) + (mspace m DIFF u)))`, + REPEAT STRIP_TAC THEN + MP_TAC(ISPEC `m:A metric` SEMI_LOCALLY_CONNECTED_GEN_SPACE) THEN ANTS_TAC THENL + [(* Need: FINITE(connected_components_of(mtopology m)) /\ + locally_compact_space /\ locally_connected_space *) + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [MATCH_MP_TAC FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN MP_TAC(ISPEC `mtopology m:A topology` + COMPACT_IMP_LOCALLY_COMPACT_SPACE) THEN + ASM_REWRITE_TAC[compact_space; TOPSPACE_MTOPOLOGY]; + (* Apply the resulting implication to x and v *) + DISCH_THEN(MP_TAC o SPECL [`x:A`; `v:A->bool`]) THEN ASM_REWRITE_TAC[]]);; -let CONTINUOUS_MAP_NSPHERE_REFLECTION = prove - (`!n k. continuous_map (nsphere n,nsphere n) - (\x i. if i = k then --x i else x i)`, - REPEAT GEN_TAC THEN REWRITE_TAC[NSPHERE; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN - REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM] THEN CONJ_TAC THENL - [X_GEN_TAC `i:num` THEN MATCH_MP_TAC CONTINUOUS_MAP_FROM_SUBTOPOLOGY THEN - ASM_CASES_TAC `i:num = k` THEN - ASM_SIMP_TAC[CONTINUOUS_MAP_REAL_NEG; CONTINUOUS_MAP_PRODUCT_PROJECTION; - IN_UNIV]; - ONCE_REWRITE_TAC[COND_RAND] THEN ONCE_REWRITE_TAC[COND_RATOR] THEN - REWRITE_TAC[REAL_NEG_EQ_0; REAL_ARITH `(--x:real) pow 2 = x pow 2`] THEN - SIMP_TAC[COND_ID; TOPSPACE_SUBTOPOLOGY; IN_INTER; IN_ELIM_THM]]);; +(* ------------------------------------------------------------------------- *) +(* The dyadic rationals in [0,1] are dense in [0,1]. *) +(* ------------------------------------------------------------------------- *) -let CONTRACTIBLE_SPACE_UPPER_HEMISPHERE = prove - (`!n k. k IN 1..n+1 - ==> contractible_space(subtopology (nsphere n) {x | x k >= &0})`, - REPEAT STRIP_TAC THEN - ABBREV_TAC `p:num->real = \i. if i = k then &1 else &0` THEN - REWRITE_TAC[contractible_space] THEN EXISTS_TAC `p:num->real` THEN - SUBGOAL_THEN `p IN topspace(nsphere n)` ASSUME_TAC THENL - [EXPAND_TAC "p" THEN REWRITE_TAC[NSPHERE; TOPSPACE_SUBTOPOLOGY] THEN - REWRITE_TAC[IN_INTER; TOPSPACE_PRODUCT_TOPOLOGY; IN_ELIM_THM; o_DEF] THEN - REWRITE_TAC[TOPSPACE_EUCLIDEANREAL; CARTESIAN_PRODUCT_UNIV; IN_UNIV] THEN - CONJ_TAC THENL [ALL_TAC; ASM_MESON_TAC[]] THEN - REWRITE_TAC[COND_RAND; COND_RATOR] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN - ASM_REWRITE_TAC[SUM_DELTA]; +let CLOSURE_OF_DYADIC_RATIONALS_IN_UNIT_INTERVAL = prove + (`euclideanreal closure_of {&k / &2 pow n | k <= 2 EXP n} = + real_interval[&0,&1]`, + let REAL_EXP_DIV_POW2 = prove + (`!n. &(2 EXP n) / &2 pow n = &1`, + GEN_TAC THEN REWRITE_TAC[REAL_OF_NUM_POW] THEN + MATCH_MP_TAC REAL_DIV_REFL THEN + REWRITE_TAC[REAL_OF_NUM_EQ; EXP_EQ_0; ARITH]) in + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [(* closure_of D SUBSET [0,1]: D SUBSET [0,1] which is closed *) + MATCH_MP_TAC CLOSURE_OF_MINIMAL THEN CONJ_TAC THENL + [REWRITE_TAC[SUBSET; FORALL_IN_GSPEC; IN_REAL_INTERVAL] THEN + REPEAT STRIP_TAC THENL [MATCH_MP_TAC REAL_LE_DIV THEN + REWRITE_TAC[REAL_POS] THEN MATCH_MP_TAC REAL_POW_LE THEN + REAL_ARITH_TAC; ASM_SIMP_TAC[REAL_LE_LDIV_EQ; REAL_LT_POW2] THEN + ASM_REWRITE_TAC[REAL_MUL_LID; REAL_OF_NUM_POW; REAL_OF_NUM_LE]]; + REWRITE_TAC[GSYM REAL_CLOSED_IN; REAL_CLOSED_REAL_INTERVAL]]; + (* [0,1] SUBSET closure_of D: density argument *) + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `x:real` THEN + REWRITE_TAC[IN_REAL_INTERVAL] THEN STRIP_TAC THEN + REWRITE_TAC[GSYM MTOPOLOGY_REAL_EUCLIDEAN_METRIC] THEN + REWRITE_TAC[METRIC_CLOSURE_OF] THEN + REWRITE_TAC[IN_ELIM_THM; REAL_EUCLIDEAN_METRIC; IN_UNIV; + MBALL_REAL_INTERVAL; IN_REAL_INTERVAL] THEN + X_GEN_TAC `r:real` THEN DISCH_TAC THEN + MP_TAC(ISPECL [`inv(&2)`; `r:real`] REAL_ARCH_POW_INV) THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[REAL_POW_INV] THEN DISCH_THEN(X_CHOOSE_TAC `n:num`) THEN + SUBGOAL_THEN `?k:num. x <= &k / &2 pow n` MP_TAC THENL + [EXISTS_TAC `2 EXP n` THEN ASM_REWRITE_TAC[REAL_EXP_DIV_POW2]; + ALL_TAC] THEN GEN_REWRITE_TAC LAND_CONV [num_WOP] THEN + DISCH_THEN(X_CHOOSE_THEN `k:num` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `k <= 2 EXP n` ASSUME_TAC THENL + [REWRITE_TAC[GSYM NOT_LT] THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `2 EXP n`) THEN + ASM_REWRITE_TAC[REAL_EXP_DIV_POW2]; ALL_TAC] THEN + EXISTS_TAC `&k / &2 pow n` THEN CONJ_TAC THENL + [MAP_EVERY EXISTS_TAC [`k:num`; `n:num`] THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + ASM_CASES_TAC `k = 0` THENL [FIRST_X_ASSUM SUBST_ALL_TAC THEN + RULE_ASSUM_TAC(REWRITE_RULE[real_div; REAL_MUL_LZERO]) THEN + REWRITE_TAC[real_div; REAL_MUL_LZERO] THEN ASM_REAL_ARITH_TAC; + ALL_TAC] THEN FIRST_X_ASSUM(MP_TAC o SPEC `k - 1`) THEN + ASM_SIMP_TAC[ARITH_RULE `~(k = 0) ==> k - 1 < k`] THEN + REWRITE_TAC[REAL_NOT_LE] THEN DISCH_TAC THEN + SUBGOAL_THEN `&(k - 1) = &k - &1` + (fun th -> RULE_ASSUM_TAC(REWRITE_RULE[th])) THENL + [CONV_TAC SYM_CONV THEN MATCH_MP_TAC REAL_OF_NUM_SUB THEN ASM_ARITH_TAC; + ALL_TAC] THEN + SUBGOAL_THEN `&k / &2 pow n - (&k - &1) / &2 pow n = inv(&2 pow n)` + ASSUME_TAC THENL [MATCH_MP_TAC(REAL_FIELD + `&0 < p ==> k / p - (k - &1) / p = inv p`) THEN + REWRITE_TAC[REAL_LT_POW2]; ASM_REAL_ARITH_TAC]]);; + +(* ------------------------------------------------------------------------- *) +(* Path-connectivity of complete locally connected metric spaces. *) +(* Whyburn, Analytic Topology, Theorems (5.1)-(5.4); H-Y Theorem 3-17. *) +(* ------------------------------------------------------------------------- *) + +(* Chain from open cover: in a connected space, any open cover admits a *) +(* finite chain between any two points (H-Y Theorem 3-4). *) + +let CHAIN_FROM_OPEN_COVER = prove + (`!top:A topology U a b. + connected_space top /\ + a IN topspace top /\ b IN topspace top /\ + (!x. x IN topspace top ==> ?u. u IN U /\ x IN u) /\ + (!u. u IN U ==> open_in top u) ==> ?c n. (!i. i <= n ==> c i IN U) /\ + a IN c 0 /\ b IN c n /\ + (!i. i < n ==> ~(c i INTER c(SUC i) = {}))`, + REPEAT GEN_TAC THEN STRIP_TAC THEN SUBGOAL_THEN `{x:A | x IN topspace top /\ + ?c n. (!i. i <= n ==> c i IN U) /\ a IN c 0 /\ x IN c n /\ + (!i. i < n ==> ~(c i INTER c(SUC i) = {}))} = + topspace top` MP_TAC THENL + [FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [CONNECTED_SPACE_CLOPEN_IN]) THEN + DISCH_THEN(MP_TAC o SPEC `{x:A | x IN topspace top /\ + ?c n. (!i. i <= n ==> c i IN U) /\ a IN c 0 /\ x IN c n /\ + (!i. i < n ==> ~(c i INTER c(SUC i) = {}))}`) THEN + ANTS_TAC THENL [CONJ_TAC THENL [(* open_in: use OPEN_IN_SUBOPEN *) + GEN_REWRITE_TAC I [OPEN_IN_SUBOPEN] THEN + X_GEN_TAC `x:A` THEN REWRITE_TAC[IN_ELIM_THM] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `v:A->bool` THEN + SUBGOAL_THEN `open_in top (v:A->bool) /\ v SUBSET topspace top` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[OPEN_IN_SUBSET]; ALL_TAC] THEN + ASM_REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN EXISTS_TAC + `\i:num. if i <= n then (c:num->A->bool) i else (v:A->bool)` THEN + EXISTS_TAC `SUC n` THEN REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [X_GEN_TAC `j:num` THEN DISCH_TAC THEN + COND_CASES_TAC THEN ASM_MESON_TAC[]; ASM_REWRITE_TAC[LE_0]; + ASM_REWRITE_TAC[ARITH_RULE `~(SUC n <= n)`]; + X_GEN_TAC `j:num` THEN REWRITE_TAC[LT_SUC_LE] THEN DISCH_TAC THEN + SUBGOAL_THEN `j:num <= n` ASSUME_TAC THENL + [ASM_ARITH_TAC; ASM_REWRITE_TAC[]] THEN + ASM_CASES_TAC `SUC j <= n` THEN ASM_REWRITE_TAC[] THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; + SUBGOAL_THEN `j:num = n` SUBST_ALL_TAC THENL + [ASM_ARITH_TAC; ASM SET_TAC[]]]]; + (* closed_in: complement is open by chain extension *) + REWRITE_TAC[closed_in] THEN CONJ_TAC THENL + [REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN MESON_TAC[]; ALL_TAC] THEN + GEN_REWRITE_TAC I [OPEN_IN_SUBOPEN] THEN + X_GEN_TAC `x':A` THEN REWRITE_TAC[IN_DIFF; IN_ELIM_THM] THEN + STRIP_TAC THEN FIRST_X_ASSUM(MP_TAC o SPEC `x':A`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `w:A->bool` THEN + SUBGOAL_THEN `open_in top (w:A->bool)` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[SUBSET; IN_DIFF; IN_ELIM_THM] THEN + X_GEN_TAC `y':A` THEN DISCH_TAC THEN CONJ_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; ALL_TAC] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (X_CHOOSE_THEN `c':num->A->bool` + (X_CHOOSE_THEN `n':num` STRIP_ASSUME_TAC))) THEN SUBGOAL_THEN + `?c'':num->A->bool n'':num. + (!i. i <= n'' ==> c'' i IN (U:(A->bool)->bool)) /\ + (a:A) IN c'' 0 /\ (x':A) IN c'' n'' /\ + (!i. i < n'' ==> ~(c'' i INTER c''(SUC i) = {}))` MP_TAC THENL + [EXISTS_TAC + `\i:num. if i <= n' then (c':num->A->bool) i else (w:A->bool)` THEN + EXISTS_TAC `SUC n'` THEN REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [X_GEN_TAC `j:num` THEN DISCH_TAC THEN + COND_CASES_TAC THEN ASM_MESON_TAC[]; ASM_REWRITE_TAC[LE_0]; + ASM_REWRITE_TAC[ARITH_RULE `~(SUC n <= n)`]; + X_GEN_TAC `j:num` THEN REWRITE_TAC[LT_SUC_LE] THEN DISCH_TAC THEN + SUBGOAL_THEN `j:num <= n'` ASSUME_TAC THENL + [ASM_ARITH_TAC; ASM_REWRITE_TAC[]] THEN + ASM_CASES_TAC `SUC j <= n'` THEN ASM_REWRITE_TAC[] THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; + SUBGOAL_THEN `j:num = n'` SUBST_ALL_TAC THENL + [ASM_ARITH_TAC; ASM SET_TAC[]]]]; ASM_MESON_TAC[]]]; + (* From X = {} \/ X = topspace, eliminate X = {} *) + DISCH_THEN(DISJ_CASES_TAC) THENL [SUBGOAL_THEN `(a:A) IN {}` MP_TAC THENL + [FIRST_X_ASSUM(fun th -> GEN_REWRITE_TAC RAND_CONV [SYM th]) THEN + ASM_REWRITE_TAC[IN_ELIM_THM] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `a:A`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u0:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(\i:num. u0):num->A->bool` THEN + EXISTS_TAC `0` THEN ASM_REWRITE_TAC[LE_0; LT]; + REWRITE_TAC[NOT_IN_EMPTY]]; ASM_REWRITE_TAC[]]]; + (* Extract chain for b from b IN X *) + DISCH_TAC THEN SUBGOAL_THEN `(b:A) IN {x | x IN topspace top /\ + ?c n. (!i. i <= n ==> c i IN U) /\ a IN c 0 /\ x IN c n /\ + (!i. i < n ==> ~(c i INTER c(SUC i) = {}))}` + MP_TAC THENL [FIRST_X_ASSUM SUBST1_TAC THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[IN_ELIM_THM] THEN MESON_TAC[]]]);; + +(* CONNECTED_IN_CHAIN_UNIONS: A finite chain of connected sets (consecutive *) +(* links overlapping) has connected union. *) + +let CONNECTED_IN_CHAIN_UNIONS = prove + (`!top (c:num->A->bool) n. + (!i. i <= n ==> connected_in top (c i)) /\ + (!i. i < n ==> ~(c i INTER c(SUC i) = {})) + ==> connected_in top (UNIONS {c i | i <= n})`, + GEN_TAC THEN GEN_TAC THEN INDUCT_TAC THENL [STRIP_TAC THEN + SUBGOAL_THEN `{(c:num->A->bool) i | i <= 0} = {c 0}` SUBST1_TAC THENL + [REWRITE_TAC[EXTENSION; IN_ELIM_THM; IN_SING; LE] THEN MESON_TAC[]; + REWRITE_TAC[UNIONS_1] THEN ASM_MESON_TAC[LE_0]]; STRIP_TAC THEN + SUBGOAL_THEN `UNIONS {(c:num->A->bool) i | i <= SUC n} = + UNIONS {c i | i <= n} UNION c(SUC n)` SUBST1_TAC THENL + [REWRITE_TAC[EXTENSION; IN_UNIONS; IN_UNION; IN_ELIM_THM; LE] THEN + MESON_TAC[]; MATCH_MP_TAC CONNECTED_IN_UNION THEN REPEAT CONJ_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN + ASM_MESON_TAC[ARITH_RULE `i <= n ==> i <= SUC n`; + ARITH_RULE `i < n ==> i < SUC n`]; + ASM_MESON_TAC[LE_REFL]; + SUBGOAL_THEN `~((c:num->A->bool) n INTER c(SUC n) = {})` MP_TAC THENL + [ASM_MESON_TAC[ARITH_RULE `n < SUC n`]; ALL_TAC] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER; IN_UNIONS; + IN_ELIM_THM] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `z:A` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + EXISTS_TAC `(c:num->A->bool) n` THEN ASM_REWRITE_TAC[] THEN + EXISTS_TAC `n:num` THEN REWRITE_TAC[LE_REFL]]]]);; + +(* Helper: intersection of nested unions of closures with vanishing *) +(* diameter in a complete metric space is compact. Proved for the whole *) +(* metric space; localized versions follow by instantiating m to submetric. *) + +let COMPACT_NESTED_INTERS = prove + (`!m:A metric (c:num->num->A->bool) (N:num->num). + mcomplete m /\ + (!n i. i <= N n ==> c n i SUBSET mspace m) /\ + (!n i. i <= N n ==> !x y. x IN c n i /\ y IN c n i + ==> mdist m (x:A,y) < inv(&(n + 1))) + ==> compact_in (mtopology m) + (INTERS {UNIONS {mtopology m closure_of c n i | i | + i <= N n} | n IN (:num)})`, + REPEAT GEN_TAC THEN STRIP_TAC THEN ABBREV_TAC `KK = \n:num. UNIONS + {mtopology m closure_of (c:num->num->A->bool) n i | i | i <= N n}` THEN + ABBREV_TAC `K:A->bool = INTERS {(KK:num->A->bool) n | n IN (:num)}` THEN + (* Step 1: closure SUBSET mspace m *) SUBGOAL_THEN + `!n i. (mtopology m closure_of (c:num->num->A->bool) n i) SUBSET mspace m` + ASSUME_TAC THENL + [MESON_TAC[CLOSURE_OF_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + (* Step 2: finiteness of the index sets *) SUBGOAL_THEN + `!n. FINITE {mtopology m closure_of (c:num->num->A->bool) n i | i | + i <= N n}` + ASSUME_TAC THENL [GEN_TAC THEN ONCE_REWRITE_TAC[SIMPLE_IMAGE_GEN] THEN + MATCH_MP_TAC FINITE_IMAGE THEN REWRITE_TAC[FINITE_NUMSEG_LE]; ALL_TAC] THEN + (* Step 3: KK n SUBSET mspace m *) + SUBGOAL_THEN `!n. (KK:num->A->bool) n SUBSET mspace m` ASSUME_TAC THENL + [GEN_TAC THEN EXPAND_TAC "KK" THEN + REWRITE_TAC[UNIONS_SUBSET; IN_ELIM_THM] THEN + REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Step 4: K SUBSET mspace m *) + SUBGOAL_THEN `(K:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN MATCH_MP_TAC(SET_RULE + `!t:A->bool. t IN s /\ t SUBSET u ==> INTERS s SUBSET u`) THEN + EXISTS_TAC `(KK:num->A->bool) 0` THEN REWRITE_TAC[IN_ELIM_THM] THEN + CONJ_TAC THENL + [EXISTS_TAC `0` THEN REWRITE_TAC[IN_UNIV]; ASM_REWRITE_TAC[]]; + ALL_TAC] THEN (* Step 5: KK n is closed *) + SUBGOAL_THEN `!n. closed_in (mtopology m) ((KK:num->A->bool) n)` + ASSUME_TAC THENL [GEN_TAC THEN EXPAND_TAC "KK" THEN + MATCH_MP_TAC CLOSED_IN_UNIONS THEN ONCE_REWRITE_TAC[SIMPLE_IMAGE_GEN] THEN + ASM_SIMP_TAC[FINITE_IMAGE; FINITE_NUMSEG_LE; + FORALL_IN_IMAGE; CLOSED_IN_CLOSURE_OF]; ALL_TAC] THEN + (* Step 6: K is closed *) + SUBGOAL_THEN `closed_in (mtopology m) (K:A->bool)` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN MATCH_MP_TAC CLOSED_IN_INTERS THEN CONJ_TAC THENL + [REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + EXISTS_TAC `(KK:num->A->bool) 0` THEN + EXISTS_TAC `0` THEN REWRITE_TAC[IN_UNIV]; + REWRITE_TAC[IN_ELIM_THM] THEN REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[]]; + ALL_TAC] THEN (* Step 7: mcomplete(submetric m K) *) + SUBGOAL_THEN `mcomplete (submetric m (K:A->bool))` ASSUME_TAC THENL + [MATCH_MP_TAC CLOSED_IN_MCOMPLETE_IMP_MCOMPLETE THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN (* Step 8: K SUBSET KK n for all n *) + SUBGOAL_THEN `!n. (K:A->bool) SUBSET (KK:num->A->bool) n` + ASSUME_TAC THENL [GEN_TAC THEN EXPAND_TAC "K" THEN MATCH_MP_TAC(SET_RULE + `(t:A->bool) IN s ==> INTERS s SUBSET t`) THEN + REWRITE_TAC[IN_ELIM_THM] THEN EXISTS_TAC `n:num` THEN REWRITE_TAC[IN_UNIV]; + ALL_TAC] THEN (* Step 9: c n i is mbounded *) + SUBGOAL_THEN `!n i. i <= N n ==> mbounded m ((c:num->num->A->bool) n i)` + ASSUME_TAC THENL [REPEAT STRIP_TAC THEN + ASM_CASES_TAC `(c:num->num->A->bool) n i = {}` THENL + [ASM_REWRITE_TAC[MBOUNDED_EMPTY]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + DISCH_THEN(X_CHOOSE_TAC `z:A`) THEN REWRITE_TAC[mbounded] THEN + EXISTS_TAC `z:A` THEN EXISTS_TAC `inv(&(n + 1))` THEN + REWRITE_TAC[SUBSET; IN_MCBALL] THEN X_GEN_TAC `w:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(z:A) IN mspace m /\ (w:A) IN mspace m` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LT_IMP_LE THEN ASM_MESON_TAC[]; + ALL_TAC] THEN (* Step 10: mdiameter(closure c n i) <= inv(n+1) *) + SUBGOAL_THEN `!n i. i <= N n ==> mdiameter m (mtopology m closure_of + (c:num->num->A->bool) n i) <= inv(&(n + 1))` + ASSUME_TAC THENL [REPEAT STRIP_TAC THEN SUBGOAL_THEN + `mdiameter m (mtopology m closure_of (c:num->num->A->bool) n i) = + mdiameter m (c n i)` SUBST1_TAC THENL + [MATCH_MP_TAC MDIAMETER_CLOSURE THEN ASM_SIMP_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC MDIAMETER_LE THEN REPEAT CONJ_TAC THENL [ASM_SIMP_TAC[]; + DISJ2_TAC THEN MATCH_MP_TAC REAL_LT_IMP_LE THEN + MATCH_MP_TAC REAL_LT_INV THEN REWRITE_TAC[REAL_OF_NUM_LT] THEN ARITH_TAC; + REPEAT STRIP_TAC THEN MATCH_MP_TAC REAL_LT_IMP_LE THEN ASM_MESON_TAC[]]; + ALL_TAC] THEN (* Step 11: totally_bounded_in m K *) + SUBGOAL_THEN `totally_bounded_in m (K:A->bool)` ASSUME_TAC THENL + [REWRITE_TAC[totally_bounded_in] THEN X_GEN_TAC `e:real` THEN DISCH_TAC THEN + (* Choose n with inv(n+1) < e *) + MP_TAC(SPEC `e:real` REAL_ARCH_INV) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `nn:num` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `inv(&((nn:num) + 1)) < e` ASSUME_TAC THENL + [MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `inv(&nn)` THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LE_INV2 THEN CONJ_TAC THENL + [ASM_SIMP_TAC[REAL_OF_NUM_LT; ARITH_RULE `~(nn = 0) ==> 0 < nn`]; + REWRITE_TAC[REAL_OF_NUM_LE] THEN ARITH_TAC]; ALL_TAC] THEN + (* For each closure(c nn i) that intersects K, pick representative *) + SUBGOAL_THEN `?rep:num->A. !i. i <= N(nn:num) + ==> rep i IN (K:A->bool) INTER (mtopology m closure_of + (c:num->num->A->bool) nn i) \/ K INTER + (mtopology m closure_of c nn i) = {}` + (X_CHOOSE_TAC `rep:num->A`) THENL + [REWRITE_TAC[GSYM SKOLEM_THM] THEN X_GEN_TAC `i:num` THEN + ASM_CASES_TAC `(K:A->bool) INTER (mtopology m closure_of + (c:num->num->A->bool) nn i) = {}` THENL + [EXISTS_TAC `a:A` THEN ASM_MESON_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + REWRITE_TAC[IN_INTER] THEN + DISCH_THEN(X_CHOOSE_THEN `z:A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `z:A` THEN DISCH_TAC THEN DISJ1_TAC THEN + ASM_REWRITE_TAC[IN_INTER]; ALL_TAC] THEN + EXISTS_TAC `IMAGE (rep:num->A) {i | i <= N(nn:num) /\ + ~((K:A->bool) INTER (mtopology m closure_of + (c:num->num->A->bool) nn i) = {})}` THEN + REPEAT CONJ_TAC THENL [(* FINITE *) + MATCH_MP_TAC FINITE_IMAGE THEN MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `{i:num | i <= N(nn:num)}` THEN + REWRITE_TAC[FINITE_NUMSEG_LE] THEN SET_TAC[]; (* k SUBSET K *) + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM] THEN + X_GEN_TAC `i:num` THEN STRIP_TAC THEN + SUBGOAL_THEN `(rep:num->A) i IN (K:A->bool) INTER + (mtopology m closure_of (c:num->num->A->bool) nn i)` + MP_TAC THENL [FIRST_X_ASSUM(MP_TAC o SPEC `i:num`) THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + REWRITE_TAC[IN_INTER] THEN SIMP_TAC[]]; + (* K SUBSET UNIONS{mball(rep i, e) | ...} *) + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + (* x IN K, so x IN KK nn *) + SUBGOAL_THEN `(x:A) IN (KK:num->A->bool) nn` MP_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + EXPAND_TAC "KK" THEN REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `s':A->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_THEN `i:num` STRIP_ASSUME_TAC) + ASSUME_TAC)) THEN + ASM_REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `mball m ((rep:num->A) i, e)` THEN CONJ_TAC THENL + [EXISTS_TAC `(rep:num->A) i` THEN CONJ_TAC THENL + [REWRITE_TAC[IN_IMAGE; IN_ELIM_THM] THEN EXISTS_TAC `i:num` THEN + ASM_REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + EXISTS_TAC `x:A` THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `(x:A) IN (s':A->bool)` THEN ASM_REWRITE_TAC[]; + REFL_TAC]; ALL_TAC] THEN REWRITE_TAC[IN_MBALL] THEN + (* x IN closure(c nn i) *) + SUBGOAL_THEN `(x:A) IN mtopology m closure_of (c:num->num->A->bool) nn i` + ASSUME_TAC THENL + [UNDISCH_TAC `(x:A) IN (s':A->bool)` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN (* rep i IN closure(c nn i) *) + SUBGOAL_THEN `(rep:num->A) i IN + mtopology m closure_of (c:num->num->A->bool) nn i` + ASSUME_TAC THENL [SUBGOAL_THEN `(rep:num->A) i IN (K:A->bool) INTER + (mtopology m closure_of (c:num->num->A->bool) nn i)` + (fun th -> REWRITE_TAC[REWRITE_RULE[IN_INTER] th]) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `i:num`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC(TAUT `~b ==> a \/ b ==> a`) THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + EXISTS_TAC `x:A` THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* membership in mspace m *) + SUBGOAL_THEN `(rep:num->A) i IN mspace m /\ (x:A) IN mspace m` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[CLOSURE_OF_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY; SUBSET]; + ALL_TAC] THEN ASM_REWRITE_TAC[] THEN (* mdist m (rep i, x) < e *) + MATCH_MP_TAC REAL_LET_TRANS THEN + EXISTS_TAC `inv(&(nn + 1))` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `mdiameter m (mtopology m closure_of + (c:num->num->A->bool) nn i)` THEN CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN CONJ_TAC THENL + [ASM_SIMP_TAC[MBOUNDED_CLOSURE_OF]; ASM_REWRITE_TAC[]]; + ASM_SIMP_TAC[]]]; ALL_TAC] THEN + (* Conclusion: first substitute K for the INTERS expression *) SUBGOAL_THEN + `INTERS {UNIONS {mtopology m closure_of (c:num->num->A->bool) n i | i | + i <= N n} | n IN (:num)} = K` SUBST1_TAC THENL + [EXPAND_TAC "K" THEN EXPAND_TAC "KK" THEN REWRITE_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[COMPACT_IN_SUBSPACE; TOPSPACE_MTOPOLOGY] THEN SUBGOAL_THEN + `subtopology (mtopology m) (K:A->bool) = mtopology(submetric m K)` + SUBST1_TAC THENL [ASM_SIMP_TAC[MTOPOLOGY_SUBMETRIC; + SET_RULE `(K:A->bool) SUBSET t ==> t INTER K = K`]; ALL_TAC] THEN - SIMP_TAC[HOMOTOPIC_WITH] THEN - EXISTS_TAC `(\x i. x i / sqrt(sum(1..n+1) (\j. x j pow 2))) o - (\(t,q) i. (&1 - t) * q i + t * p i)` THEN - CONJ_TAC THENL - [MATCH_MP_TAC CONTINUOUS_MAP_COMPOSE; - UNDISCH_TAC `p IN topspace(nsphere n)` THEN - REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; NSPHERE; o_THM] THEN - REWRITE_TAC[REAL_SUB_REFL; REAL_MUL_LID; REAL_MUL_LZERO; REAL_SUB_RZERO; - REAL_ADD_LID; REAL_ADD_RID; IN_INTER; IN_ELIM_THM] THEN - SIMP_TAC[SQRT_1; REAL_DIV_1; ETA_AX]] THEN - EXISTS_TAC `subtopology (euclidean_space (n + 1)) - {x | x k >= &0 /\ ~(!i. i IN 1..n+1 ==> x i = &0)}` THEN - REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; euclidean_space] THEN - REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN REPEAT CONJ_TAC THENL - [X_GEN_TAC `i:num` THEN REWRITE_TAC[LAMBDA_PAIR] THEN - MATCH_MP_TAC CONTINUOUS_MAP_REAL_ADD THEN CONJ_TAC THEN - MATCH_MP_TAC CONTINUOUS_MAP_REAL_MUL THEN - REWRITE_TAC[CONTINUOUS_MAP_OF_FST; CONTINUOUS_MAP_OF_SND] THEN - SIMP_TAC[GSYM SUBTOPOLOGY_CROSS; CONTINUOUS_MAP_FROM_SUBTOPOLOGY; - CONTINUOUS_MAP_FST] THEN - REPEAT CONJ_TAC THEN DISJ2_TAC THEN - MATCH_MP_TAC CONTINUOUS_MAP_FROM_SUBTOPOLOGY THEN - SIMP_TAC[CONTINUOUS_MAP_REAL_SUB; CONTINUOUS_MAP_REAL_CONST; - CONTINUOUS_MAP_ID] THEN - REWRITE_TAC[NSPHERE] THEN MATCH_MP_TAC CONTINUOUS_MAP_FROM_SUBTOPOLOGY THEN - SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV]; - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_SUBTOPOLOGY; NSPHERE; - FORALL_PAIR_THM; TOPSPACE_PROD_TOPOLOGY; IN_CROSS; - IN_INTER; IN_ELIM_THM] THEN - EXPAND_TAC "p" THEN SIMP_TAC[REAL_MUL_RZERO; REAL_ADD_LID; REAL_ENTIRE] THEN - ASM_MESON_TAC[]; - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_PROD_TOPOLOGY] THEN - REWRITE_TAC[FORALL_PAIR_THM; IN_CROSS; TOPSPACE_SUBTOPOLOGY] THEN - REWRITE_TAC[TOPSPACE_EUCLIDEANREAL; IN_INTER; IN_UNIV] THEN - MAP_EVERY X_GEN_TAC [`t:real`; `x:num->real`] THEN - REWRITE_TAC[IN_REAL_INTERVAL; IN_ELIM_THM] THEN STRIP_TAC THEN - REWRITE_TAC[real_ge] THEN CONJ_TAC THENL - [EXPAND_TAC "p" THEN REWRITE_TAC[REAL_MUL_RID] THEN - MATCH_MP_TAC REAL_LE_ADD THEN ASM_REWRITE_TAC[] THEN - MATCH_MP_TAC REAL_LE_MUL THEN ASM_REAL_ARITH_TAC; - ASM_CASES_TAC `t = &0` THENL - [ASM_REWRITE_TAC[REAL_SUB_RZERO; REAL_MUL_LID; REAL_MUL_LZERO] THEN - REWRITE_TAC[REAL_ADD_RID] THEN DISCH_TAC THEN - UNDISCH_TAC `x IN topspace(nsphere n)` THEN - ASM_SIMP_TAC[NSPHERE; TOPSPACE_SUBTOPOLOGY; IN_INTER; IN_ELIM_THM] THEN - CONV_TAC REAL_RAT_REDUCE_CONV THEN REWRITE_TAC[SUM_0] THEN - CONV_TAC REAL_RAT_REDUCE_CONV; - DISCH_THEN(MP_TAC o SPEC `k:num`) THEN ASM_REWRITE_TAC[] THEN - EXPAND_TAC "p" THEN REWRITE_TAC[] THEN MATCH_MP_TAC(REAL_ARITH - `&0 <= x /\ &0 <= t /\ ~(t = &0) ==> ~(x + t * &1 = &0)`) THEN - ASM_REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LE_MUL THEN - ASM_REAL_ARITH_TAC]]; - ALL_TAC; - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_SUBTOPOLOGY] THEN - REWRITE_TAC[IN_INTER; IN_ELIM_THM; real_ge] THEN - REPEAT STRIP_TAC THEN MATCH_MP_TAC REAL_LE_DIV THEN - ASM_REWRITE_TAC[] THEN MATCH_MP_TAC SQRT_POS_LE THEN - MATCH_MP_TAC SUM_POS_LE_NUMSEG THEN - REWRITE_TAC[REAL_LE_POW_2]] THEN - REWRITE_TAC[NSPHERE; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN CONJ_TAC THENL - [REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN - X_GEN_TAC `i:num` THEN MATCH_MP_TAC CONTINUOUS_MAP_REAL_DIV THEN - SIMP_TAC[CONTINUOUS_MAP_FROM_SUBTOPOLOGY; - CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV] THEN + ASM_REWRITE_TAC[COMPACT_SPACE_EQ_MCOMPLETE_TOTALLY_BOUNDED_IN] THEN + SUBGOAL_THEN `mspace(submetric m (K:A->bool)) = K` + (fun th -> REWRITE_TAC[th]) THENL + [REWRITE_TAC[SUBMETRIC] THEN ASM SET_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[TOTALLY_BOUNDED_IN_ABSOLUTE]);; + +(* Helper: in a locally connected metric space, each point in an open set *) +(* has a connected open neighbourhood with closure inside the open set and *) +(* small diameter. *) + +let OPEN_CONNECTED_FINE_COVER = prove + (`!m:A metric u e. + locally_connected_space (mtopology m) /\ + open_in (mtopology m) u /\ &0 < e ==> !x. x IN u + ==> ?v. open_in (mtopology m) v /\ connected_in (mtopology m) v /\ + x IN v /\ v SUBSET u /\ + (mtopology m closure_of v) SUBSET u /\ + !y z. y IN v /\ z IN v ==> mdist m (y:A,z) < e`, + REPEAT GEN_TAC THEN STRIP_TAC THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN mspace m` ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN ASM SET_TAC[]; ALL_TAC] THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [OPEN_IN_MTOPOLOGY]) THEN + DISCH_THEN(MP_TAC o SPEC `x:A` o CONJUNCT2) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `r:real` STRIP_ASSUME_TAC) THEN + ABBREV_TAC `d = min r e / &3` THEN + SUBGOAL_THEN `&0 < d /\ d < r /\ &2 * d < e` STRIP_ASSUME_TAC THENL + [EXPAND_TAC "d" THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `mball m (x:A,d) SUBSET u` ASSUME_TAC THENL + [TRANS_TAC SUBSET_TRANS `mball m (x:A,r)` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC MBALL_SUBSET_CONCENTRIC THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [LOCALLY_CONNECTED_SPACE]) THEN + DISCH_THEN(MP_TAC o SPECL [`mball m (x:A,d)`; `x:A`]) THEN + ASM_SIMP_TAC[OPEN_IN_MBALL; CENTRE_IN_MBALL] THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `v:A->bool` THEN ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [ASM SET_TAC[]; + TRANS_TAC SUBSET_TRANS `mcball m (x:A,d)` THEN CONJ_TAC THENL + [MATCH_MP_TAC CLOSURE_OF_MINIMAL THEN CONJ_TAC THENL + [TRANS_TAC SUBSET_TRANS `mball m (x:A,d)` THEN + ASM_REWRITE_TAC[MBALL_SUBSET_MCBALL]; REWRITE_TAC[CLOSED_IN_MCBALL]]; + TRANS_TAC SUBSET_TRANS `mball m (x:A,r)` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC MCBALL_SUBSET_MBALL_CONCENTRIC THEN ASM_REWRITE_TAC[]]; + REPEAT STRIP_TAC THEN + SUBGOAL_THEN `(y:A) IN mball m (x,d) /\ (z:A) IN mball m (x,d)` MP_TAC + THENL [ASM SET_TAC[]; REWRITE_TAC[IN_MBALL]] THEN STRIP_TAC THEN + TRANS_TAC REAL_LET_TRANS `mdist m (y:A,x) + mdist m (x,z)` THEN + CONJ_TAC THENL [MATCH_MP_TAC MDIST_TRIANGLE THEN + ASM_MESON_TAC[SUBSET; MBALL_SUBSET_MSPACE]; + TRANS_TAC REAL_LT_TRANS `d + d:real` THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_LT_ADD2 THEN CONJ_TAC THENL + [ASM_MESON_TAC[MDIST_SYM; MBALL_SUBSET_MSPACE; SUBSET]; + ASM_REWRITE_TAC[]]; ASM_REAL_ARITH_TAC]]]);; + +(* Helper: chain within a single open connected set, with closures inside *) + +let CHAIN_IN_OPEN_CONNECTED_SET = prove + (`!m:A metric g e a' b'. + locally_connected_space (mtopology m) /\ + open_in (mtopology m) g /\ connected_in (mtopology m) g /\ + a' IN g /\ b' IN g /\ &0 < e + ==> ?c' M'. (!i. i <= M' ==> open_in (mtopology m) (c' i) /\ + connected_in (mtopology m) (c' i) /\ + (mtopology m closure_of c' i) SUBSET g) /\ + a' IN c' 0 /\ b' IN c' M' /\ + (!i. i < M' ==> ~(c' i INTER c'(SUC i) = {})) /\ + (!i. i <= M' ==> + !x y. x IN c' i /\ y IN c' i ==> mdist m (x:A,y) < e)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN `connected_space (subtopology (mtopology m) (g:A->bool))` + ASSUME_TAC THENL [ASM_SIMP_TAC[CONNECTED_SPACE_SUBTOPOLOGY]; ALL_TAC] THEN + SUBGOAL_THEN `(g:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + MP_TAC(ISPECL [`subtopology (mtopology m) (g:A->bool)`; + `{v:A->bool | open_in (mtopology m) v /\ connected_in (mtopology m) v /\ + v SUBSET g /\ (mtopology m closure_of v) SUBSET g /\ + !x y. x IN v /\ y IN v ==> mdist m (x:A,y) < e}`; + `a':A`; `b':A`] CHAIN_FROM_OPEN_COVER) THEN + ASM_REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; TOPSPACE_MTOPOLOGY] THEN ANTS_TAC THENL + [CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN CONJ_TAC THENL + [(* Cover property *) + X_GEN_TAC `x:A` THEN REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + STRIP_TAC THEN MP_TAC(ISPECL [`m:A metric`; `g:A->bool`; `e:real`] + OPEN_CONNECTED_FINE_COVER) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `v:A->bool` THEN ASM_REWRITE_TAC[]; (* Open in subtopology *) + REWRITE_TAC[IN_ELIM_THM] THEN REPEAT STRIP_TAC THEN + ASM_SIMP_TAC[OPEN_IN_OPEN_SUBTOPOLOGY]]; REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `c':num->A->bool` + (X_CHOOSE_THEN `M':num` STRIP_ASSUME_TAC)) THEN + MAP_EVERY EXISTS_TAC [`c':num->A->bool`; `M':num`] THEN ASM_MESON_TAC[]]);; + +(* Helper: chain refinement step - refine a coarse chain to a finer one *) +let CHAIN_REFINEMENT_STEP = prove + (`!m:A metric (g:num->A->bool) M e a b. + locally_connected_space (mtopology m) /\ + (!i. i <= M ==> open_in (mtopology m) (g i) /\ + connected_in (mtopology m) (g i)) /\ + a IN g 0 /\ b IN g M /\ (!i. i < M ==> ~(g i INTER g(SUC i) = {})) /\ + &0 < e + ==> ?g' M'. (!i. i <= M' ==> open_in (mtopology m) (g' i) /\ + connected_in (mtopology m) (g' i)) /\ + a IN g' 0 /\ b IN g' M' /\ + (!i. i < M' ==> ~(g' i INTER g'(SUC i) = {})) /\ (!i. i <= M' ==> + !x y. x IN g' i /\ y IN g' i ==> mdist m (x:A,y) < e) /\ + (!j. j <= M' ==> ?i. i <= M /\ + (mtopology m closure_of g' j) SUBSET g i) /\ + (?ff. (!j. j <= M' ==> ff j <= M /\ + (mtopology m closure_of g' j) SUBSET g (ff j)) /\ + (!j1 j2. j1 <= j2 /\ j2 <= M' ==> ff j1 <= ff j2) /\ + (!i. i <= M ==> ?j. j <= M' /\ ff j = i)) /\ + (!i. i <= M ==> ?j. j <= M' /\ + (mtopology m closure_of g' j) SUBSET g i)`, + GEN_TAC THEN GEN_TAC THEN INDUCT_TAC THENL + [(* Base case: M = 0, single link *) REPEAT STRIP_TAC THEN + MP_TAC(ISPECL [`m:A metric`; `(g:num->A->bool) 0`; `e:real`; `a:A`; `b:A`] + CHAIN_IN_OPEN_CONNECTED_SET) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[LE_0]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `c':num->A->bool` + (X_CHOOSE_THEN `M':num` STRIP_ASSUME_TAC)) THEN + MAP_EVERY EXISTS_TAC [`c':num->A->bool`; `M':num`] THEN + ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL [ASM_MESON_TAC[]; + X_GEN_TAC `j:num` THEN DISCH_TAC THEN + EXISTS_TAC `0` THEN REWRITE_TAC[LE_0] THEN ASM_MESON_TAC[]; + EXISTS_TAC `\j:num. 0` THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + REWRITE_TAC[LE_0] THEN CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + X_GEN_TAC `i':num` THEN DISCH_TAC THEN + EXISTS_TAC `0` THEN REWRITE_TAC[LE_0] THEN ASM_ARITH_TAC; + X_GEN_TAC `i:num` THEN REWRITE_TAC[LE] THEN DISCH_TAC THEN + EXISTS_TAC `0` THEN ASM_REWRITE_TAC[LE_0] THEN ASM_MESON_TAC[LE_0]]; + (* Inductive step: M -> SUC M *) REPEAT STRIP_TAC THEN + (* Pick bridge point q in g M INTER g (SUC M) *) + SUBGOAL_THEN `~((g:num->A->bool) M INTER g(SUC M) = {})` + MP_TAC THENL [FIRST_X_ASSUM MATCH_MP_TAC THEN ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + DISCH_THEN(X_CHOOSE_THEN `q:A` STRIP_ASSUME_TAC) THEN + (* Apply IH to chain g 0,...,g M from a to q *) + FIRST_X_ASSUM(MP_TAC o SPECL [`e:real`; `a:A`; `q:A`]) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [X_GEN_TAC `i:num` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `i:num`) THEN + ASM_SIMP_TAC[ARITH_RULE `i <= M ==> i <= SUC M`]; + X_GEN_TAC `i:num` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `i:num`) THEN + ASM_SIMP_TAC[ARITH_RULE `i < M ==> i < SUC M`]]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `c1:num->A->bool` + (X_CHOOSE_THEN `M1:num` STRIP_ASSUME_TAC)) THEN + (* Build chain within g(SUC M) from q to b *) + MP_TAC(ISPECL [`m:A metric`; `(g:num->A->bool) (SUC M)`; `e:real`; + `q:A`; `b:A`] + CHAIN_IN_OPEN_CONNECTED_SET) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[LE_REFL]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `c2:num->A->bool` + (X_CHOOSE_THEN `M2:num` STRIP_ASSUME_TAC)) THEN + (* Pre-extract c2 closure property for easier use later *) + SUBGOAL_THEN `!k:num. k <= M2 ==> + (mtopology m closure_of (c2:num->A->bool) k) SUBSET + (g:num->A->bool) (SUC M)` ASSUME_TAC THENL + [X_GEN_TAC `k:num` THEN DISCH_TAC THEN SUBGOAL_THEN + `open_in (mtopology m) ((c2:num->A->bool) k) /\ + connected_in (mtopology m) ((c2:num->A->bool) k) /\ + (mtopology m closure_of (c2:num->A->bool) k) SUBSET + (g:num->A->bool) (SUC M)` MP_TAC THENL [ASM_MESON_TAC[]; + DISCH_THEN(ACCEPT_TAC o CONJUNCT2 o CONJUNCT2)]; ALL_TAC] THEN + (* Concatenation: combine c1 (a to q) and c2 (q to b) *) + MAP_EVERY EXISTS_TAC [`\i:num. if i <= M1 then (c1:num->A->bool) i + else (c2:num->A->bool) (i - (M1 + 1))`; `M1 + M2 + 1`] THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN (* 1: open_in and connected_in *) + CONJ_TAC THENL [X_GEN_TAC `j:num` THEN DISCH_TAC THEN + ASM_CASES_TAC `j:num <= M1` THEN ASM_REWRITE_TAC[] THENL + [ASM_MESON_TAC[]; SUBGOAL_THEN `j - (M1 + 1) <= M2` ASSUME_TAC THENL + [ASM_ARITH_TAC; ASM_MESON_TAC[]]]; ALL_TAC] THEN (* 2: a IN g' 0 *) + CONJ_TAC THENL [ASM_REWRITE_TAC[LE_0]; ALL_TAC] THEN (* 3: b IN g' M' *) + CONJ_TAC THENL [SIMP_TAC[ARITH_RULE `~(M1 + M2 + 1 <= M1)`; + ARITH_RULE `(M1 + M2 + 1) - (M1 + 1) = M2`] THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN (* 4: consecutive overlap *) + CONJ_TAC THENL [X_GEN_TAC `j:num` THEN DISCH_TAC THEN + ASM_CASES_TAC `j:num < M1` THENL [SUBGOAL_THEN `j <= M1 /\ SUC j <= M1` + (fun th -> REWRITE_TAC[th]) THENL [ASM_ARITH_TAC; + REWRITE_TAC[GSYM IN_INTER; MEMBER_NOT_EMPTY] THEN + FIRST_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC]; + ASM_CASES_TAC `j:num = M1` THENL [ASM_REWRITE_TAC[LE_REFL] THEN + SIMP_TAC[ARITH_RULE `~(SUC M1 <= M1)`; + ARITH_RULE `SUC M1 - (M1 + 1) = 0`] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + EXISTS_TAC `q:A` THEN ASM_REWRITE_TAC[]; + SUBGOAL_THEN `~(j <= M1) /\ ~(SUC j <= M1)` + (fun th -> REWRITE_TAC[th]) THENL [ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `SUC j - (M1 + 1) = SUC(j - (M1 + 1))` + (fun th -> REWRITE_TAC[th]) THENL [ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `j - (M1 + 1) < M2` ASSUME_TAC THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[GSYM IN_INTER; MEMBER_NOT_EMPTY] THEN + FIRST_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC]]; ALL_TAC] THEN + (* 5: diameter bound *) + CONJ_TAC THENL [X_GEN_TAC `j:num` THEN DISCH_TAC THEN + ASM_CASES_TAC `j:num <= M1` THEN ASM_REWRITE_TAC[] THENL + [ASM_MESON_TAC[]; SUBGOAL_THEN `j - (M1 + 1) <= M2` ASSUME_TAC THENL + [ASM_ARITH_TAC; ASM_MESON_TAC[]]]; ALL_TAC] THEN + (* 6: forward refinement *) + CONJ_TAC THENL [X_GEN_TAC `j:num` THEN DISCH_TAC THEN + ASM_CASES_TAC `j:num <= M1` THENL [ASM_REWRITE_TAC[] THEN SUBGOAL_THEN + `?i. i <= M /\ (mtopology m closure_of (c1:num->A->bool) j) SUBSET + (g:num->A->bool) i` MP_TAC THENL [ASM_MESON_TAC[]; + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `i':num` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN ASM_ARITH_TAC]; + ASM_REWRITE_TAC[] THEN + EXISTS_TAC `SUC M` THEN REWRITE_TAC[LE_REFL] THEN + SUBGOAL_THEN `j - (M1 + 1) <= M2` ASSUME_TAC THENL + [ASM_ARITH_TAC; ASM_MESON_TAC[]]]; ALL_TAC] THEN + (* 6b: monotone surjective forward refinement *) CONJ_TAC THENL + [EXISTS_TAC `\j:num. if j <= M1 then (ff:num->num) j else SUC M` THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN CONJ_TAC THENL + [X_GEN_TAC `j:num` THEN DISCH_TAC THEN + ASM_CASES_TAC `j:num <= M1` THEN ASM_REWRITE_TAC[] THENL + [ASM_MESON_TAC[ARITH_RULE `x <= M ==> x <= SUC M`]; + REWRITE_TAC[LE_REFL] THEN + SUBGOAL_THEN `j - (M1 + 1) <= M2` ASSUME_TAC THENL + [ASM_ARITH_TAC; ASM_MESON_TAC[]]]; ALL_TAC] THEN CONJ_TAC THENL + [MAP_EVERY X_GEN_TAC [`j1:num`; `j2:num`] THEN STRIP_TAC THEN + ASM_CASES_TAC `j2:num <= M1` THENL [SUBGOAL_THEN `j1:num <= M1` + (fun th -> REWRITE_TAC[th]) THENL [ASM_ARITH_TAC; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + ASM_CASES_TAC `j1:num <= M1` THENL [ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[ARITH_RULE `x <= M ==> x <= SUC M`]; + ASM_REWRITE_TAC[LE_REFL]]]; ALL_TAC] THEN (* Surjectivity of ff *) + X_GEN_TAC `ii':num` THEN DISCH_TAC THEN + ASM_CASES_TAC `ii':num <= M` THENL + [SUBGOAL_THEN `?j0. j0 <= M1 /\ (ff:num->num) j0 = ii'` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + EXISTS_TAC `j0:num` THEN ASM_REWRITE_TAC[] THEN ASM_ARITH_TAC; + SUBGOAL_THEN `ii' = SUC M` SUBST_ALL_TAC THENL + [ASM_ARITH_TAC; ALL_TAC] THEN EXISTS_TAC `SUC M1` THEN + REWRITE_TAC[ARITH_RULE `~(SUC n <= n)`] THEN ASM_ARITH_TAC]; + ALL_TAC] THEN (* 7: backward refinement *) + X_GEN_TAC `ii:num` THEN DISCH_TAC THEN ASM_CASES_TAC `ii:num <= M` THENL + [SUBGOAL_THEN `?j. j <= M1 /\ + (mtopology m closure_of (c1:num->A->bool) j) SUBSET + (g:num->A->bool) ii` MP_TAC THENL [ASM_MESON_TAC[]; + DISCH_THEN(X_CHOOSE_THEN `j0:num` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `j0:num` THEN ASM_REWRITE_TAC[] THEN ASM_ARITH_TAC]; + SUBGOAL_THEN `ii = SUC M` SUBST_ALL_TAC THENL + [ASM_ARITH_TAC; ALL_TAC] THEN EXISTS_TAC `M1 + 1` THEN + SIMP_TAC[ARITH_RULE `~(M1 + 1 <= M1)`; + ARITH_RULE `(M1 + 1) - (M1 + 1) = 0`] THEN + CONJ_TAC THENL [ASM_ARITH_TAC; ASM_MESON_TAC[LE_0]]]]);; + +(* Helper: chain hierarchy construction via DEPENDENT_CHOICE. *) +(* Builds a sequence of increasingly fine chains from a to b. *) + +let CHAIN_HIERARCHY = prove + (`!m:A metric a b. + connected_space (mtopology m) /\ + locally_connected_space (mtopology m) /\ a IN mspace m /\ b IN mspace m + ==> ?c (N:num->num). (!n i. i <= N n + ==> open_in (mtopology m) ((c:num->num->A->bool) n i)) /\ + (!n i. i <= N n ==> connected_in (mtopology m) (c n i)) /\ + (!n. (a:A) IN c n 0) /\ (!n. b IN c n (N n)) /\ + (!n i. i < N n ==> ~(c n i INTER c n (SUC i) = {})) /\ + (!n i. i <= N n ==> !x y. x IN c n i /\ y IN c n i + ==> mdist m (x:A,y) < inv(&(n + 1))) /\ + (!n j. j <= N(SUC n) ==> ?i. i <= N n /\ + (mtopology m closure_of c (SUC n) j) SUBSET c n i) /\ + (!n i. i <= N n ==> ?j. j <= N(SUC n) /\ (mtopology m closure_of + (c:num->num->A->bool) (SUC n) j) SUBSET c n i) /\ + (!n. ?ff. (!j. j <= N(SUC n) ==> ff j <= N n /\ + (mtopology m closure_of + (c:num->num->A->bool) (SUC n) j) SUBSET + c n (ff j)) /\ + (!j1 j2. j1 <= j2 /\ j2 <= N(SUC n) ==> ff j1 <= ff j2) /\ + (!i. i <= N n ==> ?j. j <= N(SUC n) /\ ff j = i))`, + REPEAT STRIP_TAC THEN MP_TAC(ISPECL + [`\n (p:num#(num->A->bool)). (!i. i <= FST p + ==> open_in (mtopology m) (SND p i) /\ + connected_in (mtopology m) (SND p i)) /\ + (a:A) IN SND p 0 /\ b IN SND p (FST p) /\ + (!i. i < FST p ==> ~(SND p i INTER SND p (SUC i) = {})) /\ + (!i. i <= FST p ==> !x y. x IN SND p i /\ y IN SND p i + ==> mdist m (x:A,y) < inv(&(n + 1)))`; + `\(n:num) (p1:num#(num->A->bool)) (p2:num#(num->A->bool)). + (?ff. (!j. j <= FST p2 ==> ff j <= FST p1 /\ + (mtopology m closure_of SND p2 j) SUBSET SND p1 (ff j)) /\ + (!j1 j2. j1 <= j2 /\ j2 <= FST p2 ==> ff j1 <= ff j2) /\ + (!i. i <= FST p1 ==> ?j. j <= FST p2 /\ ff j = i)) /\ + (!j. j <= FST p2 ==> ?i. i <= FST p1 /\ + (mtopology m closure_of SND p2 j) SUBSET SND p1 i) /\ + (!i. i <= FST p1 ==> ?j. j <= FST p2 /\ + (mtopology m closure_of SND p2 j) SUBSET SND p1 i)`] + DEPENDENT_CHOICE) THEN CONV_TAC(TOP_DEPTH_CONV BETA_CONV) THEN + REWRITE_TAC[FST; SND] THEN ANTS_TAC THENL + [CONJ_TAC THENL [(* Base case: exists initial chain at level 0 *) + SUBGOAL_THEN `open_in (mtopology m) (mspace m:A->bool) /\ + connected_in (mtopology m) (mspace m:A->bool)` + STRIP_ASSUME_TAC THENL [CONJ_TAC THENL + [MESON_TAC[OPEN_IN_TOPSPACE; TOPSPACE_MTOPOLOGY]; + ASM_MESON_TAC[CONNECTED_IN_TOPSPACE; TOPSPACE_MTOPOLOGY]]; + ALL_TAC] THEN + MP_TAC(ISPECL [`m:A metric`; `mspace m:A->bool`; `inv(&1)`; `a:A`; `b:A`] + CHAIN_IN_OPEN_CONNECTED_SET) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN CONV_TAC REAL_RAT_REDUCE_CONV; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `c0:num->A->bool` + (X_CHOOSE_THEN `M0:num` STRIP_ASSUME_TAC)) THEN + EXISTS_TAC `(M0:num, c0:num->A->bool)` THEN REWRITE_TAC[FST; SND] THEN + CONV_TAC NUM_REDUCE_CONV THEN ASM_MESON_TAC[]; + (* Step case: refine existing chain *) + MAP_EVERY X_GEN_TAC [`nn:num`; `xx:num#(num->A->bool)`] THEN + STRIP_TAC THEN MP_TAC(ISPECL [`m:A metric`; `SND(xx:num#(num->A->bool))`; + `FST(xx:num#(num->A->bool))`; `inv(&(SUC nn + 1))`; `a:A`; `b:A`] + CHAIN_REFINEMENT_STEP) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[REAL_LT_INV_EQ; REAL_OF_NUM_LT] THEN + ARITH_TAC; ALL_TAC] THEN DISCH_THEN(X_CHOOSE_THEN `g':num->A->bool` + (X_CHOOSE_THEN `MM:num` STRIP_ASSUME_TAC)) THEN + EXISTS_TAC `(MM:num, g':num->A->bool)` THEN + ASM_REWRITE_TAC[FST; SND] THEN + REPEAT CONJ_TAC THEN ASM_REWRITE_TAC[] THEN + TRY(EXISTS_TAC `ff:num->num` THEN + REPEAT CONJ_TAC THEN FIRST_ASSUM MATCH_ACCEPT_TAC) THEN + ASM_MESON_TAC[]]; ALL_TAC] THEN + (* Extract c and N from the DEPENDENT_CHOICE result *) + DISCH_THEN(X_CHOOSE_THEN `f:num->num#(num->A->bool)` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `\n. SND ((f:num->num#(num->A->bool)) n)` THEN + EXISTS_TAC `\n. FST ((f:num->num#(num->A->bool)) n)` THEN + CONV_TAC(TOP_DEPTH_CONV BETA_CONV) THEN + RULE_ASSUM_TAC(REWRITE_RULE[FORALL_AND_THM]) THEN + REPEAT(FIRST_X_ASSUM(CONJUNCTS_THEN ASSUME_TAC)) THEN REPEAT CONJ_TAC THEN + TRY(FIRST_ASSUM MATCH_ACCEPT_TAC) THEN ASM_MESON_TAC[]);; + +(* Helper lemma: construct a uniformly continuous function on dyadic *) +(* rationals D = {k/2^n | k <= 2^n} mapping into a complete connected *) +(* locally connected metric space. This is the core of the Menger theorem. *) + +let MCOMPLETE_DYADIC_APPROXIMATION = prove + (`!m:A metric a b. + mcomplete m /\ connected_space (mtopology m) /\ + locally_connected_space (mtopology m) /\ a IN mspace m /\ b IN mspace m + ==> ?f:real->A. f(&0) = a /\ f(&1) = b /\ + (!m' n. m' <= 2 EXP n ==> f(&m' / &2 pow n) IN mspace m) /\ + (!j. ?d. &0 < d /\ !n m1 m2. m1 <= 2 EXP n /\ m2 <= 2 EXP n /\ + abs(&m1 / &2 pow n - &m2 / &2 pow n) < d + ==> mdist m (f(&m1 / &2 pow n), + f(&m2 / &2 pow n):A) + < inv(&2 pow j))`, + let DYADIC_PRECISION_RAISE' = prove + (`!k n n'. n <= n' /\ k <= 2 EXP n + ==> k * 2 EXP (n' - n) <= 2 EXP n' /\ + &(k * 2 EXP (n' - n)) / &2 pow n' = + &k / &2 pow n`, + REPEAT GEN_TAC THEN + ONCE_REWRITE_TAC[MULT_SYM] THEN STRIP_TAC THEN CONJ_TAC THENL - [MATCH_MP_TAC CONTINUOUS_MAP_SQRT THEN - MATCH_MP_TAC CONTINUOUS_MAP_SUM THEN - REWRITE_TAC[FINITE_NUMSEG; IN_NUMSEG] THEN - REPEAT STRIP_TAC THEN MATCH_MP_TAC CONTINUOUS_MAP_REAL_POW THEN - REPEAT(MATCH_MP_TAC CONTINUOUS_MAP_FROM_SUBTOPOLOGY) THEN - SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV]; - REWRITE_TAC[SQRT_EQ_0; TOPSPACE_SUBTOPOLOGY; IN_INTER; IN_ELIM_THM]]; - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_SUBTOPOLOGY] THEN - SIMP_TAC[IN_INTER; IN_ELIM_THM; real_ge; IN_NUMSEG] THEN - REWRITE_TAC[real_div; REAL_MUL_LZERO; REAL_POW_MUL; SUM_RMUL] THEN - REWRITE_TAC[REAL_POW_INV; GSYM real_div] THEN - SIMP_TAC[SQRT_POW_2; SUM_POS_LE_NUMSEG; REAL_LE_POW_2] THEN - REWRITE_TAC[REAL_DIV_EQ_1]] THEN - REWRITE_TAC[IMP_CONJ; CONTRAPOS_THM] THEN - GEN_TAC THEN REPLICATE_TAC 3 DISCH_TAC THEN REWRITE_TAC[IN_NUMSEG] THEN - DISCH_THEN(MP_TAC o MATCH_MP (ONCE_REWRITE_RULE[IMP_CONJ_ALT] - SUM_POS_EQ_0_NUMSEG)) THEN - SIMP_TAC[REAL_POW_EQ_0; REAL_LE_POW_2; ARITH]);; + [TRANS_TAC LE_TRANS `2 EXP (n' - n) * 2 EXP n` THEN + ASM_REWRITE_TAC[LE_MULT_LCANCEL; GSYM EXP_ADD] THEN + ASM_SIMP_TAC[ARITH_RULE + `n <= n' ==> (n' - n) + n = n':num`; LE_REFL]; + REWRITE_TAC[GSYM REAL_OF_NUM_MUL; + GSYM REAL_OF_NUM_POW] THEN + ASM_SIMP_TAC[REAL_POW_SUB; + REAL_OF_NUM_EQ; ARITH_EQ] THEN + SIMP_TAC[REAL_LT_POW2; REAL_FIELD + `&0 < a /\ &0 < b + ==> (a / b * m) / a = m / b`]]) + and STEP_MONO_IMP_STRICT = prove + (`!(f:num->num). (!n. f(n) < f(SUC n)) + ==> !m n. m < n ==> f(m) < f(n)`, + GEN_TAC THEN DISCH_TAC THEN + MATCH_MP_TAC TRANSITIVE_STEPWISE_LT THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[LT_TRANS]) + and STEP_MONO_IMP_MONO = prove + (`!(f:num->num). (!n. f(n) < f(SUC n)) + ==> !m n. m <= n ==> f(m) <= f(n)`, + GEN_TAC THEN DISCH_TAC THEN + MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN + ASM_REWRITE_TAC[LE_REFL] THEN + ASM_MESON_TAC[LE_TRANS; LT_IMP_LE]) in + let STEP_MONO_IMP_UNBOUNDED = prove + (`!(f:num->num). (!n. f(n) < f(SUC n)) ==> !n. n <= f(n)`, + GEN_TAC THEN DISCH_TAC THEN MATCH_MP_TAC MONOTONE_BIGGER THEN + ASM_MESON_TAC[STEP_MONO_IMP_STRICT]) in + let ITERATED_REFINEMENT = prove + (`!(f:num->num) (g:num->num->B). (!n k. k <= 2 EXP f(n) + ==> g(SUC n)(2 EXP (f(SUC n) - f(n)) * k) = g(n) k) /\ + (!j1 j2. j1 <= j2 ==> f(j1) <= f(j2)) ==> !d j k. k <= 2 EXP f(j) + ==> g(j + d)(2 EXP (f(j + d) - f(j)) * k) = g(j) k`, + GEN_TAC THEN GEN_TAC THEN STRIP_TAC THEN INDUCT_TAC THENL + [REWRITE_TAC[ADD_CLAUSES; SUB_REFL; EXP; MULT_CLAUSES]; ALL_TAC] THEN + REPEAT GEN_TAC THEN DISCH_TAC THEN + REWRITE_TAC[ADD_CLAUSES] THEN SUBGOAL_THEN + `f(SUC(j + d)):num - f(j) = + (f(SUC(j + d)) - f(j + d)) + (f(j + d) - f(j))` + SUBST1_TAC THENL [MATCH_MP_TAC(ARITH_RULE + `a <= b /\ b <= c ==> c - a:num = (c - b) + (b - a)`) THEN + CONJ_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[EXP_ADD; GSYM MULT_ASSOC] THEN SUBGOAL_THEN + `(g:num->num->B)(SUC(j + d)) + (2 EXP (f(SUC(j + d)):num - f(j + d)) * (2 EXP (f(j + d) - f(j)) * k)) = + g(j + d)(2 EXP (f(j + d) - f(j)) * k)` + SUBST1_TAC THENL [FIRST_X_ASSUM MATCH_MP_TAC THEN TRANS_TAC LE_TRANS + `2 EXP (f(j + d:num) - f(j)) * 2 EXP f(j)` THEN CONJ_TAC THENL + [REWRITE_TAC[LE_MULT_LCANCEL] THEN DISJ2_TAC THEN + FIRST_X_ASSUM ACCEPT_TAC; REWRITE_TAC[GSYM EXP_ADD] THEN + SUBGOAL_THEN `(f:num->num) j <= f(j + d:num)` ASSUME_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ARITH_TAC; ALL_TAC] THEN SUBGOAL_THEN + `((f:num->num)(j + d:num) - f(j)) + f(j) = f(j + d)` + (fun th -> REWRITE_TAC[th; LE_REFL]) THEN ASM_ARITH_TAC]; + ALL_TAC] THEN FIRST_X_ASSUM MATCH_MP_TAC THEN + FIRST_X_ASSUM ACCEPT_TAC) in + let DYADIC_FRACTION_EQ_IMP = prove + (`!m1 m2 p1 p2. p1 <= p2 /\ &m1 / &2 pow p1 = &m2 / &2 pow p2 + ==> m2 = 2 EXP (p2 - p1) * m1`, + REPEAT GEN_TAC THEN DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + SIMP_TAC[REAL_FIELD `~(y = &0) /\ ~(y' = &0) + ==> (x / y = x' / y' <=> y' / y * x = x')`; + REAL_POW_EQ_0; REAL_OF_NUM_EQ; ARITH_EQ] THEN + ASM_SIMP_TAC[REAL_DIV_POW2; REAL_OF_NUM_EQ; ARITH_EQ] THEN + REWRITE_TAC[REAL_OF_NUM_POW; REAL_OF_NUM_MUL; REAL_OF_NUM_EQ] THEN + DISCH_THEN(ACCEPT_TAC o SYM)) in + let DIV_NEARBY_BOUND = prove + (`!a b K. ~(K = 0) /\ b < a + K ==> b DIV K <= SUC(a DIV K)`, + REPEAT STRIP_TAC THEN REWRITE_TAC[ADD1] THEN ASM_SIMP_TAC[LE_LDIV_EQ] THEN + REWRITE_TAC[ARITH_RULE `(n + 1) + 1 = n + 2`] THEN MATCH_MP_TAC(ARITH_RULE + `b < a + K /\ a < K * (a DIV K + 1) ==> b < K * (a DIV K + 2)`) THEN + ASM_REWRITE_TAC[] THEN + MP_TAC(SPECL [`a:num`; `K:num`] DIVISION) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[LEFT_ADD_DISTRIB; MULT_CLAUSES] THEN + ONCE_REWRITE_TAC[MULT_SYM] THEN ARITH_TAC) in + let DYADIC_FRACTION_CLOSE_EQ = prove + (`!n a b. abs(&a / &2 pow n - &b / &2 pow n) < inv(&2 pow n) ==> a = b`, + REPEAT GEN_TAC THEN DISCH_TAC THEN REWRITE_TAC[GSYM REAL_OF_NUM_EQ] THEN + MATCH_MP_TAC REAL_EQ_INTEGERS_IMP THEN REWRITE_TAC[INTEGER_CLOSED] THEN + POP_ASSUM MP_TAC THEN SIMP_TAC[REAL_LT_POW2; REAL_FIELD + `&0 < p ==> a / p - b / p = (a - b) / p`] THEN + REWRITE_TAC[REAL_ABS_DIV; REAL_ABS_POW; REAL_ABS_NUM] THEN + SIMP_TAC[REAL_LT_LDIV_EQ; REAL_LT_POW2] THEN + MATCH_MP_TAC(REAL_ARITH `y = &1 ==> x < y ==> x < &1`) THEN + MATCH_MP_TAC REAL_MUL_LINV THEN + MP_TAC(SPEC `n:num` REAL_LT_POW2) THEN REAL_ARITH_TAC) in + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Step 1: DEPENDENT_CHOICE for per-level chain sequence *) + SUBGOAL_THEN `?t:num->num#(num->A). (!n. SND(t n) 0 = (a:A) /\ + (!i. 2 EXP (FST(t n)) <= i ==> SND(t n) i = (b:A)) /\ + (!r. r <= 2 EXP (FST(t n)) ==> ?c. open_in (mtopology m) c /\ + connected_in (mtopology m) c /\ SND(t n) r IN c /\ + SND(t n) (SUC r) IN c /\ (!x y:A. x IN c /\ y IN c + ==> mdist m (x,y) < inv(&2 pow n)))) /\ + (!n. FST(t n) < FST(t(SUC n)) /\ + (!k. k <= 2 EXP (FST(t n)) ==> SND(t(SUC n)) + (2 EXP (FST(t(SUC n)) - FST(t n)) * k) = SND(t n) k) /\ + (!i1 i2. i1 <= 2 EXP (FST(t n)) /\ i2 <= 2 EXP (FST(t(SUC n))) /\ + abs(&i1 / &2 pow (FST(t n)) - &i2 / &2 pow (FST(t(SUC n)))) + < inv(&2 pow (FST(t n))) + ==> mdist m (SND(t n) i1:A, SND(t(SUC n)) i2) < inv(&2 pow n)))` + MP_TAC THENL [MATCH_MP_TAC DEPENDENT_CHOICE THEN + REWRITE_TAC[EXISTS_PAIR_THM; FORALL_PAIR_THM] THEN CONJ_TAC THENL + [(* Base case: apply CHAIN_IN_OPEN_CONNECTED_SET to mspace m *) + MP_TAC(ISPECL [`m:A metric`; `mspace m:A->bool`; `&1`; + `a:A`; `b:A`] CHAIN_IN_OPEN_CONNECTED_SET) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[REAL_LT_01; OPEN_IN_MSPACE] THEN + ASM_MESON_TAC[CONNECTED_IN_TOPSPACE; TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN DISCH_THEN(X_CHOOSE_THEN `c0:num->A->bool` + (X_CHOOSE_THEN `M0:num` STRIP_ASSUME_TAC)) THEN + EXISTS_TAC `M0:num` THEN SUBGOAL_THEN + `?z:num->A. !i. i < M0 ==> z i IN c0 i /\ z i IN c0(SUC i)` + (X_CHOOSE_TAC `z:num->A`) THENL [REWRITE_TAC[GSYM SKOLEM_THM] THEN + ASM_MESON_TAC[MEMBER_NOT_EMPTY; IN_INTER]; ALL_TAC] THEN EXISTS_TAC + `\i. if i = 0 then a else if M0 < i then b + else (z:num->A)(i - 1)` THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + CONJ_TAC THENL + [COND_CASES_TAC THENL [REFL_TAC; ASM_MESON_TAC[]]; ALL_TAC] THEN + CONJ_TAC THENL [X_GEN_TAC `i:num` THEN DISCH_TAC THEN + SUBGOAL_THEN `~(i = 0) /\ M0 < i` STRIP_ASSUME_TAC THENL + [MP_TAC(SPEC `M0:num` LT_POW2_REFL) THEN ASM_ARITH_TAC; + ASM_REWRITE_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `inv(&2 pow 0) = &1` SUBST1_TAC THENL + [CONV_TAC REAL_RAT_REDUCE_CONV; ALL_TAC] THEN + X_GEN_TAC `r:num` THEN DISCH_TAC THEN ASM_CASES_TAC `r < M0:num` THENL + [(* Case r < M0: use c0 r, both f(r) and f(SUC r) in c0 r *) + EXISTS_TAC `(c0:num->A->bool) r` THEN + SUBGOAL_THEN `r <= M0 /\ ~(SUC r = 0) /\ ~(M0 < SUC r) /\ + SUC r - 1 = r` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `r < M0:num` THEN ARITH_TAC; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [ASM_MESON_TAC[]; ASM_MESON_TAC[]; + ASM_CASES_TAC `r = 0` THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_SIMP_TAC[ARITH_RULE `r < M0 ==> ~(M0 < r:num)`] THEN + SUBGOAL_THEN `r - 1 < M0 /\ SUC(r - 1) = r` + STRIP_ASSUME_TAC THENL [UNDISCH_TAC `~(r = 0)` THEN + UNDISCH_TAC `r < M0:num` THEN ARITH_TAC; ALL_TAC] THEN + ASM_MESON_TAC[]; ASM_MESON_TAC[]; ASM_MESON_TAC[]]; ALL_TAC] THEN + (* Case r >= M0: use c0 M0, both values in c0 M0 *) + EXISTS_TAC `(c0:num->A->bool) M0` THEN + SUBGOAL_THEN `~(SUC r = 0) /\ M0 < SUC r` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `~(r < M0:num)` THEN ARITH_TAC; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [ASM_MESON_TAC[LE_REFL]; ASM_MESON_TAC[LE_REFL]; + ASM_CASES_TAC `r = 0` THENL [SUBGOAL_THEN `M0 = 0` SUBST_ALL_TAC THENL + [UNDISCH_TAC `(r:num) = 0` THEN + UNDISCH_TAC `~(r < M0:num)` THEN ARITH_TAC; ALL_TAC] THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN ASM_CASES_TAC `M0 < r:num` THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `r = M0:num` SUBST_ALL_TAC THENL + [UNDISCH_TAC `~(M0 < r:num)` THEN + UNDISCH_TAC `~(r < M0:num)` THEN ARITH_TAC; ALL_TAC] THEN + ASM_SIMP_TAC[ARITH_RULE `~(M0 = 0) ==> ~(M0 < M0:num)`] THEN + SUBGOAL_THEN `M0 - 1 < M0 /\ SUC(M0 - 1) = M0` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `~(M0 = 0)` THEN ARITH_TAC; ALL_TAC] THEN + ASM_MESON_TAC[]; ASM_MESON_TAC[LE_REFL]]; + (* Step case: given level n chain, produce level SUC n chain *) + MAP_EVERY X_GEN_TAC [`n:num`; `p:num`; `g0:num->A`] THEN STRIP_TAC THEN + (* For each r <= 2^p, subdivide the connecting set *) + SUBGOAL_THEN `!r. r <= 2 EXP p ==> ?l (h:num->A). + h 0 = g0 r /\ (!i. l <= i ==> h i = g0(SUC r)) /\ + (!i. h i IN mspace m) /\ + (!i j. mdist m (h i, h j) < inv(&2 pow n)) /\ + (!i. ?c. open_in (mtopology m) c /\ + connected_in (mtopology m) c /\ + h i IN c /\ h(SUC i) IN c /\ + (!x y:A. x IN c /\ y IN c + ==> mdist m (x,y) < inv(&2 pow (SUC n))))` + MP_TAC THENL [X_GEN_TAC `r:num` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `r:num`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `cr:A->bool` STRIP_ASSUME_TAC) THEN + MP_TAC(ISPECL [`m:A metric`; `cr:A->bool`; `inv(&2 pow (SUC n))`; + `(g0:num->A) r`; `g0(SUC r):A`] + CHAIN_IN_OPEN_CONNECTED_SET) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[REAL_LT_INV_EQ; REAL_LT_POW2]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `c1:num->A->bool` + (X_CHOOSE_THEN `M1:num` STRIP_ASSUME_TAC)) THEN SUBGOAL_THEN + `?z:num->A. !i. i < M1 ==> z i IN c1 i /\ z i IN c1(SUC i)` + (X_CHOOSE_TAC `z1:num->A`) THENL [REWRITE_TAC[GSYM SKOLEM_THM] THEN + ASM_MESON_TAC[MEMBER_NOT_EMPTY; IN_INTER]; ALL_TAC] THEN + EXISTS_TAC `M1 + 1` THEN EXISTS_TAC `\i. if i = 0 then (g0:num->A) r + else if M1 < i then g0(SUC r) else (z1:num->A)(i - 1)` THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN REPEAT CONJ_TAC THENL + [COND_CASES_TAC THENL [REFL_TAC; ASM_MESON_TAC[]]; + X_GEN_TAC `i:num` THEN DISCH_TAC THEN + SUBGOAL_THEN `~(i = 0) /\ M1 < i` (fun th -> REWRITE_TAC[th]) THEN + UNDISCH_TAC `M1 + 1 <= i` THEN ARITH_TAC; + (* h(i) IN mspace m for all i *) + SUBGOAL_THEN `(cr:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + X_GEN_TAC `i:num` THEN + COND_CASES_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + COND_CASES_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `i - 1 < M1 /\ i - 1 <= M1` + STRIP_ASSUME_TAC THENL [UNDISCH_TAC `~(i = 0)` THEN + UNDISCH_TAC `~(M1 < i:num)` THEN ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `open_in (mtopology m) ((c1:num->A->bool)(i - 1)) /\ + (z1:num->A)(i - 1) IN c1(i - 1)` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[OPEN_IN_SUBSET; TOPSPACE_MTOPOLOGY; SUBSET]; + (* mdist bound: all sub-chain elements lie in cr *) + SUBGOAL_THEN `!i:num. (if i = 0 then (g0:num->A) r + else if M1 < i then g0(SUC r) + else (z1:num->A)(i - 1)) IN (cr:A->bool)` + ASSUME_TAC THENL [X_GEN_TAC `i:num` THEN + COND_CASES_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + COND_CASES_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `i - 1 <= M1:num /\ i - 1 < M1` + STRIP_ASSUME_TAC THENL [UNDISCH_TAC `~(M1 < i:num)` THEN + UNDISCH_TAC `~(i = 0)` THEN ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(z1:num->A)(i - 1) IN c1(i - 1)` + ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(c1:num->A->bool)(i - 1) SUBSET (cr:A->bool)` + MP_TAC THENL [MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC + `mtopology m closure_of (c1:num->A->bool)(i - 1)` THEN + CONJ_TAC THENL [MATCH_MP_TAC CLOSURE_OF_SUBSET THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN + ASM_MESON_TAC[OPEN_IN_SUBSET; TOPSPACE_MTOPOLOGY]; + ASM_MESON_TAC[]]; ALL_TAC] THEN ASM SET_TAC[]; ALL_TAC] THEN + REPEAT GEN_TAC THEN UNDISCH_TAC `!x y:A. x IN cr /\ y IN cr + ==> mdist m (x,y) < inv(&2 pow n)` THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + X_GEN_TAC `ii:num` THEN ASM_CASES_TAC `M1 < ii:num` THENL + [SUBGOAL_THEN `~(ii = 0) /\ M1 < SUC ii` + (fun th -> REWRITE_TAC[th]) THENL + [UNDISCH_TAC `M1 < ii:num` THEN ARITH_TAC; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN EXISTS_TAC `(c1:num->A->bool) M1` THEN + ASM_SIMP_TAC[LE_REFL; NOT_SUC] THEN ASM_MESON_TAC[LE_REFL]; + ALL_TAC] THEN (* Case ~(M1 < ii), i.e., ii <= M1: use c1(ii) *) + SUBGOAL_THEN `ii <= M1:num` ASSUME_TAC THENL + [UNDISCH_TAC `~(M1 < ii:num)` THEN ARITH_TAC; ALL_TAC] THEN + EXISTS_TAC `(c1:num->A->bool) ii` THEN REPEAT CONJ_TAC THENL + [(* open_in *) ASM_MESON_TAC[]; (* connected_in *) + ASM_MESON_TAC[]; (* h(ii) IN c1 ii *) + ASM_CASES_TAC `ii = 0` THENL [ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `ii - 1 < M1 /\ SUC(ii - 1) = ii` + STRIP_ASSUME_TAC THENL [UNDISCH_TAC `~(ii = 0)` THEN + UNDISCH_TAC `ii <= M1:num` THEN ARITH_TAC; ALL_TAC] THEN + ASM_MESON_TAC[]]; (* h(SUC ii) IN c1 ii *) + REWRITE_TAC[NOT_SUC] THEN ASM_CASES_TAC `M1 < SUC ii` THENL + [ASM_REWRITE_TAC[] THEN SUBGOAL_THEN `ii = M1:num` + (fun th -> ASM_REWRITE_TAC[th]) THEN + UNDISCH_TAC `M1 < SUC ii` THEN + UNDISCH_TAC `ii <= M1:num` THEN ARITH_TAC; + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `ii < M1:num` ASSUME_TAC THENL + [UNDISCH_TAC `~(M1 < SUC ii)` THEN ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `SUC ii - 1 = ii` + (fun th -> REWRITE_TAC[th]) THENL [ARITH_TAC; ALL_TAC] THEN + ASM_MESON_TAC[]]; (* diameter *) ASM_MESON_TAC[]]]; + (* Second branch: use sub-chain existence to build refined chain *) + ALL_TAC] THEN (* Skolemize the sub-chains *) + GEN_REWRITE_TAC (LAND_CONV o TOP_DEPTH_CONV) [RIGHT_IMP_EXISTS_THM] THEN + REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`l:num->num`; `h:num->num->A`] THEN + DISCH_THEN(LABEL_TAC "*") THEN + (* Find upper bound q for all sub-chain lengths *) + MP_TAC(ISPECL [`\n:num. n`; + `2 EXP 1 INSERT IMAGE (l:num->num) {r | r <= 2 EXP p}`] + UPPER_BOUND_FINITE_SET) THEN + SIMP_TAC[FINITE_INSERT; FINITE_IMAGE; FINITE_NUMSEG_LE] THEN + DISCH_THEN(X_CHOOSE_THEN `q:num` (MP_TAC o MATCH_MP + (MESON[LE_TRANS; LT_LE] `(!x. x IN s ==> x <= q) ==> q < 2 EXP q + ==> (!x. x IN s ==> x <= 2 EXP q)`))) THEN + ANTS_TAC THEN REWRITE_TAC[LT_POW2_REFL] THEN + REWRITE_TAC[FORALL_IN_INSERT; LE_EXP] THEN CONV_TAC NUM_REDUCE_CONV THEN + REWRITE_TAC[FORALL_IN_IMAGE; FORALL_IN_GSPEC] THEN STRIP_TAC THEN + (* Define new precision p' = p + q and new chain *) + EXISTS_TAC `p + q:num` THEN EXISTS_TAC `\i. if i <= 2 EXP (p + q) + then (h:num->num->A) (i DIV (2 EXP q)) (i MOD (2 EXP q)) + else b:A` THEN + ASM_REWRITE_TAC[ARITH_RULE `p < p + q <=> 1 <= q`] THEN + REWRITE_TAC[ADD_SUB2] THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + SUBGOAL_THEN `~(2 EXP q = 0)` ASSUME_TAC THENL + [REWRITE_TAC[EXP_EQ_0] THEN ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `0 < 2 EXP q` ASSUME_TAC THENL + [UNDISCH_TAC `~(2 EXP q = 0)` THEN ARITH_TAC; ALL_TAC] THEN + REPEAT CONJ_TAC THENL [(* Conjunct 1: g'(0) = a *) + SIMP_TAC[LE_0] THEN ASM_SIMP_TAC[DIV_LT; MOD_LT] THEN + SUBGOAL_THEN `(h:num->num->A) 0 0 = (g0:num->A) 0` + (fun th -> ASM_REWRITE_TAC[th]) THEN + USE_THEN "*" (MP_TAC o SPEC `0`) THEN + REWRITE_TAC[LE_0] THEN MESON_TAC[]; + (* Conjunct 2: g'(i) = b for i >= 2^(p+q) *) + X_GEN_TAC `i:num` THEN DISCH_TAC THEN COND_CASES_TAC THENL + [SUBGOAL_THEN `i DIV 2 EXP q = 2 EXP p /\ i MOD 2 EXP q = 0` + (fun th -> REWRITE_TAC[th]) THENL + [SUBGOAL_THEN `i = 2 EXP (p + q):num` SUBST1_TAC THENL + [UNDISCH_TAC `2 EXP (p + q) <= i` THEN + UNDISCH_TAC `i <= 2 EXP (p + q)` THEN ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[EXP_ADD] THEN ONCE_REWRITE_TAC[MULT_SYM] THEN + ASM_SIMP_TAC[DIV_MULT; MOD_MULT]; ALL_TAC] THEN + SUBGOAL_THEN `(h:num->num->A) (2 EXP p) 0 = g0(2 EXP p):A` + SUBST1_TAC THENL [USE_THEN "*" (MP_TAC o SPEC `2 EXP p`) THEN + REWRITE_TAC[LE_REFL] THEN MESON_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN REWRITE_TAC[LE_REFL]; + ASM_REWRITE_TAC[]]; (* Conjunct 3: connecting sets at SUC n *) + X_GEN_TAC `r:num` THEN DISCH_TAC THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `r DIV 2 EXP q <= 2 EXP p` ASSUME_TAC THENL + [TRANS_TAC LE_TRANS `2 EXP (p + q) DIV 2 EXP q` THEN + ASM_SIMP_TAC[DIV_MONO] THEN + REWRITE_TAC[EXP_ADD] THEN ONCE_REWRITE_TAC[MULT_SYM] THEN + ASM_SIMP_TAC[DIV_MULT; LE_REFL]; ALL_TAC] THEN + (* Extract sub-chain connecting sets via USE_THEN *) + USE_THEN "*" (MP_TAC o SPEC `r DIV 2 EXP q`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN STRIP_ASSUME_TAC THEN + EXISTS_TAC `(c:num->A->bool) (r MOD 2 EXP q)` THEN + FIRST_ASSUM(STRIP_ASSUME_TAC o SPEC `r MOD 2 EXP q`) THEN + ASM_REWRITE_TAC[] THEN (* Remaining: second element membership *) + COND_CASES_TAC THENL [(* SUC r <= 2^(p+q) *) SUBGOAL_THEN + `(h:num->num->A) (SUC r DIV 2 EXP q) (SUC r MOD 2 EXP q) = + h (r DIV 2 EXP q) (SUC(r MOD 2 EXP q))` + (fun th -> ASM_REWRITE_TAC[th]) THEN + SUBGOAL_THEN `1 < 2 EXP q` ASSUME_TAC THENL + [TRANS_TAC LET_TRANS `q:num` THEN + ASM_REWRITE_TAC[LT_POW2_REFL]; ALL_TAC] THEN + ASM_CASES_TAC `SUC(r MOD 2 EXP q) < 2 EXP q` THENL + [(* Non-boundary: same sub-chain *) + SUBGOAL_THEN `r MOD 2 EXP q + 1 MOD 2 EXP q < 2 EXP q` + ASSUME_TAC THENL [ASM_SIMP_TAC[MOD_LT] THEN + UNDISCH_TAC `SUC (r MOD 2 EXP q) < 2 EXP q` THEN + REWRITE_TAC[ADD1]; ALL_TAC] THEN REWRITE_TAC[ADD1] THEN + ASM_SIMP_TAC[MOD_ADD_EQ; DIV_ADD_EQ; MOD_LT; DIV_LT; ADD_CLAUSES]; + (* Boundary: crossing to next sub-chain *) + SUBGOAL_THEN `SUC(r MOD 2 EXP q) = 2 EXP q` ASSUME_TAC THENL + [UNDISCH_TAC `~(SUC (r MOD 2 EXP q) < 2 EXP q)` THEN + SUBGOAL_THEN `r MOD 2 EXP q < 2 EXP q` MP_TAC THENL + [ASM_MESON_TAC[DIVISION]; ALL_TAC] THEN + ARITH_TAC; ALL_TAC] THEN SUBGOAL_THEN + `SUC r = SUC(r DIV 2 EXP q) * 2 EXP q` + ASSUME_TAC THENL [SUBGOAL_THEN + `r = r DIV 2 EXP q * 2 EXP q + r MOD 2 EXP q` + MP_TAC THENL [ASM_MESON_TAC[DIVISION]; ALL_TAC] THEN + UNDISCH_TAC `SUC(r MOD 2 EXP q) = 2 EXP q` THEN + REWRITE_TAC[ADD1; LEFT_ADD_DISTRIB; MULT_CLAUSES] THEN + ARITH_TAC; ALL_TAC] THEN SUBGOAL_THEN + `SUC r DIV 2 EXP q = SUC(r DIV 2 EXP q)` SUBST1_TAC THENL + [ASM_REWRITE_TAC[] THEN ONCE_REWRITE_TAC[MULT_SYM] THEN + ASM_SIMP_TAC[DIV_MULT]; ALL_TAC] THEN + SUBGOAL_THEN `SUC r MOD 2 EXP q = 0` SUBST1_TAC THENL + [ASM_REWRITE_TAC[] THEN ONCE_REWRITE_TAC[MULT_SYM] THEN + REWRITE_TAC[MOD_MULT]; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + (* Goal: h(SUC(r DIV 2^q))(0) = h(r DIV 2^q)(2^q) *) + SUBGOAL_THEN `SUC(r DIV 2 EXP q) <= 2 EXP p` + ASSUME_TAC THENL [SUBGOAL_THEN + `SUC(r DIV 2 EXP q) * 2 EXP q <= 2 EXP p * 2 EXP q` + MP_TAC THENL [UNDISCH_TAC `SUC r <= 2 EXP (p + q)` THEN + ASM_REWRITE_TAC[GSYM EXP_ADD]; ALL_TAC] THEN + ASM_REWRITE_TAC[LE_MULT_RCANCEL] THEN + UNDISCH_TAC `0 < 2 EXP q` THEN ARITH_TAC; ALL_TAC] THEN + TRANS_TAC EQ_TRANS + `g0(SUC(r DIV 2 EXP q)):A` THEN CONJ_TAC THENL [USE_THEN "*" + (MP_TAC o SPEC `SUC(r DIV 2 EXP q)`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN SIMP_TAC[]; + CONV_TAC SYM_CONV THEN SUBGOAL_THEN + `l(r DIV 2 EXP q:num) <= 2 EXP q` + MP_TAC THENL [UNDISCH_TAC `!r:num. r <= 2 EXP p + ==> (l:num->num) r <= 2 EXP q` THEN + DISCH_THEN(MP_TAC o SPEC `r DIV 2 EXP q`) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + UNDISCH_TAC `!i. (l:num->num) (r DIV 2 EXP q) <= i + ==> (h:num->num->A) (r DIV 2 EXP q) i = + g0 (SUC (r DIV 2 EXP q))` THEN + DISCH_THEN(MP_TAC o SPEC `2 EXP q`) THEN SIMP_TAC[]]]; + (* ~(SUC r <= 2^(p+q)): element is b *) + SUBGOAL_THEN `r = 2 EXP (p + q):num` ASSUME_TAC THENL + [UNDISCH_TAC `r <= 2 EXP (p + q)` THEN + UNDISCH_TAC `~(SUC r <= 2 EXP (p + q))` THEN ARITH_TAC; + ALL_TAC] THEN SUBGOAL_THEN `r MOD 2 EXP q = 0` SUBST_ALL_TAC THENL + [ASM_REWRITE_TAC[EXP_ADD] THEN ONCE_REWRITE_TAC[MULT_SYM] THEN + REWRITE_TAC[MOD_MULT]; ALL_TAC] THEN + SUBGOAL_THEN `r DIV 2 EXP q = 2 EXP p` SUBST_ALL_TAC THENL + [ASM_REWRITE_TAC[EXP_ADD] THEN ONCE_REWRITE_TAC[MULT_SYM] THEN + ASM_SIMP_TAC[DIV_MULT]; ALL_TAC] THEN + (* Now assumptions have h(2^p) and c(0); goal is b IN c 0 *) + ASM_MESON_TAC[LE_REFL]]; + (* Conjunct 4: refinement g'(2^q * k) = g0(k) *) + X_GEN_TAC `k:num` THEN DISCH_TAC THEN + SUBGOAL_THEN `2 EXP q * k <= 2 EXP (p + q)` + (fun th -> REWRITE_TAC[th]) THENL + [TRANS_TAC LE_TRANS `2 EXP q * 2 EXP p` THEN CONJ_TAC THENL + [ASM_REWRITE_TAC[LE_MULT_LCANCEL]; ONCE_REWRITE_TAC[MULT_SYM] THEN + REWRITE_TAC[GSYM EXP_ADD; LE_REFL]]; ALL_TAC] THEN + ASM_SIMP_TAC[DIV_MULT; MOD_MULT] THEN + USE_THEN "*" (MP_TAC o SPEC `k:num`) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]; (* Conjunct 5: closeness *) + MAP_EVERY X_GEN_TAC [`i1:num`; `i2:num`] THEN STRIP_TAC THEN + ASM_REWRITE_TAC[] THEN + MP_TAC(ISPECL [`i2:num`; `2 EXP q`] DIVISION) THEN + ABBREV_TAC `k1 = i2 DIV 2 EXP q` THEN + ABBREV_TAC `k2 = i2 MOD 2 EXP q` THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(CONJUNCTS_THEN2 SUBST_ALL_TAC ASSUME_TAC) THEN + SUBGOAL_THEN `k1 <= 2 EXP p` ASSUME_TAC THENL + [SUBGOAL_THEN `k1 * 2 EXP q <= 2 EXP p * 2 EXP q` MP_TAC THENL + [UNDISCH_TAC `k1 * 2 EXP q + k2 <= 2 EXP (p + q)` THEN + REWRITE_TAC[EXP_ADD] THEN ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[LE_MULT_RCANCEL; EXP_EQ_0; ARITH_EQ]; ALL_TAC] THEN + USE_THEN "*" (MP_TAC o SPEC `k1:num`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN STRIP_ASSUME_TAC THEN + SUBGOAL_THEN `i1 = k1 \/ i1 = SUC k1` MP_TAC THENL [UNDISCH_TAC + `abs(&i1 / &2 pow p - &(k1 * 2 EXP q + k2) / &2 pow (p + q)) < + inv(&2 pow p)` THEN + GEN_REWRITE_TAC (LAND_CONV o LAND_CONV) [REAL_ABS_SUB] THEN + GEN_REWRITE_TAC (LAND_CONV o RAND_CONV) [GSYM REAL_MUL_LID] THEN + REWRITE_TAC[GSYM real_div; GSYM REAL_OF_NUM_ADD; + GSYM REAL_OF_NUM_MUL] THEN + SIMP_TAC[REAL_LT_RDIV_EQ; REAL_LT_POW2; GSYM REAL_OF_NUM_POW] THEN + SIMP_TAC[REAL_POW_ADD; REAL_LT_POW2; REAL_FIELD `&0 < p /\ &0 < q + ==> (k1 * q + k2) / (p * q) - r / p = + ((k1 - r) * q + k2) / q / p`] THEN + REWRITE_TAC[REAL_ABS_DIV; REAL_ABS_POW; REAL_ABS_NUM] THEN + SIMP_TAC[REAL_DIV_RMUL; REAL_LT_IMP_NZ; REAL_LT_POW2] THEN + SIMP_TAC[REAL_LT_LDIV_EQ; REAL_MUL_LID; REAL_LT_POW2] THEN + DISCH_THEN(MP_TAC o MATCH_MP (REAL_ARITH `abs(r + k2) < q + ==> &0 <= k2 /\ k2 < q ==> -- &2 * q < r /\ r < &1 * q`)) THEN + SIMP_TAC[REAL_LT_RMUL_EQ; REAL_LT_POW2] THEN + ASM_REWRITE_TAC[REAL_POS; REAL_OF_NUM_POW; REAL_OF_NUM_LT] THEN + SIMP_TAC[REAL_LT_INTEGERS; INTEGER_CLOSED; REAL_POS] THEN + REWRITE_TAC [REAL_ARITH `-- &2 + &1:real <= k - r <=> r <= k + &1`; + REAL_ARITH `k - r + &1:real <= &1 <=> k <= r`] THEN + REWRITE_TAC[REAL_OF_NUM_LE; REAL_OF_NUM_ADD] THEN ARITH_TAC; + ALL_TAC] THEN DISCH_THEN(DISJ_CASES_THEN SUBST_ALL_TAC) THENL + [(* Case i1 = k1: g0(k1) = h k1 0 *) + SUBGOAL_THEN `(g0:num->A) k1 = (h:num->num->A) k1 0` + SUBST1_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN ASM_MESON_TAC[]; + (* Case i1 = SUC k1: g0(SUC k1) = h k1 (l k1) *) SUBGOAL_THEN + `(g0:num->A) (SUC k1) = (h:num->num->A) k1 ((l:num->num) k1)` + SUBST1_TAC THENL [ASM_MESON_TAC[LE_REFL]; ALL_TAC] THEN + ASM_MESON_TAC[]]]]; ALL_TAC] THEN + (* Step 2: Extract p, g; define f and derive modulus property *) + DISCH_THEN(X_CHOOSE_THEN `t:num->num#(num->A)` STRIP_ASSUME_TAC) THEN + POP_ASSUM(STRIP_ASSUME_TAC o REWRITE_RULE[FORALL_AND_THM]) THEN + (* Monotonicity: FST(t) is non-decreasing *) + MP_TAC(CONV_RULE(DEPTH_CONV BETA_CONV) + (ISPEC `\n:num. FST(t n:num#(num->A))` STEP_MONO_IMP_MONO)) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; DISCH_TAC] THEN (* Strict monotonicity *) + MP_TAC(CONV_RULE(DEPTH_CONV BETA_CONV) + (ISPEC `\n:num. FST(t n:num#(num->A))` STEP_MONO_IMP_STRICT)) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; DISCH_TAC] THEN + (* Unboundedness: FST(t n) >= n *) MP_TAC(CONV_RULE(DEPTH_CONV BETA_CONV) + (ISPEC `\n:num. FST(t n:num#(num->A))` STEP_MONO_IMP_UNBOUNDED)) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; DISCH_TAC] THEN (* Iterated refinement *) + MP_TAC(CONV_RULE(DEPTH_CONV BETA_CONV) + (ISPECL [`\n:num. FST(t n:num#(num->A))`; + `\n:num. SND(t n:num#(num->A))`] ITERATED_REFINEMENT)) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; DISCH_TAC] THEN + (* Well-definedness: same dyadic = same value *) + SUBGOAL_THEN `!(n1:num) n2 m1 m2. n1 <= n2 /\ + m1 <= 2 EXP FST(t n1:num#(num->A)) /\ m2 <= 2 EXP FST(t n2) /\ + &m1 / &2 pow FST(t n1) = &m2 / &2 pow FST(t n2) + ==> SND(t n1) m1 :A = SND(t n2) m2` ASSUME_TAC THENL [REPEAT GEN_TAC THEN + DISCH_THEN(CONJUNCTS_THEN2 MP_TAC STRIP_ASSUME_TAC) THEN + REWRITE_TAC[LE_EXISTS] THEN + DISCH_THEN(X_CHOOSE_THEN `d:num` SUBST_ALL_TAC) THEN + SUBGOAL_THEN `FST((t:num->num#(num->A)) n1) <= FST(t(n1 + d))` + ASSUME_TAC THENL [FIRST_ASSUM MATCH_MP_TAC THEN ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN + `m2 = 2 EXP (FST((t:num->num#(num->A))(n1 + d)) - FST(t n1)) * m1` + SUBST1_TAC THENL + [MATCH_MP_TAC DYADIC_FRACTION_EQ_IMP THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + CONV_TAC SYM_CONV THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`d:num`; `n1:num`; `m1:num`]) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Chain membership: all chain values are in mspace m *) + SUBGOAL_THEN `!nn (kk:num). kk <= 2 EXP FST((t:num->num#(num->A)) nn) + ==> SND(t nn) kk IN mspace (m:A metric)` + ASSUME_TAC THENL [REPEAT GEN_TAC THEN DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o CONJUNCT2 o CONJUNCT2 o SPEC `nn:num`) THEN + DISCH_THEN(MP_TAC o SPEC `kk:num`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `c:A->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN ASM SET_TAC[]; ALL_TAC] THEN + (* Now define f via choice *) EXISTS_TAC `\x:real. + let s = @s:num#num. SND s <= 2 EXP FST((t:num->num#(num->A))(FST s)) /\ + &(SND s) / &2 pow FST(t(FST s)) = x in + SND(t(FST s)) (SND s)` THEN CONV_TAC(TOP_DEPTH_CONV let_CONV) THEN + (* Prove: for any valid pair, the value equals the canonical one *) + SUBGOAL_THEN `!n m. m <= 2 EXP FST(t n:num#(num->A)) + ==> (\x:real. SND((t:num->num#(num->A)) + (FST(@s:num#num. SND s <= 2 EXP FST(t(FST s)) /\ + &(SND s) / &2 pow FST(t(FST s)) = x))) + (SND(@s. SND s <= 2 EXP FST(t(FST s)) /\ + &(SND s) / &2 pow FST(t(FST s)) = x))) + (&m / &2 pow FST(t n)) = SND(t n) m` + ASSUME_TAC THENL [X_GEN_TAC `nn:num` THEN X_GEN_TAC `mm:num` THEN + DISCH_TAC THEN REWRITE_TAC[] THEN ABBREV_TAC `s = @s:num#num. + SND s <= 2 EXP FST((t:num->num#(num->A))(FST s)) /\ + &(SND s) / &2 pow FST(t(FST s)) = + &mm / &2 pow FST(t nn)` THEN SUBGOAL_THEN + `SND s <= 2 EXP FST((t:num->num#(num->A))(FST s)) /\ + &(SND s) / &2 pow FST(t(FST s)) = &mm / &2 pow FST(t nn)` + STRIP_ASSUME_TAC THENL [EXPAND_TAC "s" THEN CONV_TAC SELECT_CONV THEN + EXISTS_TAC `nn:num,mm:num` THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISJ_CASES_TAC(SPECL [`FST(s:num#num)`; `nn:num`] LE_CASES) THENL + [FIRST_X_ASSUM(MP_TAC o SPECL + [`FST(s:num#num)`; `nn:num`; `SND(s:num#num)`; `mm:num`]) THEN + ASM_REWRITE_TAC[]; CONV_TAC SYM_CONV THEN FIRST_X_ASSUM(MP_TAC o SPECL + [`nn:num`; `FST(s:num#num)`; `mm:num`; `SND(s:num#num)`]) THEN + ASM_REWRITE_TAC[]]; ALL_TAC] THEN REPEAT CONJ_TAC THENL [(* f(&0) = a *) + FIRST_X_ASSUM(MP_TAC o SPECL [`0`; `0`]) THEN + SIMP_TAC[real_div; REAL_MUL_LZERO; LE_0] THEN STRIP_TAC THEN + FIRST_ASSUM(fun th -> REWRITE_TAC[CONJUNCT1(SPEC `0` th)]); (* f(&1) = b *) + FIRST_X_ASSUM(MP_TAC o SPECL [`0`; `2 EXP FST(t 0:num#(num->A))`]) THEN + SIMP_TAC[LE_REFL; GSYM REAL_OF_NUM_POW; REAL_DIV_REFL; REAL_POW_EQ_0; + REAL_OF_NUM_EQ; ARITH_EQ] THEN STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o CONJUNCT1 o CONJUNCT2 o SPEC `0`) THEN + DISCH_THEN(MP_TAC o SPEC `2 EXP FST(t 0:num#(num->A))`) THEN + REWRITE_TAC[LE_REFL]; (* f maps dyadics to mspace m *) + MAP_EVERY X_GEN_TAC [`m':num`; `nn:num`] THEN DISCH_TAC THEN + SUBGOAL_THEN `nn <= FST(t nn:num#(num->A))` ASSUME_TAC THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN SUBGOAL_THEN + `m' * 2 EXP (FST(t nn:num#(num->A)) - nn) <= 2 EXP FST(t nn) /\ + &(m' * 2 EXP (FST(t nn:num#(num->A)) - nn)) / + &2 pow FST(t nn) = &m' / &2 pow nn` + (CONJUNCTS_THEN2 ASSUME_TAC (SUBST1_TAC o SYM)) THENL + [ASM_MESON_TAC[DYADIC_PRECISION_RAISE']; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPECL + [`nn:num`; `m' * 2 EXP (FST(t nn:num#(num->A)) - nn)`]) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN SUBST1_TAC THEN FIRST_ASSUM(fun th -> + MATCH_MP_TAC(SPECL [`nn:num`; + `m' * 2 EXP (FST((t:num->num#(num->A)) nn) - nn)`] th)) THEN + ASM_REWRITE_TAC[]; (* Modulus property *) + (* Multi-level closeness: by induction on gap d *) + SUBGOAL_THEN `!d k i1 i2. i1 <= 2 EXP FST(t k:num#(num->A)) /\ + i2 <= 2 EXP FST(t(k + d)) /\ + abs(&i1 / &2 pow FST(t k) - &i2 / &2 pow FST(t(k + d))) + < inv(&2 pow FST(t k)) ==> mdist m (SND(t k) i1:A, SND(t(k + d)) i2) + < &2 * inv(&2 pow k)` ASSUME_TAC THENL [INDUCT_TAC THENL + [(* Base d=0: closeness implies same point *) + REWRITE_TAC[ADD_CLAUSES] THEN REPEAT GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN `i1:num = i2` SUBST_ALL_TAC THENL + [POP_ASSUM(ACCEPT_TAC o MATCH_MP DYADIC_FRACTION_CLOSE_EQ); + ALL_TAC] THEN + SUBGOAL_THEN `SND((t:num->num#(num->A)) k) i2 IN mspace m` + ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + ASM_SIMP_TAC[MDIST_REFL; REAL_ARITH `&0 < &2 * x <=> &0 < x`; + REAL_LT_INV_EQ; REAL_LT_POW2]; (* Inductive d -> SUC d *) + REPEAT GEN_TAC THEN REWRITE_TAC[ADD_CLAUSES] THEN STRIP_TAC THEN + (* Find intermediate kk at level SUC k *) + SUBGOAL_THEN `?kk. kk <= 2 EXP FST(t(SUC k):num#(num->A)) /\ + abs(&i1 / &2 pow FST(t k) - + &kk / &2 pow FST(t(SUC k):num#(num->A))) + < inv(&2 pow FST(t k:num#(num->A))) /\ + abs(&kk / &2 pow FST(t(SUC k):num#(num->A)) - + &i2 / &2 pow FST(t(SUC(k + d)):num#(num->A))) + < inv(&2 pow FST(t(SUC k):num#(num->A)))` + STRIP_ASSUME_TAC THENL [MATCH_MP_TAC(MESON[] + `(?kk. P kk \/ P(kk + 1)) ==> ?kk. P kk`) THEN EXISTS_TAC + `i2 DIV 2 EXP (FST(t(SUC(k + d)):num#(num->A)) - + FST(t(SUC k):num#(num->A)))` THEN + REWRITE_TAC[GSYM REAL_OF_NUM_LE; GSYM REAL_OF_NUM_ADD; + GSYM REAL_OF_NUM_POW] THEN + ONCE_REWRITE_TAC[REAL_ARITH `x <= y <=> x <= &1 * y`] THEN + SIMP_TAC[GSYM REAL_LE_LDIV_EQ; REAL_LT_POW2] THEN + REWRITE_TAC[REAL_ARITH `(x + &1) / y = x / y + inv(y)`] THEN + MATCH_MP_TAC(REAL_ARITH + `x <= b /\ b < x + e /\ abs(a - b) < d /\ e <= d /\ a <= c /\ b <= c + ==> x <= c /\ abs(a - x) < d /\ abs(x - b) < e \/ + x + e <= c /\ abs(a - (x + e)) < d /\ + abs((x + e) - b) < e`) THEN + ASM_SIMP_TAC[REAL_LE_INV2; REAL_POW_MONO; REAL_OF_NUM_LE; + ARITH; LT_IMP_LE; REAL_LT_POW2] THEN + SIMP_TAC[REAL_LE_LDIV_EQ; REAL_LT_POW2; REAL_MUL_LID] THEN + ASM_REWRITE_TAC[REAL_OF_NUM_POW; REAL_OF_NUM_LE] THEN + REWRITE_TAC[REAL_ARITH `x / y + inv y = (x + &1) / y`] THEN + SIMP_TAC[REAL_LT_RDIV_EQ; REAL_LT_POW2; GSYM REAL_OF_NUM_POW] THEN + SIMP_TAC[REAL_LT_POW2; REAL_FIELD + `&0 < m /\ &0 < n ==> x / m * n = x / (m / n)`] THEN SUBGOAL_THEN + `FST(t(SUC k):num#(num->A)) <= FST(t(SUC(k + d)):num#(num->A))` + (fun th -> SIMP_TAC[th; GSYM REAL_POW_SUB; + REAL_OF_NUM_EQ; ARITH_EQ]) THENL + [FIRST_ASSUM MATCH_MP_TAC THEN ARITH_TAC; ALL_TAC] THEN + SIMP_TAC[REAL_LE_RDIV_EQ; REAL_LT_LDIV_EQ; REAL_LT_POW2] THEN + REWRITE_TAC[REAL_OF_NUM_POW; REAL_OF_NUM_MUL; + REAL_OF_NUM_ADD; REAL_OF_NUM_LT; REAL_OF_NUM_LE] THEN + MP_TAC(SPECL [`i2:num`; `2 EXP (FST(t(SUC(k + d)):num#(num->A)) - + FST(t(SUC k):num#(num->A)))`] + DIVISION) THEN REWRITE_TAC[EXP_EQ_0; ARITH_EQ] THEN + ASM_ARITH_TAC; ALL_TAC] THEN (* One-step mdist bound: k to SUC k *) + SUBGOAL_THEN `mdist m (SND((t:num->num#(num->A)) k) i1, + SND(t(SUC k)) kk) < inv(&2 pow k)` + ASSUME_TAC THENL [FIRST_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN (* IH mdist bound: SUC k to SUC(k+d) with gap d *) + SUBGOAL_THEN `mdist m (SND((t:num->num#(num->A))(SUC k)) kk, + SND(t(SUC(k + d))) i2) < &2 * inv(&2 pow (SUC k))` + ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPECL [`SUC k`; `kk:num`; `i2:num`]) THEN + ASM_REWRITE_TAC[ADD_CLAUSES]; ALL_TAC] THEN + (* Triangle inequality + arithmetic *) + SUBGOAL_THEN `&2 * inv(&2 pow (SUC k)) = inv(&2 pow k)` + ASSUME_TAC THENL + [REWRITE_TAC[real_pow; REAL_INV_MUL; REAL_MUL_ASSOC] THEN + SIMP_TAC[REAL_MUL_RINV; REAL_OF_NUM_EQ; ARITH_EQ] THEN + REWRITE_TAC[REAL_MUL_LID]; ALL_TAC] THEN SUBGOAL_THEN + `SND((t:num->num#(num->A)) k) i1 IN mspace m /\ + SND(t(SUC k)) kk IN mspace m /\ + SND(t(SUC(k + d))) i2 IN mspace m` STRIP_ASSUME_TAC THENL + [REPEAT CONJ_TAC THEN FIRST_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN MP_TAC(ISPECL + [`m:A metric`; `SND((t:num->num#(num->A)) k) i1`; + `SND((t:num->num#(num->A))(SUC k)) kk`; + `SND((t:num->num#(num->A))(SUC(k + d))) i2`] + MDIST_TRIANGLE) THEN ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC]; + ALL_TAC] THEN (* Use multi-level closeness for the modulus property *) + X_GEN_TAC `j:num` THEN + EXISTS_TAC `inv(&2 pow FST((t:num->num#(num->A))(j + 3)))` THEN + REWRITE_TAC[REAL_LT_INV_EQ; REAL_LT_POW2] THEN + MAP_EVERY X_GEN_TAC [`nn:num`; `mm1:num`; `mm2:num`] THEN STRIP_TAC THEN + ASM_CASES_TAC `nn <= FST((t:num->num#(num->A))(j + 3))` THENL + [(* Easy case: nn <= FST(t(j+3)), implies mm1 = mm2 *) + SUBGOAL_THEN `mm1:num = mm2` SUBST_ALL_TAC THENL + [MATCH_MP_TAC(SPEC `nn:num` DYADIC_FRACTION_CLOSE_EQ) THEN + MATCH_MP_TAC REAL_LTE_TRANS THEN EXISTS_TAC + `inv(&2 pow FST((t:num->num#(num->A))(j + 3)))` THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LE_INV2 THEN + REWRITE_TAC[REAL_LT_POW2] THEN MATCH_MP_TAC REAL_POW_MONO THEN + ASM_REWRITE_TAC[REAL_OF_NUM_LE] THEN ASM_ARITH_TAC; ALL_TAC] THEN + (* After mm1 = mm2: mdist(f(x),f(x)) = 0 < inv(2^j) *) + (* Use multi-level closeness with d=0 to get a trivial bound *) + SUBGOAL_THEN `nn <= FST((t:num->num#(num->A)) nn)` ASSUME_TAC THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN SUBGOAL_THEN + `mm2 * 2 EXP (FST((t:num->num#(num->A)) nn) - nn) <= 2 EXP FST(t nn) /\ + &(mm2 * 2 EXP (FST((t:num->num#(num->A)) nn) - nn)) / + &2 pow FST(t nn) = &mm2 / &2 pow nn` (CONJUNCTS_THEN2 ASSUME_TAC + (fun th -> PURE_ONCE_REWRITE_TAC[SYM th])) THENL + [ASM_MESON_TAC[DYADIC_PRECISION_RAISE']; ALL_TAC] THEN + (* Use canonical choice to rewrite f_term to SND form, + BEFORE MDIST_REFL which would beta-reduce and break matching *) + FIRST_ASSUM(fun th -> + let b = snd(dest_forall(snd(dest_forall(concl th)))) in + if is_imp b && is_eq(rand b) then MP_TAC(SPECL + [`nn:num`; `mm2 * 2 EXP (FST((t:num->num#(num->A)) nn) - nn)`] th) + else failwith "") THEN ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(SUBST1_TAC o CONV_RULE(LAND_CONV BETA_CONV)) THEN + (* Now goal: mdist m (SND(t nn)(mm2*...), *) + (* SND(t nn)(mm2*...)) < inv(2^j) *) + SUBGOAL_THEN `SND((t:num->num#(num->A)) nn) + (mm2 * 2 EXP (FST(t nn) - nn)) IN mspace m` + (fun th -> SIMP_TAC[th; MDIST_REFL; REAL_LT_INV_EQ; REAL_LT_POW2]) THEN + FIRST_ASSUM(fun th -> + let b = snd(dest_forall(snd(dest_forall(concl th)))) in + if is_imp b && not(is_eq(rand b)) then MATCH_MP_TAC th + else failwith "") THEN ASM_REWRITE_TAC[]; + (* Hard case: nn > FST(t(j+3)) *) (* Step 1: Key orderings *) + SUBGOAL_THEN `j + 3 <= nn` ASSUME_TAC THENL + [ASM_MESON_TAC[NOT_LE; LET_TRANS; LT_IMP_LE]; ALL_TAC] THEN + SUBGOAL_THEN `nn <= FST((t:num->num#(num->A)) nn)` ASSUME_TAC THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN SUBGOAL_THEN + `FST((t:num->num#(num->A))(j + 3)) <= FST(t nn)` + ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(j + 3) + (nn - (j + 3)) = nn` ASSUME_TAC THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + (* Step 2: Scale mm1/mm2 to canonical level *) + SUBGOAL_THEN `mm1 * 2 EXP (FST((t:num->num#(num->A)) nn) - nn) <= + 2 EXP FST(t nn) /\ + mm2 * 2 EXP (FST(t nn) - nn) <= 2 EXP FST(t nn)` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[DYADIC_PRECISION_RAISE']; ALL_TAC] THEN + (* Step 3: Rewrite mm1 dyadic + canonical choice *) + SUBGOAL_THEN `&mm1 / &2 pow nn = + &(mm1 * 2 EXP (FST((t:num->num#(num->A)) nn) - nn)) / &2 pow FST(t nn)` + (fun th -> PURE_ONCE_REWRITE_TAC[th]) THENL + [ASM_MESON_TAC[DYADIC_PRECISION_RAISE']; ALL_TAC] THEN + FIRST_ASSUM(fun th -> + let b = snd(dest_forall(snd(dest_forall(concl th)))) in + if is_imp b && is_eq(rand b) then MP_TAC(SPECL + [`nn:num`; `mm1 * 2 EXP (FST((t:num->num#(num->A)) nn) - nn)`] th) + else failwith "") THEN ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(SUBST1_TAC o CONV_RULE(LAND_CONV BETA_CONV)) THEN + (* Step 4: Rewrite mm2 dyadic + canonical choice *) + SUBGOAL_THEN `&mm2 / &2 pow nn = + &(mm2 * 2 EXP (FST((t:num->num#(num->A)) nn) - nn)) / &2 pow FST(t nn)` + (fun th -> PURE_ONCE_REWRITE_TAC[th]) THENL + [ASM_MESON_TAC[DYADIC_PRECISION_RAISE']; ALL_TAC] THEN + FIRST_ASSUM(fun th -> + let b = snd(dest_forall(snd(dest_forall(concl th)))) in + if is_imp b && is_eq(rand b) then MP_TAC(SPECL + [`nn:num`; `mm2 * 2 EXP (FST((t:num->num#(num->A)) nn) - nn)`] th) + else failwith "") THEN ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(SUBST1_TAC o CONV_RULE(LAND_CONV BETA_CONV)) THEN + (* Step 5: Abbreviate *) ABBREV_TAC + `mm1' = mm1 * 2 EXP (FST((t:num->num#(num->A)) nn) - nn)` THEN + ABBREV_TAC `mm2' = mm2 * 2 EXP (FST((t:num->num#(num->A)) nn) - nn)` THEN + ABBREV_TAC `gap = FST((t:num->num#(num->A)) nn) - FST(t(j + 3))` THEN + (* Step 6: Scaled bounds *) SUBGOAL_THEN + `mm1' <= 2 EXP FST((t:num->num#(num->A)) nn) /\ mm2' <= 2 EXP FST(t nn)` + STRIP_ASSUME_TAC THENL [CONJ_TAC THENL + [EXPAND_TAC "mm1'" THEN ASM_REWRITE_TAC[]; + EXPAND_TAC "mm2'" THEN ASM_REWRITE_TAC[]]; ALL_TAC] THEN + (* Step 7: DIV bounds for intermediates *) + SUBGOAL_THEN `mm1' DIV 2 EXP gap <= + 2 EXP FST((t:num->num#(num->A))(j + 3)) /\ mm2' DIV 2 EXP gap <= + 2 EXP FST(t(j + 3))` STRIP_ASSUME_TAC THENL [SUBGOAL_THEN + `!mm'. mm' <= 2 EXP FST((t:num->num#(num->A)) nn) + ==> mm' DIV 2 EXP gap <= 2 EXP FST(t(j + 3))` + (fun th -> CONJ_TAC THEN MATCH_MP_TAC th THEN ASM_REWRITE_TAC[]) THEN + X_GEN_TAC `q:num` THEN DISCH_TAC THEN SUBGOAL_THEN + `2 EXP gap * (q DIV 2 EXP gap) <= + 2 EXP gap * 2 EXP FST((t:num->num#(num->A))(j + 3))` + MP_TAC THENL [TRANS_TAC LE_TRANS `q:num` THEN CONJ_TAC THENL + [MP_TAC(SPECL [`q:num`; `2 EXP gap`] DIVISION) THEN + REWRITE_TAC[EXP_EQ_0; ARITH_EQ] THEN ARITH_TAC; + EXPAND_TAC "gap" THEN REWRITE_TAC[GSYM EXP_ADD] THEN + ASM_SIMP_TAC[ARITH_RULE `a <= b ==> (b - a) + a = b:num`] THEN + ASM_REWRITE_TAC[]]; + REWRITE_TAC[LE_MULT_LCANCEL; EXP_EQ_0; ARITH_EQ]]; ALL_TAC] THEN + (* Step 8: Memberships *) + SUBGOAL_THEN `SND((t:num->num#(num->A)) nn) mm1' IN mspace m /\ + SND(t nn) mm2' IN mspace m /\ + SND(t(j + 3)) (mm1' DIV 2 EXP gap) IN mspace m /\ + SND(t(j + 3)) (mm2' DIV 2 EXP gap) IN mspace m` + STRIP_ASSUME_TAC THENL [REPEAT CONJ_TAC THEN FIRST_ASSUM(fun th -> + let b = snd(dest_forall(snd(dest_forall(concl th)))) in + if is_imp b && not(is_eq(rand b)) then MATCH_MP_TAC th + else failwith "") THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Step 9: Multi-level closeness bounds *) + SUBGOAL_THEN `mdist m (SND((t:num->num#(num->A))(j + 3)) + (mm1' DIV 2 EXP gap), SND(t nn) mm1') + < &2 * inv(&2 pow (j + 3)) /\ + mdist m (SND((t:num->num#(num->A))(j + 3)) + (mm2' DIV 2 EXP gap), SND(t nn) mm2') + < &2 * inv(&2 pow (j + 3))` STRIP_ASSUME_TAC THENL [SUBGOAL_THEN + `!q. q <= 2 EXP FST((t:num->num#(num->A)) nn) + ==> mdist m (SND(t(j + 3)) (q DIV 2 EXP gap), SND(t nn) q) + < &2 * inv(&2 pow (j + 3))` + (fun th -> CONJ_TAC THEN MATCH_MP_TAC th THEN + (EXPAND_TAC "mm1'" ORELSE EXPAND_TAC "mm2'") THEN + ASM_REWRITE_TAC[]) THEN X_GEN_TAC `q:num` THEN DISCH_TAC THEN + FIRST_ASSUM(fun th -> if length(fst(strip_forall(concl th))) = 4 + then MP_TAC(SPECL [`nn - (j + 3)`; `j + 3`; + `q DIV 2 EXP gap`; `q:num`] th) + else failwith "") THEN + SUBGOAL_THEN `(j + 3) + (nn - (j + 3)) = nn:num` + (fun th -> REWRITE_TAC[th]) THENL [ASM_ARITH_TAC; ALL_TAC] THEN + ANTS_TAC THENL [REPEAT CONJ_TAC THENL + [(* q DIV 2^gap <= 2^FST(t(j+3)) *) + SUBGOAL_THEN `2 EXP gap * (q DIV 2 EXP gap) <= + 2 EXP gap * 2 EXP FST((t:num->num#(num->A))(j + 3))` + MP_TAC THENL [TRANS_TAC LE_TRANS `q:num` THEN CONJ_TAC THENL + [MP_TAC(SPECL [`q:num`; `2 EXP gap`] DIVISION) THEN + REWRITE_TAC[EXP_EQ_0; ARITH_EQ] THEN ARITH_TAC; + EXPAND_TAC "gap" THEN REWRITE_TAC[GSYM EXP_ADD] THEN + ASM_SIMP_TAC[ARITH_RULE `a <= b ==> (b - a) + a = b:num`] THEN + ASM_REWRITE_TAC[]]; + REWRITE_TAC[LE_MULT_LCANCEL; EXP_EQ_0; ARITH_EQ]]; + (* q <= 2^FST(t nn) *) ASM_REWRITE_TAC[]; (* Closeness condition *) + SUBGOAL_THEN `FST((t:num->num#(num->A)) nn) = FST(t(j + 3)) + gap` + SUBST1_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[REAL_POW_ADD] THEN + REWRITE_TAC[real_div; REAL_INV_MUL] THEN ONCE_REWRITE_TAC[REAL_ARITH + `d * ia - q * (ia * ig) = ia * (d - q * ig)`] THEN + REWRITE_TAC[REAL_ABS_MUL] THEN + SIMP_TAC[REAL_ARITH `&0 < x ==> abs x = x`; + REAL_LT_INV_EQ; REAL_LT_POW2] THEN + GEN_REWRITE_TAC (RAND_CONV) [GSYM REAL_MUL_RID] THEN + SIMP_TAC[REAL_LT_LMUL_EQ; REAL_LT_INV_EQ; REAL_LT_POW2] THEN + REWRITE_TAC[GSYM real_div; REAL_OF_NUM_POW] THEN + MP_TAC(SPECL [`q:num`; `2 EXP gap`] DIVISION) THEN + REWRITE_TAC[EXP_EQ_0; ARITH_EQ] THEN STRIP_TAC THEN SUBGOAL_THEN + `&q = &(2 EXP gap) * &(q DIV 2 EXP gap) + &(q MOD 2 EXP gap)` + SUBST1_TAC THENL [REWRITE_TAC[REAL_OF_NUM_MUL; REAL_OF_NUM_ADD; + REAL_OF_NUM_EQ] THEN GEN_REWRITE_TAC LAND_CONV [ASSUME + `q = q DIV 2 EXP gap * 2 EXP gap + q MOD 2 EXP gap`] THEN + REWRITE_TAC[MULT_SYM]; ALL_TAC] THEN + REWRITE_TAC[real_div; REAL_ADD_RDISTRIB; GSYM REAL_MUL_ASSOC] THEN + REWRITE_TAC[GSYM real_div] THEN SIMP_TAC[REAL_DIV_LMUL; + REAL_OF_NUM_EQ; EXP_EQ_0; ARITH_EQ] THEN REWRITE_TAC[REAL_ARITH + `abs(d - (d + r)) = abs r`] THEN + REWRITE_TAC[REAL_ABS_DIV; REAL_ABS_NUM] THEN + SIMP_TAC[REAL_LT_LDIV_EQ; + REAL_OF_NUM_LT; LT_NZ; EXP_EQ_0; ARITH_EQ] THEN + ASM_REWRITE_TAC[REAL_MUL_LID; REAL_OF_NUM_LT]]; MESON_TAC[]]; + ALL_TAC] THEN (* Step 10: Same-level bound for intermediates *) + SUBGOAL_THEN `mdist m (SND((t:num->num#(num->A))(j + 3)) + (mm1' DIV 2 EXP gap), SND(t(j + 3)) (mm2' DIV 2 EXP gap)) + < inv(&2 pow (j + 3))` + ASSUME_TAC THENL [(* Step 10: Same-level bound *) ASM_CASES_TAC + `mm1' DIV 2 EXP gap = mm2' DIV 2 EXP gap` THENL + [ASM_SIMP_TAC[MDIST_REFL; REAL_LT_INV_EQ; REAL_LT_POW2]; ALL_TAC] THEN + SUBGOAL_THEN `mm2' DIV 2 EXP gap = SUC(mm1' DIV 2 EXP gap) \/ + mm1' DIV 2 EXP gap = SUC(mm2' DIV 2 EXP gap)` + STRIP_ASSUME_TAC THENL [(* Prove abs closeness first *) + SUBGOAL_THEN `abs(&mm1' - &mm2') < &(2 EXP gap)` + ASSUME_TAC THENL [(* Replace mm1', mm2' with mm1*K, mm2*K *) + SUBGOAL_THEN + `&mm1' = &mm1 * &(2 EXP (FST((t:num->num#(num->A)) nn) - nn)) /\ + &mm2' = &mm2 * &(2 EXP (FST((t:num->num#(num->A)) nn) - nn))` + (CONJUNCTS_THEN SUBST1_TAC) THENL [CONJ_TAC THEN + ASM_REWRITE_TAC[REAL_OF_NUM_MUL; REAL_OF_NUM_EQ]; ALL_TAC] THEN + REWRITE_TAC[GSYM REAL_SUB_RDISTRIB; + REAL_ABS_MUL; REAL_ABS_NUM] THEN + (* Decompose 2^gap = 2^(nn-q) * 2^(p-nn) *) + SUBGOAL_THEN `&(2 EXP gap) = + &(2 EXP (nn - FST((t:num->num#(num->A))(j + 3)))) * + &(2 EXP (FST(t nn) - nn))` SUBST1_TAC THENL [SUBGOAL_THEN + `gap = (nn - FST((t:num->num#(num->A))(j + 3))) + + (FST(t nn) - nn)` SUBST1_TAC THENL [ASM_ARITH_TAC; + REWRITE_TAC[EXP_ADD; REAL_OF_NUM_MUL]]; ALL_TAC] THEN + (* Cancel common factor *) + SIMP_TAC[REAL_LT_RMUL_EQ; REAL_OF_NUM_LT; LT_NZ; + EXP_EQ_0; ARITH_EQ] THEN (* Derive from asm 19 *) + FIRST_X_ASSUM(MP_TAC o check (fun th -> + can (find_term (fun t -> is_const t && + fst(dest_const t) = "real_abs")) (concl th) && + can (find_term (fun t -> try fst(dest_var t) = "mm1" + with _ -> false)) (concl th))) THEN + REWRITE_TAC[real_div; GSYM REAL_SUB_RDISTRIB; REAL_ABS_MUL] THEN + SIMP_TAC[REAL_ARITH `&0 < x ==> abs x = x`; + REAL_LT_INV_EQ; REAL_LT_POW2] THEN + REWRITE_TAC[GSYM real_div] THEN + SIMP_TAC[REAL_LT_LDIV_EQ; REAL_LT_POW2] THEN + MATCH_MP_TAC(REAL_ARITH `b = c ==> x < b ==> x < c`) THEN + REWRITE_TAC[GSYM REAL_OF_NUM_POW] THEN SUBGOAL_THEN + `nn = FST((t:num->num#(num->A))(j + 3)) + (nn - FST(t(j + 3)))` + (fun th -> GEN_REWRITE_TAC + (LAND_CONV o RAND_CONV o RAND_CONV) [th]) THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[REAL_POW_ADD; REAL_MUL_ASSOC] THEN + SIMP_TAC[REAL_MUL_LINV; REAL_POW_EQ_0; + REAL_OF_NUM_EQ; ARITH_EQ] THEN REWRITE_TAC[REAL_MUL_LID]; + ALL_TAC] THEN (* Derive natural closeness *) + SUBGOAL_THEN `mm2' < mm1' + 2 EXP gap /\ mm1' < mm2' + 2 EXP gap` + STRIP_ASSUME_TAC THENL + [REWRITE_TAC[GSYM REAL_OF_NUM_LT; GSYM REAL_OF_NUM_ADD] THEN + FIRST_X_ASSUM(MP_TAC o check (fun th -> + can (find_term (fun t -> is_const t && + fst(dest_const t) = "real_abs")) (concl th) && + can (find_term (fun t -> try fst(dest_var t) = "mm1'" + with _ -> false)) (concl th))) THEN REAL_ARITH_TAC; + ALL_TAC] THEN (* Derive quotient bounds *) + SUBGOAL_THEN `mm2' DIV 2 EXP gap <= SUC(mm1' DIV 2 EXP gap) /\ + mm1' DIV 2 EXP gap <= SUC(mm2' DIV 2 EXP gap)` + MP_TAC THENL [CONJ_TAC THEN MATCH_MP_TAC DIV_NEARBY_BOUND THEN + ASM_REWRITE_TAC[EXP_EQ_0; ARITH_EQ]; ASM_ARITH_TAC]; + (* Case mm2'DIV = SUC(mm1'DIV) *) FIRST_X_ASSUM SUBST1_TAC THEN + FIRST_ASSUM(MP_TAC o SPEC `mm1' DIV 2 EXP gap` o + CONJUNCT2 o CONJUNCT2 o SPEC `j + 3:num` o check (fun th -> + fst(dest_var(fst(dest_forall(concl th)))) = "n" && + can (find_term (fun t -> is_const t && + fst(dest_const t) = "open_in")) (concl th))) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `cc:A->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + (* Case mm1'DIV = SUC(mm2'DIV) *) FIRST_X_ASSUM SUBST1_TAC THEN + FIRST_ASSUM(MP_TAC o SPEC `mm2' DIV 2 EXP gap` o + CONJUNCT2 o CONJUNCT2 o SPEC `j + 3:num` o check (fun th -> + fst(dest_var(fst(dest_forall(concl th)))) = "n" && + can (find_term (fun t -> is_const t && + fst(dest_const t) = "open_in")) (concl th))) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `cc:A->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]]; ALL_TAC] THEN + (* Step 9: MDIST_SYM for first cross-level bound *) + SUBGOAL_THEN `mdist m (SND((t:num->num#(num->A)) nn) mm1', + SND(t(j + 3)) (mm1' DIV 2 EXP gap)) + < &2 * inv(&2 pow (j + 3))` ASSUME_TAC THENL [SUBGOAL_THEN + `mdist m (SND((t:num->num#(num->A)) nn) mm1', + SND(t(j + 3)) (mm1' DIV 2 EXP gap)) = + mdist m (SND(t(j + 3)) (mm1' DIV 2 EXP gap), SND(t nn) mm1')` + SUBST1_TAC THENL [MATCH_MP_TAC MDIST_SYM THEN ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[]]; ALL_TAC] THEN + (* Step 10: Triangle inequality + arithmetic *) + MP_TAC(ISPECL [`m:A metric`; `SND((t:num->num#(num->A)) nn) mm1'`; + `SND((t:num->num#(num->A))(j + 3)) + (mm1' DIV 2 EXP gap)`; `SND((t:num->num#(num->A)) nn) mm2'`] + MDIST_TRIANGLE) THEN ASM_REWRITE_TAC[] THEN MP_TAC(ISPECL + [`m:A metric`; `SND((t:num->num#(num->A))(j + 3)) + (mm1' DIV 2 EXP gap)`; `SND((t:num->num#(num->A))(j + 3)) + (mm2' DIV 2 EXP gap)`; `SND((t:num->num#(num->A)) nn) mm2'`] + MDIST_TRIANGLE) THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `&5 * inv(&2 pow (j + 3)) <= inv(&2 pow j)` MP_TAC THENL + [REWRITE_TAC[ARITH_RULE `j + 3 = SUC(SUC(SUC j))`; real_pow; + REAL_INV_MUL] THEN MATCH_MP_TAC(REAL_ARITH + `&0 < x ==> &5 * (inv(&2) * (inv(&2) * (inv(&2) * x))) <= x`) THEN + REWRITE_TAC[REAL_LT_INV_EQ; REAL_LT_POW2]; ALL_TAC] THEN + ASM_REAL_ARITH_TAC]]);; -let CONTRACTIBLE_SPACE_LOWER_HEMISPHERE = prove - (`!n k. k IN 1..n+1 - ==> contractible_space(subtopology (nsphere n) {x | x k <= &0})`, - REPEAT GEN_TAC THEN - DISCH_THEN(MP_TAC o MATCH_MP CONTRACTIBLE_SPACE_UPPER_HEMISPHERE) THEN - MATCH_MP_TAC EQ_IMP THEN MATCH_MP_TAC HOMEOMORPHIC_SPACE_CONTRACTIBILITY THEN - REWRITE_TAC[homeomorphic_space] THEN - REPEAT(EXISTS_TAC `\(x:num->real) i. if i = k then --(x i) else x i`) THEN - REWRITE_TAC[homeomorphic_maps; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN - SIMP_TAC[CONTINUOUS_MAP_FROM_SUBTOPOLOGY; - CONTINUOUS_MAP_NSPHERE_REFLECTION] THEN - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM; REAL_NEG_NEG; - TOPSPACE_SUBTOPOLOGY; IN_INTER] THEN - REWRITE_TAC[FUN_EQ_THM] THEN REPEAT STRIP_TAC THEN - TRY COND_CASES_TAC THEN ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC);; - -let NULLHOMOTOPIC_NONSURJECTIVE_SPHERE_MAP = prove - (`!p f. continuous_map(nsphere p,nsphere p) f /\ - ~(IMAGE f (topspace(nsphere p)) = topspace(nsphere p)) - ==> ?a. homotopic_with (\x. T) (nsphere p,nsphere p) f (\x. a)`, - SIMP_TAC[IMP_CONJ; CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE; SET_RULE - `s SUBSET t ==> (~(s = t) <=> ?a. a IN t /\ ~(a IN s))`] THEN - REPEAT GEN_TAC THEN DISCH_TAC THEN - DISCH_THEN(X_CHOOSE_THEN `a:num->real` STRIP_ASSUME_TAC) THEN - EXISTS_TAC `(\i. --(a i)):num->real` THEN SIMP_TAC[HOMOTOPIC_WITH] THEN - EXISTS_TAC - `(\x i. x i / sqrt(sum(1..p+1) (\j. x j pow 2))) o - (\(t,x) i. (&1 - t) * f(x:num->real) i - t * a i)` THEN - REWRITE_TAC[o_THM; REAL_ARITH - `(&1 - &1) * x - &1 * a = --a /\ (&1 - &0) * x - &0 * a = x`] THEN - MP_TAC(ASSUME `a IN topspace(nsphere p)`) THEN - FIRST_ASSUM(MP_TAC o MATCH_MP CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE) THEN - REWRITE_TAC[NSPHERE; TOPSPACE_SUBTOPOLOGY; SUBSET] THEN - REWRITE_TAC[GSYM NSPHERE; IN_ELIM_THM; IN_INTER; FORALL_IN_IMAGE] THEN - SIMP_TAC[REAL_ARITH `(--x:real) pow 2 = x pow 2`] THEN - DISCH_THEN(K ALL_TAC) THEN DISCH_THEN(STRIP_ASSUME_TAC o CONJUNCT2) THEN - REWRITE_TAC[SQRT_1; REAL_DIV_1; ETA_AX] THEN - MATCH_MP_TAC CONTINUOUS_MAP_COMPOSE THEN - EXISTS_TAC `subtopology (euclidean_space(p + 1)) (UNIV DELETE (\i. &0))` THEN - REWRITE_TAC[euclidean_space; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN - REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN REPEAT CONJ_TAC THENL - [X_GEN_TAC `i:num` THEN REWRITE_TAC[LAMBDA_PAIR] THEN - MATCH_MP_TAC CONTINUOUS_MAP_REAL_SUB THEN CONJ_TAC THEN - MATCH_MP_TAC CONTINUOUS_MAP_REAL_MUL THEN - REWRITE_TAC[CONTINUOUS_MAP_OF_FST; CONTINUOUS_MAP_OF_SND] THEN - SIMP_TAC[GSYM SUBTOPOLOGY_CROSS; nsphere; CONTINUOUS_MAP_FROM_SUBTOPOLOGY; - CONTINUOUS_MAP_FST] THEN - REPEAT CONJ_TAC THEN DISJ2_TAC THEN - SIMP_TAC[CONTINUOUS_MAP_REAL_SUB; CONTINUOUS_MAP_REAL_CONST; - CONTINUOUS_MAP_ID; CONTINUOUS_MAP_FROM_SUBTOPOLOGY] THEN - REWRITE_TAC[GSYM nsphere] THEN - SUBGOAL_THEN `(\x:num->real. f x i) = (\y:num->real. y i) o f` - SUBST1_TAC THENL [REWRITE_TAC[o_DEF]; ALL_TAC] THEN - MATCH_MP_TAC CONTINUOUS_MAP_COMPOSE THEN - EXISTS_TAC `nsphere p` THEN ASM_REWRITE_TAC[] THEN - SIMP_TAC[NSPHERE; CONTINUOUS_MAP_FROM_SUBTOPOLOGY; - CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV]; - FIRST_ASSUM(MP_TAC o MATCH_MP CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE) THEN - GEN_REWRITE_TAC (LAND_CONV o RAND_CONV o RAND_CONV) [NSPHERE] THEN - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_SUBTOPOLOGY; - FORALL_PAIR_THM; IN_CROSS; TOPSPACE_PROD_TOPOLOGY] THEN - ASM_SIMP_TAC[IN_ELIM_THM; IN_INTER] THEN - REPEAT STRIP_TAC THEN REAL_ARITH_TAC; - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; FORALL_PAIR_THM] THEN - REWRITE_TAC[TOPSPACE_PROD_TOPOLOGY; IN_CROSS] THEN - MAP_EVERY X_GEN_TAC [`t:real`; `b:num->real`] THEN - REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN - REWRITE_TAC[IN_UNIV; IN_REAL_INTERVAL; IN_DELETE] THEN - STRIP_TAC THEN REWRITE_TAC[FUN_EQ_THM; REAL_SUB_0] THEN - GEN_REWRITE_TAC RAND_CONV [GSYM FUN_EQ_THM] THEN - MATCH_MP_TAC(MESON[] - `(a = b ==> t = &1 / &2) /\ (t = &1 / &2 ==> ~(a = b)) - ==> ~(a = b)`) THEN - CONJ_TAC THENL - [DISCH_THEN(MP_TAC o AP_TERM `\x. sum(1..p+1) (\i. x i pow 2)`) THEN - FIRST_ASSUM(MP_TAC o MATCH_MP CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE) THEN - GEN_REWRITE_TAC (LAND_CONV o RAND_CONV o RAND_CONV) [NSPHERE] THEN - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_SUBTOPOLOGY; - FORALL_PAIR_THM; IN_CROSS; TOPSPACE_PROD_TOPOLOGY] THEN - ASM_SIMP_TAC[IN_ELIM_THM; IN_INTER; REAL_POW_MUL; SUM_LMUL] THEN - DISCH_TAC THEN CONV_TAC REAL_RING; - DISCH_THEN SUBST1_TAC THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN - REWRITE_TAC[FUN_EQ_THM; REAL_ARITH - `&1 / &2 * x = &1 / &2 * y <=> x = y`] THEN - GEN_REWRITE_TAC RAND_CONV [GSYM FUN_EQ_THM] THEN - REWRITE_TAC[ETA_AX] THEN ASM SET_TAC[]]; - REWRITE_TAC[NSPHERE; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN - CONJ_TAC THENL - [REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE; IN_UNIV] THEN - REWRITE_TAC[EXTENSIONAL_UNIV; IN; SUBSET] THEN - X_GEN_TAC `k:num` THEN MATCH_MP_TAC CONTINUOUS_MAP_REAL_DIV THEN - REWRITE_TAC[CONJ_ASSOC] THEN CONJ_TAC THENL - [CONJ_TAC THEN REPEAT(MATCH_MP_TAC CONTINUOUS_MAP_FROM_SUBTOPOLOGY) THEN - SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV] THEN - MATCH_MP_TAC CONTINUOUS_MAP_SQRT THEN - MATCH_MP_TAC CONTINUOUS_MAP_SUM THEN - SIMP_TAC[CONTINUOUS_MAP_REAL_POW; CONTINUOUS_MAP_PRODUCT_PROJECTION; - IN_UNIV; FINITE_NUMSEG]; - ALL_TAC]; +(* Imbedding Theorem: Whyburn, Analytic Topology, Theorem (4.2). *) +(* In a complete, connected, locally connected metric space, any two points *) +(* are contained in a locally connected continuum (compact connected locally *) +(* connected subset). Build a uniformly continuous function on dyadics via *) +(* the chain construction, extend to [0,1] by completeness, and observe *) +(* that the image is compact, connected, and locally connected. *) + +let MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM = prove + (`!m:A metric a b. + mcomplete m /\ + connected_space (mtopology m) /\ + locally_connected_space (mtopology m) /\ + a IN mspace m /\ + b IN mspace m + ==> ?K. compact_in (mtopology m) K /\ + connected_in (mtopology m) K /\ + locally_connected_space + (subtopology (mtopology m) K) /\ + a IN K /\ b IN K`, + let DYADIC_PRECISION_RAISE = prove + (`!k n n'. n <= n' /\ k <= 2 EXP n + ==> 2 EXP (n' - n) * k <= 2 EXP n' /\ + &(2 EXP (n' - n) * k) / &2 pow n' = + &k / &2 pow n`, + REPEAT GEN_TAC THEN STRIP_TAC THEN CONJ_TAC THENL + [TRANS_TAC LE_TRANS `2 EXP (n' - n) * 2 EXP n` THEN + ASM_REWRITE_TAC[LE_MULT_LCANCEL; GSYM EXP_ADD] THEN + ASM_SIMP_TAC[ARITH_RULE + `n <= n' ==> (n' - n) + n = n':num`; LE_REFL]; + REWRITE_TAC[GSYM REAL_OF_NUM_MUL; + GSYM REAL_OF_NUM_POW] THEN + ASM_SIMP_TAC[REAL_POW_SUB; + REAL_OF_NUM_EQ; ARITH_EQ] THEN + SIMP_TAC[REAL_LT_POW2; REAL_FIELD + `&0 < a /\ &0 < b + ==> (a / b * m) / a = m / b`]]) in + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Build uniformly continuous f on dyadics *) + SUBGOAL_THEN `?f:real->A. + f(&0) = a /\ f(&1) = b /\ + (!x. x IN {&k / &2 pow n | k <= 2 EXP n} ==> f x IN mspace m) /\ + uniformly_continuous_map + (submetric real_euclidean_metric {&k / &2 pow n | k <= 2 EXP n}, + m) f` + STRIP_ASSUME_TAC THENL + [SUBGOAL_THEN `?f:real->A. f(&0) = a /\ f(&1) = b /\ + (!m' n. m' <= 2 EXP n ==> f(&m' / &2 pow n) IN mspace m) /\ + (!j. ?d. &0 < d /\ + !n m1 m2. m1 <= 2 EXP n /\ m2 <= 2 EXP n /\ + abs(&m1 / &2 pow n - &m2 / &2 pow n) < d + ==> mdist m (f(&m1 / &2 pow n),f(&m2 / &2 pow n):A) + < inv(&2 pow j))` + STRIP_ASSUME_TAC THENL + [MATCH_MP_TAC MCOMPLETE_DYADIC_APPROXIMATION THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN - SIMP_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_SUBTOPOLOGY; IN_INTER; - IN_ELIM_THM; IN_DELETE; IN_UNIV; real_div; REAL_POW_MUL; - REAL_MUL_LZERO; SUM_RMUL; REAL_POW_INV; SQRT_POW_2; - SUM_POS_LE_NUMSEG; REAL_LE_POW_2; SQRT_EQ_0] THEN - X_GEN_TAC `x:num->real` THEN STRIP_TAC THEN - REWRITE_TAC[GSYM real_div ] THEN TRY(MATCH_MP_TAC REAL_DIV_REFL) THEN - DISCH_THEN(MP_TAC o MATCH_MP (ONCE_REWRITE_RULE[IMP_CONJ_ALT] - SUM_POS_EQ_0_NUMSEG)) THEN - REWRITE_TAC[REAL_LE_POW_2; GSYM IN_NUMSEG; REAL_POW_EQ_0] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE RAND_CONV [FUN_EQ_THM]) THEN - ASM_MESON_TAC[IN]]);; + EXISTS_TAC `f:real->A` THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[FORALL_IN_GSPEC]; ALL_TAC] THEN + REWRITE_TAC[uniformly_continuous_map; SUBMETRIC; + REAL_EUCLIDEAN_METRIC; IN_INTER; IN_UNIV] THEN + CONJ_TAC THENL + [REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_INTER; IN_UNIV] THEN + ASM_REWRITE_TAC[FORALL_IN_GSPEC]; ALL_TAC] THEN + X_GEN_TAC `e:real` THEN DISCH_TAC THEN + MP_TAC(ISPECL [`inv(&2)`; `e:real`] REAL_ARCH_POW_INV) THEN + REWRITE_TAC[REAL_POW_INV] THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_TAC `j:num`) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `j:num`) THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `d:real` THEN STRIP_TAC THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[IN_INTER; IN_UNIV; IMP_CONJ; + RIGHT_FORALL_IMP_THM; FORALL_IN_GSPEC] THEN + MAP_EVERY X_GEN_TAC [`k1:num`; `n1:num`] THEN DISCH_TAC THEN + MAP_EVERY X_GEN_TAC [`k2:num`; `n2:num`] THEN + DISCH_TAC THEN DISCH_TAC THEN + TRANS_TAC REAL_LT_TRANS `inv(&2 pow j)` THEN ASM_REWRITE_TAC[] THEN + DISJ_CASES_TAC(SPECL [`n1:num`; `n2:num`] LE_CASES) THENL + [FIRST_X_ASSUM(MP_TAC o SPECL + [`n2:num`; `k2:num`; `2 EXP (n2 - n1) * k1`]) THEN + SUBGOAL_THEN `&(2 EXP (n2 - n1) * k1) / &2 pow n2 = + &k1 / &2 pow n1` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_MESON_TAC[DYADIC_PRECISION_RAISE]; ALL_TAC] THEN + DISCH_THEN MATCH_MP_TAC THEN REPEAT CONJ_TAC THENL + [ASM_REWRITE_TAC[]; + ASM_MESON_TAC[DYADIC_PRECISION_RAISE]; + ONCE_REWRITE_TAC[REAL_ABS_SUB] THEN ASM_REWRITE_TAC[]]; + FIRST_X_ASSUM(MP_TAC o SPECL + [`n1:num`; `2 EXP (n1 - n2) * k2`; `k1:num`]) THEN + SUBGOAL_THEN `&(2 EXP (n1 - n2) * k2) / &2 pow n1 = + &k2 / &2 pow n2` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_MESON_TAC[DYADIC_PRECISION_RAISE]; ALL_TAC] THEN + DISCH_THEN MATCH_MP_TAC THEN REPEAT CONJ_TAC THENL + [ASM_MESON_TAC[DYADIC_PRECISION_RAISE]; + ASM_REWRITE_TAC[]; + ONCE_REWRITE_TAC[REAL_ABS_SUB] THEN ASM_REWRITE_TAC[]]]; + ALL_TAC] THEN + (* Extend f to g on [0,1] using mcomplete *) + MP_TAC(ISPECL [`real_euclidean_metric`; `m:A metric`; + `f:real->A`; `{&k / &2 pow n | k <= 2 EXP n}`] + UNIFORMLY_CONTINUOUS_MAP_EXTENDS_TO_CLOSURE_OF) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[MTOPOLOGY_REAL_EUCLIDEAN_METRIC; + CLOSURE_OF_DYADIC_RATIONALS_IN_UNIT_INTERVAL] THEN + DISCH_THEN(X_CHOOSE_THEN `g:real->A` STRIP_ASSUME_TAC) THEN + (* K = IMAGE g [0,1] is our locally connected continuum *) + EXISTS_TAC `IMAGE (g:real->A) (real_interval[&0,&1])` THEN + ABBREV_TAC `sub = subtopology euclideanreal + (real_interval[&0:real,&1])` THEN + SUBGOAL_THEN `continuous_map (sub,mtopology m) (g:real->A)` + ASSUME_TAC THENL + [EXPAND_TAC "sub" THEN + REWRITE_TAC[GSYM MTOPOLOGY_SUBMETRIC; + GSYM MTOPOLOGY_REAL_EUCLIDEAN_METRIC] THEN + MATCH_MP_TAC UNIFORMLY_CONTINUOUS_IMP_CONTINUOUS_MAP THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `topspace (sub:real topology) = real_interval[&0:real,&1]` + ASSUME_TAC THENL + [EXPAND_TAC "sub" THEN + REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY]; ALL_TAC] THEN + SUBGOAL_THEN + `IMAGE (g:real->A) (real_interval[&0,&1]) SUBSET mspace m` + ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o MATCH_MP + CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE) THEN + ASM_REWRITE_TAC[TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + REPEAT CONJ_TAC THENL + [(* compact: continuous image of compact *) + MATCH_MP_TAC IMAGE_COMPACT_IN THEN + EXISTS_TAC `sub:real topology` THEN ASM_REWRITE_TAC[] THEN + EXPAND_TAC "sub" THEN + REWRITE_TAC[COMPACT_IN_SUBTOPOLOGY; + COMPACT_IN_EUCLIDEANREAL_INTERVAL; SUBSET_REFL]; + (* connected: continuous image of connected *) + MATCH_MP_TAC CONNECTED_IN_CONTINUOUS_MAP_IMAGE THEN + EXISTS_TAC `sub:real topology` THEN ASM_REWRITE_TAC[] THEN + EXPAND_TAC "sub" THEN + REWRITE_TAC[CONNECTED_IN_SUBTOPOLOGY; + CONNECTED_IN_EUCLIDEANREAL_INTERVAL; SUBSET_REFL]; + (* locally connected: quotient image of LC *) + SUBGOAL_THEN `locally_connected_space (sub:real topology)` + ASSUME_TAC THENL + [EXPAND_TAC "sub" THEN + REWRITE_TAC[LOCALLY_CONNECTED_REAL_INTERVAL]; ALL_TAC] THEN + SUBGOAL_THEN `compact_space (sub:real topology)` ASSUME_TAC THENL + [EXPAND_TAC "sub" THEN MATCH_MP_TAC COMPACT_SPACE_SUBTOPOLOGY THEN + REWRITE_TAC[COMPACT_IN_EUCLIDEANREAL_INTERVAL]; ALL_TAC] THEN + SUBGOAL_THEN `quotient_map(sub, + subtopology (mtopology m) + (IMAGE (g:real->A) (real_interval[&0,&1]))) g` + ASSUME_TAC THENL + [MATCH_MP_TAC CONTINUOUS_IMP_QUOTIENT_MAP THEN + ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [MATCH_MP_TAC HAUSDORFF_SPACE_SUBTOPOLOGY THEN + REWRITE_TAC[HAUSDORFF_SPACE_MTOPOLOGY]; + MATCH_MP_TAC CONTINUOUS_MAP_INTO_SUBTOPOLOGY THEN + ASM_REWRITE_TAC[] THEN ASM_SIMP_TAC[SUBSET_REFL]; + ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY; TOPSPACE_MTOPOLOGY] THEN + ASM SET_TAC[]]; ALL_TAC] THEN + MATCH_MP_TAC(ISPECL + [`sub:real topology`; + `subtopology (mtopology (m:A metric)) + (IMAGE (g:real->A) (real_interval[&0,&1]))`; + `g:real->A`] + LOCALLY_CONNECTED_SPACE_QUOTIENT_MAP_IMAGE) THEN + ASM_REWRITE_TAC[]; + (* a IN IMAGE g [0,1] *) + REWRITE_TAC[IN_IMAGE] THEN EXISTS_TAC `&0` THEN CONJ_TAC THENL + [SUBGOAL_THEN `(g:real->A)(&0) = f(&0)` SUBST1_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN REWRITE_TAC[IN_ELIM_THM] THEN + MAP_EVERY EXISTS_TAC [`0`; `0`] THEN + REWRITE_TAC[LE_0] THEN REAL_ARITH_TAC; + ASM_REWRITE_TAC[]]; + REWRITE_TAC[IN_REAL_INTERVAL] THEN REAL_ARITH_TAC]; + (* b IN IMAGE g [0,1] *) + REWRITE_TAC[IN_IMAGE] THEN EXISTS_TAC `&1` THEN CONJ_TAC THENL + [SUBGOAL_THEN `(g:real->A)(&1) = f(&1)` SUBST1_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN REWRITE_TAC[IN_ELIM_THM] THEN + MAP_EVERY EXISTS_TAC [`1`; `0`] THEN + CONV_TAC NUM_REDUCE_CONV THEN REAL_ARITH_TAC; + ASM_REWRITE_TAC[]]; + REWRITE_TAC[IN_REAL_INTERVAL] THEN REAL_ARITH_TAC]]);; + + +(* Localized version: imbedding theorem for a complete *) +(* metric subspace. *) + +let MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM_IN = prove + (`!m:A metric s a b. + mcomplete(submetric m s) /\ + connected_in (mtopology m) s /\ + locally_connected_space (subtopology (mtopology m) s) /\ + a IN s /\ b IN s + ==> ?K. compact_in (mtopology m) K /\ + connected_in (mtopology m) K /\ + locally_connected_space + (subtopology (mtopology m) K) /\ + K SUBSET s /\ a IN K /\ b IN K`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN `(s:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[CONNECTED_IN_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN + SUBGOAL_THEN `(a:A) IN mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + SUBGOAL_THEN `(b:A) IN mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + MP_TAC(ISPECL [`submetric m (s:A->bool)`; `a:A`; `b:A`] + MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM) THEN + ASM_SIMP_TAC[MTOPOLOGY_SUBMETRIC; + SET_RULE `s SUBSET t ==> t INTER s = (s:A->bool)`; + SUBMETRIC; IN_INTER] THEN + ANTS_TAC THENL [ASM_MESON_TAC[connected_in]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `K:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `K:A->bool` THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `(K:A->bool) SUBSET s` ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBTOPOLOGY]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBTOPOLOGY]; + ASM_MESON_TAC[CONNECTED_IN_SUBTOPOLOGY]; + SUBGOAL_THEN `s INTER (K:A->bool) = K` + (fun eq_th -> + FIRST_X_ASSUM(ACCEPT_TAC o + REWRITE_RULE[SUBTOPOLOGY_SUBTOPOLOGY; eq_th])) THEN + ASM SET_TAC[]]);; (* ------------------------------------------------------------------------- *) -(* Contractions. *) +(* "Capped" equivalent bounded metrics and general product metrics. *) (* ------------------------------------------------------------------------- *) -let CONTRACTION_IMP_UNIQUE_FIXPOINT = prove - (`!m (f:A->A) k x y. - k < &1 /\ - (!x. x IN mspace m ==> f x IN mspace m) /\ - (!x y. x IN mspace m /\ y IN mspace m - ==> mdist m (f x, f y) <= k * mdist m (x,y)) /\ - x IN mspace m /\ y IN mspace m /\ f x = x /\ f y = y - ==> x = y`, - INTRO_TAC "!m f k x y; k f le x y xeq yeq" THEN - ASM_CASES_TAC `x:A = y` THENL [POP_ASSUM ACCEPT_TAC; ALL_TAC] THEN - REMOVE_THEN "le" (MP_TAC o SPECL[`x:A`;`y:A`]) THEN ASM_REWRITE_TAC[] THEN - CUT_TAC `&0 < (&1 - k) * mdist m (x:A,y:A)` THENL - [REAL_ARITH_TAC; - MATCH_MP_TAC REAL_LT_MUL THEN ASM_SIMP_TAC[MDIST_POS_LT] THEN - ASM_REAL_ARITH_TAC]);; +let capped_metric = new_definition + `capped_metric d (m:A metric) = + if d <= &0 then m + else metric(mspace m,(\(x,y). min d (mdist m (x,y))))`;; -(* ------------------------------------------------------------------------- *) -(* Banach Fixed-Point Theorem (aka, Contraction Mapping Principle). *) -(* ------------------------------------------------------------------------- *) +let CAPPED_METRIC = prove + (`!d m:A metric. + mspace (capped_metric d m) = mspace m /\ + mdist (capped_metric d m) = + \(x,y). if d <= &0 then mdist m (x,y) else min d (mdist m (x,y))`, + REPEAT GEN_TAC THEN ASM_CASES_TAC `d:real <= &0` THEN + ASM_REWRITE_TAC[capped_metric; PAIRED_ETA_THM; ETA_AX] THEN + REWRITE_TAC[capped_metric; mspace; mdist; GSYM PAIR_EQ] THEN + REWRITE_TAC[GSYM(CONJUNCT2 metric_tybij)] THEN + REWRITE_TAC[is_metric_space; GSYM mspace; GSYM mdist] THEN + ASM_SIMP_TAC[REAL_ARITH `~(d <= &0) ==> (&0 <= min d x <=> &0 <= x)`] THEN + ASM_SIMP_TAC[MDIST_POS_LE; MDIST_0; REAL_ARITH + `~(d <= &0) /\ &0 <= x ==> (min d x = &0 <=> x = &0)`] THEN + CONJ_TAC THENL [MESON_TAC[MDIST_SYM]; REPEAT STRIP_TAC] THEN + MATCH_MP_TAC(REAL_ARITH + `~(d <= &0) /\ &0 <= y /\ &0 <= z /\ x <= y + z + ==> min d x <= min d y + min d z`) THEN + ASM_MESON_TAC[MDIST_POS_LE; MDIST_TRIANGLE]);; -let BANACH_FIXPOINT_THM = prove - (`!m f:A->A k. - ~(mspace m = {}) /\ - mcomplete m /\ - (!x. x IN mspace m ==> f x IN mspace m) /\ - k < &1 /\ - (!x y. x IN mspace m /\ y IN mspace m - ==> mdist m (f x, f y) <= k * mdist m (x,y)) - ==> (?!x. x IN mspace m /\ f x = x)`, - INTRO_TAC "!m f k; ne compl 4 k1 contr" THEN REMOVE_THEN "ne" MP_TAC THEN - REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN INTRO_TAC "@a. aINm" THEN - REWRITE_TAC[EXISTS_UNIQUE_THM] THEN CONJ_TAC THENL - [ALL_TAC; - REPEAT STRIP_TAC THEN MATCH_MP_TAC CONTRACTION_IMP_UNIQUE_FIXPOINT THEN - ASM_MESON_TAC[]] THEN - ASM_CASES_TAC `!x:A. x IN mspace m ==> f x:A = f a` THENL - [ASM_MESON_TAC[]; POP_ASSUM (LABEL_TAC "nonsing")] THEN - CLAIM_TAC "kpos" `&0 < k` THENL - [MATCH_MP_TAC (ISPECL [`m:A metric`; `m:A metric`; `f:A->A`] - LIPSCHITZ_COEFFICIENT_POS) THEN - ASM_SIMP_TAC[] THEN ASM_MESON_TAC[]; - ALL_TAC] THEN - CLAIM_TAC "fINm" `!n:num. (ITER n f (a:A)) IN mspace m` THENL - [LABEL_INDUCT_TAC THEN ASM_SIMP_TAC[ITER]; ALL_TAC] THEN - ASM_CASES_TAC `f a = a:A` THENL - [ASM_MESON_TAC[]; POP_ASSUM (LABEL_TAC "aneq")] THEN - CUT_TAC `cauchy_in (m:A metric) (\n. ITER n f (a:A))` THENL - [DISCH_THEN (fun cauchy -> HYP_TAC "compl : @l. lim" - (C MATCH_MP cauchy o REWRITE_RULE[mcomplete])) THEN - EXISTS_TAC `l:A` THEN CONJ_TAC THENL - [ASM_MESON_TAC [LIMIT_IN_MSPACE]; ALL_TAC] THEN - MATCH_MP_TAC - (ISPECL [`sequentially`; `m:A metric`; `(\n. ITER n f a:A)`] - LIMIT_METRIC_UNIQUE) THEN - ASM_REWRITE_TAC[TRIVIAL_LIMIT_SEQUENTIALLY] THEN - MATCH_MP_TAC LIMIT_SEQUENTIALLY_OFFSET_REV THEN - EXISTS_TAC `1` THEN REWRITE_TAC[GSYM ADD1] THEN - SUBGOAL_THEN `(\i. ITER (SUC i) f (a:A)) = f o (\i. ITER i f a)` - SUBST1_TAC THENL [REWRITE_TAC[FUN_EQ_THM; o_THM; ITER]; ALL_TAC] THEN - MATCH_MP_TAC CONTINUOUS_MAP_LIMIT THEN - EXISTS_TAC `mtopology (m:A metric)` THEN ASM_REWRITE_TAC[] THEN - MATCH_MP_TAC LIPSCHITZ_CONTINUOUS_IMP_CONTINUOUS_MAP THEN - ASM_REWRITE_TAC[lipschitz_continuous_map; SUBSET; FORALL_IN_IMAGE] THEN - EXISTS_TAC `k:real` THEN ASM_REWRITE_TAC[]; - ALL_TAC] THEN - CLAIM_TAC "k1'" `&0 < &1 - k` THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN - ASM_SIMP_TAC[cauchy_in] THEN INTRO_TAC "!e; e" THEN - CLAIM_TAC "@N. N" `?N. k pow N < ((&1 - k) * e) / mdist m (a:A,f a)` THENL - [MATCH_MP_TAC REAL_ARCH_POW_INV THEN - ASM_SIMP_TAC[REAL_LT_DIV; MDIST_POS_LT; REAL_LT_MUL]; - EXISTS_TAC `N:num`] THEN - MATCH_MP_TAC WLOG_LT THEN ASM_SIMP_TAC[MDIST_REFL] THEN CONJ_TAC THENL - [HYP MESON_TAC "fINm" [MDIST_SYM]; ALL_TAC] THEN - INTRO_TAC "!n n'; lt; le le'" THEN - TRANS_TAC REAL_LET_TRANS - `sum (n..n'-1) (\i. mdist m (ITER i f a:A, ITER (SUC i) f a))` THEN - CONJ_TAC THENL - [REMOVE_THEN "lt" MP_TAC THEN SPEC_TAC (`n':num`,`n':num`) THEN - LABEL_INDUCT_TAC THENL [REWRITE_TAC[LT]; REWRITE_TAC[LT_SUC_LE]] THEN - INTRO_TAC "nle" THEN HYP_TAC "nle : nlt | neq" (REWRITE_RULE[LE_LT]) THENL - [ALL_TAC; - POP_ASSUM SUBST_ALL_TAC THEN - REWRITE_TAC[ITER; - ARITH_RULE `SUC n'' - 1 = n''`; SUM_SING_NUMSEG; REAL_LE_REFL]] THEN - USE_THEN "nlt" (HYP_TAC "ind_n'" o C MATCH_MP) THEN REWRITE_TAC[ITER] THEN - TRANS_TAC REAL_LE_TRANS - `mdist m (ITER n f a:A,ITER n'' f a) + - mdist m (ITER n'' f a,f (ITER n'' f a))` THEN - ASM_SIMP_TAC[MDIST_TRIANGLE] THEN - SUBGOAL_THEN `SUC n'' - 1 = SUC (n'' - 1)` SUBST1_TAC THENL - [ASM_ARITH_TAC; ASM_SIMP_TAC[SUM_CLAUSES_NUMSEG]] THEN - SUBGOAL_THEN `SUC (n'' - 1) = n''` SUBST1_TAC THENL - [ASM_ARITH_TAC; ASM_SIMP_TAC[LT_IMP_LE; REAL_LE_RADD]] THEN - REMOVE_THEN "ind_n'" (ACCEPT_TAC o REWRITE_RULE[ITER]); - ALL_TAC] THEN - TRANS_TAC REAL_LET_TRANS - `sum (n..n'-1) (\i. mdist m (a:A, f a) * k pow i)` THEN CONJ_TAC THENL - [MATCH_MP_TAC SUM_LE_NUMSEG THEN - CUT_TAC `!i. mdist m (ITER i f a,ITER (SUC i) f a) <= - mdist m (a:A,f a) * k pow i` THENL - [SIMP_TAC[ITER]; ALL_TAC] THEN - LABEL_INDUCT_TAC THENL - [REWRITE_TAC[ITER; real_pow; REAL_MUL_RID; REAL_LE_REFL]; - HYP_TAC "ind_i" (REWRITE_RULE[ITER]) THEN - TRANS_TAC REAL_LE_TRANS `k * mdist m (ITER i f a:A, f (ITER i f a))` THEN - ASM_SIMP_TAC[real_pow; REAL_LE_LMUL_EQ; ITER; - REAL_ARITH `!x. x * k * k pow i = k * x * k pow i`]]; - ALL_TAC] THEN - REWRITE_TAC[SUM_LMUL; SUM_GP] THEN - HYP SIMP_TAC "lt" [ARITH_RULE `n < n' ==> ~(n' - 1 < n)`] THEN - HYP SIMP_TAC "k1" [REAL_ARITH `k < &1 ==> ~(k = &1)`] THEN - USE_THEN "lt" (SUBST1_TAC o - MATCH_MP (ARITH_RULE `n < n' ==> SUC (n' - 1) = n'`)) THEN - SUBGOAL_THEN `k pow n - k pow n' = k pow n * (&1 - k pow (n' - n))` - SUBST1_TAC THENL - [REWRITE_TAC[REAL_SUB_LDISTRIB; REAL_MUL_RID; GSYM REAL_POW_ADD] THEN - HYP SIMP_TAC "lt" [ARITH_RULE `n < n' ==> n + n' - n = n':num`]; - (SUBST1_TAC o REAL_ARITH) - `mdist m (a:A,f a) * (k pow n * (&1 - k pow (n' - n))) / (&1 - k) = - ((k pow n * (&1 - k pow (n' - n))) / (&1 - k)) * mdist m (a,f a)`] THEN - ASM_SIMP_TAC[GSYM REAL_LT_RDIV_EQ; MDIST_POS_LT; REAL_LT_LDIV_EQ] THEN - TRANS_TAC REAL_LET_TRANS `k pow n` THEN CONJ_TAC THENL - [ONCE_REWRITE_TAC[GSYM REAL_SUB_LE] THEN - REWRITE_TAC[GSYM REAL_POW_ADD; - REAL_ARITH `k pow n - k pow n * (&1 - k pow (n' - n)) = - k pow n * k pow (n' - n)`] THEN - HYP SIMP_TAC "lt" [ARITH_RULE `n < n' ==> n + n' - n = n':num`] THEN - HYP SIMP_TAC "kpos" [REAL_POW_LE; REAL_LT_IMP_LE]; - TRANS_TAC REAL_LET_TRANS `k pow N` THEN - ASM_SIMP_TAC[REAL_POW_MONO_INV; REAL_LT_IMP_LE; - REAL_ARITH `e / mdist m (a:A,f a) * (&1 - k) = - ((&1 - k) * e) / mdist m (a,f a)`]]);; +let MDIST_CAPPED = prove + (`!d m x y:A. &0 < d ==> mdist(capped_metric d m) (x,y) <= d`, + SIMP_TAC[CAPPED_METRIC; GSYM REAL_NOT_LT] THEN REAL_ARITH_TAC);; -(* ------------------------------------------------------------------------- *) -(* Metric space of bounded functions. *) -(* ------------------------------------------------------------------------- *) +let MTOPOLOGY_CAPPED_METRIC = prove + (`!d m:A metric. mtopology(capped_metric d m) = mtopology m`, + REPEAT GEN_TAC THEN ASM_CASES_TAC `d <= &0` THENL + [ASM_MESON_TAC[capped_metric]; + RULE_ASSUM_TAC(REWRITE_RULE[REAL_NOT_LE])] THEN + REWRITE_TAC[TOPOLOGY_EQ] THEN + X_GEN_TAC `s:A->bool` THEN ASM_REWRITE_TAC[OPEN_IN_MTOPOLOGY] THEN + ASM_CASES_TAC `(s:A->bool) SUBSET mspace m` THEN + ASM_REWRITE_TAC[CAPPED_METRIC] THEN + AP_TERM_TAC THEN GEN_REWRITE_TAC I [FUN_EQ_THM] THEN + X_GEN_TAC `a:A` THEN ASM_CASES_TAC `(a:A) IN s` THEN ASM_REWRITE_TAC[] THEN + ASM_REWRITE_TAC[SUBSET; IN_MBALL] THEN + ASM_CASES_TAC `(a:A) IN mspace m` THENL + [ASM_REWRITE_TAC[CAPPED_METRIC]; ASM SET_TAC[]] THEN + EQ_TAC THEN + DISCH_THEN(X_CHOOSE_THEN `r:real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `min (d / &2) r` THEN + ASM_REWRITE_TAC[REAL_LT_MIN; REAL_HALF] THEN + REPEAT STRIP_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC);; -let funspace = new_definition - `funspace s m = - metric ({f:A->B | (!x. x IN s ==> f x IN mspace m) /\ - f IN EXTENSIONAL s /\ - mbounded m (IMAGE f s)}, - (\(f,g). if s = {} then &0 else - sup {mdist m (f x,g x) | x | x IN s}))`;; +let CAUCHY_IN_CAPPED_METRIC = prove + (`!d (m:A metric) x. + cauchy_in (capped_metric d m) x <=> cauchy_in m x`, + REPEAT GEN_TAC THEN ASM_CASES_TAC `d <= &0` THENL + [ASM_MESON_TAC[capped_metric]; ALL_TAC] THEN + ASM_REWRITE_TAC[cauchy_in; CAPPED_METRIC; REAL_MIN_LT] THEN + ASM_MESON_TAC[REAL_ARITH `~(d < min d e)`; REAL_LT_MIN; REAL_NOT_LE]);; -let FUNSPACE = (REWRITE_RULE[GSYM FORALL_AND_THM] o prove) - (`!s m. - mspace (funspace s m) = - {f:A->B | (!x. x IN s ==> f x IN mspace m) /\ - f IN EXTENSIONAL s /\ - mbounded m (IMAGE f s)} /\ - (!f g. mdist (funspace s m) (f,g) = - if s = {} then &0 else - sup {mdist m (f x,g x) | x | x IN s})`, - REPEAT GEN_TAC THEN MAP_EVERY LABEL_ABBREV_TAC - [`fspace = {f:A->B | (!x. x IN s ==> f x IN mspace m) /\ - f IN EXTENSIONAL s /\ - mbounded m (IMAGE f s)}`; - `fdist = - \(f,g). if s = {} then &0 else - sup {mdist m (f x:B,g x) | x | x:A IN s}`] THEN - CUT_TAC `mspace (funspace s m) = fspace:(A->B)->bool /\ - mdist (funspace s m:(A->B)metric) = fdist` THENL - [EXPAND_TAC "fdist" THEN DISCH_THEN (fun th -> REWRITE_TAC[th]); - ASM_REWRITE_TAC[funspace] THEN MATCH_MP_TAC METRIC] THEN - ASM_CASES_TAC `s:A->bool = {}` THENL - [POP_ASSUM SUBST_ALL_TAC THEN MAP_EVERY EXPAND_TAC ["fspace"; "fdist"] THEN - SIMP_TAC[is_metric_space; NOT_IN_EMPTY; IN_EXTENSIONAL; IMAGE_CLAUSES; - MBOUNDED_EMPTY; IN_ELIM_THM; REAL_LE_REFL; REAL_ADD_LID; FUN_EQ_THM]; - POP_ASSUM (LABEL_TAC "nempty")] THEN - REMOVE_THEN "nempty" (fun th -> - RULE_ASSUM_TAC(REWRITE_RULE[th]) THEN LABEL_TAC "nempty" th) THEN - CLAIM_TAC "wd ext bound" - `(!f x:A. f IN fspace /\ x IN s ==> f x:B IN mspace m) /\ - (!f. f IN fspace ==> f IN EXTENSIONAL s) /\ - (!f. f IN fspace - ==> (?c b. c IN mspace m /\ - (!x. x IN s ==> mdist m (c,f x) <= b)))` THENL - [EXPAND_TAC "fspace" THEN - ASM_SIMP_TAC[IN_ELIM_THM; MBOUNDED; IMAGE_EQ_EMPTY] THEN SET_TAC[]; - ALL_TAC] THEN - CLAIM_TAC "bound2" - `!f g:A->B. f IN fspace /\ g IN fspace - ==> (?b. !x. x IN s ==> mdist m (f x,g x) <= b)` THENL - [REMOVE_THEN "fspace" (SUBST_ALL_TAC o GSYM) THEN - REWRITE_TAC[IN_ELIM_THM] THEN REPEAT STRIP_TAC THEN - CUT_TAC `mbounded m (IMAGE (f:A->B) s UNION IMAGE g s)` THENL - [REWRITE_TAC[MBOUNDED_ALT; SUBSET; IN_UNION] THEN - STRIP_TAC THEN EXISTS_TAC `b:real` THEN ASM SET_TAC []; - ASM_REWRITE_TAC[MBOUNDED_UNION]]; - ALL_TAC] THEN - HYP_TAC "nempty -> @a. a" (REWRITE_RULE[GSYM MEMBER_NOT_EMPTY]) THEN - REWRITE_TAC[is_metric_space] THEN CONJ_TAC THENL - [INTRO_TAC "![f] [g]; f g" THEN EXPAND_TAC "fdist" THEN - REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LE_SUP THEN - CLAIM_TAC "@b. b" `?b. !x:A. x IN s ==> mdist m (f x:B,g x) <= b` THENL - [HYP SIMP_TAC "bound2 f g" []; +let MCOMPLETE_CAPPED_METRIC = prove + (`!d (m:A metric). mcomplete(capped_metric d m) <=> mcomplete m`, + REWRITE_TAC[mcomplete; CAUCHY_IN_CAPPED_METRIC; MTOPOLOGY_CAPPED_METRIC]);; + +let BOUNDED_EQUIVALENT_METRIC = prove + (`!m:A metric d. + &0 < d + ==> ?m'. mspace m' = mspace m /\ + mtopology m' = mtopology m /\ + !x y. mdist m' (x,y) < d`, + REPEAT STRIP_TAC THEN EXISTS_TAC `capped_metric (d / &2) m:A metric` THEN + ASM_REWRITE_TAC[MTOPOLOGY_CAPPED_METRIC; CAPPED_METRIC] THEN + ASM_REAL_ARITH_TAC);; + +let SUP_METRIC_CARTESIAN_PRODUCT = prove + (`!k (m:K->(A)metric) m'. + metric(cartesian_product k (mspace o m), + \(x,y). sup {mdist(m i) (x i,y i) | i IN k}) = m' /\ + ~(k = {}) /\ + (?c. !i x y. i IN k /\ x IN mspace(m i) /\ y IN mspace(m i) + ==> mdist(m i) (x,y) <= c) + ==> mspace m' = cartesian_product k (mspace o m) /\ + mdist m' = (\(x,y). sup {mdist(m i) (x i,y i) | i IN k}) /\ + !x y b. x IN cartesian_product k (mspace o m) /\ + y IN cartesian_product k (mspace o m) + ==> (mdist m' (x,y) <= b <=> + !i. i IN k ==> mdist (m i) (x i,y i) <= b)`, + REPEAT GEN_TAC THEN DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC) THEN + ABBREV_TAC `M = \(x,y). sup {mdist(m i) (x i:A,y i) | (i:K) IN k}` THEN + SUBGOAL_THEN + `!x (y:K->A) b. + x IN cartesian_product k (mspace o m) /\ + y IN cartesian_product k (mspace o m) + ==> (M(x,y) <= b <=> !i. i IN k ==> mdist (m i) (x i,y i) <= b)` + ASSUME_TAC THENL + [REWRITE_TAC[cartesian_product; o_DEF; IN_ELIM_THM] THEN + REPEAT STRIP_TAC THEN EXPAND_TAC "M" THEN REWRITE_TAC[] THEN + W(MP_TAC o PART_MATCH (lhand o rand) REAL_SUP_LE_EQ o lhand o snd) THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN ASM SET_TAC[]; ALL_TAC] THEN - MAP_EVERY EXISTS_TAC [`b:real`; `mdist m (f(a:A):B,g a)`] THEN - REWRITE_TAC[IN_ELIM_THM] THEN HYP SIMP_TAC "wd f g a" [MDIST_POS_LE] THEN - HYP MESON_TAC "a b" []; + FIRST_ASSUM(MP_TAC o MATCH_MP (MESON[] + `m = m' ==> mspace m = mspace m' /\ mdist m = mdist m'`)) THEN + REWRITE_TAC[GSYM PAIR_EQ; mspace; mdist] THEN + W(MP_TAC o PART_MATCH (lhand o rand) (CONJUNCT2 metric_tybij) o + lhand o lhand o snd) THEN + DISCH_THEN(MP_TAC o fst o EQ_IMP_RULE) THEN ANTS_TAC THENL + [ALL_TAC; + DISCH_THEN SUBST1_TAC THEN DISCH_THEN(SUBST1_TAC o SYM) THEN + ASM_REWRITE_TAC[GSYM mdist]] THEN + REWRITE_TAC[is_metric_space] THEN + MATCH_MP_TAC(TAUT `p /\ (p ==> q) ==> p /\ q`) THEN CONJ_TAC THENL + [REPEAT STRIP_TAC THEN EXPAND_TAC "M" THEN REWRITE_TAC[] THEN + MATCH_MP_TAC REAL_LE_SUP THEN + ASM_SIMP_TAC[FORALL_IN_GSPEC; EXISTS_IN_GSPEC] THEN + RULE_ASSUM_TAC(REWRITE_RULE[cartesian_product; IN_ELIM_THM; o_THM]) THEN + FIRST_X_ASSUM(X_CHOOSE_TAC `c:real`) THEN EXISTS_TAC `c:real` THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + MATCH_MP_TAC MONO_EXISTS THEN ASM_SIMP_TAC[MDIST_POS_LE]; + DISCH_TAC] THEN + REPEAT CONJ_TAC THENL + [ASM_SIMP_TAC[GSYM REAL_LE_ANTISYM] THEN REPEAT GEN_TAC THEN + DISCH_THEN(fun th -> + SUBST1_TAC(MATCH_MP CARTESIAN_PRODUCT_EQ_MEMBERS_EQ th) THEN + MP_TAC th) THEN + REWRITE_TAC[cartesian_product; o_THM; IN_ELIM_THM] THEN + SIMP_TAC[METRIC_ARITH + `x IN mspace m /\ y IN mspace m ==> (mdist m (x,y) <= &0 <=> x = y)`]; + REPEAT STRIP_TAC THEN EXPAND_TAC "M" THEN REWRITE_TAC[IN_ELIM_THM] THEN + AP_TERM_TAC THEN MATCH_MP_TAC(SET_RULE + `(!i. i IN w ==> f i = g i) ==> {f i | i IN w} = {g i | i IN w}`) THEN + RULE_ASSUM_TAC(REWRITE_RULE[cartesian_product; IN_ELIM_THM; o_THM]) THEN + ASM_MESON_TAC[MDIST_SYM]; + MAP_EVERY X_GEN_TAC [`x:K->A`; `y:K->A`; `z:K->A`] THEN + ASM_SIMP_TAC[] THEN STRIP_TAC THEN X_GEN_TAC `i:K` THEN DISCH_TAC THEN + TRANS_TAC REAL_LE_TRANS + `mdist (m i) ((x:K->A) i,y i) + mdist (m i) (y i,z i)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC MDIST_TRIANGLE THEN + RULE_ASSUM_TAC(REWRITE_RULE[cartesian_product; IN_ELIM_THM; o_THM]) THEN + ASM_SIMP_TAC[]; + MATCH_MP_TAC REAL_LE_ADD2 THEN EXPAND_TAC "M" THEN + REWRITE_TAC[] THEN CONJ_TAC THEN MATCH_MP_TAC ELEMENT_LE_SUP THEN + RULE_ASSUM_TAC(REWRITE_RULE[cartesian_product; IN_ELIM_THM; o_THM]) THEN + ASM SET_TAC[]]]);; + +let (METRIZABLE_SPACE_PRODUCT_TOPOLOGY, + COMPLETELY_METRIZABLE_SPACE_PRODUCT_TOPOLOGY) = (CONJ_PAIR o prove) + (`(!(tops:K->A topology) k. + metrizable_space (product_topology k tops) <=> + topspace (product_topology k tops) = {} \/ + COUNTABLE {i | i IN k /\ ~(?a. topspace(tops i) SUBSET {a})} /\ + !i. i IN k ==> metrizable_space (tops i)) /\ + (!(tops:K->A topology) k. + completely_metrizable_space (product_topology k tops) <=> + topspace (product_topology k tops) = {} \/ + COUNTABLE {i | i IN k /\ ~(?a. topspace(tops i) SUBSET {a})} /\ + !i. i IN k ==> completely_metrizable_space (tops i))`, + REWRITE_TAC[AND_FORALL_THM] THEN REPEAT GEN_TAC THEN + MATCH_MP_TAC(TAUT + `(n ==> m) /\ (t ==> n) /\ (m ==> t \/ m') /\ (n ==> t \/ n') /\ + (~t ==> m /\ m' ==> c) /\ (~t ==> c ==> (m' ==> m) /\ (n' ==> n)) + ==> (m <=> t \/ c /\ m') /\ (n <=> t \/ c /\ n')`) THEN + REWRITE_TAC[COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE] THEN CONJ_TAC THENL + [SIMP_TAC[GSYM SUBTOPOLOGY_EQ_DISCRETE_TOPOLOGY_EMPTY] THEN + REWRITE_TAC[COMPLETELY_METRIZABLE_SPACE_DISCRETE_TOPOLOGY]; + GEN_REWRITE_TAC I [CONJ_ASSOC]] THEN + CONJ_TAC THENL + [CONJ_TAC THEN MATCH_MP_TAC TOPOLOGICAL_PROPERTY_OF_PRODUCT_COMPONENT THEN + REWRITE_TAC[HOMEOMORPHIC_COMPLETELY_METRIZABLE_SPACE; + HOMEOMORPHIC_METRIZABLE_SPACE] THEN + ASM_SIMP_TAC[METRIZABLE_SPACE_SUBTOPOLOGY] THEN REPEAT STRIP_TAC THEN + MATCH_MP_TAC COMPLETELY_METRIZABLE_SPACE_CLOSED_IN THEN + ASM_REWRITE_TAC[CLOSED_IN_CARTESIAN_PRODUCT] THEN + DISJ2_TAC THEN REPEAT STRIP_TAC THEN + COND_CASES_TAC THEN ASM_REWRITE_TAC[CLOSED_IN_TOPSPACE] THEN + FIRST_ASSUM(MP_TAC o + MATCH_MP COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE) THEN + DISCH_THEN(MP_TAC o MATCH_MP METRIZABLE_IMP_T1_SPACE) THEN + REWRITE_TAC[T1_SPACE_PRODUCT_TOPOLOGY] THEN + REWRITE_TAC[T1_SPACE_CLOSED_IN_SING; RIGHT_IMP_FORALL_THM; IMP_IMP] THEN + STRIP_TAC THENL [ASM SET_TAC[]; FIRST_X_ASSUM MATCH_MP_TAC] THEN + RULE_ASSUM_TAC(REWRITE_RULE + [TOPSPACE_PRODUCT_TOPOLOGY; cartesian_product; o_DEF; IN_ELIM_THM]) THEN + ASM SET_TAC[]; ALL_TAC] THEN CONJ_TAC THENL - [INTRO_TAC "![f] [g]; f g" THEN EXPAND_TAC "fdist" THEN + [REPEAT STRIP_TAC THEN ABBREV_TAC + `l = {i:K | i IN k /\ ~(?a:A. topspace(tops i) SUBSET {a})}` THEN + SUBGOAL_THEN + `!i:K. ?p q:A. + i IN l ==> p IN topspace(tops i) /\ q IN topspace(tops i) /\ ~(p = q)` + MP_TAC THENL [EXPAND_TAC "l" THEN SET_TAC[]; ALL_TAC] THEN + REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`a:K->A`; `b:K->A`] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; o_DEF; LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `z:K->A` THEN DISCH_TAC THEN + ABBREV_TAC `p:K->A = \i. if i IN l then a i else z i` THEN + ABBREV_TAC `q:K->K->A = \i j. if j = i then b i else p j` THEN + SUBGOAL_THEN + `p IN topspace(product_topology k (tops:K->A topology)) /\ + (!i:K. i IN l + ==> q i IN topspace(product_topology k (tops:K->A topology)))` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `(z:K->A) IN cartesian_product k (\x. topspace(tops x))` THEN + MAP_EVERY EXPAND_TAC ["q"; "p"] THEN + REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; cartesian_product; o_THM] THEN + REWRITE_TAC[EXTENSIONAL; IN_ELIM_THM] THEN ASM SET_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN + `!u:(K->A)->bool. + open_in (product_topology k tops) u /\ p IN u + ==> FINITE {i:K | i IN l /\ ~(q i IN u)}` + ASSUME_TAC THENL + [X_GEN_TAC `u:(K->A)->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 MP_TAC ASSUME_TAC) THEN + REWRITE_TAC[OPEN_IN_PRODUCT_TOPOLOGY_ALT] THEN + DISCH_THEN(MP_TAC o SPEC `p:K->A`) THEN + ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `v:K->A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 MP_TAC STRIP_ASSUME_TAC) THEN + MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ_ALT] FINITE_SUBSET) THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN X_GEN_TAC `i:K` THEN + MATCH_MP_TAC(TAUT + `(l ==> k) /\ (k /\ l ==> p ==> q) ==> l /\ ~q ==> k /\ ~p`) THEN + CONJ_TAC THENL [ASM SET_TAC[]; REPEAT STRIP_TAC] THEN + FIRST_X_ASSUM(MATCH_MP_TAC o GEN_REWRITE_RULE I [SUBSET]) THEN + EXPAND_TAC "q" THEN UNDISCH_TAC `(p:K->A) IN cartesian_product k v` THEN + REWRITE_TAC[cartesian_product; IN_ELIM_THM; EXTENSIONAL] THEN + ASM SET_TAC[]; + ALL_TAC] THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [metrizable_space]) THEN + DISCH_THEN(X_CHOOSE_TAC `m:(K->A)metric`) THEN + MATCH_MP_TAC COUNTABLE_SUBSET THEN + EXISTS_TAC `UNIONS {{i | i IN l /\ + ~((q:K->K->A) i IN mball m (p,inv(&n + &1)))} | + n IN (:num)}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC COUNTABLE_UNIONS THEN REWRITE_TAC[SIMPLE_IMAGE] THEN + SIMP_TAC[COUNTABLE_IMAGE; NUM_COUNTABLE; FORALL_IN_IMAGE] THEN + X_GEN_TAC `n:num` THEN DISCH_THEN(K ALL_TAC) THEN + MATCH_MP_TAC FINITE_IMP_COUNTABLE THEN FIRST_X_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[OPEN_IN_MBALL] THEN MATCH_MP_TAC CENTRE_IN_MBALL THEN + REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`] THEN + ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]; + REWRITE_TAC[SUBSET; UNIONS_GSPEC; IN_ELIM_THM; IN_UNIV] THEN + X_GEN_TAC `i:K` THEN DISCH_TAC THEN MP_TAC(snd(EQ_IMP_RULE(ISPEC + `mdist (m:(K->A)metric) (p,q(i:K))` ARCH_EVENTUALLY_INV1))) THEN + ANTS_TAC THENL + [MATCH_MP_TAC MDIST_POS_LT THEN REPEAT + (CONJ_TAC THENL [ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]; ALL_TAC]) THEN + DISCH_THEN(MP_TAC o C AP_THM `i:K`) THEN + MAP_EVERY EXPAND_TAC ["q"; "p"] THEN REWRITE_TAC[] THEN + ASM_SIMP_TAC[]; + DISCH_THEN(MP_TAC o MATCH_MP EVENTUALLY_HAPPENS_SEQUENTIALLY) THEN + MATCH_MP_TAC MONO_EXISTS THEN + ASM_REWRITE_TAC[IN_MBALL] THEN REAL_ARITH_TAC]]; + ALL_TAC] THEN + DISCH_TAC THEN DISCH_TAC THEN + ASM_CASES_TAC `k:K->bool = {}` THENL + [ASM_REWRITE_TAC[NOT_IN_EMPTY; EMPTY_GSPEC; COUNTABLE_EMPTY] THEN + REWRITE_TAC[PRODUCT_TOPOLOGY_EMPTY_DISCRETE; + METRIZABLE_SPACE_DISCRETE_TOPOLOGY; + COMPLETELY_METRIZABLE_SPACE_DISCRETE_TOPOLOGY]; + ALL_TAC] THEN + REWRITE_TAC[metrizable_space; completely_metrizable_space] THEN + GEN_REWRITE_TAC (BINOP_CONV o LAND_CONV o BINDER_CONV) + [RIGHT_IMP_EXISTS_THM] THEN + REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM; AND_FORALL_THM] THEN + X_GEN_TAC `m:K->A metric` THEN ONCE_REWRITE_TAC[EQ_SYM_EQ] THEN + ASM_CASES_TAC `!i. i IN k ==> mtopology(m i) = (tops:K->A topology) i` THEN + ASM_SIMP_TAC[] THENL [ALL_TAC; ASM_MESON_TAC[]] THEN MATCH_MP_TAC(MESON[] + `!m. P m /\ (Q ==> C m) ==> (?m. P m) /\ (Q ==> ?m. C m /\ P m)`) THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I + [COUNTABLE_AS_INJECTIVE_IMAGE_SUBSET]) THEN + REWRITE_TAC[LEFT_IMP_EXISTS_THM; INJECTIVE_ON_LEFT_INVERSE] THEN + MAP_EVERY X_GEN_TAC [`nk:num->K`; `c:num->bool`] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (X_CHOOSE_TAC `kn:K->num`)) THEN + MP_TAC(ISPECL + [`k:K->bool`; `\i. capped_metric (inv(&(kn i) + &1)) ((m:K->A metric) i)`] + SUP_METRIC_CARTESIAN_PRODUCT) THEN + REWRITE_TAC[o_DEF; CONJUNCT1(SPEC_ALL CAPPED_METRIC)] THEN + MATCH_MP_TAC(MESON[] + `Q /\ (!m. P m ==> R m) + ==> (!m. a = m /\ Q ==> P m) ==> ?m. R m`) THEN + CONJ_TAC THENL + [ASM_REWRITE_TAC[] THEN EXISTS_TAC `&1:real` THEN + REWRITE_TAC[CAPPED_METRIC; GSYM REAL_NOT_LT] THEN + REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`] THEN + REWRITE_TAC[REAL_NOT_LT; REAL_MIN_LE] THEN REPEAT STRIP_TAC THEN + DISJ1_TAC THEN MATCH_MP_TAC REAL_INV_LE_1 THEN REAL_ARITH_TAC; + X_GEN_TAC `M:(K->A)metric`] THEN + SUBGOAL_THEN + `cartesian_product k (\i. mspace (m i)) = + topspace(product_topology k (tops:K->A topology))` + SUBST1_TAC THENL + [REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; CARTESIAN_PRODUCT_EQ] THEN + ASM_SIMP_TAC[GSYM TOPSPACE_MTOPOLOGY; o_THM]; + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + DISCH_THEN(CONJUNCTS_THEN2 (ASSUME_TAC o SYM) ASSUME_TAC)] THEN + MATCH_MP_TAC(TAUT `p /\ (p ==> q) ==> p /\ q`) THEN CONJ_TAC THENL + [REWRITE_TAC[MTOPOLOGY_BASE; product_topology] THEN + REWRITE_TAC[GSYM TOPSPACE_PRODUCT_TOPOLOGY_ALT] THEN + REWRITE_TAC[PRODUCT_TOPOLOGY_BASE_ALT] THEN + MATCH_MP_TAC TOPOLOGY_BASES_EQ THEN + REWRITE_TAC[SET_RULE `GSPEC P x <=> x IN GSPEC P`] THEN + REWRITE_TAC[EXISTS_IN_GSPEC; IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN + REWRITE_TAC[FORALL_IN_GSPEC; GSYM CONJ_ASSOC; IN_MBALL] THEN CONJ_TAC THENL + [MAP_EVERY X_GEN_TAC [`z:K->A`; `r:real`] THEN STRIP_TAC THEN + X_GEN_TAC `x:K->A` THEN STRIP_TAC THEN + SUBGOAL_THEN + `(!i. i IN k ==> (z:K->A) i IN topspace(tops i)) /\ + (!i. i IN k ==> (x:K->A) i IN topspace(tops i))` + STRIP_ASSUME_TAC THENL + [MAP_EVERY UNDISCH_TAC + [`(z:K->A) IN mspace M`; `(x:K->A) IN mspace M`] THEN + ASM_SIMP_TAC[TOPSPACE_PRODUCT_TOPOLOGY; cartesian_product; o_DEF] THEN + SET_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `?R. &0 < R /\ mdist M (z:K->A,x) < R /\ R < r` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[REAL_LT_BETWEEN; REAL_LET_TRANS; MDIST_POS_LE]; + ALL_TAC] THEN + EXISTS_TAC + `\i. if R <= inv(&(kn i) + &1) then mball (m i) (z i,R) + else topspace((tops:K->A topology) i)` THEN + REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [MP_TAC(ASSUME `&0 < R`) THEN DISCH_THEN(MP_TAC o + SPEC `&1:real` o MATCH_MP REAL_ARCH) THEN + DISCH_THEN(X_CHOOSE_TAC `n:num`) THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `IMAGE (nk:num->K) (c INTER (0..n))` THEN + SIMP_TAC[FINITE_IMAGE; FINITE_INTER; FINITE_NUMSEG] THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM; MESON[] + `~((if p then x else y) = y) <=> p /\ ~(x = y)`] THEN + FIRST_ASSUM(MATCH_MP_TAC o MATCH_MP (SET_RULE + `{i | i IN k /\ P i} = IMAGE nk c + ==> (!i. i IN k /\ Q i ==> P i) /\ + (!n. n IN c ==> Q(nk n) ==> n IN s) + ==> !i. i IN k /\ Q i ==> i IN IMAGE nk (c INTER s)`)) THEN + CONJ_TAC THENL + [X_GEN_TAC `i:K` THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + MATCH_MP_TAC(SET_RULE + `!x. b SUBSET u /\ x IN b + ==> P /\ ~(b = u) ==> ~(?a. u SUBSET {a})`) THEN + EXISTS_TAC `(z:K->A) i` THEN CONJ_TAC THENL + [REWRITE_TAC[SUBSET; IN_MBALL]; + MATCH_MP_TAC CENTRE_IN_MBALL] THEN + ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]; + X_GEN_TAC `m:num` THEN ASM_SIMP_TAC[IN_NUMSEG; LE_0] THEN + DISCH_TAC THEN DISCH_THEN(CONJUNCTS_THEN2 MP_TAC ASSUME_TAC) THEN + GEN_REWRITE_TAC I [GSYM CONTRAPOS_THM] THEN + REWRITE_TAC[NOT_LE; REAL_NOT_LE] THEN DISCH_TAC THEN + REWRITE_TAC[REAL_ARITH `inv x < y <=> &1 / x < y`] THEN + ASM_SIMP_TAC[REAL_LT_LDIV_EQ; REAL_ARITH `&0 < &n + &1`] THEN + FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (REAL_ARITH + `&1 < n * r ==> r * n < r * m ==> &1 < r * m`)) THEN + ASM_SIMP_TAC[REAL_LT_LMUL_EQ; REAL_OF_NUM_ADD; REAL_OF_NUM_LT] THEN + ASM_ARITH_TAC]; + ASM_MESON_TAC[OPEN_IN_MBALL; OPEN_IN_TOPSPACE]; + SUBGOAL_THEN `(x:K->A) IN cartesian_product k (topspace o tops)` + MP_TAC THENL [ASM_MESON_TAC[TOPSPACE_PRODUCT_TOPOLOGY]; ALL_TAC] THEN + REWRITE_TAC[cartesian_product; o_DEF; IN_ELIM_THM] THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN X_GEN_TAC `i:K` THEN + DISCH_TAC THEN COND_CASES_TAC THEN ASM_SIMP_TAC[IN_MBALL] THEN + REPEAT(CONJ_TAC THENL + [ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]; ALL_TAC]) THEN + FIRST_X_ASSUM(MP_TAC o SPECL + [`z:K->A`; `x:K->A`; `mdist M (z:K->A,x)`]) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; REWRITE_TAC[REAL_LE_REFL]] THEN + DISCH_THEN(MP_TAC o SPEC `i:K`) THEN + ASM_REWRITE_TAC[CAPPED_METRIC] THEN ASM_REAL_ARITH_TAC; + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `y:K->A` THEN + DISCH_THEN(LABEL_TAC "*") THEN + SUBGOAL_THEN `(y:K->A) IN mspace M` ASSUME_TAC THENL + [ASM_REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY] THEN + REMOVE_THEN "*" MP_TAC THEN REWRITE_TAC[cartesian_product] THEN + REWRITE_TAC[IN_ELIM_THM; o_THM] THEN + MATCH_MP_TAC MONO_AND THEN REWRITE_TAC[] THEN + MATCH_MP_TAC MONO_FORALL THEN X_GEN_TAC `i:K` THEN + ASM_CASES_TAC `(i:K) IN k` THEN ASM_REWRITE_TAC[] THEN + COND_CASES_TAC THEN ASM_REWRITE_TAC[IN_MBALL] THEN + MATCH_MP_TAC(SET_RULE + `s SUBSET t ==> P /\ x IN s /\ Q ==> x IN t`) THEN + ASM_SIMP_TAC[GSYM TOPSPACE_MTOPOLOGY; SUBSET_REFL]; + ALL_TAC] THEN + ASM_REWRITE_TAC[IN_MBALL] THEN + TRANS_TAC REAL_LET_TRANS `R:real` THEN ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o SPECL + [`z:K->A`; `y:K->A`; `R:real`]) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; DISCH_THEN SUBST1_TAC] THEN + REWRITE_TAC[CAPPED_METRIC; REAL_ARITH `x <= &0 <=> ~(&0 < x)`] THEN + REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`] THEN + REWRITE_TAC[REAL_MIN_LE] THEN X_GEN_TAC `i:K` THEN DISCH_TAC THEN + MATCH_MP_TAC(REAL_ARITH + `(a <= b ==> c <= d) ==> b <= a \/ c <= d`) THEN + DISCH_TAC THEN REMOVE_THEN "*" MP_TAC THEN + ASM_REWRITE_TAC[cartesian_product; IN_ELIM_THM] THEN + DISCH_THEN(MP_TAC o SPEC `i:K` o CONJUNCT2) THEN + ASM_REWRITE_TAC[IN_MBALL] THEN REAL_ARITH_TAC]; + X_GEN_TAC `u:K->A->bool` THEN STRIP_TAC THEN + X_GEN_TAC `z:K->A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(z:K->A) IN mspace M` ASSUME_TAC THENL + [UNDISCH_TAC `(z:K->A) IN cartesian_product k u` THEN + ASM_REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; cartesian_product] THEN + REWRITE_TAC[IN_ELIM_THM; o_THM] THEN + ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; + EXISTS_TAC `z:K->A` THEN ASM_SIMP_TAC[MDIST_REFL; CONJ_ASSOC]] THEN + SUBGOAL_THEN + `!i. ?r. i IN k ==> &0 < r /\ mball (m i) ((z:K->A) i,r) SUBSET u i` + MP_TAC THENL + [X_GEN_TAC `i:K` THEN REWRITE_TAC[RIGHT_EXISTS_IMP_THM] THEN + DISCH_TAC THEN + SUBGOAL_THEN `open_in(mtopology(m i)) ((u:K->A->bool) i)` MP_TAC THENL + [ASM_MESON_TAC[]; REWRITE_TAC[OPEN_IN_MTOPOLOGY]] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MATCH_MP_TAC) THEN + UNDISCH_TAC `(z:K->A) IN cartesian_product k u` THEN + ASM_SIMP_TAC[cartesian_product; IN_ELIM_THM]; + REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM]] THEN + X_GEN_TAC `r:K->real` THEN DISCH_TAC THEN + SUBGOAL_THEN `?a:K. a IN k` STRIP_ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + EXISTS_TAC + `inf (IMAGE (\i. min (r i) (inv(&(kn i) + &1))) + (a INSERT {i | i IN k /\ + ~(u i = topspace ((tops:K->A topology) i))})) / + &2` THEN + ASM_SIMP_TAC[REAL_LT_INF_FINITE; FINITE_INSERT; NOT_INSERT_EMPTY; + REAL_HALF; FINITE_IMAGE; IMAGE_EQ_EMPTY; FORALL_IN_IMAGE] THEN + REWRITE_TAC[REAL_LT_MIN; REAL_LT_INV_EQ] THEN + REWRITE_TAC[REAL_ARITH `&0 < &n + &1`] THEN + ASM_SIMP_TAC[FORALL_IN_INSERT; IN_ELIM_THM] THEN + REWRITE_TAC[SUBSET; IN_MBALL] THEN X_GEN_TAC `x:K->A` THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC o CONJUNCT2) THEN + DISCH_THEN(MP_TAC o MATCH_MP REAL_LT_IMP_LE) THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`z:K->A`; `x:K->A`]) THEN + REWRITE_TAC[RIGHT_FORALL_IMP_THM] THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + SUBGOAL_THEN `(x:K->A) IN topspace(product_topology k tops)` MP_TAC THENL + [ASM_MESON_TAC[]; REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY]] THEN + REWRITE_TAC[cartesian_product; o_THM; IN_ELIM_THM] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + ASM_REWRITE_TAC[IMP_IMP; AND_FORALL_THM] THEN + MATCH_MP_TAC MONO_FORALL THEN X_GEN_TAC `i:K` THEN + ASM_CASES_TAC `(i:K) IN k` THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + REWRITE_TAC[REAL_ARITH `x <= y / &2 <=> &2 * x <= y`] THEN + ASM_SIMP_TAC[REAL_LE_INF_FINITE; FINITE_INSERT; NOT_INSERT_EMPTY; + REAL_HALF; FINITE_IMAGE; IMAGE_EQ_EMPTY; FORALL_IN_IMAGE] THEN + REWRITE_TAC[FORALL_IN_INSERT] THEN + DISCH_THEN(MP_TAC o SPEC `i:K` o CONJUNCT2) THEN + ASM_CASES_TAC `(u:K->A->bool) i = topspace(tops i)` THEN + ASM_REWRITE_TAC[IN_ELIM_THM] THEN + REWRITE_TAC[CAPPED_METRIC; REAL_ARITH `x <= &0 <=> ~(&0 < x)`] THEN + REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`] THEN + DISCH_THEN(MP_TAC o MATCH_MP (REAL_ARITH + `&2 * min a b <= min c a ==> &0 < a /\ &0 < c ==> b < c`)) THEN + REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`] THEN + ASM_SIMP_TAC[] THEN DISCH_TAC THEN + REPEAT(FIRST_X_ASSUM(MP_TAC o SPEC `i:K`)) THEN + ASM_REWRITE_TAC[] THEN REPEAT STRIP_TAC THEN + FIRST_X_ASSUM(MATCH_MP_TAC o GEN_REWRITE_RULE I [SUBSET]) THEN + ASM_REWRITE_TAC[IN_MBALL] THEN + CONJ_TAC THENL [ALL_TAC; ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]] THEN + UNDISCH_TAC `(z:K->A) IN mspace M` THEN + ASM_REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; cartesian_product] THEN + REWRITE_TAC[IN_ELIM_THM; o_DEF] THEN + ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]]; + DISCH_TAC THEN REWRITE_TAC[mcomplete] THEN DISCH_THEN(LABEL_TAC "*") THEN + X_GEN_TAC `x:num->K->A` THEN ASM_REWRITE_TAC[cauchy_in] THEN STRIP_TAC THEN + ASM_REWRITE_TAC[LIMIT_COMPONENTWISE] THEN + SUBGOAL_THEN + `!i. ?y. i IN k ==> limit (tops i) (\n. (x:num->K->A) n i) y sequentially` + MP_TAC THENL + [X_GEN_TAC `i:K` THEN ASM_CASES_TAC `(i:K) IN k` THEN + ASM_REWRITE_TAC[] THEN REMOVE_THEN "*" (MP_TAC o SPEC `i:K`) THEN + ASM_SIMP_TAC[] THEN DISCH_THEN MATCH_MP_TAC THEN + REWRITE_TAC[cauchy_in; GSYM TOPSPACE_MTOPOLOGY] THEN CONJ_TAC THENL + [RULE_ASSUM_TAC(REWRITE_RULE[TOPSPACE_PRODUCT_TOPOLOGY; + cartesian_product; IN_ELIM_THM; o_DEF]) THEN ASM_MESON_TAC[]; + X_GEN_TAC `e:real` THEN DISCH_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `min e (inv(&(kn(i:K)) + &1)) / &2`) THEN + REWRITE_TAC[REAL_HALF; REAL_LT_MIN; REAL_LT_INV_EQ] THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; MATCH_MP_TAC MONO_EXISTS] THEN + X_GEN_TAC `N:num` THEN DISCH_TAC THEN + MAP_EVERY X_GEN_TAC [`m:num`; `n:num`] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`m:num`; `n:num`]) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN(MP_TAC o MATCH_MP REAL_LT_IMP_LE) THEN + ASM_SIMP_TAC[] THEN DISCH_THEN(MP_TAC o SPEC `i:K`) THEN + ASM_REWRITE_TAC[CAPPED_METRIC; REAL_ARITH `x <= &0 <=> ~(&0 < x)`] THEN + REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`] THEN + MATCH_MP_TAC(REAL_ARITH + `&0 < d /\ &0 < e ==> min d x <= min e d / &2 ==> x < e`) THEN + ASM_REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`]; + REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM]] THEN + X_GEN_TAC `y:K->A` THEN DISCH_TAC THEN + EXISTS_TAC `RESTRICTION k (y:K->A)` THEN + ASM_REWRITE_TAC[REWRITE_RULE[IN] RESTRICTION_IN_EXTENSIONAL] THEN + SIMP_TAC[RESTRICTION; EVENTUALLY_TRUE] THEN ASM_REWRITE_TAC[]]);; + +(* ------------------------------------------------------------------------- *) +(* Urysohn's metrization theorem. *) +(* ------------------------------------------------------------------------- *) + +let EMBEDDING_INTO_METRIZABLE_IMP_METRIZABLE = prove + (`!top top' (f:A->B). + embedding_map (top,top') f /\ metrizable_space top' + ==> metrizable_space top`, + REPEAT STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o MATCH_MP EMBEDDING_MAP_IMP_HOMEOMORPHIC_SPACE) THEN + DISCH_TAC THEN + MP_TAC(ISPECL [`top:A topology`; + `subtopology (top':B topology) (IMAGE (f:A->B) (topspace top))`] + HOMEOMORPHIC_METRIZABLE_SPACE) THEN + ASM_SIMP_TAC[METRIZABLE_SPACE_SUBTOPOLOGY]);; + +(* Helper lemma: separating functions give injectivity *) +let SEPARATING_FUNCTIONS_INJECTIVE = prove + (`!top (fs:num->A->real) x y. + hausdorff_space top /\ + (!x0 u. open_in top u /\ x0 IN u + ==> (?n. fs n x0 > &0 /\ + (!x. x IN topspace top /\ ~(x IN u) ==> fs n x = &0))) /\ + x IN topspace top /\ y IN topspace top + ==> ((\n. fs n x) = (\n. fs n y) <=> x = y)`, + REPEAT STRIP_TAC THEN EQ_TAC THENL + [DISCH_TAC THEN ASM_CASES_TAC `x:A = y` THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [hausdorff_space]) THEN + DISCH_THEN(MP_TAC o SPECL [`x:A`; `y:A`]) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` (X_CHOOSE_THEN `v:A->bool` + STRIP_ASSUME_TAC)) THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`x:A`; `u:A->bool`]) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `n:num` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(fs:num->A->real) n y = &0` ASSUME_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + ALL_TAC] THEN + UNDISCH_TAC `(\(n:num). (fs:num->A->real) n x) = (\n. fs n y)` THEN + REWRITE_TAC[FUN_EQ_THM] THEN + DISCH_THEN(MP_TAC o SPEC `n:num`) THEN + ASM_REAL_ARITH_TAC; + DISCH_THEN SUBST1_TAC THEN REFL_TAC]);; + +let METRIZABLE_PRODUCT_EUCLIDEANREAL_NUM = prove + (`metrizable_space (product_topology (:num) (\n. euclideanreal))`, + REWRITE_TAC[METRIZABLE_SPACE_PRODUCT_TOPOLOGY] THEN + DISJ2_TAC THEN CONJ_TAC THENL + [MATCH_MP_TAC COUNTABLE_SUBSET THEN EXISTS_TAC `(:num)` THEN + REWRITE_TAC[NUM_COUNTABLE; SUBSET_UNIV]; + GEN_TAC THEN DISCH_TAC THEN REWRITE_TAC[METRIZABLE_SPACE_EUCLIDEANREAL]]);; + +let URYSOHN_METRIZATION = prove + (`!top:A topology. + regular_space top /\ second_countable top /\ hausdorff_space top + ==> metrizable_space top`, + (* Helper lemma: construct countable family of separating functions *) + let CONSTRUCT_SEPARATING_FUNCTIONS = prove + (`!top:A topology. + regular_space top /\ second_countable top /\ normal_space top + ==> ?fs:(num->A->real). + (!n. continuous_map + (top, subtopology euclideanreal (real_interval[&0,&1])) + (fs n)) /\ + (!x0 u. open_in top u /\ x0 IN u + ==> ?n. (fs n) x0 > &0 /\ + (!x. x IN topspace top /\ ~(x IN u) + ==> (fs n) x = &0))`, + GEN_TAC THEN STRIP_TAC THEN + (* Extract a countable basis *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [second_countable]) THEN + DISCH_THEN(X_CHOOSE_THEN `cbasis:((A->bool)->bool)` STRIP_ASSUME_TAC) THEN + (* Enumerate the basis: use countability to get a sequence *) + SUBGOAL_THEN + `?b:num->A->bool. !u. u IN cbasis ==> ?n. b n = u` + STRIP_ASSUME_TAC THENL + [MP_TAC(ISPEC `cbasis:(A->bool)->bool` COUNTABLE_AS_IMAGE_SUBSET) THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[SUBSET; IN_IMAGE; IN_UNIV] THEN + MESON_TAC[]; + ALL_TAC] THEN + (* For pairs (n,m), construct functions using Urysohn lemma *) + (* g always gives continuous functions; properties hold when + open(b m) /\ closure(b n) SUBSET b m *) + SUBGOAL_THEN + `?g:(num#num)->A->real. + (!n m. continuous_map + (top, subtopology euclideanreal (real_interval[&0,&1])) + (g(n,m))) /\ + (!n m. open_in top (b m) /\ top closure_of (b n) SUBSET (b m) + ==> (!x. x IN topspace top /\ x IN (b n) ==> g(n,m) x = &1) /\ + (!x. x IN topspace top DIFF (b m) ==> g(n,m) x = &0))` + STRIP_ASSUME_TAC THENL + [(* Construct g by proving existence for each pair, then Skolemizing *) + (* For each (n,m): if condition holds use Urysohn, else use constant *) + SUBGOAL_THEN + `!n m. ?f. + continuous_map ((top:A topology), subtopology euclideanreal + (real_interval[&0,&1])) f /\ + (open_in top ((b:num->A->bool) m) /\ top closure_of (b n) SUBSET (b m) + ==> (!x. x IN topspace top /\ x IN (b n) ==> f x = &1) /\ + (!x. x IN topspace top DIFF (b m) ==> f x = &0))` + MP_TAC THENL + [(* Inner proof: for each (n,m), construct a suitable function *) + REPEAT GEN_TAC THEN + ASM_CASES_TAC `open_in top ((b:num->A->bool) m) /\ + top closure_of (b n) SUBSET (b m)` THENL + [(* TRUE: condition holds, use Urysohn lemma *) + FIRST_X_ASSUM(CONJUNCTS_THEN2 ASSUME_TAC ASSUME_TAC) THEN + (* Apply Urysohn lemma with a=0, b=1 on (topspace DIFF b m, + closure_of (b n)) *) + MP_TAC(ISPECL [`top:A topology`; + `topspace top DIFF (b:num->A->bool) m`; + `top closure_of (b:num->A->bool) n`; + `&0`; `&1`] URYSOHN_LEMMA) THEN + ASM_SIMP_TAC[REAL_POS; CLOSED_IN_DIFF; CLOSED_IN_TOPSPACE; + CLOSED_IN_CLOSURE_OF] THEN + ANTS_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `f:A->real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `f:A->real` THEN + ASM_REWRITE_TAC[] THEN + (* After ASM_REWRITE_TAC, + the goal is: forall x. x IN topspace /\ x IN b n ==> f x = &1 *) + (* Use CLOSURE_OF_SUBSET_INTER: topspace INTER (b n) SUBSET closure_of + (b n), and f = 1 on closure *) + X_GEN_TAC `x:A` THEN STRIP_TAC THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN + ASM_MESON_TAC[CLOSURE_OF_SUBSET_INTER; SUBSET; IN_INTER]; + (* FALSE: condition doesn't hold, use constant 1/2 *) + EXISTS_TAC `(\x:A. &1 / &2)` THEN CONJ_TAC THENL + [REWRITE_TAC[CONTINUOUS_MAP_CONST; TOPSPACE_SUBTOPOLOGY; IN_INTER; + IN_REAL_INTERVAL; TOPSPACE_EUCLIDEANREAL; IN_UNIV] THEN + REAL_ARITH_TAC; + ASM_REWRITE_TAC[]]]; + ALL_TAC] THEN + (* Use the proved statement to construct g directly *) + DISCH_TAC THEN + (* Use Hilbert choice to define g as the witness for each pair *) + EXISTS_TAC + `\(n:num,m:num). @f. continuous_map ((top:A topology), subtopology + euclideanreal (real_interval[&0,&1])) f /\ + (open_in top ((b:num->A->bool) m) /\ top closure_of (b n) SUBSET (b m) + ==> (!x. x IN topspace top /\ x IN (b n) ==> f x = &1) /\ + (!x. x IN topspace top DIFF (b m) ==> f x = &0))` THEN + REWRITE_TAC[] THEN CONJ_TAC THENL + [(* First conjunct: continuity of @f. P f /\ Q f *) + MAP_EVERY X_GEN_TAC [`n:num`; `m:num`] THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`n:num`; `m:num`]) THEN + DISCH_THEN(MP_TAC o SELECT_RULE) THEN SIMP_TAC[]; + (* Second conjunct: properties when condition holds *) + MAP_EVERY X_GEN_TAC [`n:num`; `m:num`] THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`n:num`; `m:num`]) THEN + DISCH_THEN(MP_TAC o SELECT_RULE) THEN ASM_SIMP_TAC[]]; + ALL_TAC] THEN + (* Enumerate pairs (num#num) as num to get final sequence *) + (* Use g composed with (NUMFST, NUMSND) to get fs:num->A->real *) + SUBGOAL_THEN + `?fs:num->A->real. + (!n. continuous_map + (top, subtopology euclideanreal (real_interval[&0,&1])) + (fs n)) /\ + (!x0 u. open_in top u /\ x0 IN u + ==> ?k. (fs k) x0 > &0 /\ + (!x. x IN topspace top /\ + ~(x IN u) ==> (fs k) x = &0))` + MP_TAC THENL + [EXISTS_TAC `\(k:num) (x:A). (g:num#num->A->real) (NUMFST k, NUMSND k) x` + THEN + CONJ_TAC THENL + [GEN_TAC THEN BETA_TAC THEN + CONV_TAC(RAND_CONV ETA_CONV) THEN + FIRST_X_ASSUM(MATCH_ACCEPT_TAC o SPECL [`NUMFST (n:num)`; `NUMSND + (n:num)`]); + MAP_EVERY X_GEN_TAC [`x0:A`; `u:A->bool`] THEN STRIP_TAC THEN + (* Step 1: Find basis element V1 with x0 IN V1 SUBSET u (will be b m) *) + SUBGOAL_THEN `?V1:A->bool. V1 IN cbasis /\ x0 IN V1 /\ + V1 SUBSET u` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `V1:A->bool` STRIP_ASSUME_TAC) THEN + (* V1 is a basis element, hence open *) + SUBGOAL_THEN `open_in top (V1:A->bool)` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + (* Step 2: Use regularity at x0 with V1 to get W with closure(W) SUBSET + V1 *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [regular_space]) THEN + DISCH_THEN(MP_TAC o SPECL [`topspace top DIFF V1:A->bool`; `x0:A`]) THEN + ASM_SIMP_TAC[CLOSED_IN_DIFF; CLOSED_IN_TOPSPACE; OPEN_IN_CLOSED_IN; + IN_DIFF] THEN + ANTS_TAC THENL [ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `W:A->bool` (X_CHOOSE_THEN `W':A->bool` + STRIP_ASSUME_TAC)) THEN + (* W and W' are disjoint opens with x0 + IN W and (topspace - V1) SUBSET W' *) + (* So closure(W) SUBSET topspace - W' SUBSET V1 *) + SUBGOAL_THEN `(W:A->bool) SUBSET topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET]; ALL_TAC] THEN + SUBGOAL_THEN `(W:A->bool) SUBSET topspace top DIFF W'` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + (* topspace - W' SUBSET V1 (from complement inclusion) *) + SUBGOAL_THEN `topspace top DIFF W':A->bool SUBSET V1` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `top closure_of (W:A->bool) SUBSET V1` ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET_TRANS; CLOSURE_OF_MINIMAL; CLOSED_IN_DIFF; + CLOSED_IN_TOPSPACE]; + ALL_TAC] THEN + (* Step 3: Find basis element U with x0 IN U SUBSET W (will be b n') *) + SUBGOAL_THEN `?U:A->bool. U IN cbasis /\ x0 IN U /\ + U SUBSET W` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `U:A->bool` STRIP_ASSUME_TAC) THEN + (* closure(U) SUBSET closure(W) SUBSET V1 *) + SUBGOAL_THEN `top closure_of (U:A->bool) SUBSET V1` ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET_TRANS; CLOSURE_OF_MONO]; ALL_TAC] THEN + (* U and V1 are basis elements, so there exist indices n', m' *) + SUBGOAL_THEN `?n':num. (b:num->A->bool) n' = U` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_TAC `n':num`) THEN + SUBGOAL_THEN `?m':num. (b:num->A->bool) m' = V1` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_TAC `m':num`) THEN + (* Now use k = NUMPAIR n' m' *) + EXISTS_TAC `NUMPAIR (n':num) (m':num)` THEN + SIMP_TAC[NUMPAIR_DEST] THEN + (* Get the g properties for (n', m') *) + FIRST_X_ASSUM(MP_TAC o SPECL [`n':num`; `m':num`]) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(CONJUNCTS_THEN2 + (LABEL_TAC "g_one") + (LABEL_TAC "g_zero")) THEN + CONJ_TAC THENL + [(* g(n', m') x0 > 0: since x0 + IN U = b n' and g = 1 on topspace INTER b n' *) + USE_THEN "g_one" (MP_TAC o SPEC `x0:A`) THEN + ANTS_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; REAL_ARITH_TAC]; + (* g(n', m') y = 0 for y IN topspace /\ y NOTIN u *) + X_GEN_TAC `y:A` THEN STRIP_TAC THEN + USE_THEN "g_zero" MATCH_MP_TAC THEN ASM SET_TAC[]]]; + DISCH_THEN(X_CHOOSE_THEN `fs:num->A->real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `fs:num->A->real` THEN ASM_REWRITE_TAC[]]) in + GEN_TAC THEN STRIP_TAC THEN + (* Our space is normal *) + SUBGOAL_THEN `normal_space (top:A topology)` ASSUME_TAC THENL + [MATCH_MP_TAC REGULAR_SECOND_COUNTABLE_HAUSDORFF_IMP_NORMAL_SPACE THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Step 1: Construct countable family of continuous functions *) + (* We need functions f_n: X -> [0,1] such that for any x_0 and neighborhood + U, there exists n with f_n(x_0) > 0 and f_n vanishing outside U *) + SUBGOAL_THEN + `?fs:(num->A->real). + (!n. continuous_map (top, subtopology euclideanreal + (real_interval[&0,&1])) + (fs n)) /\ + (!x0 u. open_in top u /\ x0 IN u + ==> ?n. (fs n) x0 > &0 /\ + (!x. x IN topspace top /\ ~(x IN u) ==> (fs n) x = &0))` + ASSUME_TAC THENL + [MATCH_MP_TAC CONSTRUCT_SEPARATING_FUNCTIONS THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Step 2: Define embedding F: X -> (num -> real) using the product topology + *) + (* F(x) = (fs 0 x, fs 1 x, fs 2 x, ...) *) + POP_ASSUM(X_CHOOSE_THEN `fs:num->A->real` STRIP_ASSUME_TAC) THEN + (* Define the embedding map: emb(x)(n) = fs n x *) + (* Then prove emb is an embedding *) + SUBGOAL_THEN + `?emb:A->num->real. + embedding_map (top, product_topology (:num) (\n. euclideanreal)) emb` + MP_TAC THENL + [EXISTS_TAC `\(x:A) (n:num). (fs n:A->real) x` THEN + (* Prove embedding: homeomorphism onto image with subtopology *) + REWRITE_TAC[embedding_map] THEN + MATCH_MP_TAC BIJECTIVE_OPEN_IMP_HOMEOMORPHIC_MAP THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; IN_INTER] THEN + REPEAT CONJ_TAC THENL + [(* Continuity into subtopology *) + REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET_REFL] THEN + REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN + X_GEN_TAC `n:num` THEN + CONV_TAC(RAND_CONV ETA_CONV) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `n:num`) THEN + REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN + MESON_TAC[]; + (* Open map into subtopology - KEY STEP *) + REWRITE_TAC[open_map] THEN X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN + (* Construct witness: union of basic opens {g : g(n) > 0} for separating n + *) + EXISTS_TAC + `UNIONS {v | ?n x. x IN u /\ x IN topspace top /\ + (fs:num->A->real) n x > &0 /\ + (!y. y IN topspace top /\ + ~(y IN u) ==> fs n y = &0) /\ + v = {g:num->real | g n > &0}}` THEN + CONJ_TAC THENL + [(* Prove witness is open in product topology *) + (* Each {g : g(n) > 0} is a basic open, UNIONS of opens is open *) + MATCH_MP_TAC OPEN_IN_UNIONS THEN + REWRITE_TAC[IN_ELIM_THM] THEN + X_GEN_TAC `v:(num->real)->bool` THEN + DISCH_THEN(X_CHOOSE_THEN `n':num` (X_CHOOSE_THEN `x':A` + (CONJUNCTS_THEN2 ASSUME_TAC (CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 ASSUME_TAC (CONJUNCTS_THEN2 ASSUME_TAC + SUBST1_TAC)))))) THEN + (* Need: open_in product_topology {g | g n' > &0} *) + (* This is preimage of {y | y > 0} under projection *) + SUBGOAL_THEN + `{g:num->real | g n' > &0} = + {g | g IN topspace(product_topology (:num) (\n. euclideanreal)) /\ + (\g. g n') g IN {y:real | y > &0}}` + SUBST1_TAC THENL + [REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY_ALT; EXTENSIONAL_UNIV; + o_DEF; TOPSPACE_EUCLIDEANREAL; IN_UNIV] THEN + SET_TAC[]; + MATCH_MP_TAC OPEN_IN_CONTINUOUS_MAP_PREIMAGE THEN + EXISTS_TAC `euclideanreal` THEN + SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV] THEN + REWRITE_TAC[GSYM REAL_OPEN_IN; REAL_OPEN_HALFSPACE_GT]]; + (* Prove set equality: IMAGE emb u = witness INTER IMAGE emb (topspace + top) *) + REWRITE_TAC[EXTENSION; IN_INTER; IN_IMAGE; IN_UNIONS] THEN + REWRITE_TAC[IN_ELIM_THM] THEN X_GEN_TAC `f:num->real` THEN + EQ_TAC THENL + [(* Forward: x IN u ==> emb(x) IN witness *) + DISCH_THEN(X_CHOOSE_THEN `x:A` STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [(* Show f IN UNIONS - use separation to get n *) + FIRST_X_ASSUM(MP_TAC o SPECL [`x:A`; `u:A->bool`]) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `n:num` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `{g:num->real | g n > &0}` THEN + ASM_REWRITE_TAC[IN_ELIM_THM] THEN + MAP_EVERY EXISTS_TAC [`n:num`; `x:A`] THEN + ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; + (* Show f IN IMAGE emb (topspace top) *) + EXISTS_TAC `x:A` THEN CONJ_TAC THENL + [REFL_TAC; ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]]]; + (* Backward: emb(x) IN witness ==> x IN u *) + REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + REPEAT GEN_TAC THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `t:(num->real)->bool` (CONJUNCTS_THEN2 + (X_CHOOSE_THEN `n:num` (X_CHOOSE_THEN `x:A` STRIP_ASSUME_TAC)) + ASSUME_TAC)) + (X_CHOOSE_THEN `x':A` STRIP_ASSUME_TAC)) THEN + (* Now we have all assumptions including x IN topspace top *) + EXISTS_TAC `x':A` THEN + ASM_REWRITE_TAC[] THEN + (* Prove x' IN u: we have f(n) > &0, f = emb(x'), so fs n x' > &0 *) + (* From witness: x IN u, x IN topspace top, fs n x > &0, + t = {g | g n > &0}, f IN t *) + (* From IMAGE: f = emb x', x' IN topspace top *) + (* Since f IN t and t = {g | g n > &0}, we have f n > &0, i.e., + fs n x' > &0 *) + (* By separation: if x' NOTIN u then fs n x' = 0, but fs n x' > &0, + so x' IN u *) + ASM_CASES_TAC `x':A IN u` THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `(fs:num->A->real) n x' = &0` ASSUME_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(fs:num->A->real) n x' > &0` MP_TAC THENL + [ASM_MESON_TAC[IN_ELIM_THM]; ASM_REAL_ARITH_TAC]]]; + (* Surjectivity onto subtopology topspace: IMAGE = topspace INTER IMAGE *) + REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY_ALT; o_DEF; + TOPSPACE_EUCLIDEANREAL; IN_UNIV; INTER_UNIV; + EXTENSIONAL_UNIV; IN_ELIM_THM] THEN + SET_TAC[]; + (* Injectivity using separation property with Hausdorff *) + REPEAT GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPECL [`top:A topology`; `fs:num->A->real`; `x:A`; `y:A`] + SEPARATING_FUNCTIONS_INJECTIVE) THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + (* Apply EMBEDDING_INTO_METRIZABLE_IMP_METRIZABLE *) + DISCH_THEN(X_CHOOSE_THEN `emb:A->num->real` ASSUME_TAC) THEN + MATCH_MP_TAC(INST_TYPE [`:num->real`,`:B`] + EMBEDDING_INTO_METRIZABLE_IMP_METRIZABLE) THEN + MAP_EVERY EXISTS_TAC + [`product_topology (:num) (\n. euclideanreal)`; + `emb:A->num->real`] THEN + ASM_MESON_TAC[METRIZABLE_PRODUCT_EUCLIDEANREAL_NUM]);; + +(* Corollary: equivalential form of Urysohn metrization *) +let URYSOHN_METRIZATION_EQ = prove + (`!top:A topology. + second_countable top + ==> (regular_space top /\ hausdorff_space top <=> + metrizable_space top)`, + GEN_TAC THEN DISCH_TAC THEN EQ_TAC THENL + [STRIP_TAC THEN MATCH_MP_TAC URYSOHN_METRIZATION THEN ASM_REWRITE_TAC[]; + MESON_TAC[METRIZABLE_IMP_REGULAR_SPACE; METRIZABLE_IMP_HAUSDORFF_SPACE]]);; + +(* ------------------------------------------------------------------------- *) +(* A perfect set in common cases must have cardinality >= c. *) +(* ------------------------------------------------------------------------- *) + +let CARD_GE_PERFECT_SET = prove + (`!top s:A->bool. + (completely_metrizable_space top \/ + locally_compact_space top /\ hausdorff_space top) /\ + top derived_set_of s = s /\ ~(s = {}) + ==> (:real) <=_c s`, + REWRITE_TAC[TAUT `(p \/ q) /\ r ==> s <=> + (p ==> r ==> s) /\ (q /\ r ==> s)`] THEN + REWRITE_TAC[FORALL_AND_THM; RIGHT_FORALL_IMP_THM] THEN + REWRITE_TAC[GSYM FORALL_MCOMPLETE_TOPOLOGY] THEN + REWRITE_TAC[RIGHT_IMP_FORALL_THM; IMP_IMP; GSYM CONJ_ASSOC] THEN + CONJ_TAC THENL + [REPEAT STRIP_TAC THEN + TRANS_TAC CARD_LE_TRANS `(:num->bool)` THEN + SIMP_TAC[CARD_EQ_REAL; CARD_EQ_IMP_LE] THEN + SUBGOAL_THEN `(s:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[DERIVED_SET_OF_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN + SUBGOAL_THEN + `!x e. x IN s /\ &0 < e + ==> ?y z d. y IN s /\ z IN s /\ &0 < d /\ d < e / &2 /\ + mcball m (y,d) SUBSET mcball m (x,e) /\ + mcball m (z,d) SUBSET mcball m (x,e) /\ + DISJOINT (mcball m (y:A,d)) (mcball m (z,d))` + MP_TAC THENL + [REPEAT STRIP_TAC THEN + MP_TAC(ISPECL [`m:A metric`; `s:A->bool`] + DERIVED_SET_OF_INFINITE_MBALL) THEN + ASM_REWRITE_TAC[EXTENSION; IN_ELIM_THM] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `e / &4`)) THEN + ASM_REWRITE_TAC[INFINITE; REAL_ARITH `&0 < e / &4 <=> &0 < e`] THEN + DISCH_THEN(MP_TAC o SPEC `x:A` o MATCH_MP + (MESON[FINITE_RULES; FINITE_SUBSET] + `~FINITE s ==> !a b c. ~(s SUBSET {a,b,c})`)) THEN + DISCH_THEN(MP_TAC o MATCH_MP (SET_RULE + `(!b c. ~(s SUBSET {a,b,c})) + ==> ?b c. b IN s /\ c IN s /\ ~(c = a) /\ ~(b = a) /\ ~(b = c)`)) THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `l:A` THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `r:A` THEN + REWRITE_TAC[IN_INTER] THEN STRIP_TAC THEN + EXISTS_TAC `mdist m (l:A,r) / &3` THEN + REPEAT(FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_MBALL])) THEN + UNDISCH_TAC `~(l:A = r)` THEN + REWRITE_TAC[DISJOINT; SUBSET; EXTENSION; IN_INTER; NOT_IN_EMPTY] THEN + ASM_SIMP_TAC[IN_MCBALL] THEN UNDISCH_TAC `(x:A) IN mspace m` THEN + POP_ASSUM_LIST(K ALL_TAC) THEN + REPEAT(DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC)) THEN + ONCE_REWRITE_TAC[CONJ_ASSOC] THEN CONJ_TAC THENL + [REPEAT(POP_ASSUM MP_TAC) THEN CONV_TAC METRIC_ARITH; ALL_TAC] THEN + REWRITE_TAC[AND_FORALL_THM] THEN X_GEN_TAC `y:A` THEN + REWRITE_TAC[CONJ_ASSOC] THEN CONJ_TAC THENL + [ALL_TAC; REPEAT(POP_ASSUM MP_TAC) THEN CONV_TAC METRIC_ARITH] THEN + REPEAT STRIP_TAC THEN FIRST_ASSUM(MP_TAC o SPEC `e:real` o MATCH_MP + (REAL_ARITH `x <= y / &3 ==> !e. y < e / &2 ==> x < e / &6`)) THEN + (ANTS_TAC THENL + [REPEAT(POP_ASSUM MP_TAC) THEN CONV_TAC METRIC_ARITH; ALL_TAC]) + THENL + [UNDISCH_TAC `mdist m (x:A,l) < e / &4`; + UNDISCH_TAC `mdist m (x:A,r) < e / &4`] THEN + MAP_EVERY UNDISCH_TAC + [`(x:A) IN mspace m`; `(y:A) IN mspace m`; + `(l:A) IN mspace m`; `(r:A) IN mspace m`] THEN + CONV_TAC METRIC_ARITH; + REWRITE_TAC[RIGHT_IMP_EXISTS_THM; SKOLEM_THM; LEFT_IMP_EXISTS_THM]] THEN + MAP_EVERY X_GEN_TAC + [`l:A->real->A`; `r:A->real->A`; `d:A->real->real`] THEN + DISCH_TAC THEN FIRST_X_ASSUM(X_CHOOSE_TAC `a:A` o + REWRITE_RULE[GSYM MEMBER_NOT_EMPTY]) THEN + SUBGOAL_THEN + `!b. ?xe. xe 0 = (a:A,&1) /\ + !n. xe(SUC n) = (if b(n) then r else l) (FST(xe n)) (SND(xe n)), + d (FST(xe n)) (SND(xe n))` + MP_TAC THENL + [GEN_TAC THEN + W(ACCEPT_TAC o prove_recursive_functions_exist num_RECURSION o + snd o dest_exists o snd); + REWRITE_TAC[EXISTS_PAIR_FUN_THM; PAIR_EQ] THEN + REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM; FORALL_AND_THM]] THEN + MAP_EVERY X_GEN_TAC + [`x:(num->bool)->num->A`; `r:(num->bool)->num->real`] THEN + STRIP_TAC THEN + SUBGOAL_THEN `mcomplete (submetric m s:A metric)` MP_TAC THENL + [MATCH_MP_TAC CLOSED_IN_MCOMPLETE_IMP_MCOMPLETE THEN + ASM_REWRITE_TAC[CLOSED_IN_CONTAINS_DERIVED_SET; TOPSPACE_MTOPOLOGY] THEN + ASM SET_TAC[]; + REWRITE_TAC[MCOMPLETE_NEST_SING]] THEN + DISCH_THEN(MP_TAC o MATCH_MP MONO_FORALL o GEN `b:num->bool` o + SPEC `\n. mcball (submetric m s) + ((x:(num->bool)->num->A) b n,r b n)`) THEN + REWRITE_TAC[SKOLEM_THM] THEN + SUBGOAL_THEN `(!b n. (x:(num->bool)->num->A) b n IN s) /\ + (!b n. &0 < (r:(num->bool)->num->real) b n)` + STRIP_ASSUME_TAC THENL + [REWRITE_TAC[AND_FORALL_THM] THEN GEN_TAC THEN + INDUCT_TAC THEN ASM_REWRITE_TAC[REAL_LT_01] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `(!b n. (x:(num->bool)->num->A) b n IN mspace m)` + ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + ANTS_TAC THENL + [X_GEN_TAC `b:num->bool` THEN REWRITE_TAC[CLOSED_IN_MCBALL] THEN + ASM_REWRITE_TAC[MCBALL_EQ_EMPTY; SUBMETRIC; IN_INTER] THEN + ASM_SIMP_TAC[REAL_ARITH `&0 < x ==> ~(x < &0)`] THEN CONJ_TAC THENL + [MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN + REPEAT(CONJ_TAC THENL [SET_TAC[]; ALL_TAC]) THEN + ASM_REWRITE_TAC[MCBALL_SUBMETRIC_EQ] THEN ASM SET_TAC[]; + X_GEN_TAC `e:real` THEN DISCH_TAC THEN + MP_TAC(ISPECL [`inv(&2)`; `e:real`] REAL_ARCH_POW_INV) THEN + ASM_REWRITE_TAC[REAL_POW_INV] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `n:num` THEN + DISCH_TAC THEN EXISTS_TAC `(x:(num->bool)->num->A) b n` THEN + MATCH_MP_TAC MCBALL_SUBSET_CONCENTRIC THEN + TRANS_TAC REAL_LE_TRANS `inv(&2 pow n)` THEN + ASM_SIMP_TAC[REAL_LT_IMP_LE] THEN + SPEC_TAC(`n:num`,`n:num`) THEN + MATCH_MP_TAC num_INDUCTION THEN ASM_REWRITE_TAC[real_pow] THEN + CONV_TAC REAL_RAT_REDUCE_CONV THEN REWRITE_TAC[REAL_INV_MUL] THEN + GEN_TAC THEN MATCH_MP_TAC(REAL_ARITH + `d < e / &2 ==> e <= i ==> d <= inv(&2) * i`) THEN + ASM_SIMP_TAC[]]; + REWRITE_TAC[SKOLEM_THM; le_c; IN_UNIV] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `z:(num->bool)->A` THEN + SIMP_TAC[SUBMETRIC; IN_INTER; FORALL_AND_THM] THEN STRIP_TAC THEN + MAP_EVERY X_GEN_TAC [`b:num->bool`; `c:num->bool`] THEN + GEN_REWRITE_TAC I [GSYM CONTRAPOS_THM] THEN + REWRITE_TAC[FUN_EQ_THM; NOT_FORALL_THM] THEN + GEN_REWRITE_TAC LAND_CONV [num_WOP] THEN + REWRITE_TAC[LEFT_IMP_EXISTS_THM; TAUT `~(p <=> q) <=> p <=> ~q`] THEN + X_GEN_TAC `n:num` THEN REPEAT STRIP_TAC THEN FIRST_ASSUM(MP_TAC o + GEN_REWRITE_RULE (BINDER_CONV o LAND_CONV) [INTERS_GSPEC]) THEN + DISCH_THEN(fun th -> + MP_TAC(SPEC `c:num->bool` th) THEN MP_TAC(SPEC `b:num->bool` th)) THEN + ASM_REWRITE_TAC[TAUT `p ==> ~q <=> ~(p /\ q)`] THEN + DISCH_THEN(MP_TAC o MATCH_MP (SET_RULE + `s = {a} /\ t = {a} ==> a IN s INTER t`)) THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM; AND_FORALL_THM] THEN + DISCH_THEN(MP_TAC o SPEC `SUC n`) THEN ASM_REWRITE_TAC[COND_SWAP] THEN + SUBGOAL_THEN + `(x:(num->bool)->num->A) b n = x c n /\ + (r:(num->bool)->num->real) b n = r c n` + (CONJUNCTS_THEN SUBST1_TAC) + THENL + [UNDISCH_TAC `!m:num. m < n ==> (b m <=> c m)` THEN + SPEC_TAC(`n:num`,`p:num`) THEN + INDUCT_TAC THEN ASM_SIMP_TAC[LT_SUC_LE; LE_REFL; LT_IMP_LE]; + COND_CASES_TAC THEN ASM_REWRITE_TAC[MCBALL_SUBMETRIC_EQ; IN_INTER] THEN + ASM SET_TAC[]]]; + SUBGOAL_THEN + `!top:A topology. + locally_compact_space top /\ hausdorff_space top /\ + top derived_set_of topspace top = topspace top /\ ~(topspace top = {}) + ==> (:real) <=_c topspace top` + ASSUME_TAC THENL + [REPEAT STRIP_TAC; + MAP_EVERY X_GEN_TAC [`top:A topology`; `s:A->bool`] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `subtopology top (s:A->bool)`) THEN + SUBGOAL_THEN `(s:A->bool) SUBSET topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[DERIVED_SET_OF_SUBSET_TOPSPACE]; ALL_TAC] THEN + ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY; HAUSDORFF_SPACE_SUBTOPOLOGY; + DERIVED_SET_OF_SUBTOPOLOGY; SET_RULE `s INTER s = s`; + SET_RULE `s SUBSET u ==> u INTER s = s`] THEN + DISCH_THEN MATCH_MP_TAC THEN + MATCH_MP_TAC LOCALLY_COMPACT_SPACE_CLOSED_SUBSET THEN + ASM_REWRITE_TAC[CLOSED_IN_CONTAINS_DERIVED_SET; SUBSET_REFL]] THEN + TRANS_TAC CARD_LE_TRANS `(:num->bool)` THEN + SIMP_TAC[CARD_EQ_REAL; CARD_EQ_IMP_LE] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + DISCH_THEN(X_CHOOSE_TAC `z:A`) THEN + FIRST_ASSUM(MP_TAC o SPEC `z:A` o REWRITE_RULE[locally_compact_space]) THEN + ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`u:A->bool`; `k:A->bool`] THEN STRIP_TAC THEN + SUBGOAL_THEN `~(u:A->bool = {})` ASSUME_TAC THENL + [ASM SET_TAC[]; + REPEAT(FIRST_X_ASSUM(K ALL_TAC o check (free_in `z:A`) o concl))] THEN + SUBGOAL_THEN + `!c. closed_in top c /\ c SUBSET k /\ ~(top interior_of c = {}) + ==> ?d e. closed_in top d /\ d SUBSET k /\ + ~(top interior_of d = {}) /\ + closed_in top e /\ e SUBSET k /\ + ~(top interior_of e = {}) /\ + DISJOINT d e /\ d SUBSET c /\ e SUBSET (c:A->bool)` + MP_TAC THENL + [REPEAT STRIP_TAC THEN + UNDISCH_TAC `~(top interior_of c:A->bool = {})` THEN + ASM_REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `z:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(z:A) IN topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET; INTERIOR_OF_SUBSET_TOPSPACE]; ALL_TAC] THEN + MP_TAC(ISPECL [`top:A topology`; `topspace top:A->bool`] + DERIVED_SET_OF_INFINITE_OPEN_IN) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN(MP_TAC o AP_TERM `\s. (z:A) IN s`) THEN + ASM_REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(MP_TAC o SPEC `top interior_of c:A->bool`) THEN + ASM_SIMP_TAC[OPEN_IN_INTERIOR_OF; INTERIOR_OF_SUBSET_TOPSPACE; + SET_RULE `s SUBSET u ==> u INTER s = s`] THEN + DISCH_THEN(MP_TAC o MATCH_MP (MESON[INFINITE; FINITE_SING; FINITE_SUBSET] + `INFINITE s ==> !a. ~(s SUBSET {a})`)) THEN + DISCH_THEN(MP_TAC o MATCH_MP (SET_RULE + `(!a. ~(s SUBSET {a})) ==> ?a b. a IN s /\ b IN s /\ ~(a = b)`)) THEN + REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN + SUBGOAL_THEN `(x:A) IN topspace top /\ y IN topspace top` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET; INTERIOR_OF_SUBSET_TOPSPACE]; ALL_TAC] THEN + FIRST_ASSUM(MP_TAC o SPECL [`x:A`; `y:A`] o + REWRITE_RULE[hausdorff_space]) THEN + ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`v:A->bool`; `w:A->bool`] THEN STRIP_TAC THEN + MP_TAC(ISPEC `top:A topology` + LOCALLY_COMPACT_HAUSDORFF_IMP_REGULAR_SPACE) THEN + ASM_REWRITE_TAC[GSYM NEIGHBOURHOOD_BASE_OF_CLOSED_IN] THEN + REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN DISCH_THEN(fun th -> + MP_TAC(SPECL [`top interior_of c INTER w:A->bool`; `y:A`] th) THEN + MP_TAC(SPECL [`top interior_of c INTER v:A->bool`; `x:A`] th)) THEN + ASM_SIMP_TAC[IN_INTER; OPEN_IN_INTER; OPEN_IN_INTERIOR_OF] THEN + REWRITE_TAC[LEFT_IMP_EXISTS_THM; SUBSET_INTER] THEN + MAP_EVERY X_GEN_TAC [`m:A->bool`; `d:A->bool`] THEN STRIP_TAC THEN + MAP_EVERY X_GEN_TAC [`n:A->bool`; `e:A->bool`] THEN STRIP_TAC THEN + MAP_EVERY EXISTS_TAC [`d:A->bool`; `e:A->bool`] THEN + ASM_REWRITE_TAC[] THEN ONCE_REWRITE_TAC[TAUT + `p /\ q /\ r /\ s /\ t <=> (q /\ s) /\ p /\ r /\ t`] THEN + CONJ_TAC THENL + [CONJ_TAC THENL [EXISTS_TAC `x:A`; EXISTS_TAC `y:A`] THEN + REWRITE_TAC[interior_of; IN_ELIM_THM] THEN ASM_MESON_TAC[]; + MP_TAC(ISPECL [`top:A topology`; `c:A->bool`] INTERIOR_OF_SUBSET) THEN + ASM SET_TAC[]]; + ALL_TAC] THEN + REWRITE_TAC[RIGHT_IMP_EXISTS_THM; SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`l:(A->bool)->A->bool`; `r:(A->bool)->A->bool`] THEN + DISCH_TAC THEN + SUBGOAL_THEN + `!b. ?d:num->A->bool. + d 0 = k /\ + (!n. d(SUC n) = (if b(n) then r else l) (d n))` + MP_TAC THENL + [GEN_TAC THEN + W(ACCEPT_TAC o prove_recursive_functions_exist num_RECURSION o + snd o dest_exists o snd); + REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM; FORALL_AND_THM]] THEN + X_GEN_TAC `d:(num->bool)->num->A->bool` THEN STRIP_TAC THEN + SUBGOAL_THEN + `!b n. closed_in top (d b n) /\ d b n SUBSET k /\ + ~(top interior_of ((d:(num->bool)->num->A->bool) b n) = {})` + MP_TAC THENL + [GEN_TAC THEN INDUCT_TAC THENL + [ASM_SIMP_TAC[SUBSET_REFL; COMPACT_IN_IMP_CLOSED_IN] THEN + FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (SET_RULE + `~(u = {}) ==> u SUBSET i ==> ~(i = {})`)) THEN + ASM_SIMP_TAC[INTERIOR_OF_MAXIMAL_EQ]; + ASM_REWRITE_TAC[] THEN COND_CASES_TAC THEN ASM_SIMP_TAC[]]; + REWRITE_TAC[FORALL_AND_THM] THEN STRIP_TAC] THEN + SUBGOAL_THEN + `!b. ~(INTERS {(d:(num->bool)->num->A->bool) b n | n IN (:num)} = {})` + MP_TAC THENL + [X_GEN_TAC `b:num->bool` THEN MATCH_MP_TAC COMPACT_SPACE_IMP_NEST THEN + EXISTS_TAC `subtopology top (k:A->bool)` THEN + ASM_SIMP_TAC[CLOSED_IN_SUBSET_TOPSPACE; COMPACT_SPACE_SUBTOPOLOGY] THEN + CONJ_TAC THENL [ASM_MESON_TAC[INTERIOR_OF_EMPTY]; ALL_TAC] THEN + MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN + REPEAT(CONJ_TAC THENL [SET_TAC[]; ALL_TAC]) THEN + ASM_SIMP_TAC[] THEN GEN_TAC THEN COND_CASES_TAC THEN + ASM_SIMP_TAC[]; + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; SKOLEM_THM; LEFT_IMP_EXISTS_THM]] THEN + X_GEN_TAC `x:(num->bool)->A` THEN + REWRITE_TAC[INTERS_GSPEC; IN_ELIM_THM; IN_UNIV] THEN DISCH_TAC THEN + REWRITE_TAC[le_c; IN_UNIV] THEN EXISTS_TAC `x:(num->bool)->A` THEN + CONJ_TAC THENL [ASM_MESON_TAC[CLOSED_IN_SUBSET; SUBSET]; ALL_TAC] THEN + MAP_EVERY X_GEN_TAC [`b:num->bool`; `c:num->bool`] THEN + GEN_REWRITE_TAC I [GSYM CONTRAPOS_THM] THEN + REWRITE_TAC[FUN_EQ_THM; NOT_FORALL_THM] THEN + GEN_REWRITE_TAC LAND_CONV [num_WOP] THEN + REWRITE_TAC[LEFT_IMP_EXISTS_THM; TAUT `~(p <=> q) <=> p <=> ~q`] THEN + X_GEN_TAC `n:num` THEN REPEAT STRIP_TAC THEN + SUBGOAL_THEN + `DISJOINT ((d:(num->bool)->num->A->bool) b (SUC n)) (d c (SUC n))` + MP_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN + ASM_SIMP_TAC[COND_SWAP] THEN + SUBGOAL_THEN `(d:(num->bool)->num->A->bool) b n = d c n` SUBST1_TAC THENL + [ALL_TAC; ASM_MESON_TAC[DISJOINT_SYM]] THEN + UNDISCH_TAC `!m:num. m < n ==> (b m <=> c m)` THEN + SPEC_TAC(`n:num`,`p:num`) THEN + INDUCT_TAC THEN ASM_SIMP_TAC[LT_SUC_LE; LE_REFL; LT_IMP_LE]]);; + +(* ------------------------------------------------------------------------- *) +(* Euclidean space and n-spheres, as subtopologies of infinite product R^N. *) +(* ------------------------------------------------------------------------- *) + +let euclidean_space = new_definition + `euclidean_space n = subtopology (product_topology (:num) (\i. euclideanreal)) + {x | !i. ~(i IN 1..n) ==> x i = &0}`;; + +let TOPSPACE_EUCLIDEAN_SPACE = prove + (`!n. topspace(euclidean_space n) = {x | !i. ~(i IN 1..n) ==> x i = &0}`, + REWRITE_TAC[euclidean_space; TOPSPACE_SUBTOPOLOGY; + TOPSPACE_PRODUCT_TOPOLOGY] THEN + REWRITE_TAC[o_DEF; TOPSPACE_EUCLIDEANREAL; CARTESIAN_PRODUCT_UNIV] THEN + REWRITE_TAC[INTER_UNIV]);; + +let NONEMPTY_EUCLIDEAN_SPACE = prove + (`!n. ~(topspace(euclidean_space n) = {})`, + GEN_TAC THEN REWRITE_TAC[TOPSPACE_EUCLIDEAN_SPACE] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + EXISTS_TAC `(\i. &0):num->real` THEN REWRITE_TAC[]);; + +let SUBSET_EUCLIDEAN_SPACE = prove + (`!m n. topspace(euclidean_space m) SUBSET topspace(euclidean_space n) <=> + m <= n`, + REPEAT GEN_TAC THEN + REWRITE_TAC[TOPSPACE_EUCLIDEAN_SPACE; SUBSET; IN_ELIM_THM; IN_NUMSEG] THEN + EQ_TAC THENL [ALL_TAC; MESON_TAC[LE_TRANS]] THEN + GEN_REWRITE_TAC I [GSYM CONTRAPOS_THM] THEN + REWRITE_TAC[NOT_LE] THEN DISCH_TAC THEN + DISCH_THEN(MP_TAC o SPEC `(\i. if i = m then &1 else &0):num->real`) THEN + REWRITE_TAC[NOT_IMP] THEN CONJ_TAC THENL + [REPEAT STRIP_TAC THEN COND_CASES_TAC THEN ASM_REWRITE_TAC[] THEN + ASM_ARITH_TAC; + DISCH_THEN(MP_TAC o SPEC `m:num`) THEN + REWRITE_TAC[] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN ASM_ARITH_TAC]);; + +let CLOSED_IN_EUCLIDEAN_SPACE = prove + (`!n. closed_in (product_topology (:num) (\i. euclideanreal)) + (topspace(euclidean_space n))`, + GEN_TAC THEN + SUBGOAL_THEN + `topspace(euclidean_space n) = + INTERS {{x | x IN topspace(product_topology (:num) (\i. euclideanreal)) /\ + x i IN {&0}} + | ~(i IN 1..n)}` + SUBST1_TAC THENL + [REWRITE_TAC[TOPSPACE_EUCLIDEAN_SPACE; INTERS_GSPEC; IN_ELIM_THM] THEN + REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; o_DEF] THEN + REWRITE_TAC[TOPSPACE_EUCLIDEANREAL; CARTESIAN_PRODUCT_UNIV] THEN + SET_TAC[]; + MATCH_MP_TAC CLOSED_IN_INTERS THEN REWRITE_TAC[FORALL_IN_GSPEC] THEN + REWRITE_TAC[SET_RULE `~({f x | P x} = {}) <=> ?x. P x`; IN_NUMSEG] THEN + REPEAT STRIP_TAC THENL [EXISTS_TAC `0` THEN ARITH_TAC; ALL_TAC] THEN + MATCH_MP_TAC CLOSED_IN_CONTINUOUS_MAP_PREIMAGE THEN + EXISTS_TAC `euclideanreal` THEN + SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV] THEN + REWRITE_TAC[GSYM REAL_CLOSED_IN; REAL_CLOSED_SING]]);; + +let COMPLETELY_METRIZABLE_EUCLIDEAN_SPACE = prove + (`!n. completely_metrizable_space(euclidean_space n)`, + GEN_TAC THEN REWRITE_TAC[euclidean_space] THEN + MATCH_MP_TAC COMPLETELY_METRIZABLE_SPACE_CLOSED_IN THEN + REWRITE_TAC[GSYM TOPSPACE_EUCLIDEAN_SPACE; CLOSED_IN_EUCLIDEAN_SPACE] THEN + REWRITE_TAC[COMPLETELY_METRIZABLE_SPACE_PRODUCT_TOPOLOGY] THEN + REWRITE_TAC[COMPLETELY_METRIZABLE_SPACE_EUCLIDEANREAL] THEN + REWRITE_TAC[COUNTABLE_SUBSET_NUM]);; + +let METRIZABLE_EUCLIDEAN_SPACE = prove + (`!n. metrizable_space(euclidean_space n)`, + SIMP_TAC[COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE; + COMPLETELY_METRIZABLE_EUCLIDEAN_SPACE]);; + +let CONTINUOUS_MAP_COMPONENTWISE_EUCLIDEAN_SPACE = prove + (`!top (f:A->num->real) n. + continuous_map (top,euclidean_space n) + (\x i. if 1 <= i /\ i <= n then f x i else &0) <=> + !i. 1 <= i /\ i <= n ==> continuous_map(top,euclideanreal) (\x. f x i)`, + REWRITE_TAC[euclidean_space; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN + SIMP_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM; IN_NUMSEG] THEN + REPEAT GEN_TAC THEN REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN + EQ_TAC THEN MATCH_MP_TAC MONO_FORALL THEN X_GEN_TAC `i:num` THEN + ASM_CASES_TAC `1 <= i /\ i <= n` THEN + ASM_REWRITE_TAC[CONTINUOUS_MAP_REAL_CONST]);; + +let CONTINUOUS_MAP_EUCLIDEAN_SPACE_ADD = prove + (`!f g:A->num->real. + continuous_map(top,euclidean_space n) f /\ + continuous_map(top,euclidean_space n) g + ==> continuous_map(top,euclidean_space n) (\x i. f x i + g x i)`, + REWRITE_TAC[euclidean_space; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN + SIMP_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM; REAL_ADD_LID] THEN + REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN + SIMP_TAC[CONTINUOUS_MAP_REAL_ADD; EXTENSIONAL_UNIV]);; + +let CONTINUOUS_MAP_EUCLIDEAN_SPACE_SUB = prove + (`!f g:A->num->real. + continuous_map(top,euclidean_space n) f /\ + continuous_map(top,euclidean_space n) g + ==> continuous_map(top,euclidean_space n) (\x i. f x i - g x i)`, + REWRITE_TAC[euclidean_space; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN + SIMP_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM; REAL_SUB_RZERO] THEN + REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN + SIMP_TAC[CONTINUOUS_MAP_REAL_SUB; EXTENSIONAL_UNIV]);; + +let HOMEOMORPHIC_EUCLIDEAN_SPACE_PRODUCT_TOPOLOGY = prove + (`!n. euclidean_space n homeomorphic_space + product_topology (1..n) (\i. euclideanreal)`, + GEN_TAC THEN REWRITE_TAC[homeomorphic_space; homeomorphic_maps] THEN + EXISTS_TAC `\f:num->real. RESTRICTION (1..n) f` THEN + EXISTS_TAC `\(f:num->real) i. if i IN 1..n then f i else &0` THEN + REWRITE_TAC[TOPSPACE_EUCLIDEAN_SPACE; TOPSPACE_PRODUCT_TOPOLOGY] THEN + REWRITE_TAC[cartesian_product; o_THM; TOPSPACE_EUCLIDEANREAL] THEN + REWRITE_TAC[IN_ELIM_THM; EXTENSION; euclidean_space] THEN + REPEAT CONJ_TAC THENL + [MATCH_MP_TAC CONTINUOUS_MAP_FROM_SUBTOPOLOGY THEN + REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE] THEN + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; RESTRICTION_IN_EXTENSIONAL] THEN + SIMP_TAC[RESTRICTION; CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV]; + REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN + SIMP_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM] THEN + REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE] THEN + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_UNIV] THEN + CONJ_TAC THENL [MESON_TAC[IN; EXTENSIONAL_UNIV; IN_UNIV]; ALL_TAC] THEN + X_GEN_TAC `i:num` THEN ASM_CASES_TAC `i IN 1..n` THEN + ASM_REWRITE_TAC[CONTINUOUS_MAP_REAL_CONST] THEN + ASM_SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION]; + REPEAT STRIP_TAC THEN GEN_REWRITE_TAC I [FUN_EQ_THM] THEN + SIMP_TAC[RESTRICTION] THEN ASM_MESON_TAC[]; + REWRITE_TAC[EXTENSIONAL; FUN_EQ_THM; IN_UNIV; IN_ELIM_THM] THEN + REWRITE_TAC[RESTRICTION] THEN MESON_TAC[]]);; + +let CONTRACTIBLE_EUCLIDEAN_SPACE = prove + (`!n. contractible_space(euclidean_space n)`, + GEN_TAC THEN + MP_TAC(SPEC `n:num` HOMEOMORPHIC_EUCLIDEAN_SPACE_PRODUCT_TOPOLOGY) THEN + DISCH_THEN(SUBST1_TAC o MATCH_MP HOMEOMORPHIC_SPACE_CONTRACTIBILITY) THEN + REWRITE_TAC[CONTRACTIBLE_SPACE_PRODUCT_TOPOLOGY] THEN + REWRITE_TAC[CONTRACTIBLE_SPACE_EUCLIDEANREAL]);; + +let PATH_CONNECTED_EUCLIDEAN_SPACE = prove + (`!n. path_connected_space(euclidean_space n)`, + SIMP_TAC[CONTRACTIBLE_IMP_PATH_CONNECTED_SPACE; + CONTRACTIBLE_EUCLIDEAN_SPACE]);; + +let CONNECTED_EUCLIDEAN_SPACE = prove + (`!n. connected_space(euclidean_space n)`, + SIMP_TAC[PATH_CONNECTED_EUCLIDEAN_SPACE; + PATH_CONNECTED_IMP_CONNECTED_SPACE]);; + +let LOCALLY_COMPACT_EUCLIDEAN_SPACE = prove + (`!n. locally_compact_space(euclidean_space n)`, + X_GEN_TAC `n:num` THEN + MP_TAC(SPEC `n:num` HOMEOMORPHIC_EUCLIDEAN_SPACE_PRODUCT_TOPOLOGY) THEN + DISCH_THEN(SUBST1_TAC o MATCH_MP HOMEOMORPHIC_LOCALLY_COMPACT_SPACE) THEN + REWRITE_TAC[LOCALLY_COMPACT_SPACE_PRODUCT_TOPOLOGY] THEN + DISJ2_TAC THEN REWRITE_TAC[LOCALLY_COMPACT_SPACE_EUCLIDEANREAL] THEN + SIMP_TAC[FINITE_NUMSEG; FINITE_RESTRICT]);; + +let LOCALLY_PATH_CONNECTED_EUCLIDEAN_SPACE = prove + (`!n. locally_path_connected_space(euclidean_space n)`, + X_GEN_TAC `n:num` THEN + MP_TAC(SPEC `n:num` HOMEOMORPHIC_EUCLIDEAN_SPACE_PRODUCT_TOPOLOGY) THEN + DISCH_THEN(SUBST1_TAC o + MATCH_MP HOMEOMORPHIC_LOCALLY_PATH_CONNECTED_SPACE) THEN + REWRITE_TAC[LOCALLY_PATH_CONNECTED_SPACE_PRODUCT_TOPOLOGY] THEN + DISJ2_TAC THEN REWRITE_TAC[LOCALLY_PATH_CONNECTED_SPACE_EUCLIDEANREAL] THEN + SIMP_TAC[FINITE_NUMSEG; FINITE_RESTRICT]);; + +let LOCALLY_CONNECTED_EUCLIDEAN_SPACE = prove + (`!n. locally_connected_space(euclidean_space n)`, + SIMP_TAC[LOCALLY_PATH_CONNECTED_EUCLIDEAN_SPACE; + LOCALLY_PATH_CONNECTED_IMP_LOCALLY_CONNECTED_SPACE]);; + +let HAUSDORFF_EUCLIDEAN_SPACE = prove + (`!n. hausdorff_space (euclidean_space n)`, + GEN_TAC THEN REWRITE_TAC[euclidean_space] THEN + MATCH_MP_TAC HAUSDORFF_SPACE_SUBTOPOLOGY THEN + REWRITE_TAC[HAUSDORFF_SPACE_PRODUCT_TOPOLOGY; + HAUSDORFF_SPACE_EUCLIDEANREAL]);; + +let COMPACT_EUCLIDEAN_SPACE = prove + (`!n. compact_space(euclidean_space n) <=> n = 0`, + X_GEN_TAC `n:num` THEN + MP_TAC(SPEC `n:num` HOMEOMORPHIC_EUCLIDEAN_SPACE_PRODUCT_TOPOLOGY) THEN + DISCH_THEN(SUBST1_TAC o MATCH_MP HOMEOMORPHIC_COMPACT_SPACE) THEN + REWRITE_TAC[COMPACT_SPACE_PRODUCT_TOPOLOGY] THEN + REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; CARTESIAN_PRODUCT_EQ_EMPTY] THEN + REWRITE_TAC[NOT_COMPACT_SPACE_EUCLIDEANREAL] THEN + REWRITE_TAC[o_DEF; TOPSPACE_EUCLIDEANREAL; UNIV_NOT_EMPTY] THEN + REWRITE_TAC[GSYM NOT_EXISTS_THM; MEMBER_NOT_EMPTY] THEN + REWRITE_TAC[NUMSEG_EMPTY] THEN ARITH_TAC);; + +let nsphere = new_definition + `nsphere n = subtopology (euclidean_space (n + 1)) + { x | sum(1..n+1) (\i. x i pow 2) = &1 }`;; + +let NSPHERE = prove + (`!n. nsphere n = subtopology (product_topology (:num) (\i. euclideanreal)) + {x | sum(1..n+1) (\i. x i pow 2) = &1 /\ + !i. ~(i IN 1..n+1) ==> x i = &0}`, + REWRITE_TAC[nsphere; euclidean_space; SUBTOPOLOGY_SUBTOPOLOGY] THEN + GEN_TAC THEN AP_TERM_TAC THEN SET_TAC[]);; + +let NONEMPTY_NSPHERE = prove + (`!n. ~(topspace(nsphere n) = {})`, + GEN_TAC THEN REWRITE_TAC[nsphere; GSYM MEMBER_NOT_EMPTY] THEN + EXISTS_TAC `(\n. if n = 1 then &1 else &0):num->real` THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; TOPSPACE_EUCLIDEAN_SPACE] THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN CONJ_TAC THENL + [GEN_TAC THEN COND_CASES_TAC THEN ASM_REWRITE_TAC[IN_NUMSEG] THEN ARITH_TAC; + ONCE_REWRITE_TAC[COND_RAND] THEN ONCE_REWRITE_TAC[COND_RATOR] THEN + CONV_TAC REAL_RAT_REDUCE_CONV THEN REWRITE_TAC[SUM_DELTA] THEN + REWRITE_TAC[IN_NUMSEG; ARITH_RULE `1 <= 1 /\ 1 <= n + 1`]]);; + +let SUBTOPOLOGY_NSPHERE_EQUATOR = prove + (`!n. subtopology (nsphere (n + 1)) {x | x(n+2) = &0} = nsphere n`, + GEN_TAC THEN + REWRITE_TAC[NSPHERE; SUBTOPOLOGY_SUBTOPOLOGY] THEN AP_TERM_TAC THEN + GEN_REWRITE_TAC I [EXTENSION] THEN X_GEN_TAC `x:num->real` THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM; GSYM CONJ_ASSOC] THEN + REWRITE_TAC[ARITH_RULE `(n + 1) + 1 = SUC(n + 1)`; SUM_CLAUSES_NUMSEG] THEN + REWRITE_TAC[ARITH_RULE `1 <= SUC n`; NUMSEG_CLAUSES] THEN + REWRITE_TAC[ARITH_RULE `SUC(n + 1) = n + 2`; IN_INSERT; IN_NUMSEG] THEN + ASM_CASES_TAC `(x:num->real)(n + 2) = &0` THENL + [ALL_TAC; ASM_MESON_TAC[ARITH_RULE `~(n + 2 <= n + 1)`]] THEN + ASM_REWRITE_TAC[] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN + REWRITE_TAC[REAL_ADD_RID] THEN ASM_MESON_TAC[]);; + +let CONTINUOUS_MAP_NSPHERE_REFLECTION = prove + (`!n k. continuous_map (nsphere n,nsphere n) + (\x i. if i = k then --x i else x i)`, + REPEAT GEN_TAC THEN REWRITE_TAC[NSPHERE; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN + REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM] THEN CONJ_TAC THENL + [X_GEN_TAC `i:num` THEN MATCH_MP_TAC CONTINUOUS_MAP_FROM_SUBTOPOLOGY THEN + ASM_CASES_TAC `i:num = k` THEN + ASM_SIMP_TAC[CONTINUOUS_MAP_REAL_NEG; CONTINUOUS_MAP_PRODUCT_PROJECTION; + IN_UNIV]; + ONCE_REWRITE_TAC[COND_RAND] THEN ONCE_REWRITE_TAC[COND_RATOR] THEN + REWRITE_TAC[REAL_NEG_EQ_0; REAL_ARITH `(--x:real) pow 2 = x pow 2`] THEN + SIMP_TAC[COND_ID; TOPSPACE_SUBTOPOLOGY; IN_INTER; IN_ELIM_THM]]);; + +let CONTRACTIBLE_SPACE_UPPER_HEMISPHERE = prove + (`!n k. k IN 1..n+1 + ==> contractible_space(subtopology (nsphere n) {x | x k >= &0})`, + REPEAT STRIP_TAC THEN + ABBREV_TAC `p:num->real = \i. if i = k then &1 else &0` THEN + REWRITE_TAC[contractible_space] THEN EXISTS_TAC `p:num->real` THEN + SUBGOAL_THEN `p IN topspace(nsphere n)` ASSUME_TAC THENL + [EXPAND_TAC "p" THEN REWRITE_TAC[NSPHERE; TOPSPACE_SUBTOPOLOGY] THEN + REWRITE_TAC[IN_INTER; TOPSPACE_PRODUCT_TOPOLOGY; IN_ELIM_THM; o_DEF] THEN + REWRITE_TAC[TOPSPACE_EUCLIDEANREAL; CARTESIAN_PRODUCT_UNIV; IN_UNIV] THEN + CONJ_TAC THENL [ALL_TAC; ASM_MESON_TAC[]] THEN + REWRITE_TAC[COND_RAND; COND_RATOR] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN + ASM_REWRITE_TAC[SUM_DELTA]; + ALL_TAC] THEN + SIMP_TAC[HOMOTOPIC_WITH] THEN + EXISTS_TAC `(\x i. x i / sqrt(sum(1..n+1) (\j. x j pow 2))) o + (\(t,q) i. (&1 - t) * q i + t * p i)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC CONTINUOUS_MAP_COMPOSE; + UNDISCH_TAC `p IN topspace(nsphere n)` THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; NSPHERE; o_THM] THEN + REWRITE_TAC[REAL_SUB_REFL; REAL_MUL_LID; REAL_MUL_LZERO; REAL_SUB_RZERO; + REAL_ADD_LID; REAL_ADD_RID; IN_INTER; IN_ELIM_THM] THEN + SIMP_TAC[SQRT_1; REAL_DIV_1; ETA_AX]] THEN + EXISTS_TAC `subtopology (euclidean_space (n + 1)) + {x | x k >= &0 /\ ~(!i. i IN 1..n+1 ==> x i = &0)}` THEN + REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; euclidean_space] THEN + REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN REPEAT CONJ_TAC THENL + [X_GEN_TAC `i:num` THEN REWRITE_TAC[LAMBDA_PAIR] THEN + MATCH_MP_TAC CONTINUOUS_MAP_REAL_ADD THEN CONJ_TAC THEN + MATCH_MP_TAC CONTINUOUS_MAP_REAL_MUL THEN + REWRITE_TAC[CONTINUOUS_MAP_OF_FST; CONTINUOUS_MAP_OF_SND] THEN + SIMP_TAC[GSYM SUBTOPOLOGY_CROSS; CONTINUOUS_MAP_FROM_SUBTOPOLOGY; + CONTINUOUS_MAP_FST] THEN + REPEAT CONJ_TAC THEN DISJ2_TAC THEN + MATCH_MP_TAC CONTINUOUS_MAP_FROM_SUBTOPOLOGY THEN + SIMP_TAC[CONTINUOUS_MAP_REAL_SUB; CONTINUOUS_MAP_REAL_CONST; + CONTINUOUS_MAP_ID] THEN + REWRITE_TAC[NSPHERE] THEN MATCH_MP_TAC CONTINUOUS_MAP_FROM_SUBTOPOLOGY THEN + SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV]; + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_SUBTOPOLOGY; NSPHERE; + FORALL_PAIR_THM; TOPSPACE_PROD_TOPOLOGY; IN_CROSS; + IN_INTER; IN_ELIM_THM] THEN + EXPAND_TAC "p" THEN SIMP_TAC[REAL_MUL_RZERO; REAL_ADD_LID; REAL_ENTIRE] THEN + ASM_MESON_TAC[]; + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_PROD_TOPOLOGY] THEN + REWRITE_TAC[FORALL_PAIR_THM; IN_CROSS; TOPSPACE_SUBTOPOLOGY] THEN + REWRITE_TAC[TOPSPACE_EUCLIDEANREAL; IN_INTER; IN_UNIV] THEN + MAP_EVERY X_GEN_TAC [`t:real`; `x:num->real`] THEN + REWRITE_TAC[IN_REAL_INTERVAL; IN_ELIM_THM] THEN STRIP_TAC THEN + REWRITE_TAC[real_ge] THEN CONJ_TAC THENL + [EXPAND_TAC "p" THEN REWRITE_TAC[REAL_MUL_RID] THEN + MATCH_MP_TAC REAL_LE_ADD THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC REAL_LE_MUL THEN ASM_REAL_ARITH_TAC; + ASM_CASES_TAC `t = &0` THENL + [ASM_REWRITE_TAC[REAL_SUB_RZERO; REAL_MUL_LID; REAL_MUL_LZERO] THEN + REWRITE_TAC[REAL_ADD_RID] THEN DISCH_TAC THEN + UNDISCH_TAC `x IN topspace(nsphere n)` THEN + ASM_SIMP_TAC[NSPHERE; TOPSPACE_SUBTOPOLOGY; IN_INTER; IN_ELIM_THM] THEN + CONV_TAC REAL_RAT_REDUCE_CONV THEN REWRITE_TAC[SUM_0] THEN + CONV_TAC REAL_RAT_REDUCE_CONV; + DISCH_THEN(MP_TAC o SPEC `k:num`) THEN ASM_REWRITE_TAC[] THEN + EXPAND_TAC "p" THEN REWRITE_TAC[] THEN MATCH_MP_TAC(REAL_ARITH + `&0 <= x /\ &0 <= t /\ ~(t = &0) ==> ~(x + t * &1 = &0)`) THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LE_MUL THEN + ASM_REAL_ARITH_TAC]]; + ALL_TAC; + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_SUBTOPOLOGY] THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM; real_ge] THEN + REPEAT STRIP_TAC THEN MATCH_MP_TAC REAL_LE_DIV THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC SQRT_POS_LE THEN + MATCH_MP_TAC SUM_POS_LE_NUMSEG THEN + REWRITE_TAC[REAL_LE_POW_2]] THEN + REWRITE_TAC[NSPHERE; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN CONJ_TAC THENL + [REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN + X_GEN_TAC `i:num` THEN MATCH_MP_TAC CONTINUOUS_MAP_REAL_DIV THEN + SIMP_TAC[CONTINUOUS_MAP_FROM_SUBTOPOLOGY; + CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV] THEN + CONJ_TAC THENL + [MATCH_MP_TAC CONTINUOUS_MAP_SQRT THEN + MATCH_MP_TAC CONTINUOUS_MAP_SUM THEN + REWRITE_TAC[FINITE_NUMSEG; IN_NUMSEG] THEN + REPEAT STRIP_TAC THEN MATCH_MP_TAC CONTINUOUS_MAP_REAL_POW THEN + REPEAT(MATCH_MP_TAC CONTINUOUS_MAP_FROM_SUBTOPOLOGY) THEN + SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV]; + REWRITE_TAC[SQRT_EQ_0; TOPSPACE_SUBTOPOLOGY; IN_INTER; IN_ELIM_THM]]; + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_SUBTOPOLOGY] THEN + SIMP_TAC[IN_INTER; IN_ELIM_THM; real_ge; IN_NUMSEG] THEN + REWRITE_TAC[real_div; REAL_MUL_LZERO; REAL_POW_MUL; SUM_RMUL] THEN + REWRITE_TAC[REAL_POW_INV; GSYM real_div] THEN + SIMP_TAC[SQRT_POW_2; SUM_POS_LE_NUMSEG; REAL_LE_POW_2] THEN + REWRITE_TAC[REAL_DIV_EQ_1]] THEN + REWRITE_TAC[IMP_CONJ; CONTRAPOS_THM] THEN + GEN_TAC THEN REPLICATE_TAC 3 DISCH_TAC THEN REWRITE_TAC[IN_NUMSEG] THEN + DISCH_THEN(MP_TAC o MATCH_MP (ONCE_REWRITE_RULE[IMP_CONJ_ALT] + SUM_POS_EQ_0_NUMSEG)) THEN + SIMP_TAC[REAL_POW_EQ_0; REAL_LE_POW_2; ARITH]);; + +let CONTRACTIBLE_SPACE_LOWER_HEMISPHERE = prove + (`!n k. k IN 1..n+1 + ==> contractible_space(subtopology (nsphere n) {x | x k <= &0})`, + REPEAT GEN_TAC THEN + DISCH_THEN(MP_TAC o MATCH_MP CONTRACTIBLE_SPACE_UPPER_HEMISPHERE) THEN + MATCH_MP_TAC EQ_IMP THEN MATCH_MP_TAC HOMEOMORPHIC_SPACE_CONTRACTIBILITY THEN + REWRITE_TAC[homeomorphic_space] THEN + REPEAT(EXISTS_TAC `\(x:num->real) i. if i = k then --(x i) else x i`) THEN + REWRITE_TAC[homeomorphic_maps; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN + SIMP_TAC[CONTINUOUS_MAP_FROM_SUBTOPOLOGY; + CONTINUOUS_MAP_NSPHERE_REFLECTION] THEN + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM; REAL_NEG_NEG; + TOPSPACE_SUBTOPOLOGY; IN_INTER] THEN + REWRITE_TAC[FUN_EQ_THM] THEN REPEAT STRIP_TAC THEN + TRY COND_CASES_TAC THEN ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC);; + +let NULLHOMOTOPIC_NONSURJECTIVE_SPHERE_MAP = prove + (`!p f. continuous_map(nsphere p,nsphere p) f /\ + ~(IMAGE f (topspace(nsphere p)) = topspace(nsphere p)) + ==> ?a. homotopic_with (\x. T) (nsphere p,nsphere p) f (\x. a)`, + SIMP_TAC[IMP_CONJ; CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE; SET_RULE + `s SUBSET t ==> (~(s = t) <=> ?a. a IN t /\ ~(a IN s))`] THEN + REPEAT GEN_TAC THEN DISCH_TAC THEN + DISCH_THEN(X_CHOOSE_THEN `a:num->real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(\i. --(a i)):num->real` THEN SIMP_TAC[HOMOTOPIC_WITH] THEN + EXISTS_TAC + `(\x i. x i / sqrt(sum(1..p+1) (\j. x j pow 2))) o + (\(t,x) i. (&1 - t) * f(x:num->real) i - t * a i)` THEN + REWRITE_TAC[o_THM; REAL_ARITH + `(&1 - &1) * x - &1 * a = --a /\ (&1 - &0) * x - &0 * a = x`] THEN + MP_TAC(ASSUME `a IN topspace(nsphere p)`) THEN + FIRST_ASSUM(MP_TAC o MATCH_MP CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE) THEN + REWRITE_TAC[NSPHERE; TOPSPACE_SUBTOPOLOGY; SUBSET] THEN + REWRITE_TAC[GSYM NSPHERE; IN_ELIM_THM; IN_INTER; FORALL_IN_IMAGE] THEN + SIMP_TAC[REAL_ARITH `(--x:real) pow 2 = x pow 2`] THEN + DISCH_THEN(K ALL_TAC) THEN DISCH_THEN(STRIP_ASSUME_TAC o CONJUNCT2) THEN + REWRITE_TAC[SQRT_1; REAL_DIV_1; ETA_AX] THEN + MATCH_MP_TAC CONTINUOUS_MAP_COMPOSE THEN + EXISTS_TAC `subtopology (euclidean_space(p + 1)) (UNIV DELETE (\i. &0))` THEN + REWRITE_TAC[euclidean_space; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN + REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE_UNIV] THEN REPEAT CONJ_TAC THENL + [X_GEN_TAC `i:num` THEN REWRITE_TAC[LAMBDA_PAIR] THEN + MATCH_MP_TAC CONTINUOUS_MAP_REAL_SUB THEN CONJ_TAC THEN + MATCH_MP_TAC CONTINUOUS_MAP_REAL_MUL THEN + REWRITE_TAC[CONTINUOUS_MAP_OF_FST; CONTINUOUS_MAP_OF_SND] THEN + SIMP_TAC[GSYM SUBTOPOLOGY_CROSS; nsphere; CONTINUOUS_MAP_FROM_SUBTOPOLOGY; + CONTINUOUS_MAP_FST] THEN + REPEAT CONJ_TAC THEN DISJ2_TAC THEN + SIMP_TAC[CONTINUOUS_MAP_REAL_SUB; CONTINUOUS_MAP_REAL_CONST; + CONTINUOUS_MAP_ID; CONTINUOUS_MAP_FROM_SUBTOPOLOGY] THEN + REWRITE_TAC[GSYM nsphere] THEN + SUBGOAL_THEN `(\x:num->real. f x i) = (\y:num->real. y i) o f` + SUBST1_TAC THENL [REWRITE_TAC[o_DEF]; ALL_TAC] THEN + MATCH_MP_TAC CONTINUOUS_MAP_COMPOSE THEN + EXISTS_TAC `nsphere p` THEN ASM_REWRITE_TAC[] THEN + SIMP_TAC[NSPHERE; CONTINUOUS_MAP_FROM_SUBTOPOLOGY; + CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV]; + FIRST_ASSUM(MP_TAC o MATCH_MP CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE) THEN + GEN_REWRITE_TAC (LAND_CONV o RAND_CONV o RAND_CONV) [NSPHERE] THEN + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_SUBTOPOLOGY; + FORALL_PAIR_THM; IN_CROSS; TOPSPACE_PROD_TOPOLOGY] THEN + ASM_SIMP_TAC[IN_ELIM_THM; IN_INTER] THEN + REPEAT STRIP_TAC THEN REAL_ARITH_TAC; + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; FORALL_PAIR_THM] THEN + REWRITE_TAC[TOPSPACE_PROD_TOPOLOGY; IN_CROSS] THEN + MAP_EVERY X_GEN_TAC [`t:real`; `b:num->real`] THEN + REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN + REWRITE_TAC[IN_UNIV; IN_REAL_INTERVAL; IN_DELETE] THEN + STRIP_TAC THEN REWRITE_TAC[FUN_EQ_THM; REAL_SUB_0] THEN + GEN_REWRITE_TAC RAND_CONV [GSYM FUN_EQ_THM] THEN + MATCH_MP_TAC(MESON[] + `(a = b ==> t = &1 / &2) /\ (t = &1 / &2 ==> ~(a = b)) + ==> ~(a = b)`) THEN + CONJ_TAC THENL + [DISCH_THEN(MP_TAC o AP_TERM `\x. sum(1..p+1) (\i. x i pow 2)`) THEN + FIRST_ASSUM(MP_TAC o MATCH_MP CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE) THEN + GEN_REWRITE_TAC (LAND_CONV o RAND_CONV o RAND_CONV) [NSPHERE] THEN + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_SUBTOPOLOGY; + FORALL_PAIR_THM; IN_CROSS; TOPSPACE_PROD_TOPOLOGY] THEN + ASM_SIMP_TAC[IN_ELIM_THM; IN_INTER; REAL_POW_MUL; SUM_LMUL] THEN + DISCH_TAC THEN CONV_TAC REAL_RING; + DISCH_THEN SUBST1_TAC THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN + REWRITE_TAC[FUN_EQ_THM; REAL_ARITH + `&1 / &2 * x = &1 / &2 * y <=> x = y`] THEN + GEN_REWRITE_TAC RAND_CONV [GSYM FUN_EQ_THM] THEN + REWRITE_TAC[ETA_AX] THEN ASM SET_TAC[]]; + REWRITE_TAC[NSPHERE; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN + CONJ_TAC THENL + [REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE; IN_UNIV] THEN + REWRITE_TAC[EXTENSIONAL_UNIV; IN; SUBSET] THEN + X_GEN_TAC `k:num` THEN MATCH_MP_TAC CONTINUOUS_MAP_REAL_DIV THEN + REWRITE_TAC[CONJ_ASSOC] THEN CONJ_TAC THENL + [CONJ_TAC THEN REPEAT(MATCH_MP_TAC CONTINUOUS_MAP_FROM_SUBTOPOLOGY) THEN + SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION; IN_UNIV] THEN + MATCH_MP_TAC CONTINUOUS_MAP_SQRT THEN + MATCH_MP_TAC CONTINUOUS_MAP_SUM THEN + SIMP_TAC[CONTINUOUS_MAP_REAL_POW; CONTINUOUS_MAP_PRODUCT_PROJECTION; + IN_UNIV; FINITE_NUMSEG]; + ALL_TAC]; + ALL_TAC] THEN + SIMP_TAC[SUBSET; FORALL_IN_IMAGE; TOPSPACE_SUBTOPOLOGY; IN_INTER; + IN_ELIM_THM; IN_DELETE; IN_UNIV; real_div; REAL_POW_MUL; + REAL_MUL_LZERO; SUM_RMUL; REAL_POW_INV; SQRT_POW_2; + SUM_POS_LE_NUMSEG; REAL_LE_POW_2; SQRT_EQ_0] THEN + X_GEN_TAC `x:num->real` THEN STRIP_TAC THEN + REWRITE_TAC[GSYM real_div ] THEN TRY(MATCH_MP_TAC REAL_DIV_REFL) THEN + DISCH_THEN(MP_TAC o MATCH_MP (ONCE_REWRITE_RULE[IMP_CONJ_ALT] + SUM_POS_EQ_0_NUMSEG)) THEN + REWRITE_TAC[REAL_LE_POW_2; GSYM IN_NUMSEG; REAL_POW_EQ_0] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE RAND_CONV [FUN_EQ_THM]) THEN + ASM_MESON_TAC[IN]]);; + +(* ------------------------------------------------------------------------- *) +(* Contractions. *) +(* ------------------------------------------------------------------------- *) + +let CONTRACTION_IMP_UNIQUE_FIXPOINT = prove + (`!m (f:A->A) k x y. + k < &1 /\ + (!x. x IN mspace m ==> f x IN mspace m) /\ + (!x y. x IN mspace m /\ y IN mspace m + ==> mdist m (f x, f y) <= k * mdist m (x,y)) /\ + x IN mspace m /\ y IN mspace m /\ f x = x /\ f y = y + ==> x = y`, + INTRO_TAC "!m f k x y; k f le x y xeq yeq" THEN + ASM_CASES_TAC `x:A = y` THENL [POP_ASSUM ACCEPT_TAC; ALL_TAC] THEN + REMOVE_THEN "le" (MP_TAC o SPECL[`x:A`;`y:A`]) THEN ASM_REWRITE_TAC[] THEN + CUT_TAC `&0 < (&1 - k) * mdist m (x:A,y:A)` THENL + [REAL_ARITH_TAC; + MATCH_MP_TAC REAL_LT_MUL THEN ASM_SIMP_TAC[MDIST_POS_LT] THEN + ASM_REAL_ARITH_TAC]);; + +(* ------------------------------------------------------------------------- *) +(* Banach Fixed-Point Theorem (aka, Contraction Mapping Principle). *) +(* ------------------------------------------------------------------------- *) + +let BANACH_FIXPOINT_THM = prove + (`!m f:A->A k. + ~(mspace m = {}) /\ + mcomplete m /\ + (!x. x IN mspace m ==> f x IN mspace m) /\ + k < &1 /\ + (!x y. x IN mspace m /\ y IN mspace m + ==> mdist m (f x, f y) <= k * mdist m (x,y)) + ==> (?!x. x IN mspace m /\ f x = x)`, + INTRO_TAC "!m f k; ne compl 4 k1 contr" THEN REMOVE_THEN "ne" MP_TAC THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN INTRO_TAC "@a. aINm" THEN + REWRITE_TAC[EXISTS_UNIQUE_THM] THEN CONJ_TAC THENL + [ALL_TAC; + REPEAT STRIP_TAC THEN MATCH_MP_TAC CONTRACTION_IMP_UNIQUE_FIXPOINT THEN + ASM_MESON_TAC[]] THEN + ASM_CASES_TAC `!x:A. x IN mspace m ==> f x:A = f a` THENL + [ASM_MESON_TAC[]; POP_ASSUM (LABEL_TAC "nonsing")] THEN + CLAIM_TAC "kpos" `&0 < k` THENL + [MATCH_MP_TAC (ISPECL [`m:A metric`; `m:A metric`; `f:A->A`] + LIPSCHITZ_COEFFICIENT_POS) THEN + ASM_SIMP_TAC[] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + CLAIM_TAC "fINm" `!n:num. (ITER n f (a:A)) IN mspace m` THENL + [LABEL_INDUCT_TAC THEN ASM_SIMP_TAC[ITER]; ALL_TAC] THEN + ASM_CASES_TAC `f a = a:A` THENL + [ASM_MESON_TAC[]; POP_ASSUM (LABEL_TAC "aneq")] THEN + CUT_TAC `cauchy_in (m:A metric) (\n. ITER n f (a:A))` THENL + [DISCH_THEN (fun cauchy -> HYP_TAC "compl : @l. lim" + (C MATCH_MP cauchy o REWRITE_RULE[mcomplete])) THEN + EXISTS_TAC `l:A` THEN CONJ_TAC THENL + [ASM_MESON_TAC [LIMIT_IN_MSPACE]; ALL_TAC] THEN + MATCH_MP_TAC + (ISPECL [`sequentially`; `m:A metric`; `(\n. ITER n f a:A)`] + LIMIT_METRIC_UNIQUE) THEN + ASM_REWRITE_TAC[TRIVIAL_LIMIT_SEQUENTIALLY] THEN + MATCH_MP_TAC LIMIT_SEQUENTIALLY_OFFSET_REV THEN + EXISTS_TAC `1` THEN REWRITE_TAC[GSYM ADD1] THEN + SUBGOAL_THEN `(\i. ITER (SUC i) f (a:A)) = f o (\i. ITER i f a)` + SUBST1_TAC THENL [REWRITE_TAC[FUN_EQ_THM; o_THM; ITER]; ALL_TAC] THEN + MATCH_MP_TAC CONTINUOUS_MAP_LIMIT THEN + EXISTS_TAC `mtopology (m:A metric)` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC LIPSCHITZ_CONTINUOUS_IMP_CONTINUOUS_MAP THEN + ASM_REWRITE_TAC[lipschitz_continuous_map; SUBSET; FORALL_IN_IMAGE] THEN + EXISTS_TAC `k:real` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + CLAIM_TAC "k1'" `&0 < &1 - k` THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + ASM_SIMP_TAC[cauchy_in] THEN INTRO_TAC "!e; e" THEN + CLAIM_TAC "@N. N" `?N. k pow N < ((&1 - k) * e) / mdist m (a:A,f a)` THENL + [MATCH_MP_TAC REAL_ARCH_POW_INV THEN + ASM_SIMP_TAC[REAL_LT_DIV; MDIST_POS_LT; REAL_LT_MUL]; + EXISTS_TAC `N:num`] THEN + MATCH_MP_TAC WLOG_LT THEN ASM_SIMP_TAC[MDIST_REFL] THEN CONJ_TAC THENL + [HYP MESON_TAC "fINm" [MDIST_SYM]; ALL_TAC] THEN + INTRO_TAC "!n n'; lt; le le'" THEN + TRANS_TAC REAL_LET_TRANS + `sum (n..n'-1) (\i. mdist m (ITER i f a:A, ITER (SUC i) f a))` THEN + CONJ_TAC THENL + [REMOVE_THEN "lt" MP_TAC THEN SPEC_TAC (`n':num`,`n':num`) THEN + LABEL_INDUCT_TAC THENL [REWRITE_TAC[LT]; REWRITE_TAC[LT_SUC_LE]] THEN + INTRO_TAC "nle" THEN HYP_TAC "nle : nlt | neq" (REWRITE_RULE[LE_LT]) THENL + [ALL_TAC; + POP_ASSUM SUBST_ALL_TAC THEN + REWRITE_TAC[ITER; + ARITH_RULE `SUC n'' - 1 = n''`; SUM_SING_NUMSEG; REAL_LE_REFL]] THEN + USE_THEN "nlt" (HYP_TAC "ind_n'" o C MATCH_MP) THEN REWRITE_TAC[ITER] THEN + TRANS_TAC REAL_LE_TRANS + `mdist m (ITER n f a:A,ITER n'' f a) + + mdist m (ITER n'' f a,f (ITER n'' f a))` THEN + ASM_SIMP_TAC[MDIST_TRIANGLE] THEN + SUBGOAL_THEN `SUC n'' - 1 = SUC (n'' - 1)` SUBST1_TAC THENL + [ASM_ARITH_TAC; ASM_SIMP_TAC[SUM_CLAUSES_NUMSEG]] THEN + SUBGOAL_THEN `SUC (n'' - 1) = n''` SUBST1_TAC THENL + [ASM_ARITH_TAC; ASM_SIMP_TAC[LT_IMP_LE; REAL_LE_RADD]] THEN + REMOVE_THEN "ind_n'" (ACCEPT_TAC o REWRITE_RULE[ITER]); + ALL_TAC] THEN + TRANS_TAC REAL_LET_TRANS + `sum (n..n'-1) (\i. mdist m (a:A, f a) * k pow i)` THEN CONJ_TAC THENL + [MATCH_MP_TAC SUM_LE_NUMSEG THEN + CUT_TAC `!i. mdist m (ITER i f a,ITER (SUC i) f a) <= + mdist m (a:A,f a) * k pow i` THENL + [SIMP_TAC[ITER]; ALL_TAC] THEN + LABEL_INDUCT_TAC THENL + [REWRITE_TAC[ITER; real_pow; REAL_MUL_RID; REAL_LE_REFL]; + HYP_TAC "ind_i" (REWRITE_RULE[ITER]) THEN + TRANS_TAC REAL_LE_TRANS `k * mdist m (ITER i f a:A, f (ITER i f a))` THEN + ASM_SIMP_TAC[real_pow; REAL_LE_LMUL_EQ; ITER; + REAL_ARITH `!x. x * k * k pow i = k * x * k pow i`]]; + ALL_TAC] THEN + REWRITE_TAC[SUM_LMUL; SUM_GP] THEN + HYP SIMP_TAC "lt" [ARITH_RULE `n < n' ==> ~(n' - 1 < n)`] THEN + HYP SIMP_TAC "k1" [REAL_ARITH `k < &1 ==> ~(k = &1)`] THEN + USE_THEN "lt" (SUBST1_TAC o + MATCH_MP (ARITH_RULE `n < n' ==> SUC (n' - 1) = n'`)) THEN + SUBGOAL_THEN `k pow n - k pow n' = k pow n * (&1 - k pow (n' - n))` + SUBST1_TAC THENL + [REWRITE_TAC[REAL_SUB_LDISTRIB; REAL_MUL_RID; GSYM REAL_POW_ADD] THEN + HYP SIMP_TAC "lt" [ARITH_RULE `n < n' ==> n + n' - n = n':num`]; + (SUBST1_TAC o REAL_ARITH) + `mdist m (a:A,f a) * (k pow n * (&1 - k pow (n' - n))) / (&1 - k) = + ((k pow n * (&1 - k pow (n' - n))) / (&1 - k)) * mdist m (a,f a)`] THEN + ASM_SIMP_TAC[GSYM REAL_LT_RDIV_EQ; MDIST_POS_LT; REAL_LT_LDIV_EQ] THEN + TRANS_TAC REAL_LET_TRANS `k pow n` THEN CONJ_TAC THENL + [ONCE_REWRITE_TAC[GSYM REAL_SUB_LE] THEN + REWRITE_TAC[GSYM REAL_POW_ADD; + REAL_ARITH `k pow n - k pow n * (&1 - k pow (n' - n)) = + k pow n * k pow (n' - n)`] THEN + HYP SIMP_TAC "lt" [ARITH_RULE `n < n' ==> n + n' - n = n':num`] THEN + HYP SIMP_TAC "kpos" [REAL_POW_LE; REAL_LT_IMP_LE]; + TRANS_TAC REAL_LET_TRANS `k pow N` THEN + ASM_SIMP_TAC[REAL_POW_MONO_INV; REAL_LT_IMP_LE; + REAL_ARITH `e / mdist m (a:A,f a) * (&1 - k) = + ((&1 - k) * e) / mdist m (a,f a)`]]);; + +(* ------------------------------------------------------------------------- *) +(* Metric space of bounded functions. *) +(* ------------------------------------------------------------------------- *) + +let funspace = new_definition + `funspace s m = + metric ({f:A->B | (!x. x IN s ==> f x IN mspace m) /\ + f IN EXTENSIONAL s /\ + mbounded m (IMAGE f s)}, + (\(f,g). if s = {} then &0 else + sup {mdist m (f x,g x) | x | x IN s}))`;; + +let FUNSPACE = (REWRITE_RULE[GSYM FORALL_AND_THM] o prove) + (`!s m. + mspace (funspace s m) = + {f:A->B | (!x. x IN s ==> f x IN mspace m) /\ + f IN EXTENSIONAL s /\ + mbounded m (IMAGE f s)} /\ + (!f g. mdist (funspace s m) (f,g) = + if s = {} then &0 else + sup {mdist m (f x,g x) | x | x IN s})`, + REPEAT GEN_TAC THEN MAP_EVERY LABEL_ABBREV_TAC + [`fspace = {f:A->B | (!x. x IN s ==> f x IN mspace m) /\ + f IN EXTENSIONAL s /\ + mbounded m (IMAGE f s)}`; + `fdist = + \(f,g). if s = {} then &0 else + sup {mdist m (f x:B,g x) | x | x:A IN s}`] THEN + CUT_TAC `mspace (funspace s m) = fspace:(A->B)->bool /\ + mdist (funspace s m:(A->B)metric) = fdist` THENL + [EXPAND_TAC "fdist" THEN DISCH_THEN (fun th -> REWRITE_TAC[th]); + ASM_REWRITE_TAC[funspace] THEN MATCH_MP_TAC METRIC] THEN + ASM_CASES_TAC `s:A->bool = {}` THENL + [POP_ASSUM SUBST_ALL_TAC THEN MAP_EVERY EXPAND_TAC ["fspace"; "fdist"] THEN + SIMP_TAC[is_metric_space; NOT_IN_EMPTY; IN_EXTENSIONAL; IMAGE_CLAUSES; + MBOUNDED_EMPTY; IN_ELIM_THM; REAL_LE_REFL; REAL_ADD_LID; FUN_EQ_THM]; + POP_ASSUM (LABEL_TAC "nempty")] THEN + REMOVE_THEN "nempty" (fun th -> + RULE_ASSUM_TAC(REWRITE_RULE[th]) THEN LABEL_TAC "nempty" th) THEN + CLAIM_TAC "wd ext bound" + `(!f x:A. f IN fspace /\ x IN s ==> f x:B IN mspace m) /\ + (!f. f IN fspace ==> f IN EXTENSIONAL s) /\ + (!f. f IN fspace + ==> (?c b. c IN mspace m /\ + (!x. x IN s ==> mdist m (c,f x) <= b)))` THENL + [EXPAND_TAC "fspace" THEN + ASM_SIMP_TAC[IN_ELIM_THM; MBOUNDED; IMAGE_EQ_EMPTY] THEN SET_TAC[]; + ALL_TAC] THEN + CLAIM_TAC "bound2" + `!f g:A->B. f IN fspace /\ g IN fspace + ==> (?b. !x. x IN s ==> mdist m (f x,g x) <= b)` THENL + [REMOVE_THEN "fspace" (SUBST_ALL_TAC o GSYM) THEN + REWRITE_TAC[IN_ELIM_THM] THEN REPEAT STRIP_TAC THEN + CUT_TAC `mbounded m (IMAGE (f:A->B) s UNION IMAGE g s)` THENL + [REWRITE_TAC[MBOUNDED_ALT; SUBSET; IN_UNION] THEN + STRIP_TAC THEN EXISTS_TAC `b:real` THEN ASM SET_TAC []; + ASM_REWRITE_TAC[MBOUNDED_UNION]]; + ALL_TAC] THEN + HYP_TAC "nempty -> @a. a" (REWRITE_RULE[GSYM MEMBER_NOT_EMPTY]) THEN + REWRITE_TAC[is_metric_space] THEN CONJ_TAC THENL + [INTRO_TAC "![f] [g]; f g" THEN EXPAND_TAC "fdist" THEN + REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LE_SUP THEN + CLAIM_TAC "@b. b" `?b. !x:A. x IN s ==> mdist m (f x:B,g x) <= b` THENL + [HYP SIMP_TAC "bound2 f g" []; + ALL_TAC] THEN + MAP_EVERY EXISTS_TAC [`b:real`; `mdist m (f(a:A):B,g a)`] THEN + REWRITE_TAC[IN_ELIM_THM] THEN HYP SIMP_TAC "wd f g a" [MDIST_POS_LE] THEN + HYP MESON_TAC "a b" []; + ALL_TAC] THEN + CONJ_TAC THENL + [INTRO_TAC "![f] [g]; f g" THEN EXPAND_TAC "fdist" THEN REWRITE_TAC[] THEN EQ_TAC THENL [INTRO_TAC "sup0" THEN MATCH_MP_TAC (SPEC `s:A->bool` EXTENSIONAL_EQ) THEN HYP SIMP_TAC "f g ext" [] THEN INTRO_TAC "!x; x" THEN @@ -32719,2201 +38731,10403 @@ let FUNSPACE = (REWRITE_RULE[GSYM FORALL_AND_THM] o prove) REWRITE_TAC[EXTENSION; IN_ELIM_THM; NOT_IN_EMPTY; IN_UNIV; IN_INSERT] THEN HYP MESON_TAC "wd f a" [MDIST_REFL]]; ALL_TAC] THEN - CONJ_TAC THENL - [INTRO_TAC "![f] [g]; f g" THEN EXPAND_TAC "fdist" THEN REWRITE_TAC[] THEN - AP_TERM_TAC THEN REWRITE_TAC[EXTENSION; IN_ELIM_THM] THEN - HYP MESON_TAC "wd f g" [MDIST_SYM]; + CONJ_TAC THENL + [INTRO_TAC "![f] [g]; f g" THEN EXPAND_TAC "fdist" THEN REWRITE_TAC[] THEN + AP_TERM_TAC THEN REWRITE_TAC[EXTENSION; IN_ELIM_THM] THEN + HYP MESON_TAC "wd f g" [MDIST_SYM]; + ALL_TAC] THEN + INTRO_TAC "![f] [g] [h]; f g h" THEN EXPAND_TAC "fdist" THEN + REWRITE_TAC[] THEN MATCH_MP_TAC REAL_SUP_LE THEN CONJ_TAC THENL + [REWRITE_TAC[EXTENSION; IN_ELIM_THM; NOT_IN_EMPTY; IN_UNIV] THEN + HYP MESON_TAC "a" []; + ALL_TAC] THEN + FIX_TAC "[d]" THEN REWRITE_TAC [IN_ELIM_THM; IN_UNIV] THEN + INTRO_TAC "@x. x d" THEN POP_ASSUM SUBST1_TAC THEN + CUT_TAC + `mdist m (f (x:A):B,h x) <= mdist m (f x,g x) + mdist m (g x, h x) /\ + mdist m (f x, g x) <= fdist (f,g) /\ + mdist m (g x, h x) <= fdist (g,h)` THEN + EXPAND_TAC "fdist" THEN REWRITE_TAC[] THENL [REAL_ARITH_TAC; ALL_TAC] THEN + HYP SIMP_TAC "wd f g h x" [MDIST_TRIANGLE] THEN + CONJ_TAC THEN MATCH_MP_TAC REAL_LE_SUP THENL + [CLAIM_TAC "@B. B" `?b. !x:A. x IN s ==> mdist m (f x:B,g x) <= b` THENL + [HYP SIMP_TAC "bound2 f g" []; + MAP_EVERY EXISTS_TAC [`B:real`; `mdist m (f(x:A):B,g x)`]] THEN + REWRITE_TAC[IN_ELIM_THM; IN_UNIV; REAL_LE_REFL] THEN HYP MESON_TAC "B x" []; + CLAIM_TAC "@B. B" `?b. !x:A. x IN s ==> mdist m (g x:B,h x) <= b` THENL + [HYP SIMP_TAC "bound2 g h" []; ALL_TAC] THEN + MAP_EVERY EXISTS_TAC [`B:real`; `mdist m (g(x:A):B,h x)`] THEN + REWRITE_TAC[IN_ELIM_THM; IN_UNIV; REAL_LE_REFL] THEN + HYP MESON_TAC "B x" []]);; + +let FUNSPACE_IMP_WELLDEFINED = prove + (`!s m f:A->B x. f IN mspace (funspace s m) /\ x IN s ==> f x IN mspace m`, + SIMP_TAC[FUNSPACE; IN_ELIM_THM]);; + +let FUNSPACE_IMP_EXTENSIONAL = prove + (`!s m f:A->B. f IN mspace (funspace s m) ==> f IN EXTENSIONAL s`, + SIMP_TAC[FUNSPACE; IN_ELIM_THM]);; + +let FUNSPACE_IMP_BOUNDED_IMAGE = prove + (`!s m f:A->B. f IN mspace (funspace s m) ==> mbounded m (IMAGE f s)`, + SIMP_TAC[FUNSPACE; IN_ELIM_THM]);; + +let FUNSPACE_IMP_BOUNDED = prove + (`!s m f:A->B. f IN mspace (funspace s m) + ==> s = {} \/ (?c b. !x. x IN s ==> mdist m (c,f x) <= b)`, + REPEAT GEN_TAC THEN + REWRITE_TAC[FUNSPACE; MBOUNDED; IMAGE_EQ_EMPTY; IN_ELIM_THM] THEN + ASM_CASES_TAC `s:A->bool = {}` THEN ASM_REWRITE_TAC[] THEN ASM SET_TAC[]);; + +let FUNSPACE_IMP_BOUNDED2 = prove + (`!s m f g:A->B. f IN mspace (funspace s m) /\ g IN mspace (funspace s m) + ==> (?b. !x. x IN s ==> mdist m (f x,g x) <= b)`, + REWRITE_TAC[FUNSPACE; IN_ELIM_THM] THEN REPEAT STRIP_TAC THEN + CUT_TAC `mbounded m (IMAGE (f:A->B) s UNION IMAGE g s)` THENL + [REWRITE_TAC[MBOUNDED_ALT; SUBSET; IN_UNION] THEN + STRIP_TAC THEN EXISTS_TAC `b:real` THEN ASM SET_TAC []; + ASM_REWRITE_TAC[MBOUNDED_UNION]]);; + +let FUNSPACE_MDIST_LE = prove + (`!s m f g:A->B a. + ~(s = {}) /\ + f IN mspace (funspace s m) /\ + g IN mspace (funspace s m) + ==> (mdist (funspace s m) (f,g) <= a <=> + !x. x IN s ==> mdist m (f x, g x) <= a)`, + INTRO_TAC "! *; ne f g" THEN + HYP (DESTRUCT_TAC "@b. b" o + MATCH_MP FUNSPACE_IMP_BOUNDED2 o CONJ_LIST) "f g" [] THEN + ASM_REWRITE_TAC[FUNSPACE] THEN + MP_TAC (ISPECL [`{mdist m (f x:B,g x) | x:A IN s}`; `a:real`] + REAL_SUP_LE_EQ) THEN + ANTS_TAC THENL [ASM SET_TAC[]; REWRITE_TAC[IN_ELIM_THM]] THEN + MESON_TAC[]);; + +let MCOMPLETE_FUNSPACE = prove + (`!s:A->bool m:B metric. mcomplete m ==> mcomplete (funspace s m)`, + REWRITE_TAC[mcomplete] THEN INTRO_TAC "!s m; cpl; ![f]; cy" THEN + ASM_CASES_TAC `s:A->bool = {}` THENL + [POP_ASSUM SUBST_ALL_TAC THEN EXISTS_TAC `\x:A. ARB:B` THEN + REMOVE_THEN "cy" MP_TAC THEN + SIMP_TAC[cauchy_in; LIMIT_METRIC_SEQUENTIALLY; FUNSPACE; NOT_IN_EMPTY; + IN_ELIM_THM; IN_EXTENSIONAL; IMAGE_CLAUSES; MBOUNDED_EMPTY]; + POP_ASSUM (LABEL_TAC "nempty")] THEN + LABEL_ABBREV_TAC + `g (x:A) = if x IN s + then @y. limit (mtopology m) (\n:num. f n x) y sequentially + else ARB:B` THEN + EXISTS_TAC `g:A->B` THEN USE_THEN "cy" MP_TAC THEN + HYP REWRITE_TAC "nempty" + [cauchy_in; FUNSPACE; IN_ELIM_THM; FORALL_AND_THM] THEN + INTRO_TAC "(fwd fext fbd) cy'" THEN + ASM_REWRITE_TAC[LIMIT_METRIC_SEQUENTIALLY; FUNSPACE; IN_ELIM_THM] THEN + CLAIM_TAC "gext" `g:A->B IN EXTENSIONAL s` THENL + [REMOVE_THEN "g" (fun th -> SIMP_TAC[IN_EXTENSIONAL; GSYM th]); + HYP REWRITE_TAC "gext" []] THEN + CLAIM_TAC "bd2" + `!n n'. ?b. !x:A. x IN s ==> mdist m (f (n:num) x:B, f n' x) <= b` THENL + [REPEAT GEN_TAC THEN MATCH_MP_TAC FUNSPACE_IMP_BOUNDED2 THEN + ASM_REWRITE_TAC[FUNSPACE; IN_ELIM_THM; ETA_AX]; + ALL_TAC] THEN + CLAIM_TAC "sup" + `!n n':num x0:A. x0 IN s + ==> mdist m (f n x0:B,f n' x0) <= + sup {mdist m (f n x,f n' x) | x IN s}` THENL + [INTRO_TAC "!n n' x0; x0" THEN MATCH_MP_TAC REAL_LE_SUP THEN + REMOVE_THEN "bd2" (DESTRUCT_TAC "@b. b" o SPECL[`n:num`;`n':num`]) THEN + MAP_EVERY EXISTS_TAC + [`b:real`; `mdist m (f (n:num) (x0:A):B, f n' x0)`] THEN + REWRITE_TAC[IN_ELIM_THM] THEN CONJ_TAC THENL + [HYP MESON_TAC "x0" []; REWRITE_TAC[REAL_LE_REFL]] THEN + INTRO_TAC "![d]; @y. y d" THEN REMOVE_THEN "d" SUBST1_TAC THEN + HYP SIMP_TAC "b y" []; + ALL_TAC] THEN + CLAIM_TAC "pcy" `!x:A. x IN s ==> cauchy_in m (\n. f n x:B)` THENL + [INTRO_TAC "!x; x" THEN REWRITE_TAC[cauchy_in] THEN + HYP SIMP_TAC "fwd x" [] THEN INTRO_TAC "!e; e" THEN + USE_THEN "e" (HYP_TAC "cy': @N.N" o C MATCH_MP) THEN EXISTS_TAC `N:num` THEN + REPEAT GEN_TAC THEN DISCH_THEN (HYP_TAC "N" o C MATCH_MP) THEN + TRANS_TAC REAL_LET_TRANS + `sup {mdist m (f (n:num) x:B,f n' x) | x:A IN s}` THEN + HYP REWRITE_TAC "N" [] THEN HYP SIMP_TAC "sup x" []; + ALL_TAC] THEN + CLAIM_TAC "glim" + `!x:A. x IN s + ==> limit (mtopology m) (\n. f n x:B) (g x) sequentially` THENL + [INTRO_TAC "!x; x" THEN + REMOVE_THEN "g" (fun th -> ASM_REWRITE_TAC[GSYM th]) THEN + SELECT_ELIM_TAC THEN HYP SIMP_TAC "cpl pcy x" []; + ALL_TAC] THEN + CLAIM_TAC "gwd" `!x:A. x IN s ==> g x:B IN mspace m` THENL + [INTRO_TAC "!x; x" THEN + MATCH_MP_TAC (ISPECL[`sequentially`] LIMIT_IN_MSPACE) THEN + EXISTS_TAC `\n:num. f n (x:A):B` THEN HYP SIMP_TAC "glim x" []; + HYP REWRITE_TAC "gwd" []] THEN + CLAIM_TAC "unif" + `!e. &0 < e ==> ?N:num. !x:A n. x IN s /\ N <= n + ==> mdist m (f n x:B, g x) < e` THENL + [INTRO_TAC "!e; e" THEN REMOVE_THEN "cy'" (MP_TAC o SPEC `e / &2`) THEN + HYP REWRITE_TAC "e" [REAL_HALF] THEN INTRO_TAC "@N. N" THEN + EXISTS_TAC `N:num` THEN INTRO_TAC "!x n; x n" THEN + USE_THEN "x" (HYP_TAC "glim" o C MATCH_MP) THEN + HYP_TAC "glim: gx glim" (REWRITE_RULE[LIMIT_METRIC_SEQUENTIALLY]) THEN + REMOVE_THEN "glim" (MP_TAC o SPEC `e / &2`) THEN + HYP REWRITE_TAC "e" [REAL_HALF] THEN + HYP SIMP_TAC "fwd x" [] THEN INTRO_TAC "@N'. N'" THEN + TRANS_TAC REAL_LET_TRANS + `mdist m (f n (x:A):B, f (MAX N N') x) + + mdist m (f (MAX N N') x, g x)` THEN + HYP SIMP_TAC "fwd x gwd" [MDIST_TRIANGLE] THEN + TRANS_TAC REAL_LTE_TRANS `e / &2 + e / &2` THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_LT_ADD2; REWRITE_TAC[REAL_HALF; REAL_LE_REFL]] THEN + CONJ_TAC THENL [ALL_TAC; REMOVE_THEN "N'" MATCH_MP_TAC THEN ARITH_TAC] THEN + TRANS_TAC REAL_LET_TRANS + `sup {mdist m (f n x:B,f (MAX N N') x) | x:A IN s}` THEN + HYP SIMP_TAC "N n" [ARITH_RULE `N <= MAX N N'`] THEN + HYP SIMP_TAC "sup x" []; + ALL_TAC] THEN + CONJ_TAC THENL + [HYP_TAC "cy': @N. N" (C MATCH_MP REAL_LT_01) THEN + USE_THEN "fbd" (MP_TAC o REWRITE_RULE[MBOUNDED] o SPEC `N:num`) THEN + HYP REWRITE_TAC "nempty" [mbounded; IMAGE_EQ_EMPTY] THEN + INTRO_TAC "Nwd (@c b. c Nbd)" THEN + MAP_EVERY EXISTS_TAC [`c:B`; `b + &1`] THEN + REWRITE_TAC[SUBSET; IN_IMAGE; IN_MCBALL] THEN + INTRO_TAC "![y]; (@x. y x)" THEN REMOVE_THEN "y" SUBST1_TAC THEN + HYP SIMP_TAC "x gwd c" [] THEN TRANS_TAC REAL_LE_TRANS + `mdist m (c:B, f (N:num) (x:A)) + mdist m (f N x, g x)` THEN + HYP SIMP_TAC "c fwd gwd x" [MDIST_TRIANGLE] THEN + MATCH_MP_TAC REAL_LE_ADD2 THEN CONJ_TAC THENL + [REMOVE_THEN "Nbd" MATCH_MP_TAC THEN REWRITE_TAC[IN_IMAGE] THEN + HYP MESON_TAC "x" []; + REFUTE_THEN (LABEL_TAC "contra" o REWRITE_RULE[REAL_NOT_LE])] THEN + CLAIM_TAC "@a. a1 a2" + `?a. &1 < a /\ a < mdist m (f (N:num) (x:A), g x:B)` THENL + [EXISTS_TAC `(&1 + mdist m (f (N:num) (x:A), g x:B)) / &2` THEN + REMOVE_THEN "contra" MP_TAC THEN REAL_ARITH_TAC; + USE_THEN "x" (HYP_TAC "glim" o C MATCH_MP)] THEN + REMOVE_THEN "glim" (MP_TAC o REWRITE_RULE[LIMIT_METRIC_SEQUENTIALLY]) THEN + HYP SIMP_TAC "gwd x" [] THEN DISCH_THEN (MP_TAC o SPEC `a - &1`) THEN + ANTS_TAC THENL [REMOVE_THEN "a1" MP_TAC THEN REAL_ARITH_TAC; ALL_TAC] THEN + HYP SIMP_TAC "fwd x" [] THEN INTRO_TAC "@N'. N'" THEN + CUT_TAC `mdist m (f (N:num) (x:A), g x:B) < a` THENL + [REMOVE_THEN "a2" MP_TAC THEN REAL_ARITH_TAC; ALL_TAC] THEN + TRANS_TAC REAL_LET_TRANS + `mdist m (f N (x:A),f (MAX N N') x:B) + mdist m (f (MAX N N') x,g x)` THEN + HYP SIMP_TAC "fwd gwd x" [MDIST_TRIANGLE] THEN + SUBST1_TAC (REAL_ARITH `a = &1 + (a - &1)`) THEN + MATCH_MP_TAC REAL_LT_ADD2 THEN CONJ_TAC THENL + [ALL_TAC; REMOVE_THEN "N'" MATCH_MP_TAC THEN ARITH_TAC] THEN + TRANS_TAC REAL_LET_TRANS + `sup {mdist m (f N x:B,f (MAX N N') x) | x:A IN s}` THEN + CONJ_TAC THENL + [HYP SIMP_TAC "sup x" []; REMOVE_THEN "N" MATCH_MP_TAC THEN ARITH_TAC]; + ALL_TAC] THEN + INTRO_TAC "!e; e" THEN REMOVE_THEN "unif" (MP_TAC o SPEC `e / &2`) THEN + HYP REWRITE_TAC "e" [REAL_HALF] THEN INTRO_TAC "@N. N" THEN + EXISTS_TAC `N:num` THEN INTRO_TAC "!n; n" THEN + TRANS_TAC REAL_LET_TRANS `e / &2` THEN CONJ_TAC THENL + [ALL_TAC; REMOVE_THEN "e" MP_TAC THEN REAL_ARITH_TAC] THEN + MATCH_MP_TAC REAL_SUP_LE THEN REWRITE_TAC[IN_ELIM_THM] THEN CONJ_TAC THENL + [HYP SET_TAC "nempty" []; HYP MESON_TAC "N n" [REAL_LT_IMP_LE]]);; + +(* ------------------------------------------------------------------------- *) +(* Metric space of continuous bounded functions. *) +(* ------------------------------------------------------------------------- *) + +let cfunspace = new_definition + `cfunspace top m = + submetric (funspace (topspace top) m) + {f:A->B | continuous_map (top,mtopology m) f}`;; + +let CFUNSPACE = (REWRITE_RULE[GSYM FORALL_AND_THM] o prove) + (`(!top m. + mspace (cfunspace top m) = + {f:A->B | (!x. x IN topspace top ==> f x IN mspace m) /\ + f IN EXTENSIONAL (topspace top) /\ + mbounded m (IMAGE f (topspace top)) /\ + continuous_map (top,mtopology m) f}) /\ + (!f g:A->B. + mdist (cfunspace top m) (f,g) = + if topspace top = {} then &0 else + sup {mdist m (f x,g x) | x IN topspace top})`, + REWRITE_TAC[cfunspace; SUBMETRIC; FUNSPACE] THEN SET_TAC[]);; + +let CFUNSPACE_SUBSET_FUNSPACE = prove + (`!top:A topology m:B metric. + mspace (cfunspace top m) SUBSET mspace (funspace (topspace top) m)`, + SIMP_TAC[SUBSET; FUNSPACE; CFUNSPACE; IN_ELIM_THM]);; + +let MDIST_CFUNSPACE_EQ_MDIST_FUNSPACE = prove + (`!top m f g:A->B. + mdist (cfunspace top m) (f,g) = mdist (funspace (topspace top) m) (f,g)`, + REWRITE_TAC[FUNSPACE; CFUNSPACE]);; + +let CFUNSPACE_MDIST_LE = prove + (`!top m f g:A->B a. + ~(topspace top = {}) /\ + f IN mspace (cfunspace top m) /\ + g IN mspace (cfunspace top m) + ==> (mdist (cfunspace top m) (f,g) <= a <=> + !x. x IN topspace top ==> mdist m (f x, g x) <= a)`, + INTRO_TAC "! *; ne f g" THEN + REWRITE_TAC[MDIST_CFUNSPACE_EQ_MDIST_FUNSPACE] THEN + MATCH_MP_TAC FUNSPACE_MDIST_LE THEN + ASM_SIMP_TAC[REWRITE_RULE[SUBSET] CFUNSPACE_SUBSET_FUNSPACE]);; + +let CFUNSPACE_IMP_BOUNDED2 = prove + (`!top m f g:A->B. + f IN mspace (cfunspace top m) /\ g IN mspace (cfunspace top m) + ==> (?b. !x. x IN topspace top ==> mdist m (f x,g x) <= b)`, + REPEAT STRIP_TAC THEN MATCH_MP_TAC FUNSPACE_IMP_BOUNDED2 THEN + ASM SET_TAC [CFUNSPACE_SUBSET_FUNSPACE]);; + +let CFUNSPACE_MDIST_LT = prove + (`!top m f g:A->B a x. + compact_in top (topspace top) /\ + f IN mspace (cfunspace top m) /\ g IN mspace (cfunspace top m) /\ + mdist (cfunspace top m) (f, g) < a /\ + x IN topspace top + ==> mdist m (f x, g x) < a`, + REPEAT GEN_TAC THEN ASM_CASES_TAC `topspace (top:A topology) = {}` THEN + ASM_REWRITE_TAC[NOT_IN_EMPTY] THEN INTRO_TAC "cpt f g lt x" THEN + REMOVE_THEN "lt" MP_TAC THEN ASM_REWRITE_TAC[CFUNSPACE] THEN + INTRO_TAC "lt" THEN + TRANS_TAC REAL_LET_TRANS + `sup {mdist m (f x:B,g x) | x:A IN topspace top}` THEN + HYP SIMP_TAC "lt" [] THEN MATCH_MP_TAC REAL_LE_SUP THEN + HYP (DESTRUCT_TAC "@b. b" o + MATCH_MP CFUNSPACE_IMP_BOUNDED2 o CONJ_LIST) "f g" [] THEN + MAP_EVERY EXISTS_TAC [`b:real`; `mdist m (f (x:A):B,g x)`] THEN + REWRITE_TAC[IN_ELIM_THM; REAL_LE_REFL] THEN HYP MESON_TAC "x b" []);; + +let MDIST_CFUNSPACE_LE = prove + (`!top m B f g. + &0 <= B /\ + (!x:A. x IN topspace top ==> mdist m (f x:B, g x) <= B) + ==> mdist (cfunspace top m) (f,g) <= B`, + INTRO_TAC "!top m B f g; Bpos bound" THEN + REWRITE_TAC[CFUNSPACE] THEN COND_CASES_TAC THEN + HYP REWRITE_TAC "Bpos" [] THEN MATCH_MP_TAC REAL_SUP_LE THEN + CONJ_TAC THENL + [POP_ASSUM MP_TAC THEN SET_TAC[]; + REWRITE_TAC[IN_ELIM_THM] THEN HYP MESON_TAC "bound" []]);; + +let MDIST_CFUNSPACE_IMP_MDIST_LE = prove + (`!top m f g:A->B a x. + f IN mspace (cfunspace top m) /\ + g IN mspace (cfunspace top m) /\ + mdist (cfunspace top m) (f,g) <= a /\ + x IN topspace top + ==> mdist m (f x,g x) <= a`, + MESON_TAC[MEMBER_NOT_EMPTY; CFUNSPACE_MDIST_LE]);; + +let COMPACT_IN_MSPACE_CFUNSPACE = prove + (`!top m. + compact_in top (topspace top) + ==> mspace (cfunspace top m) = + {f | (!x:A. x IN topspace top ==> f x:B IN mspace m) /\ + f IN EXTENSIONAL (topspace top) /\ + continuous_map (top,mtopology m) f}`, + REWRITE_TAC[CFUNSPACE; EXTENSION; IN_ELIM_THM] THEN REPEAT STRIP_TAC THEN + EQ_TAC THEN SIMP_TAC[] THEN INTRO_TAC "wd ext cont" THEN + MATCH_MP_TAC COMPACT_IN_IMP_MBOUNDED THEN + MATCH_MP_TAC (ISPEC `top:A topology` IMAGE_COMPACT_IN) THEN + ASM_REWRITE_TAC[]);; + +let MCOMPLETE_CFUNSPACE = prove + (`!top:A topology m:B metric. mcomplete m ==> mcomplete (cfunspace top m)`, + INTRO_TAC "!top m; cpl" THEN REWRITE_TAC[cfunspace] THEN + MATCH_MP_TAC SEQUENTIALLY_CLOSED_IN_MCOMPLETE_IMP_MCOMPLETE THEN + ASM_SIMP_TAC[MCOMPLETE_FUNSPACE] THEN + REWRITE_TAC[IN_ELIM_THM; LIMIT_METRIC_SEQUENTIALLY] THEN + INTRO_TAC "![f] [g]; fcont g lim" THEN + ASM_CASES_TAC `topspace top = {}:A->bool` THENL + [ASM_REWRITE_TAC[continuous_map; NOT_IN_EMPTY; EMPTY_GSPEC; OPEN_IN_EMPTY]; + POP_ASSUM (LABEL_TAC "nempty")] THEN + REWRITE_TAC[CONTINUOUS_MAP_TO_METRIC; IN_MBALL] THEN + INTRO_TAC "!x; x; ![e]; e" THEN CLAIM_TAC "e3pos" `&0 < e / &3` THENL + [REMOVE_THEN "e" MP_TAC THEN REAL_ARITH_TAC; + USE_THEN "e3pos" (HYP_TAC "lim: @N. N" o C MATCH_MP)] THEN + HYP_TAC "N: f lt" (C MATCH_MP (SPEC `N:num` LE_REFL)) THEN + HYP_TAC "fcont" (REWRITE_RULE[CONTINUOUS_MAP_TO_METRIC]) THEN + USE_THEN "x" (HYP_TAC "fcont" o C MATCH_MP) THEN + USE_THEN "e3pos" (HYP_TAC "fcont" o C MATCH_MP) THEN + HYP_TAC "fcont: @u. u x' inc" (SPEC `N:num`) THEN EXISTS_TAC `u:A->bool` THEN + HYP REWRITE_TAC "u x'" [] THEN INTRO_TAC "!y; y'" THEN + CLAIM_TAC "uinc" `!x:A. x IN u ==> x IN topspace top` THENL + [REMOVE_THEN "u" (MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN SET_TAC[]; + ALL_TAC] THEN + HYP_TAC "g -> gwd gext gbd" (REWRITE_RULE[FUNSPACE; IN_ELIM_THM]) THEN + HYP_TAC "f -> fwd fext fbd" (REWRITE_RULE[FUNSPACE; IN_ELIM_THM]) THEN + CLAIM_TAC "y" `y:A IN topspace top` THENL + [HYP SIMP_TAC "uinc y'" [OPEN_IN_SUBSET]; HYP SIMP_TAC "gwd x y" []] THEN + CLAIM_TAC "sup" `!x0:A. x0 IN topspace top + ==> mdist m (f (N:num) x0:B,g x0) <= e / &3` THENL + [INTRO_TAC "!x0; x0" THEN TRANS_TAC REAL_LE_TRANS + `sup {mdist m (f (N:num) x,g x:B) | x:A IN topspace top}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC REAL_LE_SUP THEN HYP (DESTRUCT_TAC "@b. b" o + MATCH_MP FUNSPACE_IMP_BOUNDED2 o CONJ_LIST) "f g" [] THEN + MAP_EVERY EXISTS_TAC [`b:real`; `mdist m (f (N:num) (x0:A), g x0:B)`] THEN + REWRITE_TAC[IN_ELIM_THM; REAL_LE_REFL] THEN + CONJ_TAC THENL [HYP SET_TAC "x0" []; HYP MESON_TAC "b" []]; + REMOVE_THEN "lt" MP_TAC THEN HYP REWRITE_TAC "nempty" [FUNSPACE] THEN + MATCH_ACCEPT_TAC REAL_LT_IMP_LE]; + ALL_TAC] THEN + TRANS_TAC REAL_LET_TRANS + `mdist m (g (x:A):B, f (N:num) x) + mdist m (f N x, g y)` THEN + HYP SIMP_TAC "gwd fwd x y" [MDIST_TRIANGLE] THEN + SUBST1_TAC (ARITH_RULE `e = e / &3 + (e / &3 + e / &3)`) THEN + MATCH_MP_TAC REAL_LET_ADD2 THEN HYP SIMP_TAC "gwd fwd x sup" [MDIST_SYM] THEN + TRANS_TAC REAL_LET_TRANS + `mdist m (f (N:num) (x:A):B, f N y) + mdist m (f N y, g y)` THEN + HYP SIMP_TAC "fwd gwd x y" [MDIST_TRIANGLE] THEN + MATCH_MP_TAC REAL_LTE_ADD2 THEN HYP SIMP_TAC "gwd fwd y sup" [] THEN + REMOVE_THEN "inc" MP_TAC THEN HYP SIMP_TAC "fwd x y' uinc" [IN_MBALL]);; + +(* ------------------------------------------------------------------------- *) +(* Existence of completion for any metric space M as a subspace of M->R. *) +(* ------------------------------------------------------------------------- *) + +let METRIC_COMPLETION_EXPLICIT = prove + (`!m:A metric. ?s f:A->A->real. + s SUBSET mspace(funspace (mspace m) real_euclidean_metric) /\ + mcomplete(submetric (funspace (mspace m) real_euclidean_metric) s) /\ + IMAGE f (mspace m) SUBSET s /\ + mtopology(funspace (mspace m) real_euclidean_metric) closure_of + IMAGE f (mspace m) = s /\ + !x y. x IN mspace m /\ y IN mspace m + ==> mdist (funspace (mspace m) real_euclidean_metric) (f x,f y) = + mdist m (x,y)`, + GEN_TAC THEN + ABBREV_TAC `m' = funspace (mspace m:A->bool) real_euclidean_metric` THEN + ASM_CASES_TAC `mspace m:A->bool = {}` THENL + [EXISTS_TAC `{}:(A->real)->bool` THEN + ASM_REWRITE_TAC[NOT_IN_EMPTY; IMAGE_CLAUSES; CLOSURE_OF_EMPTY; + EMPTY_SUBSET; INTER_EMPTY; mcomplete; CAUCHY_IN_SUBMETRIC]; + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY])] THEN + DISCH_THEN(X_CHOOSE_TAC `a:A`) THEN + ABBREV_TAC + `f:A->A->real = + \x. RESTRICTION (mspace m) (\u. mdist m (x,u) - mdist m (a,u))` THEN + EXISTS_TAC `mtopology(funspace (mspace m) real_euclidean_metric) closure_of + IMAGE (f:A->A->real) (mspace m)` THEN + EXISTS_TAC `f:A->A->real` THEN + EXPAND_TAC "m'" THEN + SUBGOAL_THEN `IMAGE (f:A->A->real) (mspace m) SUBSET mspace m'` + ASSUME_TAC THENL + [EXPAND_TAC "m'" THEN REWRITE_TAC[SUBSET; FUNSPACE] THEN + REWRITE_TAC[FORALL_IN_IMAGE; IN_ELIM_THM; EXTENSIONAL] THEN + REWRITE_TAC[REAL_EUCLIDEAN_METRIC; IN_UNIV; mbounded; mcball] THEN + X_GEN_TAC `b:A` THEN DISCH_TAC THEN + EXPAND_TAC "f" THEN SIMP_TAC[RESTRICTION; SUBSET; FORALL_IN_IMAGE] THEN + MAP_EVERY EXISTS_TAC [`&0:real`; `mdist m (a:A,b)`] THEN + REWRITE_TAC[IN_ELIM_THM; REAL_SUB_RZERO] THEN + MAP_EVERY UNDISCH_TAC [`(a:A) IN mspace m`; `(b:A) IN mspace m`] THEN + CONV_TAC METRIC_ARITH; + ALL_TAC] THEN + REWRITE_TAC[SUBMETRIC] THEN ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY] THEN + REWRITE_TAC[CLOSURE_OF_SUBSET_TOPSPACE]; + MATCH_MP_TAC CLOSED_IN_MCOMPLETE_IMP_MCOMPLETE THEN + REWRITE_TAC[CLOSED_IN_CLOSURE_OF] THEN EXPAND_TAC "m'" THEN + MATCH_MP_TAC MCOMPLETE_FUNSPACE THEN + REWRITE_TAC[MCOMPLETE_REAL_EUCLIDEAN_METRIC]; + MATCH_MP_TAC CLOSURE_OF_SUBSET THEN + ASM_REWRITE_TAC[TOPSPACE_MTOPOLOGY]; + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN + EXPAND_TAC "m'" THEN REWRITE_TAC[FUNSPACE] THEN + COND_CASES_TAC THENL [ASM_MESON_TAC[NOT_IN_EMPTY]; ALL_TAC] THEN + MATCH_MP_TAC SUP_UNIQUE THEN SIMP_TAC[FORALL_IN_GSPEC] THEN + X_GEN_TAC `b:real` THEN REWRITE_TAC[REAL_EUCLIDEAN_METRIC] THEN + EXPAND_TAC "f" THEN REWRITE_TAC[RESTRICTION] THEN EQ_TAC THENL + [DISCH_THEN(fun th -> MP_TAC(SPEC `x:A` th)) THEN EXPAND_TAC "f" THEN + ASM_SIMP_TAC[MDIST_REFL; MDIST_SYM] THEN REAL_ARITH_TAC; + MAP_EVERY UNDISCH_TAC [`(x:A) IN mspace m`; `(y:A) IN mspace m`] THEN + CONV_TAC METRIC_ARITH]]);; + +let METRIC_COMPLETION = prove + (`!m:A metric. + ?m' f:A->A->real. + mcomplete m' /\ + IMAGE f (mspace m) SUBSET mspace m' /\ + (mtopology m') closure_of (IMAGE f (mspace m)) = mspace m' /\ + !x y. x IN mspace m /\ y IN mspace m + ==> mdist m' (f x,f y) = mdist m (x,y)`, + GEN_TAC THEN + MATCH_MP_TAC(MESON[] + `(?s f. P (submetric (funspace (mspace m) real_euclidean_metric) s) f) + ==> ?n f. P n f`) THEN + MP_TAC(SPEC `m:A metric` METRIC_COMPLETION_EXPLICIT) THEN + REPEAT(MATCH_MP_TAC MONO_EXISTS THEN GEN_TAC) THEN + REWRITE_TAC[SUBMETRIC; SUBSET_INTER] THEN + REWRITE_TAC[MTOPOLOGY_SUBMETRIC; CLOSURE_OF_SUBTOPOLOGY] THEN + SIMP_TAC[SET_RULE `t SUBSET s ==> s INTER t = t`] THEN SET_TAC[]);; + +let METRIZABLE_SPACE_COMPLETION = prove + (`!top:A topology. + metrizable_space top + ==> ?top' (f:A->A->real). + completely_metrizable_space top' /\ + embedding_map(top,top') f /\ + top' closure_of (IMAGE f (topspace top)) = topspace top'`, + REWRITE_TAC[FORALL_METRIZABLE_SPACE; RIGHT_EXISTS_AND_THM] THEN + X_GEN_TAC `m:A metric` THEN + REWRITE_TAC[EXISTS_COMPLETELY_METRIZABLE_SPACE; RIGHT_AND_EXISTS_THM] THEN + MP_TAC(ISPEC `m:A metric` METRIC_COMPLETION) THEN + REPEAT(MATCH_MP_TAC MONO_EXISTS THEN GEN_TAC) THEN + MESON_TAC[ISOMETRY_IMP_EMBEDDING_MAP]);; + +(* ------------------------------------------------------------------------- *) +(* The Baire Category Theorem *) +(* ------------------------------------------------------------------------- *) + +let METRIC_BAIRE_CATEGORY = prove + (`!m:A metric g. + mcomplete m /\ + COUNTABLE g /\ + (!t. t IN g ==> open_in (mtopology m) t /\ + mtopology m closure_of t = mspace m) + ==> mtopology m closure_of INTERS g = mspace m`, + REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN INTRO_TAC "!m; m" THEN + REWRITE_TAC[FORALL_COUNTABLE_AS_IMAGE; NOT_IN_EMPTY; CLOSURE_OF_UNIV; + INTERS_0; TOPSPACE_MTOPOLOGY; FORALL_IN_IMAGE; IN_UNIV; FORALL_AND_THM] THEN + INTRO_TAC "![u]; u_open u_dense" THEN + REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY] THEN + REWRITE_TAC[DENSE_INTERSECTS_OPEN] THEN + INTRO_TAC "![w]; w_open w_ne" THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + CLAIM_TAC "@x0. x0" `?x0:A. x0 IN u 0 INTER w` THENL + [REWRITE_TAC[MEMBER_NOT_EMPTY] THEN + ASM_MESON_TAC[DENSE_INTERSECTS_OPEN; TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN + CLAIM_TAC "@r0. r0pos r0lt1 sub" + `?r. &0 < r /\ r < &1 /\ mcball m (x0:A,r) SUBSET u 0 INTER w` THENL + [SUBGOAL_THEN `open_in (mtopology m) (u 0 INTER w:A->bool)` MP_TAC THENL + [HYP SIMP_TAC "u_open w_open" [OPEN_IN_INTER]; ALL_TAC] THEN + REWRITE_TAC[OPEN_IN_MTOPOLOGY] THEN INTRO_TAC "u0w hp" THEN + REMOVE_THEN "hp" (MP_TAC o SPEC `x0:A`) THEN + ANTS_TAC THENL [HYP REWRITE_TAC "x0" []; ALL_TAC] THEN + INTRO_TAC "@r. rpos ball" THEN EXISTS_TAC `min r (&1) / &2` THEN + CONJ_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + CONJ_TAC THENL [REAL_ARITH_TAC; ALL_TAC] THEN + TRANS_TAC SUBSET_TRANS `mball m (x0:A,r)` THEN + HYP REWRITE_TAC "ball" [] THEN + MATCH_MP_TAC MCBALL_SUBSET_MBALL_CONCENTRIC THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + (DESTRUCT_TAC "@b. b0 b1" o prove_general_recursive_function_exists) + `?b:num->(A#real). + b 0 = (x0:A,r0) /\ + (!n. b (SUC n) = + @(x,r). &0 < r /\ r < SND (b n) / &2 /\ x IN mspace m /\ + mcball m (x,r) SUBSET mball m (b n) INTER u n)` THEN + CLAIM_TAC "rmk" + `!n. (\ (x:A,r). &0 < r /\ r < SND (b n) / &2 /\ x IN mspace m /\ + mcball m (x,r) SUBSET mball m (b n) INTER u n) + (b (SUC n))` THENL + [LABEL_INDUCT_TAC THENL + [REMOVE_THEN "b1" (fun b1 -> REWRITE_TAC[b1]) THEN + MATCH_MP_TAC CHOICE_PAIRED_THM THEN + REMOVE_THEN "b0" (fun b0 -> REWRITE_TAC[b0]) THEN + MAP_EVERY EXISTS_TAC [`x0:A`; `r0 / &4`] THEN + CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + CONJ_TAC THENL + [CUT_TAC `u 0:A->bool SUBSET mspace m` THENL + [HYP SET_TAC "x0" []; + HYP SIMP_TAC "u_open" [GSYM TOPSPACE_MTOPOLOGY; OPEN_IN_SUBSET]]; + ALL_TAC] THEN + TRANS_TAC SUBSET_TRANS `mball m (x0:A,r0)` THEN CONJ_TAC THENL + [MATCH_MP_TAC MCBALL_SUBSET_MBALL_CONCENTRIC THEN ASM_REAL_ARITH_TAC; + REWRITE_TAC[SUBSET_INTER; SUBSET_REFL] THEN + TRANS_TAC SUBSET_TRANS `mcball m (x0:A,r0)` THEN + REWRITE_TAC [MBALL_SUBSET_MCBALL] THEN HYP SET_TAC "sub" []]; + ALL_TAC] THEN + USE_THEN "b1" (fun b1 -> GEN_REWRITE_TAC RAND_CONV [b1]) THEN + MATCH_MP_TAC CHOICE_PAIRED_THM THEN REWRITE_TAC[] THEN + HYP_TAC "ind_n: rpos rlt x subn" (REWRITE_RULE[LAMBDA_PAIR]) THEN + USE_THEN "u_dense" (MP_TAC o SPEC `SUC n` o + REWRITE_RULE[GSYM TOPSPACE_MTOPOLOGY]) THEN + REWRITE_TAC[DENSE_INTERSECTS_OPEN] THEN + DISCH_THEN (MP_TAC o SPEC `mball m (b (SUC n):A#real)`) THEN + (DESTRUCT_TAC "@x1 r1. bsuc" o MESON[PAIR]) + `?x1:A r1:real. b (SUC n) = x1,r1` THEN + HYP REWRITE_TAC "bsuc" [] THEN + REMOVE_THEN "bsuc" + (fun th -> RULE_ASSUM_TAC (REWRITE_RULE[th]) THEN LABEL_TAC "bsuc" th) THEN + ANTS_TAC THENL + [HYP REWRITE_TAC "x" [OPEN_IN_MBALL; MBALL_EQ_EMPTY; DE_MORGAN_THM] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN INTRO_TAC "@z. hp" THEN + EXISTS_TAC `z:A` THEN + SUBGOAL_THEN `open_in (mtopology m) (mball m (x1:A,r1) INTER u (SUC n))` + (DESTRUCT_TAC "hp1 hp2" o REWRITE_RULE[OPEN_IN_MTOPOLOGY_MCBALL]) THENL + [HYP SIMP_TAC "u_open" [OPEN_IN_INTER; OPEN_IN_MBALL]; ALL_TAC] THEN + CLAIM_TAC "z" `z:A IN mspace m` THENL + [CUT_TAC `u (SUC n):A->bool SUBSET mspace m` THENL + [HYP SET_TAC "hp" []; + HYP SIMP_TAC "u_open" [GSYM TOPSPACE_MTOPOLOGY; OPEN_IN_SUBSET]]; + HYP REWRITE_TAC "z" []] THEN + REMOVE_THEN "hp2" (MP_TAC o SPEC `z:A`) THEN + ANTS_TAC THENL [HYP SET_TAC "hp" []; ALL_TAC] THEN + INTRO_TAC "@r. rpos ball" THEN EXISTS_TAC `min r (r1 / &4)` THEN + CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + TRANS_TAC SUBSET_TRANS `mcball m (z:A,r)` THEN + HYP SIMP_TAC "ball" [MCBALL_SUBSET_CONCENTRIC; REAL_MIN_MIN]; + ALL_TAC] THEN + CLAIM_TAC "@x r. b" `?x r. !n:num. b n = x n:A, r n:real` THENL + [MAP_EVERY EXISTS_TAC + [`FST o (b:num->A#real)`; `SND o (b:num->A#real)`] THEN + REWRITE_TAC[o_DEF]; ALL_TAC] THEN + REMOVE_THEN "b" + (fun b -> RULE_ASSUM_TAC (REWRITE_RULE[b]) THEN LABEL_TAC "b" b) THEN + HYP_TAC "b0: x_0 r_0" (REWRITE_RULE[PAIR_EQ]) THEN + REMOVE_THEN "x_0" (SUBST_ALL_TAC o GSYM) THEN + REMOVE_THEN "r_0" (SUBST_ALL_TAC o GSYM) THEN + HYP_TAC "rmk: r1pos r1lt x1 ball" (REWRITE_RULE[FORALL_AND_THM]) THEN + CLAIM_TAC "x" `!n:num. x n:A IN mspace m` THENL + [LABEL_INDUCT_TAC THENL + [CUT_TAC `u 0:A->bool SUBSET mspace m` THENL + [HYP SET_TAC "x0" []; + HYP SIMP_TAC "u_open" [GSYM TOPSPACE_MTOPOLOGY; OPEN_IN_SUBSET]]; + HYP REWRITE_TAC "x1" []]; ALL_TAC] THEN - INTRO_TAC "![f] [g] [h]; f g h" THEN EXPAND_TAC "fdist" THEN - REWRITE_TAC[] THEN MATCH_MP_TAC REAL_SUP_LE THEN CONJ_TAC THENL - [REWRITE_TAC[EXTENSION; IN_ELIM_THM; NOT_IN_EMPTY; IN_UNIV] THEN - HYP MESON_TAC "a" []; + CLAIM_TAC "rpos" `!n:num. &0 < r n` THENL + [LABEL_INDUCT_TAC THENL + [HYP REWRITE_TAC "r0pos" []; HYP REWRITE_TAC "r1pos" []]; ALL_TAC] THEN - FIX_TAC "[d]" THEN REWRITE_TAC [IN_ELIM_THM; IN_UNIV] THEN - INTRO_TAC "@x. x d" THEN POP_ASSUM SUBST1_TAC THEN - CUT_TAC - `mdist m (f (x:A):B,h x) <= mdist m (f x,g x) + mdist m (g x, h x) /\ - mdist m (f x, g x) <= fdist (f,g) /\ - mdist m (g x, h x) <= fdist (g,h)` THEN - EXPAND_TAC "fdist" THEN REWRITE_TAC[] THENL [REAL_ARITH_TAC; ALL_TAC] THEN - HYP SIMP_TAC "wd f g h x" [MDIST_TRIANGLE] THEN - CONJ_TAC THEN MATCH_MP_TAC REAL_LE_SUP THENL - [CLAIM_TAC "@B. B" `?b. !x:A. x IN s ==> mdist m (f x:B,g x) <= b` THENL - [HYP SIMP_TAC "bound2 f g" []; - MAP_EVERY EXISTS_TAC [`B:real`; `mdist m (f(x:A):B,g x)`]] THEN - REWRITE_TAC[IN_ELIM_THM; IN_UNIV; REAL_LE_REFL] THEN HYP MESON_TAC "B x" []; - CLAIM_TAC "@B. B" `?b. !x:A. x IN s ==> mdist m (g x:B,h x) <= b` THENL - [HYP SIMP_TAC "bound2 g h" []; ALL_TAC] THEN - MAP_EVERY EXISTS_TAC [`B:real`; `mdist m (g(x:A):B,h x)`] THEN - REWRITE_TAC[IN_ELIM_THM; IN_UNIV; REAL_LE_REFL] THEN - HYP MESON_TAC "B x" []]);; - -let FUNSPACE_IMP_WELLDEFINED = prove - (`!s m f:A->B x. f IN mspace (funspace s m) /\ x IN s ==> f x IN mspace m`, - SIMP_TAC[FUNSPACE; IN_ELIM_THM]);; - -let FUNSPACE_IMP_EXTENSIONAL = prove - (`!s m f:A->B. f IN mspace (funspace s m) ==> f IN EXTENSIONAL s`, - SIMP_TAC[FUNSPACE; IN_ELIM_THM]);; + CLAIM_TAC "rmono" `!p q:num. p <= q ==> r q <= r p` THENL + [MATCH_MP_TAC LE_INDUCT THEN REWRITE_TAC[REAL_LE_REFL] THEN + INTRO_TAC "!p q; pq rpq" THEN + REMOVE_THEN "r1lt" (MP_TAC o SPEC `q:num`) THEN + REMOVE_THEN "rpos" (MP_TAC o SPEC `q:num`) THEN + ASM_REAL_ARITH_TAC; + ALL_TAC] THEN + CLAIM_TAC "rlt" `!n:num. r n < inv (&2 pow n)` THENL + [LABEL_INDUCT_TAC THENL + [CONV_TAC (RAND_CONV REAL_RAT_REDUCE_CONV) THEN HYP REWRITE_TAC "r0lt1" []; + TRANS_TAC REAL_LTE_TRANS `r (n:num) / &2` THEN + HYP REWRITE_TAC "r1lt" [real_pow] THEN REMOVE_THEN "ind_n" MP_TAC THEN + REMOVE_THEN "rpos" (MP_TAC o SPEC `n:num`) THEN CONV_TAC REAL_FIELD]; + ALL_TAC] THEN + CLAIM_TAC "nested" + `!p q:num. p <= q ==> mball m (x q:A, r q) SUBSET mball m (x p, r p)` THENL + [MATCH_MP_TAC LE_INDUCT THEN REWRITE_TAC[SUBSET_REFL] THEN + INTRO_TAC "!p q; pq sub" THEN + TRANS_TAC SUBSET_TRANS `mball m (x (q:num):A,r q)` THEN + HYP REWRITE_TAC "sub" [] THEN + TRANS_TAC SUBSET_TRANS `mcball m (x (SUC q):A,r(SUC q))` THEN + REWRITE_TAC[MBALL_SUBSET_MCBALL] THEN HYP SET_TAC "ball" []; + ALL_TAC] THEN + CLAIM_TAC "in_ball" `!p q:num. p <= q ==> x q:A IN mball m (x p, r p)` THENL + [INTRO_TAC "!p q; le" THEN CUT_TAC `x (q:num):A IN mball m (x q, r q)` THENL + [HYP SET_TAC "nested le" []; HYP SIMP_TAC "x rpos" [CENTRE_IN_MBALL_EQ]]; + ALL_TAC] THEN + CLAIM_TAC "@l. l" `?l:A. limit (mtopology m) x l sequentially` THENL + [HYP_TAC "m" (REWRITE_RULE[mcomplete]) THEN REMOVE_THEN "m" MATCH_MP_TAC THEN + HYP REWRITE_TAC "x" [cauchy_in] THEN INTRO_TAC "!e; epos" THEN + CLAIM_TAC "@N. N" `?N. inv(&2 pow N) < e` THENL + [REWRITE_TAC[REAL_INV_POW] THEN MATCH_MP_TAC REAL_ARCH_POW_INV THEN + HYP REWRITE_TAC "epos" [] THEN REAL_ARITH_TAC; + ALL_TAC] THEN + EXISTS_TAC `N:num` THEN MATCH_MP_TAC WLOG_LE THEN CONJ_TAC THENL + [HYP SIMP_TAC "x" [MDIST_SYM] THEN MESON_TAC[]; ALL_TAC] THEN + INTRO_TAC "!n n'; le; n n'" THEN + TRANS_TAC REAL_LT_TRANS `inv (&2 pow N)` THEN HYP REWRITE_TAC "N" [] THEN + TRANS_TAC REAL_LT_TRANS `r (N:num):real` THEN HYP REWRITE_TAC "rlt" [] THEN + CUT_TAC `x (n':num):A IN mball m (x n, r n)` THENL + [HYP REWRITE_TAC "x" [IN_MBALL] THEN INTRO_TAC "hp" THEN + TRANS_TAC REAL_LTE_TRANS `r (n:num):real` THEN + HYP SIMP_TAC "n rmono hp" []; + HYP SIMP_TAC "in_ball le" []]; + ALL_TAC] THEN + EXISTS_TAC `l:A` THEN + CLAIM_TAC "in_mcball" `!n:num. l:A IN mcball m (x n, r n)` THENL + [GEN_TAC THEN + (MATCH_MP_TAC o ISPECL [`sequentially`; `mtopology (m:A metric)`]) + LIMIT_IN_CLOSED_IN THEN EXISTS_TAC `x:num->A` THEN + HYP REWRITE_TAC "l" [TRIVIAL_LIMIT_SEQUENTIALLY; CLOSED_IN_MCBALL] THEN + REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN EXISTS_TAC `n:num` THEN + INTRO_TAC "![p]; p" THEN CUT_TAC `x (p:num):A IN mball m (x n, r n)` THENL + [SET_TAC[MBALL_SUBSET_MCBALL]; HYP SIMP_TAC "in_ball p" []]; + ALL_TAC] THEN + REWRITE_TAC[IN_INTER] THEN CONJ_TAC THENL + [REWRITE_TAC[IN_INTERS; FORALL_IN_IMAGE; IN_UNIV] THEN + LABEL_INDUCT_TAC THENL + [HYP SET_TAC "in_mcball sub " []; HYP SET_TAC "in_mcball ball " []]; + HYP SET_TAC "sub in_mcball" []]);; -let FUNSPACE_IMP_BOUNDED_IMAGE = prove - (`!s m f:A->B. f IN mspace (funspace s m) ==> mbounded m (IMAGE f s)`, - SIMP_TAC[FUNSPACE; IN_ELIM_THM]);; +let METRIC_BAIRE_CATEGORY_ALT = prove + (`!m g:(A->bool)->bool. + mcomplete m /\ + COUNTABLE g /\ + (!t. t IN g + ==> closed_in (mtopology m) t /\ mtopology m interior_of t = {}) + ==> mtopology m interior_of (UNIONS g) = {}`, + REPEAT STRIP_TAC THEN + MP_TAC(ISPECL [`m:A metric`; `IMAGE (\u:A->bool. mspace m DIFF u) g`] + METRIC_BAIRE_CATEGORY) THEN + ASM_SIMP_TAC[COUNTABLE_IMAGE; FORALL_IN_IMAGE] THEN + ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_MSPACE] THEN + REWRITE_TAC[CLOSURE_OF_COMPLEMENT; GSYM TOPSPACE_MTOPOLOGY] THEN + ASM_SIMP_TAC[DIFF_EMPTY] THEN REWRITE_TAC[CLOSURE_OF_INTERIOR_OF] THEN + MATCH_MP_TAC(SET_RULE + `s SUBSET u /\ s' = s ==> u DIFF s' = u ==> s = {}`) THEN + REWRITE_TAC[INTERIOR_OF_SUBSET_TOPSPACE] THEN AP_TERM_TAC THEN + REWRITE_TAC[DIFF_INTERS; SET_RULE + `{f y | y IN IMAGE g s} = {f(g x) | x IN s}`] THEN + AP_TERM_TAC THEN MATCH_MP_TAC(SET_RULE + `(!x. x IN s ==> f x = x) ==> {f x | x IN s} = s`) THEN + X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `s:A->bool`) THEN + ASM_REWRITE_TAC[] THEN STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o MATCH_MP CLOSED_IN_SUBSET) THEN SET_TAC[]);; -let FUNSPACE_IMP_BOUNDED = prove - (`!s m f:A->B. f IN mspace (funspace s m) - ==> s = {} \/ (?c b. !x. x IN s ==> mdist m (c,f x) <= b)`, - REPEAT GEN_TAC THEN - REWRITE_TAC[FUNSPACE; MBOUNDED; IMAGE_EQ_EMPTY; IN_ELIM_THM] THEN - ASM_CASES_TAC `s:A->bool = {}` THEN ASM_REWRITE_TAC[] THEN ASM SET_TAC[]);; +let BAIRE_CATEGORY_ALT = prove + (`!top g:(A->bool)->bool. + (completely_metrizable_space top \/ + locally_compact_space top /\ + (hausdorff_space top \/ regular_space top)) /\ + COUNTABLE g /\ + (!t. t IN g ==> closed_in top t /\ top interior_of t = {}) + ==> top interior_of (UNIONS g) = {}`, + REWRITE_TAC[TAUT `(p \/ q) /\ r ==> s <=> + (p ==> r ==> s) /\ (q /\ r ==> s)`] THEN + REWRITE_TAC[FORALL_AND_THM; RIGHT_FORALL_IMP_THM] THEN + REWRITE_TAC[GSYM FORALL_MCOMPLETE_TOPOLOGY] THEN + SIMP_TAC[METRIC_BAIRE_CATEGORY_ALT] THEN REPEAT GEN_TAC THEN + DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC) THEN + FIRST_ASSUM(MP_TAC o MATCH_MP (TAUT `(p \/ q) ==> (p ==> q) ==> q`)) THEN + ANTS_TAC THENL + [ASM_MESON_TAC[LOCALLY_COMPACT_HAUSDORFF_IMP_REGULAR_SPACE]; DISCH_TAC] THEN + ASM_CASES_TAC `g:(A->bool)->bool = {}` THEN + ASM_REWRITE_TAC[UNIONS_0; INTERIOR_OF_EMPTY] THEN + FIRST_X_ASSUM(MP_TAC o MATCH_MP (REWRITE_RULE[IMP_CONJ] + COUNTABLE_AS_IMAGE)) THEN + ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `t:num->A->bool` THEN DISCH_THEN SUBST_ALL_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [FORALL_IN_IMAGE]) THEN + REWRITE_TAC[IN_UNIV; FORALL_AND_THM] THEN STRIP_TAC THEN + REWRITE_TAC[interior_of; EXTENSION; IN_ELIM_THM; NOT_IN_EMPTY] THEN + X_GEN_TAC `z:A` THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + MP_TAC(ISPEC `top:A topology` + LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE_CLOSED_IN) THEN + ASM_REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN + FIRST_ASSUM(MP_TAC o SPEC `z:A` o REWRITE_RULE[SUBSET] o MATCH_MP + OPEN_IN_SUBSET) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + DISCH_THEN(MP_TAC o SPECL [`u:A->bool`; `z:A`]) THEN + ASM_REWRITE_TAC[NOT_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`v:A->bool`; `k:A->bool`] THEN STRIP_TAC THEN + SUBGOAL_THEN + `?c:num->A->bool. + (!n. c n SUBSET k /\ closed_in top (c n) /\ + ~(top interior_of c n = {}) /\ DISJOINT (c n) (t n)) /\ + (!n. c (SUC n) SUBSET c n)` + MP_TAC THENL + [MATCH_MP_TAC DEPENDENT_CHOICE THEN CONJ_TAC THENL + [FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I + [GSYM NEIGHBOURHOOD_BASE_OF_CLOSED_IN]) THEN + REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN + DISCH_THEN(MP_TAC o SPEC `v DIFF (t:num->A->bool) 0`) THEN + ASM_SIMP_TAC[OPEN_IN_DIFF] THEN + DISCH_THEN(MP_TAC o MATCH_MP MONO_EXISTS) THEN ANTS_TAC THENL + [REWRITE_TAC[SET_RULE `(?x. x IN s DIFF t) <=> ~(s SUBSET t)`] THEN + DISCH_TAC THEN + SUBGOAL_THEN `top interior_of (t:num->A->bool) 0 = {}` MP_TAC THENL + [ASM_REWRITE_TAC[]; REWRITE_TAC[interior_of]] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN ASM_MESON_TAC[]; + REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`x:A`; `n:A->bool`; `c:A->bool`] THEN + STRIP_TAC THEN EXISTS_TAC `c:A->bool` THEN + ASM_REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + REPEAT CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC; ASM SET_TAC[]] THEN + EXISTS_TAC `x:A` THEN REWRITE_TAC[interior_of; IN_ELIM_THM] THEN + ASM_MESON_TAC[]]; + MAP_EVERY X_GEN_TAC [`n:num`; `c:A->bool`] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I + [GSYM NEIGHBOURHOOD_BASE_OF_CLOSED_IN]) THEN + REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN + DISCH_THEN(MP_TAC o SPEC + `top interior_of c DIFF (t:num->A->bool) (SUC n)`) THEN + ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_INTERIOR_OF] THEN + DISCH_THEN(MP_TAC o MATCH_MP MONO_EXISTS) THEN ANTS_TAC THENL + [REWRITE_TAC[SET_RULE `(?x. x IN s DIFF t) <=> ~(s SUBSET t)`] THEN + DISCH_TAC THEN + SUBGOAL_THEN `top interior_of t(SUC n):A->bool = {}` MP_TAC THENL + [ASM_REWRITE_TAC[]; REWRITE_TAC[interior_of]] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + ASM_MESON_TAC[OPEN_IN_INTERIOR_OF; MEMBER_NOT_EMPTY]; + REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`x:A`; `n:A->bool`; `d:A->bool`] THEN + STRIP_TAC THEN EXISTS_TAC `d:A->bool` THEN + ASM_REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN REPEAT CONJ_TAC THENL + [MP_TAC(ISPECL[`top:A topology`; `c:A->bool`] INTERIOR_OF_SUBSET) THEN + ASM SET_TAC[]; + EXISTS_TAC `x:A` THEN REWRITE_TAC[interior_of; IN_ELIM_THM] THEN + ASM_MESON_TAC[]; + ASM SET_TAC[]; + MP_TAC(ISPECL[`top:A topology`; `c:A->bool`] INTERIOR_OF_SUBSET) THEN + ASM SET_TAC[]]]]; + REWRITE_TAC[NOT_EXISTS_THM; FORALL_AND_THM]] THEN + X_GEN_TAC `c:num->A->bool` THEN STRIP_TAC THEN + MP_TAC(ISPECL [`subtopology top (k:A->bool)`; `c:num->A->bool`] + COMPACT_SPACE_IMP_NEST) THEN + ASM_SIMP_TAC[COMPACT_SPACE_SUBTOPOLOGY; CLOSED_IN_SUBSET_TOPSPACE] THEN + REWRITE_TAC[NOT_IMP] THEN REPEAT CONJ_TAC THENL + [ASM_MESON_TAC[INTERIOR_OF_SUBSET; CLOSED_IN_SUBSET; MEMBER_NOT_EMPTY; + SUBSET]; + MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN ASM SET_TAC[]; + RULE_ASSUM_TAC(REWRITE_RULE[UNIONS_IMAGE; IN_UNIV]) THEN + REWRITE_TAC[INTERS_GSPEC] THEN ASM SET_TAC[]]);; -let FUNSPACE_IMP_BOUNDED2 = prove - (`!s m f g:A->B. f IN mspace (funspace s m) /\ g IN mspace (funspace s m) - ==> (?b. !x. x IN s ==> mdist m (f x,g x) <= b)`, - REWRITE_TAC[FUNSPACE; IN_ELIM_THM] THEN REPEAT STRIP_TAC THEN - CUT_TAC `mbounded m (IMAGE (f:A->B) s UNION IMAGE g s)` THENL - [REWRITE_TAC[MBOUNDED_ALT; SUBSET; IN_UNION] THEN - STRIP_TAC THEN EXISTS_TAC `b:real` THEN ASM SET_TAC []; - ASM_REWRITE_TAC[MBOUNDED_UNION]]);; +let BAIRE_CATEGORY = prove + (`!top g:(A->bool)->bool. + (completely_metrizable_space top \/ + locally_compact_space top /\ + (hausdorff_space top \/ regular_space top)) /\ + COUNTABLE g /\ + (!t. t IN g ==> open_in top t /\ top closure_of t = topspace top) + ==> top closure_of INTERS g = topspace top`, + REPEAT GEN_TAC THEN DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC) THEN + ASM_CASES_TAC `g:(A->bool)->bool = {}` THENL + [ONCE_REWRITE_TAC[CLOSURE_OF_RESTRICT] THEN + ASM_SIMP_TAC[INTERS_0; INTER_UNIV; CLOSURE_OF_TOPSPACE]; + ALL_TAC] THEN + MP_TAC(ISPECL [`top:A topology`; + `IMAGE (\u:A->bool. topspace top DIFF u) g`] + BAIRE_CATEGORY_ALT) THEN + ASM_SIMP_TAC[COUNTABLE_IMAGE; FORALL_IN_IMAGE] THEN + ASM_SIMP_TAC[CLOSED_IN_DIFF; CLOSED_IN_TOPSPACE] THEN + ASM_SIMP_TAC[INTERIOR_OF_COMPLEMENT; DIFF_EQ_EMPTY] THEN + REWRITE_TAC[INTERIOR_OF_CLOSURE_OF] THEN + MATCH_MP_TAC(SET_RULE + `s SUBSET u /\ s' = s ==> u DIFF s' = {} ==> s = u`) THEN + REWRITE_TAC[CLOSURE_OF_SUBSET_TOPSPACE] THEN AP_TERM_TAC THEN + REWRITE_TAC[DIFF_UNIONS; SET_RULE + `{f y | y IN IMAGE g s} = {f(g x) | x IN s}`] THEN + MATCH_MP_TAC(SET_RULE `t SUBSET u /\ s = t ==> u INTER s = t`) THEN + CONJ_TAC THENL [ASM_MESON_TAC[INTERS_SUBSET; OPEN_IN_SUBSET]; ALL_TAC] THEN + AP_TERM_TAC THEN MATCH_MP_TAC(SET_RULE + `(!x. x IN s ==> f x = x) ==> {f x | x IN s} = s`) THEN + X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `s:A->bool`) THEN + ASM_REWRITE_TAC[] THEN STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN SET_TAC[]);; -let FUNSPACE_MDIST_LE = prove - (`!s m f g:A->B a. - ~(s = {}) /\ - f IN mspace (funspace s m) /\ - g IN mspace (funspace s m) - ==> (mdist (funspace s m) (f,g) <= a <=> - !x. x IN s ==> mdist m (f x, g x) <= a)`, - INTRO_TAC "! *; ne f g" THEN - HYP (DESTRUCT_TAC "@b. b" o - MATCH_MP FUNSPACE_IMP_BOUNDED2 o CONJ_LIST) "f g" [] THEN - ASM_REWRITE_TAC[FUNSPACE] THEN - MP_TAC (ISPECL [`{mdist m (f x:B,g x) | x:A IN s}`; `a:real`] - REAL_SUP_LE_EQ) THEN - ANTS_TAC THENL [ASM SET_TAC[]; REWRITE_TAC[IN_ELIM_THM]] THEN - MESON_TAC[]);; +(* ------------------------------------------------------------------------- *) +(* Sierpinski-Hausdorff type results about countable closed unions. *) +(* ------------------------------------------------------------------------- *) -let MCOMPLETE_FUNSPACE = prove - (`!s:A->bool m:B metric. mcomplete m ==> mcomplete (funspace s m)`, - REWRITE_TAC[mcomplete] THEN INTRO_TAC "!s m; cpl; ![f]; cy" THEN - ASM_CASES_TAC `s:A->bool = {}` THENL - [POP_ASSUM SUBST_ALL_TAC THEN EXISTS_TAC `\x:A. ARB:B` THEN - REMOVE_THEN "cy" MP_TAC THEN - SIMP_TAC[cauchy_in; LIMIT_METRIC_SEQUENTIALLY; FUNSPACE; NOT_IN_EMPTY; - IN_ELIM_THM; IN_EXTENSIONAL; IMAGE_CLAUSES; MBOUNDED_EMPTY]; - POP_ASSUM (LABEL_TAC "nempty")] THEN - LABEL_ABBREV_TAC - `g (x:A) = if x IN s - then @y. limit (mtopology m) (\n:num. f n x) y sequentially - else ARB:B` THEN - EXISTS_TAC `g:A->B` THEN USE_THEN "cy" MP_TAC THEN - HYP REWRITE_TAC "nempty" - [cauchy_in; FUNSPACE; IN_ELIM_THM; FORALL_AND_THM] THEN - INTRO_TAC "(fwd fext fbd) cy'" THEN - ASM_REWRITE_TAC[LIMIT_METRIC_SEQUENTIALLY; FUNSPACE; IN_ELIM_THM] THEN - CLAIM_TAC "gext" `g:A->B IN EXTENSIONAL s` THENL - [REMOVE_THEN "g" (fun th -> SIMP_TAC[IN_EXTENSIONAL; GSYM th]); - HYP REWRITE_TAC "gext" []] THEN - CLAIM_TAC "bd2" - `!n n'. ?b. !x:A. x IN s ==> mdist m (f (n:num) x:B, f n' x) <= b` THENL - [REPEAT GEN_TAC THEN MATCH_MP_TAC FUNSPACE_IMP_BOUNDED2 THEN - ASM_REWRITE_TAC[FUNSPACE; IN_ELIM_THM; ETA_AX]; - ALL_TAC] THEN - CLAIM_TAC "sup" - `!n n':num x0:A. x0 IN s - ==> mdist m (f n x0:B,f n' x0) <= - sup {mdist m (f n x,f n' x) | x IN s}` THENL - [INTRO_TAC "!n n' x0; x0" THEN MATCH_MP_TAC REAL_LE_SUP THEN - REMOVE_THEN "bd2" (DESTRUCT_TAC "@b. b" o SPECL[`n:num`;`n':num`]) THEN - MAP_EVERY EXISTS_TAC - [`b:real`; `mdist m (f (n:num) (x0:A):B, f n' x0)`] THEN - REWRITE_TAC[IN_ELIM_THM] THEN CONJ_TAC THENL - [HYP MESON_TAC "x0" []; REWRITE_TAC[REAL_LE_REFL]] THEN - INTRO_TAC "![d]; @y. y d" THEN REMOVE_THEN "d" SUBST1_TAC THEN - HYP SIMP_TAC "b y" []; - ALL_TAC] THEN - CLAIM_TAC "pcy" `!x:A. x IN s ==> cauchy_in m (\n. f n x:B)` THENL - [INTRO_TAC "!x; x" THEN REWRITE_TAC[cauchy_in] THEN - HYP SIMP_TAC "fwd x" [] THEN INTRO_TAC "!e; e" THEN - USE_THEN "e" (HYP_TAC "cy': @N.N" o C MATCH_MP) THEN EXISTS_TAC `N:num` THEN - REPEAT GEN_TAC THEN DISCH_THEN (HYP_TAC "N" o C MATCH_MP) THEN - TRANS_TAC REAL_LET_TRANS - `sup {mdist m (f (n:num) x:B,f n' x) | x:A IN s}` THEN - HYP REWRITE_TAC "N" [] THEN HYP SIMP_TAC "sup x" []; - ALL_TAC] THEN - CLAIM_TAC "glim" - `!x:A. x IN s - ==> limit (mtopology m) (\n. f n x:B) (g x) sequentially` THENL - [INTRO_TAC "!x; x" THEN - REMOVE_THEN "g" (fun th -> ASM_REWRITE_TAC[GSYM th]) THEN - SELECT_ELIM_TAC THEN HYP SIMP_TAC "cpl pcy x" []; - ALL_TAC] THEN - CLAIM_TAC "gwd" `!x:A. x IN s ==> g x:B IN mspace m` THENL - [INTRO_TAC "!x; x" THEN - MATCH_MP_TAC (ISPECL[`sequentially`] LIMIT_IN_MSPACE) THEN - EXISTS_TAC `\n:num. f n (x:A):B` THEN HYP SIMP_TAC "glim x" []; - HYP REWRITE_TAC "gwd" []] THEN - CLAIM_TAC "unif" - `!e. &0 < e ==> ?N:num. !x:A n. x IN s /\ N <= n - ==> mdist m (f n x:B, g x) < e` THENL - [INTRO_TAC "!e; e" THEN REMOVE_THEN "cy'" (MP_TAC o SPEC `e / &2`) THEN - HYP REWRITE_TAC "e" [REAL_HALF] THEN INTRO_TAC "@N. N" THEN - EXISTS_TAC `N:num` THEN INTRO_TAC "!x n; x n" THEN - USE_THEN "x" (HYP_TAC "glim" o C MATCH_MP) THEN - HYP_TAC "glim: gx glim" (REWRITE_RULE[LIMIT_METRIC_SEQUENTIALLY]) THEN - REMOVE_THEN "glim" (MP_TAC o SPEC `e / &2`) THEN - HYP REWRITE_TAC "e" [REAL_HALF] THEN - HYP SIMP_TAC "fwd x" [] THEN INTRO_TAC "@N'. N'" THEN - TRANS_TAC REAL_LET_TRANS - `mdist m (f n (x:A):B, f (MAX N N') x) + - mdist m (f (MAX N N') x, g x)` THEN - HYP SIMP_TAC "fwd x gwd" [MDIST_TRIANGLE] THEN - TRANS_TAC REAL_LTE_TRANS `e / &2 + e / &2` THEN CONJ_TAC THENL - [MATCH_MP_TAC REAL_LT_ADD2; REWRITE_TAC[REAL_HALF; REAL_LE_REFL]] THEN - CONJ_TAC THENL [ALL_TAC; REMOVE_THEN "N'" MATCH_MP_TAC THEN ARITH_TAC] THEN - TRANS_TAC REAL_LET_TRANS - `sup {mdist m (f n x:B,f (MAX N N') x) | x:A IN s}` THEN - HYP SIMP_TAC "N n" [ARITH_RULE `N <= MAX N N'`] THEN - HYP SIMP_TAC "sup x" []; - ALL_TAC] THEN +let LOCALLY_CONNECTED_NOT_COUNTABLE_CLOSED_UNION = prove + (`!top u:(A->bool)->bool. + ~(topspace top = {}) /\ + connected_space top /\ + locally_connected_space top /\ + (completely_metrizable_space top \/ + locally_compact_space top /\ hausdorff_space top) /\ + COUNTABLE u /\ pairwise DISJOINT u /\ + (!c. c IN u ==> closed_in top c /\ ~(c = {})) /\ + UNIONS u = topspace top + ==> u = {topspace top}`, + let lemma = prove + (`UNIONS (IMAGE f s UNION IMAGE g s) = + UNIONS (IMAGE (\x. f x UNION g x) s)`, + REWRITE_TAC[UNIONS_UNION; UNIONS_IMAGE] THEN SET_TAC[]) in + REWRITE_TAC[REAL_CLOSED_IN] THEN REPEAT GEN_TAC THEN + DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC) THEN + ABBREV_TAC `v = IMAGE (\c:A->bool. top frontier_of c) u` THEN + ABBREV_TAC `b:A->bool = UNIONS v` THEN + MATCH_MP_TAC(TAUT `(~p ==> F) ==> p`) THEN DISCH_TAC THEN + SUBGOAL_THEN `(b:A->bool) SUBSET topspace top` ASSUME_TAC THENL + [EXPAND_TAC "b" THEN REWRITE_TAC[UNIONS_SUBSET] THEN + EXPAND_TAC "v" THEN REWRITE_TAC[FORALL_IN_IMAGE] THEN + REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY; FRONTIER_OF_SUBSET_TOPSPACE]; + ALL_TAC] THEN + MP_TAC(ISPECL [`subtopology top (b:A->bool)`; `v:(A->bool)->bool`] + BAIRE_CATEGORY_ALT) THEN + ASM_REWRITE_TAC[] THEN EXPAND_TAC "v" THEN REWRITE_TAC[FORALL_IN_IMAGE] THEN + ASM_SIMP_TAC[COUNTABLE_IMAGE; NOT_IMP] THEN CONJ_TAC THENL + [ALL_TAC; + MP_TAC(ISPEC `subtopology top (b:A->bool)` + INTERIOR_OF_TOPSPACE) THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY] THEN + ASM_SIMP_TAC[TOPSPACE_MTOPOLOGY; SET_RULE + `s SUBSET u ==> u INTER s = s`] THEN + DISCH_THEN SUBST1_TAC THEN EXPAND_TAC "b" THEN + EXPAND_TAC "v" THEN MATCH_MP_TAC(SET_RULE + `(!s. s IN u /\ s SUBSET UNIONS u /\ f s = {} ==> s = {}) /\ + ~(UNIONS u = {}) + ==> ~(UNIONS(IMAGE f u) = {})`) THEN + ASM_SIMP_TAC[IMP_CONJ; FRONTIER_OF_EQ_EMPTY; GSYM TOPSPACE_MTOPOLOGY] THEN + ASM_REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN + X_GEN_TAC `s:A->bool` THEN REPEAT STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [CONNECTED_SPACE_CLOPEN_IN]) THEN + DISCH_THEN(MP_TAC o SPEC `s:A->bool`) THEN + ASM_CASES_TAC `s:A->bool = {}` THEN ASM_SIMP_TAC[] THEN + ASM_REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN DISCH_THEN SUBST_ALL_TAC THEN + FIRST_ASSUM(MP_TAC o MATCH_MP (SET_RULE + `~(u = {a}) ==> a IN u ==> ?b. b IN u /\ ~(b = a)`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `t:A->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [pairwise]) THEN + DISCH_THEN(MP_TAC o SPECL [`topspace top:A->bool`; `t:A->bool`]) THEN + ASM SET_TAC[]] THEN + SUBGOAL_THEN `closed_in top (b:A->bool)` ASSUME_TAC THENL + [SUBGOAL_THEN + `b = topspace top DIFF + UNIONS (IMAGE (\c:A->bool. top interior_of c) u)` + SUBST1_TAC THENL + [MAP_EVERY EXPAND_TAC ["b"; "v"] THEN MATCH_MP_TAC(SET_RULE + `s UNION t = u /\ DISJOINT s t ==> s = u DIFF t`) THEN + CONJ_TAC THENL + [REWRITE_TAC[GSYM UNIONS_UNION; lemma] THEN + ONCE_REWRITE_TAC[UNION_COMM] THEN + REWRITE_TAC[INTERIOR_OF_UNION_FRONTIER_OF] THEN + FIRST_X_ASSUM(fun th -> GEN_REWRITE_TAC RAND_CONV [SYM th]) THEN + AP_TERM_TAC THEN MATCH_MP_TAC(SET_RULE + `(!x. x IN s ==> f x = x) ==> IMAGE f s = s`) THEN + ASM_SIMP_TAC[CLOSURE_OF_EQ]; + REWRITE_TAC[SET_RULE + `DISJOINT (UNIONS s) (UNIONS t) <=> + !x. x IN s ==> !y. y IN t ==> DISJOINT x y`] THEN + REWRITE_TAC[FORALL_IN_IMAGE] THEN + X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN + X_GEN_TAC `t:A->bool` THEN DISCH_TAC THEN + ASM_CASES_TAC `s:A->bool = t` THENL + [ASM_REWRITE_TAC[frontier_of] THEN SET_TAC[]; + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [pairwise])] THEN + DISCH_THEN(MP_TAC o SPECL [`s:A->bool`; `t:A->bool`]) THEN + ASM_SIMP_TAC[frontier_of; CLOSURE_OF_CLOSED_IN] THEN + MP_TAC(ISPECL [`top:A topology`; `t:A->bool`] + INTERIOR_OF_SUBSET) THEN + SET_TAC[]]; + MATCH_MP_TAC CLOSED_IN_DIFF THEN REWRITE_TAC[CLOSED_IN_TOPSPACE] THEN + MATCH_MP_TAC OPEN_IN_UNIONS THEN + REWRITE_TAC[FORALL_IN_IMAGE; OPEN_IN_INTERIOR_OF]]; + ALL_TAC] THEN + CONJ_TAC THENL + [ASM_MESON_TAC[COMPLETELY_METRIZABLE_SPACE_CLOSED_IN; + LOCALLY_COMPACT_SPACE_CLOSED_SUBSET; + HAUSDORFF_SPACE_SUBTOPOLOGY]; + ALL_TAC] THEN + X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN CONJ_TAC THENL + [MATCH_MP_TAC CLOSED_IN_SUBSET_TOPSPACE THEN + REWRITE_TAC[CLOSED_IN_FRONTIER_OF; FRONTIER_OF_SUBSET_TOPSPACE] THEN + ASM SET_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[EXTENSION; interior_of; IN_ELIM_THM; NOT_IN_EMPTY] THEN + X_GEN_TAC `a:A` THEN + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY_ALT; EXISTS_IN_GSPEC; IN_INTER] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(a:A) IN top frontier_of s` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(a:A) IN s` ASSUME_TAC THENL + [UNDISCH_TAC `(a:A) IN top frontier_of s` THEN + REWRITE_TAC[frontier_of; IN_DIFF] THEN ASM_SIMP_TAC[CLOSURE_OF_CLOSED_IN]; + ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [locally_connected_space]) THEN + DISCH_THEN(MP_TAC o GEN_REWRITE_RULE I [NEIGHBOURHOOD_BASE_OF]) THEN + DISCH_THEN(MP_TAC o SPECL [`u:A->bool`; `a:A`]) THEN + REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY; SUBTOPOLOGY_TOPSPACE] THEN + ASM_REWRITE_TAC[NOT_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`w:A->bool`; `c:A->bool`] THEN STRIP_TAC THEN + MP_TAC(ISPECL [`top:A topology`; `s:A->bool`; `w:A->bool`] + FRONTIER_OF_OPEN_IN_STRADDLE_INTER) THEN + ASM_REWRITE_TAC[NOT_IMP] THEN CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + STRIP_TAC THEN + SUBGOAL_THEN `?t:A->bool. t IN u /\ ~(t = s) /\ ~(w INTER t = {})` + STRIP_ASSUME_TAC THENL + [REPEAT(FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET)) THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN ASM SET_TAC[]; + ALL_TAC] THEN + FIRST_ASSUM(MP_TAC o SPECL [`s:A->bool`; `t:A->bool`] o + GEN_REWRITE_RULE I [pairwise]) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + MP_TAC(ISPECL [`top:A topology`; `c:A->bool`; `t:A->bool`] + CONNECTED_IN_INTER_FRONTIER_OF) THEN + ASM_REWRITE_TAC[NOT_IMP] THEN CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `top frontier_of (s:A->bool) SUBSET s /\ + top frontier_of (t:A->bool) SUBSET t` + STRIP_ASSUME_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN + ASM_SIMP_TAC[FRONTIER_OF_SUBSET_CLOSED_IN]);; + +let REAL_SIERPINSKI_LEMMA = prove + (`!a b u. + a <= b /\ + COUNTABLE u /\ pairwise DISJOINT u /\ + (!c. c IN u ==> real_closed c /\ ~(c = {})) /\ + UNIONS u = real_interval[a,b] + ==> u = {real_interval[a,b]}`, + REPEAT STRIP_TAC THEN + MP_TAC(ISPEC `subtopology euclideanreal (real_interval[a,b])` + LOCALLY_CONNECTED_NOT_COUNTABLE_CLOSED_UNION) THEN + REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN + DISCH_THEN MATCH_MP_TAC THEN + ASM_REWRITE_TAC[REAL_INTERVAL_NE_EMPTY; REAL_POS] THEN + ASM_SIMP_TAC[CONNECTED_SPACE_SUBTOPOLOGY; + CONNECTED_IN_EUCLIDEANREAL_INTERVAL; + LOCALLY_CONNECTED_REAL_INTERVAL] THEN CONJ_TAC THENL - [HYP_TAC "cy': @N. N" (C MATCH_MP REAL_LT_01) THEN - USE_THEN "fbd" (MP_TAC o REWRITE_RULE[MBOUNDED] o SPEC `N:num`) THEN - HYP REWRITE_TAC "nempty" [mbounded; IMAGE_EQ_EMPTY] THEN - INTRO_TAC "Nwd (@c b. c Nbd)" THEN - MAP_EVERY EXISTS_TAC [`c:B`; `b + &1`] THEN - REWRITE_TAC[SUBSET; IN_IMAGE; IN_MCBALL] THEN - INTRO_TAC "![y]; (@x. y x)" THEN REMOVE_THEN "y" SUBST1_TAC THEN - HYP SIMP_TAC "x gwd c" [] THEN TRANS_TAC REAL_LE_TRANS - `mdist m (c:B, f (N:num) (x:A)) + mdist m (f N x, g x)` THEN - HYP SIMP_TAC "c fwd gwd x" [MDIST_TRIANGLE] THEN - MATCH_MP_TAC REAL_LE_ADD2 THEN CONJ_TAC THENL - [REMOVE_THEN "Nbd" MATCH_MP_TAC THEN REWRITE_TAC[IN_IMAGE] THEN - HYP MESON_TAC "x" []; - REFUTE_THEN (LABEL_TAC "contra" o REWRITE_RULE[REAL_NOT_LE])] THEN - CLAIM_TAC "@a. a1 a2" - `?a. &1 < a /\ a < mdist m (f (N:num) (x:A), g x:B)` THENL - [EXISTS_TAC `(&1 + mdist m (f (N:num) (x:A), g x:B)) / &2` THEN - REMOVE_THEN "contra" MP_TAC THEN REAL_ARITH_TAC; - USE_THEN "x" (HYP_TAC "glim" o C MATCH_MP)] THEN - REMOVE_THEN "glim" (MP_TAC o REWRITE_RULE[LIMIT_METRIC_SEQUENTIALLY]) THEN - HYP SIMP_TAC "gwd x" [] THEN DISCH_THEN (MP_TAC o SPEC `a - &1`) THEN - ANTS_TAC THENL [REMOVE_THEN "a1" MP_TAC THEN REAL_ARITH_TAC; ALL_TAC] THEN - HYP SIMP_TAC "fwd x" [] THEN INTRO_TAC "@N'. N'" THEN - CUT_TAC `mdist m (f (N:num) (x:A), g x:B) < a` THENL - [REMOVE_THEN "a2" MP_TAC THEN REAL_ARITH_TAC; ALL_TAC] THEN - TRANS_TAC REAL_LET_TRANS - `mdist m (f N (x:A),f (MAX N N') x:B) + mdist m (f (MAX N N') x,g x)` THEN - HYP SIMP_TAC "fwd gwd x" [MDIST_TRIANGLE] THEN - SUBST1_TAC (REAL_ARITH `a = &1 + (a - &1)`) THEN - MATCH_MP_TAC REAL_LT_ADD2 THEN CONJ_TAC THENL - [ALL_TAC; REMOVE_THEN "N'" MATCH_MP_TAC THEN ARITH_TAC] THEN - TRANS_TAC REAL_LET_TRANS - `sup {mdist m (f N x:B,f (MAX N N') x) | x:A IN s}` THEN - CONJ_TAC THENL - [HYP SIMP_TAC "sup x" []; REMOVE_THEN "N" MATCH_MP_TAC THEN ARITH_TAC]; - ALL_TAC] THEN - INTRO_TAC "!e; e" THEN REMOVE_THEN "unif" (MP_TAC o SPEC `e / &2`) THEN - HYP REWRITE_TAC "e" [REAL_HALF] THEN INTRO_TAC "@N. N" THEN - EXISTS_TAC `N:num` THEN INTRO_TAC "!n; n" THEN - TRANS_TAC REAL_LET_TRANS `e / &2` THEN CONJ_TAC THENL - [ALL_TAC; REMOVE_THEN "e" MP_TAC THEN REAL_ARITH_TAC] THEN - MATCH_MP_TAC REAL_SUP_LE THEN REWRITE_TAC[IN_ELIM_THM] THEN CONJ_TAC THENL - [HYP SET_TAC "nempty" []; HYP MESON_TAC "N n" [REAL_LT_IMP_LE]]);; + [DISJ1_TAC THEN MATCH_MP_TAC COMPLETELY_METRIZABLE_SPACE_CLOSED_IN THEN + REWRITE_TAC[COMPLETELY_METRIZABLE_SPACE_EUCLIDEANREAL] THEN + REWRITE_TAC[GSYM REAL_CLOSED_IN; REAL_CLOSED_REAL_INTERVAL]; + REPEAT STRIP_TAC THEN MATCH_MP_TAC CLOSED_IN_SUBSET_TOPSPACE THEN + ASM_SIMP_TAC[GSYM REAL_CLOSED_IN] THEN ASM SET_TAC[]]);; (* ------------------------------------------------------------------------- *) -(* Metric space of continuous bounded functions. *) +(* Size bounds on connected or path-connected spaces. *) (* ------------------------------------------------------------------------- *) -let cfunspace = new_definition - `cfunspace top m = - submetric (funspace (topspace top) m) - {f:A->B | continuous_map (top,mtopology m) f}`;; +let CONNECTED_SPACE_IMP_CARD_GE_ALT = prove + (`!top s:A->bool. + connected_space top /\ completely_regular_space top /\ + closed_in top s /\ ~(s = {}) /\ ~(s = topspace top) + ==> (:real) <=_c topspace top`, + REPEAT STRIP_TAC THEN + FIRST_ASSUM(ASSUME_TAC o MATCH_MP CLOSED_IN_SUBSET) THEN + SUBGOAL_THEN `?a:A. a IN topspace top /\ ~(a IN s)` STRIP_ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + TRANS_TAC CARD_LE_TRANS `real_interval[&0,&1]` THEN CONJ_TAC THENL + [MATCH_MP_TAC CARD_EQ_IMP_LE THEN ONCE_REWRITE_TAC[CARD_EQ_SYM] THEN + MATCH_MP_TAC CARD_EQ_REAL_SUBSET THEN + MAP_EVERY EXISTS_TAC [`&0:real`; `&1:real`] THEN + ASM_SIMP_TAC[IN_REAL_INTERVAL; REAL_LT_01; REAL_LT_IMP_LE]; + ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [completely_regular_space]) THEN + DISCH_THEN(MP_TAC o SPECL [`s:A->bool`; `a:A`]) THEN + ASM_REWRITE_TAC[LE_C; IN_DIFF; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `f:A->real` THEN STRIP_TAC THEN + X_GEN_TAC `t:real` THEN REWRITE_TAC[IN_REAL_INTERVAL] THEN STRIP_TAC THEN + ONCE_REWRITE_TAC[EQ_SYM_EQ] THEN ONCE_REWRITE_TAC[CONJ_SYM] THEN + FIRST_ASSUM + (MP_TAC o SPEC `topspace top:A->bool` o MATCH_MP (REWRITE_RULE[IMP_CONJ] + CONNECTED_IN_CONTINUOUS_MAP_IMAGE)) THEN + ASM_REWRITE_TAC[CONNECTED_IN_TOPSPACE] THEN + REWRITE_TAC[CONNECTED_IN_EUCLIDEANREAL; is_realinterval] THEN + REWRITE_TAC[IN_IMAGE] THEN DISCH_THEN MATCH_MP_TAC THEN + MAP_EVERY EXISTS_TAC [`&0:real`; `&1:real`] THEN + REPEAT(FIRST_X_ASSUM(ASSUME_TAC o MATCH_MP CLOSED_IN_SUBSET)) THEN + ASM SET_TAC[]);; -let CFUNSPACE = (REWRITE_RULE[GSYM FORALL_AND_THM] o prove) - (`(!top m. - mspace (cfunspace top m) = - {f:A->B | (!x. x IN topspace top ==> f x IN mspace m) /\ - f IN EXTENSIONAL (topspace top) /\ - mbounded m (IMAGE f (topspace top)) /\ - continuous_map (top,mtopology m) f}) /\ - (!f g:A->B. - mdist (cfunspace top m) (f,g) = - if topspace top = {} then &0 else - sup {mdist m (f x,g x) | x IN topspace top})`, - REWRITE_TAC[cfunspace; SUBMETRIC; FUNSPACE] THEN SET_TAC[]);; +let CONNECTED_SPACE_IMP_CARD_GE_GEN = prove + (`!top s t:A->bool. + connected_space top /\ normal_space top /\ + closed_in top s /\ closed_in top t /\ + ~(s = {}) /\ ~(t = {}) /\ DISJOINT s t + ==> (:real) <=_c topspace top`, + REPEAT STRIP_TAC THEN + TRANS_TAC CARD_LE_TRANS `real_interval[&0,&1]` THEN CONJ_TAC THENL + [MATCH_MP_TAC CARD_EQ_IMP_LE THEN ONCE_REWRITE_TAC[CARD_EQ_SYM] THEN + MATCH_MP_TAC CARD_EQ_REAL_SUBSET THEN + MAP_EVERY EXISTS_TAC [`&0:real`; `&1:real`] THEN + ASM_SIMP_TAC[IN_REAL_INTERVAL; REAL_LT_01; REAL_LT_IMP_LE]; + ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [NORMAL_SPACE_EQ_URYSOHN]) THEN + DISCH_THEN(MP_TAC o SPECL [`s:A->bool`; `t:A->bool`]) THEN + ASM_REWRITE_TAC[LE_C; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `f:A->real` THEN STRIP_TAC THEN + X_GEN_TAC `t:real` THEN REWRITE_TAC[IN_REAL_INTERVAL] THEN STRIP_TAC THEN + ONCE_REWRITE_TAC[EQ_SYM_EQ] THEN ONCE_REWRITE_TAC[CONJ_SYM] THEN + FIRST_ASSUM + (MP_TAC o SPEC `topspace top:A->bool` o MATCH_MP (REWRITE_RULE[IMP_CONJ] + CONNECTED_IN_CONTINUOUS_MAP_IMAGE)) THEN + ASM_REWRITE_TAC[CONNECTED_IN_TOPSPACE] THEN + REWRITE_TAC[CONNECTED_IN_EUCLIDEANREAL; is_realinterval] THEN + REWRITE_TAC[IN_IMAGE] THEN DISCH_THEN MATCH_MP_TAC THEN + MAP_EVERY EXISTS_TAC [`&0:real`; `&1:real`] THEN + REPEAT(FIRST_X_ASSUM(ASSUME_TAC o MATCH_MP CLOSED_IN_SUBSET)) THEN + ASM SET_TAC[]);; -let CFUNSPACE_SUBSET_FUNSPACE = prove - (`!top:A topology m:B metric. - mspace (cfunspace top m) SUBSET mspace (funspace (topspace top) m)`, - SIMP_TAC[SUBSET; FUNSPACE; CFUNSPACE; IN_ELIM_THM]);; +let CONNECTED_SPACE_IMP_CARD_GE = prove + (`!top:A topology. + connected_space top /\ normal_space top /\ + (t1_space top \/ hausdorff_space top) /\ + ~(?a. topspace top SUBSET {a}) + ==> (:real) <=_c topspace top`, + GEN_TAC THEN REWRITE_TAC[T1_OR_HAUSDORFF_SPACE] THEN STRIP_TAC THEN + MATCH_MP_TAC CONNECTED_SPACE_IMP_CARD_GE_ALT THEN + FIRST_X_ASSUM(MP_TAC o MATCH_MP (SET_RULE + `~(?a. s SUBSET {a}) ==> ?a b. a IN s /\ b IN s /\ ~(a = b)`)) THEN + REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`a:A`; `b:A`] THEN STRIP_TAC THEN + EXISTS_TAC `{a:A}` THEN + ASM_SIMP_TAC[NORMAL_IMP_COMPLETELY_REGULAR_SPACE_GEN] THEN + CONJ_TAC THENL [ASM_MESON_TAC[T1_SPACE_CLOSED_IN_SING]; ASM SET_TAC[]]);; -let MDIST_CFUNSPACE_EQ_MDIST_FUNSPACE = prove - (`!top m f g:A->B. - mdist (cfunspace top m) (f,g) = mdist (funspace (topspace top) m) (f,g)`, - REWRITE_TAC[FUNSPACE; CFUNSPACE]);; +let CONNECTED_SPACE_IMP_INFINITE_GEN = prove + (`!top:A topology. + connected_space top /\ t1_space top /\ + ~(?a. topspace top SUBSET {a}) + ==> INFINITE(topspace top)`, + REPEAT STRIP_TAC THEN MATCH_MP_TAC INFINITE_PERFECT_SET_GEN THEN + EXISTS_TAC `top:A topology` THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN + MATCH_MP_TAC CONNECTED_IN_IMP_PERFECT_GEN THEN + ASM_REWRITE_TAC[CONNECTED_IN_TOPSPACE] THEN ASM SET_TAC[]);; -let CFUNSPACE_MDIST_LE = prove - (`!top m f g:A->B a. - ~(topspace top = {}) /\ - f IN mspace (cfunspace top m) /\ - g IN mspace (cfunspace top m) - ==> (mdist (cfunspace top m) (f,g) <= a <=> - !x. x IN topspace top ==> mdist m (f x, g x) <= a)`, - INTRO_TAC "! *; ne f g" THEN - REWRITE_TAC[MDIST_CFUNSPACE_EQ_MDIST_FUNSPACE] THEN - MATCH_MP_TAC FUNSPACE_MDIST_LE THEN - ASM_SIMP_TAC[REWRITE_RULE[SUBSET] CFUNSPACE_SUBSET_FUNSPACE]);; +let CONNECTED_SPACE_IMP_INFINITE = prove + (`!top:A topology. + connected_space top /\ hausdorff_space top /\ + ~(?a. topspace top SUBSET {a}) + ==> INFINITE(topspace top)`, + MESON_TAC[CONNECTED_SPACE_IMP_INFINITE_GEN; HAUSDORFF_IMP_T1_SPACE]);; + +let CONNECTED_SPACE_IMP_INFINITE_ALT = prove + (`!top s:A->bool. + connected_space top /\ regular_space top /\ + closed_in top s /\ ~(s = {}) /\ ~(s = topspace top) + ==> INFINITE(topspace top)`, + REPEAT STRIP_TAC THEN + FIRST_ASSUM(ASSUME_TAC o MATCH_MP CLOSED_IN_SUBSET) THEN + SUBGOAL_THEN `?a:A. a IN topspace top /\ ~(a IN s)` STRIP_ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `?u. (!n. DISJOINT (u n) s /\ (a:A) IN u n /\ open_in top (u n)) /\ + (!n. u(SUC n) PSUBSET u n)` + STRIP_ASSUME_TAC THENL + [MATCH_MP_TAC DEPENDENT_CHOICE THEN CONJ_TAC THENL + [EXISTS_TAC `topspace top DIFF s:A->bool` THEN + ASM_SIMP_TAC[IN_DIFF; OPEN_IN_DIFF; OPEN_IN_TOPSPACE] THEN + SET_TAC[]; + ALL_TAC] THEN + MAP_EVERY X_GEN_TAC [`n:num`; `v:A->bool`] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [GSYM NEIGHBOURHOOD_BASE_OF_CLOSED_IN]) THEN + REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN + DISCH_THEN(MP_TAC o SPECL [`v:A->bool`; `a:A`]) THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC MONO_EXISTS THEN + X_GEN_TAC `u:A->bool` THEN + DISCH_THEN(X_CHOOSE_THEN `c:A->bool` STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN + ASM_CASES_TAC `c:A->bool = u` THENL + [FIRST_X_ASSUM SUBST_ALL_TAC; ASM SET_TAC[]] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `u:A->bool` o + GEN_REWRITE_RULE I [CONNECTED_SPACE_CLOPEN_IN]) THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + SUBGOAL_THEN `!n. ?x:A. x IN u n /\ ~(x IN u(SUC n))` MP_TAC THENL + [ASM SET_TAC[]; REWRITE_TAC[SKOLEM_THM]] THEN + REWRITE_TAC[INFINITE_CARD_LE; le_c; IN_UNIV; FORALL_AND_THM] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `f:num->A` THEN STRIP_TAC THEN + CONJ_TAC THENL [ASM_MESON_TAC[SUBSET; OPEN_IN_SUBSET]; ALL_TAC] THEN + MATCH_MP_TAC WLOG_LT THEN + SUBGOAL_THEN `!m n. m < n ==> ~((f:num->A) m IN u n)` MP_TAC THENL + [X_GEN_TAC `m:num`; ASM SET_TAC[]] THEN + REWRITE_TAC[GSYM LE_SUC_LT] THEN + SUBGOAL_THEN `!m n. m <= n ==> (u:num->A->bool) n SUBSET u m` + MP_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN + MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN ASM SET_TAC[]]);; -let CFUNSPACE_IMP_BOUNDED2 = prove - (`!top m f g:A->B. - f IN mspace (cfunspace top m) /\ g IN mspace (cfunspace top m) - ==> (?b. !x. x IN topspace top ==> mdist m (f x,g x) <= b)`, - REPEAT STRIP_TAC THEN MATCH_MP_TAC FUNSPACE_IMP_BOUNDED2 THEN - ASM SET_TAC [CFUNSPACE_SUBSET_FUNSPACE]);; +let PATH_CONNECTED_SPACE_IMP_CARD_GE = prove + (`!top:A topology. + path_connected_space top /\ hausdorff_space top /\ + ~(?a. topspace top SUBSET {a}) + ==> (:real) <=_c topspace top`, + REPEAT STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o MATCH_MP (SET_RULE + `~(?a. s SUBSET {a}) ==> ?a b. a IN s /\ b IN s /\ ~(a = b)`)) THEN + REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`a:A`; `b:A`] THEN STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o SPECL [`a:A`; `b:A`] o + REWRITE_RULE[path_connected_space]) THEN + ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `g:real->A` THEN STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o MATCH_MP CARD_LE_SUBSET o + MATCH_MP PATH_IMAGE_SUBSET_TOPSPACE) THEN + MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ] CARD_LE_TRANS) THEN + MP_TAC(ISPEC + `subtopology (top:A topology) + (IMAGE g (topspace (subtopology euclideanreal (real_interval [&0,&1]))))` + CONNECTED_SPACE_IMP_CARD_GE) THEN + FIRST_ASSUM(MP_TAC o MATCH_MP PATH_IMAGE_SUBSET_TOPSPACE) THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; TOPSPACE_EUCLIDEANREAL; INTER_UNIV] THEN + SIMP_TAC[SET_RULE `s SUBSET u ==> u INTER s = s`] THEN + DISCH_TAC THEN DISCH_THEN MATCH_MP_TAC THEN + ASM_SIMP_TAC[HAUSDORFF_SPACE_SUBTOPOLOGY] THEN + ASM_SIMP_TAC[CONNECTED_SPACE_SUBTOPOLOGY; CONNECTED_IN_PATH_IMAGE] THEN + CONJ_TAC THENL + [MATCH_MP_TAC COMPACT_HAUSDORFF_OR_REGULAR_IMP_NORMAL_SPACE THEN + ASM_SIMP_TAC[HAUSDORFF_SPACE_SUBTOPOLOGY] THEN + ASM_SIMP_TAC[COMPACT_IN_PATH_IMAGE; COMPACT_SPACE_SUBTOPOLOGY]; + MP_TAC ENDS_IN_UNIT_REAL_INTERVAL THEN ASM SET_TAC[]]);; -let CFUNSPACE_MDIST_LT = prove - (`!top m f g:A->B a x. - compact_in top (topspace top) /\ - f IN mspace (cfunspace top m) /\ g IN mspace (cfunspace top m) /\ - mdist (cfunspace top m) (f, g) < a /\ - x IN topspace top - ==> mdist m (f x, g x) < a`, - REPEAT GEN_TAC THEN ASM_CASES_TAC `topspace (top:A topology) = {}` THEN - ASM_REWRITE_TAC[NOT_IN_EMPTY] THEN INTRO_TAC "cpt f g lt x" THEN - REMOVE_THEN "lt" MP_TAC THEN ASM_REWRITE_TAC[CFUNSPACE] THEN - INTRO_TAC "lt" THEN - TRANS_TAC REAL_LET_TRANS - `sup {mdist m (f x:B,g x) | x:A IN topspace top}` THEN - HYP SIMP_TAC "lt" [] THEN MATCH_MP_TAC REAL_LE_SUP THEN - HYP (DESTRUCT_TAC "@b. b" o - MATCH_MP CFUNSPACE_IMP_BOUNDED2 o CONJ_LIST) "f g" [] THEN - MAP_EVERY EXISTS_TAC [`b:real`; `mdist m (f (x:A):B,g x)`] THEN - REWRITE_TAC[IN_ELIM_THM; REAL_LE_REFL] THEN HYP MESON_TAC "x b" []);; +let CONNECTED_SPACE_IMP_UNCOUNTABLE = prove + (`!top:A topology. + connected_space top /\ regular_space top /\ hausdorff_space top /\ + ~(?a. topspace top SUBSET {a}) + ==> ~COUNTABLE(topspace top)`, + REPEAT STRIP_TAC THEN + MP_TAC(ISPEC `top:A topology` CONNECTED_SPACE_IMP_CARD_GE) THEN + ASM_SIMP_TAC[NOT_IMP; CARD_NOT_LE; COUNTABLE_IMP_CARD_LT_REAL] THEN + MATCH_MP_TAC REGULAR_LINDELOF_IMP_NORMAL_SPACE THEN + ASM_SIMP_TAC[COUNTABLE_IMP_LINDELOF_SPACE]);; -let MDIST_CFUNSPACE_LE = prove - (`!top m B f g. - &0 <= B /\ - (!x:A. x IN topspace top ==> mdist m (f x:B, g x) <= B) - ==> mdist (cfunspace top m) (f,g) <= B`, - INTRO_TAC "!top m B f g; Bpos bound" THEN - REWRITE_TAC[CFUNSPACE] THEN COND_CASES_TAC THEN - HYP REWRITE_TAC "Bpos" [] THEN MATCH_MP_TAC REAL_SUP_LE THEN - CONJ_TAC THENL - [POP_ASSUM MP_TAC THEN SET_TAC[]; - REWRITE_TAC[IN_ELIM_THM] THEN HYP MESON_TAC "bound" []]);; +let PATH_CONNECTED_SPACE_IMP_UNCOUNTABLE = prove + (`!top:A topology. + path_connected_space top /\ t1_space top /\ + ~(?a. topspace top SUBSET {a}) + ==> ~COUNTABLE(topspace top)`, + REPEAT STRIP_TAC THEN FIRST_X_ASSUM(MP_TAC o MATCH_MP (SET_RULE + `~(?a. s SUBSET {a}) ==> ?a b. a IN s /\ b IN s /\ ~(a = b)`)) THEN + REWRITE_TAC[NOT_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`a:A`; `b:A`] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`a:A`; `b:A`] o + REWRITE_RULE[path_connected_space]) THEN + ASM_REWRITE_TAC[NOT_EXISTS_THM; path_in] THEN + X_GEN_TAC `g:real->A` THEN STRIP_TAC THEN + MP_TAC(ISPECL + [`&0:real`; `&1:real`; + `{{x | x IN topspace(subtopology euclideanreal (real_interval[&0,&1])) /\ + (g:real->A) x IN {a}} | + a IN topspace top} DELETE {}`] REAL_SIERPINSKI_LEMMA) THEN + ASM_SIMP_TAC[SIMPLE_IMAGE; COUNTABLE_IMAGE; COUNTABLE_DELETE] THEN + REWRITE_TAC[IMP_CONJ; FORALL_IN_IMAGE; IN_DELETE] THEN + REWRITE_TAC[REAL_POS; NOT_IMP] THEN REPEAT CONJ_TAC THENL + [MATCH_MP_TAC(MATCH_MP (REWRITE_RULE[IMP_CONJ_ALT] PAIRWISE_MONO) + (SET_RULE `s DELETE a SUBSET s`)) THEN + REWRITE_TAC[PAIRWISE_IMAGE] THEN REWRITE_TAC[pairwise] THEN SET_TAC[]; + X_GEN_TAC `x:A` THEN REWRITE_TAC[IMP_IMP] THEN + STRIP_TAC THEN ASM_REWRITE_TAC[REAL_CLOSED_IN] THEN + MATCH_MP_TAC CLOSED_IN_TRANS_FULL THEN + EXISTS_TAC `real_interval[&0,&1]` THEN + REWRITE_TAC[GSYM REAL_CLOSED_IN; REAL_CLOSED_REAL_INTERVAL] THEN + FIRST_ASSUM(MATCH_MP_TAC o MATCH_MP (REWRITE_RULE[IMP_CONJ] + CLOSED_IN_CONTINUOUS_MAP_PREIMAGE)) THEN + ASM_MESON_TAC[T1_SPACE_CLOSED_IN_SING]; + FIRST_ASSUM(MP_TAC o MATCH_MP CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE) THEN + REWRITE_TAC[UNIONS_IMAGE; TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN + REWRITE_TAC[UNIONS_DELETE_EMPTY; UNIONS_IMAGE] THEN ASM SET_TAC[]; + MATCH_MP_TAC(SET_RULE + `!a b. a IN s /\ b IN s /\ ~(f a = z) /\ ~(f b = z) /\ ~(f a = f b) + ==> ~(IMAGE f s DELETE z = {c})`) THEN + MAP_EVERY EXISTS_TAC [`a:A`; `b:A`] THEN + ASM_REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN + MATCH_MP_TAC(SET_RULE `(p /\ q ==> r) /\ p /\ q ==> p /\ q /\ r`) THEN + CONJ_TAC THENL [ASM SET_TAC[]; REWRITE_TAC[GSYM MEMBER_NOT_EMPTY]] THEN + CONJ_TAC THENL [EXISTS_TAC `&0:real`; EXISTS_TAC `&1:real`] THEN + ASM_REWRITE_TAC[IN_ELIM_THM; IN_SING] THEN + REWRITE_TAC[ENDS_IN_REAL_INTERVAL; REAL_INTERVAL_NE_EMPTY; REAL_POS]]);; -let MDIST_CFUNSPACE_IMP_MDIST_LE = prove - (`!top m f g:A->B a x. - f IN mspace (cfunspace top m) /\ - g IN mspace (cfunspace top m) /\ - mdist (cfunspace top m) (f,g) <= a /\ - x IN topspace top - ==> mdist m (f x,g x) <= a`, - MESON_TAC[MEMBER_NOT_EMPTY; CFUNSPACE_MDIST_LE]);; +(* ------------------------------------------------------------------------- *) +(* The Tychonoff embedding. *) +(* ------------------------------------------------------------------------- *) -let COMPACT_IN_MSPACE_CFUNSPACE = prove - (`!top m. - compact_in top (topspace top) - ==> mspace (cfunspace top m) = - {f | (!x:A. x IN topspace top ==> f x:B IN mspace m) /\ - f IN EXTENSIONAL (topspace top) /\ - continuous_map (top,mtopology m) f}`, - REWRITE_TAC[CFUNSPACE; EXTENSION; IN_ELIM_THM] THEN REPEAT STRIP_TAC THEN - EQ_TAC THEN SIMP_TAC[] THEN INTRO_TAC "wd ext cont" THEN - MATCH_MP_TAC COMPACT_IN_IMP_MBOUNDED THEN - MATCH_MP_TAC (ISPEC `top:A topology` IMAGE_COMPACT_IN) THEN - ASM_REWRITE_TAC[]);; +let COMPLETELY_REGULAR_SPACE_CUBE_EMBEDDING_EXPLICIT = prove + (`!top:A topology. + completely_regular_space top /\ hausdorff_space top + ==> embedding_map + (top, + product_topology + (mspace (submetric (cfunspace top real_euclidean_metric) + {f | IMAGE f (topspace top) SUBSET real_interval [&0,&1]})) + (\f. subtopology euclideanreal (real_interval [&0,&1]))) + (\x. RESTRICTION + (mspace (submetric (cfunspace top real_euclidean_metric) + {f | IMAGE f (topspace top) SUBSET real_interval [&0,&1]})) + (\f. f x))`, + REPEAT STRIP_TAC THEN + MAP_EVERY ABBREV_TAC + [`k = mspace(submetric (cfunspace top real_euclidean_metric) + {f | IMAGE f (topspace top:A->bool) SUBSET + real_interval[&0,&1]})`; + `e = \x. RESTRICTION k (\f:A->real. f x)`] THEN + SUBGOAL_THEN + `!x y. x IN topspace top /\ y IN topspace top + ==> ((e:A->(A->real)->real) x = e y <=> x = y)` + ASSUME_TAC THENL + [MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN + EQ_TAC THEN SIMP_TAC[] THEN GEN_REWRITE_TAC I [GSYM CONTRAPOS_THM] THEN + DISCH_TAC THEN EXPAND_TAC "e" THEN REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [completely_regular_space]) THEN + DISCH_THEN(MP_TAC o SPECL [`{x:A}`; `y:A`]) THEN + ASM_SIMP_TAC[IN_DIFF; IN_SING; CLOSED_IN_HAUSDORFF_SING] THEN + REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; FORALL_UNWIND_THM2] THEN + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `f:A->real`THEN REWRITE_TAC[IN_REAL_INTERVAL] THEN STRIP_TAC THEN + DISCH_THEN(MP_TAC o C AP_THM `RESTRICTION(topspace top) (f:A->real)`) THEN + ASM_REWRITE_TAC[RESTRICTION] THEN COND_CASES_TAC THEN + ASM_REWRITE_TAC[] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN + FIRST_X_ASSUM(MP_TAC o check (is_neg o concl)) THEN + EXPAND_TAC "k" THEN REWRITE_TAC[SUBMETRIC] THEN + SIMP_TAC[CFUNSPACE; IN_ELIM_THM; IN_INTER; RESTRICTION_IN_EXTENSIONAL] THEN + REWRITE_TAC[REAL_EUCLIDEAN_METRIC; IN_UNIV] THEN + SIMP_TAC[IMAGE_RESTRICTION; RESTRICTION_CONTINUOUS_MAP; SUBSET_REFL] THEN + ASM_REWRITE_TAC[MTOPOLOGY_REAL_EUCLIDEAN_METRIC] THEN + ASM_SIMP_TAC[SUBSET; FORALL_IN_IMAGE; IN_REAL_INTERVAL] THEN + REWRITE_TAC[MBOUNDED_REAL_EUCLIDEAN_METRIC; real_bounded] THEN + EXISTS_TAC `&1` THEN REWRITE_TAC[FORALL_IN_IMAGE] THEN + ASM_SIMP_TAC[real_abs]; + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM INJECTIVE_ON_ALT])] THEN + REWRITE_TAC[INJECTIVE_ON_LEFT_INVERSE] THEN + DISCH_THEN(X_CHOOSE_TAC `e':((A->real)->real)->A`) THEN + REWRITE_TAC[embedding_map; HOMEOMORPHIC_MAP_MAPS] THEN + EXISTS_TAC `e':((A->real)->real)->A` THEN + ASM_REWRITE_TAC[homeomorphic_maps; TOPSPACE_SUBTOPOLOGY] THEN + ASM_SIMP_TAC[IN_INTER; IMP_CONJ_ALT; FORALL_IN_IMAGE] THEN CONJ_TAC THENL + [REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET_REFL] THEN + REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE; SUBSET; FORALL_IN_IMAGE] THEN + EXPAND_TAC "e" THEN REWRITE_TAC[RESTRICTION_IN_EXTENSIONAL] THEN + X_GEN_TAC `f:A->real` THEN SIMP_TAC[RESTRICTION] THEN EXPAND_TAC "k" THEN + REWRITE_TAC[SUBMETRIC; CFUNSPACE; IN_ELIM_THM] THEN + SIMP_TAC[IN_ELIM_THM; CONTINUOUS_MAP_IN_SUBTOPOLOGY; ETA_AX; IN_INTER; + MTOPOLOGY_REAL_EUCLIDEAN_METRIC]; + ALL_TAC] THEN + REWRITE_TAC[CONTINUOUS_MAP_ATPOINTOF; TOPSPACE_SUBTOPOLOGY] THEN + REWRITE_TAC[IN_INTER; IMP_CONJ_ALT; FORALL_IN_IMAGE] THEN + X_GEN_TAC `x:A` THEN ASM_SIMP_TAC[] THEN REPEAT DISCH_TAC THEN + ASM_REWRITE_TAC[LIMIT_ATPOINTOF] THEN DISCH_THEN(K ALL_TAC) THEN + X_GEN_TAC `u:A->bool` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`topspace top DIFF u:A->bool`; `x:A`] o + GEN_REWRITE_RULE I [completely_regular_space]) THEN + ASM_SIMP_TAC[CLOSED_IN_DIFF; CLOSED_IN_TOPSPACE; IN_DIFF] THEN + DISCH_THEN(X_CHOOSE_THEN `g:A->real` STRIP_ASSUME_TAC) THEN + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY_ALT; EXISTS_IN_GSPEC] THEN + EXISTS_TAC + `cartesian_product (k:(A->real)->bool) + (\f. if f = RESTRICTION (topspace top) g + then real_interval[&0,&1] DELETE &1 + else real_interval[&0,&1])` THEN + REWRITE_TAC[OPEN_IN_CARTESIAN_PRODUCT_GEN] THEN + REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN + REPEAT(CONJ_TAC ORELSE DISJ2_TAC) THENL + [MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `{RESTRICTION (topspace top) (g:A->real)}` THEN + REWRITE_TAC[FINITE_SING; SUBSET; IN_ELIM_THM; IN_SING] THEN MESON_TAC[]; + REPEAT STRIP_TAC THEN COND_CASES_TAC THEN ASM_REWRITE_TAC[] THEN + TRY(MATCH_MP_TAC OPEN_IN_HAUSDORFF_DELETE) THEN + ASM_SIMP_TAC[HAUSDORFF_SPACE_SUBTOPOLOGY; + HAUSDORFF_SPACE_EUCLIDEANREAL] THEN + MESON_TAC[OPEN_IN_TOPSPACE; TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY]; + ASM_SIMP_TAC[IN_INTER; FUN_IN_IMAGE] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE RAND_CONV + [TOPSPACE_PRODUCT_TOPOLOGY]) THEN + REWRITE_TAC[cartesian_product; IN_ELIM_THM; o_THM; + TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN + REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[] THEN COND_CASES_TAC THEN + ASM_SIMP_TAC[IN_DELETE] THEN FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP + (REAL_ARITH `y = &0 ==> x = y ==> ~(x = &1)`)) THEN + FIRST_X_ASSUM SUBST_ALL_TAC THEN EXPAND_TAC "e" THEN + REWRITE_TAC[RESTRICTION] THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_DELETE; IN_INTER; IMP_CONJ] THEN + X_GEN_TAC `y:A` THEN ASM_SIMP_TAC[] THEN DISCH_TAC THEN + REWRITE_TAC[cartesian_product; IN_ELIM_THM] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPEC `RESTRICTION (topspace top) (g:A->real)`)) THEN + REWRITE_TAC[] THEN EXPAND_TAC "e" THEN REWRITE_TAC[] THEN + SIMP_TAC[RESTRICTION] THEN ASM_REWRITE_TAC[IN_DELETE] THEN + ANTS_TAC THENL [EXPAND_TAC "k"; ASM_MESON_TAC[]] THEN + REWRITE_TAC[SUBMETRIC; CFUNSPACE; IN_ELIM_THM; IN_INTER] THEN + REWRITE_TAC[RESTRICTION_IN_EXTENSIONAL] THEN + RULE_ASSUM_TAC(REWRITE_RULE[CONTINUOUS_MAP_IN_SUBTOPOLOGY]) THEN + SIMP_TAC[RESTRICTION_CONTINUOUS_MAP; SUBSET_REFL] THEN + ASM_SIMP_TAC[IMAGE_RESTRICTION; SUBSET_REFL] THEN + ASM_REWRITE_TAC[REAL_EUCLIDEAN_METRIC; MTOPOLOGY_REAL_EUCLIDEAN_METRIC; + IN_UNIV] THEN + MATCH_MP_TAC MBOUNDED_SUBSET THEN EXISTS_TAC `real_interval[&0,&1]` THEN + ASM_REWRITE_TAC[MBOUNDED_REAL_EUCLIDEAN_METRIC; + REAL_BOUNDED_REAL_INTERVAL]]);; -let MCOMPLETE_CFUNSPACE = prove - (`!top:A topology m:B metric. mcomplete m ==> mcomplete (cfunspace top m)`, - INTRO_TAC "!top m; cpl" THEN REWRITE_TAC[cfunspace] THEN - MATCH_MP_TAC SEQUENTIALLY_CLOSED_IN_MCOMPLETE_IMP_MCOMPLETE THEN - ASM_SIMP_TAC[MCOMPLETE_FUNSPACE] THEN - REWRITE_TAC[IN_ELIM_THM; LIMIT_METRIC_SEQUENTIALLY] THEN - INTRO_TAC "![f] [g]; fcont g lim" THEN - ASM_CASES_TAC `topspace top = {}:A->bool` THENL - [ASM_REWRITE_TAC[continuous_map; NOT_IN_EMPTY; EMPTY_GSPEC; OPEN_IN_EMPTY]; - POP_ASSUM (LABEL_TAC "nempty")] THEN - REWRITE_TAC[CONTINUOUS_MAP_TO_METRIC; IN_MBALL] THEN - INTRO_TAC "!x; x; ![e]; e" THEN CLAIM_TAC "e3pos" `&0 < e / &3` THENL - [REMOVE_THEN "e" MP_TAC THEN REAL_ARITH_TAC; - USE_THEN "e3pos" (HYP_TAC "lim: @N. N" o C MATCH_MP)] THEN - HYP_TAC "N: f lt" (C MATCH_MP (SPEC `N:num` LE_REFL)) THEN - HYP_TAC "fcont" (REWRITE_RULE[CONTINUOUS_MAP_TO_METRIC]) THEN - USE_THEN "x" (HYP_TAC "fcont" o C MATCH_MP) THEN - USE_THEN "e3pos" (HYP_TAC "fcont" o C MATCH_MP) THEN - HYP_TAC "fcont: @u. u x' inc" (SPEC `N:num`) THEN EXISTS_TAC `u:A->bool` THEN - HYP REWRITE_TAC "u x'" [] THEN INTRO_TAC "!y; y'" THEN - CLAIM_TAC "uinc" `!x:A. x IN u ==> x IN topspace top` THENL - [REMOVE_THEN "u" (MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN SET_TAC[]; - ALL_TAC] THEN - HYP_TAC "g -> gwd gext gbd" (REWRITE_RULE[FUNSPACE; IN_ELIM_THM]) THEN - HYP_TAC "f -> fwd fext fbd" (REWRITE_RULE[FUNSPACE; IN_ELIM_THM]) THEN - CLAIM_TAC "y" `y:A IN topspace top` THENL - [HYP SIMP_TAC "uinc y'" [OPEN_IN_SUBSET]; HYP SIMP_TAC "gwd x y" []] THEN - CLAIM_TAC "sup" `!x0:A. x0 IN topspace top - ==> mdist m (f (N:num) x0:B,g x0) <= e / &3` THENL - [INTRO_TAC "!x0; x0" THEN TRANS_TAC REAL_LE_TRANS - `sup {mdist m (f (N:num) x,g x:B) | x:A IN topspace top}` THEN - CONJ_TAC THENL - [MATCH_MP_TAC REAL_LE_SUP THEN HYP (DESTRUCT_TAC "@b. b" o - MATCH_MP FUNSPACE_IMP_BOUNDED2 o CONJ_LIST) "f g" [] THEN - MAP_EVERY EXISTS_TAC [`b:real`; `mdist m (f (N:num) (x0:A), g x0:B)`] THEN - REWRITE_TAC[IN_ELIM_THM; REAL_LE_REFL] THEN - CONJ_TAC THENL [HYP SET_TAC "x0" []; HYP MESON_TAC "b" []]; - REMOVE_THEN "lt" MP_TAC THEN HYP REWRITE_TAC "nempty" [FUNSPACE] THEN - MATCH_ACCEPT_TAC REAL_LT_IMP_LE]; - ALL_TAC] THEN - TRANS_TAC REAL_LET_TRANS - `mdist m (g (x:A):B, f (N:num) x) + mdist m (f N x, g y)` THEN - HYP SIMP_TAC "gwd fwd x y" [MDIST_TRIANGLE] THEN - SUBST1_TAC (ARITH_RULE `e = e / &3 + (e / &3 + e / &3)`) THEN - MATCH_MP_TAC REAL_LET_ADD2 THEN HYP SIMP_TAC "gwd fwd x sup" [MDIST_SYM] THEN - TRANS_TAC REAL_LET_TRANS - `mdist m (f (N:num) (x:A):B, f N y) + mdist m (f N y, g y)` THEN - HYP SIMP_TAC "fwd gwd x y" [MDIST_TRIANGLE] THEN - MATCH_MP_TAC REAL_LTE_ADD2 THEN HYP SIMP_TAC "gwd fwd y sup" [] THEN - REMOVE_THEN "inc" MP_TAC THEN HYP SIMP_TAC "fwd x y' uinc" [IN_MBALL]);; +let COMPLETELY_REGULAR_SPACE_CUBE_EMBEDDING = prove + (`!top:A topology. + completely_regular_space top /\ hausdorff_space top + ==> ?k:((A->real)->bool) e. + embedding_map + (top, + product_topology k + (\f. subtopology euclideanreal (real_interval[&0,&1]))) + e`, + REPEAT GEN_TAC THEN DISCH_THEN(MP_TAC o MATCH_MP + COMPLETELY_REGULAR_SPACE_CUBE_EMBEDDING_EXPLICIT) THEN + MESON_TAC[]);; (* ------------------------------------------------------------------------- *) -(* Existence of completion for any metric space M as a subspace of M->R. *) +(* Urysohn and Tietze analogs for completely regular spaces if (one) set is *) +(* assumed compact instead of closed. Note that Hausdorffness is *not* *) +(* required: inside one proof we factor through the Kolmogorov quotient. *) (* ------------------------------------------------------------------------- *) -let METRIC_COMPLETION_EXPLICIT = prove - (`!m:A metric. ?s f:A->A->real. - s SUBSET mspace(funspace (mspace m) real_euclidean_metric) /\ - mcomplete(submetric (funspace (mspace m) real_euclidean_metric) s) /\ - IMAGE f (mspace m) SUBSET s /\ - mtopology(funspace (mspace m) real_euclidean_metric) closure_of - IMAGE f (mspace m) = s /\ - !x y. x IN mspace m /\ y IN mspace m - ==> mdist (funspace (mspace m) real_euclidean_metric) (f x,f y) = - mdist m (x,y)`, - GEN_TAC THEN - ABBREV_TAC `m' = funspace (mspace m:A->bool) real_euclidean_metric` THEN - ASM_CASES_TAC `mspace m:A->bool = {}` THENL - [EXISTS_TAC `{}:(A->real)->bool` THEN - ASM_REWRITE_TAC[NOT_IN_EMPTY; IMAGE_CLAUSES; CLOSURE_OF_EMPTY; - EMPTY_SUBSET; INTER_EMPTY; mcomplete; CAUCHY_IN_SUBMETRIC]; - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY])] THEN - DISCH_THEN(X_CHOOSE_TAC `a:A`) THEN - ABBREV_TAC - `f:A->A->real = - \x. RESTRICTION (mspace m) (\u. mdist m (x,u) - mdist m (a,u))` THEN - EXISTS_TAC `mtopology(funspace (mspace m) real_euclidean_metric) closure_of - IMAGE (f:A->A->real) (mspace m)` THEN - EXISTS_TAC `f:A->A->real` THEN - EXPAND_TAC "m'" THEN - SUBGOAL_THEN `IMAGE (f:A->A->real) (mspace m) SUBSET mspace m'` - ASSUME_TAC THENL - [EXPAND_TAC "m'" THEN REWRITE_TAC[SUBSET; FUNSPACE] THEN - REWRITE_TAC[FORALL_IN_IMAGE; IN_ELIM_THM; EXTENSIONAL] THEN - REWRITE_TAC[REAL_EUCLIDEAN_METRIC; IN_UNIV; mbounded; mcball] THEN - X_GEN_TAC `b:A` THEN DISCH_TAC THEN - EXPAND_TAC "f" THEN SIMP_TAC[RESTRICTION; SUBSET; FORALL_IN_IMAGE] THEN - MAP_EVERY EXISTS_TAC [`&0:real`; `mdist m (a:A,b)`] THEN - REWRITE_TAC[IN_ELIM_THM; REAL_SUB_RZERO] THEN - MAP_EVERY UNDISCH_TAC [`(a:A) IN mspace m`; `(b:A) IN mspace m`] THEN - CONV_TAC METRIC_ARITH; +let URYSOHN_COMPLETELY_REGULAR_CLOSED_COMPACT = prove + (`!top s (t:A->bool) a b. + a <= b /\ completely_regular_space top /\ + closed_in top s /\ compact_in top t /\ DISJOINT s t + ==> ?f. continuous_map + (top,subtopology euclideanreal (real_interval[a,b])) f /\ + (!x. x IN t ==> f x = a) /\ + (!x. x IN s ==> f x = b)`, + REPEAT STRIP_TAC THEN + SUBGOAL_THEN + `?f. continuous_map + (top,subtopology euclideanreal (real_interval[&0,&1])) f /\ + (!x. x IN t ==> f x = &0) /\ + (!x:A. x IN s ==> f x = &1)` + MP_TAC THENL + [ALL_TAC; + REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET] THEN + REWRITE_TAC[FORALL_IN_IMAGE; IN_REAL_INTERVAL; LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `f:A->real` THEN STRIP_TAC THEN + EXISTS_TAC `\x. a + (b - a) * (f:A->real) x` THEN + ASM_SIMP_TAC[] THEN CONJ_TAC THENL [ALL_TAC; REAL_ARITH_TAC] THEN + ASM_SIMP_TAC[CONTINUOUS_MAP_REAL_ADD; CONTINUOUS_MAP_REAL_LMUL; + CONTINUOUS_MAP_CONST; TOPSPACE_EUCLIDEANREAL; IN_UNIV] THEN + REWRITE_TAC[IN_REAL_INTERVAL; REAL_LE_ADDR] THEN + REWRITE_TAC[REAL_ARITH + `a + (b - a) * y <= b <=> &0 <= (b - a) * (&1 - y)`] THEN + ASM_SIMP_TAC[REAL_LE_MUL; REAL_SUB_LE]] THEN + ASM_CASES_TAC `t:A->bool = {}` THENL + [EXISTS_TAC `(\x. &1):A->real` THEN + ASM_REWRITE_TAC[CONTINUOUS_MAP_CONST; NOT_IN_EMPTY] THEN + REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY; IN_REAL_INTERVAL] THEN + CONV_TAC REAL_RAT_REDUCE_CONV; ALL_TAC] THEN - REWRITE_TAC[SUBMETRIC] THEN ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL - [REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY] THEN - REWRITE_TAC[CLOSURE_OF_SUBSET_TOPSPACE]; - MATCH_MP_TAC CLOSED_IN_MCOMPLETE_IMP_MCOMPLETE THEN - REWRITE_TAC[CLOSED_IN_CLOSURE_OF] THEN EXPAND_TAC "m'" THEN - MATCH_MP_TAC MCOMPLETE_FUNSPACE THEN - REWRITE_TAC[MCOMPLETE_REAL_EUCLIDEAN_METRIC]; - MATCH_MP_TAC CLOSURE_OF_SUBSET THEN - ASM_REWRITE_TAC[TOPSPACE_MTOPOLOGY]; - MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN - EXPAND_TAC "m'" THEN REWRITE_TAC[FUNSPACE] THEN - COND_CASES_TAC THENL [ASM_MESON_TAC[NOT_IN_EMPTY]; ALL_TAC] THEN - MATCH_MP_TAC SUP_UNIQUE THEN SIMP_TAC[FORALL_IN_GSPEC] THEN - X_GEN_TAC `b:real` THEN REWRITE_TAC[REAL_EUCLIDEAN_METRIC] THEN - EXPAND_TAC "f" THEN REWRITE_TAC[RESTRICTION] THEN EQ_TAC THENL - [DISCH_THEN(fun th -> MP_TAC(SPEC `x:A` th)) THEN EXPAND_TAC "f" THEN - ASM_SIMP_TAC[MDIST_REFL; MDIST_SYM] THEN REAL_ARITH_TAC; - MAP_EVERY UNDISCH_TAC [`(x:A) IN mspace m`; `(y:A) IN mspace m`] THEN - CONV_TAC METRIC_ARITH]]);; + SUBGOAL_THEN + `!a. a IN t + ==> ?f. continuous_map + (top,subtopology euclideanreal (real_interval[&0,&1])) f /\ + f a = &0 /\ !x. x IN s ==> (f:A->real) x = &1` + MP_TAC THENL + [REPEAT STRIP_TAC THEN + FIRST_X_ASSUM(MATCH_MP_TAC o REWRITE_RULE[completely_regular_space]) THEN + FIRST_ASSUM(MP_TAC o MATCH_MP COMPACT_IN_SUBSET_TOPSPACE) THEN + ASM SET_TAC[]; + GEN_REWRITE_TAC (LAND_CONV o BINDER_CONV) [RIGHT_IMP_EXISTS_THM]] THEN + REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `g:A->A->real` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [compact_in]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC + `{{x | x IN topspace top /\ (g:A->A->real) a x IN {t | t < &1 / &2}} | + a IN t}`)) THEN + REWRITE_TAC[SIMPLE_IMAGE; EXISTS_FINITE_SUBSET_IMAGE; FORALL_IN_IMAGE] THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [X_GEN_TAC `a:A` THEN DISCH_TAC THEN + MATCH_MP_TAC OPEN_IN_CONTINUOUS_MAP_PREIMAGE THEN + EXISTS_TAC `euclideanreal` THEN REWRITE_TAC[GSYM REAL_OPEN_IN] THEN + RULE_ASSUM_TAC(REWRITE_RULE[CONTINUOUS_MAP_IN_SUBTOPOLOGY]) THEN + ASM_SIMP_TAC[REAL_OPEN_HALFSPACE_LT; ETA_AX]; + MATCH_MP_TAC(SET_RULE + `(!a. a IN s ==> a IN f a) ==> s SUBSET UNIONS(IMAGE f s)`) THEN + ASM_SIMP_TAC[IN_ELIM_THM] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN + ASM SET_TAC[]]; + DISCH_THEN(X_CHOOSE_THEN `k:A->bool` MP_TAC)] THEN + ASM_CASES_TAC `k:A->bool = {}` THEN + ASM_REWRITE_TAC[IMAGE_CLAUSES; UNIONS_0; SUBSET_EMPTY] THEN STRIP_TAC THEN + EXISTS_TAC + `\x. &2 * max (&0) (inf {(g:A->A->real) a x | a IN k} - &1 / &2)` THEN + REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET; FORALL_IN_IMAGE] THEN + REWRITE_TAC[REAL_ARITH `&2 * max (&0) (x - &1 / &2) = &0 <=> x <= &1 / &2`; + REAL_ARITH `&2 * max (&0) (x - &1 / &2) = &1 <=> x = &1`] THEN + RULE_ASSUM_TAC(REWRITE_RULE[CONTINUOUS_MAP_IN_SUBTOPOLOGY]) THEN + REWRITE_TAC[IN_REAL_INTERVAL] THEN + REWRITE_TAC[REAL_ARITH `&0 <= &2 * max (&0) a`; + REAL_ARITH `&2 * max (&0) (x - &1 / &2) <= &1 <=> x <= &1`] THEN + REWRITE_TAC[GSYM CONJ_ASSOC] THEN CONJ_TAC THENL + [MATCH_MP_TAC CONTINUOUS_MAP_REAL_LMUL THEN + MATCH_MP_TAC CONTINUOUS_MAP_REAL_MAX THEN + REWRITE_TAC[CONTINUOUS_MAP_CONST; TOPSPACE_EUCLIDEANREAL; IN_UNIV] THEN + MATCH_MP_TAC CONTINUOUS_MAP_REAL_SUB THEN + REWRITE_TAC[CONTINUOUS_MAP_CONST; TOPSPACE_EUCLIDEANREAL; IN_UNIV] THEN + MATCH_MP_TAC CONTINUOUS_MAP_INF THEN REWRITE_TAC[ETA_AX] THEN + ASM SET_TAC[]; + ALL_TAC] THEN + MATCH_MP_TAC(TAUT `p /\ (p ==> q) ==> p /\ q`) THEN CONJ_TAC THENL + [X_GEN_TAC `x:A` THEN DISCH_TAC THEN + MATCH_MP_TAC REAL_INF_LE THEN REWRITE_TAC[EXISTS_IN_GSPEC] THEN + EXISTS_TAC `&0` THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `a:A` THEN + RULE_ASSUM_TAC(REWRITE_RULE[CONTINUOUS_MAP_IN_SUBTOPOLOGY; + SUBSET; FORALL_IN_IMAGE; IN_REAL_INTERVAL]) THEN + ASM SET_TAC[]; + DISCH_TAC] THEN + CONJ_TAC THEN X_GEN_TAC `x:A` THEN DISCH_TAC THENL + [MATCH_MP_TAC REAL_INF_LE THEN REWRITE_TAC[EXISTS_IN_GSPEC] THEN + EXISTS_TAC `&0`; + REWRITE_TAC[GSYM REAL_LE_ANTISYM] THEN CONJ_TAC THENL + [ASM_MESON_TAC[SUBSET; CLOSED_IN_SUBSET]; ALL_TAC] THEN + MATCH_MP_TAC REAL_LE_INF THEN + ASM_REWRITE_TAC[SIMPLE_IMAGE; IMAGE_EQ_EMPTY; FORALL_IN_IMAGE]] THEN + RULE_ASSUM_TAC(REWRITE_RULE[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET; + FORALL_IN_IMAGE; IN_REAL_INTERVAL; UNIONS_IMAGE; IN_ELIM_THM]) THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN + ASM_MESON_TAC[REAL_LT_IMP_LE; REAL_LE_REFL]);; + +let URYSOHN_COMPLETELY_REGULAR_COMPACT_CLOSED = prove + (`!top s (t:A->bool) a b. + a <= b /\ completely_regular_space top /\ + compact_in top s /\ closed_in top t /\ DISJOINT s t + ==> ?f. continuous_map + (top,subtopology euclideanreal (real_interval[a,b])) f /\ + (!x. x IN t ==> f x = a) /\ + (!x. x IN s ==> f x = b)`, + REPEAT STRIP_TAC THEN MP_TAC(ISPECL + [`top:A topology`; `t:A->bool`; `s:A->bool`;`--b:real`; `--a:real`] + URYSOHN_COMPLETELY_REGULAR_CLOSED_COMPACT) THEN + ASM_REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET; REAL_LE_NEG2] THEN + ONCE_REWRITE_TAC[DISJOINT_SYM] THEN + ASM_REWRITE_TAC[FORALL_IN_IMAGE; IN_REAL_INTERVAL] THEN + REWRITE_TAC[REAL_ARITH `--b <= x /\ x <= --a <=> a <= --x /\ --x <= b`] THEN + REWRITE_TAC[REAL_ARITH `x:real = --a <=> --x = a`] THEN + DISCH_THEN(X_CHOOSE_THEN `f:A->real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `\x. --((f:A->real) x)` THEN + ASM_REWRITE_TAC[CONTINUOUS_MAP_REAL_NEG_EQ]);; -let METRIC_COMPLETION = prove - (`!m:A metric. - ?m' f:A->A->real. - mcomplete m' /\ - IMAGE f (mspace m) SUBSET mspace m' /\ - (mtopology m') closure_of (IMAGE f (mspace m)) = mspace m' /\ - !x y. x IN mspace m /\ y IN mspace m - ==> mdist m' (f x,f y) = mdist m (x,y)`, - GEN_TAC THEN - MATCH_MP_TAC(MESON[] - `(?s f. P (submetric (funspace (mspace m) real_euclidean_metric) s) f) - ==> ?n f. P n f`) THEN - MP_TAC(SPEC `m:A metric` METRIC_COMPLETION_EXPLICIT) THEN - REPEAT(MATCH_MP_TAC MONO_EXISTS THEN GEN_TAC) THEN - REWRITE_TAC[SUBMETRIC; SUBSET_INTER] THEN - REWRITE_TAC[MTOPOLOGY_SUBMETRIC; CLOSURE_OF_SUBTOPOLOGY] THEN - SIMP_TAC[SET_RULE `t SUBSET s ==> s INTER t = t`] THEN SET_TAC[]);; +let URYSOHN_COMPLETELY_REGULAR_COMPACT_CLOSED_ALT = prove + (`!top s (t:A->bool) a b. + completely_regular_space top /\ + compact_in top s /\ closed_in top t /\ DISJOINT s t + ==> ?f. continuous_map (top,euclideanreal) f /\ + (!x. x IN t ==> f x = a) /\ + (!x. x IN s ==> f x = b)`, + REPEAT STRIP_TAC THEN DISJ_CASES_TAC(REAL_ARITH `a <= b \/ b <= a`) THENL + [MP_TAC(ISPECL + [`top:A topology`; `s:A->bool`; `t:A->bool`; `a:real`; `b:real`] + URYSOHN_COMPLETELY_REGULAR_COMPACT_CLOSED); + MP_TAC(ISPECL + [`top:A topology`; `t:A->bool`; `s:A->bool`; `b:real`; `a:real`] + URYSOHN_COMPLETELY_REGULAR_CLOSED_COMPACT)] THEN + ASM_REWRITE_TAC[] THEN ONCE_REWRITE_TAC[DISJOINT_SYM] THEN + ASM_REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN MESON_TAC[]);; -let METRIZABLE_SPACE_COMPLETION = prove - (`!top:A topology. - metrizable_space top - ==> ?top' (f:A->A->real). - completely_metrizable_space top' /\ - embedding_map(top,top') f /\ - top' closure_of (IMAGE f (topspace top)) = topspace top'`, - REWRITE_TAC[FORALL_METRIZABLE_SPACE; RIGHT_EXISTS_AND_THM] THEN - X_GEN_TAC `m:A metric` THEN - REWRITE_TAC[EXISTS_COMPLETELY_METRIZABLE_SPACE; RIGHT_AND_EXISTS_THM] THEN - MP_TAC(ISPEC `m:A metric` METRIC_COMPLETION) THEN - REPEAT(MATCH_MP_TAC MONO_EXISTS THEN GEN_TAC) THEN - MESON_TAC[ISOMETRY_IMP_EMBEDDING_MAP]);; +let TIETZE_EXTENSION_COMPLETELY_REGULAR = prove + (`!top (f:A->real) s t. + completely_regular_space top /\ + compact_in top s /\ is_realinterval t /\ ~(t = {}) /\ + continuous_map (subtopology top s,euclideanreal) f /\ + (!x. x IN s ==> f x IN t) + ==> ?g. continuous_map (top,euclideanreal) g /\ + (!x. x IN topspace top ==> g x IN t) /\ + (!x. x IN s ==> g x = f x)`, + let lemma = prove + (`!top (f:A->real) s t. + completely_regular_space top /\ hausdorff_space top /\ + compact_in top s /\ is_realinterval t /\ ~(t = {}) /\ + continuous_map (subtopology top s,euclideanreal) f /\ + (!x. x IN s ==> f x IN t) + ==> ?g. continuous_map (top,euclideanreal) g /\ + (!x. x IN topspace top ==> g x IN t) /\ + (!x. x IN s ==> g x = f x)`, + REPEAT STRIP_TAC THEN + MP_TAC(ISPEC `top:A topology` COMPLETELY_REGULAR_SPACE_CUBE_EMBEDDING) THEN + ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`k:((A->real)->bool)`; `e:A->(A->real)->real`] THEN + REWRITE_TAC[embedding_map; HOMEOMORPHIC_MAP_MAPS; LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `e':((A->real)->real)->A` THEN ABBREV_TAC + `cube:((A->real)->real)topology = + product_topology k + (\f. subtopology euclideanreal (real_interval [&0,&1]))` THEN + REWRITE_TAC[homeomorphic_maps] THEN STRIP_TAC THEN + MP_TAC(ISPECL + [`cube:((A->real)->real)topology`; + `(f:A->real) o (e':((A->real)->real)->A)`; + `IMAGE (e:A->(A->real)->real) s`; + `t:real->bool`] TIETZE_EXTENSION_REALINTERVAL) THEN + ASM_SIMP_TAC[FORALL_IN_IMAGE; o_THM] THEN ANTS_TAC THENL + [REPEAT CONJ_TAC THENL + [MATCH_MP_TAC COMPACT_HAUSDORFF_OR_REGULAR_IMP_NORMAL_SPACE THEN + EXPAND_TAC "cube" THEN + REWRITE_TAC[COMPACT_SPACE_PRODUCT_TOPOLOGY; + HAUSDORFF_SPACE_PRODUCT_TOPOLOGY] THEN + SIMP_TAC[HAUSDORFF_SPACE_SUBTOPOLOGY; + HAUSDORFF_SPACE_EUCLIDEANREAL] THEN + SIMP_TAC[COMPACT_IN_EUCLIDEANREAL_INTERVAL; COMPACT_SPACE_SUBTOPOLOGY]; + MATCH_MP_TAC COMPACT_IN_IMP_CLOSED_IN THEN CONJ_TAC THENL + [EXPAND_TAC "cube" THEN + SIMP_TAC[HAUSDORFF_SPACE_PRODUCT_TOPOLOGY; + HAUSDORFF_SPACE_SUBTOPOLOGY; + HAUSDORFF_SPACE_EUCLIDEANREAL]; + MATCH_MP_TAC IMAGE_COMPACT_IN THEN EXISTS_TAC `top:A topology` THEN + ASM_MESON_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY]]; + MATCH_MP_TAC CONTINUOUS_MAP_COMPOSE THEN + EXISTS_TAC `subtopology top (s:A->bool)` THEN + ASM_REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN CONJ_TAC THENL + [FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (REWRITE_RULE[IMP_CONJ] + CONTINUOUS_MAP_FROM_SUBTOPOLOGY_MONO)) THEN + ASM_SIMP_TAC[COMPACT_IN_SUBSET_TOPSPACE; IMAGE_SUBSET]; + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY] THEN + MATCH_MP_TAC(SET_RULE + `(!x. x IN s ==> f(g x) = x) + ==> IMAGE f (u INTER IMAGE g s) SUBSET s`) THEN + FIRST_X_ASSUM(MP_TAC o MATCH_MP COMPACT_IN_SUBSET_TOPSPACE) THEN + ASM SET_TAC[]]; + FIRST_X_ASSUM(MP_TAC o MATCH_MP COMPACT_IN_SUBSET_TOPSPACE) THEN + ASM SET_TAC[]]; + DISCH_THEN(X_CHOOSE_THEN `g:((A->real)->real)->real` + STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(g:((A->real)->real)->real) o (e:A->(A->real)->real)` THEN + CONJ_TAC THENL + [ASM_MESON_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; CONTINUOUS_MAP_COMPOSE]; + REWRITE_TAC[o_THM] THEN + FIRST_X_ASSUM(MP_TAC o MATCH_MP COMPACT_IN_SUBSET_TOPSPACE) THEN + REPEAT(FIRST_X_ASSUM(MP_TAC o MATCH_MP + CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE)) THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY] THEN ASM SET_TAC[]]]) in + REPEAT STRIP_TAC THEN + ABBREV_TAC `q:A->bool = IMAGE (kolmogorov_quotient top) (topspace top)` THEN + MP_TAC(ISPECL + [`top:A topology`; `euclideanreal`; `f:A->real`; `s:A->bool`] + KOLMOGOROV_QUOTIENT_LIFT_EXISTS) THEN + SIMP_TAC[HAUSDORFF_IMP_T0_SPACE; HAUSDORFF_SPACE_EUCLIDEANREAL] THEN + ASM_SIMP_TAC[COMPACT_IN_SUBSET_TOPSPACE; LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `g:A->real` THEN STRIP_TAC THEN + MP_TAC(ISPECL + [`subtopology top (q:A->bool)`; `g:A->real`; + `IMAGE (kolmogorov_quotient top) (s:A->bool)`; + `t:real->bool`] + lemma) THEN + ASM_SIMP_TAC[COMPLETELY_REGULAR_SPACE_SUBTOPOLOGY; FORALL_IN_IMAGE] THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; SUBTOPOLOGY_SUBTOPOLOGY] THEN + EXPAND_TAC "q" THEN REWRITE_TAC[IN_INTER; IMP_CONJ_ALT; FORALL_IN_IMAGE] THEN + ASM_SIMP_TAC[COMPACT_IN_SUBSET_TOPSPACE; SET_RULE + `s SUBSET u ==> IMAGE f u INTER IMAGE f s = IMAGE f s`] THEN + SIMP_TAC[KOLMOGOROV_QUOTIENT_IN_TOPSPACE] THEN + REWRITE_TAC[IMP_IMP] THEN ANTS_TAC THENL + [CONJ_TAC THENL + [MATCH_MP_TAC IMAGE_COMPACT_IN THEN + EXISTS_TAC `top:A topology` THEN + ASM_REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET_REFL] THEN + REWRITE_TAC[CONTINUOUS_MAP_KOLMOGOROV_QUOTIENT]; + MATCH_MP_TAC REGULAR_T0_IMP_HAUSDORFF_SPACE THEN + ASM_SIMP_TAC[REGULAR_SPACE_SUBTOPOLOGY; + COMPLETELY_REGULAR_IMP_REGULAR_SPACE] THEN + EXPAND_TAC "q" THEN REWRITE_TAC[T0_SPACE_KOLMOGOROV_QUOTIENT]]; + DISCH_THEN(X_CHOOSE_THEN `h:A->real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(h:A->real) o kolmogorov_quotient top` THEN + ASM_REWRITE_TAC[o_THM] THEN MATCH_MP_TAC CONTINUOUS_MAP_COMPOSE THEN + EXISTS_TAC `subtopology top (q:A->bool)` THEN + ASM_REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET_REFL] THEN + REWRITE_TAC[CONTINUOUS_MAP_KOLMOGOROV_QUOTIENT]]);; (* ------------------------------------------------------------------------- *) -(* The Baire Category Theorem *) +(* Embedding in products and hence more about completely metrizable spaces. *) (* ------------------------------------------------------------------------- *) -let METRIC_BAIRE_CATEGORY = prove - (`!m:A metric g. - mcomplete m /\ - COUNTABLE g /\ - (!t. t IN g ==> open_in (mtopology m) t /\ - mtopology m closure_of t = mspace m) - ==> mtopology m closure_of INTERS g = mspace m`, - REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN INTRO_TAC "!m; m" THEN - REWRITE_TAC[FORALL_COUNTABLE_AS_IMAGE; NOT_IN_EMPTY; CLOSURE_OF_UNIV; - INTERS_0; TOPSPACE_MTOPOLOGY; FORALL_IN_IMAGE; IN_UNIV; FORALL_AND_THM] THEN - INTRO_TAC "![u]; u_open u_dense" THEN - REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY] THEN - REWRITE_TAC[DENSE_INTERSECTS_OPEN] THEN - INTRO_TAC "![w]; w_open w_ne" THEN - REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN - CLAIM_TAC "@x0. x0" `?x0:A. x0 IN u 0 INTER w` THENL - [REWRITE_TAC[MEMBER_NOT_EMPTY] THEN - ASM_MESON_TAC[DENSE_INTERSECTS_OPEN; TOPSPACE_MTOPOLOGY]; - ALL_TAC] THEN - CLAIM_TAC "@r0. r0pos r0lt1 sub" - `?r. &0 < r /\ r < &1 /\ mcball m (x0:A,r) SUBSET u 0 INTER w` THENL - [SUBGOAL_THEN `open_in (mtopology m) (u 0 INTER w:A->bool)` MP_TAC THENL - [HYP SIMP_TAC "u_open w_open" [OPEN_IN_INTER]; ALL_TAC] THEN - REWRITE_TAC[OPEN_IN_MTOPOLOGY] THEN INTRO_TAC "u0w hp" THEN - REMOVE_THEN "hp" (MP_TAC o SPEC `x0:A`) THEN - ANTS_TAC THENL [HYP REWRITE_TAC "x0" []; ALL_TAC] THEN - INTRO_TAC "@r. rpos ball" THEN EXISTS_TAC `min r (&1) / &2` THEN - CONJ_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN - CONJ_TAC THENL [REAL_ARITH_TAC; ALL_TAC] THEN - TRANS_TAC SUBSET_TRANS `mball m (x0:A,r)` THEN - HYP REWRITE_TAC "ball" [] THEN - MATCH_MP_TAC MCBALL_SUBSET_MBALL_CONCENTRIC THEN - ASM_REAL_ARITH_TAC; ALL_TAC] THEN - (DESTRUCT_TAC "@b. b0 b1" o prove_general_recursive_function_exists) - `?b:num->(A#real). - b 0 = (x0:A,r0) /\ - (!n. b (SUC n) = - @(x,r). &0 < r /\ r < SND (b n) / &2 /\ x IN mspace m /\ - mcball m (x,r) SUBSET mball m (b n) INTER u n)` THEN - CLAIM_TAC "rmk" - `!n. (\ (x:A,r). &0 < r /\ r < SND (b n) / &2 /\ x IN mspace m /\ - mcball m (x,r) SUBSET mball m (b n) INTER u n) - (b (SUC n))` THENL - [LABEL_INDUCT_TAC THENL - [REMOVE_THEN "b1" (fun b1 -> REWRITE_TAC[b1]) THEN - MATCH_MP_TAC CHOICE_PAIRED_THM THEN - REMOVE_THEN "b0" (fun b0 -> REWRITE_TAC[b0]) THEN - MAP_EVERY EXISTS_TAC [`x0:A`; `r0 / &4`] THEN - CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN - CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN - CONJ_TAC THENL - [CUT_TAC `u 0:A->bool SUBSET mspace m` THENL - [HYP SET_TAC "x0" []; - HYP SIMP_TAC "u_open" [GSYM TOPSPACE_MTOPOLOGY; OPEN_IN_SUBSET]]; - ALL_TAC] THEN - TRANS_TAC SUBSET_TRANS `mball m (x0:A,r0)` THEN CONJ_TAC THENL - [MATCH_MP_TAC MCBALL_SUBSET_MBALL_CONCENTRIC THEN ASM_REAL_ARITH_TAC; - REWRITE_TAC[SUBSET_INTER; SUBSET_REFL] THEN - TRANS_TAC SUBSET_TRANS `mcball m (x0:A,r0)` THEN - REWRITE_TAC [MBALL_SUBSET_MCBALL] THEN HYP SET_TAC "sub" []]; +let GDELTA_HOMEOMORPHIC_SPACE_CLOSED_IN_PRODUCT = prove + (`!top (s:K->A->bool) k. + metrizable_space top /\ (!i. i IN k ==> open_in top(s i)) + ==> ?t. closed_in + (prod_topology top (product_topology k (\i. euclideanreal))) + t /\ + subtopology top (INTERS {s i | i IN k}) homeomorphic_space + subtopology + (prod_topology top (product_topology k (\i. euclideanreal))) + t`, + REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM; FORALL_METRIZABLE_SPACE] THEN + MAP_EVERY X_GEN_TAC [`m:A metric`; `s:K->A->bool`; `k:K->bool`] THEN + DISCH_TAC THEN ASM_CASES_TAC `k:K->bool = {}` THENL + [ASM_REWRITE_TAC[NOT_IN_EMPTY; SET_RULE `{f x |x| F} = {}`] THEN + REWRITE_TAC[INTERS_0; SUBTOPOLOGY_UNIV; + PRODUCT_TOPOLOGY_EMPTY_DISCRETE] THEN + EXISTS_TAC + `(mspace m:A->bool) CROSS {(\x. ARB):K->real}` THEN + REWRITE_TAC[CLOSED_IN_CROSS; CLOSED_IN_MSPACE] THEN + REWRITE_TAC[CLOSED_IN_DISCRETE_TOPOLOGY; SUBSET_REFL] THEN + REWRITE_TAC[SUBTOPOLOGY_CROSS; SUBTOPOLOGY_MSPACE] THEN + MATCH_MP_TAC(CONJUNCT1 HOMEOMORPHIC_SPACE_PROD_TOPOLOGY_SING) THEN + REWRITE_TAC[TOPSPACE_DISCRETE_TOPOLOGY; IN_SING]; + ALL_TAC] THEN + REPEAT STRIP_TAC THEN + SUBGOAL_THEN `!i. i IN k ==> (s:K->A->bool) i SUBSET mspace m` + ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + SUBGOAL_THEN `INTERS {(s:K->A->bool) i | i IN k} SUBSET mspace m` + ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN ABBREV_TAC + `d:K->A->real = + \i. if ~(i IN k) \/ s i = mspace m then \a. &1 + else \a. inf {mdist m (a,x) |x| x IN mspace m DIFF s i}` THEN + SUBGOAL_THEN + `!i. continuous_map (subtopology (mtopology m) (s i),euclideanreal) + ((d:K->A->real) i)` + ASSUME_TAC THENL + [X_GEN_TAC `i:K` THEN EXPAND_TAC "d" THEN REWRITE_TAC[] THEN + COND_CASES_TAC THEN REWRITE_TAC[CONTINUOUS_MAP_REAL_CONST] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [DE_MORGAN_THM]) THEN + ASM_SIMP_TAC[OPEN_IN_SUBSET; IMP_CONJ; GSYM TOPSPACE_MTOPOLOGY; SET_RULE + `s SUBSET u ==> (~(s = u) <=> ~(u DIFF s = {}))`] THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN REPEAT STRIP_TAC THEN + REWRITE_TAC[GSYM MTOPOLOGY_SUBMETRIC; + GSYM MTOPOLOGY_REAL_EUCLIDEAN_METRIC] THEN + MATCH_MP_TAC LIPSCHITZ_CONTINUOUS_IMP_CONTINUOUS_MAP THEN + REWRITE_TAC[lipschitz_continuous_map; REAL_EUCLIDEAN_METRIC] THEN + REWRITE_TAC[SUBSET_UNIV; SUBMETRIC] THEN EXISTS_TAC `&1:real` THEN + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN + REWRITE_TAC[IN_INTER; REAL_MUL_LID] THEN STRIP_TAC THEN + EXPAND_TAC "d" THEN REWRITE_TAC[REAL_ARITH + `abs(x - y) <= d <=> x - d <= y /\ y - d <= x`] THEN + CONJ_TAC THEN + W(MP_TAC o PART_MATCH (lhand o rand) REAL_LE_INF_EQ o snd) THEN + ASM_SIMP_TAC[SIMPLE_IMAGE; IMAGE_EQ_EMPTY; FORALL_IN_IMAGE; IN_DIFF] THEN + (ANTS_TAC THENL [ASM_MESON_TAC[MDIST_POS_LE]; DISCH_THEN SUBST1_TAC]) THEN + X_GEN_TAC `z:A` THEN STRIP_TAC THEN REWRITE_TAC[REAL_LE_SUB_RADD] THENL + [TRANS_TAC REAL_LE_TRANS `mdist m (y:A,z)`; + TRANS_TAC REAL_LE_TRANS `mdist m (x:A,z)`] THEN + (CONJ_TAC THENL + [MATCH_MP_TAC INF_LE_ELEMENT THEN + CONJ_TAC THENL [EXISTS_TAC `&0`; ASM SET_TAC[]] THEN + ASM_SIMP_TAC[FORALL_IN_IMAGE; IN_DIFF; MDIST_POS_LE]; + MAP_EVERY UNDISCH_TAC + [`(x:A) IN mspace m`; `(y:A) IN mspace m`; `(z:A) IN mspace m`] THEN + CONV_TAC METRIC_ARITH]); ALL_TAC] THEN - USE_THEN "b1" (fun b1 -> GEN_REWRITE_TAC RAND_CONV [b1]) THEN - MATCH_MP_TAC CHOICE_PAIRED_THM THEN REWRITE_TAC[] THEN - HYP_TAC "ind_n: rpos rlt x subn" (REWRITE_RULE[LAMBDA_PAIR]) THEN - USE_THEN "u_dense" (MP_TAC o SPEC `SUC n` o - REWRITE_RULE[GSYM TOPSPACE_MTOPOLOGY]) THEN - REWRITE_TAC[DENSE_INTERSECTS_OPEN] THEN - DISCH_THEN (MP_TAC o SPEC `mball m (b (SUC n):A#real)`) THEN - (DESTRUCT_TAC "@x1 r1. bsuc" o MESON[PAIR]) - `?x1:A r1:real. b (SUC n) = x1,r1` THEN - HYP REWRITE_TAC "bsuc" [] THEN - REMOVE_THEN "bsuc" - (fun th -> RULE_ASSUM_TAC (REWRITE_RULE[th]) THEN LABEL_TAC "bsuc" th) THEN - ANTS_TAC THENL - [HYP REWRITE_TAC "x" [OPEN_IN_MBALL; MBALL_EQ_EMPTY; DE_MORGAN_THM] THEN - ASM_REAL_ARITH_TAC; ALL_TAC] THEN - REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN INTRO_TAC "@z. hp" THEN - EXISTS_TAC `z:A` THEN - SUBGOAL_THEN `open_in (mtopology m) (mball m (x1:A,r1) INTER u (SUC n))` - (DESTRUCT_TAC "hp1 hp2" o REWRITE_RULE[OPEN_IN_MTOPOLOGY_MCBALL]) THENL - [HYP SIMP_TAC "u_open" [OPEN_IN_INTER; OPEN_IN_MBALL]; ALL_TAC] THEN - CLAIM_TAC "z" `z:A IN mspace m` THENL - [CUT_TAC `u (SUC n):A->bool SUBSET mspace m` THENL - [HYP SET_TAC "hp" []; - HYP SIMP_TAC "u_open" [GSYM TOPSPACE_MTOPOLOGY; OPEN_IN_SUBSET]]; - HYP REWRITE_TAC "z" []] THEN - REMOVE_THEN "hp2" (MP_TAC o SPEC `z:A`) THEN - ANTS_TAC THENL [HYP SET_TAC "hp" []; ALL_TAC] THEN - INTRO_TAC "@r. rpos ball" THEN EXISTS_TAC `min r (r1 / &4)` THEN - CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN - CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN - TRANS_TAC SUBSET_TRANS `mcball m (z:A,r)` THEN - HYP SIMP_TAC "ball" [MCBALL_SUBSET_CONCENTRIC; REAL_MIN_MIN]; - ALL_TAC] THEN - CLAIM_TAC "@x r. b" `?x r. !n:num. b n = x n:A, r n:real` THENL - [MAP_EVERY EXISTS_TAC - [`FST o (b:num->A#real)`; `SND o (b:num->A#real)`] THEN - REWRITE_TAC[o_DEF]; ALL_TAC] THEN - REMOVE_THEN "b" - (fun b -> RULE_ASSUM_TAC (REWRITE_RULE[b]) THEN LABEL_TAC "b" b) THEN - HYP_TAC "b0: x_0 r_0" (REWRITE_RULE[PAIR_EQ]) THEN - REMOVE_THEN "x_0" (SUBST_ALL_TAC o GSYM) THEN - REMOVE_THEN "r_0" (SUBST_ALL_TAC o GSYM) THEN - HYP_TAC "rmk: r1pos r1lt x1 ball" (REWRITE_RULE[FORALL_AND_THM]) THEN - CLAIM_TAC "x" `!n:num. x n:A IN mspace m` THENL - [LABEL_INDUCT_TAC THENL - [CUT_TAC `u 0:A->bool SUBSET mspace m` THENL - [HYP SET_TAC "x0" []; - HYP SIMP_TAC "u_open" [GSYM TOPSPACE_MTOPOLOGY; OPEN_IN_SUBSET]]; - HYP REWRITE_TAC "x1" []]; - ALL_TAC] THEN - CLAIM_TAC "rpos" `!n:num. &0 < r n` THENL - [LABEL_INDUCT_TAC THENL - [HYP REWRITE_TAC "r0pos" []; HYP REWRITE_TAC "r1pos" []]; - ALL_TAC] THEN - CLAIM_TAC "rmono" `!p q:num. p <= q ==> r q <= r p` THENL - [MATCH_MP_TAC LE_INDUCT THEN REWRITE_TAC[REAL_LE_REFL] THEN - INTRO_TAC "!p q; pq rpq" THEN - REMOVE_THEN "r1lt" (MP_TAC o SPEC `q:num`) THEN - REMOVE_THEN "rpos" (MP_TAC o SPEC `q:num`) THEN - ASM_REAL_ARITH_TAC; - ALL_TAC] THEN - CLAIM_TAC "rlt" `!n:num. r n < inv (&2 pow n)` THENL - [LABEL_INDUCT_TAC THENL - [CONV_TAC (RAND_CONV REAL_RAT_REDUCE_CONV) THEN HYP REWRITE_TAC "r0lt1" []; - TRANS_TAC REAL_LTE_TRANS `r (n:num) / &2` THEN - HYP REWRITE_TAC "r1lt" [real_pow] THEN REMOVE_THEN "ind_n" MP_TAC THEN - REMOVE_THEN "rpos" (MP_TAC o SPEC `n:num`) THEN CONV_TAC REAL_FIELD]; - ALL_TAC] THEN - CLAIM_TAC "nested" - `!p q:num. p <= q ==> mball m (x q:A, r q) SUBSET mball m (x p, r p)` THENL - [MATCH_MP_TAC LE_INDUCT THEN REWRITE_TAC[SUBSET_REFL] THEN - INTRO_TAC "!p q; pq sub" THEN - TRANS_TAC SUBSET_TRANS `mball m (x (q:num):A,r q)` THEN - HYP REWRITE_TAC "sub" [] THEN - TRANS_TAC SUBSET_TRANS `mcball m (x (SUC q):A,r(SUC q))` THEN - REWRITE_TAC[MBALL_SUBSET_MCBALL] THEN HYP SET_TAC "ball" []; - ALL_TAC] THEN - CLAIM_TAC "in_ball" `!p q:num. p <= q ==> x q:A IN mball m (x p, r p)` THENL - [INTRO_TAC "!p q; le" THEN CUT_TAC `x (q:num):A IN mball m (x q, r q)` THENL - [HYP SET_TAC "nested le" []; HYP SIMP_TAC "x rpos" [CENTRE_IN_MBALL_EQ]]; - ALL_TAC] THEN - CLAIM_TAC "@l. l" `?l:A. limit (mtopology m) x l sequentially` THENL - [HYP_TAC "m" (REWRITE_RULE[mcomplete]) THEN REMOVE_THEN "m" MATCH_MP_TAC THEN - HYP REWRITE_TAC "x" [cauchy_in] THEN INTRO_TAC "!e; epos" THEN - CLAIM_TAC "@N. N" `?N. inv(&2 pow N) < e` THENL - [REWRITE_TAC[REAL_INV_POW] THEN MATCH_MP_TAC REAL_ARCH_POW_INV THEN - HYP REWRITE_TAC "epos" [] THEN REAL_ARITH_TAC; + SUBGOAL_THEN `!i x. x IN s i ==> &0 < (d:K->A->real) i x` + ASSUME_TAC THENL + [REPEAT STRIP_TAC THEN EXPAND_TAC "d" THEN REWRITE_TAC[] THEN + COND_CASES_TAC THEN REWRITE_TAC[REAL_LT_01] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [DE_MORGAN_THM]) THEN + ASM_SIMP_TAC[OPEN_IN_SUBSET; IMP_CONJ; GSYM TOPSPACE_MTOPOLOGY; SET_RULE + `s SUBSET u ==> (~(s = u) <=> ~(u DIFF s = {}))`] THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN REPEAT STRIP_TAC THEN + MP_TAC(ISPECL + [`m:A metric`; `(s:K->A->bool) i`] OPEN_IN_MTOPOLOGY) THEN + ASM_SIMP_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[SUBSET; IN_MBALL; LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `r:real` THEN STRIP_TAC THEN + TRANS_TAC REAL_LTE_TRANS `r:real` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC REAL_LE_INF THEN + ASM_REWRITE_TAC[FORALL_IN_GSPEC; GSYM REAL_NOT_LT] THEN + REPEAT(FIRST_X_ASSUM(MP_TAC o SPEC `i:K`) THEN ASM_REWRITE_TAC[]) THEN + REPEAT DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN ASM SET_TAC[]; ALL_TAC] THEN - EXISTS_TAC `N:num` THEN MATCH_MP_TAC WLOG_LE THEN CONJ_TAC THENL - [HYP SIMP_TAC "x" [MDIST_SYM] THEN MESON_TAC[]; ALL_TAC] THEN - INTRO_TAC "!n n'; le; n n'" THEN - TRANS_TAC REAL_LT_TRANS `inv (&2 pow N)` THEN HYP REWRITE_TAC "N" [] THEN - TRANS_TAC REAL_LT_TRANS `r (N:num):real` THEN HYP REWRITE_TAC "rlt" [] THEN - CUT_TAC `x (n':num):A IN mball m (x n, r n)` THENL - [HYP REWRITE_TAC "x" [IN_MBALL] THEN INTRO_TAC "hp" THEN - TRANS_TAC REAL_LTE_TRANS `r (n:num):real` THEN - HYP SIMP_TAC "n rmono hp" []; - HYP SIMP_TAC "in_ball le" []]; - ALL_TAC] THEN - EXISTS_TAC `l:A` THEN - CLAIM_TAC "in_mcball" `!n:num. l:A IN mcball m (x n, r n)` THENL - [GEN_TAC THEN - (MATCH_MP_TAC o ISPECL [`sequentially`; `mtopology (m:A metric)`]) - LIMIT_IN_CLOSED_IN THEN EXISTS_TAC `x:num->A` THEN - HYP REWRITE_TAC "l" [TRIVIAL_LIMIT_SEQUENTIALLY; CLOSED_IN_MCBALL] THEN - REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN EXISTS_TAC `n:num` THEN - INTRO_TAC "![p]; p" THEN CUT_TAC `x (p:num):A IN mball m (x n, r n)` THENL - [SET_TAC[MBALL_SUBSET_MCBALL]; HYP SIMP_TAC "in_ball p" []]; - ALL_TAC] THEN - REWRITE_TAC[IN_INTER] THEN CONJ_TAC THENL - [REWRITE_TAC[IN_INTERS; FORALL_IN_IMAGE; IN_UNIV] THEN - LABEL_INDUCT_TAC THENL - [HYP SET_TAC "in_mcball sub " []; HYP SET_TAC "in_mcball ball " []]; - HYP SET_TAC "sub in_mcball" []]);; + ABBREV_TAC `f = \x. x,RESTRICTION k (\i. inv((d:K->A->real) i x))` THEN + EXISTS_TAC `IMAGE (f:A->A#(K->real)) (INTERS {s(i:K) | i IN k})` THEN + CONJ_TAC THENL + [ALL_TAC; + MP_TAC(snd(EQ_IMP_RULE(ISPECL + [`subtopology (mtopology m) (INTERS {(s:K->A->bool) i | i IN k})`; + `product_topology (k:K->bool) (\i. euclideanreal)`; + `\x. RESTRICTION k (\i. inv((d:K->A->real) i x))`] + EMBEDDING_MAP_GRAPH))) THEN + ASM_REWRITE_TAC[] THEN ANTS_TAC THENL + [REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE; SUBSET; FORALL_IN_IMAGE] THEN + REWRITE_TAC[RESTRICTION_IN_EXTENSIONAL] THEN X_GEN_TAC `i:K` THEN + SIMP_TAC[RESTRICTION] THEN DISCH_TAC THEN + MATCH_MP_TAC CONTINUOUS_MAP_REAL_INV THEN CONJ_TAC THENL + [REWRITE_TAC[ETA_AX] THEN FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP + (REWRITE_RULE[IMP_CONJ] CONTINUOUS_MAP_FROM_SUBTOPOLOGY_MONO) o + SPEC `i:K`) THEN + ASM SET_TAC[]; + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; IN_INTER; INTERS_GSPEC] THEN + ASM_SIMP_TAC[IN_ELIM_THM; REAL_LT_IMP_NZ]]; + DISCH_THEN(MP_TAC o MATCH_MP EMBEDDING_MAP_IMP_HOMEOMORPHIC_SPACE) THEN + MATCH_MP_TAC EQ_IMP THEN AP_TERM_TAC THEN + ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY_SUBSET; TOPSPACE_MTOPOLOGY] THEN + REWRITE_TAC[PROD_TOPOLOGY_SUBTOPOLOGY; SUBTOPOLOGY_SUBTOPOLOGY] THEN + AP_TERM_TAC THEN MATCH_MP_TAC(SET_RULE + `(!x. x IN s ==> f x IN t) ==> t INTER IMAGE f s = IMAGE f s`) THEN + SIMP_TAC[TOPSPACE_PRODUCT_TOPOLOGY; o_DEF; TOPSPACE_EUCLIDEANREAL] THEN + EXPAND_TAC "f" THEN SIMP_TAC[IN_CROSS] THEN + REWRITE_TAC[RESTRICTION_IN_CARTESIAN_PRODUCT; IN_UNIV]]] THEN + REWRITE_TAC[GSYM CLOSURE_OF_SUBSET_EQ] THEN CONJ_TAC THENL + [EXPAND_TAC "f" THEN REWRITE_TAC[SUBSET; FORALL_IN_IMAGE] THEN + REWRITE_TAC[TOPSPACE_PROD_TOPOLOGY; TOPSPACE_PRODUCT_TOPOLOGY] THEN + REWRITE_TAC[o_DEF; TOPSPACE_EUCLIDEANREAL; IN_CROSS] THEN + REWRITE_TAC[RESTRICTION_IN_CARTESIAN_PRODUCT; IN_UNIV] THEN + ASM_REWRITE_TAC[GSYM SUBSET; TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN + GEN_REWRITE_TAC I [SUBSET] THEN REWRITE_TAC[closure_of] THEN + REWRITE_TAC[FORALL_PAIR_THM; IN_ELIM_THM; TOPSPACE_PROD_TOPOLOGY] THEN + MAP_EVERY X_GEN_TAC [`x:A`; `ds:K->real`] THEN + REWRITE_TAC[IN_CROSS; TOPSPACE_MTOPOLOGY; TOPSPACE_PRODUCT_TOPOLOGY] THEN + REWRITE_TAC[o_THM; TOPSPACE_EUCLIDEANREAL; IN_UNIV; cartesian_product] THEN + REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(CONJUNCTS_THEN2 STRIP_ASSUME_TAC MP_TAC) THEN + DISCH_THEN(MP_TAC o GENL [`u:A->bool`; `v:(K->real)->bool`] o + SPEC `(u:A->bool) CROSS (v:(K->real)->bool)`) THEN + REWRITE_TAC[IN_CROSS; OPEN_IN_CROSS; SET_RULE + `(x IN s /\ y IN t) /\ (s = {} \/ t = {} \/ R s t) <=> + x IN s /\ y IN t /\ R s t`] THEN + REWRITE_TAC[EXISTS_IN_IMAGE] THEN DISCH_TAC THEN + SUBGOAL_THEN `x IN INTERS {(s:K->A->bool) i | i IN k}` ASSUME_TAC THENL + [REWRITE_TAC[INTERS_GSPEC; IN_ELIM_THM] THEN + X_GEN_TAC `i:K` THEN DISCH_TAC THEN + GEN_REWRITE_TAC I [TAUT `p <=> ~p ==> F`] THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL + [`mball m (x:A,inv(abs(ds(i:K)) + &1))`; + `{z | z IN topspace(product_topology k (\i. euclideanreal)) /\ + (z:K->real) i IN real_interval(ds i - &1,ds i + &1)}`]) THEN + REWRITE_TAC[IN_ELIM_THM; NOT_IMP] THEN REPEAT CONJ_TAC THENL + [MATCH_MP_TAC CENTRE_IN_MBALL THEN + ASM_REWRITE_TAC[REAL_LT_INV_EQ] THEN REAL_ARITH_TAC; + ASM_REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; TOPSPACE_EUCLIDEANREAL; o_DEF; + cartesian_product; IN_ELIM_THM; IN_UNIV]; + REWRITE_TAC[IN_REAL_INTERVAL] THEN REAL_ARITH_TAC; + REWRITE_TAC[OPEN_IN_MBALL]; + MATCH_MP_TAC OPEN_IN_CONTINUOUS_MAP_PREIMAGE THEN + EXISTS_TAC `euclideanreal` THEN + ASM_SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION] THEN + REWRITE_TAC[GSYM REAL_OPEN_IN; REAL_OPEN_REAL_INTERVAL]; + ALL_TAC] THEN + EXPAND_TAC "f" THEN REWRITE_TAC[INTERS_GSPEC; IN_ELIM_THM] THEN + REWRITE_TAC[NOT_EXISTS_THM; IN_CROSS; IN_ELIM_THM] THEN + X_GEN_TAC `y:A` THEN + DISCH_THEN(CONJUNCTS_THEN2 (MP_TAC o SPEC `i:K`) ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + FIRST_X_ASSUM(CONJUNCTS_THEN MP_TAC) THEN + DISCH_THEN(MP_TAC o CONJUNCT2) THEN ASM_REWRITE_TAC[RESTRICTION] THEN + DISCH_TAC THEN ASM_REWRITE_TAC[IN_MBALL] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + REWRITE_TAC[REAL_NOT_LT] THEN + TRANS_TAC REAL_LE_TRANS `(d:K->A->real) i y` THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_LE_LINV THEN ASM_SIMP_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_REAL_INTERVAL]) THEN + REAL_ARITH_TAC; + EXPAND_TAC "d" THEN REWRITE_TAC[] THEN + COND_CASES_TAC THENL [ASM SET_TAC[]; REWRITE_TAC[]] THEN + MATCH_MP_TAC INF_LE_ELEMENT THEN CONJ_TAC THENL + [EXISTS_TAC `&0` THEN + ASM_SIMP_TAC[FORALL_IN_GSPEC; IN_DIFF; MDIST_POS_LE]; + REWRITE_TAC[IN_ELIM_THM] THEN EXISTS_TAC `x:A` THEN + ASM_REWRITE_TAC[IN_DIFF] THEN ASM_MESON_TAC[MDIST_SYM]]]; + REWRITE_TAC[IN_IMAGE] THEN EXISTS_TAC `x:A` THEN + ASM_REWRITE_TAC[] THEN EXPAND_TAC "f" THEN REWRITE_TAC[PAIR_EQ] THEN + GEN_REWRITE_TAC I [FUN_EQ_THM] THEN X_GEN_TAC `i:K` THEN + REWRITE_TAC[RESTRICTION] THEN + COND_CASES_TAC THENL + [ALL_TAC; + RULE_ASSUM_TAC(REWRITE_RULE[EXTENSIONAL]) THEN ASM SET_TAC[]] THEN + REWRITE_TAC[REAL_ARITH `x = y <=> ~(&0 < abs(x - y))`] THEN DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o + MATCH_MP (REWRITE_RULE[IMP_CONJ] CONTINUOUS_MAP_REAL_INV) o + SPEC `i:K`) THEN + ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY; REAL_LT_IMP_NZ; IN_INTER] THEN + ABBREV_TAC `e = abs (ds i - inv((d:K->A->real) i x))` THEN + REWRITE_TAC[continuous_map] THEN DISCH_THEN(MP_TAC o SPEC + `real_interval(inv((d:K->A->real) i x) - e / &2,inv(d i x) + e / &2)` o + CONJUNCT2) THEN + REWRITE_TAC[GSYM REAL_OPEN_IN; REAL_OPEN_REAL_INTERVAL] THEN + ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY_SUBSET; TOPSPACE_MTOPOLOGY] THEN + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o SPECL + [`u:A->bool`; + `{z | z IN topspace(product_topology k (\i:K. euclideanreal)) /\ + z i IN real_interval(ds i - e / &2,ds i + e / &2)}`]) THEN + ASM_REWRITE_TAC[IN_ELIM_THM; NOT_IMP] THEN REPEAT CONJ_TAC THENL + [FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (SET_RULE + `s = u INTER t ==> x IN s ==> x IN u`)) THEN + REWRITE_TAC[IN_REAL_INTERVAL; IN_ELIM_THM] THEN + CONJ_TAC THENL [ASM SET_TAC[]; ASM_REAL_ARITH_TAC]; + REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; cartesian_product] THEN + ASM_REWRITE_TAC[o_THM; TOPSPACE_EUCLIDEANREAL; IN_UNIV; IN_ELIM_THM]; + REWRITE_TAC[IN_REAL_INTERVAL] THEN ASM_REAL_ARITH_TAC; + MATCH_MP_TAC OPEN_IN_CONTINUOUS_MAP_PREIMAGE THEN + EXISTS_TAC `euclideanreal` THEN + ASM_SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION] THEN + REWRITE_TAC[GSYM REAL_OPEN_IN; REAL_OPEN_REAL_INTERVAL]; + ALL_TAC] THEN + EXPAND_TAC "f" THEN REWRITE_TAC[IN_CROSS; IN_ELIM_THM] THEN + ASM_REWRITE_TAC[RESTRICTION; NOT_EXISTS_THM] THEN X_GEN_TAC `y:A` THEN + GEN_REWRITE_TAC RAND_CONV [CONJ_ASSOC] THEN + DISCH_THEN(CONJUNCTS_THEN2 MP_TAC ASSUME_TAC) THEN + FIRST_ASSUM(MATCH_MP_TAC o MATCH_MP (SET_RULE + `t = u INTER s i + ==> i IN k /\ ~(y IN t) + ==> y IN INTERS {s i | i IN k} /\ y IN u ==> F`)) THEN + ASM_REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(MP_TAC o CONJUNCT2) THEN + FIRST_X_ASSUM(MP_TAC o CONJUNCT2) THEN + REWRITE_TAC[IN_REAL_INTERVAL] THEN + EXPAND_TAC "e" THEN REAL_ARITH_TAC]);; -let METRIC_BAIRE_CATEGORY_ALT = prove - (`!m g:(A->bool)->bool. - mcomplete m /\ - COUNTABLE g /\ - (!t. t IN g - ==> closed_in (mtopology m) t /\ mtopology m interior_of t = {}) - ==> mtopology m interior_of (UNIONS g) = {}`, +let OPEN_HOMEOMORPHIC_SPACE_CLOSED_IN_PRODUCT = prove + (`!top (s:A->bool). + metrizable_space top /\ open_in top s + ==> ?t. closed_in (prod_topology top euclideanreal) t /\ + subtopology top s homeomorphic_space + subtopology (prod_topology top euclideanreal) t`, REPEAT STRIP_TAC THEN - MP_TAC(ISPECL [`m:A metric`; `IMAGE (\u:A->bool. mspace m DIFF u) g`] - METRIC_BAIRE_CATEGORY) THEN - ASM_SIMP_TAC[COUNTABLE_IMAGE; FORALL_IN_IMAGE] THEN - ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_MSPACE] THEN - REWRITE_TAC[CLOSURE_OF_COMPLEMENT; GSYM TOPSPACE_MTOPOLOGY] THEN - ASM_SIMP_TAC[DIFF_EMPTY] THEN REWRITE_TAC[CLOSURE_OF_INTERIOR_OF] THEN - MATCH_MP_TAC(SET_RULE - `s SUBSET u /\ s' = s ==> u DIFF s' = u ==> s = {}`) THEN - REWRITE_TAC[INTERIOR_OF_SUBSET_TOPSPACE] THEN AP_TERM_TAC THEN - REWRITE_TAC[DIFF_INTERS; SET_RULE - `{f y | y IN IMAGE g s} = {f(g x) | x IN s}`] THEN - AP_TERM_TAC THEN MATCH_MP_TAC(SET_RULE - `(!x. x IN s ==> f x = x) ==> {f x | x IN s} = s`) THEN - X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPEC `s:A->bool`) THEN - ASM_REWRITE_TAC[] THEN STRIP_TAC THEN - FIRST_ASSUM(MP_TAC o MATCH_MP CLOSED_IN_SUBSET) THEN SET_TAC[]);; - -let BAIRE_CATEGORY_ALT = prove - (`!top g:(A->bool)->bool. - (completely_metrizable_space top \/ - locally_compact_space top /\ - (hausdorff_space top \/ regular_space top)) /\ - COUNTABLE g /\ - (!t. t IN g ==> closed_in top t /\ top interior_of t = {}) - ==> top interior_of (UNIONS g) = {}`, - REWRITE_TAC[TAUT `(p \/ q) /\ r ==> s <=> - (p ==> r ==> s) /\ (q /\ r ==> s)`] THEN - REWRITE_TAC[FORALL_AND_THM; RIGHT_FORALL_IMP_THM] THEN - REWRITE_TAC[GSYM FORALL_MCOMPLETE_TOPOLOGY] THEN - SIMP_TAC[METRIC_BAIRE_CATEGORY_ALT] THEN REPEAT GEN_TAC THEN - DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC) THEN - FIRST_ASSUM(MP_TAC o MATCH_MP (TAUT `(p \/ q) ==> (p ==> q) ==> q`)) THEN - ANTS_TAC THENL - [ASM_MESON_TAC[LOCALLY_COMPACT_HAUSDORFF_IMP_REGULAR_SPACE]; DISCH_TAC] THEN - ASM_CASES_TAC `g:(A->bool)->bool = {}` THEN - ASM_REWRITE_TAC[UNIONS_0; INTERIOR_OF_EMPTY] THEN - FIRST_X_ASSUM(MP_TAC o MATCH_MP (REWRITE_RULE[IMP_CONJ] - COUNTABLE_AS_IMAGE)) THEN - ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `t:num->A->bool` THEN DISCH_THEN SUBST_ALL_TAC THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [FORALL_IN_IMAGE]) THEN - REWRITE_TAC[IN_UNIV; FORALL_AND_THM] THEN STRIP_TAC THEN - REWRITE_TAC[interior_of; EXTENSION; IN_ELIM_THM; NOT_IN_EMPTY] THEN - X_GEN_TAC `z:A` THEN - DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN - MP_TAC(ISPEC `top:A topology` - LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE_CLOSED_IN) THEN - ASM_REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN - FIRST_ASSUM(MP_TAC o SPEC `z:A` o REWRITE_RULE[SUBSET] o MATCH_MP - OPEN_IN_SUBSET) THEN - ASM_REWRITE_TAC[] THEN DISCH_TAC THEN - DISCH_THEN(MP_TAC o SPECL [`u:A->bool`; `z:A`]) THEN - ASM_REWRITE_TAC[NOT_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`v:A->bool`; `k:A->bool`] THEN STRIP_TAC THEN + MP_TAC(ISPECL [`top:A topology`; `(\x. s):1->A->bool`; `{one}`] + GDELTA_HOMEOMORPHIC_SPACE_CLOSED_IN_PRODUCT) THEN + ASM_REWRITE_TAC[SET_RULE `INTERS {s |i| i IN {a}} = s`] THEN + DISCH_THEN(X_CHOOSE_THEN `t:A#(1->real)->bool` STRIP_ASSUME_TAC) THEN SUBGOAL_THEN - `?c:num->A->bool. - (!n. c n SUBSET k /\ closed_in top (c n) /\ - ~(top interior_of c n = {}) /\ DISJOINT (c n) (t n)) /\ - (!n. c (SUC n) SUBSET c n)` + `prod_topology (top:A topology) (product_topology {one} (\i. euclideanreal)) + homeomorphic_space prod_topology top euclideanreal` MP_TAC THENL - [MATCH_MP_TAC DEPENDENT_CHOICE THEN CONJ_TAC THENL - [FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I - [GSYM NEIGHBOURHOOD_BASE_OF_CLOSED_IN]) THEN - REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN - DISCH_THEN(MP_TAC o SPEC `v DIFF (t:num->A->bool) 0`) THEN - ASM_SIMP_TAC[OPEN_IN_DIFF] THEN - DISCH_THEN(MP_TAC o MATCH_MP MONO_EXISTS) THEN ANTS_TAC THENL - [REWRITE_TAC[SET_RULE `(?x. x IN s DIFF t) <=> ~(s SUBSET t)`] THEN - DISCH_TAC THEN - SUBGOAL_THEN `top interior_of (t:num->A->bool) 0 = {}` MP_TAC THENL - [ASM_REWRITE_TAC[]; REWRITE_TAC[interior_of]] THEN - REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN ASM_MESON_TAC[]; - REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`x:A`; `n:A->bool`; `c:A->bool`] THEN - STRIP_TAC THEN EXISTS_TAC `c:A->bool` THEN - ASM_REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN - REPEAT CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC; ASM SET_TAC[]] THEN - EXISTS_TAC `x:A` THEN REWRITE_TAC[interior_of; IN_ELIM_THM] THEN - ASM_MESON_TAC[]]; - MAP_EVERY X_GEN_TAC [`n:num`; `c:A->bool`] THEN STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I - [GSYM NEIGHBOURHOOD_BASE_OF_CLOSED_IN]) THEN - REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN - DISCH_THEN(MP_TAC o SPEC - `top interior_of c DIFF (t:num->A->bool) (SUC n)`) THEN - ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_INTERIOR_OF] THEN - DISCH_THEN(MP_TAC o MATCH_MP MONO_EXISTS) THEN ANTS_TAC THENL - [REWRITE_TAC[SET_RULE `(?x. x IN s DIFF t) <=> ~(s SUBSET t)`] THEN - DISCH_TAC THEN - SUBGOAL_THEN `top interior_of t(SUC n):A->bool = {}` MP_TAC THENL - [ASM_REWRITE_TAC[]; REWRITE_TAC[interior_of]] THEN - REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN - ASM_MESON_TAC[OPEN_IN_INTERIOR_OF; MEMBER_NOT_EMPTY]; - REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`x:A`; `n:A->bool`; `d:A->bool`] THEN - STRIP_TAC THEN EXISTS_TAC `d:A->bool` THEN - ASM_REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN REPEAT CONJ_TAC THENL - [MP_TAC(ISPECL[`top:A topology`; `c:A->bool`] INTERIOR_OF_SUBSET) THEN - ASM SET_TAC[]; - EXISTS_TAC `x:A` THEN REWRITE_TAC[interior_of; IN_ELIM_THM] THEN - ASM_MESON_TAC[]; - ASM SET_TAC[]; - MP_TAC(ISPECL[`top:A topology`; `c:A->bool`] INTERIOR_OF_SUBSET) THEN - ASM SET_TAC[]]]]; - REWRITE_TAC[NOT_EXISTS_THM; FORALL_AND_THM]] THEN - X_GEN_TAC `c:num->A->bool` THEN STRIP_TAC THEN - MP_TAC(ISPECL [`subtopology top (k:A->bool)`; `c:num->A->bool`] - COMPACT_SPACE_IMP_NEST) THEN - ASM_SIMP_TAC[COMPACT_SPACE_SUBTOPOLOGY; CLOSED_IN_SUBSET_TOPSPACE] THEN - REWRITE_TAC[NOT_IMP] THEN REPEAT CONJ_TAC THENL - [ASM_MESON_TAC[INTERIOR_OF_SUBSET; CLOSED_IN_SUBSET; MEMBER_NOT_EMPTY; - SUBSET]; - MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN ASM SET_TAC[]; - RULE_ASSUM_TAC(REWRITE_RULE[UNIONS_IMAGE; IN_UNIV]) THEN - REWRITE_TAC[INTERS_GSPEC] THEN ASM SET_TAC[]]);; + [MATCH_MP_TAC HOMEOMORPHIC_SPACE_PROD_TOPOLOGY THEN + REWRITE_TAC[HOMEOMORPHIC_SPACE_SINGLETON_PRODUCT; HOMEOMORPHIC_SPACE_REFL]; + REWRITE_TAC[HOMEOMORPHIC_SPACE; LEFT_IMP_EXISTS_THM]] THEN + X_GEN_TAC `f:A#(1->real)->A#real` THEN DISCH_TAC THEN + EXISTS_TAC `IMAGE (f:A#(1->real)->A#real) t` THEN CONJ_TAC THENL + [ASM_MESON_TAC[HOMEOMORPHIC_MAP_CLOSEDNESS_EQ]; ALL_TAC] THEN + REWRITE_TAC[GSYM HOMEOMORPHIC_SPACE] THEN + FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (ONCE_REWRITE_RULE[IMP_CONJ] + HOMEOMORPHIC_SPACE_TRANS)) THEN + REWRITE_TAC[HOMEOMORPHIC_SPACE] THEN EXISTS_TAC `f:A#(1->real)->A#real` THEN + MATCH_MP_TAC HOMEOMORPHIC_MAP_SUBTOPOLOGIES THEN + ASM_REWRITE_TAC[] THEN + RULE_ASSUM_TAC(REWRITE_RULE[HOMEOMORPHIC_EQ_EVERYTHING_MAP]) THEN + FIRST_ASSUM(MP_TAC o MATCH_MP CLOSED_IN_SUBSET) THEN ASM SET_TAC[]);; -let BAIRE_CATEGORY = prove - (`!top g:(A->bool)->bool. - (completely_metrizable_space top \/ - locally_compact_space top /\ - (hausdorff_space top \/ regular_space top)) /\ - COUNTABLE g /\ - (!t. t IN g ==> open_in top t /\ top closure_of t = topspace top) - ==> top closure_of INTERS g = topspace top`, - REPEAT GEN_TAC THEN DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC) THEN - ASM_CASES_TAC `g:(A->bool)->bool = {}` THENL - [ONCE_REWRITE_TAC[CLOSURE_OF_RESTRICT] THEN - ASM_SIMP_TAC[INTERS_0; INTER_UNIV; CLOSURE_OF_TOPSPACE]; +let COMPLETELY_METRIZABLE_SPACE_GDELTA_IN_ALT = prove + (`!top s:A->bool. + completely_metrizable_space top /\ + (COUNTABLE INTERSECTION_OF open_in top) s + ==> completely_metrizable_space (subtopology top s)`, + REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM; FORALL_INTERSECTION_OF] THEN + X_GEN_TAC `top:A topology` THEN DISCH_TAC THEN + X_GEN_TAC `u:(A->bool)->bool` THEN REPEAT DISCH_TAC THEN + REPEAT STRIP_TAC THEN + MP_TAC(ISPECL [`top:A topology`; `(\x:A->bool. x)`; `u:(A->bool)->bool`] + GDELTA_HOMEOMORPHIC_SPACE_CLOSED_IN_PRODUCT) THEN + ASM_SIMP_TAC[COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE; IN_GSPEC] THEN + DISCH_THEN(X_CHOOSE_THEN `c:A#((A->bool)->real)->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(SUBST1_TAC o + MATCH_MP HOMEOMORPHIC_COMPLETELY_METRIZABLE_SPACE) THEN + MATCH_MP_TAC COMPLETELY_METRIZABLE_SPACE_CLOSED_IN THEN + ASM_REWRITE_TAC[COMPLETELY_METRIZABLE_SPACE_PROD_TOPOLOGY] THEN + REWRITE_TAC[COMPLETELY_METRIZABLE_SPACE_EUCLIDEANREAL; + COMPLETELY_METRIZABLE_SPACE_PRODUCT_TOPOLOGY] THEN + ASM_SIMP_TAC[COUNTABLE_RESTRICT]);; + +let COMPLETELY_METRIZABLE_SPACE_GDELTA_IN = prove + (`!top s:A->bool. + completely_metrizable_space top /\ gdelta_in top s + ==> completely_metrizable_space (subtopology top s)`, + SIMP_TAC[GDELTA_IN_ALT; COMPLETELY_METRIZABLE_SPACE_GDELTA_IN_ALT]);; + +let COMPLETELY_METRIZABLE_SPACE_OPEN_IN = prove + (`!top s:A->bool. + completely_metrizable_space top /\ open_in top s + ==> completely_metrizable_space (subtopology top s)`, + SIMP_TAC[COMPLETELY_METRIZABLE_SPACE_GDELTA_IN; OPEN_IMP_GDELTA_IN]);; + +let LOCALLY_COMPACT_IMP_COMPLETELY_METRIZABLE_SPACE = prove + (`!top:A topology. + metrizable_space top /\ locally_compact_space top + ==> completely_metrizable_space top`, + REWRITE_TAC[IMP_CONJ; FORALL_METRIZABLE_SPACE] THEN + X_GEN_TAC `m:A metric` THEN DISCH_TAC THEN + MP_TAC(ISPEC `m:A metric` METRIC_COMPLETION) THEN + REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`m':(A->real)metric`; `f:A->A->real`] THEN + STRIP_TAC THEN + SUBGOAL_THEN + `mtopology m homeomorphic_space + subtopology (mtopology m') (IMAGE (f:A->A->real) (mspace m))` + ASSUME_TAC THENL + [MP_TAC(ISPECL [`m:A metric`; `m':(A->real)metric`; `f:A->A->real`] + ISOMETRY_IMP_EMBEDDING_MAP) THEN + ASM_SIMP_TAC[SUBSET_REFL] THEN + DISCH_THEN(MP_TAC o MATCH_MP EMBEDDING_MAP_IMP_HOMEOMORPHIC_SPACE) THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN - MP_TAC(ISPECL [`top:A topology`; - `IMAGE (\u:A->bool. topspace top DIFF u) g`] - BAIRE_CATEGORY_ALT) THEN - ASM_SIMP_TAC[COUNTABLE_IMAGE; FORALL_IN_IMAGE] THEN - ASM_SIMP_TAC[CLOSED_IN_DIFF; CLOSED_IN_TOPSPACE] THEN - ASM_SIMP_TAC[INTERIOR_OF_COMPLEMENT; DIFF_EQ_EMPTY] THEN - REWRITE_TAC[INTERIOR_OF_CLOSURE_OF] THEN + FIRST_ASSUM(SUBST1_TAC o + MATCH_MP HOMEOMORPHIC_COMPLETELY_METRIZABLE_SPACE) THEN + FIRST_X_ASSUM(MP_TAC o + MATCH_MP HOMEOMORPHIC_LOCALLY_COMPACT_SPACE) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN(MP_TAC o MATCH_MP + (ONCE_REWRITE_RULE[IMP_CONJ_ALT] (REWRITE_RULE[CONJ_ASSOC] + LOCALLY_COMPACT_SUBSPACE_OPEN_IN_CLOSURE_OF))) THEN + ASM_REWRITE_TAC[HAUSDORFF_SPACE_MTOPOLOGY; SUBTOPOLOGY_MSPACE] THEN + ASM_REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN DISCH_TAC THEN + MATCH_MP_TAC COMPLETELY_METRIZABLE_SPACE_OPEN_IN THEN + ASM_SIMP_TAC[COMPLETELY_METRIZABLE_SPACE_MTOPOLOGY]);; + +let COMPLETELY_METRIZABLE_SPACE_IMP_GDELTA_IN = prove + (`!top s:A->bool. + metrizable_space top /\ s SUBSET topspace top /\ + completely_metrizable_space (subtopology top s) + ==> gdelta_in top s`, + REPEAT STRIP_TAC THEN + MP_TAC(ISPECL [`top:A topology`; `s:A->bool`; + `subtopology top s:A topology`; `\x:A. x`] + LAVRENTIEV_EXTENSION) THEN + ASM_REWRITE_TAC[CONTINUOUS_MAP_ID; LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`u:A->bool`; `f:A->A`] THEN STRIP_TAC THEN + SUBGOAL_THEN `s:A->bool = u` (fun th -> ASM_REWRITE_TAC[th]) THEN + ASM_REWRITE_TAC[GSYM SUBSET_ANTISYM_EQ] THEN + FIRST_ASSUM(MP_TAC o MATCH_MP CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE) THEN + ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY_SUBSET; GDELTA_IN_SUBSET] THEN MATCH_MP_TAC(SET_RULE - `s SUBSET u /\ s' = s ==> u DIFF s' = {} ==> s = u`) THEN - REWRITE_TAC[CLOSURE_OF_SUBSET_TOPSPACE] THEN AP_TERM_TAC THEN - REWRITE_TAC[DIFF_UNIONS; SET_RULE - `{f y | y IN IMAGE g s} = {f(g x) | x IN s}`] THEN - MATCH_MP_TAC(SET_RULE `t SUBSET u /\ s = t ==> u INTER s = t`) THEN - CONJ_TAC THENL [ASM_MESON_TAC[INTERS_SUBSET; OPEN_IN_SUBSET]; ALL_TAC] THEN - AP_TERM_TAC THEN MATCH_MP_TAC(SET_RULE - `(!x. x IN s ==> f x = x) ==> {f x | x IN s} = s`) THEN - X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPEC `s:A->bool`) THEN - ASM_REWRITE_TAC[] THEN STRIP_TAC THEN - FIRST_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN SET_TAC[]);; + `(!x. x IN u ==> f x = x) ==> IMAGE f u SUBSET s ==> u SUBSET s`) THEN + MP_TAC(ISPECL + [`subtopology top u:A topology`; `subtopology top u:A topology`; + `f:A->A`; `\x:A. x`] FORALL_IN_CLOSURE_OF_EQ) THEN + ASM_SIMP_TAC[CLOSURE_OF_SUBTOPOLOGY; CONTINUOUS_MAP_ID; SET_RULE + `s SUBSET u ==> u INTER s = s`] THEN + ANTS_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN + ASM_SIMP_TAC[HAUSDORFF_SPACE_SUBTOPOLOGY; + METRIZABLE_IMP_HAUSDORFF_SPACE] THEN + UNDISCH_TAC + `continuous_map (subtopology top u,subtopology top s) (f:A->A)` THEN + SIMP_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN ASM SET_TAC[]);; (* ------------------------------------------------------------------------- *) -(* Sierpinski-Hausdorff type results about countable closed unions. *) +(* Locally compact subspaces of metrizable spaces are G-delta. *) (* ------------------------------------------------------------------------- *) -let LOCALLY_CONNECTED_NOT_COUNTABLE_CLOSED_UNION = prove - (`!top u:(A->bool)->bool. - ~(topspace top = {}) /\ - connected_space top /\ - locally_connected_space top /\ - (completely_metrizable_space top \/ - locally_compact_space top /\ hausdorff_space top) /\ - COUNTABLE u /\ pairwise DISJOINT u /\ - (!c. c IN u ==> closed_in top c /\ ~(c = {})) /\ - UNIONS u = topspace top - ==> u = {topspace top}`, +let LOCALLY_COMPACT_SPACE_IMP_GDELTA_IN = prove + (`!top s:A->bool. + metrizable_space top /\ + s SUBSET topspace top /\ + locally_compact_space(subtopology top s) + ==> gdelta_in top s`, + REPEAT STRIP_TAC THEN + MATCH_MP_TAC COMPLETELY_METRIZABLE_SPACE_IMP_GDELTA_IN THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC LOCALLY_COMPACT_IMP_COMPLETELY_METRIZABLE_SPACE THEN + ASM_SIMP_TAC[METRIZABLE_SPACE_SUBTOPOLOGY]);; + +let COMPLETELY_METRIZABLE_SPACE_EQ_GDELTA_IN = prove + (`!top s:A->bool. + completely_metrizable_space top /\ s SUBSET topspace top + ==> (completely_metrizable_space (subtopology top s) <=> + gdelta_in top s)`, + MESON_TAC[COMPLETELY_METRIZABLE_SPACE_GDELTA_IN; + COMPLETELY_METRIZABLE_SPACE_IMP_GDELTA_IN; + COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE]);; + +let GDELTA_IN_EQ_COMPLETELY_METRIZABLE_SPACE = prove + (`!top s:A->bool. + completely_metrizable_space top + ==> (gdelta_in top s <=> + s SUBSET topspace top /\ + completely_metrizable_space (subtopology top s))`, + MESON_TAC[GDELTA_IN_ALT; COMPLETELY_METRIZABLE_SPACE_EQ_GDELTA_IN]);; + +(* ------------------------------------------------------------------------- *) +(* Paracompact spaces. *) +(* ------------------------------------------------------------------------- *) + +let paracompact_space = new_definition + `paracompact_space (top:A topology) <=> + !U. (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?V. (!v. v IN V ==> open_in top v) /\ + UNIONS V = topspace top /\ + (!v. v IN V ==> ?u. u IN U /\ v SUBSET u) /\ + locally_finite_in top V`;; + +let COMPACT_IMP_PARACOMPACT_SPACE = prove + (`!top:A topology. compact_space top ==> paracompact_space top`, + GEN_TAC THEN REWRITE_TAC[COMPACT_SPACE; paracompact_space] THEN + STRIP_TAC THEN X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `U:(A->bool)->bool`) THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `V:(A->bool)->bool` THEN + STRIP_TAC THEN ASM_SIMP_TAC[FINITE_IMP_LOCALLY_FINITE_IN; SUBSET_REFL] THEN + ASM_MESON_TAC[SUBSET; OPEN_IN_TOPSPACE]);; + +let PARACOMPACT_SPACE_CLOSED_SUBSET = prove + (`!top s:A->bool. + paracompact_space top /\ closed_in top s + ==> paracompact_space(subtopology top s)`, + REPEAT GEN_TAC THEN REWRITE_TAC[paracompact_space] THEN STRIP_TAC THEN + ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY_SUBSET; CLOSED_IN_SUBSET] THEN + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY_ALT; GSYM SUBSET] THEN + ONCE_REWRITE_TAC[SIMPLE_IMAGE_GEN] THEN REWRITE_TAC[EXISTS_SUBSET_IMAGE] THEN + REWRITE_TAC[IMP_CONJ; FORALL_SUBSET_IMAGE] THEN + REWRITE_TAC[FORALL_IN_IMAGE; EXISTS_IN_IMAGE] THEN + REWRITE_TAC[GSYM SIMPLE_IMAGE; GSYM INTER_UNIONS] THEN + REWRITE_TAC[SET_RULE + `(s:A->bool) SUBSET {x | P x} <=> !x. x IN s ==> P x`] THEN + X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + REWRITE_TAC[SET_RULE + `(s:A->bool) INTER t = s <=> s SUBSET t`] THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `(topspace top DIFF s:A->bool) INSERT U`) THEN + ASM_REWRITE_TAC[FORALL_IN_INSERT; EXISTS_IN_INSERT; UNIONS_INSERT] THEN + ANTS_TAC THENL + [ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_TOPSPACE] THEN + RULE_ASSUM_TAC(REWRITE_RULE[OPEN_IN_CLOSED_IN_EQ]) THEN ASM SET_TAC[]; + DISCH_THEN(X_CHOOSE_THEN `V:(A->bool)->bool` STRIP_ASSUME_TAC)] THEN + EXISTS_TAC `{v:A->bool | v IN V /\ ~(v SUBSET topspace top DIFF s)}` THEN + ASM_SIMP_TAC[FORALL_IN_GSPEC] THEN REPEAT CONJ_TAC THENL + [RULE_ASSUM_TAC(REWRITE_RULE[OPEN_IN_CLOSED_IN_EQ]) THEN ASM SET_TAC[]; + ASM SET_TAC[]; + MATCH_MP_TAC LOCALLY_FINITE_IN_SUBTOPOLOGY THEN + REWRITE_TAC[FORALL_IN_GSPEC; INTER_SUBSET] THEN + MATCH_MP_TAC LOCALLY_FINITE_IN_REFINEMENT THEN + REWRITE_TAC[INTER_SUBSET] THEN + FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP + (REWRITE_RULE[IMP_CONJ] LOCALLY_FINITE_IN_SUBSET)) THEN + REWRITE_TAC[SUBSET_RESTRICT]]);; + +let PARACOMPACT_SPACE_RETRACTION_MAP_IMAGE = prove + (`!top top' (r:A->B). + retraction_map(top,top') r /\ paracompact_space top + ==> paracompact_space top'`, + REPEAT GEN_TAC THEN + REWRITE_TAC[paracompact_space; locally_finite_in] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [retraction_map]) THEN + REWRITE_TAC[retraction_maps; LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `s:B->A` THEN STRIP_TAC THEN + X_GEN_TAC `U:(B->bool)->bool` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC + `{{x | x IN topspace top /\ (r:A->B) x IN u} | u IN U}`) THEN + REWRITE_TAC[FORALL_IN_GSPEC; EXISTS_IN_GSPEC] THEN ANTS_TAC THENL + [CONJ_TAC THENL + [ASM_MESON_TAC[OPEN_IN_CONTINUOUS_MAP_PREIMAGE]; ALL_TAC] THEN + REWRITE_TAC[UNIONS_GSPEC] THEN + RULE_ASSUM_TAC(REWRITE_RULE[continuous_map]) THEN ASM SET_TAC[]; + DISCH_THEN(X_CHOOSE_THEN `V:(A->bool)->bool` STRIP_ASSUME_TAC)] THEN + EXISTS_TAC + `{{y | y IN topspace top' /\ (s:B->A) y IN v} | v IN V}` THEN + REWRITE_TAC[FORALL_IN_GSPEC; EXISTS_IN_GSPEC] THEN + REWRITE_TAC[SUBSET_RESTRICT] THEN REPEAT CONJ_TAC THENL + [ASM_MESON_TAC[OPEN_IN_CONTINUOUS_MAP_PREIMAGE]; + REWRITE_TAC[UNIONS_GSPEC] THEN + RULE_ASSUM_TAC(REWRITE_RULE[continuous_map]) THEN ASM SET_TAC[]; + ASM SET_TAC[]; + X_GEN_TAC `y:B` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `(s:B->A) y`) THEN ANTS_TAC THENL + [RULE_ASSUM_TAC(REWRITE_RULE[continuous_map]) THEN ASM SET_TAC[]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `{y | y IN topspace top' /\ (s:B->A) y IN w}` THEN + REPEAT CONJ_TAC THENL + [ASM_MESON_TAC[OPEN_IN_CONTINUOUS_MAP_PREIMAGE]; + ASM SET_TAC[]; + REWRITE_TAC[SET_RULE + `{y:B | y IN {(f:A->B) x | x IN s} /\ P y} = + IMAGE f {x | x IN s /\ P(f x)}`] THEN + MATCH_MP_TAC FINITE_IMAGE THEN FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP + (REWRITE_RULE[IMP_CONJ] FINITE_SUBSET)) THEN + ASM SET_TAC[]]]);; + +let HOMEOMORPHIC_PARACOMPACT_SPACE = prove + (`!(top:A topology) (top':B topology). + top homeomorphic_space top' + ==> (paracompact_space top <=> paracompact_space top')`, + REWRITE_TAC[homeomorphic_space; HOMEOMORPHIC_MAPS_MAP] THEN + REWRITE_TAC[GSYM SECTION_AND_RETRACTION_EQ_HOMEOMORPHIC_MAP] THEN + MESON_TAC[PARACOMPACT_SPACE_RETRACTION_MAP_IMAGE]);; + +let PARACOMPACT_HAUSDORFF_IMP_REGULAR_SPACE, + PARACOMPACT_HAUSDORFF_IMP_NORMAL_SPACE = (CONJ_PAIR o prove) + (`(!top:A topology. + paracompact_space top /\ hausdorff_space top + ==> regular_space top) /\ + (!top:A topology. + paracompact_space top /\ (hausdorff_space top \/ regular_space top) + ==> normal_space top)`, let lemma = prove - (`UNIONS (IMAGE f s UNION IMAGE g s) = - UNIONS (IMAGE (\x. f x UNION g x) s)`, - REWRITE_TAC[UNIONS_UNION; UNIONS_IMAGE] THEN SET_TAC[]) in - REWRITE_TAC[REAL_CLOSED_IN] THEN REPEAT GEN_TAC THEN - DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC) THEN - ABBREV_TAC `v = IMAGE (\c:A->bool. top frontier_of c) u` THEN - ABBREV_TAC `b:A->bool = UNIONS v` THEN - MATCH_MP_TAC(TAUT `(~p ==> F) ==> p`) THEN DISCH_TAC THEN - SUBGOAL_THEN `(b:A->bool) SUBSET topspace top` ASSUME_TAC THENL - [EXPAND_TAC "b" THEN REWRITE_TAC[UNIONS_SUBSET] THEN - EXPAND_TAC "v" THEN REWRITE_TAC[FORALL_IN_IMAGE] THEN - REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY; FRONTIER_OF_SUBSET_TOPSPACE]; - ALL_TAC] THEN - MP_TAC(ISPECL [`subtopology top (b:A->bool)`; `v:(A->bool)->bool`] - BAIRE_CATEGORY_ALT) THEN - ASM_REWRITE_TAC[] THEN EXPAND_TAC "v" THEN REWRITE_TAC[FORALL_IN_IMAGE] THEN - ASM_SIMP_TAC[COUNTABLE_IMAGE; NOT_IMP] THEN CONJ_TAC THENL - [ALL_TAC; - MP_TAC(ISPEC `subtopology top (b:A->bool)` - INTERIOR_OF_TOPSPACE) THEN - REWRITE_TAC[TOPSPACE_SUBTOPOLOGY] THEN - ASM_SIMP_TAC[TOPSPACE_MTOPOLOGY; SET_RULE - `s SUBSET u ==> u INTER s = s`] THEN - DISCH_THEN SUBST1_TAC THEN EXPAND_TAC "b" THEN - EXPAND_TAC "v" THEN MATCH_MP_TAC(SET_RULE - `(!s. s IN u /\ s SUBSET UNIONS u /\ f s = {} ==> s = {}) /\ - ~(UNIONS u = {}) - ==> ~(UNIONS(IMAGE f u) = {})`) THEN - ASM_SIMP_TAC[IMP_CONJ; FRONTIER_OF_EQ_EMPTY; GSYM TOPSPACE_MTOPOLOGY] THEN - ASM_REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN - X_GEN_TAC `s:A->bool` THEN REPEAT STRIP_TAC THEN - FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [CONNECTED_SPACE_CLOPEN_IN]) THEN - DISCH_THEN(MP_TAC o SPEC `s:A->bool`) THEN - ASM_CASES_TAC `s:A->bool = {}` THEN ASM_SIMP_TAC[] THEN - ASM_REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN DISCH_THEN SUBST_ALL_TAC THEN - FIRST_ASSUM(MP_TAC o MATCH_MP (SET_RULE - `~(u = {a}) ==> a IN u ==> ?b. b IN u /\ ~(b = a)`)) THEN - ASM_REWRITE_TAC[] THEN - DISCH_THEN(X_CHOOSE_THEN `t:A->bool` STRIP_ASSUME_TAC) THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [pairwise]) THEN - DISCH_THEN(MP_TAC o SPECL [`topspace top:A->bool`; `t:A->bool`]) THEN - ASM SET_TAC[]] THEN - SUBGOAL_THEN `closed_in top (b:A->bool)` ASSUME_TAC THENL - [SUBGOAL_THEN - `b = topspace top DIFF - UNIONS (IMAGE (\c:A->bool. top interior_of c) u)` - SUBST1_TAC THENL - [MAP_EVERY EXPAND_TAC ["b"; "v"] THEN MATCH_MP_TAC(SET_RULE - `s UNION t = u /\ DISJOINT s t ==> s = u DIFF t`) THEN - CONJ_TAC THENL - [REWRITE_TAC[GSYM UNIONS_UNION; lemma] THEN - ONCE_REWRITE_TAC[UNION_COMM] THEN - REWRITE_TAC[INTERIOR_OF_UNION_FRONTIER_OF] THEN - FIRST_X_ASSUM(fun th -> GEN_REWRITE_TAC RAND_CONV [SYM th]) THEN - AP_TERM_TAC THEN MATCH_MP_TAC(SET_RULE - `(!x. x IN s ==> f x = x) ==> IMAGE f s = s`) THEN - ASM_SIMP_TAC[CLOSURE_OF_EQ]; - REWRITE_TAC[SET_RULE - `DISJOINT (UNIONS s) (UNIONS t) <=> - !x. x IN s ==> !y. y IN t ==> DISJOINT x y`] THEN - REWRITE_TAC[FORALL_IN_IMAGE] THEN - X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN - X_GEN_TAC `t:A->bool` THEN DISCH_TAC THEN - ASM_CASES_TAC `s:A->bool = t` THENL - [ASM_REWRITE_TAC[frontier_of] THEN SET_TAC[]; - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [pairwise])] THEN - DISCH_THEN(MP_TAC o SPECL [`s:A->bool`; `t:A->bool`]) THEN - ASM_SIMP_TAC[frontier_of; CLOSURE_OF_CLOSED_IN] THEN - MP_TAC(ISPECL [`top:A topology`; `t:A->bool`] - INTERIOR_OF_SUBSET) THEN - SET_TAC[]]; - MATCH_MP_TAC CLOSED_IN_DIFF THEN REWRITE_TAC[CLOSED_IN_TOPSPACE] THEN - MATCH_MP_TAC OPEN_IN_UNIONS THEN - REWRITE_TAC[FORALL_IN_IMAGE; OPEN_IN_INTERIOR_OF]]; + (`!(top:A topology) (s:A->bool) (t:A->bool). + paracompact_space top /\ + closed_in top s /\ t SUBSET topspace top /\ + (!x. x IN s + ==> ?u v. open_in top u /\ open_in top v /\ + x IN u /\ t SUBSET v /\ DISJOINT u v) + ==> ?u v. open_in top u /\ open_in top v /\ + s SUBSET u /\ t SUBSET v /\ DISJOINT u v`, + REPEAT GEN_TAC THEN + REPEAT(DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) THEN + GEN_REWRITE_TAC (LAND_CONV o TOP_DEPTH_CONV) [RIGHT_IMP_EXISTS_THM] THEN + REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`uu:A->A->bool`; `vv:A->A->bool`] THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [paracompact_space]) THEN + DISCH_THEN(MP_TAC o SPEC + `(topspace top DIFF s) INSERT {(uu:A->A->bool) x | x IN s}`) THEN + ANTS_TAC THENL + [ASM_SIMP_TAC[FORALL_IN_INSERT; FORALL_IN_GSPEC; UNIONS_INSERT] THEN + ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_TOPSPACE] THEN MATCH_MP_TAC(SET_RULE + `(s:A->bool) SUBSET u /\ u SUBSET t ==> (t DIFF s) UNION u = t`) THEN + REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + CONJ_TAC THENL [ASM SET_TAC[]; ASM_MESON_TAC[OPEN_IN_SUBSET]]; + REWRITE_TAC[LEFT_IMP_EXISTS_THM; IN_INSERT]] THEN + X_GEN_TAC `w:(A->bool)->bool` THEN + REWRITE_TAC[RIGHT_OR_DISTRIB; EXISTS_OR_THM; UNWIND_THM2] THEN + REWRITE_TAC[EXISTS_IN_GSPEC] THEN REWRITE_TAC[SET_RULE + `(!x:A. x IN s ==> P x \/ Q x) <=> + (!x. x IN {y | y IN s /\ ~P y} ==> Q x)`] THEN + ABBREV_TAC + `w' = {t:A->bool | t IN w /\ ~(t SUBSET topspace top DIFF s)}` THEN + STRIP_TAC THEN MAP_EVERY EXISTS_TAC + [`UNIONS w':A->bool`; + `topspace top DIFF UNIONS {top closure_of t | t IN w'}:A->bool`] THEN + REPEAT CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_UNIONS THEN EXPAND_TAC "w'" THEN ASM SET_TAC[]; + MATCH_MP_TAC OPEN_IN_DIFF THEN REWRITE_TAC[OPEN_IN_TOPSPACE] THEN + MATCH_MP_TAC CLOSED_IN_UNIONS_LOCALLY_FINITE_CLOSURES THEN + MATCH_MP_TAC LOCALLY_FINITE_IN_SUBSET THEN + EXISTS_TAC `w:(A->bool)->bool` THEN ASM SET_TAC[]; + EXPAND_TAC "w'" THEN REWRITE_TAC[UNIONS_GSPEC] THEN + FIRST_ASSUM(MP_TAC o MATCH_MP CLOSED_IN_SUBSET) THEN + ASM SET_TAC[]; + ASM_REWRITE_TAC[SET_RULE + `(t:A->bool) SUBSET s DIFF u <=> t SUBSET s /\ t INTER u = {}`] THEN + REWRITE_TAC[INTER_UNIONS; EMPTY_UNIONS] THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN + X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN + REPEAT(FIRST_X_ASSUM(MP_TAC o SPEC `u:A->bool`)) THEN + ASM_REWRITE_TAC[] THEN + REPEAT(ANTS_TAC THENL [ASM SET_TAC[]; DISCH_TAC]) THEN + REPEAT DISCH_TAC THEN + FIRST_X_ASSUM(X_CHOOSE_THEN `a:A` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `a:A`) THEN + ASM_REWRITE_TAC[] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (SET_RULE + `(t:A->bool) SUBSET t' ==> t' INTER u = {} ==> t INTER u = {}`)) THEN + ASM_SIMP_TAC[OPEN_IN_INTER_CLOSURE_OF_EQ_EMPTY] THEN ASM SET_TAC[]; + MATCH_MP_TAC(SET_RULE + `(s:A->bool) SUBSET t ==> DISJOINT s (u DIFF t)`) THEN + MATCH_MP_TAC(SET_RULE + `(!(s:A->bool). s IN u ==> s SUBSET f s) + ==> UNIONS u SUBSET UNIONS {f s | s IN u}`) THEN + EXPAND_TAC "w'" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_MESON_TAC[CLOSURE_OF_SUBSET; OPEN_IN_SUBSET]]) in + REWRITE_TAC[AND_FORALL_THM] THEN X_GEN_TAC `top:A topology` THEN + REWRITE_TAC[TAUT + `(p /\ h ==> r) /\ (p /\ (h \/ r) ==> n) <=> + p ==> (h ==> r) /\ (r ==> n)`] THEN + DISCH_TAC THEN + REWRITE_TAC[hausdorff_space; regular_space; normal_space] THEN + REWRITE_TAC[GSYM SING_SUBSET] THEN REPEAT STRIP_TAC THENL + [ONCE_REWRITE_TAC[TAUT + `p /\ q /\ r /\ s /\ t <=> q /\ p /\ s /\ r /\ t`] THEN + ONCE_REWRITE_TAC[DISJOINT_SYM] THEN + GEN_REWRITE_TAC I [SWAP_EXISTS_THM] THEN + MATCH_MP_TAC lemma THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [ASM SET_TAC[]; REPEAT STRIP_TAC] THEN + REWRITE_TAC[GSYM SING_SUBSET] THEN FIRST_X_ASSUM MATCH_MP_TAC THEN + FIRST_X_ASSUM(MP_TAC o MATCH_MP CLOSED_IN_SUBSET) THEN ASM SET_TAC[]; + MATCH_MP_TAC lemma THEN ASM_SIMP_TAC[CLOSED_IN_SUBSET] THEN + REPEAT STRIP_TAC THEN REWRITE_TAC[GSYM SING_SUBSET] THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[] THEN + REPEAT(FIRST_X_ASSUM(MP_TAC o MATCH_MP CLOSED_IN_SUBSET)) THEN + ASM SET_TAC[]]);; + +let sigma_locally_finite_in = new_definition + `sigma_locally_finite_in (top:A topology) (U:(A->bool)->bool) <=> + ?f. (!n:num. locally_finite_in top (f n)) /\ + U = UNIONS {f n | n IN (:num)}`;; + +(* Helper: Countable collection with elements in topspace is + sigma-locally-finite. Each {u} is l.f., so take f(n) = {V_n}. *) +let COUNTABLE_IMP_SIGMA_LOCALLY_FINITE_IN = prove + (`!top:A topology U. + COUNTABLE U /\ (!u. u IN U ==> u SUBSET topspace top) + ==> sigma_locally_finite_in top U`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + REWRITE_TAC[sigma_locally_finite_in] THEN + ASM_CASES_TAC `U:(A->bool)->bool = {}` THENL + [EXISTS_TAC `(\n:num. {}:(A->bool)->bool)` THEN + REWRITE_TAC[locally_finite_in; NOT_IN_EMPTY; FINITE_EMPTY] THEN + REWRITE_TAC[SIMPLE_IMAGE; IMAGE_CONST; UNIV_NOT_EMPTY] THEN + CONJ_TAC THENL + [GEN_TAC THEN DISCH_TAC THEN EXISTS_TAC `topspace top:A->bool` THEN + REWRITE_TAC[OPEN_IN_TOPSPACE; EMPTY_GSPEC; FINITE_EMPTY] THEN + ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[UNIONS_1]]; + ALL_TAC] THEN + MP_TAC(ISPEC `U:(A->bool)->bool` COUNTABLE_AS_IMAGE) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `V:num->A->bool` (ASSUME_TAC o SYM)) THEN + EXISTS_TAC `(\n:num. {(V:num->A->bool) n})` THEN CONJ_TAC THENL + [X_GEN_TAC `n:num` THEN REWRITE_TAC[locally_finite_in; IN_SING] THEN + CONJ_TAC THENL + [GEN_TAC THEN DISCH_THEN SUBST1_TAC THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN + FIRST_X_ASSUM(SUBST1_TAC o SYM) THEN + REWRITE_TAC[IN_IMAGE; IN_UNIV] THEN MESON_TAC[]; + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + EXISTS_TAC `topspace top:A->bool` THEN + REWRITE_TAC[OPEN_IN_TOPSPACE] THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC FINITE_SUBSET THEN EXISTS_TAC `{(V:num->A->bool) n}` THEN + REWRITE_TAC[FINITE_SING; IN_SING; SUBSET; IN_ELIM_THM] THEN + GEN_TAC THEN STRIP_TAC THEN ASM_REWRITE_TAC[]]; + (* Goal: UNIONS (IMAGE (\n. {V n}) (:num)) = IMAGE V (:num) *) + REWRITE_TAC[SIMPLE_IMAGE] THEN FIRST_X_ASSUM(SUBST1_TAC o SYM) THEN + REWRITE_TAC[UNIONS_IMAGE; EXTENSION; IN_ELIM_THM; IN_SING; IN_UNIV] THEN + REWRITE_TAC[IMAGE; IN_UNIV; IN_ELIM_THM] THEN SET_TAC[]]);; + +(* Munkres Lemma 39.2: Metric covers have sigma-locally-finite refinements *) +(* Key construction for Stone's theorem using well-ordering *) +let METRIC_COVER_SIGMA_LOCALLY_FINITE = prove + (`!m:A metric U. + (!u. u IN U ==> open_in (mtopology m) u) /\ + UNIONS U = mspace m + ==> ?V. (!v. v IN V ==> open_in (mtopology m) v) /\ + UNIONS V = mspace m /\ + (!v. v IN V ==> ?u. u IN U /\ v SUBSET u) /\ + sigma_locally_finite_in (mtopology m) V`, + let WELL_ORDER_CHOICE = prove + (`!(U:(A->bool)->bool). + ?first. !x. x IN UNIONS U ==> + first x IN U /\ x IN first x /\ + !y. y IN UNIONS U + ==> y IN first x /\ x IN first y ==> first x = first y`, + GEN_TAC THEN + MP_TAC(ISPEC `U:(A->bool)->bool` WO) THEN + DISCH_THEN(X_CHOOSE_THEN `lt:(A->bool)->(A->bool)->bool` + (CONJUNCTS_THEN2 + (ASSUME_TAC o GEN_REWRITE_RULE I [WOSET]) + (fun th -> + RULE_ASSUM_TAC(REWRITE_RULE[th]) THEN REWRITE_TAC[th]))) THEN + FIRST_ASSUM(CONJUNCTS_THEN2 ASSUME_TAC (LABEL_TAC "min")) THEN + SUBGOAL_THEN + `!x:A. x IN UNIONS U ==> + ?u. u IN U /\ x IN u /\ + !v. v IN U /\ x IN v ==> (lt:(A->bool)->(A->bool)->bool) u v` + MP_TAC THENL + [X_GEN_TAC `x:A` THEN REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `u0:A->bool` STRIP_ASSUME_TAC) THEN + USE_THEN "min" (MP_TAC o SPEC `{u:A->bool | u IN U /\ x IN u}`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL [SET_TAC[]; ASM SET_TAC[]]; SET_TAC[]]; + ALL_TAC] THEN REWRITE_TAC[SKOLEM_THM_GEN] THEN + DISCH_THEN(X_CHOOSE_THEN `first:A->(A->bool)` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `first:A->(A->bool)` THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + ASM_MESON_TAC[]) in + let METRIC_TRIANGLE_LOWER = prove + (`!m:A metric x1 x2 p q. + x1 IN mspace m /\ x2 IN mspace m /\ p IN mspace m /\ q IN mspace m + ==> mdist m (x1, x2) - mdist m (p, x1) - mdist m (q, x2) + <= mdist m (p, q)`, + CONV_TAC METRIC_ARITH) in + let COVER_SEPARATION = prove + (`!m:A metric n (x1:A) (x2:A) (p:A) (q:A) (u1:A->bool). + x1 IN mspace m /\ x2 IN mspace m /\ p IN mspace m /\ q IN mspace m /\ + mball m (x1, inv(&(n + 1))) SUBSET u1 /\ + ~(x2 IN u1) /\ + mdist m (p, x1) < inv(&3 * &(n + 1)) /\ + mdist m (q, x2) < inv(&3 * &(n + 1)) + ==> inv(&3 * &(n + 1)) <= mdist m (p, q)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC + `mdist m (x1:A, x2) - mdist m (p:A, x1) - mdist m (q:A, x2)` THEN + CONJ_TAC THENL + [SUBGOAL_THEN `inv(&(n + 1)) <= mdist m (x1:A, x2)` MP_TAC THENL + [REWRITE_TAC[GSYM REAL_NOT_LT] THEN DISCH_TAC THEN + UNDISCH_TAC `~(x2:A IN u1)` THEN REWRITE_TAC[] THEN + FIRST_X_ASSUM(MATCH_MP_TAC o GEN_REWRITE_RULE I [SUBSET]) THEN + REWRITE_TAC[IN_MBALL] THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `inv(&(n + 1)) = &3 * inv(&3 * &(n + 1))` SUBST1_TAC THENL + [REWRITE_TAC[REAL_INV_MUL] THEN + SUBGOAL_THEN `~(&3 = &0)` + (fun th -> SIMP_TAC[th; REAL_MUL_LINV]) THENL + [REAL_ARITH_TAC; REAL_ARITH_TAC]; + ASM_REAL_ARITH_TAC]; + MATCH_MP_TAC METRIC_TRIANGLE_LOWER THEN ASM_REWRITE_TAC[]]) in + REPEAT STRIP_TAC THEN + (* Get canonical well-ordered choice function *) + MP_TAC(ISPEC `U:(A->bool)->bool` WELL_ORDER_CHOICE) THEN + DISCH_THEN(X_CHOOSE_THEN `first:A->(A->bool)` (LABEL_TAC "first_prop")) THEN + (* Define E(n,u) = union of balls of radius 1/(3(n+1)) centered at + points whose 1/(n+1)-ball fits in u and whose first choice is u *) + ABBREV_TAC + `E = \n (u:A->bool). UNIONS {mball m (x:A, inv(&3 * &(n + 1))) | x | + x IN mspace m /\ mball m (x, inv(&(n + 1))) SUBSET u /\ + (first:A->(A->bool)) x = u}` THEN + (* V includes all E(n,u) for n and u IN U *) + EXISTS_TAC `{v:A->bool | ?n (u:A->bool). u IN U /\ + v = (E:num->(A->bool)->(A->bool)) n u}` THEN + (* Helper: first(x) IN U and x IN first(x) *) + SUBGOAL_THEN `!x:A. x IN mspace m ==> + (first:A->(A->bool)) x IN U /\ x IN first x` ASSUME_TAC THENL + [X_GEN_TAC `x:A` THEN DISCH_TAC THEN + USE_THEN "first_prop" (MP_TAC o SPEC `x:A`) THEN + ANTS_TAC THENL [ASM_MESON_TAC[EXTENSION; IN_UNIONS]; SIMP_TAC[]]; + ALL_TAC] THEN + (* Helper: x IN E(n, first(x)) when ball fits *) + SUBGOAL_THEN + `!x:A n. x IN mspace m /\ + mball m (x, inv(&(n + 1))) SUBSET (first:A->(A->bool)) x + ==> x IN (E:num->(A->bool)->(A->bool)) n (first x)` ASSUME_TAC THENL + [REPEAT STRIP_TAC THEN EXPAND_TAC "E" THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `mball m (x:A, inv(&3 * &(n + 1)))` THEN + CONJ_TAC THENL + [EXISTS_TAC `x:A` THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[IN_MBALL] THEN ASM_SIMP_TAC[MDIST_REFL] THEN + MATCH_MP_TAC REAL_LT_INV THEN + MATCH_MP_TAC REAL_LT_MUL THEN REWRITE_TAC[REAL_OF_NUM_LT] THEN ARITH_TAC]; + ALL_TAC] THEN + (* Helper: E(n,u) SUBSET u *) + SUBGOAL_THEN + `!n (u:A->bool). (E:num->(A->bool)->(A->bool)) n u SUBSET u` + ASSUME_TAC THENL + [REPEAT GEN_TAC THEN EXPAND_TAC "E" THEN + REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + X_GEN_TAC `x:A` THEN STRIP_TAC THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `mball m (x:A, inv(&(n + 1)))` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC MBALL_SUBSET_CONCENTRIC THEN MATCH_MP_TAC REAL_LE_INV2 THEN + CONJ_TAC THENL + [REWRITE_TAC[REAL_OF_NUM_LT] THEN ARITH_TAC; + REWRITE_TAC[REAL_ARITH `x <= &3 * x <=> &0 <= &2 * x`] THEN + MATCH_MP_TAC REAL_LE_MUL THEN REWRITE_TAC[REAL_OF_NUM_LE] THEN ARITH_TAC]; + ALL_TAC] THEN + (* Property 1: open *) CONJ_TAC THENL - [ASM_MESON_TAC[COMPLETELY_METRIZABLE_SPACE_CLOSED_IN; - LOCALLY_COMPACT_SPACE_CLOSED_SUBSET; - HAUSDORFF_SPACE_SUBTOPOLOGY]; + [REWRITE_TAC[IN_ELIM_THM] THEN REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + EXPAND_TAC "E" THEN MATCH_MP_TAC OPEN_IN_UNIONS THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN REPEAT STRIP_TAC THEN + REWRITE_TAC[OPEN_IN_MBALL]; + ALL_TAC] THEN + (* Property 2: covering *) + CONJ_TAC THENL + [MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; IN_ELIM_THM] THEN + REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + EXPAND_TAC "E" THEN REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + REPEAT STRIP_TAC THEN REWRITE_TAC[MBALL_SUBSET_MSPACE]; + (* x IN mspace m ==> x IN UNIONS V *) + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + SUBGOAL_THEN `open_in (mtopology m) ((first:A->(A->bool)) x)` MP_TAC THENL + [ASM_MESON_TAC[]; REWRITE_TAC[OPEN_IN_MTOPOLOGY]] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `x:A`)) THEN + ASM_SIMP_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `r:real` STRIP_ASSUME_TAC) THEN + MP_TAC(SPEC `r:real` REAL_ARCH_INV) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `N:num` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `mball m (x:A, inv(&(N + 1))) SUBSET (first:A->(A->bool)) x` + ASSUME_TAC THENL + [MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC `mball m (x:A, r)` THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC MBALL_SUBSET_CONCENTRIC THEN + MATCH_MP_TAC REAL_LE_TRANS THEN EXISTS_TAC `inv(&N)` THEN + ASM_SIMP_TAC[REAL_LT_IMP_LE] THEN MATCH_MP_TAC REAL_LE_INV2 THEN + REWRITE_TAC[REAL_OF_NUM_LT; REAL_OF_NUM_LE] THEN ASM_ARITH_TAC; + ALL_TAC] THEN + EXISTS_TAC `(E:num->(A->bool)->(A->bool)) N ((first:A->(A->bool)) x)` THEN + CONJ_TAC THENL + [EXISTS_TAC `N:num` THEN EXISTS_TAC `(first:A->(A->bool)) x` THEN + ASM_SIMP_TAC[]; + ASM_SIMP_TAC[]]]; + ALL_TAC] THEN + (* Property 3: refinement *) + CONJ_TAC THENL + [REWRITE_TAC[IN_ELIM_THM] THEN REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + EXISTS_TAC `u:A->bool` THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Property 4: sigma locally finite *) + REWRITE_TAC[sigma_locally_finite_in; TOPSPACE_MTOPOLOGY] THEN + EXISTS_TAC `\n. {(E:num->(A->bool)->(A->bool)) n u | u | u IN U}` THEN + CONJ_TAC THENL + [X_GEN_TAC `n:num` THEN + REWRITE_TAC[locally_finite_in; TOPSPACE_MTOPOLOGY] THEN CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_GSPEC] THEN X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN + ASM_MESON_TAC[SUBSET_TRANS; OPEN_IN_SUBSET; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN - X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN CONJ_TAC THENL - [MATCH_MP_TAC CLOSED_IN_SUBSET_TOPSPACE THEN - REWRITE_TAC[CLOSED_IN_FRONTIER_OF; FRONTIER_OF_SUBSET_TOPSPACE] THEN - ASM SET_TAC[]; + (* For each a in mspace m, B(a, inv(6(n+1))) meets at most one E(n,u) *) + X_GEN_TAC `a:A` THEN DISCH_TAC THEN + EXISTS_TAC `mball m (a:A, inv(&6 * &(n + 1)))` THEN + REWRITE_TAC[OPEN_IN_MBALL] THEN CONJ_TAC THENL + [REWRITE_TAC[IN_MBALL] THEN ASM_SIMP_TAC[MDIST_REFL] THEN + MATCH_MP_TAC REAL_LT_INV THEN + MATCH_MP_TAC REAL_LT_MUL THEN REWRITE_TAC[REAL_OF_NUM_LT] THEN ARITH_TAC; ALL_TAC] THEN - REWRITE_TAC[EXTENSION; interior_of; IN_ELIM_THM; NOT_IN_EMPTY] THEN - X_GEN_TAC `a:A` THEN - REWRITE_TAC[OPEN_IN_SUBTOPOLOGY_ALT; EXISTS_IN_GSPEC; IN_INTER] THEN - DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN - SUBGOAL_THEN `(a:A) IN top frontier_of s` ASSUME_TAC THENL - [ASM SET_TAC[]; ALL_TAC] THEN - SUBGOAL_THEN `(a:A) IN s` ASSUME_TAC THENL - [UNDISCH_TAC `(a:A) IN top frontier_of s` THEN - REWRITE_TAC[frontier_of; IN_DIFF] THEN ASM_SIMP_TAC[CLOSURE_OF_CLOSED_IN]; + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `{(E:num->(A->bool)->(A->bool)) n u | u | + u IN U /\ ~(E n u INTER mball m (a:A, inv(&6 * &(n + 1))) = {})}` THEN + CONJ_TAC THENL + [ALL_TAC; + SET_TAC[]] THEN + ASM_CASES_TAC + `{(E:num->(A->bool)->(A->bool)) n u | u | + u IN U /\ ~(E n u INTER mball m (a:A, inv(&6 * &(n + 1))) = {})} = {}` + THENL [ASM_REWRITE_TAC[FINITE_EMPTY]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `v0:A->bool` + (X_CHOOSE_THEN `u0:A->bool` STRIP_ASSUME_TAC)) THEN + SUBGOAL_THEN + `{(E:num->(A->bool)->(A->bool)) n u | u | + u IN U /\ ~(E n u INTER mball m (a:A, inv(&6 * &(n + 1))) = {})} = + {E n u0}` + (fun th -> REWRITE_TAC[th; FINITE_SING]) THEN + MATCH_MP_TAC(SET_RULE + `(a:A) IN s /\ (!y. y IN s ==> y = a) ==> s = {a}`) THEN + CONJ_TAC THENL + [REWRITE_TAC[IN_ELIM_THM] THEN EXISTS_TAC `u0:A->bool` THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_ELIM_THM] THEN X_GEN_TAC `w:A->bool` THEN + DISCH_THEN(X_CHOOSE_THEN `u1:A->bool` STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN + ASM_CASES_TAC `u0:A->bool = u1` THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Get witnesses: p in E(n,u0) INTER B(a,r6), q in E(n,u1) INTER B(a,r6) *) + SUBGOAL_THEN + `?p:A. p IN (E:num->(A->bool)->(A->bool)) n u0 /\ + p IN mball m (a, inv(&6 * &(n + 1)))` + STRIP_ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `?q:A. q IN (E:num->(A->bool)->(A->bool)) n u1 /\ + q IN mball m (a, inv(&6 * &(n + 1)))` + STRIP_ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + (* Extract x1 from E(n,u0): x1 in T(n,u0) with p near x1 *) + SUBGOAL_THEN + `?x1:A. x1 IN mspace m /\ mball m (x1, inv(&(n + 1))) SUBSET u0 /\ + (first:A->(A->bool)) x1 = u0 /\ + p IN mball m (x1, inv(&3 * &(n + 1)))` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `p:A IN (E:num->(A->bool)->(A->bool)) n u0` THEN + EXPAND_TAC "E" THEN REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `b:A->bool` + (CONJUNCTS_THEN2 MP_TAC ASSUME_TAC)) THEN + DISCH_THEN(X_CHOOSE_THEN `x1:A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `x1:A` THEN ASM_MESON_TAC[]; ALL_TAC] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [locally_connected_space]) THEN - DISCH_THEN(MP_TAC o GEN_REWRITE_RULE I [NEIGHBOURHOOD_BASE_OF]) THEN - DISCH_THEN(MP_TAC o SPECL [`u:A->bool`; `a:A`]) THEN - REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY; SUBTOPOLOGY_TOPSPACE] THEN - ASM_REWRITE_TAC[NOT_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`w:A->bool`; `c:A->bool`] THEN STRIP_TAC THEN - MP_TAC(ISPECL [`top:A topology`; `s:A->bool`; `w:A->bool`] - FRONTIER_OF_OPEN_IN_STRADDLE_INTER) THEN - ASM_REWRITE_TAC[NOT_IMP] THEN CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - STRIP_TAC THEN - SUBGOAL_THEN `?t:A->bool. t IN u /\ ~(t = s) /\ ~(w INTER t = {})` - STRIP_ASSUME_TAC THENL - [REPEAT(FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET)) THEN - REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN ASM SET_TAC[]; + (* Extract x2 from E(n,u1): x2 in T(n,u1) with q near x2 *) + SUBGOAL_THEN + `?x2:A. x2 IN mspace m /\ mball m (x2, inv(&(n + 1))) SUBSET u1 /\ + (first:A->(A->bool)) x2 = u1 /\ + q IN mball m (x2, inv(&3 * &(n + 1)))` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `q:A IN (E:num->(A->bool)->(A->bool)) n u1` THEN + EXPAND_TAC "E" THEN REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `b:A->bool` + (CONJUNCTS_THEN2 MP_TAC ASSUME_TAC)) THEN + DISCH_THEN(X_CHOOSE_THEN `x2:A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `x2:A` THEN ASM_MESON_TAC[]; ALL_TAC] THEN - FIRST_ASSUM(MP_TAC o SPECL [`s:A->bool`; `t:A->bool`] o - GEN_REWRITE_RULE I [pairwise]) THEN - ASM_REWRITE_TAC[] THEN DISCH_TAC THEN - MP_TAC(ISPECL [`top:A topology`; `c:A->bool`; `t:A->bool`] - CONNECTED_IN_INTER_FRONTIER_OF) THEN - ASM_REWRITE_TAC[NOT_IMP] THEN CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - SUBGOAL_THEN - `top frontier_of (s:A->bool) SUBSET s /\ - top frontier_of (t:A->bool) SUBSET t` - STRIP_ASSUME_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN - ASM_SIMP_TAC[FRONTIER_OF_SUBSET_CLOSED_IN]);; + (* p, q in mspace m *) + SUBGOAL_THEN `p:A IN mspace m /\ q:A IN mspace m` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[IN_MBALL; MBALL_SUBSET_MSPACE; SUBSET]; ALL_TAC] THEN + (* d(p,q) < inv(3(n+1)) via triangle inequality through a *) + SUBGOAL_THEN `mdist m (p:A, q) < inv(&3 * &(n + 1))` ASSUME_TAC THENL + [MATCH_MP_TAC REAL_LET_TRANS THEN + EXISTS_TAC `mdist m (p:A, a) + mdist m (a:A, q)` THEN CONJ_TAC THENL + [ASM_MESON_TAC[MDIST_TRIANGLE]; ALL_TAC] THEN + SUBGOAL_THEN `inv(&3 * &(n + 1)) = inv(&6 * &(n + 1)) + inv(&6 * &(n + 1))` + SUBST1_TAC THENL + [REWRITE_TAC[REAL_ARITH `a = b + b <=> a = &2 * b`] THEN + REWRITE_TAC[REAL_ARITH `&6 * x = &2 * &3 * x`] THEN + REWRITE_TAC[REAL_INV_MUL] THEN + SUBGOAL_THEN `~(&2 = &0)` (fun th -> SIMP_TAC[th; REAL_MUL_LINV]) THENL + [REAL_ARITH_TAC; REAL_ARITH_TAC]; + MATCH_MP_TAC REAL_LT_ADD2 THEN CONJ_TAC THENL + [UNDISCH_TAC `p:A IN mball m (a:A, inv(&6 * &(n + 1)))` THEN + REWRITE_TAC[IN_MBALL] THEN MESON_TAC[MDIST_SYM]; + UNDISCH_TAC `q:A IN mball m (a:A, inv(&6 * &(n + 1)))` THEN + REWRITE_TAC[IN_MBALL] THEN MESON_TAC[]]]; + ALL_TAC] THEN + (* By WELL_ORDER_CHOICE: ~(x2 IN u0) \/ ~(x1 IN u1) *) + SUBGOAL_THEN `~(x2:A IN u0) \/ ~(x1:A IN u1)` MP_TAC THENL + [USE_THEN "first_prop" (MP_TAC o SPEC `x1:A`) THEN + ANTS_TAC THENL [ASM_MESON_TAC[EXTENSION; IN_UNIONS]; ALL_TAC] THEN + DISCH_THEN(MP_TAC o CONJUNCT2 o CONJUNCT2) THEN + DISCH_THEN(MP_TAC o SPEC `x2:A`) THEN + ANTS_TAC THENL [ASM_MESON_TAC[EXTENSION; IN_UNIONS]; ALL_TAC] THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Extract explicit distance bounds from mball membership *) + SUBGOAL_THEN `mdist m (p:A, x1) < inv(&3 * &(n + 1))` ASSUME_TAC THENL + [UNDISCH_TAC `p:A IN mball m (x1:A, inv (&3 * &(n + 1)))` THEN + REWRITE_TAC[IN_MBALL] THEN MESON_TAC[MDIST_SYM]; ALL_TAC] THEN + SUBGOAL_THEN `mdist m (q:A, x2) < inv(&3 * &(n + 1))` ASSUME_TAC THENL + [UNDISCH_TAC `q:A IN mball m (x2:A, inv (&3 * &(n + 1)))` THEN + REWRITE_TAC[IN_MBALL] THEN MESON_TAC[MDIST_SYM]; ALL_TAC] THEN + (* In either case, COVER_SEPARATION gives contradiction *) + DISCH_THEN DISJ_CASES_TAC THENL + [(* Case ~(x2 IN u0): separation via u0 *) + MP_TAC(ISPECL [`m:A metric`; `n:num`; `x1:A`; `x2:A`; `p:A`; `q:A`; + `u0:A->bool`] COVER_SEPARATION) THEN + ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC; + (* Case ~(x1 IN u1): separation via u1, need MDIST_SYM *) + MP_TAC(ISPECL [`m:A metric`; `n:num`; `x2:A`; `x1:A`; `q:A`; `p:A`; + `u1:A->bool`] COVER_SEPARATION) THEN + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `mdist m (q:A, p) = mdist m (p, q)` + (fun th -> REWRITE_TAC[th]) THENL + [MATCH_MP_TAC MDIST_SYM THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_REAL_ARITH_TAC]; + (* V = UNIONS {f n | n IN (:num)} *) + POP_ASSUM_LIST(K ALL_TAC) THEN + REWRITE_TAC[EXTENSION; UNIONS_GSPEC; IN_UNIV; IN_ELIM_THM] THEN + MESON_TAC[]]);; -let REAL_SIERPINSKI_LEMMA = prove - (`!a b u. - a <= b /\ - COUNTABLE u /\ pairwise DISJOINT u /\ - (!c. c IN u ==> real_closed c /\ ~(c = {})) /\ - UNIONS u = real_interval[a,b] - ==> u = {real_interval[a,b]}`, +(* Michael's Lemma - Steps (1)=>(2)=>(3)=>(4) from Munkres Lemma 41.3 *) +(* Step (1)=>(2): Shrinking sigma-l.f. to l.f. covering *) +(* The "shrinking trick": S_n(U) = U - UNION_{i open_in top b) /\ + sigma_locally_finite_in top B /\ + UNIONS B = topspace top + ==> ?C. UNIONS C = UNIONS B /\ + locally_finite_in top C /\ + (!c. c IN C ==> ?b. b IN B /\ c SUBSET b)`, + (* Shrinking trick: For B = UNIONS {Bn(i) | i in N} where each Bn(i) is l.f., + define Cn(i) = {b DIFF UNIONS{Bn(j) | j < i} | b IN Bn(i)}. + The union C = UNIONS{Cn(i) | i} is locally finite. + Key insight: for x's minimal level n, the nbhd Nn INTER Vn(n) works, + where Vn(n) = UNIONS(Bn n). For k > n, sets in Cn(k) exclude Vn(n). *) + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Unfold sigma_locally_finite_in to get Bn *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [sigma_locally_finite_in]) THEN + DISCH_THEN(X_CHOOSE_THEN `Bn:num->(A->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Define the "earlier unions": Vn n = UNIONS {UNIONS (Bn j) | j < n} *) + ABBREV_TAC + `Vn = \n:num. UNIONS {UNIONS ((Bn:num->(A->bool)->bool) j) | j < n}` THEN + (* Define shrunk sets: Cn n = {b - Vn n | b IN Bn n} *) + (* Use two-bar syntax {... | b | ...} to only bind b, not n *) + ABBREV_TAC + `Cn = \n:num. {b DIFF (Vn:num->A->bool) n | + b | b IN (Bn:num->(A->bool)->bool) n}` THEN + (* Define C = {c | ?n. c IN Cn n} - flattened form *) + EXISTS_TAC `{c:A->bool | ?n:num. c IN (Cn:num->(A->bool)->bool) n}` THEN + (* Prove: UNIONS C = UNIONS B, locally_finite_in, refinement *) + REPEAT CONJ_TAC THENL + [(* UNIONS C = UNIONS B *) + REWRITE_TAC[GSYM SUBSET_ANTISYM_EQ] THEN CONJ_TAC THENL + [(* UNIONS C SUBSET UNIONS B: each c IN C is c SUBSET b for some b IN B *) + REWRITE_TAC[UNIONS_SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `c:A->bool` THEN DISCH_THEN(X_CHOOSE_THEN `n:num` MP_TAC) THEN + EXPAND_TAC "Cn" THEN REWRITE_TAC[IN_ELIM_THM] THEN STRIP_TAC THEN + (* c SUBSET b SUBSET UNIONS B, where b and n are now free *) + TRANS_TAC SUBSET_TRANS `b:A->bool` THEN + CONJ_TAC THENL + [ASM_REWRITE_TAC[SUBSET_DIFF]; + (* b SUBSET UNIONS B: b IN Bn n, B = UNIONS {Bn k | k} *) + REWRITE_TAC[SUBSET; IN_UNIONS] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + EXISTS_TAC `b:A->bool` THEN ASM_REWRITE_TAC[] THEN + UNDISCH_THEN + `B = UNIONS {(Bn:num->(A->bool)->bool) n | n IN (:num)}` + SUBST1_TAC THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `(Bn:num->(A->bool)->bool) n` THEN + ASM_REWRITE_TAC[] THEN + EXISTS_TAC `n:num` THEN REWRITE_TAC[IN_UNIV]]; + (* UNIONS B SUBSET UNIONS C: use WOP for minimal n *) + REWRITE_TAC[SUBSET; IN_UNIONS] THEN X_GEN_TAC `x:A` THEN + DISCH_THEN(X_CHOOSE_THEN `b1:A->bool` STRIP_ASSUME_TAC) THEN + (* First get k such that b1 IN Bn k *) + SUBGOAL_THEN + `?k:num. (b1:A->bool) IN (Bn:num->(A->bool)->bool) k` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `(b1:A->bool) IN B` THEN + ASM_REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + STRIP_TAC THEN + (* Now have t = Bn n and b1 IN t *) + EXISTS_TAC `n:num` THEN + FIRST_X_ASSUM SUBST_ALL_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Now x IN b1, b1 IN Bn k. Use WOP to get minimal n with x IN UNIONS(Bn n) *) + (* num_WOP gives: (?n. P n) <=> (?n. P n /\ !m. m < n ==> ~P m) *) + (* We need the forward direction, so use EQ_IMP_RULE *) + MP_TAC(fst(EQ_IMP_RULE(BETA_RULE(SPEC + `\n:num. x:A IN UNIONS ((Bn:num->(A->bool)->bool) n)` + num_WOP)))) THEN + ANTS_TAC THENL + [EXISTS_TAC `k:num` THEN REWRITE_TAC[IN_UNIONS] THEN + EXISTS_TAC `b1:A->bool` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `n0:num` (CONJUNCTS_THEN2 MP_TAC ASSUME_TAC)) THEN + REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `b0:A->bool` STRIP_ASSUME_TAC) THEN + (* x IN b0, b0 IN Bn n0, and !m. m < n0 ==> x NOT IN UNIONS(Bn m) *) + REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `b0 DIFF (Vn:num->A->bool) n0` THEN CONJ_TAC THENL + [(* b0 DIFF Vn n0 IN C, i.e., ?n. b0 DIFF Vn n0 IN Cn n *) + EXISTS_TAC `n0:num` THEN EXPAND_TAC "Cn" THEN REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `b0:A->bool` THEN ASM_REWRITE_TAC[]; + (* x IN b0 DIFF Vn n0 *) + REWRITE_TAC[IN_DIFF] THEN CONJ_TAC THENL + [ASM_REWRITE_TAC[]; + (* x NOT IN Vn n0 *) + EXPAND_TAC "Vn" THEN REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + REWRITE_TAC[NOT_EXISTS_THM] THEN X_GEN_TAC `s:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 MP_TAC ASSUME_TAC) THEN + DISCH_THEN(X_CHOOSE_THEN `j:num` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST_ALL_TAC)) THEN + (* Goal: ~(x IN s) where s = UNIONS(Bn j), and we have j < n0 and + !m. m < n0 ==> ~(x IN UNIONS(Bn m)). + Need to show x NOT IN UNIONS(Bn j). *) + FIRST_X_ASSUM(MP_TAC o SPEC `j:num`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[IN_UNIONS]]]]; + (* locally_finite_in: For any x, let n0 be minimal with + x IN UNIONS(Bn n0). By l.f. of Bn i for i <= n0, get + neighborhoods N_i intersecting finitely many. + N = (INTERS{N_i | i <= n0}) INTER UNIONS(Bn n0) works. + For k > n0, Cn k elements are disjoint from UNIONS(Bn n0). + For k <= n0, Cn k elements hitting N come from Bn k + elements hitting N_k. *) + REWRITE_TAC[locally_finite_in] THEN CONJ_TAC THENL + [(* !u. u IN C ==> u SUBSET topspace top: each element of + C is b DIFF Vn n, b IN Bn n, so b SUBSET topspace top + by l.f. of Bn n, hence b DIFF Vn n SUBSET topspace top. *) + REWRITE_TAC[IN_ELIM_THM] THEN X_GEN_TAC `u:A->bool` THEN + DISCH_THEN(X_CHOOSE_THEN `n:num` ASSUME_TAC) THEN + UNDISCH_TAC `(u:A->bool) IN (Cn:num->(A->bool)->bool) n` THEN + EXPAND_TAC "Cn" THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `b:A->bool` STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `b:A->bool` THEN REWRITE_TAC[SUBSET_DIFF] THEN + SUBGOAL_THEN + `locally_finite_in top ((Bn:num->(A->bool)->bool) n)` + MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN REWRITE_TAC[locally_finite_in] THEN + DISCH_THEN(MP_TAC o CONJUNCT1) THEN + DISCH_THEN(MP_TAC o SPEC `b:A->bool`) THEN + ASM_REWRITE_TAC[]; + (* Second conjunct: neighborhood finiteness property *) + (* For x in topspace, find minimal n0 with + x IN UNIONS(Bn n0). For k > n0, Cn k elements + exclude x. For k <= n0, use l.f. of Bn k. *) + REWRITE_TAC[IN_ELIM_THM] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `?k:num. x IN UNIONS ((Bn:num->(A->bool)->bool) k)` MP_TAC THENL + [UNDISCH_TAC `(x:A) IN topspace top` THEN + UNDISCH_TAC `UNIONS B = topspace (top:A topology)` THEN + UNDISCH_TAC `B = UNIONS {(Bn:num->(A->bool)->bool) n | n IN (:num)}` THEN + REWRITE_TAC[EXTENSION; IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + MESON_TAC[]; + ALL_TAC] THEN + (* Step 2: Use WOP to get minimal n0 *) + GEN_REWRITE_TAC LAND_CONV [num_WOP] THEN + DISCH_THEN(X_CHOOSE_THEN `n0:num` (CONJUNCTS_THEN2 ASSUME_TAC + (LABEL_TAC "min"))) THEN + (* Step 3: For each k <= n0, get neighborhood from locally_finite_in (Bn k) *) + SUBGOAL_THEN + `!k:num. k <= n0 + ==> ?Nk:A->bool. open_in top Nk /\ x IN Nk /\ + FINITE {b | b IN (Bn:num->(A->bool)->bool) k /\ ~(Nk INTER b = {})}` + MP_TAC THENL + [X_GEN_TAC `k:num` THEN DISCH_TAC THEN + SUBGOAL_THEN + `locally_finite_in top ((Bn:num->(A->bool)->bool) k)` + MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[locally_finite_in] THEN + DISCH_THEN(MP_TAC o SPEC `x:A` o CONJUNCT2) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `v:A->bool` THEN ASM_REWRITE_TAC[] THEN + ONCE_REWRITE_TAC[INTER_COMM] THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Step 4: Skolemize to get function Nk: num -> A->bool *) + GEN_REWRITE_TAC (LAND_CONV o TOP_DEPTH_CONV) [RIGHT_IMP_EXISTS_THM] THEN + REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `Nk:num->A->bool` THEN DISCH_TAC THEN + (* Step 5: Vn(n0+1) is open - it's a union of unions of open sets *) + SUBGOAL_THEN `open_in top ((Vn:num->A->bool) (n0 + 1))` ASSUME_TAC THENL + [EXPAND_TAC "Vn" THEN MATCH_MP_TAC OPEN_IN_UNIONS THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN X_GEN_TAC `j:num` THEN DISCH_TAC THEN + MATCH_MP_TAC OPEN_IN_UNIONS THEN + (* Elements of Bn j are in B, hence open *) + X_GEN_TAC `t:A->bool` THEN DISCH_TAC THEN + (* t IN Bn j => t IN B => open_in top t *) + FIRST_X_ASSUM(fun th -> MATCH_MP_TAC th) THEN + (* Goal: t IN B. Use the specific equation B = UNIONS {...} *) + UNDISCH_THEN + `B = UNIONS {(Bn:num->(A->bool)->bool) n | n IN (:num)}` + SUBST1_TAC THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + EXISTS_TAC `(Bn:num->(A->bool)->bool) j` THEN + ASM_REWRITE_TAC[] THEN EXISTS_TAC `j:num` THEN REWRITE_TAC[]; + ALL_TAC] THEN + (* Step 6: x IN Vn(n0+1) since x IN UNIONS(Bn n0) and n0 < n0+1 *) + SUBGOAL_THEN `(x:A) IN (Vn:num->A->bool) (n0 + 1)` ASSUME_TAC THENL + [EXPAND_TAC "Vn" THEN REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `UNIONS ((Bn:num->(A->bool)->bool) n0)` THEN + ASM_REWRITE_TAC[] THEN EXISTS_TAC `n0:num` THEN ARITH_TAC; + ALL_TAC] THEN + (* Step 7: Get b0 from x IN UNIONS(Bn n0), and b0 is open *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_UNIONS]) THEN + DISCH_THEN(X_CHOOSE_THEN `b0:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `open_in top (b0:A->bool)` ASSUME_TAC THENL + [(* b0 IN Bn n0, so b0 IN B, hence open_in top b0 *) + FIRST_X_ASSUM(fun th -> MATCH_MP_TAC th) THEN + UNDISCH_THEN + `B = UNIONS {(Bn:num->(A->bool)->bool) n | n IN (:num)}` + SUBST1_TAC THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + EXISTS_TAC `(Bn:num->(A->bool)->bool) n0` THEN + ASM_REWRITE_TAC[] THEN EXISTS_TAC `n0:num` THEN REWRITE_TAC[]; + ALL_TAC] THEN + (* Step 8: Construct N = b0 INTER Vn(n0+1) INTER INTERS{Nk k | k <= n0} *) + (* First prove FINITE {Nk k | k <= n0} and all elements are open *) + SUBGOAL_THEN `FINITE {(Nk:num->A->bool) k | k <= n0}` ASSUME_TAC THENL + [MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `IMAGE (Nk:num->A->bool) {k | k <= n0}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN REWRITE_TAC[FINITE_NUMSEG_LE]; + SET_TAC[]]; + ALL_TAC] THEN + SUBGOAL_THEN `!s. s IN {(Nk:num->A->bool) k | k <= n0} ==> open_in top s` + ASSUME_TAC THENL + [REWRITE_TAC[FORALL_IN_GSPEC] THEN X_GEN_TAC `k:num` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `k:num`) THEN ASM_REWRITE_TAC[] THEN + STRIP_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* {Nk k | k <= n0} is nonempty since 0 <= n0 *) + SUBGOAL_THEN `~({(Nk:num->A->bool) k | k <= n0} = {})` ASSUME_TAC THENL + [REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + EXISTS_TAC `(Nk:num->A->bool) 0` THEN EXISTS_TAC `0` THEN ARITH_TAC; + ALL_TAC] THEN + EXISTS_TAC `(b0:A->bool) INTER (Vn:num->A->bool) (n0 + 1) INTER + INTERS {(Nk:num->A->bool) k | k <= n0}` THEN + REPEAT CONJ_TAC THENL + [(* N is open *) + REPEAT(MATCH_MP_TAC OPEN_IN_INTER THEN CONJ_TAC) THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC OPEN_IN_INTERS THEN + ASM_REWRITE_TAC[]; + (* x IN N *) + REWRITE_TAC[IN_INTER; IN_INTERS; FORALL_IN_GSPEC] THEN + ASM_REWRITE_TAC[] THEN X_GEN_TAC `k:num` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `k:num`) THEN ASM_REWRITE_TAC[] THEN + STRIP_TAC THEN ASM_REWRITE_TAC[]; + (* FINITE {c | c IN C /\ ~(N INTER c = {})} *) + (* Step 1: Vn is monotonic: m <= n ==> Vn m SUBSET Vn n *) + SUBGOAL_THEN `!m n:num. m <= n ==> (Vn:num->A->bool) m SUBSET Vn n` + ASSUME_TAC THENL + [REPEAT GEN_TAC THEN DISCH_TAC THEN EXPAND_TAC "Vn" THEN + MATCH_MP_TAC UNIONS_MONO THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN + X_GEN_TAC `j:num` THEN DISCH_TAC THEN + EXISTS_TAC `UNIONS ((Bn:num->(A->bool)->bool) j)` THEN + CONJ_TAC THENL + [REWRITE_TAC[IN_ELIM_THM] THEN EXISTS_TAC `j:num` THEN + ASM_ARITH_TAC; + REWRITE_TAC[SUBSET_REFL]]; + ALL_TAC] THEN + (* Abbreviate N for clarity - the neighborhood we're working with *) + ABBREV_TAC `N = (b0:A->bool) INTER (Vn:num->A->bool) (n0 + 1) INTER + INTERS {(Nk:num->A->bool) k | k <= n0}` THEN + (* Step 2: N SUBSET Vn(n0+1) - from definition of N *) + SUBGOAL_THEN + `(N:A->bool) SUBSET (Vn:num->A->bool) (n0 + 1)` ASSUME_TAC THENL + [EXPAND_TAC "N" THEN SET_TAC[]; + ALL_TAC] THEN + (* Step 3: For k > n0, elements of Cn k are disjoint from Vn(n0+1) *) + SUBGOAL_THEN + `!k c:A->bool. n0 < k /\ c IN (Cn:num->(A->bool)->bool) k + ==> c INTER (Vn:num->A->bool) (n0 + 1) = {}` + ASSUME_TAC THENL + [REPEAT GEN_TAC THEN STRIP_TAC THEN + (* c IN Cn k means c = b DIFF Vn k for some b *) + UNDISCH_TAC `(c:A->bool) IN (Cn:num->(A->bool)->bool) k` THEN + EXPAND_TAC "Cn" THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `b:A->bool` STRIP_ASSUME_TAC) THEN + (* c = b DIFF Vn k, so c INTER Vn k = {} *) + ASM_REWRITE_TAC[] THEN + (* b DIFF Vn k is disjoint from Vn(n0+1) because Vn(n0+1) SUBSET Vn k *) + SUBGOAL_THEN `(Vn:num->A->bool) (n0 + 1) SUBSET Vn k` MP_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; + SET_TAC[]]; + ALL_TAC] THEN + (* Step 4: Therefore, for k > n0, N INTER c = {} for c IN Cn k *) + SUBGOAL_THEN + `!k c:A->bool. n0 < k /\ c IN (Cn:num->(A->bool)->bool) k + ==> (N:A->bool) INTER c = {}` + ASSUME_TAC THENL + [REPEAT GEN_TAC THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`k:num`; `c:A->bool`]) THEN + ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `(N:A->bool) SUBSET (Vn:num->A->bool) (n0 + 1)` THEN + SET_TAC[]; + ALL_TAC] THEN + (* For k <= n0, N SUBSET Nk k *) + SUBGOAL_THEN `!k:num. k <= n0 ==> (N:A->bool) SUBSET (Nk:num->A->bool) k` + ASSUME_TAC THENL + [X_GEN_TAC `k:num` THEN DISCH_TAC THEN EXPAND_TAC "N" THEN + REWRITE_TAC[SUBSET; IN_INTER; INTERS_GSPEC; IN_ELIM_THM] THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Step 5b: For k <= n0, {c IN Cn k | ~(N INTER c = {})} is finite *) + SUBGOAL_THEN + `!k:num. k <= n0 ==> + FINITE {c:A->bool | c IN (Cn:num->(A->bool)->bool) k /\ + ~((N:A->bool) INTER c = {})}` + ASSUME_TAC THENL + [X_GEN_TAC `k:num` THEN DISCH_TAC THEN + (* Use finite subset of IMAGE *) + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `IMAGE (\b. b DIFF (Vn:num->A->bool) k) + {b:A->bool | b IN (Bn:num->(A->bool)->bool) k /\ + ~((Nk:num->A->bool) k INTER b = {})}` THEN + CONJ_TAC THENL + [(* The image is finite because the source is finite *) + MATCH_MP_TAC FINITE_IMAGE THEN ASM_MESON_TAC[]; + (* The subset relation *) + REWRITE_TAC[SUBSET; IN_IMAGE; IN_ELIM_THM] THEN + X_GEN_TAC `c:A->bool` THEN STRIP_TAC THEN + (* c IN Cn k means c = b DIFF Vn k for some b IN Bn k *) + UNDISCH_TAC `(c:A->bool) IN (Cn:num->(A->bool)->bool) k` THEN + EXPAND_TAC "Cn" THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `b:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `b:A->bool` THEN ASM_REWRITE_TAC[] THEN + (* Nk k INTER b nonempty from N INTER c nonempty *) + UNDISCH_TAC `~((N:A->bool) INTER c = {})` THEN + ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `k:num`) THEN ASM_REWRITE_TAC[] THEN + SET_TAC[]]; + ALL_TAC] THEN + (* Step 5c: Main finiteness argument *) + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `UNIONS {{c:A->bool | c IN (Cn:num->(A->bool)->bool) k /\ + ~((N:A->bool) INTER c = {})} | k <= n0}` THEN + CONJ_TAC THENL + [REWRITE_TAC[FINITE_UNIONS] THEN CONJ_TAC THENL + [MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `IMAGE (\k. {c:A->bool | c IN (Cn:num->(A->bool)->bool) k /\ + ~((N:A->bool) INTER c = {})}) {k:num | k <= n0}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN REWRITE_TAC[FINITE_NUMSEG_LE]; + SET_TAC[]]; + REWRITE_TAC[FORALL_IN_GSPEC] THEN ASM_REWRITE_TAC[]]; + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `c:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `m:num` ASSUME_TAC) ASSUME_TAC) THEN + ASM_CASES_TAC `n0:num < m` THENL + [FIRST_X_ASSUM(MP_TAC o SPECL [`m:num`; `c:A->bool`]) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + UNDISCH_TAC `~((c:A->bool) INTER (N:A->bool) = {})` THEN + ONCE_REWRITE_TAC[INTER_COMM] THEN ASM_REWRITE_TAC[]; + EXISTS_TAC `{c':A->bool | c' IN (Cn:num->(A->bool)->bool) m /\ + ~((N:A->bool) INTER c' = {})}` THEN + CONJ_TAC THENL + [REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `m:num` THEN CONJ_TAC THENL + [ASM_ARITH_TAC; REFL_TAC]; + REWRITE_TAC[IN_ELIM_THM] THEN ASM_REWRITE_TAC[] THEN + ONCE_REWRITE_TAC[INTER_COMM] THEN ASM_REWRITE_TAC[]]]]]]; + (* Refinement: each c in C refines some b in B *) + REWRITE_TAC[IN_ELIM_THM] THEN X_GEN_TAC `c:A->bool` THEN + EXPAND_TAC "Cn" THEN REWRITE_TAC[] THEN + REWRITE_TAC[IN_ELIM_THM] THEN + (* With fixed Cn, we have ?n. ?b. b IN Bn n /\ c = b DIFF Vn n *) + DISCH_THEN(X_CHOOSE_THEN `n0:num` + (X_CHOOSE_THEN `b0:A->bool` STRIP_ASSUME_TAC)) THEN + EXISTS_TAC `b0:A->bool` THEN CONJ_TAC THENL + [(* b0 IN B: from b0 IN Bn n0 and B = UNIONS {Bn n | n} *) + UNDISCH_THEN + `B = UNIONS {(Bn:num->(A->bool)->bool) n | n IN (:num)}` + SUBST1_TAC THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `(Bn:num->(A->bool)->bool) n0` THEN + ASM_REWRITE_TAC[] THEN + EXISTS_TAC `n0:num` THEN REWRITE_TAC[IN_UNIV]; + (* c SUBSET b0: from c = b0 DIFF Vn n0 *) + ASM_REWRITE_TAC[SUBSET_DIFF]]]);; + +(* Helper: In a regular space, open sets with closure in some element + of an open cover form an open cover of the whole space *) +let REGULAR_CLOSURE_REFINEMENT_COVERS = prove + (`!(top:A topology) U. + regular_space top /\ + (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> UNIONS {b | open_in top b /\ ?u. u IN U /\ top closure_of b SUBSET u} + = topspace top`, REPEAT STRIP_TAC THEN - MP_TAC(ISPEC `subtopology euclideanreal (real_interval[a,b])` - LOCALLY_CONNECTED_NOT_COUNTABLE_CLOSED_UNION) THEN - REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN - DISCH_THEN MATCH_MP_TAC THEN - ASM_REWRITE_TAC[REAL_INTERVAL_NE_EMPTY; REAL_POS] THEN - ASM_SIMP_TAC[CONNECTED_SPACE_SUBTOPOLOGY; - CONNECTED_IN_EUCLIDEANREAL_INTERVAL; - LOCALLY_CONNECTED_REAL_INTERVAL] THEN - CONJ_TAC THENL - [DISJ1_TAC THEN MATCH_MP_TAC COMPLETELY_METRIZABLE_SPACE_CLOSED_IN THEN - REWRITE_TAC[COMPLETELY_METRIZABLE_SPACE_EUCLIDEANREAL] THEN - REWRITE_TAC[GSYM REAL_CLOSED_IN; REAL_CLOSED_REAL_INTERVAL]; - REPEAT STRIP_TAC THEN MATCH_MP_TAC CLOSED_IN_SUBSET_TOPSPACE THEN - ASM_SIMP_TAC[GSYM REAL_CLOSED_IN] THEN ASM SET_TAC[]]);; - -(* ------------------------------------------------------------------------- *) -(* Size bounds on connected or path-connected spaces. *) -(* ------------------------------------------------------------------------- *) - -let CONNECTED_SPACE_IMP_CARD_GE_ALT = prove - (`!top s:A->bool. - connected_space top /\ completely_regular_space top /\ - closed_in top s /\ ~(s = {}) /\ ~(s = topspace top) - ==> (:real) <=_c topspace top`, + REWRITE_TAC[EXTENSION; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN EQ_TAC THENL + [STRIP_TAC THEN + ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; + DISCH_TAC THEN + (* x is in some u IN U since UNIONS U = topspace *) + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [EXTENSION]) THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + (* u is open since u IN U *) + SUBGOAL_THEN `open_in top (u:A->bool)` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + (* By regularity, get open v and closed c with x IN v SUBSET c SUBSET u *) + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I + [GSYM NEIGHBOURHOOD_BASE_OF_CLOSED_IN]) THEN + REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN + DISCH_THEN(MP_TAC o SPECL [`u:A->bool`; `x:A`]) THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`v:A->bool`; `c:A->bool`] THEN STRIP_TAC THEN + (* v is open, x IN v, v SUBSET c SUBSET u, c is closed *) + EXISTS_TAC `v:A->bool` THEN ASM_REWRITE_TAC[] THEN + EXISTS_TAC `u:A->bool` THEN ASM_REWRITE_TAC[] THEN + (* closure(v) SUBSET c SUBSET u *) + MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC `c:A->bool` THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CLOSURE_OF_MINIMAL THEN ASM_REWRITE_TAC[]]);; + +(* Step (2)=>(3): Using regularity to get l.f. closed refinement *) +(* Given that every open cover has l.f. refinement, show every open cover + has l.f. CLOSED refinement. The proof defines B = {U open | closure(U) + in some element of A}, applies property (2) to B, then takes closures. *) +let LF_COVERING_IMP_LF_CLOSED = prove + (`!(top:A topology). + regular_space top /\ + (!B. (!b. b IN B ==> open_in top b) /\ UNIONS B = topspace top + ==> ?C. UNIONS C = topspace top /\ + locally_finite_in top C /\ + (!c. c IN C ==> ?b. b IN B /\ c SUBSET b)) + ==> !U. (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?W. UNIONS W = topspace top /\ + locally_finite_in top W /\ + (!w. w IN W ==> closed_in top w) /\ + (!w. w IN W ==> ?u. u IN U /\ w SUBSET u)`, REPEAT STRIP_TAC THEN - FIRST_ASSUM(ASSUME_TAC o MATCH_MP CLOSED_IN_SUBSET) THEN - SUBGOAL_THEN `?a:A. a IN topspace top /\ ~(a IN s)` STRIP_ASSUME_TAC THENL - [ASM SET_TAC[]; ALL_TAC] THEN - TRANS_TAC CARD_LE_TRANS `real_interval[&0,&1]` THEN CONJ_TAC THENL - [MATCH_MP_TAC CARD_EQ_IMP_LE THEN ONCE_REWRITE_TAC[CARD_EQ_SYM] THEN - MATCH_MP_TAC CARD_EQ_REAL_SUBSET THEN - MAP_EVERY EXISTS_TAC [`&0:real`; `&1:real`] THEN - ASM_SIMP_TAC[IN_REAL_INTERVAL; REAL_LT_01; REAL_LT_IMP_LE]; + (* Define B = {b open | closure(b) SUBSET some u IN U} *) + ABBREV_TAC `B = {b:A->bool | open_in top b /\ + ?u. u IN U /\ top closure_of b SUBSET u}` THEN + (* B covers X by regularity - use the helper lemma *) + SUBGOAL_THEN `UNIONS B = topspace (top:A topology)` ASSUME_TAC THENL + [EXPAND_TAC "B" THEN MATCH_MP_TAC REGULAR_CLOSURE_REFINEMENT_COVERS THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* B is open *) + SUBGOAL_THEN `!b:A->bool. b IN B ==> open_in top b` ASSUME_TAC THENL + [EXPAND_TAC "B" THEN SIMP_TAC[IN_ELIM_THM]; ALL_TAC] THEN + (* Apply property (2) to B to get l.f. C *) + FIRST_X_ASSUM(MP_TAC o SPEC `B:(A->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `C:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Take W = {closure(c) | c IN C} *) + EXISTS_TAC `{(top:A topology) closure_of c | c IN C}` THEN + (* The 4 goals: UNIONS W = topspace, locally_finite, closed, refines *) + REPEAT CONJ_TAC THENL + [(* Goal 1: UNIONS W = topspace *) + (* UNIONS{closure(c)} = closure(UNIONS C) = topspace *) + MP_TAC(ISPECL [`top:A topology`; `C:(A->bool)->bool`] + CLOSURE_OF_LOCALLY_FINITE_UNIONS) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(SUBST1_TAC o SYM) THEN REWRITE_TAC[CLOSURE_OF_TOPSPACE]; + (* Goal 2: locally_finite_in top W *) + MP_TAC(ISPECL [`top:A topology`; `C:(A->bool)->bool`] + LOCALLY_FINITE_IN_CLOSURES) THEN + ASM_REWRITE_TAC[]; + (* Goal 3: all elements are closed *) + REWRITE_TAC[FORALL_IN_GSPEC; CLOSED_IN_CLOSURE_OF]; + (* Goal 4: W refines U - each closure(c) SUBSET some u IN U *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN + (* c IN C, so c SUBSET some b IN B since C refines B *) + SUBGOAL_THEN `?b:A->bool. b IN B /\ c SUBSET b` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `b:A->bool` STRIP_ASSUME_TAC) THEN + (* b IN B means closure(b) SUBSET some u IN U (by definition of B) *) + SUBGOAL_THEN `?u:A->bool. u IN U /\ (top:A topology) closure_of b SUBSET u` + MP_TAC THENL + [UNDISCH_TAC `b:A->bool IN B` THEN EXPAND_TAC "B" THEN SET_TAC[]; ALL_TAC] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [completely_regular_space]) THEN - DISCH_THEN(MP_TAC o SPECL [`s:A->bool`; `a:A`]) THEN - ASM_REWRITE_TAC[LE_C; IN_DIFF; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `f:A->real` THEN STRIP_TAC THEN - X_GEN_TAC `t:real` THEN REWRITE_TAC[IN_REAL_INTERVAL] THEN STRIP_TAC THEN - ONCE_REWRITE_TAC[EQ_SYM_EQ] THEN ONCE_REWRITE_TAC[CONJ_SYM] THEN - FIRST_ASSUM - (MP_TAC o SPEC `topspace top:A->bool` o MATCH_MP (REWRITE_RULE[IMP_CONJ] - CONNECTED_IN_CONTINUOUS_MAP_IMAGE)) THEN - ASM_REWRITE_TAC[CONNECTED_IN_TOPSPACE] THEN - REWRITE_TAC[CONNECTED_IN_EUCLIDEANREAL; is_realinterval] THEN - REWRITE_TAC[IN_IMAGE] THEN DISCH_THEN MATCH_MP_TAC THEN - MAP_EVERY EXISTS_TAC [`&0:real`; `&1:real`] THEN - REPEAT(FIRST_X_ASSUM(ASSUME_TAC o MATCH_MP CLOSED_IN_SUBSET)) THEN - ASM SET_TAC[]);; - -let CONNECTED_SPACE_IMP_CARD_GE_GEN = prove - (`!top s t:A->bool. - connected_space top /\ normal_space top /\ - closed_in top s /\ closed_in top t /\ - ~(s = {}) /\ ~(t = {}) /\ DISJOINT s t - ==> (:real) <=_c topspace top`, + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `u:A->bool` THEN ASM_REWRITE_TAC[] THEN + (* closure(c) SUBSET closure(b) SUBSET u *) + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `(top:A topology) closure_of b` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CLOSURE_OF_MONO THEN ASM_REWRITE_TAC[]]);; + +(* Helper: expansion set is open when C is locally finite closed. + E(b) = X - UNIONS{c in C | c INTER b = {}} is open and contains b *) +let EXPANSION_SET_OPEN = prove + (`!(top:A topology) C b. + locally_finite_in top C /\ + (!c. c IN C ==> closed_in top c) /\ + b SUBSET topspace top + ==> open_in top (topspace top DIFF UNIONS {c | c IN C /\ c INTER b = {}})`, + REPEAT STRIP_TAC THEN MATCH_MP_TAC OPEN_IN_DIFF THEN + REWRITE_TAC[OPEN_IN_TOPSPACE] THEN + MATCH_MP_TAC CLOSED_IN_LOCALLY_FINITE_UNIONS THEN CONJ_TAC THENL + [ASM SET_TAC[]; + MATCH_MP_TAC LOCALLY_FINITE_IN_SUBSET THEN + EXISTS_TAC `C:(A->bool)->bool` THEN ASM SET_TAC[]]);; + +let EXPANSION_SET_CONTAINS = prove + (`!(top:A topology) C b. + UNIONS C = topspace top /\ b SUBSET topspace top + ==> b SUBSET topspace top DIFF UNIONS {c | c IN C /\ c INTER b = {}}`, REPEAT STRIP_TAC THEN - TRANS_TAC CARD_LE_TRANS `real_interval[&0,&1]` THEN CONJ_TAC THENL - [MATCH_MP_TAC CARD_EQ_IMP_LE THEN ONCE_REWRITE_TAC[CARD_EQ_SYM] THEN - MATCH_MP_TAC CARD_EQ_REAL_SUBSET THEN - MAP_EVERY EXISTS_TAC [`&0:real`; `&1:real`] THEN - ASM_SIMP_TAC[IN_REAL_INTERVAL; REAL_LT_01; REAL_LT_IMP_LE]; - ALL_TAC] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [NORMAL_SPACE_EQ_URYSOHN]) THEN - DISCH_THEN(MP_TAC o SPECL [`s:A->bool`; `t:A->bool`]) THEN - ASM_REWRITE_TAC[LE_C; CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `f:A->real` THEN STRIP_TAC THEN - X_GEN_TAC `t:real` THEN REWRITE_TAC[IN_REAL_INTERVAL] THEN STRIP_TAC THEN - ONCE_REWRITE_TAC[EQ_SYM_EQ] THEN ONCE_REWRITE_TAC[CONJ_SYM] THEN - FIRST_ASSUM - (MP_TAC o SPEC `topspace top:A->bool` o MATCH_MP (REWRITE_RULE[IMP_CONJ] - CONNECTED_IN_CONTINUOUS_MAP_IMAGE)) THEN - ASM_REWRITE_TAC[CONNECTED_IN_TOPSPACE] THEN - REWRITE_TAC[CONNECTED_IN_EUCLIDEANREAL; is_realinterval] THEN - REWRITE_TAC[IN_IMAGE] THEN DISCH_THEN MATCH_MP_TAC THEN - MAP_EVERY EXISTS_TAC [`&0:real`; `&1:real`] THEN - REPEAT(FIRST_X_ASSUM(ASSUME_TAC o MATCH_MP CLOSED_IN_SUBSET)) THEN - ASM SET_TAC[]);; - -let CONNECTED_SPACE_IMP_CARD_GE = prove - (`!top:A topology. - connected_space top /\ normal_space top /\ - (t1_space top \/ hausdorff_space top) /\ - ~(?a. topspace top SUBSET {a}) - ==> (:real) <=_c topspace top`, - GEN_TAC THEN REWRITE_TAC[T1_OR_HAUSDORFF_SPACE] THEN STRIP_TAC THEN - MATCH_MP_TAC CONNECTED_SPACE_IMP_CARD_GE_ALT THEN - FIRST_X_ASSUM(MP_TAC o MATCH_MP (SET_RULE - `~(?a. s SUBSET {a}) ==> ?a b. a IN s /\ b IN s /\ ~(a = b)`)) THEN - REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`a:A`; `b:A`] THEN STRIP_TAC THEN - EXISTS_TAC `{a:A}` THEN - ASM_SIMP_TAC[NORMAL_IMP_COMPLETELY_REGULAR_SPACE_GEN] THEN - CONJ_TAC THENL [ASM_MESON_TAC[T1_SPACE_CLOSED_IN_SING]; ASM SET_TAC[]]);; - -let CONNECTED_SPACE_IMP_INFINITE_GEN = prove - (`!top:A topology. - connected_space top /\ t1_space top /\ - ~(?a. topspace top SUBSET {a}) - ==> INFINITE(topspace top)`, - REPEAT STRIP_TAC THEN MATCH_MP_TAC INFINITE_PERFECT_SET_GEN THEN - EXISTS_TAC `top:A topology` THEN ASM_REWRITE_TAC[] THEN - CONJ_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN - MATCH_MP_TAC CONNECTED_IN_IMP_PERFECT_GEN THEN - ASM_REWRITE_TAC[CONNECTED_IN_TOPSPACE] THEN ASM SET_TAC[]);; + REWRITE_TAC[SUBSET; IN_DIFF; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN CONJ_TAC THENL + [ASM SET_TAC[]; + REWRITE_TAC[NOT_EXISTS_THM] THEN X_GEN_TAC `c:A->bool` THEN + ASM SET_TAC[]]);; -let CONNECTED_SPACE_IMP_INFINITE = prove +(* Step (3)=>(4): Expanding l.f. covering to l.f. open refinement *) +(* Given that every open cover has l.f. refinement (including closed), + show every open cover has l.f. OPEN refinement. The expansion trick: + use property (3) twice to get closed l.f. covers B and C, then + expand B using C to get open l.f. cover. Following Munkres Lemma 41.3. *) +let LF_COVERING_IMP_LF_OPEN = prove + (`!(top:A topology). + regular_space top /\ + (!B. (!b. b IN B ==> open_in top b) /\ UNIONS B = topspace top + ==> ?C. UNIONS C = topspace top /\ + locally_finite_in top C /\ + (!c. c IN C ==> closed_in top c) /\ + (!c. c IN C ==> ?b. b IN B /\ c SUBSET b)) + ==> !U. (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?W. UNIONS W = topspace top /\ + locally_finite_in top W /\ + (!w. w IN W ==> open_in top w) /\ + (!w. w IN W ==> ?u. u IN U /\ w SUBSET u)`, + let EXPANSION_MEETS_IMP_INTERSECTS = prove + (`!(X:A->bool) C b c. + c IN C /\ UNIONS C = X /\ + ~((X DIFF UNIONS {c' | c' IN C /\ c' INTER b = {}}) INTER c = {}) + ==> ~(c INTER b = {})`, + REWRITE_TAC[EXTENSION; NOT_IN_EMPTY; IN_INTER; IN_DIFF; IN_UNIONS; + IN_ELIM_THM; NOT_FORALL_THM] THEN + MESON_TAC[]) in + GEN_TAC THEN DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (LABEL_TAC "prop3")) THEN + REPEAT STRIP_TAC THEN + USE_THEN "prop3" (MP_TAC o SPEC `U:(A->bool)->bool`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `B:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Skolemize Fb *) + SUBGOAL_THEN + `?Fb:(A->bool)->(A->bool). !b. b IN B ==> Fb b IN U /\ b SUBSET Fb b` + STRIP_ASSUME_TAC THENL + [REWRITE_TAC[GSYM SKOLEM_THM_GEN] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + (* NB = sets meeting finitely many elements of B *) + ABBREV_TAC `NB = {N:A->bool | open_in top N /\ + FINITE {b | b IN B /\ ~(b INTER N = {})}}` THEN + (* NB covers topspace *) + SUBGOAL_THEN `UNIONS NB = topspace (top:A topology)` ASSUME_TAC THENL + [EXPAND_TAC "NB" THEN REWRITE_TAC[EXTENSION; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN EQ_TAC THENL + [STRIP_TAC THEN FIRST_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN + ASM SET_TAC[]; + DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [locally_finite_in]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `x:A`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `V:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `V:A->bool` THEN + REWRITE_TAC[GSYM EXTENSION] THEN ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + SUBGOAL_THEN `!N:A->bool. N IN NB ==> open_in top N` ASSUME_TAC THENL + [EXPAND_TAC "NB" THEN REWRITE_TAC[IN_ELIM_THM] THEN + GEN_TAC THEN DISCH_THEN(CONJUNCTS_THEN2 ACCEPT_TAC (K ALL_TAC)); + ALL_TAC] THEN + (* Apply prop3 to NB to get l.f. closed refinement C *) + USE_THEN "prop3" (MP_TAC o SPEC `NB:(A->bool)->bool`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `C:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Define expansion function Eb *) + ABBREV_TAC `Eb = \b:A->bool. topspace top DIFF + UNIONS {c:A->bool | c IN C /\ c INTER b = {}}` THEN + (* Witness: {Eb b INTER Fb b | b IN B} *) + EXISTS_TAC + `{(Eb:(A->bool)->(A->bool)) b INTER + (Fb:(A->bool)->(A->bool)) b | b | b IN B}` THEN + (* Prove the four properties *) + CONJ_TAC THENL + [(* UNIONS {Eb b INTER Fb b | b IN B} = topspace top *) + REWRITE_TAC[EXTENSION; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN EQ_TAC THENL + [DISCH_THEN(X_CHOOSE_THEN `w:A->bool` MP_TAC) THEN + DISCH_THEN(CONJUNCTS_THEN2 MP_TAC STRIP_ASSUME_TAC) THEN + EXPAND_TAC "Eb" THEN ASM SET_TAC[]; + DISCH_TAC THEN + (* x is in topspace, so in some b in B *) + SUBGOAL_THEN `?b:A->bool. b IN B /\ x IN b` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `UNIONS B = topspace (top:A topology)` THEN + REWRITE_TAC[EXTENSION; IN_UNIONS] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + EXISTS_TAC + `(Eb:(A->bool)->(A->bool)) b INTER + (Fb:(A->bool)->(A->bool)) b` THEN CONJ_TAC THENL + [EXISTS_TAC `b:A->bool` THEN ASM_REWRITE_TAC[]; + (* x IN Eb b INTER Fb b follows from x IN b and b SUBSET both *) + REWRITE_TAC[IN_INTER] THEN CONJ_TAC THENL + [MP_TAC(ISPECL [`top:A topology`; `C:(A->bool)->bool`; `b:A->bool`] + EXPANSION_SET_CONTAINS) THEN + ASM_REWRITE_TAC[] THEN + ANTS_TAC THENL + [UNDISCH_TAC `UNIONS B = topspace (top:A topology)` THEN + REWRITE_TAC[EXTENSION; SUBSET; IN_UNIONS] THEN ASM_MESON_TAC[]; + (* b SUBSET Eb b, so x IN Eb b from x IN b *) + EXPAND_TAC "Eb" THEN REWRITE_TAC[SUBSET; IN_DIFF] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + MESON_TAC[]]; + (* x IN Fb b from x IN b and b SUBSET Fb b *) + ASM_MESON_TAC[SUBSET]]]]; + ALL_TAC] THEN CONJ_TAC THENL + [(* locally_finite_in top {Eb b INTER Fb b | b IN B} *) + (* For x, use l.f. of C to get nbhd M meeting finitely + many c's. If (Eb b INTER Fb b) meets M, then Eb b meets M, + so b meets some c meeting M. Each c refines some N in NB, + so {b | b meets c} is finite. + Hence {Eb b INTER Fb b | ... meets M} is finite. *) + REWRITE_TAC[locally_finite_in; FORALL_IN_GSPEC] THEN CONJ_TAC THENL + [(* Each Eb b INTER Fb b SUBSET topspace top *) + X_GEN_TAC `b:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC(SET_RULE `(s:A->bool) SUBSET t ==> (s INTER u) SUBSET t`) THEN + EXPAND_TAC "Eb" THEN SET_TAC[]; + ALL_TAC] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + (* Use local finiteness of C to get neighborhood *) + (* Use l.f. of C to get neighborhood M *) + SUBGOAL_THEN `?M:A->bool. open_in top M /\ x IN M /\ + FINITE {c:A->bool | c IN C /\ ~(c INTER M = {})}` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `locally_finite_in top (C:(A->bool)->bool)` THEN + REWRITE_TAC[locally_finite_in] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `x:A`)) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + EXISTS_TAC `M:A->bool` THEN ASM_REWRITE_TAC[] THEN + (* Now need: FINITE {Eb b | Eb b meets M} *) + (* Key: if Eb b meets M, then b meets some c meeting M *) + (* Abbreviate S = {c in C | c meets M} - finite by assumption *) + ABBREV_TAC `S' = {c:A->bool | c IN C /\ ~(c INTER M = {})}` THEN + (* For each c in S', c SUBSET some N in NB, so {b | b meets c} finite *) + SUBGOAL_THEN + `!c:A->bool. c IN S' ==> FINITE {b:A->bool | b IN B /\ ~(b INTER c = {})}` + ASSUME_TAC THENL + [X_GEN_TAC `c:A->bool` THEN EXPAND_TAC "S'" THEN + REWRITE_TAC[IN_ELIM_THM] THEN STRIP_TAC THEN + (* c IN C, so c SUBSET some N in NB *) + SUBGOAL_THEN `?N:A->bool. N IN NB /\ c SUBSET N` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + (* N IN NB means FINITE {b in B | b meets N} *) + UNDISCH_TAC `(N:A->bool) IN NB` THEN EXPAND_TAC "NB" THEN + REWRITE_TAC[IN_ELIM_THM] THEN STRIP_TAC THEN + (* {b | b meets c} SUBSET {b | b meets N} which is finite *) + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `{b:A->bool | b IN B /\ ~(b INTER N = {})}` THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `b':A->bool` THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `~(b' INTER (c:A->bool) = {})` THEN + UNDISCH_TAC `(c:A->bool) SUBSET N` THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; SUBSET; IN_INTER] THEN MESON_TAC[]; + ALL_TAC] THEN + (* {Eb b INTER Fb b | b IN B /\ ... meets M} is bounded by UNIONS over S' *) + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `IMAGE (\b:A->bool. (Eb:(A->bool)->(A->bool)) b INTER + (Fb:(A->bool)->(A->bool)) b) + (UNIONS {{b:A->bool | b IN B /\ ~(b INTER c = {})} | c IN S'})` THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN + REWRITE_TAC[FINITE_UNIONS] THEN CONJ_TAC THENL + [REWRITE_TAC[SIMPLE_IMAGE] THEN + MATCH_MP_TAC FINITE_IMAGE THEN EXPAND_TAC "S'" THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[FORALL_IN_GSPEC] THEN ASM_REWRITE_TAC[]]; + REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_IMAGE; UNIONS_GSPEC] THEN + X_GEN_TAC `w:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `b:A->bool` STRIP_ASSUME_TAC) ASSUME_TAC) THEN + EXISTS_TAC `b:A->bool` THEN ASM_REWRITE_TAC[] THEN + (* Need: exists c in S' with b meets c *) + (* From: w = Eb b INTER Fb b, and w meets M, derive Eb b meets M *) + (* Since (Eb b INTER Fb b) SUBSET Eb b, if w meets M then Eb b meets M *) + SUBGOAL_THEN `~((Eb:(A->bool)->(A->bool)) b INTER M = {})` MP_TAC THENL + [(* ~(w INTER M = {}) ==> ~(Eb b INTER M = {}), where w = Eb b INTER Fb b *) + UNDISCH_TAC `~((w:A->bool) INTER M = {})` THEN + ASM_REWRITE_TAC[] THEN + (* Now goal: ~((Eb b INTER Fb b) INTER M = {}) ==> ~(Eb b INTER M = {}) *) + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + DISCH_THEN(X_CHOOSE_THEN `z:A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `z:A` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + EXPAND_TAC "Eb" THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER; + IN_DIFF; IN_UNIONS; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `y:A` STRIP_ASSUME_TAC) THEN + (* y IN M, y IN topspace top, y NOT IN any c with c INTER b = {} *) + (* y IN topspace from open_in top M *) + SUBGOAL_THEN `(y:A) IN topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; ALL_TAC] THEN + (* y IN some c since UNIONS C = topspace top *) + SUBGOAL_THEN `?c:A->bool. c IN C /\ y IN c` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `UNIONS C = topspace (top:A topology)` THEN + REWRITE_TAC[EXTENSION; IN_UNIONS] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + (* This c must have c INTER b != {} since y doesn't avoid it *) + (* First prove c IN S' using SUBGOAL_THEN *) + SUBGOAL_THEN `(c:A->bool) IN S'` ASSUME_TAC THENL + [EXPAND_TAC "S'" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + EXISTS_TAC `y:A` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Now prove the existential with c as witness *) + EXISTS_TAC `c:A->bool` THEN ASM_REWRITE_TAC[] THEN + (* Prove ~(b INTER c = {}) via SUBGOAL_THEN, then derive existential *) + SUBGOAL_THEN `~((c:A->bool) INTER b = {})` MP_TAC THENL + [MATCH_MP_TAC EXPANSION_MEETS_IMP_INTERSECTS THEN + EXISTS_TAC `topspace (top:A topology)` THEN + EXISTS_TAC `C:(A->bool)->bool` THEN + ASM_REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + EXISTS_TAC `y:A` THEN + REWRITE_TAC[IN_DIFF; IN_UNIONS; IN_ELIM_THM; IN_INTER] THEN + ASM_REWRITE_TAC[]; + (* ~(c INTER b = {}) ==> ?x. x IN b /\ x IN c *) + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + MESON_TAC[]]]; + ALL_TAC] THEN + (* Remaining: openness and refinement *) + CONJ_TAC THENL + [(* Openness: each Eb b INTER Fb b is open *) + (* Eb b is open by EXPANSION_SET_OPEN, Fb b is open since Fb b IN U *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN + X_GEN_TAC `b:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC OPEN_IN_INTER THEN CONJ_TAC THENL + [(* Eb b is open *) + EXPAND_TAC "Eb" THEN + MATCH_MP_TAC EXPANSION_SET_OPEN THEN ASM_REWRITE_TAC[] THEN + (* Need: b SUBSET topspace top *) + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + UNDISCH_TAC `UNIONS B = topspace (top:A topology)` THEN + REWRITE_TAC[EXTENSION; IN_UNIONS] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN + REWRITE_TAC[] THEN DISCH_THEN(fun th -> REWRITE_TAC[GSYM th]) THEN + ASM_MESON_TAC[]; + (* Fb b is open since Fb b IN U and all u in U are open *) + ASM_MESON_TAC[]]; + (* Refinement: each Eb b INTER Fb b SUBSET some u in U *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN + X_GEN_TAC `b:A->bool` THEN DISCH_TAC THEN + (* Witness: Fb b IN U and Eb b INTER Fb b SUBSET Fb b trivially *) + EXISTS_TAC `(Fb:(A->bool)->(A->bool)) b` THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; SET_TAC[]]]);; + +(* Michael's lemma: For regular spaces, sigma-locally-finite + implies locally finite *) +(* Combines steps (1)=>(2)=>(3)=>(4) - Lemma 41.3 from Munkres *) +(* The full proof uses SIGMA_LOCALLY_FINITE_IMP_LOCALLY_FINITE_COVERING, + LF_COVERING_IMP_LF_CLOSED, and LF_COVERING_IMP_LF_OPEN *) +let MICHAEL_LEMMA = prove (`!top:A topology. - connected_space top /\ hausdorff_space top /\ - ~(?a. topspace top SUBSET {a}) - ==> INFINITE(topspace top)`, - MESON_TAC[CONNECTED_SPACE_IMP_INFINITE_GEN; HAUSDORFF_IMP_T1_SPACE]);; + regular_space top + ==> (!U. (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?V. (!v. v IN V ==> open_in top v) /\ + UNIONS V = topspace top /\ + (!v. v IN V ==> ?u. u IN U /\ v SUBSET u) /\ + sigma_locally_finite_in top V) + ==> (!U. (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?V. (!v. v IN V ==> open_in top v) /\ + UNIONS V = topspace top /\ + (!v. v IN V ==> ?u. u IN U /\ v SUBSET u) /\ + locally_finite_in top V)`, + GEN_TAC THEN DISCH_TAC THEN DISCH_TAC THEN + X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + (* Apply LF_COVERING_IMP_LF_OPEN then reorder conjuncts *) + MP_TAC(ISPEC `top:A topology` LF_COVERING_IMP_LF_OPEN) THEN + ASM_REWRITE_TAC[] THEN + (* Need: every open cover has LF closed refinement *) + (* Apply LF_COVERING_IMP_LF_CLOSED *) + SUBGOAL_THEN + `!B:(A->bool)->bool. (!b. b IN B ==> open_in top b) /\ UNIONS B = topspace top + ==> ?C. UNIONS C = topspace top /\ + locally_finite_in top C /\ + (!c. c IN C ==> closed_in top c) /\ + (!c. c IN C ==> ?b. b IN B /\ c SUBSET b)` ASSUME_TAC THENL + [MP_TAC(ISPEC `top:A topology` LF_COVERING_IMP_LF_CLOSED) THEN + ASM_REWRITE_TAC[] THEN + (* Need: every open cover has LF refinement *) + SUBGOAL_THEN + `!B:(A->bool)->bool. (!b. b IN B ==> open_in top b) /\ UNIONS B = topspace top + ==> ?C. UNIONS C = topspace top /\ + locally_finite_in top C /\ + (!c. c IN C ==> ?b. b IN B /\ c SUBSET b)` ASSUME_TAC THENL + [X_GEN_TAC `B:(A->bool)->bool` THEN STRIP_TAC THEN + (* Apply sigma-LF hypothesis to B *) + FIRST_X_ASSUM(MP_TAC o SPEC `B:(A->bool)->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `V:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Apply SIGMA_LOCALLY_FINITE_IMP_LOCALLY_FINITE_COVERING to V *) + MP_TAC(ISPECL [`top:A topology`; `V:(A->bool)->bool`] + SIGMA_LOCALLY_FINITE_IMP_LOCALLY_FINITE_COVERING) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `C:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `C:(A->bool)->bool` THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN ASM_MESON_TAC[SUBSET_TRANS]; + ASM_REWRITE_TAC[]]; + ASM_REWRITE_TAC[]] THEN + (* Now apply to U and reorder *) + DISCH_THEN(MP_TAC o SPEC `U:(A->bool)->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `W:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `W:(A->bool)->bool` THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]);; + +(* Engelking 5.1.3 / Munkres 41.4 (A.H. Stone): + Every metrizable space is paracompact. + Proof combines METRIC_COVER_SIGMA_LOCALLY_FINITE and MICHAEL_LEMMA *) +let METRIZABLE_IMP_PARACOMPACT_SPACE = prove + (`!top:A topology. metrizable_space top ==> paracompact_space top`, + REWRITE_TAC[metrizable_space; LEFT_IMP_EXISTS_THM] THEN + REPEAT GEN_TAC THEN DISCH_THEN SUBST_ALL_TAC THEN + (* Now goal is: paracompact_space (mtopology m) *) + REWRITE_TAC[paracompact_space] THEN + (* Use MICHAEL_LEMMA: regular + sigma-LF refinements => LF refinements *) + MP_TAC(ISPEC `mtopology (m:A metric)` MICHAEL_LEMMA) THEN + REWRITE_TAC[REGULAR_SPACE_MTOPOLOGY; TOPSPACE_MTOPOLOGY] THEN + DISCH_THEN MATCH_MP_TAC THEN + GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPECL [`m:A metric`; `U:(A->bool)->bool`] + METRIC_COVER_SIGMA_LOCALLY_FINITE) THEN + ASM_REWRITE_TAC[]);; -let CONNECTED_SPACE_IMP_INFINITE_ALT = prove - (`!top s:A->bool. - connected_space top /\ regular_space top /\ - closed_in top s /\ ~(s = {}) /\ ~(s = topspace top) - ==> INFINITE(topspace top)`, +(* Immediate corollary: every metric space is paracompact *) +let PARACOMPACT_SPACE_MTOPOLOGY = prove + (`!m:A metric. paracompact_space(mtopology m)`, + MESON_TAC[METRIZABLE_IMP_PARACOMPACT_SPACE; METRIZABLE_SPACE_MTOPOLOGY]);; + +(* Helper: compact set in l.f. family has open neighborhood + meeting finitely many. Uses compactness to get finite + subcover by neighborhoods; union of finite sets is finite. *) +let COMPACT_LF_OPEN_NEIGHBORHOOD = prove + (`!(top:A topology) (K:A->bool) (V:(A->bool)->bool). + compact_in top K /\ locally_finite_in top V + ==> ?N. open_in top N /\ K SUBSET N /\ + FINITE {v | v IN V /\ ~(v INTER N = {})}`, REPEAT STRIP_TAC THEN - FIRST_ASSUM(ASSUME_TAC o MATCH_MP CLOSED_IN_SUBSET) THEN - SUBGOAL_THEN `?a:A. a IN topspace top /\ ~(a IN s)` STRIP_ASSUME_TAC THENL - [ASM SET_TAC[]; ALL_TAC] THEN - SUBGOAL_THEN - `?u. (!n. DISJOINT (u n) s /\ (a:A) IN u n /\ open_in top (u n)) /\ - (!n. u(SUC n) PSUBSET u n)` - STRIP_ASSUME_TAC THENL - [MATCH_MP_TAC DEPENDENT_CHOICE THEN CONJ_TAC THENL - [EXISTS_TAC `topspace top DIFF s:A->bool` THEN - ASM_SIMP_TAC[IN_DIFF; OPEN_IN_DIFF; OPEN_IN_TOPSPACE] THEN - SET_TAC[]; - ALL_TAC] THEN - MAP_EVERY X_GEN_TAC [`n:num`; `v:A->bool`] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [locally_finite_in]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o REWRITE_RULE[RIGHT_IMP_EXISTS_THM; SKOLEM_THM])) THEN + DISCH_THEN(X_CHOOSE_THEN `M:A->A->bool` ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [compact_in]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPEC `IMAGE (M:A->A->bool) K`)) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_IMAGE] THEN X_GEN_TAC `a:A` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `a:A`) THEN + ANTS_TAC THENL [ASM SET_TAC[]; SIMP_TAC[]]; + REWRITE_TAC[UNIONS_IMAGE; SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `a:A` THEN DISCH_TAC THEN EXISTS_TAC `a:A` THEN + ASM_REWRITE_TAC[] THEN FIRST_X_ASSUM(MP_TAC o SPEC `a:A`) THEN + ANTS_TAC THENL [ASM SET_TAC[]; SIMP_TAC[]]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `T':(A->bool)->bool` STRIP_ASSUME_TAC) THEN + MP_TAC(ISPECL [`M:A->A->bool`; `K:A->bool`; `T':(A->bool)->bool`] + FINITE_SUBSET_IMAGE_IMP) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `F':A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `UNIONS (IMAGE (M:A->A->bool) F')` THEN + CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_UNIONS THEN REWRITE_TAC[FORALL_IN_IMAGE] THEN + X_GEN_TAC `a:A` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `a:A`) THEN + ANTS_TAC THENL [ASM SET_TAC[]; SIMP_TAC[]]; + ALL_TAC] THEN CONJ_TAC THENL + [MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `UNIONS (T':(A->bool)->bool)` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC SUBSET_UNIONS THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `UNIONS (IMAGE (\a:A. {v:A->bool | v IN V /\ + ~(v INTER (M:A->A->bool) a = {})}) F')` THEN + CONJ_TAC THENL + [REWRITE_TAC[FINITE_UNIONS; SIMPLE_IMAGE; FORALL_IN_IMAGE] THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN ASM_REWRITE_TAC[]; + X_GEN_TAC `a:A` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `a:A`) THEN + ANTS_TAC THENL [ASM SET_TAC[]; SIMP_TAC[]]]; + REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_UNIONS; EXISTS_IN_IMAGE] THEN + X_GEN_TAC `v:A->bool` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + REWRITE_TAC[IN_INTER; UNIONS_IMAGE; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `x:A` MP_TAC) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `a:A` STRIP_ASSUME_TAC)) THEN + EXISTS_TAC `a:A` THEN ASM_REWRITE_TAC[IN_ELIM_THM] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + EXISTS_TAC `x:A` THEN REWRITE_TAC[IN_INTER] THEN + ASM_REWRITE_TAC[]]);; + +(* Helper: LF closed refinement pushed forward by perfect map *) +let LF_CLOSED_PERFECT_MAP_IMAGE = prove + (`!top top' (f:A->B) (W:(A->bool)->bool). + perfect_map(top,top') f /\ + locally_finite_in top W /\ + (!w. w IN W ==> closed_in top w) + ==> locally_finite_in top' (IMAGE (IMAGE f) W) /\ + (!v. v IN IMAGE (IMAGE f) W ==> closed_in top' v)`, + REPEAT GEN_TAC THEN + DISCH_THEN(CONJUNCTS_THEN2 MP_TAC STRIP_ASSUME_TAC) THEN + REWRITE_TAC[perfect_map; proper_map] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 (CONJUNCTS_THEN2 ASSUME_TAC ASSUME_TAC) + ASSUME_TAC)) THEN + CONJ_TAC THENL + [(* locally_finite_in top' (IMAGE (IMAGE f) W) *) + REWRITE_TAC[locally_finite_in] THEN CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_IMAGE] THEN + X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN + SUBGOAL_THEN `w SUBSET topspace (top:A topology)` ASSUME_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET]; ASM SET_TAC[]]; + ALL_TAC] THEN + X_GEN_TAC `y:B` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `y:B`) THEN ASM_REWRITE_TAC[] THEN + DISCH_TAC THEN + MP_TAC(ISPECL [`top:A topology`; + `{x:A | x IN topspace top /\ (f:A->B) x = y}`; + `W:(A->bool)->bool`] COMPACT_LF_OPEN_NEIGHBORHOOD) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `N:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC + `topspace top' DIFF IMAGE (f:A->B) (topspace top DIFF N)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_DIFF THEN REWRITE_TAC[OPEN_IN_TOPSPACE] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [closed_map]) THEN + DISCH_THEN MATCH_MP_TAC THEN MATCH_MP_TAC CLOSED_IN_DIFF THEN + REWRITE_TAC[CLOSED_IN_TOPSPACE] THEN ASM_SIMP_TAC[]; + ALL_TAC] THEN CONJ_TAC THENL + [REWRITE_TAC[IN_DIFF; IN_IMAGE; IN_DIFF] THEN + ASM_REWRITE_TAC[NOT_EXISTS_THM; DE_MORGAN_THM] THEN + X_GEN_TAC `x:A` THEN ASM SET_TAC[]; + ALL_TAC] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `IMAGE (IMAGE (f:A->B)) + {w:A->bool | w IN W /\ ~(w INTER N = {})}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_IMAGE] THEN + X_GEN_TAC `v:B->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) + ASSUME_TAC) THEN + FIRST_X_ASSUM(SUBST_ALL_TAC) THEN + EXISTS_TAC `w:A->bool` THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `w SUBSET topspace (top:A topology)` ASSUME_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET]; ALL_TAC] THEN FIRST_X_ASSUM(MP_TAC o - GEN_REWRITE_RULE I [GSYM NEIGHBOURHOOD_BASE_OF_CLOSED_IN]) THEN - REWRITE_TAC[NEIGHBOURHOOD_BASE_OF] THEN - DISCH_THEN(MP_TAC o SPECL [`v:A->bool`; `a:A`]) THEN - ASM_REWRITE_TAC[] THEN MATCH_MP_TAC MONO_EXISTS THEN - X_GEN_TAC `u:A->bool` THEN - DISCH_THEN(X_CHOOSE_THEN `c:A->bool` STRIP_ASSUME_TAC) THEN + GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + REWRITE_TAC[IN_INTER; IN_DIFF; IN_IMAGE] THEN + DISCH_THEN(X_CHOOSE_THEN `z:B` + (CONJUNCTS_THEN2 + (X_CHOOSE_THEN `a:A` STRIP_ASSUME_TAC) + (CONJUNCTS_THEN2 ASSUME_TAC ASSUME_TAC))) THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + EXISTS_TAC `a:A` THEN REWRITE_TAC[IN_INTER] THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + FIRST_ASSUM(SUBST1_TAC o SYM) THEN + UNDISCH_TAC + `~(?x:A. (z:B) = (f:A->B) x /\ + x IN topspace top /\ ~(x IN N))` THEN + REWRITE_TAC[NOT_EXISTS_THM; DE_MORGAN_THM] THEN + DISCH_THEN(MP_TAC o SPEC `a:A`) THEN ASM_REWRITE_TAC[] THEN - ASM_CASES_TAC `c:A->bool = u` THENL - [FIRST_X_ASSUM SUBST_ALL_TAC; ASM SET_TAC[]] THEN - FIRST_X_ASSUM(MP_TAC o SPEC `u:A->bool` o - GEN_REWRITE_RULE I [CONNECTED_SPACE_CLOPEN_IN]) THEN - ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; - SUBGOAL_THEN `!n. ?x:A. x IN u n /\ ~(x IN u(SUC n))` MP_TAC THENL - [ASM SET_TAC[]; REWRITE_TAC[SKOLEM_THM]] THEN - REWRITE_TAC[INFINITE_CARD_LE; le_c; IN_UNIV; FORALL_AND_THM] THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `f:num->A` THEN STRIP_TAC THEN - CONJ_TAC THENL [ASM_MESON_TAC[SUBSET; OPEN_IN_SUBSET]; ALL_TAC] THEN - MATCH_MP_TAC WLOG_LT THEN - SUBGOAL_THEN `!m n. m < n ==> ~((f:num->A) m IN u n)` MP_TAC THENL - [X_GEN_TAC `m:num`; ASM SET_TAC[]] THEN - REWRITE_TAC[GSYM LE_SUC_LT] THEN - SUBGOAL_THEN `!m n. m <= n ==> (u:num->A->bool) n SUBSET u m` - MP_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN - MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN ASM SET_TAC[]]);; - -let PATH_CONNECTED_SPACE_IMP_CARD_GE = prove - (`!top:A topology. - path_connected_space top /\ hausdorff_space top /\ - ~(?a. topspace top SUBSET {a}) - ==> (:real) <=_c topspace top`, + ASM SET_TAC[]]; + (* closed_in top' v for v IN IMAGE (IMAGE f) W *) + REWRITE_TAC[FORALL_IN_IMAGE] THEN + X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [closed_map]) THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_SIMP_TAC[]]);; + +(* Engelking 5.1.33: Perfect image of paracompact Hausdorff is paracompact *) +let PARACOMPACT_SPACE_PERFECT_MAP_IMAGE = prove + (`!top top' (f:A->B). + paracompact_space top /\ hausdorff_space top /\ + perfect_map(top,top') f + ==> paracompact_space top'`, REPEAT STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o MATCH_MP (SET_RULE - `~(?a. s SUBSET {a}) ==> ?a b. a IN s /\ b IN s /\ ~(a = b)`)) THEN - REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`a:A`; `b:A`] THEN STRIP_TAC THEN - FIRST_ASSUM(MP_TAC o SPECL [`a:A`; `b:A`] o - REWRITE_RULE[path_connected_space]) THEN - ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `g:real->A` THEN STRIP_TAC THEN - FIRST_ASSUM(MP_TAC o MATCH_MP CARD_LE_SUBSET o - MATCH_MP PATH_IMAGE_SUBSET_TOPSPACE) THEN - MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ] CARD_LE_TRANS) THEN - MP_TAC(ISPEC - `subtopology (top:A topology) - (IMAGE g (topspace (subtopology euclideanreal (real_interval [&0,&1]))))` - CONNECTED_SPACE_IMP_CARD_GE) THEN - FIRST_ASSUM(MP_TAC o MATCH_MP PATH_IMAGE_SUBSET_TOPSPACE) THEN - REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; TOPSPACE_EUCLIDEANREAL; INTER_UNIV] THEN - SIMP_TAC[SET_RULE `s SUBSET u ==> u INTER s = s`] THEN - DISCH_TAC THEN DISCH_THEN MATCH_MP_TAC THEN - ASM_SIMP_TAC[HAUSDORFF_SPACE_SUBTOPOLOGY] THEN - ASM_SIMP_TAC[CONNECTED_SPACE_SUBTOPOLOGY; CONNECTED_IN_PATH_IMAGE] THEN + FIRST_ASSUM(STRIP_ASSUME_TAC o + GEN_REWRITE_RULE I [perfect_map]) THEN + FIRST_ASSUM(STRIP_ASSUME_TAC o + GEN_REWRITE_RULE I [proper_map]) THEN + (* Y is regular *) + SUBGOAL_THEN `regular_space (top':B topology)` ASSUME_TAC THENL + [MATCH_MP_TAC NORMAL_T1_IMP_REGULAR_SPACE THEN CONJ_TAC THENL + [MATCH_MP_TAC NORMAL_SPACE_PERFECT_MAP_IMAGE THEN + MAP_EVERY EXISTS_TAC [`top:A topology`; `f:A->B`] THEN + ASM_REWRITE_TAC[perfect_map; proper_map] THEN + MATCH_MP_TAC PARACOMPACT_HAUSDORFF_IMP_NORMAL_SPACE THEN + ASM_REWRITE_TAC[]; + MATCH_MP_TAC T1_SPACE_PERFECT_MAP_IMAGE THEN + MAP_EVERY EXISTS_TAC [`top:A topology`; `f:A->B`] THEN + ASM_REWRITE_TAC[perfect_map; proper_map] THEN + MATCH_MP_TAC HAUSDORFF_IMP_T1_SPACE THEN ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + (* X is regular *) + SUBGOAL_THEN `regular_space (top:A topology)` ASSUME_TAC THENL + [MATCH_MP_TAC PARACOMPACT_HAUSDORFF_IMP_REGULAR_SPACE THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Use LF_COVERING_IMP_LF_OPEN: need regular + LF closed ref property *) + REWRITE_TAC[paracompact_space] THEN + X_GEN_TAC `U':(B->bool)->bool` THEN STRIP_TAC THEN + (* Get the LF open refinement from LF_COVERING_IMP_LF_OPEN *) + MP_TAC(ISPEC `top':B topology` LF_COVERING_IMP_LF_OPEN) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN + X_GEN_TAC `B:(B->bool)->bool` THEN STRIP_TAC THEN + (* Pull back B to X *) + SUBGOAL_THEN + `(!pb. pb IN IMAGE (\b:B->bool. + {x:A | x IN topspace top /\ f x IN b}) B ==> open_in top pb) /\ + UNIONS (IMAGE (\b:B->bool. + {x:A | x IN topspace top /\ f x IN b}) B) = topspace top` + STRIP_ASSUME_TAC THENL + [CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_IMAGE] THEN REPEAT STRIP_TAC THEN + MATCH_MP_TAC OPEN_IN_CONTINUOUS_MAP_PREIMAGE THEN + EXISTS_TAC `top':B topology` THEN ASM_SIMP_TAC[]; + REWRITE_TAC[UNIONS_IMAGE; EXTENSION; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN EQ_TAC THENL + [STRIP_TAC THEN ASM_REWRITE_TAC[]; + DISCH_TAC THEN + SUBGOAL_THEN `(f:A->B) x IN UNIONS B` MP_TAC THENL + [ASM_MESON_TAC[continuous_map]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `b:B->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `b:B->bool` THEN ASM_REWRITE_TAC[IN_ELIM_THM]]]; + ALL_TAC] THEN + (* Get LF closed refinement of pullback on X *) + MP_TAC(ISPEC `top:A topology` LF_COVERING_IMP_LF_CLOSED) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN REPEAT STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [paracompact_space]) THEN + DISCH_THEN(MP_TAC o SPEC `B':(A->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `V:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `V:(A->bool)->bool` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + DISCH_THEN(MP_TAC o SPEC + `IMAGE (\b:B->bool. {x:A | x IN topspace top /\ f x IN b}) B`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `W:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Push forward W via f *) + EXISTS_TAC `IMAGE (IMAGE (f:A->B)) W` THEN + (* Use the helper lemma for LF + closed *) + MP_TAC(ISPECL [`top:A topology`; `top':B topology`; + `f:A->B`; `W:(A->bool)->bool`] LF_CLOSED_PERFECT_MAP_IMAGE) THEN + ASM_REWRITE_TAC[perfect_map; proper_map] THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + (* UNIONS = topspace top' *) + CONJ_TAC THENL + [REWRITE_TAC[UNIONS_IMAGE; EXTENSION; IN_ELIM_THM] THEN + X_GEN_TAC `y:B` THEN EQ_TAC THENL + [DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `w SUBSET topspace (top:A topology)` MP_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET]; ASM SET_TAC[]]; + DISCH_TAC THEN + SUBGOAL_THEN `?x:A. x IN topspace top /\ (f:A->B) x = y` + STRIP_ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `?w:A->bool. w IN W /\ x IN w` STRIP_ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + EXISTS_TAC `w:A->bool` THEN ASM_REWRITE_TAC[] THEN ASM SET_TAC[]]; + ALL_TAC] THEN + (* Refinement *) + REWRITE_TAC[FORALL_IN_IMAGE] THEN + X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `w:A->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `pb:A->bool` STRIP_ASSUME_TAC) THEN + UNDISCH_TAC + `pb IN IMAGE (\b:B->bool. + {x:A | x IN topspace top /\ (f:A->B) x IN b}) B` THEN + REWRITE_TAC[IN_IMAGE] THEN + DISCH_THEN(X_CHOOSE_THEN `b:B->bool` + (CONJUNCTS_THEN2 SUBST_ALL_TAC ASSUME_TAC)) THEN + EXISTS_TAC `b:B->bool` THEN ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + ALL_TAC] THEN + (* Apply the result of LF_COVERING_IMP_LF_OPEN to U' *) + DISCH_THEN(MP_TAC o SPEC `U':(B->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `W':(B->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `W':(B->bool)->bool` THEN ASM_REWRITE_TAC[]);; + +(* Engelking 5.1.28: F_sigma subspace of paracompact + Hausdorff is paracompact *) +(* Proof: Via Michael's Lemma. Build sigma-locally-finite open refinement + from ascending closed sets c(n), then Michael's Lemma (needs regularity + from Hausdorff + paracompact) converts to locally-finite. *) +let PARACOMPACT_SPACE_FSIGMA_SUBSET = prove + (`!top s:A->bool. + paracompact_space top /\ hausdorff_space top /\ fsigma_in top s + ==> paracompact_space(subtopology top s)`, + REPEAT STRIP_TAC THEN + SUBGOAL_THEN `regular_space(top:A topology)` ASSUME_TAC THENL + [ASM_MESON_TAC[PARACOMPACT_HAUSDORFF_IMP_REGULAR_SPACE]; ALL_TAC] THEN + SUBGOAL_THEN `(s:A->bool) SUBSET topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[FSIGMA_IN_SUBSET]; ALL_TAC] THEN + MATCH_MP_TAC(REWRITE_RULE[IMP_IMP] + (REWRITE_RULE[GSYM paracompact_space] + (ISPEC `subtopology top (s:A->bool)` MICHAEL_LEMMA))) THEN CONJ_TAC THENL - [MATCH_MP_TAC COMPACT_HAUSDORFF_OR_REGULAR_IMP_NORMAL_SPACE THEN - ASM_SIMP_TAC[HAUSDORFF_SPACE_SUBTOPOLOGY] THEN - ASM_SIMP_TAC[COMPACT_IN_PATH_IMAGE; COMPACT_SPACE_SUBTOPOLOGY]; - MP_TAC ENDS_IN_UNIT_REAL_INTERVAL THEN ASM SET_TAC[]]);; - -let CONNECTED_SPACE_IMP_UNCOUNTABLE = prove - (`!top:A topology. - connected_space top /\ regular_space top /\ hausdorff_space top /\ - ~(?a. topspace top SUBSET {a}) - ==> ~COUNTABLE(topspace top)`, + [ASM_MESON_TAC[REGULAR_SPACE_SUBTOPOLOGY]; ALL_TAC] THEN + (* Sigma-locally-finite refinement property for subtopology top s *) + SUBGOAL_THEN `topspace(subtopology top s:A topology) = (s:A->bool)` + (fun th -> RULE_ASSUM_TAC(REWRITE_RULE[th]) THEN REWRITE_TAC[th]) THENL + [ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY; + SET_RULE `(s:A->bool) SUBSET t ==> t INTER s = s`]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [FSIGMA_IN_ASCENDING]) THEN + DISCH_THEN(X_CHOOSE_THEN `c:num->A->bool` STRIP_ASSUME_TAC) THEN + X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + (* Lift open-in-subtopology to open-in-top *) + SUBGOAL_THEN + `?g:(A->bool)->(A->bool). !u:A->bool. u IN U + ==> open_in top (g u) /\ u = g u INTER s` + STRIP_ASSUME_TAC THENL + [REWRITE_TAC[GSYM SKOLEM_THM_GEN] THEN + X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `u:A->bool`) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN + MATCH_MP_TAC MONO_EXISTS THEN GEN_TAC THEN MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `(s:A->bool) SUBSET UNIONS(IMAGE (g:(A->bool)->(A->bool)) U)` + ASSUME_TAC THENL + [REWRITE_TAC[SUBSET; IN_UNIONS; EXISTS_IN_IMAGE] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN UNIONS U` MP_TAC THENL + [ASM_MESON_TAC[]; REWRITE_TAC[IN_UNIONS]] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `u:A->bool` THEN ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[IN_INTER]; + ALL_TAC] THEN + (* For each n, apply paracompactness to augmented cover *) + SUBGOAL_THEN + `!n:num. ?W:(A->bool)->bool. + (!w. w IN W ==> open_in top w) /\ + UNIONS W = topspace top /\ + (!w. w IN W ==> + ?v. v IN IMAGE (g:(A->bool)->(A->bool)) U UNION + {topspace top DIFF (c:num->A->bool) n} /\ + w SUBSET v) /\ + locally_finite_in top W` MP_TAC THENL + [X_GEN_TAC `n:num` THEN + UNDISCH_TAC `paracompact_space (top:A topology)` THEN + REWRITE_TAC[paracompact_space] THEN + DISCH_THEN(MP_TAC o SPEC + `IMAGE (g:(A->bool)->(A->bool)) U UNION + {topspace top DIFF (c:num->A->bool) n}`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [REWRITE_TAC[IN_UNION; IN_IMAGE; IN_SING] THEN + GEN_TAC THEN STRIP_TAC THENL + [ASM_MESON_TAC[]; + ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_TOPSPACE]]; + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; IN_UNION; IN_IMAGE; IN_SING] THEN + GEN_TAC THEN STRIP_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET]; ASM SET_TAC[]]; + REWRITE_TAC[SUBSET; IN_UNIONS; IN_UNION; IN_IMAGE; IN_SING] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + ASM_CASES_TAC `(x:A) IN s` THENL + [UNDISCH_TAC + `s SUBSET UNIONS(IMAGE (g:(A->bool)->(A->bool)) U)` THEN + REWRITE_TAC[SUBSET; IN_UNIONS; EXISTS_IN_IMAGE] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(g:(A->bool)->(A->bool)) u` THEN + CONJ_TAC THENL + [DISJ1_TAC THEN EXISTS_TAC `u:A->bool` THEN ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[]]; + EXISTS_TAC `topspace top DIFF (c:num->A->bool) n` THEN + CONJ_TAC THENL [DISJ2_TAC THEN REFL_TAC; ALL_TAC] THEN + REWRITE_TAC[IN_DIFF] THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `UNIONS {(c:num->A->bool) n | n IN (:num)} = s` THEN + UNDISCH_TAC `~((x:A) IN s)` THEN + REWRITE_TAC[EXTENSION; IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + MESON_TAC[]]]]; + DISCH_THEN ACCEPT_TAC]; + ALL_TAC] THEN REWRITE_TAC[SKOLEM_THM] THEN + DISCH_THEN(X_CHOOSE_TAC `W:num->(A->bool)->bool`) THEN + (* Witness: UNIONS of {w INTER s | w IN W(n), + w NOT SUBSET topspace\c(n)} for all n *) + EXISTS_TAC + `UNIONS {{w INTER (s:A->bool) |w| + w IN (W:num->(A->bool)->bool) n /\ + ~(w SUBSET topspace top DIFF (c:num->A->bool) n)} | + n IN (:num)}` THEN + REPEAT CONJ_TAC THENL + [(* Open in subtopology *) + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + X_GEN_TAC `v:A->bool` THEN + DISCH_THEN(X_CHOOSE_THEN `B:(A->bool)->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_THEN `n:num` STRIP_ASSUME_TAC) + ASSUME_TAC)) THEN + UNDISCH_TAC `(v:A->bool) IN B` THEN ASM_REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN EXISTS_TAC `w:A->bool` THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; REFL_TAC]; + (* UNIONS covers s *) + GEN_REWRITE_TAC I [EXTENSION] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + X_GEN_TAC `x:A` THEN EQ_TAC THENL + [DISCH_THEN(X_CHOOSE_THEN `v:A->bool` + (CONJUNCTS_THEN2 + (X_CHOOSE_THEN `B:(A->bool)->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_THEN `n:num` STRIP_ASSUME_TAC) + ASSUME_TAC)) + ASSUME_TAC)) THEN + UNDISCH_TAC `(v:A->bool) IN B` THEN ASM_REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + ASM_MESON_TAC[IN_INTER]; + DISCH_TAC THEN + SUBGOAL_THEN `?n:num. (x:A) IN c n` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `UNIONS {(c:num->A->bool) n | n IN (:num)} = s` THEN + REWRITE_TAC[EXTENSION; IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `(x:A) IN topspace top` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `n:num`) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 (fun th -> + ASSUME_TAC th) STRIP_ASSUME_TAC)) THEN + SUBGOAL_THEN `(x:A) IN UNIONS((W:num->(A->bool)->bool) n)` MP_TAC THENL + [ASM_MESON_TAC[EXTENSION]; REWRITE_TAC[IN_UNIONS]] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `w INTER (s:A->bool)` THEN CONJ_TAC THENL + [EXISTS_TAC `{w' INTER (s:A->bool) |w'| + w' IN (W:num->(A->bool)->bool) n /\ + ~(w' SUBSET topspace top DIFF (c:num->A->bool) n)}` THEN + CONJ_TAC THENL + [EXISTS_TAC `n:num` THEN REWRITE_TAC[]; + REWRITE_TAC[IN_ELIM_THM] THEN EXISTS_TAC `w:A->bool` THEN + ASM SET_TAC[]]; + REWRITE_TAC[IN_INTER] THEN ASM_REWRITE_TAC[]]]; + (* Refines U *) + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + X_GEN_TAC `v:A->bool` THEN + DISCH_THEN(X_CHOOSE_THEN `B:(A->bool)->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_THEN `n:num` STRIP_ASSUME_TAC) + ASSUME_TAC)) THEN + UNDISCH_TAC `(v:A->bool) IN B` THEN ASM_REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN + `?v':(A->bool). v' IN IMAGE (g:(A->bool)->(A->bool)) U UNION + {topspace top DIFF (c:num->A->bool) n} /\ + (w:A->bool) SUBSET v'` + MP_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `v':A->bool` + (CONJUNCTS_THEN2 + (fun th -> MP_TAC(REWRITE_RULE[IN_UNION; IN_IMAGE; IN_SING] th)) + ASSUME_TAC)) THEN + DISCH_THEN(DISJ_CASES_THEN2 + (X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) + ASSUME_TAC) THENL + [EXISTS_TAC `u:A->bool` THEN CONJ_TAC THENL + [ASM_REWRITE_TAC[]; + SUBGOAL_THEN `(u:A->bool) = g u INTER s` SUBST1_TAC THENL + [ASM_MESON_TAC[]; ASM SET_TAC[]]]; + ASM_MESON_TAC[]]; + (* Sigma-locally-finite *) + REWRITE_TAC[sigma_locally_finite_in] THEN + EXISTS_TAC `\n:num. {w INTER (s:A->bool) |w| + w IN (W:num->(A->bool)->bool) n /\ + ~(w SUBSET topspace top DIFF (c:num->A->bool) n)}` THEN + CONJ_TAC THENL + [X_GEN_TAC `n:num` THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + MATCH_MP_TAC LOCALLY_FINITE_IN_SUBTOPOLOGY THEN + FIRST_X_ASSUM(MP_TAC o SPEC `n:num`) THEN STRIP_TAC THEN + CONJ_TAC THENL + [UNDISCH_TAC + `locally_finite_in (top:A topology) + ((W:num->(A->bool)->bool) n)` THEN + REWRITE_TAC[locally_finite_in] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + DISCH_THEN(fun th -> CONJ_TAC THENL + [REWRITE_TAC[IN_ELIM_THM] THEN + REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[OPEN_IN_SUBSET; INTER_SUBSET; SUBSET_TRANS]; + MP_TAC th]) THEN + MATCH_MP_TAC MONO_FORALL THEN X_GEN_TAC `a:A` THEN + MATCH_MP_TAC MONO_IMP THEN CONJ_TAC THENL + [SIMP_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `N:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `N:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `{t | t IN {w INTER (s:A->bool) |w| + w IN (W:num->(A->bool)->bool) n} /\ + ~(t INTER N = {})}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `IMAGE (\w. w INTER (s:A->bool)) + {w | w IN (W:num->(A->bool)->bool) n /\ + ~(w INTER N = {})}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[SUBSET; IN_IMAGE; IN_ELIM_THM] THEN + X_GEN_TAC `t:A->bool` THEN STRIP_TAC THEN + EXISTS_TAC `w:A->bool` THEN ASM_REWRITE_TAC[] THEN + ASM SET_TAC[]]; + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `t:A->bool` THEN STRIP_TAC THEN + CONJ_TAC THENL [ALL_TAC; ASM_REWRITE_TAC[]] THEN + ASM_REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `w:A->bool` THEN ASM_REWRITE_TAC[]]; + REWRITE_TAC[IN_ELIM_THM] THEN REPEAT STRIP_TAC THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]]; + CONV_TAC(DEPTH_CONV BETA_CONV) THEN REFL_TAC]] + );; + +(* Helper for product theorem: locally finite in product *) +(* {w CROSS topspace INTER u | w IN W, u IN Ux(xw w)} is l.f. + when W is l.f. For (x,y), use Nx CROSS topspace where Nx + meets finitely many W-elements; each contributes finitely + many u's from Ux(xw w). *) +let LOCALLY_FINITE_PRODUCT_TUBES = prove + (`!(top:A topology) (top':B topology) W U Ux xw. + locally_finite_in top W /\ + (!w. w IN W ==> FINITE (Ux((xw:(A->bool)->A) w))) /\ + (!w. w IN W ==> Ux(xw w) SUBSET U) /\ + (!u. u IN U ==> open_in (prod_topology top top') u) + ==> locally_finite_in (prod_topology top top') + {(w:A->bool) CROSS topspace top' INTER (u:(A#B)->bool) | + w IN W /\ u IN Ux(xw w)}`, + (* The proof: for (x,y) in product space, since W is l.f., there exists Nx + meeting finitely many W-elements. Use Nx CROSS topspace as neighborhood. + Any intersecting tube must have w meeting Nx; finitely + many w, each with finite Ux(xw w), so finitely many. *) REPEAT STRIP_TAC THEN - MP_TAC(ISPEC `top:A topology` CONNECTED_SPACE_IMP_CARD_GE) THEN - ASM_SIMP_TAC[NOT_IMP; CARD_NOT_LE; COUNTABLE_IMP_CARD_LT_REAL] THEN - MATCH_MP_TAC REGULAR_LINDELOF_IMP_NORMAL_SPACE THEN - ASM_SIMP_TAC[COUNTABLE_IMP_LINDELOF_SPACE]);; - -let PATH_CONNECTED_SPACE_IMP_UNCOUNTABLE = prove - (`!top:A topology. - path_connected_space top /\ t1_space top /\ - ~(?a. topspace top SUBSET {a}) - ==> ~COUNTABLE(topspace top)`, - REPEAT STRIP_TAC THEN FIRST_X_ASSUM(MP_TAC o MATCH_MP (SET_RULE - `~(?a. s SUBSET {a}) ==> ?a b. a IN s /\ b IN s /\ ~(a = b)`)) THEN - REWRITE_TAC[NOT_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`a:A`; `b:A`] THEN STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`a:A`; `b:A`] o - REWRITE_RULE[path_connected_space]) THEN - ASM_REWRITE_TAC[NOT_EXISTS_THM; path_in] THEN - X_GEN_TAC `g:real->A` THEN STRIP_TAC THEN - MP_TAC(ISPECL - [`&0:real`; `&1:real`; - `{{x | x IN topspace(subtopology euclideanreal (real_interval[&0,&1])) /\ - (g:real->A) x IN {a}} | - a IN topspace top} DELETE {}`] REAL_SIERPINSKI_LEMMA) THEN - ASM_SIMP_TAC[SIMPLE_IMAGE; COUNTABLE_IMAGE; COUNTABLE_DELETE] THEN - REWRITE_TAC[IMP_CONJ; FORALL_IN_IMAGE; IN_DELETE] THEN - REWRITE_TAC[REAL_POS; NOT_IMP] THEN REPEAT CONJ_TAC THENL - [MATCH_MP_TAC(MATCH_MP (REWRITE_RULE[IMP_CONJ_ALT] PAIRWISE_MONO) - (SET_RULE `s DELETE a SUBSET s`)) THEN - REWRITE_TAC[PAIRWISE_IMAGE] THEN REWRITE_TAC[pairwise] THEN SET_TAC[]; - X_GEN_TAC `x:A` THEN REWRITE_TAC[IMP_IMP] THEN - STRIP_TAC THEN ASM_REWRITE_TAC[REAL_CLOSED_IN] THEN - MATCH_MP_TAC CLOSED_IN_TRANS_FULL THEN - EXISTS_TAC `real_interval[&0,&1]` THEN - REWRITE_TAC[GSYM REAL_CLOSED_IN; REAL_CLOSED_REAL_INTERVAL] THEN - FIRST_ASSUM(MATCH_MP_TAC o MATCH_MP (REWRITE_RULE[IMP_CONJ] - CLOSED_IN_CONTINUOUS_MAP_PREIMAGE)) THEN - ASM_MESON_TAC[T1_SPACE_CLOSED_IN_SING]; - FIRST_ASSUM(MP_TAC o MATCH_MP CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE) THEN - REWRITE_TAC[UNIONS_IMAGE; TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN - REWRITE_TAC[UNIONS_DELETE_EMPTY; UNIONS_IMAGE] THEN ASM SET_TAC[]; - MATCH_MP_TAC(SET_RULE - `!a b. a IN s /\ b IN s /\ ~(f a = z) /\ ~(f b = z) /\ ~(f a = f b) - ==> ~(IMAGE f s DELETE z = {c})`) THEN - MAP_EVERY EXISTS_TAC [`a:A`; `b:A`] THEN - ASM_REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN - MATCH_MP_TAC(SET_RULE `(p /\ q ==> r) /\ p /\ q ==> p /\ q /\ r`) THEN - CONJ_TAC THENL [ASM SET_TAC[]; REWRITE_TAC[GSYM MEMBER_NOT_EMPTY]] THEN - CONJ_TAC THENL [EXISTS_TAC `&0:real`; EXISTS_TAC `&1:real`] THEN - ASM_REWRITE_TAC[IN_ELIM_THM; IN_SING] THEN - REWRITE_TAC[ENDS_IN_REAL_INTERVAL; REAL_INTERVAL_NE_EMPTY; REAL_POS]]);; - -(* ------------------------------------------------------------------------- *) -(* The Tychonoff embedding. *) -(* ------------------------------------------------------------------------- *) + REWRITE_TAC[locally_finite_in; TOPSPACE_PROD_TOPOLOGY; FORALL_PAIR_THM; + IN_CROSS] THEN + CONJ_TAC THENL + [(* All elements are subsets of the product topspace *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN + MAP_EVERY X_GEN_TAC [`w:A->bool`; `u:(A#B)->bool`] THEN STRIP_TAC THEN + (* w SUBSET topspace from l.f., u SUBSET prod_topspace + from open, so w CROSS topspace INTER u SUBSET prod *) + RULE_ASSUM_TAC(REWRITE_RULE[locally_finite_in]) THEN + SUBGOAL_THEN `(w:A->bool) SUBSET topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `(u:(A#B)->bool) SUBSET topspace (prod_topology top top')` + ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; ALL_TAC] THEN + REWRITE_TAC[TOPSPACE_PROD_TOPOLOGY] THEN + FIRST_X_ASSUM(MP_TAC o REWRITE_RULE[TOPSPACE_PROD_TOPOLOGY]) THEN + ASM SET_TAC[]; + ALL_TAC] THEN + (* For any (x,y), find a neighborhood meeting finitely many tubes *) + MAP_EVERY X_GEN_TAC [`x:A`; `y:B`] THEN STRIP_TAC THEN + (* Since W is l.f., get Nx meeting finitely many W-elements *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [locally_finite_in]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `x:A`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `Nx:A->bool` STRIP_ASSUME_TAC) THEN + (* The finite set of W-elements meeting Nx *) + ABBREV_TAC `W' = {w:A->bool | w IN W /\ ~(w INTER Nx = {})}` THEN + (* Use Nx CROSS topspace as our neighborhood *) + EXISTS_TAC `(Nx:A->bool) CROSS topspace (top':B topology)` THEN + REPEAT CONJ_TAC THENL + [(* Nx CROSS topspace is open *) + ASM_SIMP_TAC[OPEN_IN_CROSS; OPEN_IN_TOPSPACE]; + (* (x,y) IN Nx CROSS topspace *) + ASM_REWRITE_TAC[IN_CROSS]; + (* The finite set of tubes meeting Nx CROSS topspace *) + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `{(w:A->bool) CROSS topspace top' INTER (u:(A#B)->bool) | + w IN W' /\ u IN (Ux:A->((A#B)->bool)->bool)((xw:(A->bool)->A) w)}` THEN + CONJ_TAC THENL + [(* This is finite: W' is finite, each Ux(xw w) is finite *) + SUBGOAL_THEN `{(w:A->bool) CROSS topspace top' INTER (u:(A#B)->bool) | + w IN W' /\ u IN (Ux:A->((A#B)->bool)->bool)((xw:(A->bool)->A) w)} = + UNIONS (IMAGE (\w. IMAGE (\u. w CROSS topspace top' INTER u) + (Ux((xw:(A->bool)->A) w))) W')` + SUBST1_TAC THENL + [REWRITE_TAC[EXTENSION; IN_UNIONS; IN_IMAGE; + EXISTS_IN_IMAGE; IN_ELIM_THM] THEN + SET_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[FINITE_UNIONS] THEN CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN + EXPAND_TAC "W'" THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[FORALL_IN_IMAGE] THEN GEN_TAC THEN DISCH_TAC THEN + MATCH_MP_TAC FINITE_IMAGE THEN + SUBGOAL_THEN `(x':A->bool) IN W` ASSUME_TAC THENL + [EXPAND_TAC "W'" THEN ASM SET_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]]; + (* Subset: any tube meeting Nx CROSS topspace has w IN W' *) + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + MAP_EVERY X_GEN_TAC [`s:(A#B)->bool`] THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `w:A->bool` (X_CHOOSE_THEN `u:(A#B)->bool` STRIP_ASSUME_TAC)) + MP_TAC) THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER; IN_CROSS] THEN + DISCH_THEN(X_CHOOSE_THEN `p:A#B` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `w:A->bool` THEN EXISTS_TAC `u:(A#B)->bool` THEN + ASM_REWRITE_TAC[] THEN EXPAND_TAC "W'" THEN + REWRITE_TAC[IN_ELIM_THM] THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + EXISTS_TAC `FST(p:A#B)` THEN + (* FST p IN w /\ FST p IN Nx follow from: + p IN w CROSS topspace top' ==> FST p IN w, and + p IN Nx CROSS topspace top' ==> FST p IN Nx *) + CONJ_TAC THENL + [UNDISCH_TAC `p:(A#B) IN (w:A->bool) CROSS topspace top'` THEN + GEN_REWRITE_TAC (LAND_CONV o ONCE_DEPTH_CONV) [GSYM PAIR] THEN + REWRITE_TAC[IN_CROSS] THEN DISCH_THEN(fun th -> ACCEPT_TAC(CONJUNCT1 th)); + UNDISCH_TAC `p:(A#B) IN (Nx:A->bool) CROSS topspace top'` THEN + GEN_REWRITE_TAC (LAND_CONV o ONCE_DEPTH_CONV) [GSYM PAIR] THEN + REWRITE_TAC[IN_CROSS] THEN + DISCH_THEN(fun th -> ACCEPT_TAC(CONJUNCT1 th))]]]);; + +(* Helper for product theorem: tube lemma combined with compactness *) +(* Uses compactness to extract finite subcover, then applies tube lemma *) +let COMPACT_TUBE_COVER = prove + (`!(top:A topology) (top':B topology) x U. + compact_space top' /\ + x IN topspace top /\ + (!u. u IN U ==> open_in (prod_topology top top') u) /\ + {x} CROSS topspace top' SUBSET UNIONS U + ==> ?v Ux. open_in top v /\ x IN v /\ + FINITE Ux /\ Ux SUBSET (U:((A#B)->bool)->bool) /\ + v CROSS topspace top' SUBSET UNIONS Ux`, + REPEAT STRIP_TAC THEN + (* Step 1: {x} CROSS topspace top' is compact *) + SUBGOAL_THEN `compact_in (prod_topology top top') + ({x:A} CROSS topspace (top':B topology))` ASSUME_TAC THENL + [REWRITE_TAC[COMPACT_IN_CROSS; NOT_INSERT_EMPTY] THEN DISJ2_TAC THEN + ASM_REWRITE_TAC[COMPACT_IN_SING; GSYM compact_space]; + ALL_TAC] THEN + (* Step 2: By compactness, get finite subcover *) + FIRST_X_ASSUM(MP_TAC o REWRITE_RULE[compact_in]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPEC `U:((A#B)->bool)->bool`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `Ux:((A#B)->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Step 3: Apply TUBE_LEMMA_RIGHT to UNIONS Ux *) + MP_TAC(ISPECL [`top:A topology`; `top':B topology`; `x:A`; + `topspace (top':B topology)`; `UNIONS Ux:(A#B)->bool`] + TUBE_LEMMA_RIGHT) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_UNIONS THEN ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + ASM_REWRITE_TAC[GSYM compact_space]; + ALL_TAC] THEN REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`u:A->bool`; `v:B->bool`] THEN STRIP_TAC THEN + (* Step 4: u is the desired tube *) + EXISTS_TAC `u:A->bool` THEN EXISTS_TAC `Ux:((A#B)->bool)->bool` THEN + ASM_REWRITE_TAC[] THEN + (* u CROSS topspace top' SUBSET u CROSS v SUBSET UNIONS Ux *) + TRANS_TAC SUBSET_TRANS `(u:A->bool) CROSS (v:B->bool)` THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[SUBSET_CROSS; SUBSET_REFL] THEN ASM_REWRITE_TAC[]);; -let COMPLETELY_REGULAR_SPACE_CUBE_EMBEDDING_EXPLICIT = prove - (`!top:A topology. - completely_regular_space top /\ hausdorff_space top - ==> embedding_map - (top, - product_topology - (mspace (submetric (cfunspace top real_euclidean_metric) - {f | IMAGE f (topspace top) SUBSET real_interval [&0,&1]})) - (\f. subtopology euclideanreal (real_interval [&0,&1]))) - (\x. RESTRICTION - (mspace (submetric (cfunspace top real_euclidean_metric) - {f | IMAGE f (topspace top) SUBSET real_interval [&0,&1]})) - (\f. f x))`, +(* Engelking 5.1.36: Product of paracompact with compact is paracompact *) +(* Proof uses tube lemma: for each x, {x} CROSS Y is compact, so finitely many + elements of the cover suffice, and they extend to a tube Vx CROSS Y. + Apply paracompactness to {Vx}, then use LOCALLY_FINITE_PRODUCT_TUBES. *) +let PARACOMPACT_SPACE_PRODUCT_COMPACT_LEFT = prove + (`!(top:A topology) (top':B topology). + paracompact_space top /\ compact_space top' + ==> paracompact_space(prod_topology top top')`, REPEAT STRIP_TAC THEN - MAP_EVERY ABBREV_TAC - [`k = mspace(submetric (cfunspace top real_euclidean_metric) - {f | IMAGE f (topspace top:A->bool) SUBSET - real_interval[&0,&1]})`; - `e = \x. RESTRICTION k (\f:A->real. f x)`] THEN + REWRITE_TAC[paracompact_space; TOPSPACE_PROD_TOPOLOGY] THEN + X_GEN_TAC `U:((A#B)->bool)->bool` THEN STRIP_TAC THEN + (* Step 1: For each x, apply COMPACT_TUBE_COVER *) + (* Get Vx, finite Ux SUBSET U with Vx CROSS top' SUBSET UNIONS Ux *) SUBGOAL_THEN - `!x y. x IN topspace top /\ y IN topspace top - ==> ((e:A->(A->real)->real) x = e y <=> x = y)` - ASSUME_TAC THENL - [MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN - EQ_TAC THEN SIMP_TAC[] THEN GEN_REWRITE_TAC I [GSYM CONTRAPOS_THM] THEN - DISCH_TAC THEN EXPAND_TAC "e" THEN REWRITE_TAC[] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [completely_regular_space]) THEN - DISCH_THEN(MP_TAC o SPECL [`{x:A}`; `y:A`]) THEN - ASM_SIMP_TAC[IN_DIFF; IN_SING; CLOSED_IN_HAUSDORFF_SING] THEN - REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; FORALL_UNWIND_THM2] THEN - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `f:A->real`THEN REWRITE_TAC[IN_REAL_INTERVAL] THEN STRIP_TAC THEN - DISCH_THEN(MP_TAC o C AP_THM `RESTRICTION(topspace top) (f:A->real)`) THEN - ASM_REWRITE_TAC[RESTRICTION] THEN COND_CASES_TAC THEN - ASM_REWRITE_TAC[] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN - FIRST_X_ASSUM(MP_TAC o check (is_neg o concl)) THEN - EXPAND_TAC "k" THEN REWRITE_TAC[SUBMETRIC] THEN - SIMP_TAC[CFUNSPACE; IN_ELIM_THM; IN_INTER; RESTRICTION_IN_EXTENSIONAL] THEN - REWRITE_TAC[REAL_EUCLIDEAN_METRIC; IN_UNIV] THEN - SIMP_TAC[IMAGE_RESTRICTION; RESTRICTION_CONTINUOUS_MAP; SUBSET_REFL] THEN - ASM_REWRITE_TAC[MTOPOLOGY_REAL_EUCLIDEAN_METRIC] THEN - ASM_SIMP_TAC[SUBSET; FORALL_IN_IMAGE; IN_REAL_INTERVAL] THEN - REWRITE_TAC[MBOUNDED_REAL_EUCLIDEAN_METRIC; real_bounded] THEN - EXISTS_TAC `&1` THEN REWRITE_TAC[FORALL_IN_IMAGE] THEN - ASM_SIMP_TAC[real_abs]; - FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM INJECTIVE_ON_ALT])] THEN - REWRITE_TAC[INJECTIVE_ON_LEFT_INVERSE] THEN - DISCH_THEN(X_CHOOSE_TAC `e':((A->real)->real)->A`) THEN - REWRITE_TAC[embedding_map; HOMEOMORPHIC_MAP_MAPS] THEN - EXISTS_TAC `e':((A->real)->real)->A` THEN - ASM_REWRITE_TAC[homeomorphic_maps; TOPSPACE_SUBTOPOLOGY] THEN - ASM_SIMP_TAC[IN_INTER; IMP_CONJ_ALT; FORALL_IN_IMAGE] THEN CONJ_TAC THENL - [REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET_REFL] THEN - REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE; SUBSET; FORALL_IN_IMAGE] THEN - EXPAND_TAC "e" THEN REWRITE_TAC[RESTRICTION_IN_EXTENSIONAL] THEN - X_GEN_TAC `f:A->real` THEN SIMP_TAC[RESTRICTION] THEN EXPAND_TAC "k" THEN - REWRITE_TAC[SUBMETRIC; CFUNSPACE; IN_ELIM_THM] THEN - SIMP_TAC[IN_ELIM_THM; CONTINUOUS_MAP_IN_SUBTOPOLOGY; ETA_AX; IN_INTER; - MTOPOLOGY_REAL_EUCLIDEAN_METRIC]; + `!x:A. x IN topspace top + ==> ?v (Ux:((A#B)->bool)->bool). open_in top v /\ x IN v /\ + FINITE Ux /\ Ux SUBSET U /\ + (v:A->bool) CROSS topspace top' SUBSET UNIONS Ux` + ASSUME_TAC THENL + [X_GEN_TAC `x:A` THEN DISCH_TAC THEN + MATCH_MP_TAC COMPACT_TUBE_COVER THEN ASM_REWRITE_TAC[] THEN + (* {x} CROSS topspace top' SUBSET UNIONS U = + topspace top CROSS topspace top' *) + REWRITE_TAC[SUBSET; FORALL_PAIR_THM; IN_CROSS; IN_SING; IN_UNIONS] THEN + MAP_EVERY X_GEN_TAC [`a:A`; `b:B`] THEN STRIP_TAC THEN + ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [EXTENSION]) THEN + DISCH_THEN(MP_TAC o SPEC `(x:A,b:B)`) THEN + REWRITE_TAC[IN_UNIONS; IN_CROSS] THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Skolemize: choice functions Vx : A -> A->bool, Ux : A -> P(P(A#B)) *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [SKOLEM_THM_GEN]) THEN + DISCH_THEN(X_CHOOSE_THEN `V:A->(A->bool)` MP_TAC) THEN + REWRITE_TAC[SKOLEM_THM_GEN] THEN + DISCH_THEN(X_CHOOSE_THEN `Ux:A->((A#B)->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Step 2: {V x | x IN topspace top} is an open cover of topspace top *) + (* Apply paracompactness of top to get locally finite refinement W *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [paracompact_space]) THEN + DISCH_THEN(MP_TAC o SPEC `{(V:A->(A->bool)) x | x IN topspace top}`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_GSPEC] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + (* UNIONS covers topspace *) + REWRITE_TAC[EXTENSION; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN EQ_TAC THENL + [STRIP_TAC THEN ASM_MESON_TAC[locally_finite_in; OPEN_IN_SUBSET; SUBSET]; + DISCH_TAC THEN EXISTS_TAC `(V:A->(A->bool)) x` THEN + ASM_MESON_TAC[]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `W:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Step 3: For each w IN W, pick xw IN topspace top such that w SUBSET V(xw) *) + SUBGOAL_THEN + `?xw:(A->bool)->A. !w. w IN W ==> xw w IN topspace top /\ w SUBSET V(xw w)` + STRIP_ASSUME_TAC THENL + [REWRITE_TAC[GSYM SKOLEM_THM_GEN] THEN X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `w:A->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_ELIM_THM]) THEN + STRIP_TAC THEN EXISTS_TAC `x:A` THEN ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[SUBSET_TRANS]; + ALL_TAC] THEN + (* Step 4: Refinement is {w CROSS topspace INTER u} *) + EXISTS_TAC `{(w:A->bool) CROSS topspace top' INTER (u:(A#B)->bool) | + w IN W /\ u IN (Ux:A->((A#B)->bool)->bool)((xw:(A->bool)->A) w)}` THEN + REPEAT CONJ_TAC THENL + [(* Each element is open *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN + MAP_EVERY X_GEN_TAC [`w:A->bool`; `u:(A#B)->bool`] THEN STRIP_TAC THEN + MATCH_MP_TAC OPEN_IN_INTER THEN CONJ_TAC THENL + [ASM_SIMP_TAC[OPEN_IN_CROSS; OPEN_IN_TOPSPACE]; + ASM_MESON_TAC[SUBSET]]; + (* Covers the product space *) + REWRITE_TAC[EXTENSION; IN_UNIONS; IN_ELIM_THM; FORALL_PAIR_THM; IN_CROSS] THEN + MAP_EVERY X_GEN_TAC [`x:A`; `y:B`] THEN EQ_TAC THENL + [(* Forward: (x,y) in some tube => x in topspace, y in topspace' *) + (* STRIP_ASSUME_TAC already eliminates existentials from s IN {...}, + giving us w, u as free variables with w IN W, u IN Ux(xw w), + and a biconditional for s *) + DISCH_THEN(X_CHOOSE_THEN `s:(A#B)->bool` STRIP_ASSUME_TAC) THEN + (* Rewrite assumptions to extract membership facts *) + RULE_ASSUM_TAC(REWRITE_RULE[IN_INTER; IN_CROSS; FORALL_PAIR_THM]) THEN + (* y IN topspace top' from (x,y) IN w CROSS topspace top' INTER u + x IN w and W locally finite => x IN topspace *) + RULE_ASSUM_TAC(REWRITE_RULE[locally_finite_in]) THEN + ASM_MESON_TAC[SUBSET]; + STRIP_TAC THEN + (* (x,y) IN topspace CROSS topspace, so x IN UNIONS W *) + SUBGOAL_THEN `(x:A) IN UNIONS W` MP_TAC THENL + [FIRST_X_ASSUM(fun th -> GEN_REWRITE_TAC RAND_CONV [th]) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + (* x IN V(xw w) CROSS topspace, which is SUBSET UNIONS Ux *) + SUBGOAL_THEN `(x:A,y:B) IN UNIONS ((Ux:A->((A#B)->bool)->bool)((xw:(A->bool)->A) w))` + MP_TAC THENL + [(* Use: V(xw w) CROSS topspace top' SUBSET UNIONS(Ux(xw w)) *) + (* and: x IN w, w SUBSET V(xw w) => x IN V(xw w) *) + (* and: y IN topspace top' *) + FIRST_X_ASSUM(MP_TAC o SPEC `(xw:(A->bool)->A) w`) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + STRIP_TAC THEN + FIRST_X_ASSUM(MATCH_MP_TAC o REWRITE_RULE[SUBSET]) THEN + REWRITE_TAC[IN_CROSS] THEN ASM_MESON_TAC[SUBSET]; + ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `u:(A#B)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(w:A->bool) CROSS topspace top' INTER (u:(A#B)->bool)` THEN + CONJ_TAC THENL + [EXISTS_TAC `w:A->bool` THEN + EXISTS_TAC `u:(A#B)->bool` THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[IN_INTER; IN_CROSS] THEN ASM_REWRITE_TAC[]]]; + (* Each element is a subset of some u IN U *) + (* Goal is Skolemized: ?f. !v. v IN {...} ==> f v IN U /\ v SUBSET f v *) + (* Provide a choice function that extracts the u component *) + EXISTS_TAC `\v:(A#B)->bool. @u:(A#B)->bool. + ?w:A->bool. + (w IN W /\ + u IN (Ux:A->((A#B)->bool)->bool)((xw:(A->bool)->A) w)) /\ + v = w CROSS topspace top' INTER u` THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN + MAP_EVERY X_GEN_TAC [`w:A->bool`; `u:(A#B)->bool`] THEN STRIP_TAC THEN + REWRITE_TAC[] THEN + (* Use SELECT_AX: if ?x. P x, then P(@x. P x) *) + (* First show there exists a witness (namely u) *) + SUBGOAL_THEN + `?u':(A#B)->bool. ?w':A->bool. + (w' IN W /\ + u' IN (Ux:A->((A#B)->bool)->bool)((xw:(A->bool)->A) w')) /\ + (w:A->bool) CROSS topspace top' INTER (u:(A#B)->bool) = + w' CROSS topspace top' INTER u'` + MP_TAC THENL + [EXISTS_TAC `u:(A#B)->bool` THEN EXISTS_TAC `w:A->bool` THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN - REWRITE_TAC[CONTINUOUS_MAP_ATPOINTOF; TOPSPACE_SUBTOPOLOGY] THEN - REWRITE_TAC[IN_INTER; IMP_CONJ_ALT; FORALL_IN_IMAGE] THEN - X_GEN_TAC `x:A` THEN ASM_SIMP_TAC[] THEN REPEAT DISCH_TAC THEN - ASM_REWRITE_TAC[LIMIT_ATPOINTOF] THEN DISCH_THEN(K ALL_TAC) THEN - X_GEN_TAC `u:A->bool` THEN STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`topspace top DIFF u:A->bool`; `x:A`] o - GEN_REWRITE_RULE I [completely_regular_space]) THEN - ASM_SIMP_TAC[CLOSED_IN_DIFF; CLOSED_IN_TOPSPACE; IN_DIFF] THEN - DISCH_THEN(X_CHOOSE_THEN `g:A->real` STRIP_ASSUME_TAC) THEN - REWRITE_TAC[OPEN_IN_SUBTOPOLOGY_ALT; EXISTS_IN_GSPEC] THEN - EXISTS_TAC - `cartesian_product (k:(A->real)->bool) - (\f. if f = RESTRICTION (topspace top) g - then real_interval[&0,&1] DELETE &1 - else real_interval[&0,&1])` THEN - REWRITE_TAC[OPEN_IN_CARTESIAN_PRODUCT_GEN] THEN - REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN - REPEAT(CONJ_TAC ORELSE DISJ2_TAC) THENL - [MATCH_MP_TAC FINITE_SUBSET THEN - EXISTS_TAC `{RESTRICTION (topspace top) (g:A->real)}` THEN - REWRITE_TAC[FINITE_SING; SUBSET; IN_ELIM_THM; IN_SING] THEN MESON_TAC[]; - REPEAT STRIP_TAC THEN COND_CASES_TAC THEN ASM_REWRITE_TAC[] THEN - TRY(MATCH_MP_TAC OPEN_IN_HAUSDORFF_DELETE) THEN - ASM_SIMP_TAC[HAUSDORFF_SPACE_SUBTOPOLOGY; - HAUSDORFF_SPACE_EUCLIDEANREAL] THEN - MESON_TAC[OPEN_IN_TOPSPACE; TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY]; - ASM_SIMP_TAC[IN_INTER; FUN_IN_IMAGE] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE RAND_CONV - [TOPSPACE_PRODUCT_TOPOLOGY]) THEN - REWRITE_TAC[cartesian_product; IN_ELIM_THM; o_THM; - TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN - REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[] THEN COND_CASES_TAC THEN - ASM_SIMP_TAC[IN_DELETE] THEN FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP - (REAL_ARITH `y = &0 ==> x = y ==> ~(x = &1)`)) THEN - FIRST_X_ASSUM SUBST_ALL_TAC THEN EXPAND_TAC "e" THEN - REWRITE_TAC[RESTRICTION] THEN ASM_REWRITE_TAC[]; - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_DELETE; IN_INTER; IMP_CONJ] THEN - X_GEN_TAC `y:A` THEN ASM_SIMP_TAC[] THEN DISCH_TAC THEN - REWRITE_TAC[cartesian_product; IN_ELIM_THM] THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC - (MP_TAC o SPEC `RESTRICTION (topspace top) (g:A->real)`)) THEN - REWRITE_TAC[] THEN EXPAND_TAC "e" THEN REWRITE_TAC[] THEN - SIMP_TAC[RESTRICTION] THEN ASM_REWRITE_TAC[IN_DELETE] THEN - ANTS_TAC THENL [EXPAND_TAC "k"; ASM_MESON_TAC[]] THEN - REWRITE_TAC[SUBMETRIC; CFUNSPACE; IN_ELIM_THM; IN_INTER] THEN - REWRITE_TAC[RESTRICTION_IN_EXTENSIONAL] THEN - RULE_ASSUM_TAC(REWRITE_RULE[CONTINUOUS_MAP_IN_SUBTOPOLOGY]) THEN - SIMP_TAC[RESTRICTION_CONTINUOUS_MAP; SUBSET_REFL] THEN - ASM_SIMP_TAC[IMAGE_RESTRICTION; SUBSET_REFL] THEN - ASM_REWRITE_TAC[REAL_EUCLIDEAN_METRIC; MTOPOLOGY_REAL_EUCLIDEAN_METRIC; - IN_UNIV] THEN - MATCH_MP_TAC MBOUNDED_SUBSET THEN EXISTS_TAC `real_interval[&0,&1]` THEN - ASM_REWRITE_TAC[MBOUNDED_REAL_EUCLIDEAN_METRIC; - REAL_BOUNDED_REAL_INTERVAL]]);; + DISCH_THEN(MP_TAC o SELECT_RULE) THEN + DISCH_THEN(X_CHOOSE_THEN `w':A->bool` STRIP_ASSUME_TAC) THEN + CONJ_TAC THENL [ASM_MESON_TAC[SUBSET]; ASM SET_TAC[]]; + (* Locally finite - use LOCALLY_FINITE_PRODUCT_TUBES *) + MATCH_MP_TAC LOCALLY_FINITE_PRODUCT_TUBES THEN + EXISTS_TAC `U:((A#B)->bool)->bool` THEN + ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[SUBSET_TRANS]]);; + +(* Symmetric version: compact times paracompact is paracompact *) +let PARACOMPACT_SPACE_PRODUCT_COMPACT_RIGHT = prove + (`!(top:A topology) (top':B topology). + compact_space top /\ paracompact_space top' + ==> paracompact_space(prod_topology top top')`, + REPEAT STRIP_TAC THEN + MP_TAC(ISPECL [`top':B topology`; `top:A topology`] + PARACOMPACT_SPACE_PRODUCT_COMPACT_LEFT) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + MP_TAC(ISPECL [`top:A topology`; `top':B topology`] + HOMEOMORPHIC_SPACE_PROD_TOPOLOGY_SWAP) THEN + DISCH_THEN(MP_TAC o MATCH_MP HOMEOMORPHIC_PARACOMPACT_SPACE) THEN + ASM_REWRITE_TAC[]);; -let COMPLETELY_REGULAR_SPACE_CUBE_EMBEDDING = prove +(* Helper: In a paracompact Hausdorff space, an open cover has a locally + finite open refinement with closures contained in the original cover *) +let PARACOMPACT_HAUSDORFF_CLOSURE_REFINEMENT = prove + (`!top:A topology U. + paracompact_space top /\ hausdorff_space top /\ + (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?V r. (!v. v IN V ==> open_in top v) /\ + UNIONS V = topspace top /\ + locally_finite_in top V /\ + (!v:A->bool. v IN V + ==> (r v) IN U /\ top closure_of v SUBSET (r v))`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN `regular_space (top:A topology)` ASSUME_TAC THENL + [MATCH_MP_TAC PARACOMPACT_HAUSDORFF_IMP_REGULAR_SPACE THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + ABBREV_TAC + `C = {w:A->bool | open_in top w /\ + ?u:A->bool. u IN U /\ top closure_of w SUBSET u}` THEN + SUBGOAL_THEN `(!w:A->bool. w IN C ==> open_in top w)` ASSUME_TAC THENL + [EXPAND_TAC "C" THEN SIMP_TAC[IN_ELIM_THM]; ALL_TAC] THEN + SUBGOAL_THEN `UNIONS C = topspace (top:A topology)` ASSUME_TAC THENL + [REWRITE_TAC[EXTENSION; IN_UNIONS] THEN X_GEN_TAC `x:A` THEN + EQ_TAC THENL + [DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(w:A->bool) SUBSET topspace top` MP_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET]; ASM SET_TAC[]]; + DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN UNIONS U` MP_TAC THENL + [ASM_MESON_TAC[]; REWRITE_TAC[IN_UNIONS]] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + UNDISCH_TAC `regular_space (top:A topology)` THEN + REWRITE_TAC[regular_space] THEN + DISCH_THEN(MP_TAC o SPECL + [`topspace top DIFF u:A->bool`; `x:A`]) THEN + ASM_SIMP_TAC[CLOSED_IN_DIFF; CLOSED_IN_TOPSPACE; IN_DIFF] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` + (X_CHOOSE_THEN `w':A->bool` STRIP_ASSUME_TAC)) THEN + EXISTS_TAC `w:A->bool` THEN CONJ_TAC THENL + [EXPAND_TAC "C" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_REWRITE_TAC[] THEN EXISTS_TAC `u:A->bool` THEN + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `top closure_of (w:A->bool) SUBSET topspace top DIFF w'` + MP_TAC THENL + [MATCH_MP_TAC CLOSURE_OF_MINIMAL THEN CONJ_TAC THENL + [SUBGOAL_THEN `(w:A->bool) SUBSET topspace top` MP_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET]; ASM SET_TAC[]]; + ASM_SIMP_TAC[CLOSED_IN_DIFF; CLOSED_IN_TOPSPACE]]; + ASM SET_TAC[]]; + ASM_REWRITE_TAC[]]]; ALL_TAC] THEN + (* Use paracompactness on cover C to get locally finite refinement V *) + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [paracompact_space]) THEN + DISCH_THEN(MP_TAC o SPEC `C:(A->bool)->bool`) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `V:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `V:(A->bool)->bool` THEN + (* Build the map r: V -> U via Skolemization *) + SUBGOAL_THEN + `?r:(A->bool)->(A->bool). + !v. v IN V ==> r v IN U /\ top closure_of v SUBSET r v` + MP_TAC THENL + [REWRITE_TAC[GSYM SKOLEM_THM_GEN] THEN + X_GEN_TAC `v:A->bool` THEN DISCH_TAC THEN + SUBGOAL_THEN `?c:A->bool. c IN C /\ (v:A->bool) SUBSET c` + MP_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `c:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN + `?u:A->bool. u IN U /\ top closure_of (c:A->bool) SUBSET u` + MP_TAC THENL + [UNDISCH_TAC `(c:A->bool) IN C` THEN EXPAND_TAC "C" THEN SET_TAC[]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `u:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `top closure_of (c:A->bool)` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CLOSURE_OF_MONO THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `r:(A->bool)->(A->bool)` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `r:(A->bool)->(A->bool)` THEN + ASM_REWRITE_TAC[]);; + +(* Indexed shrinking lemma: for each u IN U, produce v(u) open + with closure in u, {v(u)} l.f. (by index, not set value) *) +let PARACOMPACT_HAUSDORFF_INDEXED_SHRINKING = prove + (`!top:A topology U. + paracompact_space top /\ hausdorff_space top /\ + (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?v. (!u. u IN U ==> open_in top (v u) /\ + top closure_of (v u) SUBSET u) /\ + UNIONS (IMAGE v U) = topspace top /\ + (!x. x IN topspace top + ==> ?N. open_in top N /\ x IN N /\ + FINITE {u | u IN U /\ ~(v u INTER N = {})})`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPECL [`top:A topology`; `U:(A->bool)->bool`] + PARACOMPACT_HAUSDORFF_CLOSURE_REFINEMENT) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `W:(A->bool)->bool` + (X_CHOOSE_THEN `r:(A->bool)->(A->bool)` STRIP_ASSUME_TAC)) THEN + (* Define v(u) = UNIONS {w IN W | r(w) = u} *) + EXISTS_TAC `\u:A->bool. UNIONS {w:A->bool | w IN W /\ r w = u}` THEN + REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [(* v(u) is open and closure_of v(u) SUBSET u *) + X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_UNIONS THEN ASM_SIMP_TAC[IN_ELIM_THM]; + (* closure_of UNIONS {w | r w = u} SUBSET u *) + SUBGOAL_THEN + `locally_finite_in top + {w:A->bool | w IN W /\ + (r:(A->bool)->(A->bool)) w = (u:A->bool)}` + ASSUME_TAC THENL + [REWRITE_TAC[locally_finite_in] THEN CONJ_TAC THENL + [REWRITE_TAC[IN_ELIM_THM] THEN + ASM_MESON_TAC[OPEN_IN_SUBSET]; + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + UNDISCH_TAC `locally_finite_in top (W:(A->bool)->bool)` THEN + REWRITE_TAC[locally_finite_in] THEN + DISCH_THEN(CONJUNCTS_THEN2 (K ALL_TAC) (MP_TAC o SPEC `x:A`)) THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `N:A->bool` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `{w:A->bool | w IN W /\ ~(w INTER N = {})}` THEN + ASM SET_TAC[]]; + ASM_SIMP_TAC[CLOSURE_OF_LOCALLY_FINITE_UNIONS] THEN + REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN ASM SET_TAC[]]]; + (* UNIONS IMAGE v U = topspace *) + REWRITE_TAC[EXTENSION; IN_UNIONS; EXISTS_IN_IMAGE] THEN + X_GEN_TAC `x:A` THEN EQ_TAC THENL + [DISCH_THEN(X_CHOOSE_THEN `u:A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(w:A->bool) SUBSET topspace top` MP_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET]; ASM SET_TAC[]]; + DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN UNIONS W` MP_TAC THENL + [ASM_MESON_TAC[]; REWRITE_TAC[IN_UNIONS]] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(r:(A->bool)->(A->bool)) w` THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `w:A->bool` THEN ASM_REWRITE_TAC[]]; + (* Index-level local finiteness *) + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + UNDISCH_TAC `locally_finite_in top (W:(A->bool)->bool)` THEN + REWRITE_TAC[locally_finite_in] THEN + DISCH_THEN(CONJUNCTS_THEN2 (K ALL_TAC) (MP_TAC o SPEC `x:A`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `N:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `N:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `IMAGE (r:(A->bool)->(A->bool)) + {w | w IN W /\ ~(w INTER N = {})}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_IMAGE] THEN + X_GEN_TAC `u:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER; IN_UNIONS; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `y:A` MP_TAC) THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `w':A->bool` STRIP_ASSUME_TAC) + ASSUME_TAC) THEN + EXISTS_TAC `w':A->bool` THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]]]);; + +(* Continuity of a sum over a locally finite family *) +let CONTINUOUS_MAP_SUM_LOCALLY_FINITE = prove + (`!top (f:K->A->real) (v:K->A->bool) (U:K->bool). + (!u. u IN U ==> continuous_map(top,euclideanreal) (f u)) /\ + (!u. u IN U ==> !x. x IN topspace top /\ ~(x IN v u) + ==> f u x = &0) /\ + (!x:A. x IN topspace top + ==> ?N. open_in top N /\ x IN N /\ + FINITE {u:K | u IN U /\ ~(v u INTER N = {})}) + ==> continuous_map(top,euclideanreal) (\x. sum U (\u. f u x))`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + REWRITE_TAC[CONTINUOUS_MAP_ATPOINTOF] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `N0:A->bool` STRIP_ASSUME_TAC) THEN + ABBREV_TAC + `F0:K->bool = {u:K | u IN U /\ ~((v:K->A->bool) u INTER N0 = {})}` THEN + SUBGOAL_THEN `F0 SUBSET (U:K->bool)` ASSUME_TAC THENL + [EXPAND_TAC "F0" THEN SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `FINITE (F0:K->bool)` ASSUME_TAC THENL + [EXPAND_TAC "F0" THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* On N0, sum over U equals sum over F0 *) + SUBGOAL_THEN + `!y:A. y IN topspace top /\ y IN N0 + ==> sum (U:K->bool) (\u. (f:K->A->real) u y) = + sum F0 (\u. f u y)` ASSUME_TAC THENL + [X_GEN_TAC `y:A` THEN STRIP_TAC THEN + MATCH_MP_TAC SUM_SUPERSET THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `u':K` THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + EXPAND_TAC "F0" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + SUBGOAL_THEN `~(y:A IN (v:K->A->bool) u')` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + BETA_TAC THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + MP_TAC(ISPECL [`atpointof top (x:A)`; + `euclideanreal`; + `\y:A. sum (F0:K->bool) (\u. (f:K->A->real) u y)`; + `\y:A. sum (U:K->bool) (\u. (f:K->A->real) u y)`; + `sum (U:K->bool) (\u. (f:K->A->real) u x)`] + LIMIT_TRANSFORM_EVENTUALLY) THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + DISCH_THEN MATCH_MP_TAC THEN CONJ_TAC THENL + [REWRITE_TAC[EVENTUALLY_ATPOINTOF] THEN DISJ2_TAC THEN + EXISTS_TAC `N0:A->bool` THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `y:A` THEN REWRITE_TAC[IN_DELETE] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `y:A`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; ASM_REWRITE_TAC[]]; + DISCH_THEN(ACCEPT_TAC o SYM)]; + SUBGOAL_THEN + `sum (U:K->bool) (\u. (f:K->A->real) u x) = + sum F0 (\u. f u x)` SUBST1_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `x:A`) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + MP_TAC(ISPECL [`top:A topology`; + `\x:A. \u:K. (f:K->A->real) u x`; + `F0:K->bool`] CONTINUOUS_MAP_SUM) THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + REWRITE_TAC[ETA_AX] THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN X_GEN_TAC `i:K` THEN DISCH_TAC THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM SET_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[CONTINUOUS_MAP_ATPOINTOF] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[]]);; + +(* Engelking 5.1.9: Partition of unity subordinate to locally finite cover *) +let PARACOMPACT_PARTITION_OF_UNITY = prove + (`!top:A topology U. + paracompact_space top /\ hausdorff_space top /\ + (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?phi. (!u. u IN U + ==> continuous_map(top,euclideanreal) (phi u) /\ + (!x. x IN topspace top ==> &0 <= phi u x) /\ + {x | x IN topspace top /\ ~(phi u x = &0)} + SUBSET u) /\ + (!x. x IN topspace top + ==> ?N. open_in top N /\ x IN N /\ + FINITE {u | u IN U /\ ~(N INTER + {y | y IN topspace top /\ ~(phi u y = &0)} = {})}) /\ + (!x. x IN topspace top ==> sum U (\u. phi u x) = &1)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Step 1: First indexed shrinking *) + MP_TAC(ISPECL [`top:A topology`; `U:(A->bool)->bool`] + PARACOMPACT_HAUSDORFF_INDEXED_SHRINKING) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `v:(A->bool)->(A->bool)` STRIP_ASSUME_TAC) THEN + (* Step 2: Second indexed shrinking on IMAGE v U *) + MP_TAC(ISPECL [`top:A topology`; `IMAGE (v:(A->bool)->(A->bool)) U`] + PARACOMPACT_HAUSDORFF_INDEXED_SHRINKING) THEN + ASM_REWRITE_TAC[FORALL_IN_IMAGE] THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `w0:(A->bool)->(A->bool)` STRIP_ASSUME_TAC) THEN + (* Step 3: normal_space *) + SUBGOAL_THEN `normal_space (top:A topology)` ASSUME_TAC THENL + [MATCH_MP_TAC PARACOMPACT_HAUSDORFF_IMP_NORMAL_SPACE THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Properties of w0(v(u)): open, closure in v(u) *) + SUBGOAL_THEN + `!u:A->bool. u IN U ==> + open_in top ((w0:(A->bool)->(A->bool)) ((v:(A->bool)->(A->bool)) u)) /\ + top closure_of (w0 (v u)) SUBSET v u` + ASSUME_TAC THENL + [ASM_MESON_TAC[FUN_IN_IMAGE]; ALL_TAC] THEN + (* IMAGE (w0 o v) covers topspace *) + SUBGOAL_THEN + `UNIONS (IMAGE (\u:A->bool. + (w0:(A->bool)->(A->bool)) ((v:(A->bool)->(A->bool)) u)) U) = + topspace top` + ASSUME_TAC THENL + [SUBGOAL_THEN + `IMAGE (\u:A->bool. + (w0:(A->bool)->(A->bool)) ((v:(A->bool)->(A->bool)) u)) U = + IMAGE w0 (IMAGE v U)` SUBST1_TAC THENL + [ONCE_REWRITE_TAC[GSYM IMAGE_o] THEN REWRITE_TAC[o_DEF]; + ASM_REWRITE_TAC[]]; ALL_TAC] THEN + (* Step 4: Urysohn functions for each u *) + SUBGOAL_THEN + `!u:A->bool. u IN U + ==> ?f:A->real. + continuous_map + (top,subtopology euclideanreal (real_interval[&0,&1])) f /\ + (!x. x IN topspace top DIFF (v:(A->bool)->(A->bool)) u + ==> f x = &0) /\ + (!x. x IN top closure_of + ((w0:(A->bool)->(A->bool)) (v u)) + ==> f x = &1)` + MP_TAC THENL + [X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC URYSOHN_LEMMA THEN ASM_REWRITE_TAC[REAL_POS] THEN + REPEAT CONJ_TAC THENL + [MATCH_MP_TAC CLOSED_IN_DIFF THEN + ASM_SIMP_TAC[CLOSED_IN_TOPSPACE]; + REWRITE_TAC[CLOSED_IN_CLOSURE_OF]; + SUBGOAL_THEN + `top closure_of ((w0:(A->bool)->(A->bool)) + ((v:(A->bool)->(A->bool)) u)) SUBSET v u` + MP_TAC THENL + [ASM_MESON_TAC[]; + REWRITE_TAC[DISJOINT; EXTENSION; IN_INTER; NOT_IN_EMPTY; + IN_DIFF; SUBSET] THEN + MESON_TAC[]]]; ALL_TAC] THEN + (* Skolemize *) + REWRITE_TAC[SKOLEM_THM_GEN] THEN + DISCH_THEN(X_CHOOSE_THEN `psi:(A->bool)->A->real` STRIP_ASSUME_TAC) THEN + (* Step 5: Define phi(u)(x) = psi(u)(x) / sum_U psi *) + EXISTS_TAC + `(\u:A->bool. \x:A. + if x IN topspace top + then (psi:(A->bool)->A->real) u x / + sum U (\u'. psi u' x) + else &0):(A->bool)->A->real` THEN + REWRITE_TAC[] THEN + SUBGOAL_THEN + `!u:A->bool. u IN U + ==> continuous_map(top,euclideanreal) ((psi:(A->bool)->A->real) u)` + ASSUME_TAC THENL + [GEN_TAC THEN DISCH_TAC THEN + MATCH_MP_TAC CONTINUOUS_MAP_INTO_FULLTOPOLOGY THEN + EXISTS_TAC `real_interval[&0,&1]` THEN ASM_SIMP_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN + `!u:A->bool. u IN U + ==> !x:A. x IN topspace top + ==> &0 <= (psi:(A->bool)->A->real) u x` + ASSUME_TAC THENL + [REPEAT STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `u:A->bool` o + check (fun th -> free_in `real_interval` (concl th))) THEN + ASM_REWRITE_TAC[] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o CONJUNCT2 o + GEN_REWRITE_RULE I [CONTINUOUS_MAP_IN_SUBTOPOLOGY]) THEN + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_REAL_INTERVAL] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + REAL_ARITH_TAC; + ALL_TAC] THEN + SUBGOAL_THEN + `!u:A->bool. u IN U + ==> !x:A. x IN topspace top /\ ~(x IN (v:(A->bool)->(A->bool)) u) + ==> (psi:(A->bool)->A->real) u x = &0` + ASSUME_TAC THENL + [REPEAT STRIP_TAC THEN ASM_MESON_TAC[IN_DIFF]; + ALL_TAC] THEN + SUBGOAL_THEN + `!x:A. x IN topspace top + ==> FINITE {u:A->bool | u IN U /\ + ~((psi:(A->bool)->A->real) u x = &0)}` + ASSUME_TAC THENL + [X_GEN_TAC `x:A` THEN DISCH_TAC THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC + `{u:A->bool | u IN U /\ x IN (v:(A->bool)->(A->bool)) u}` THEN + CONJ_TAC THENL + [ALL_TAC; + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + ASM_CASES_TAC `x:A IN (v:(A->bool)->(A->bool)) x'` THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[IN_DIFF]] THEN + SUBGOAL_THEN + `?N0:A->bool. open_in top N0 /\ x IN N0 /\ + FINITE {u:A->bool | u IN U /\ + ~((v:(A->bool)->(A->bool)) u INTER N0 = {})}` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC + `{u:A->bool | u IN U /\ + ~((v:(A->bool)->(A->bool)) u INTER N0 = {})}` THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + GEN_TAC THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + ASM SET_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN + `!x:A. x IN topspace top + ==> &0 < sum U (\u:A->bool. (psi:(A->bool)->A->real) u x)` + ASSUME_TAC THENL + [X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN + `?u0:A->bool. u0 IN U /\ + x IN (w0:(A->bool)->(A->bool)) ((v:(A->bool)->(A->bool)) u0)` + STRIP_ASSUME_TAC THENL + [SUBGOAL_THEN + `x:A IN UNIONS (IMAGE (\u:A->bool. + (w0:(A->bool)->(A->bool)) ((v:(A->bool)->(A->bool)) u)) U)` + MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; IN_IMAGE] THEN MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `(psi:(A->bool)->A->real) u0 x = &1` ASSUME_TAC THENL + [ASM_MESON_TAC[CLOSURE_OF_SUBSET; OPEN_IN_SUBSET; SUBSET]; + ALL_TAC] THEN + ONCE_REWRITE_TAC[GSYM SUM_SUPPORT] THEN + REWRITE_TAC[support; NEUTRAL_REAL_ADD] THEN + MATCH_MP_TAC SUM_POS_LT THEN + CONJ_TAC THENL [ASM_SIMP_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL + [ASM SET_TAC[]; + EXISTS_TAC `u0:A->bool` THEN + REWRITE_TAC[IN_ELIM_THM] THEN + ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC]; + ALL_TAC] THEN + (* Step 6: Verify three conditions *) + REPEAT CONJ_TAC THENL + [(* Condition 1: continuity, nonnegativity, support *) + X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN + ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [(* Continuity of phi u *) + SUBGOAL_THEN + `continuous_map(top,euclideanreal) + (\x:A. (psi:(A->bool)->A->real) u x / + sum U (\u':A->bool. psi u' x))` + ASSUME_TAC THENL + [MP_TAC(ISPECL [`top:A topology`; + `\x:A. (psi:(A->bool)->A->real) u x`; + `\x:A. sum U (\u':A->bool. + (psi:(A->bool)->A->real) u' x)`] + CONTINUOUS_MAP_REAL_DIV) THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + ANTS_TAC THENL + [REWRITE_TAC[ETA_AX] THEN REPEAT CONJ_TAC THENL + [ASM_SIMP_TAC[]; + MATCH_MP_TAC(ISPECL [`top:A topology`; + `psi:(A->bool)->A->real`; + `v:(A->bool)->A->bool`; + `U:(A->bool)->bool`] + CONTINUOUS_MAP_SUM_LOCALLY_FINITE) THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + MATCH_MP_TAC REAL_LT_IMP_NZ THEN ASM_SIMP_TAC[]]; + DISCH_THEN ACCEPT_TAC]; + ALL_TAC] THEN + MP_TAC(ISPECL [`top:A topology`; `euclideanreal`; + `\x:A. (psi:(A->bool)->A->real) u x / + sum U (\u':A->bool. psi u' x)`; + `\x:A. if x:A IN topspace top + then (psi:(A->bool)->A->real) u x / + sum U (\u':A->bool. psi u' x) + else &0`] CONTINUOUS_MAP_EQ) THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [GEN_TAC THEN DISCH_TAC THEN ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[]]; + DISCH_THEN ACCEPT_TAC]; + (* Nonnegativity *) + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LE_DIV THEN + CONJ_TAC THENL [ASM_SIMP_TAC[]; + MATCH_MP_TAC SUM_POS_LE THEN ASM_SIMP_TAC[]]; + (* Support contained in u *) + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + ASM_CASES_TAC `x:A IN (v:(A->bool)->(A->bool)) u` THENL + [DISCH_TAC THEN ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET; CLOSURE_OF_SUBSET]; + SUBGOAL_THEN `(psi:(A->bool)->A->real) u x = &0` + ASSUME_TAC THENL [ASM_MESON_TAC[IN_DIFF]; ALL_TAC] THEN + ASM_REWRITE_TAC[real_div; REAL_MUL_LZERO]]]; + (* Condition 2: local finiteness *) + GEN_REWRITE_TAC I [GSYM SKOLEM_THM] THEN X_GEN_TAC `x:A` THEN + GEN_REWRITE_TAC I [GSYM RIGHT_IMP_EXISTS_THM] THEN DISCH_TAC THEN + SUBGOAL_THEN + `?N0:A->bool. open_in top N0 /\ x IN N0 /\ + FINITE {u:A->bool | u IN U /\ + ~((v:(A->bool)->(A->bool)) u INTER N0 = {})}` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + EXISTS_TAC `N0:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC + `{u:A->bool | u IN U /\ + ~((v:(A->bool)->(A->bool)) u INTER N0 = {})}` THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `u:A->bool` THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o check (is_neg o concl)) THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER; IN_ELIM_THM] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `y:A` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + ASM_CASES_TAC `(y:A) IN (v:(A->bool)->(A->bool)) u` THEN + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `(psi:(A->bool)->A->real) u (y:A) = &0` + ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o check (fun th -> + is_neg(concl th) && free_in `psi:(A->bool)->A->real` (concl th))) THEN + ASM_REWRITE_TAC[real_div; REAL_MUL_LZERO]; + (* Condition 3: sum = 1 *) + X_GEN_TAC `x:A` THEN DISCH_TAC THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[real_div; SUM_RMUL] THEN + MATCH_MP_TAC REAL_MUL_RINV THEN + MATCH_MP_TAC(REAL_ARITH `&0 < x ==> ~(x = &0)`) THEN + ASM_SIMP_TAC[]]);; + +(* Munkres 41.5: Regular Lindelof space is paracompact *) +(* Proof: A countable subcover is sigma-locally-finite; apply Michael's Lemma *) +let REGULAR_LINDELOF_IMP_PARACOMPACT_SPACE = prove + (`!top:A topology. + regular_space top /\ lindelof_space top + ==> paracompact_space top`, + GEN_TAC THEN STRIP_TAC THEN REWRITE_TAC[paracompact_space] THEN + MP_TAC(ISPEC `top:A topology` MICHAEL_LEMMA) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN MATCH_MP_TAC THEN + X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [lindelof_space]) THEN + DISCH_THEN(MP_TAC o SPEC `U:(A->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `V:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `V:(A->bool)->bool` THEN + REPEAT CONJ_TAC THENL + [ASM_MESON_TAC[SUBSET]; + ASM_REWRITE_TAC[]; + ASM_MESON_TAC[SUBSET; SUBSET_REFL]; + MATCH_MP_TAC COUNTABLE_IMP_SIGMA_LOCALLY_FINITE_IN THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]]);; + +(* Corollary of Munkres 41.5: Second-countable regular space is paracompact *) +let SECOND_COUNTABLE_REGULAR_IMP_PARACOMPACT_SPACE = prove (`!top:A topology. - completely_regular_space top /\ hausdorff_space top - ==> ?k:((A->real)->bool) e. - embedding_map - (top, - product_topology k - (\f. subtopology euclideanreal (real_interval[&0,&1]))) - e`, - REPEAT GEN_TAC THEN DISCH_THEN(MP_TAC o MATCH_MP - COMPLETELY_REGULAR_SPACE_CUBE_EMBEDDING_EXPLICIT) THEN - MESON_TAC[]);; - -(* ------------------------------------------------------------------------- *) -(* Urysohn and Tietze analogs for completely regular spaces if (one) set is *) -(* assumed compact instead of closed. Note that Hausdorffness is *not* *) -(* required: inside one proof we factor through the Kolmogorov quotient. *) -(* ------------------------------------------------------------------------- *) + second_countable top /\ regular_space top + ==> paracompact_space top`, + MESON_TAC[REGULAR_LINDELOF_IMP_PARACOMPACT_SPACE; + SECOND_COUNTABLE_IMP_LINDELOF_SPACE]);; -let URYSOHN_COMPLETELY_REGULAR_CLOSED_COMPACT = prove - (`!top s (t:A->bool) a b. - a <= b /\ completely_regular_space top /\ - closed_in top s /\ compact_in top t /\ DISJOINT s t - ==> ?f. continuous_map - (top,subtopology euclideanreal (real_interval[a,b])) f /\ - (!x. x IN t ==> f x = a) /\ - (!x. x IN s ==> f x = b)`, +(* Engelking 5.1.35: Perfect preimage of paracompact is paracompact *) +let PARACOMPACT_SPACE_PERFECT_MAP_PREIMAGE = prove + (`!top top' (f:A->B). + perfect_map(top,top') f /\ paracompact_space top' + ==> paracompact_space top`, REPEAT STRIP_TAC THEN + FIRST_X_ASSUM(STRIP_ASSUME_TAC o GEN_REWRITE_RULE I [perfect_map]) THEN + FIRST_ASSUM(STRIP_ASSUME_TAC o GEN_REWRITE_RULE I [proper_map]) THEN + REWRITE_TAC[paracompact_space] THEN + X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + (* Step 1: For each y in Y, get open V(y) in Y and finite F(y) SUBSET U + such that f^{-1}(V(y)) SUBSET UNIONS F(y) *) SUBGOAL_THEN - `?f. continuous_map - (top,subtopology euclideanreal (real_interval[&0,&1])) f /\ - (!x. x IN t ==> f x = &0) /\ - (!x:A. x IN s ==> f x = &1)` - MP_TAC THENL - [ALL_TAC; - REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET] THEN - REWRITE_TAC[FORALL_IN_IMAGE; IN_REAL_INTERVAL; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `f:A->real` THEN STRIP_TAC THEN - EXISTS_TAC `\x. a + (b - a) * (f:A->real) x` THEN - ASM_SIMP_TAC[] THEN CONJ_TAC THENL [ALL_TAC; REAL_ARITH_TAC] THEN - ASM_SIMP_TAC[CONTINUOUS_MAP_REAL_ADD; CONTINUOUS_MAP_REAL_LMUL; - CONTINUOUS_MAP_CONST; TOPSPACE_EUCLIDEANREAL; IN_UNIV] THEN - REWRITE_TAC[IN_REAL_INTERVAL; REAL_LE_ADDR] THEN - REWRITE_TAC[REAL_ARITH - `a + (b - a) * y <= b <=> &0 <= (b - a) * (&1 - y)`] THEN - ASM_SIMP_TAC[REAL_LE_MUL; REAL_SUB_LE]] THEN - ASM_CASES_TAC `t:A->bool = {}` THENL - [EXISTS_TAC `(\x. &1):A->real` THEN - ASM_REWRITE_TAC[CONTINUOUS_MAP_CONST; NOT_IN_EMPTY] THEN - REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY; IN_REAL_INTERVAL] THEN - CONV_TAC REAL_RAT_REDUCE_CONV; + `!y:B. y IN topspace top' + ==> ?V F. open_in top' V /\ y IN V /\ + FINITE F /\ F SUBSET (U:(A->bool)->bool) /\ + {x:A | x IN topspace top /\ (f:A->B) x IN V} + SUBSET UNIONS F` + MP_TAC THENL + [X_GEN_TAC `y:B` THEN DISCH_TAC THEN + SUBGOAL_THEN + `compact_in top {x:A | x IN topspace top /\ (f:A->B) x = y}` + ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o + CONJUNCT2 o GEN_REWRITE_RULE I [compact_in]) THEN + DISCH_THEN(MP_TAC o SPEC `U:(A->bool)->bool`) THEN + ANTS_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `F0:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + FIRST_ASSUM(MP_TAC o CONJUNCT2 o + REWRITE_RULE[CLOSED_MAP_FIBRE_NEIGHBOURHOOD]) THEN + DISCH_THEN(MP_TAC o SPECL [`UNIONS F0:A->bool`; `y:B`]) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC OPEN_IN_UNIONS THEN ASM_MESON_TAC[SUBSET]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `V0:B->bool` STRIP_ASSUME_TAC) THEN + MAP_EVERY EXISTS_TAC [`V0:B->bool`; `F0:(A->bool)->bool`] THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN - SUBGOAL_THEN - `!a. a IN t - ==> ?f. continuous_map - (top,subtopology euclideanreal (real_interval[&0,&1])) f /\ - f a = &0 /\ !x. x IN s ==> (f:A->real) x = &1` - MP_TAC THENL - [REPEAT STRIP_TAC THEN - FIRST_X_ASSUM(MATCH_MP_TAC o REWRITE_RULE[completely_regular_space]) THEN - FIRST_ASSUM(MP_TAC o MATCH_MP COMPACT_IN_SUBSET_TOPSPACE) THEN - ASM SET_TAC[]; - GEN_REWRITE_TAC (LAND_CONV o BINDER_CONV) [RIGHT_IMP_EXISTS_THM]] THEN - REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `g:A->A->real` THEN DISCH_TAC THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [compact_in]) THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC - `{{x | x IN topspace top /\ (g:A->A->real) a x IN {t | t < &1 / &2}} | - a IN t}`)) THEN - REWRITE_TAC[SIMPLE_IMAGE; EXISTS_FINITE_SUBSET_IMAGE; FORALL_IN_IMAGE] THEN + (* Skolemize to get functions VV and FF *) + DISCH_THEN(MP_TAC o REWRITE_RULE[RIGHT_IMP_EXISTS_THM; SKOLEM_THM]) THEN + DISCH_THEN(X_CHOOSE_THEN `VV:B->(B->bool)` + (X_CHOOSE_THEN `FF:B->((A->bool)->bool)` (LABEL_TAC "sk"))) THEN + (* Step 2: Apply paracompactness of top' to {VV y | y in topspace top'} *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [paracompact_space]) THEN + DISCH_THEN(MP_TAC o + SPEC `{(VV:B->(B->bool)) y | y IN topspace top'}`) THEN ANTS_TAC THENL [CONJ_TAC THENL - [X_GEN_TAC `a:A` THEN DISCH_TAC THEN + [REWRITE_TAC[FORALL_IN_GSPEC] THEN ASM_MESON_TAC[]; + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + ASM_MESON_TAC[OPEN_IN_SUBSET]; + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `y:B` THEN DISCH_TAC THEN + EXISTS_TAC `(VV:B->(B->bool)) y` THEN ASM_MESON_TAC[]]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `W:(B->bool)->bool` + (CONJUNCTS_THEN2 (LABEL_TAC "Wop") + (CONJUNCTS_THEN2 (LABEL_TAC "Wcov") + (CONJUNCTS_THEN2 (LABEL_TAC "Wref") + (LABEL_TAC "Wlf"))))) THEN + (* Step 3: Skolemize the refinement map *) + SUBGOAL_THEN + `?yw:(B->bool)->B. !w. w IN W + ==> (yw w) IN topspace top' /\ + w SUBSET (VV:B->(B->bool)) (yw w)` + (X_CHOOSE_THEN `yw:(B->bool)->B` (LABEL_TAC "yw")) THENL + [REWRITE_TAC[GSYM SKOLEM_THM] THEN X_GEN_TAC `w:B->bool` THEN + USE_THEN "Wref" (MP_TAC o SPEC `w:B->bool`) THEN + REWRITE_TAC[IN_ELIM_THM] THEN MESON_TAC[]; + ALL_TAC] THEN + (* Step 4: Define the final cover *) + EXISTS_TAC + `{u INTER {x:A | x IN topspace top /\ (f:A->B) x IN w} | + w,u | w IN (W:(B->bool)->bool) /\ + u IN (FF:B->((A->bool)->bool))((yw:(B->bool)->B) w)}` THEN + REPEAT CONJ_TAC THENL + [(* Open: each u INTER f^{-1}(w) is open *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN + MAP_EVERY X_GEN_TAC [`w:B->bool`; `u:A->bool`] THEN STRIP_TAC THEN + MATCH_MP_TAC OPEN_IN_INTER THEN CONJ_TAC THENL + [USE_THEN "sk" (MP_TAC o SPEC `(yw:(B->bool)->B) w`) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + STRIP_TAC THEN ASM_MESON_TAC[SUBSET]; MATCH_MP_TAC OPEN_IN_CONTINUOUS_MAP_PREIMAGE THEN - EXISTS_TAC `euclideanreal` THEN REWRITE_TAC[GSYM REAL_OPEN_IN] THEN - RULE_ASSUM_TAC(REWRITE_RULE[CONTINUOUS_MAP_IN_SUBTOPOLOGY]) THEN - ASM_SIMP_TAC[REAL_OPEN_HALFSPACE_LT; ETA_AX]; - MATCH_MP_TAC(SET_RULE - `(!a. a IN s ==> a IN f a) ==> s SUBSET UNIONS(IMAGE f s)`) THEN - ASM_SIMP_TAC[IN_ELIM_THM] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN - ASM SET_TAC[]]; - DISCH_THEN(X_CHOOSE_THEN `k:A->bool` MP_TAC)] THEN - ASM_CASES_TAC `k:A->bool = {}` THEN - ASM_REWRITE_TAC[IMAGE_CLAUSES; UNIONS_0; SUBSET_EMPTY] THEN STRIP_TAC THEN + EXISTS_TAC `top':(B)topology` THEN ASM_MESON_TAC[]]; + (* Covers: UNIONS of the cover = topspace top *) + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + REPEAT STRIP_TAC THEN ASM SET_TAC[]; + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(f:A->B) x IN topspace top'` ASSUME_TAC THENL + [ASM_MESON_TAC[continuous_map; SUBSET; IN_IMAGE]; ALL_TAC] THEN + SUBGOAL_THEN `?w:B->bool. w IN W /\ (f:A->B) x IN w` + (X_CHOOSE_THEN `w0:B->bool` STRIP_ASSUME_TAC) THENL + [USE_THEN "Wcov" MP_TAC THEN + REWRITE_TAC[EXTENSION; IN_UNIONS] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `(x:A) IN UNIONS ((FF:B->((A->bool)->bool)) + ((yw:(B->bool)->B) w0))` MP_TAC THENL + [USE_THEN "sk" (MP_TAC o SPEC `(yw:(B->bool)->B) w0`) THEN + ANTS_TAC THENL + [USE_THEN "yw" (MP_TAC o SPEC `w0:B->bool`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; MESON_TAC[]]; + ALL_TAC] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MATCH_MP_TAC o REWRITE_RULE[SUBSET]) THEN + REWRITE_TAC[IN_ELIM_THM] THEN ASM_MESON_TAC[SUBSET]; + ALL_TAC] THEN REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `u0:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `u0 INTER {x:A | x IN topspace top /\ + (f:A->B) x IN (w0:B->bool)}` THEN + CONJ_TAC THENL + [REWRITE_TAC[IN_ELIM_THM] THEN + MAP_EVERY EXISTS_TAC [`w0:B->bool`; `u0:A->bool`] THEN + ASM_REWRITE_TAC[]; + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN ASM_REWRITE_TAC[]]]; + (* Refines: each element is subset of some u in U *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN + MAP_EVERY X_GEN_TAC [`w:B->bool`; `u:A->bool`] THEN STRIP_TAC THEN + EXISTS_TAC `u:A->bool` THEN CONJ_TAC THENL + [USE_THEN "sk" (MP_TAC o SPEC `(yw:(B->bool)->B) w`) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + STRIP_TAC THEN ASM SET_TAC[]; + SET_TAC[]]; + (* Locally finite *) + REWRITE_TAC[locally_finite_in] THEN CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_GSPEC] THEN + REPEAT STRIP_TAC THEN ASM SET_TAC[]; + ALL_TAC] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(f:A->B) x IN topspace top'` ASSUME_TAC THENL + [ASM_MESON_TAC[continuous_map; SUBSET; IN_IMAGE]; ALL_TAC] THEN + USE_THEN "Wlf" (MP_TAC o REWRITE_RULE[locally_finite_in]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPEC `(f:A->B) x`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `N:B->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `{x:A | x IN topspace top /\ (f:A->B) x IN N}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_CONTINUOUS_MAP_PREIMAGE THEN + EXISTS_TAC `top':(B)topology` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN CONJ_TAC THENL + [REWRITE_TAC[IN_ELIM_THM] THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC + `UNIONS (IMAGE + (\w. {u INTER {x:A | x IN topspace top /\ (f:A->B) x IN w} | + u | u IN (FF:B->((A->bool)->bool))((yw:(B->bool)->B) w)}) + {w:B->bool | w IN W /\ ~(w INTER (N:B->bool) = {})})` THEN + CONJ_TAC THENL + [(* FINITE of the UNIONS *) + REWRITE_TAC[FINITE_UNIONS] THEN CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[FORALL_IN_IMAGE; IN_ELIM_THM] THEN + X_GEN_TAC `w1:B->bool` THEN STRIP_TAC THEN + REWRITE_TAC[SIMPLE_IMAGE] THEN + MATCH_MP_TAC FINITE_IMAGE THEN + USE_THEN "sk" (MP_TAC o SPEC `(yw:(B->bool)->B) w1`) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; SIMP_TAC[]]]; + (* SUBSET *) + REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_UNIONS; IN_IMAGE] THEN + X_GEN_TAC `s:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `w1:B->bool` + (X_CHOOSE_THEN `u1:A->bool` STRIP_ASSUME_TAC)) + ASSUME_TAC) THEN + EXISTS_TAC + `{u INTER {x:A | x IN topspace top /\ (f:A->B) x IN w1} | + u | u IN (FF:B->((A->bool)->bool))((yw:(B->bool)->B) w1)}` THEN + CONJ_TAC THENL + [EXISTS_TAC `w1:B->bool` THEN ASM_REWRITE_TAC[IN_ELIM_THM] THEN + FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + ASM_REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN ASM SET_TAC[]; + REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `u1:A->bool` THEN ASM_REWRITE_TAC[]]]]);; + +(* Helper: locally finite is preserved under homeomorphism image *) +let LOCALLY_FINITE_IN_HOMEOMORPHIC_IMAGE = prove + (`!(top:A topology) (top':B topology) f g V. + homeomorphic_maps(top,top') (f,g) /\ locally_finite_in top V + ==> locally_finite_in top' (IMAGE (IMAGE f) V)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + REWRITE_TAC[locally_finite_in; FORALL_IN_IMAGE] THEN + (* Extract useful facts from homeomorphic_maps *) + FIRST_ASSUM(STRIP_ASSUME_TAC o GEN_REWRITE_RULE I [homeomorphic_maps]) THEN + (* f is an open map - using HOMEOMORPHIC_MAPS_MAP directly *) + SUBGOAL_THEN `homeomorphic_map(top,top') (f:A->B)` ASSUME_TAC THENL + [REWRITE_TAC[HOMEOMORPHIC_MAP_MAPS] THEN EXISTS_TAC `g:B->A` THEN + ASM_REWRITE_TAC[homeomorphic_maps]; ALL_TAC] THEN + SUBGOAL_THEN `open_map(top,top') (f:A->B)` ASSUME_TAC THENL + [ASM_MESON_TAC[HOMEOMORPHIC_IMP_OPEN_MAP]; ALL_TAC] THEN + (* Get the locally finite assumptions *) + FIRST_X_ASSUM(STRIP_ASSUME_TAC o GEN_REWRITE_RULE I [locally_finite_in]) THEN + (* Also extract continuous_map facts *) + SUBGOAL_THEN + `IMAGE (f:A->B) (topspace top) SUBSET topspace top'` + ASSUME_TAC THENL + [UNDISCH_TAC `continuous_map(top,top') (f:A->B)` THEN + REWRITE_TAC[continuous_map] THEN SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `IMAGE (g:B->A) (topspace top') SUBSET topspace top` + ASSUME_TAC THENL + [UNDISCH_TAC `continuous_map(top',top) (g:B->A)` THEN + REWRITE_TAC[continuous_map] THEN SET_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL + [(* Part 1: Each IMAGE f v SUBSET topspace top' *) + X_GEN_TAC `v:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `v:A->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_TAC THEN ASM SET_TAC[]; + ALL_TAC] THEN + (* Part 2: For y, find open nbhd meeting finitely many IMAGE f v *) + X_GEN_TAC `y:B` THEN DISCH_TAC THEN + (* g(y) is in topspace top *) + SUBGOAL_THEN `(g:B->A) y IN topspace top` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + (* Use locally finite at g(y) - be explicit about which assumption *) + UNDISCH_TAC + `!x:A. x IN topspace top + ==> ?v. open_in top v /\ x IN v /\ + FINITE {u | u IN V /\ ~(u INTER v = {})}` THEN + DISCH_THEN(MP_TAC o SPEC `(g:B->A) y`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + (* IMAGE f u is open in top' *) + SUBGOAL_THEN `open_in top' (IMAGE (f:A->B) u)` ASSUME_TAC THENL + [UNDISCH_TAC `open_map(top,top') (f:A->B)` THEN + REWRITE_TAC[open_map] THEN DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* y = f(g(y)) IN IMAGE f u *) + SUBGOAL_THEN `(y:B) IN IMAGE (f:A->B) u` ASSUME_TAC THENL + [REWRITE_TAC[IN_IMAGE] THEN EXISTS_TAC `(g:B->A) y` THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + EXISTS_TAC `IMAGE (f:A->B) u` THEN ASM_REWRITE_TAC[] THEN + (* The key: {w | w IN IMAGE (IMAGE f) V /\ ~(IMAGE f u INTER w = {})} + SUBSET IMAGE (IMAGE f) {v | v IN V /\ ~(u INTER v = {})} *) + MATCH_MP_TAC FINITE_SUBSET THEN EXISTS_TAC - `\x. &2 * max (&0) (inf {(g:A->A->real) a x | a IN k} - &1 / &2)` THEN - REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET; FORALL_IN_IMAGE] THEN - REWRITE_TAC[REAL_ARITH `&2 * max (&0) (x - &1 / &2) = &0 <=> x <= &1 / &2`; - REAL_ARITH `&2 * max (&0) (x - &1 / &2) = &1 <=> x = &1`] THEN - RULE_ASSUM_TAC(REWRITE_RULE[CONTINUOUS_MAP_IN_SUBTOPOLOGY]) THEN - REWRITE_TAC[IN_REAL_INTERVAL] THEN - REWRITE_TAC[REAL_ARITH `&0 <= &2 * max (&0) a`; - REAL_ARITH `&2 * max (&0) (x - &1 / &2) <= &1 <=> x <= &1`] THEN - REWRITE_TAC[GSYM CONJ_ASSOC] THEN CONJ_TAC THENL - [MATCH_MP_TAC CONTINUOUS_MAP_REAL_LMUL THEN - MATCH_MP_TAC CONTINUOUS_MAP_REAL_MAX THEN - REWRITE_TAC[CONTINUOUS_MAP_CONST; TOPSPACE_EUCLIDEANREAL; IN_UNIV] THEN - MATCH_MP_TAC CONTINUOUS_MAP_REAL_SUB THEN - REWRITE_TAC[CONTINUOUS_MAP_CONST; TOPSPACE_EUCLIDEANREAL; IN_UNIV] THEN - MATCH_MP_TAC CONTINUOUS_MAP_INF THEN REWRITE_TAC[ETA_AX] THEN - ASM SET_TAC[]; + `IMAGE (IMAGE (f:A->B)) + {v:A->bool | v IN V /\ ~(u INTER v = {})}` THEN + (* First prove FINITE using the assumption - need to show sets are equal *) + SUBGOAL_THEN `{v:A->bool | v IN V /\ ~(u INTER v = {})} = + {u' | u' IN V /\ ~(u' INTER u = {})}` SUBST1_TAC THENL + [REWRITE_TAC[EXTENSION; IN_ELIM_THM] THEN MESON_TAC[INTER_COMM]; ALL_TAC] THEN + ASM_SIMP_TAC[FINITE_IMAGE] THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_IMAGE] THEN + X_GEN_TAC `w:B->bool` THEN STRIP_TAC THEN + (* Now: w = IMAGE f x, x IN V, ~(w INTER IMAGE f u = {}) *) + (* Goal: exists y. w = IMAGE f y /\ y IN V /\ ~(y INTER u = {}) *) + EXISTS_TAC `x:A->bool` THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Need: ~(x INTER u = {}) *) + (* We have: ~(w INTER IMAGE f u = {}), i.e., + ~(IMAGE f x INTER IMAGE f u = {}) *) + (* Use injectivity: if z IN IMAGE f x INTER IMAGE f u, then z = f a = f b *) + (* with a IN x, b IN u, and by injectivity a = b, so a IN x INTER u *) + DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[IN_INTER; IN_IMAGE] THEN + DISCH_THEN(X_CHOOSE_THEN `z:B` (CONJUNCTS_THEN2 + (X_CHOOSE_THEN `a:A` STRIP_ASSUME_TAC) + (X_CHOOSE_THEN `b:A` STRIP_ASSUME_TAC))) THEN + (* f a = z = f b, and since g(f t) = t on topspace, we get a = b *) + (* But a IN x and b IN u, so x INTER u != {} *) + SUBGOAL_THEN `(a:A) IN topspace top` ASSUME_TAC THENL + [UNDISCH_TAC `!u:A->bool. u IN V ==> u SUBSET topspace top` THEN + DISCH_THEN(MP_TAC o SPEC `x:A->bool`) THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `(a:A) IN x` THEN SET_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `(b:A) IN topspace top` ASSUME_TAC THENL + [UNDISCH_TAC `open_in top (u:A->bool)` THEN + DISCH_THEN(MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN + UNDISCH_TAC `(b:A) IN u` THEN SET_TAC[]; + ALL_TAC] THEN + (* Use injectivity: g(f a) = a and g(f b) = b, and f a = f b, so a = b *) + UNDISCH_TAC `!x:A. x IN topspace top ==> (g:B->A)((f:A->B) x) = x` THEN + DISCH_THEN(fun th -> + MP_TAC(SPEC `a:A` th) THEN MP_TAC(SPEC `b:A` th)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_TAC THEN DISCH_TAC THEN + (* Now we have g(f a) = a and g(f b) = b *) + (* Also f a = z and f b = z, so f a = f b *) + (* Therefore g(f a) = g(f b), i.e., a = b *) + (* Prove a = b using injectivity: g(f a) = a, g(f b) = b, f a = z = f b *) + (* g(f a) = g(f b) hence a = b, contradicting disjointness *) + ASM_MESON_TAC[IN_INTER; MEMBER_NOT_EMPTY]);; + +(* Paracompactness of discrete topology *) +let PARACOMPACT_SPACE_DISCRETE_TOPOLOGY = prove + (`!u:A->bool. paracompact_space(discrete_topology u)`, + GEN_TAC THEN REWRITE_TAC[paracompact_space; locally_finite_in] THEN + REWRITE_TAC[OPEN_IN_DISCRETE_TOPOLOGY; TOPSPACE_DISCRETE_TOPOLOGY] THEN + X_GEN_TAC `U:(A->bool)->bool` THEN DISCH_TAC THEN + EXISTS_TAC `{{x:A} | x IN u}` THEN + REWRITE_TAC[UNIONS_SINGS; FORALL_IN_GSPEC; SING_SUBSET] THEN + CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN EXISTS_TAC `{x:A}` THEN + ASM_REWRITE_TAC[IN_SING; SING_SUBSET; SET_RULE + `{(y:A->bool) | y IN {(f:A->A->bool) x | P x} /\ Q y} = + IMAGE f {x:A | P x /\ Q(f x)}`] THEN + MATCH_MP_TAC FINITE_IMAGE THEN MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `{x:A}` THEN REWRITE_TAC[FINITE_SING] THEN SET_TAC[]);; + +(* Second countable + locally compact + Hausdorff implies paracompact *) +let SECOND_COUNTABLE_LOCALLY_COMPACT_HAUSDORFF_IMP_PARACOMPACT = prove + (`!top:A topology. + second_countable top /\ locally_compact_space top /\ + hausdorff_space top + ==> paracompact_space top`, + MESON_TAC[LOCALLY_COMPACT_HAUSDORFF_IMP_REGULAR_SPACE; + SECOND_COUNTABLE_IMP_LINDELOF_SPACE; + REGULAR_LINDELOF_IMP_PARACOMPACT_SPACE]);; + +(* For Lindelof Hausdorff spaces, regular <=> paracompact *) +let LINDELOF_HAUSDORFF_REGULAR_EQ_PARACOMPACT = prove + (`!top:A topology. + lindelof_space top /\ hausdorff_space top + ==> (regular_space top <=> paracompact_space top)`, + MESON_TAC[REGULAR_LINDELOF_IMP_PARACOMPACT_SPACE; + PARACOMPACT_HAUSDORFF_IMP_REGULAR_SPACE]);; + +(* Munkres Exercise 41.5: Expansion Lemma. + If {B_alpha} is a locally finite family of subsets of a paracompact + Hausdorff space X, there is a locally finite family {U_alpha} of open + sets with B_alpha SUBSET U_alpha for each alpha. + Proof: Build open cover N from LF of B, get LF closed refinement C, + then use expansion E(b) = X \ UNIONS{c IN C | c INTER b = {}}. *) +let PARACOMPACT_HAUSDORFF_EXPANSION_LEMMA = prove + (`!top (B:(A->bool)->bool). + paracompact_space top /\ hausdorff_space top /\ + (!b. b IN B ==> b SUBSET topspace top) /\ + locally_finite_in top B + ==> ?f. (!b. b IN B ==> open_in top (f b)) /\ + (!b. b IN B ==> b SUBSET f b) /\ + locally_finite_in top {f b | b IN B}`, + REPEAT STRIP_TAC THEN + (* Paracompact Hausdorff => regular *) + SUBGOAL_THEN `regular_space (top:A topology)` ASSUME_TAC THENL + [ASM_MESON_TAC[PARACOMPACT_HAUSDORFF_IMP_REGULAR_SPACE]; ALL_TAC] THEN + (* Step 1: Build open cover N = {w open | FINITE {b IN B | b meets w}} *) + ABBREV_TAC + `N = {w:A->bool | open_in top w /\ + FINITE {b:A->bool | b IN B /\ ~(b INTER w = {})}}` THEN + SUBGOAL_THEN `(!w:A->bool. w IN N ==> open_in top w)` ASSUME_TAC THENL + [EXPAND_TAC "N" THEN SIMP_TAC[IN_ELIM_THM]; ALL_TAC] THEN + SUBGOAL_THEN `UNIONS (N:(A->bool)->bool) = topspace top` + (LABEL_TAC "Ncov") THENL + [MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET] THEN ASM_MESON_TAC[OPEN_IN_SUBSET]; + REWRITE_TAC[SUBSET; IN_UNIONS] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + UNDISCH_TAC `locally_finite_in top (B:(A->bool)->bool)` THEN + REWRITE_TAC[locally_finite_in] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `x:A`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `w:A->bool` THEN ASM_REWRITE_TAC[] THEN + EXPAND_TAC "N" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_REWRITE_TAC[]]; ALL_TAC] THEN - MATCH_MP_TAC(TAUT `p /\ (p ==> q) ==> p /\ q`) THEN CONJ_TAC THENL - [X_GEN_TAC `x:A` THEN DISCH_TAC THEN - MATCH_MP_TAC REAL_INF_LE THEN REWRITE_TAC[EXISTS_IN_GSPEC] THEN - EXISTS_TAC `&0` THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `a:A` THEN - RULE_ASSUM_TAC(REWRITE_RULE[CONTINUOUS_MAP_IN_SUBTOPOLOGY; - SUBSET; FORALL_IN_IMAGE; IN_REAL_INTERVAL]) THEN - ASM SET_TAC[]; - DISCH_TAC] THEN - CONJ_TAC THEN X_GEN_TAC `x:A` THEN DISCH_TAC THENL - [MATCH_MP_TAC REAL_INF_LE THEN REWRITE_TAC[EXISTS_IN_GSPEC] THEN - EXISTS_TAC `&0`; - REWRITE_TAC[GSYM REAL_LE_ANTISYM] THEN CONJ_TAC THENL - [ASM_MESON_TAC[SUBSET; CLOSED_IN_SUBSET]; ALL_TAC] THEN - MATCH_MP_TAC REAL_LE_INF THEN - ASM_REWRITE_TAC[SIMPLE_IMAGE; IMAGE_EQ_EMPTY; FORALL_IN_IMAGE]] THEN - RULE_ASSUM_TAC(REWRITE_RULE[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET; - FORALL_IN_IMAGE; IN_REAL_INTERVAL; UNIONS_IMAGE; IN_ELIM_THM]) THEN - REWRITE_TAC[FORALL_IN_GSPEC] THEN - ASM_MESON_TAC[REAL_LT_IMP_LE; REAL_LE_REFL]);; + (* Step 2: Get LF closed refinement C of N *) + SUBGOAL_THEN + `?C:(A->bool)->bool. + UNIONS C = topspace top /\ locally_finite_in top C /\ + (!c. c IN C ==> closed_in top c) /\ + (!c. c IN C ==> ?n. n IN N /\ c SUBSET n)` + (X_CHOOSE_THEN `C:(A->bool)->bool` + (CONJUNCTS_THEN2 (LABEL_TAC "Ccov") + (CONJUNCTS_THEN2 (LABEL_TAC "Clf") + (CONJUNCTS_THEN2 (LABEL_TAC "Cclosed") (LABEL_TAC "Cref"))))) THENL + [MP_TAC(SPEC `top:A topology` LF_COVERING_IMP_LF_CLOSED) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN + X_GEN_TAC `BB:(A->bool)->bool` THEN STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [paracompact_space]) THEN + DISCH_THEN(MP_TAC o SPEC `BB:(A->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]; + DISCH_THEN(MP_TAC o SPEC `N:(A->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]]; + ALL_TAC] THEN + (* Step 3: Each c IN C meets finitely many elements of B *) + SUBGOAL_THEN + `!c:A->bool. c IN C ==> FINITE {b:A->bool | b IN B /\ ~(b INTER c = {})}` + (LABEL_TAC "fin") THENL + [X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN + SUBGOAL_THEN `?n:A->bool. n IN N /\ (c:A->bool) SUBSET n` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `{b:A->bool | b IN B /\ ~(b INTER n = {})}` THEN + CONJ_TAC THENL + [UNDISCH_TAC `(n:A->bool) IN N` THEN EXPAND_TAC "N" THEN + SIMP_TAC[IN_ELIM_THM]; + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN ASM SET_TAC[]]; + ALL_TAC] THEN + (* Step 4: Expansion E(b) = X \ UNIONS{c IN C | c INTER b = {}} *) + EXISTS_TAC `\b:A->bool. + topspace top DIFF UNIONS {c:A->bool | c IN C /\ c INTER b = {}}` THEN + BETA_TAC THEN REPEAT CONJ_TAC THENL + [(* E(b) is open -- use EXPANSION_SET_OPEN *) + X_GEN_TAC `b:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC(ISPEC `top:A topology` EXPANSION_SET_OPEN) THEN + ASM_MESON_TAC[]; + (* b SUBSET E(b) -- use EXPANSION_SET_CONTAINS *) + X_GEN_TAC `b:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC(ISPEC `top:A topology` EXPANSION_SET_CONTAINS) THEN + ASM_MESON_TAC[]; + (* locally_finite_in top {E(b) | b IN B} *) + REWRITE_TAC[locally_finite_in] THEN CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_GSPEC] THEN REPEAT STRIP_TAC THEN + REWRITE_TAC[SUBSET; IN_DIFF] THEN MESON_TAC[]; + ALL_TAC] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + (* Use LF of C to get W meeting finitely many c's *) + REMOVE_THEN "Clf" (MP_TAC o REWRITE_RULE[locally_finite_in]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `x:A`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `W:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `W:A->bool` THEN ASM_REWRITE_TAC[] THEN + ABBREV_TAC `CW = {c:A->bool | c IN C /\ ~(c INTER W = {})}` THEN + SUBGOAL_THEN `FINITE (CW:(A->bool)->bool)` ASSUME_TAC THENL + [EXPAND_TAC "CW" THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* {E(b) | b IN B, E(b) meets W} SUBSET + IMAGE E (UNIONS {{b | b IN B, b meets c} | c IN CW}) *) + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC + `IMAGE (\b:A->bool. + topspace top DIFF UNIONS {c:A->bool | c IN C /\ c INTER b = {}}) + (UNIONS {{b:A->bool | b IN B /\ ~(b INTER c = {})} | + c IN CW})` THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN + ASM_SIMP_TAC[FINITE_UNIONS; SIMPLE_IMAGE; FINITE_IMAGE; + FORALL_IN_GSPEC] THEN + X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN + USE_THEN "fin" MATCH_MP_TAC THEN + UNDISCH_TAC `(c:A->bool) IN CW` THEN + EXPAND_TAC "CW" THEN SIMP_TAC[IN_ELIM_THM]; + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `t:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `b:A->bool` STRIP_ASSUME_TAC) ASSUME_TAC) THEN + REWRITE_TAC[IN_IMAGE] THEN + EXISTS_TAC `b:A->bool` THEN BETA_TAC THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + (* Get y IN t INTER W *) + SUBGOAL_THEN `?y:A. y IN t /\ y IN W` STRIP_ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(y:A) IN topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[IN_DIFF]; ALL_TAC] THEN + SUBGOAL_THEN + `~((y:A) IN UNIONS {c:A->bool | c IN C /\ c INTER b = {}})` + ASSUME_TAC THENL + [ASM_MESON_TAC[IN_DIFF]; ALL_TAC] THEN + (* y is in some c0 IN C since C covers *) + SUBGOAL_THEN `?c0:A->bool. c0 IN C /\ y IN c0` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `(y:A) IN topspace top` THEN + ASM_REWRITE_TAC[GSYM IN_UNIONS] THEN + REWRITE_TAC[IN_UNIONS] THEN MESON_TAC[]; + ALL_TAC] THEN + (* c0 INTER b != {} *) + SUBGOAL_THEN `~(c0 INTER (b:A->bool) = {})` ASSUME_TAC THENL + [DISCH_TAC THEN + UNDISCH_TAC + `~((y:A) IN UNIONS {c:A->bool | c IN C /\ c INTER b = {}})` THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `c0:A->bool` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* c0 IN CW *) + SUBGOAL_THEN `(c0:A->bool) IN CW` ASSUME_TAC THENL + [EXPAND_TAC "CW" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + ALL_TAC] THEN + EXISTS_TAC `{b':A->bool | b' IN B /\ ~(b' INTER c0 = {})}` THEN + CONJ_TAC THENL + [EXISTS_TAC `c0:A->bool` THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[IN_ELIM_THM] THEN + ONCE_REWRITE_TAC[INTER_COMM] THEN ASM_REWRITE_TAC[]]]]);; + +(* For regular spaces, paracompact iff every open cover has a + locally finite closed refinement. *) +let PARACOMPACT_SPACE_EQ_CLOSED_REFINEMENT = prove + (`!top:A topology. + regular_space top + ==> (paracompact_space top <=> + !U. (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?V. (!v. v IN V ==> closed_in top v) /\ + UNIONS V = topspace top /\ + (!v. v IN V ==> ?u. u IN U /\ v SUBSET u) /\ + locally_finite_in top V)`, + GEN_TAC THEN DISCH_TAC THEN EQ_TAC THENL + [(* Forward: paracompact ==> LF closed refinement. + Use LF_COVERING_IMP_LF_CLOSED: the hypothesis "every open cover + has a LF refinement" follows from paracompactness (which gives + a LF OPEN refinement, a fortiori a LF refinement). *) + DISCH_TAC THEN + MP_TAC(SPEC `top:A topology` LF_COVERING_IMP_LF_CLOSED) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN + X_GEN_TAC `BB:(A->bool)->bool` THEN STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [paracompact_space]) THEN + DISCH_THEN(MP_TAC o SPEC `BB:(A->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]; + ALL_TAC] THEN + DISCH_THEN(fun th -> X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + MP_TAC(SPEC `U:(A->bool)->bool` th)) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]; + (* Backward: LF closed refinement ==> paracompact. + Use LF_COVERING_IMP_LF_OPEN with our hypothesis providing + the required "every open cover has LF closed refinement". *) + DISCH_TAC THEN REWRITE_TAC[paracompact_space] THEN + MP_TAC(SPEC `top:A topology` LF_COVERING_IMP_LF_OPEN) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN + X_GEN_TAC `BB:(A->bool)->bool` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `BB:(A->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]; + ALL_TAC] THEN + DISCH_THEN(fun th -> X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + MP_TAC(SPEC `U:(A->bool)->bool` th)) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]]);; + +(* For regular spaces, paracompact iff every open cover has a + locally finite refinement (not necessarily open or closed). *) +let PARACOMPACT_SPACE_EQ_LOCALLY_FINITE_REFINEMENT = prove + (`!top:A topology. + regular_space top + ==> (paracompact_space top <=> + !U. (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?V. UNIONS V = topspace top /\ + (!v. v IN V ==> ?u. u IN U /\ v SUBSET u) /\ + locally_finite_in top V)`, + GEN_TAC THEN DISCH_TAC THEN EQ_TAC THENL + [(* Forward: paracompact gives LF open refinement, hence LF refinement *) + DISCH_THEN(MP_TAC o GEN_REWRITE_RULE I [paracompact_space]) THEN + DISCH_THEN(fun th -> X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + MP_TAC(SPEC `U:(A->bool)->bool` th)) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]; + (* Backward: LF refinement ==> paracompact. + Chain: LF_COVERING_IMP_LF_CLOSED gives LF closed refinement, + then LF_COVERING_IMP_LF_OPEN gives LF open refinement = paracompact. *) + DISCH_TAC THEN REWRITE_TAC[paracompact_space] THEN + (* First derive: every open cover has LF closed refinement *) + SUBGOAL_THEN + `!U:(A->bool)->bool. + (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace (top:A topology) + ==> ?W. UNIONS W = topspace top /\ locally_finite_in top W /\ + (!w. w IN W ==> closed_in top w) /\ + (!w. w IN W ==> ?u. u IN U /\ w SUBSET u)` + ASSUME_TAC THENL + [MP_TAC(SPEC `top:A topology` LF_COVERING_IMP_LF_CLOSED) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN + X_GEN_TAC `BB:(A->bool)->bool` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `BB:(A->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]; + DISCH_THEN(fun th -> X_GEN_TAC `UU:(A->bool)->bool` THEN + STRIP_TAC THEN MP_TAC(SPEC `UU:(A->bool)->bool` th)) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]]; + ALL_TAC] THEN + (* Then derive: every open cover has LF open refinement *) + MP_TAC(SPEC `top:A topology` LF_COVERING_IMP_LF_OPEN) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN + X_GEN_TAC `BB:(A->bool)->bool` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `BB:(A->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]; + ALL_TAC] THEN + DISCH_THEN(fun th -> X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + MP_TAC(SPEC `U:(A->bool)->bool` th)) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]]);; + +(* ------------------------------------------------------------------------- *) +(* Basic definition of the small inductive dimension relation ind t <= n. *) +(* We plan to prove most of the theorems in R^n so this is as good a *) +(* definition as any other, but the present stuff works in any top space. *) +(* ------------------------------------------------------------------------- *) + +parse_as_infix("dimension_le",(12,"right"));; + +let DIMENSION_LE_RULES,DIMENSION_LE_INDUCT,DIMENSION_LE_CASES = + new_inductive_definition + `!top n. -- &1 <= n /\ + (!v a. open_in top v /\ a IN v + ==> ?u. a IN u /\ u SUBSET v /\ open_in top u /\ + subtopology top (top frontier_of u) + dimension_le (n - &1)) + ==> (top:A topology) dimension_le (n:int)`;; + +let DIMENSION_LE_NEIGHBOURHOOD_BASE = prove + (`!(top:A topology) n. + top dimension_le n <=> + -- &1 <= n /\ + neighbourhood_base_of + (\u. open_in top u /\ + (subtopology top (top frontier_of u)) + dimension_le (n - &1)) top`, + REPEAT GEN_TAC THEN SIMP_TAC[OPEN_NEIGHBOURHOOD_BASE_OF] THEN + GEN_REWRITE_TAC LAND_CONV [DIMENSION_LE_CASES] THEN MESON_TAC[]);; + +let DIMENSION_LE_BOUND = prove + (`!top:(A)topology n. top dimension_le n ==> -- &1 <= n`, + MATCH_MP_TAC DIMENSION_LE_INDUCT THEN SIMP_TAC[]);; -let URYSOHN_COMPLETELY_REGULAR_COMPACT_CLOSED = prove - (`!top s (t:A->bool) a b. - a <= b /\ completely_regular_space top /\ - compact_in top s /\ closed_in top t /\ DISJOINT s t - ==> ?f. continuous_map - (top,subtopology euclideanreal (real_interval[a,b])) f /\ - (!x. x IN t ==> f x = a) /\ - (!x. x IN s ==> f x = b)`, - REPEAT STRIP_TAC THEN MP_TAC(ISPECL - [`top:A topology`; `t:A->bool`; `s:A->bool`;`--b:real`; `--a:real`] - URYSOHN_COMPLETELY_REGULAR_CLOSED_COMPACT) THEN - ASM_REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET; REAL_LE_NEG2] THEN - ONCE_REWRITE_TAC[DISJOINT_SYM] THEN - ASM_REWRITE_TAC[FORALL_IN_IMAGE; IN_REAL_INTERVAL] THEN - REWRITE_TAC[REAL_ARITH `--b <= x /\ x <= --a <=> a <= --x /\ --x <= b`] THEN - REWRITE_TAC[REAL_ARITH `x:real = --a <=> --x = a`] THEN - DISCH_THEN(X_CHOOSE_THEN `f:A->real` STRIP_ASSUME_TAC) THEN - EXISTS_TAC `\x. --((f:A->real) x)` THEN - ASM_REWRITE_TAC[CONTINUOUS_MAP_REAL_NEG_EQ]);; +let DIMENSION_LE_MONO = prove + (`!top:(A)topology m n. top dimension_le m /\ m <= n ==> top dimension_le n`, + REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN + MATCH_MP_TAC DIMENSION_LE_INDUCT THEN + MAP_EVERY X_GEN_TAC [`top:(A)topology`; `m:int`] THEN STRIP_TAC THEN + X_GEN_TAC `n:int` THEN DISCH_TAC THEN + GEN_REWRITE_TAC I [DIMENSION_LE_CASES] THEN + CONJ_TAC THENL [ASM_MESON_TAC[INT_LE_TRANS]; ALL_TAC] THEN + MAP_EVERY X_GEN_TAC [`v:A->bool`; `a:A`] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`v:A->bool`; `a:A`]) THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC MONO_EXISTS THEN + GEN_TAC THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_INT_ARITH_TAC);; -let URYSOHN_COMPLETELY_REGULAR_COMPACT_CLOSED_ALT = prove - (`!top s (t:A->bool) a b. - completely_regular_space top /\ - compact_in top s /\ closed_in top t /\ DISJOINT s t - ==> ?f. continuous_map (top,euclideanreal) f /\ - (!x. x IN t ==> f x = a) /\ - (!x. x IN s ==> f x = b)`, - REPEAT STRIP_TAC THEN DISJ_CASES_TAC(REAL_ARITH `a <= b \/ b <= a`) THENL - [MP_TAC(ISPECL - [`top:A topology`; `s:A->bool`; `t:A->bool`; `a:real`; `b:real`] - URYSOHN_COMPLETELY_REGULAR_COMPACT_CLOSED); - MP_TAC(ISPECL - [`top:A topology`; `t:A->bool`; `s:A->bool`; `b:real`; `a:real`] - URYSOHN_COMPLETELY_REGULAR_CLOSED_COMPACT)] THEN - ASM_REWRITE_TAC[] THEN ONCE_REWRITE_TAC[DISJOINT_SYM] THEN - ASM_REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN MESON_TAC[]);; +let DIMENSION_LE_EQ_EMPTY = prove + (`!top:(A)topology. top dimension_le (-- &1) <=> topspace top = {}`, + REPEAT GEN_TAC THEN ONCE_REWRITE_TAC[DIMENSION_LE_CASES] THEN + CONV_TAC INT_REDUCE_CONV THEN + SUBGOAL_THEN `!top:A topology. ~(top dimension_le --(&2))` + (fun th -> REWRITE_TAC[th]) + THENL + [GEN_TAC THEN DISCH_THEN(MP_TAC o MATCH_MP DIMENSION_LE_BOUND) THEN + INT_ARITH_TAC; + EQ_TAC THENL + [DISCH_THEN(MP_TAC o SPEC `topspace top:A->bool`) THEN + REWRITE_TAC[OPEN_IN_TOPSPACE] THEN SET_TAC[]; + REPEAT STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN + ASM SET_TAC[]]]);; -let TIETZE_EXTENSION_COMPLETELY_REGULAR = prove - (`!top (f:A->real) s t. - completely_regular_space top /\ - compact_in top s /\ is_realinterval t /\ ~(t = {}) /\ - continuous_map (subtopology top s,euclideanreal) f /\ - (!x. x IN s ==> f x IN t) - ==> ?g. continuous_map (top,euclideanreal) g /\ - (!x. x IN topspace top ==> g x IN t) /\ - (!x. x IN s ==> g x = f x)`, - let lemma = prove - (`!top (f:A->real) s t. - completely_regular_space top /\ hausdorff_space top /\ - compact_in top s /\ is_realinterval t /\ ~(t = {}) /\ - continuous_map (subtopology top s,euclideanreal) f /\ - (!x. x IN s ==> f x IN t) - ==> ?g. continuous_map (top,euclideanreal) g /\ - (!x. x IN topspace top ==> g x IN t) /\ - (!x. x IN s ==> g x = f x)`, - REPEAT STRIP_TAC THEN - MP_TAC(ISPEC `top:A topology` COMPLETELY_REGULAR_SPACE_CUBE_EMBEDDING) THEN - ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`k:((A->real)->bool)`; `e:A->(A->real)->real`] THEN - REWRITE_TAC[embedding_map; HOMEOMORPHIC_MAP_MAPS; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `e':((A->real)->real)->A` THEN ABBREV_TAC - `cube:((A->real)->real)topology = - product_topology k - (\f. subtopology euclideanreal (real_interval [&0,&1]))` THEN - REWRITE_TAC[homeomorphic_maps] THEN STRIP_TAC THEN - MP_TAC(ISPECL - [`cube:((A->real)->real)topology`; - `(f:A->real) o (e':((A->real)->real)->A)`; - `IMAGE (e:A->(A->real)->real) s`; - `t:real->bool`] TIETZE_EXTENSION_REALINTERVAL) THEN - ASM_SIMP_TAC[FORALL_IN_IMAGE; o_THM] THEN ANTS_TAC THENL - [REPEAT CONJ_TAC THENL - [MATCH_MP_TAC COMPACT_HAUSDORFF_OR_REGULAR_IMP_NORMAL_SPACE THEN - EXPAND_TAC "cube" THEN - REWRITE_TAC[COMPACT_SPACE_PRODUCT_TOPOLOGY; - HAUSDORFF_SPACE_PRODUCT_TOPOLOGY] THEN - SIMP_TAC[HAUSDORFF_SPACE_SUBTOPOLOGY; - HAUSDORFF_SPACE_EUCLIDEANREAL] THEN - SIMP_TAC[COMPACT_IN_EUCLIDEANREAL_INTERVAL; COMPACT_SPACE_SUBTOPOLOGY]; - MATCH_MP_TAC COMPACT_IN_IMP_CLOSED_IN THEN CONJ_TAC THENL - [EXPAND_TAC "cube" THEN - SIMP_TAC[HAUSDORFF_SPACE_PRODUCT_TOPOLOGY; - HAUSDORFF_SPACE_SUBTOPOLOGY; - HAUSDORFF_SPACE_EUCLIDEANREAL]; - MATCH_MP_TAC IMAGE_COMPACT_IN THEN EXISTS_TAC `top:A topology` THEN - ASM_MESON_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY]]; - MATCH_MP_TAC CONTINUOUS_MAP_COMPOSE THEN - EXISTS_TAC `subtopology top (s:A->bool)` THEN - ASM_REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN CONJ_TAC THENL - [FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (REWRITE_RULE[IMP_CONJ] - CONTINUOUS_MAP_FROM_SUBTOPOLOGY_MONO)) THEN - ASM_SIMP_TAC[COMPACT_IN_SUBSET_TOPSPACE; IMAGE_SUBSET]; - REWRITE_TAC[TOPSPACE_SUBTOPOLOGY] THEN - MATCH_MP_TAC(SET_RULE - `(!x. x IN s ==> f(g x) = x) - ==> IMAGE f (u INTER IMAGE g s) SUBSET s`) THEN - FIRST_X_ASSUM(MP_TAC o MATCH_MP COMPACT_IN_SUBSET_TOPSPACE) THEN - ASM SET_TAC[]]; - FIRST_X_ASSUM(MP_TAC o MATCH_MP COMPACT_IN_SUBSET_TOPSPACE) THEN - ASM SET_TAC[]]; - DISCH_THEN(X_CHOOSE_THEN `g:((A->real)->real)->real` - STRIP_ASSUME_TAC) THEN - EXISTS_TAC `(g:((A->real)->real)->real) o (e:A->(A->real)->real)` THEN - CONJ_TAC THENL - [ASM_MESON_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; CONTINUOUS_MAP_COMPOSE]; - REWRITE_TAC[o_THM] THEN - FIRST_X_ASSUM(MP_TAC o MATCH_MP COMPACT_IN_SUBSET_TOPSPACE) THEN - REPEAT(FIRST_X_ASSUM(MP_TAC o MATCH_MP - CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE)) THEN - REWRITE_TAC[TOPSPACE_SUBTOPOLOGY] THEN ASM SET_TAC[]]]) in - REPEAT STRIP_TAC THEN - ABBREV_TAC `q:A->bool = IMAGE (kolmogorov_quotient top) (topspace top)` THEN - MP_TAC(ISPECL - [`top:A topology`; `euclideanreal`; `f:A->real`; `s:A->bool`] - KOLMOGOROV_QUOTIENT_LIFT_EXISTS) THEN - SIMP_TAC[HAUSDORFF_IMP_T0_SPACE; HAUSDORFF_SPACE_EUCLIDEANREAL] THEN - ASM_SIMP_TAC[COMPACT_IN_SUBSET_TOPSPACE; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `g:A->real` THEN STRIP_TAC THEN - MP_TAC(ISPECL - [`subtopology top (q:A->bool)`; `g:A->real`; - `IMAGE (kolmogorov_quotient top) (s:A->bool)`; - `t:real->bool`] - lemma) THEN - ASM_SIMP_TAC[COMPLETELY_REGULAR_SPACE_SUBTOPOLOGY; FORALL_IN_IMAGE] THEN - REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; SUBTOPOLOGY_SUBTOPOLOGY] THEN - EXPAND_TAC "q" THEN REWRITE_TAC[IN_INTER; IMP_CONJ_ALT; FORALL_IN_IMAGE] THEN - ASM_SIMP_TAC[COMPACT_IN_SUBSET_TOPSPACE; SET_RULE - `s SUBSET u ==> IMAGE f u INTER IMAGE f s = IMAGE f s`] THEN - SIMP_TAC[KOLMOGOROV_QUOTIENT_IN_TOPSPACE] THEN - REWRITE_TAC[IMP_IMP] THEN ANTS_TAC THENL - [CONJ_TAC THENL - [MATCH_MP_TAC IMAGE_COMPACT_IN THEN - EXISTS_TAC `top:A topology` THEN - ASM_REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET_REFL] THEN - REWRITE_TAC[CONTINUOUS_MAP_KOLMOGOROV_QUOTIENT]; - MATCH_MP_TAC REGULAR_T0_IMP_HAUSDORFF_SPACE THEN - ASM_SIMP_TAC[REGULAR_SPACE_SUBTOPOLOGY; - COMPLETELY_REGULAR_IMP_REGULAR_SPACE] THEN - EXPAND_TAC "q" THEN REWRITE_TAC[T0_SPACE_KOLMOGOROV_QUOTIENT]]; - DISCH_THEN(X_CHOOSE_THEN `h:A->real` STRIP_ASSUME_TAC) THEN - EXISTS_TAC `(h:A->real) o kolmogorov_quotient top` THEN - ASM_REWRITE_TAC[o_THM] THEN MATCH_MP_TAC CONTINUOUS_MAP_COMPOSE THEN - EXISTS_TAC `subtopology top (q:A->bool)` THEN - ASM_REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET_REFL] THEN - REWRITE_TAC[CONTINUOUS_MAP_KOLMOGOROV_QUOTIENT]]);; +let DIMENSION_LE_0_NEIGHBOURHOOD_BASE_OF_CLOPEN = prove + (`!top:A topology. + top dimension_le &0 <=> + neighbourhood_base_of (\u. closed_in top u /\ open_in top u) top`, + GEN_TAC THEN GEN_REWRITE_TAC LAND_CONV [DIMENSION_LE_NEIGHBOURHOOD_BASE] THEN + CONV_TAC INT_REDUCE_CONV THEN + REWRITE_TAC[DIMENSION_LE_EQ_EMPTY; TOPSPACE_SUBTOPOLOGY] THEN + AP_THM_TAC THEN AP_TERM_TAC THEN ABS_TAC THEN + SIMP_TAC[FRONTIER_OF_SUBSET_TOPSPACE; SET_RULE + `s SUBSET u ==> u INTER s = s`] THEN + MESON_TAC[FRONTIER_OF_EQ_EMPTY; OPEN_IN_SUBSET]);; + +let DIMENSION_LE_SUBTOPOLOGY = prove + (`!top n s:A->bool. + top dimension_le n ==> (subtopology top s) dimension_le n`, + REWRITE_TAC[RIGHT_FORALL_IMP_THM] THEN MATCH_MP_TAC DIMENSION_LE_INDUCT THEN + MAP_EVERY X_GEN_TAC [`top:A topology`; `n:int`] THEN STRIP_TAC THEN + X_GEN_TAC `s:A->bool` THEN GEN_REWRITE_TAC I [DIMENSION_LE_CASES] THEN + ASM_REWRITE_TAC[] THEN MAP_EVERY X_GEN_TAC [`u':A->bool`; `a:A`] THEN + GEN_REWRITE_TAC (LAND_CONV o LAND_CONV) [OPEN_IN_SUBTOPOLOGY] THEN + REWRITE_TAC[IMP_CONJ; LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN DISCH_THEN SUBST1_TAC THEN + REWRITE_TAC[IN_INTER] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`u:A->bool`; `a:A`]) THEN + ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `v:A->bool` THEN STRIP_TAC THEN + EXISTS_TAC `s INTER v:A->bool` THEN + ASM_REWRITE_TAC[IN_INTER] THEN REPEAT CONJ_TAC THENL + [ASM SET_TAC[]; + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN ASM_MESON_TAC[INTER_COMM]; + FIRST_X_ASSUM(MP_TAC o SPEC + `subtopology top s frontier_of (s INTER v):A->bool`) THEN + REWRITE_TAC[SUBTOPOLOGY_SUBTOPOLOGY] THEN + MATCH_MP_TAC EQ_IMP THEN AP_THM_TAC THEN AP_TERM_TAC THEN + AP_TERM_TAC THEN MATCH_MP_TAC(SET_RULE + `s SUBSET u /\ s SUBSET t ==> t INTER s = u INTER s`) THEN + REWRITE_TAC[FRONTIER_OF_SUBSET_SUBTOPOLOGY] THEN + REWRITE_TAC[FRONTIER_OF_CLOSURES; CLOSURE_OF_SUBTOPOLOGY] THEN + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; INTER_ASSOC] THEN + MATCH_MP_TAC(SET_RULE + `t SUBSET u /\ v SUBSET w + ==> s INTER t INTER s INTER v SUBSET u INTER w`) THEN + CONJ_TAC THEN MATCH_MP_TAC CLOSURE_OF_MONO THEN SET_TAC[]]);; + +let DIMENSION_LE_SUBTOPOLOGIES = prove + (`!top n s t:A->bool. + s SUBSET t /\ + subtopology top t dimension_le n + ==> (subtopology top s) dimension_le n`, + REPEAT STRIP_TAC THEN FIRST_ASSUM(MP_TAC o + ISPEC `s:A->bool` o MATCH_MP DIMENSION_LE_SUBTOPOLOGY) THEN + REWRITE_TAC[SUBTOPOLOGY_SUBTOPOLOGY] THEN + ASM_SIMP_TAC[SET_RULE `s SUBSET t ==> t INTER s = s`]);; + +let DIMENSION_LE_EQ_SUBTOPOLOGY = prove + (`!top s:A->bool n. + (subtopology top s) dimension_le n <=> + -- &1 <= n /\ + !v a. open_in top v /\ a IN v /\ a IN s + ==> ?u. a IN u /\ u SUBSET v /\ open_in top u /\ + subtopology top + ((subtopology top s frontier_of (s INTER u))) + dimension_le (n - &1)`, + REPEAT GEN_TAC THEN + GEN_REWRITE_TAC LAND_CONV [DIMENSION_LE_CASES] THEN + REWRITE_TAC[SUBTOPOLOGY_SUBTOPOLOGY; OPEN_IN_SUBTOPOLOGY] THEN + REWRITE_TAC[LEFT_AND_EXISTS_THM; LEFT_IMP_EXISTS_THM] THEN + ONCE_REWRITE_TAC[MESON[] + `(!v a t. (P t /\ Q v t) /\ R a v t ==> S a v t) <=> + (!t a v. Q v t ==> P t /\ R a v t ==> S a v t)`] THEN + REWRITE_TAC[FORALL_UNWIND_THM2] THEN AP_TERM_TAC THEN + AP_TERM_TAC THEN GEN_REWRITE_TAC I [FUN_EQ_THM] THEN + X_GEN_TAC `v:A->bool` THEN REWRITE_TAC[] THEN + AP_TERM_TAC THEN GEN_REWRITE_TAC I [FUN_EQ_THM] THEN + X_GEN_TAC `a:A` THEN REWRITE_TAC[IN_INTER] THEN + MATCH_MP_TAC(TAUT `(p ==> (q <=> r)) ==> (p ==> q <=> p ==> r)`) THEN + STRIP_TAC THEN REWRITE_TAC[RIGHT_AND_EXISTS_THM] THEN + GEN_REWRITE_TAC LAND_CONV [SWAP_EXISTS_THM] THEN + ONCE_REWRITE_TAC[TAUT + `p /\ q /\ (r /\ s) /\ t <=> s /\ p /\ q /\ r /\ t`] THEN + ASM_REWRITE_TAC[UNWIND_THM2; IN_INTER] THEN + EQ_TAC THEN DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `u INTER v:A->bool` THEN + ASM_SIMP_TAC[IN_INTER; OPEN_IN_INTER] THEN + (CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC]) THEN + ASM_SIMP_TAC[SET_RULE `u SUBSET v ==> u INTER v = u`; + SET_RULE `u INTER s SUBSET v INTER s + ==> s INTER u INTER v = s INTER u`] THEN + POP_ASSUM_LIST(MP_TAC o end_itlist CONJ o rev) THEN + ASM_SIMP_TAC[FRONTIER_OF_SUBSET_SUBTOPOLOGY; + SET_RULE `v SUBSET u ==> u INTER v = v`] THEN + STRIP_TAC THEN ONCE_REWRITE_TAC[INTER_COMM] THEN ASM_REWRITE_TAC[]);; -(* ------------------------------------------------------------------------- *) -(* Embedding in products and hence more about completely metrizable spaces. *) -(* ------------------------------------------------------------------------- *) +let HOMEOMORPHIC_SPACE_DIMENSION_LE = prove + (`!(top:A topology) (top':B topology) n. + top homeomorphic_space top' + ==> (top dimension_le n <=> top' dimension_le n)`, + let lemma = prove + (`!n (top:A topology) (top':B topology). + top homeomorphic_space top' /\ top dimension_le (&n - &1) + ==> top' dimension_le (&n - &1)`, + INDUCT_TAC THENL + [CONV_TAC INT_REDUCE_CONV THEN REWRITE_TAC[DIMENSION_LE_EQ_EMPTY] THEN + MESON_TAC[HOMEOMORPHIC_EMPTY_SPACE]; + REWRITE_TAC[GSYM INT_OF_NUM_SUC; INT_ARITH `(x + y) - y:int = x`]] THEN + MAP_EVERY X_GEN_TAC [`top:A topology`; `top':B topology`] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + ONCE_REWRITE_TAC[DIMENSION_LE_CASES] THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [homeomorphic_space]) THEN + REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`f:A->B`; `g:B->A`] THEN STRIP_TAC THEN + MAP_EVERY X_GEN_TAC [`v:B->bool`; `b:B`] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`IMAGE (g:B->A) v`; `(g:B->A) b`]) THEN + ANTS_TAC THENL + [ASM_MESON_TAC[HOMEOMORPHIC_MAPS_MAP; HOMEOMORPHIC_IMP_OPEN_MAP; + open_map; FUN_IN_IMAGE]; + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC)] THEN + EXISTS_TAC `IMAGE (f:A->B) u` THEN REPEAT CONJ_TAC THENL + [REPEAT(FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET)) THEN + RULE_ASSUM_TAC(REWRITE_RULE[homeomorphic_maps; continuous_map]) THEN + ASM SET_TAC[]; + REPEAT(FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET)) THEN + RULE_ASSUM_TAC(REWRITE_RULE[homeomorphic_maps; continuous_map]) THEN + ASM SET_TAC[]; + ASM_MESON_TAC[HOMEOMORPHIC_MAPS_MAP; HOMEOMORPHIC_MAP_OPENNESS_EQ]; + FIRST_X_ASSUM MATCH_MP_TAC THEN + EXISTS_TAC `subtopology top (top frontier_of u:A->bool)` THEN + ASM_REWRITE_TAC[homeomorphic_space] THEN + MAP_EVERY EXISTS_TAC [`f:A->B`; `g:B->A`] THEN + MATCH_MP_TAC HOMEOMORPHIC_MAPS_SUBTOPOLOGIES THEN + ASM_SIMP_TAC[FRONTIER_OF_SUBSET_TOPSPACE; SET_RULE + `s SUBSET t ==> t INTER s = s`] THEN + CONV_TAC SYM_CONV THEN MATCH_MP_TAC HOMEOMORPHIC_MAP_FRONTIER_OF THEN + ASM_MESON_TAC[OPEN_IN_SUBSET; HOMEOMORPHIC_MAPS_MAP]]) in + REPEAT STRIP_TAC THEN ASM_CASES_TAC `-- &1:int <= n` THENL + [ALL_TAC; ASM_MESON_TAC[DIMENSION_LE_BOUND]] THEN + SUBST1_TAC(INT_ARITH `n:int = (n + &1) - &1`) THEN + FIRST_X_ASSUM(MP_TAC o MATCH_MP + (INT_ARITH `--x:int <= y ==> &0 <= y + x`)) THEN + REWRITE_TAC[GSYM INT_OF_NUM_EXISTS; LEFT_IMP_EXISTS_THM] THEN + X_GEN_TAC `n:num` THEN DISCH_THEN SUBST1_TAC THEN + EQ_TAC THEN MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ] lemma) THEN + ASM_MESON_TAC[HOMEOMORPHIC_SPACE_SYM]);; -let GDELTA_HOMEOMORPHIC_SPACE_CLOSED_IN_PRODUCT = prove - (`!top (s:K->A->bool) k. - metrizable_space top /\ (!i. i IN k ==> open_in top(s i)) - ==> ?t. closed_in - (prod_topology top (product_topology k (\i. euclideanreal))) - t /\ - subtopology top (INTERS {s i | i IN k}) homeomorphic_space - subtopology - (prod_topology top (product_topology k (\i. euclideanreal))) - t`, - REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM; FORALL_METRIZABLE_SPACE] THEN - MAP_EVERY X_GEN_TAC [`m:A metric`; `s:K->A->bool`; `k:K->bool`] THEN - DISCH_TAC THEN ASM_CASES_TAC `k:K->bool = {}` THENL - [ASM_REWRITE_TAC[NOT_IN_EMPTY; SET_RULE `{f x |x| F} = {}`] THEN - REWRITE_TAC[INTERS_0; SUBTOPOLOGY_UNIV; - PRODUCT_TOPOLOGY_EMPTY_DISCRETE] THEN - EXISTS_TAC - `(mspace m:A->bool) CROSS {(\x. ARB):K->real}` THEN - REWRITE_TAC[CLOSED_IN_CROSS; CLOSED_IN_MSPACE] THEN - REWRITE_TAC[CLOSED_IN_DISCRETE_TOPOLOGY; SUBSET_REFL] THEN - REWRITE_TAC[SUBTOPOLOGY_CROSS; SUBTOPOLOGY_MSPACE] THEN - MATCH_MP_TAC(CONJUNCT1 HOMEOMORPHIC_SPACE_PROD_TOPOLOGY_SING) THEN - REWRITE_TAC[TOPSPACE_DISCRETE_TOPOLOGY; IN_SING]; - ALL_TAC] THEN - REPEAT STRIP_TAC THEN - SUBGOAL_THEN `!i. i IN k ==> (s:K->A->bool) i SUBSET mspace m` - ASSUME_TAC THENL - [ASM_MESON_TAC[OPEN_IN_SUBSET; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN - SUBGOAL_THEN `INTERS {(s:K->A->bool) i | i IN k} SUBSET mspace m` - ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN ABBREV_TAC - `d:K->A->real = - \i. if ~(i IN k) \/ s i = mspace m then \a. &1 - else \a. inf {mdist m (a,x) |x| x IN mspace m DIFF s i}` THEN - SUBGOAL_THEN - `!i. continuous_map (subtopology (mtopology m) (s i),euclideanreal) - ((d:K->A->real) i)` - ASSUME_TAC THENL - [X_GEN_TAC `i:K` THEN EXPAND_TAC "d" THEN REWRITE_TAC[] THEN - COND_CASES_TAC THEN REWRITE_TAC[CONTINUOUS_MAP_REAL_CONST] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [DE_MORGAN_THM]) THEN - ASM_SIMP_TAC[OPEN_IN_SUBSET; IMP_CONJ; GSYM TOPSPACE_MTOPOLOGY; SET_RULE - `s SUBSET u ==> (~(s = u) <=> ~(u DIFF s = {}))`] THEN - REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN REPEAT STRIP_TAC THEN - REWRITE_TAC[GSYM MTOPOLOGY_SUBMETRIC; - GSYM MTOPOLOGY_REAL_EUCLIDEAN_METRIC] THEN - MATCH_MP_TAC LIPSCHITZ_CONTINUOUS_IMP_CONTINUOUS_MAP THEN - REWRITE_TAC[lipschitz_continuous_map; REAL_EUCLIDEAN_METRIC] THEN - REWRITE_TAC[SUBSET_UNIV; SUBMETRIC] THEN EXISTS_TAC `&1:real` THEN - MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN - REWRITE_TAC[IN_INTER; REAL_MUL_LID] THEN STRIP_TAC THEN - EXPAND_TAC "d" THEN REWRITE_TAC[REAL_ARITH - `abs(x - y) <= d <=> x - d <= y /\ y - d <= x`] THEN - CONJ_TAC THEN - W(MP_TAC o PART_MATCH (lhand o rand) REAL_LE_INF_EQ o snd) THEN - ASM_SIMP_TAC[SIMPLE_IMAGE; IMAGE_EQ_EMPTY; FORALL_IN_IMAGE; IN_DIFF] THEN - (ANTS_TAC THENL [ASM_MESON_TAC[MDIST_POS_LE]; DISCH_THEN SUBST1_TAC]) THEN - X_GEN_TAC `z:A` THEN STRIP_TAC THEN REWRITE_TAC[REAL_LE_SUB_RADD] THENL - [TRANS_TAC REAL_LE_TRANS `mdist m (y:A,z)`; - TRANS_TAC REAL_LE_TRANS `mdist m (x:A,z)`] THEN - (CONJ_TAC THENL - [MATCH_MP_TAC INF_LE_ELEMENT THEN - CONJ_TAC THENL [EXISTS_TAC `&0`; ASM SET_TAC[]] THEN - ASM_SIMP_TAC[FORALL_IN_IMAGE; IN_DIFF; MDIST_POS_LE]; - MAP_EVERY UNDISCH_TAC - [`(x:A) IN mspace m`; `(y:A) IN mspace m`; `(z:A) IN mspace m`] THEN - CONV_TAC METRIC_ARITH]); - ALL_TAC] THEN - SUBGOAL_THEN `!i x. x IN s i ==> &0 < (d:K->A->real) i x` - ASSUME_TAC THENL - [REPEAT STRIP_TAC THEN EXPAND_TAC "d" THEN REWRITE_TAC[] THEN - COND_CASES_TAC THEN REWRITE_TAC[REAL_LT_01] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [DE_MORGAN_THM]) THEN - ASM_SIMP_TAC[OPEN_IN_SUBSET; IMP_CONJ; GSYM TOPSPACE_MTOPOLOGY; SET_RULE - `s SUBSET u ==> (~(s = u) <=> ~(u DIFF s = {}))`] THEN - REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN REPEAT STRIP_TAC THEN - MP_TAC(ISPECL - [`m:A metric`; `(s:K->A->bool) i`] OPEN_IN_MTOPOLOGY) THEN - ASM_SIMP_TAC[] THEN - DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN - REWRITE_TAC[SUBSET; IN_MBALL; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `r:real` THEN STRIP_TAC THEN - TRANS_TAC REAL_LTE_TRANS `r:real` THEN ASM_REWRITE_TAC[] THEN - MATCH_MP_TAC REAL_LE_INF THEN - ASM_REWRITE_TAC[FORALL_IN_GSPEC; GSYM REAL_NOT_LT] THEN - REPEAT(FIRST_X_ASSUM(MP_TAC o SPEC `i:K`) THEN ASM_REWRITE_TAC[]) THEN - REPEAT DISCH_TAC THEN - FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN - REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN ASM SET_TAC[]; - ALL_TAC] THEN - ABBREV_TAC `f = \x. x,RESTRICTION k (\i. inv((d:K->A->real) i x))` THEN - EXISTS_TAC `IMAGE (f:A->A#(K->real)) (INTERS {s(i:K) | i IN k})` THEN - CONJ_TAC THENL - [ALL_TAC; - MP_TAC(snd(EQ_IMP_RULE(ISPECL - [`subtopology (mtopology m) (INTERS {(s:K->A->bool) i | i IN k})`; - `product_topology (k:K->bool) (\i. euclideanreal)`; - `\x. RESTRICTION k (\i. inv((d:K->A->real) i x))`] - EMBEDDING_MAP_GRAPH))) THEN - ASM_REWRITE_TAC[] THEN ANTS_TAC THENL - [REWRITE_TAC[CONTINUOUS_MAP_COMPONENTWISE; SUBSET; FORALL_IN_IMAGE] THEN - REWRITE_TAC[RESTRICTION_IN_EXTENSIONAL] THEN X_GEN_TAC `i:K` THEN - SIMP_TAC[RESTRICTION] THEN DISCH_TAC THEN - MATCH_MP_TAC CONTINUOUS_MAP_REAL_INV THEN CONJ_TAC THENL - [REWRITE_TAC[ETA_AX] THEN FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP - (REWRITE_RULE[IMP_CONJ] CONTINUOUS_MAP_FROM_SUBTOPOLOGY_MONO) o - SPEC `i:K`) THEN - ASM SET_TAC[]; - REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; IN_INTER; INTERS_GSPEC] THEN - ASM_SIMP_TAC[IN_ELIM_THM; REAL_LT_IMP_NZ]]; - DISCH_THEN(MP_TAC o MATCH_MP EMBEDDING_MAP_IMP_HOMEOMORPHIC_SPACE) THEN - MATCH_MP_TAC EQ_IMP THEN AP_TERM_TAC THEN - ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY_SUBSET; TOPSPACE_MTOPOLOGY] THEN - REWRITE_TAC[PROD_TOPOLOGY_SUBTOPOLOGY; SUBTOPOLOGY_SUBTOPOLOGY] THEN - AP_TERM_TAC THEN MATCH_MP_TAC(SET_RULE - `(!x. x IN s ==> f x IN t) ==> t INTER IMAGE f s = IMAGE f s`) THEN - SIMP_TAC[TOPSPACE_PRODUCT_TOPOLOGY; o_DEF; TOPSPACE_EUCLIDEANREAL] THEN - EXPAND_TAC "f" THEN SIMP_TAC[IN_CROSS] THEN - REWRITE_TAC[RESTRICTION_IN_CARTESIAN_PRODUCT; IN_UNIV]]] THEN - REWRITE_TAC[GSYM CLOSURE_OF_SUBSET_EQ] THEN CONJ_TAC THENL - [EXPAND_TAC "f" THEN REWRITE_TAC[SUBSET; FORALL_IN_IMAGE] THEN - REWRITE_TAC[TOPSPACE_PROD_TOPOLOGY; TOPSPACE_PRODUCT_TOPOLOGY] THEN - REWRITE_TAC[o_DEF; TOPSPACE_EUCLIDEANREAL; IN_CROSS] THEN - REWRITE_TAC[RESTRICTION_IN_CARTESIAN_PRODUCT; IN_UNIV] THEN - ASM_REWRITE_TAC[GSYM SUBSET; TOPSPACE_MTOPOLOGY]; - ALL_TAC] THEN - GEN_REWRITE_TAC I [SUBSET] THEN REWRITE_TAC[closure_of] THEN - REWRITE_TAC[FORALL_PAIR_THM; IN_ELIM_THM; TOPSPACE_PROD_TOPOLOGY] THEN - MAP_EVERY X_GEN_TAC [`x:A`; `ds:K->real`] THEN - REWRITE_TAC[IN_CROSS; TOPSPACE_MTOPOLOGY; TOPSPACE_PRODUCT_TOPOLOGY] THEN - REWRITE_TAC[o_THM; TOPSPACE_EUCLIDEANREAL; IN_UNIV; cartesian_product] THEN - REWRITE_TAC[IN_ELIM_THM] THEN - DISCH_THEN(CONJUNCTS_THEN2 STRIP_ASSUME_TAC MP_TAC) THEN - DISCH_THEN(MP_TAC o GENL [`u:A->bool`; `v:(K->real)->bool`] o - SPEC `(u:A->bool) CROSS (v:(K->real)->bool)`) THEN - REWRITE_TAC[IN_CROSS; OPEN_IN_CROSS; SET_RULE - `(x IN s /\ y IN t) /\ (s = {} \/ t = {} \/ R s t) <=> - x IN s /\ y IN t /\ R s t`] THEN - REWRITE_TAC[EXISTS_IN_IMAGE] THEN DISCH_TAC THEN - SUBGOAL_THEN `x IN INTERS {(s:K->A->bool) i | i IN k}` ASSUME_TAC THENL - [REWRITE_TAC[INTERS_GSPEC; IN_ELIM_THM] THEN - X_GEN_TAC `i:K` THEN DISCH_TAC THEN - GEN_REWRITE_TAC I [TAUT `p <=> ~p ==> F`] THEN DISCH_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPECL - [`mball m (x:A,inv(abs(ds(i:K)) + &1))`; - `{z | z IN topspace(product_topology k (\i. euclideanreal)) /\ - (z:K->real) i IN real_interval(ds i - &1,ds i + &1)}`]) THEN - REWRITE_TAC[IN_ELIM_THM; NOT_IMP] THEN REPEAT CONJ_TAC THENL - [MATCH_MP_TAC CENTRE_IN_MBALL THEN - ASM_REWRITE_TAC[REAL_LT_INV_EQ] THEN REAL_ARITH_TAC; - ASM_REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; TOPSPACE_EUCLIDEANREAL; o_DEF; - cartesian_product; IN_ELIM_THM; IN_UNIV]; - REWRITE_TAC[IN_REAL_INTERVAL] THEN REAL_ARITH_TAC; - REWRITE_TAC[OPEN_IN_MBALL]; - MATCH_MP_TAC OPEN_IN_CONTINUOUS_MAP_PREIMAGE THEN - EXISTS_TAC `euclideanreal` THEN - ASM_SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION] THEN - REWRITE_TAC[GSYM REAL_OPEN_IN; REAL_OPEN_REAL_INTERVAL]; +let DIMENSION_LE_RETRACTION_MAP_IMAGE = prove + (`!top top' n (r:A->B). + retraction_map(top,top') r /\ top dimension_le n + ==> top' dimension_le n`, + GEN_REWRITE_TAC I [MESON[] `(!x y z. P x y z) <=> (!z x y. P x y z)`] THEN + GEN_TAC THEN MATCH_MP_TAC HEREDITARY_IMP_RETRACTIVE_PROPERTY THEN + REWRITE_TAC[DIMENSION_LE_SUBTOPOLOGY; HOMEOMORPHIC_SPACE_DIMENSION_LE]);; + +let DIMENSION_LE_DISCRETE_TOPOLOGY = prove + (`!u:A->bool. (discrete_topology u) dimension_le &0`, + GEN_TAC THEN ONCE_REWRITE_TAC[DIMENSION_LE_CASES] THEN + CONV_TAC INT_REDUCE_CONV THEN + REWRITE_TAC[OPEN_IN_DISCRETE_TOPOLOGY; DISCRETE_TOPOLOGY_FRONTIER_OF] THEN + REWRITE_TAC[DIMENSION_LE_EQ_EMPTY; TOPSPACE_SUBTOPOLOGY; INTER_EMPTY] THEN + SET_TAC[]);; + +let ZERO_DIMENSIONAL_IMP_COMPLETELY_REGULAR_SPACE = prove + (`!top:A topology. top dimension_le &0 ==> completely_regular_space top`, + GEN_TAC THEN REWRITE_TAC[DIMENSION_LE_0_NEIGHBOURHOOD_BASE_OF_CLOPEN] THEN + SIMP_TAC[OPEN_NEIGHBOURHOOD_BASE_OF] THEN DISCH_TAC THEN + REWRITE_TAC[completely_regular_space; IN_DIFF] THEN + MAP_EVERY X_GEN_TAC [`c:A->bool`; `a:A`] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`topspace top DIFF c:A->bool`; `a:A`]) THEN + ASM_SIMP_TAC[IN_DIFF; OPEN_IN_DIFF; OPEN_IN_TOPSPACE] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(\x. if x IN u then &0 else &1):A->real` THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN + REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET; FORALL_IN_IMAGE] THEN + CONJ_TAC THENL [ALL_TAC; ASM_MESON_TAC[ENDS_IN_UNIT_REAL_INTERVAL]] THEN + REWRITE_TAC[continuous_map; TOPSPACE_EUCLIDEANREAL; IN_UNIV] THEN + X_GEN_TAC `r:real->bool` THEN DISCH_TAC THEN REWRITE_TAC[TAUT + `(if p then a else b) IN r <=> p /\ a IN r \/ ~p /\ b IN r`] THEN + MAP_EVERY ASM_CASES_TAC [`(&0:real) IN r`; `(&1:real) IN r`] THEN + ASM_REWRITE_TAC[EMPTY_GSPEC; OPEN_IN_EMPTY; OPEN_IN_TOPSPACE; + IN_GSPEC; TAUT `p \/ ~p`] THEN + ASM_REWRITE_TAC[GSYM DIFF; GSYM INTER] THEN + ASM_SIMP_TAC[OPEN_IN_TOPSPACE; OPEN_IN_INTER; OPEN_IN_DIFF]);; + +let ZERO_DIMENSIONAL_IMP_REGULAR_SPACE = prove + (`!top:A topology. top dimension_le &0 ==> regular_space top`, + MESON_TAC[COMPLETELY_REGULAR_IMP_REGULAR_SPACE; + ZERO_DIMENSIONAL_IMP_COMPLETELY_REGULAR_SPACE]);; + +(* ------------------------------------------------------------------------- *) +(* The Cantor space {0,1}^N and its embedding in the reals as the Cantor set *) +(* via the ternary Cantor map: a |-> sum_{k=0}^inf 2*a(k) / 3^{k+1} *) +(* ------------------------------------------------------------------------- *) + +let cantor_space = new_definition + `cantor_space = product_topology (:num) (\n:num. discrete_topology (:bool))`;; + +let cantor_term = new_definition + `cantor_term (a:num->bool) k = (if a k then &2 else &0) / &3 pow (k + 1)`;; + +let cantor_map = new_definition + `cantor_map (a:num->bool) = real_infsum (from 0) (cantor_term a)`;; + +let cantor_set = new_definition + `cantor_set = IMAGE cantor_map (:num->bool)`;; + +let TOPSPACE_CANTOR_SPACE = prove + (`topspace cantor_space = (:num->bool)`, + REWRITE_TAC[cantor_space; TOPSPACE_PRODUCT_TOPOLOGY; + TOPSPACE_DISCRETE_TOPOLOGY; o_DEF] THEN + REWRITE_TAC[cartesian_product; IN_UNIV; EXTENSIONAL_UNIV] THEN + SET_TAC[]);; + +let COMPACT_SPACE_CANTOR_SPACE = prove + (`compact_space cantor_space`, + SIMP_TAC[cantor_space; COMPACT_SPACE_PRODUCT_TOPOLOGY; + COMPACT_SPACE_DISCRETE_TOPOLOGY; FINITE_BOOL]);; + +let HAUSDORFF_SPACE_CANTOR_SPACE = prove + (`hausdorff_space cantor_space`, + SIMP_TAC[cantor_space; HAUSDORFF_SPACE_PRODUCT_TOPOLOGY; + HAUSDORFF_SPACE_DISCRETE_TOPOLOGY]);; + +let METRIZABLE_SPACE_CANTOR_SPACE = prove + (`metrizable_space cantor_space`, + SIMP_TAC[cantor_space; METRIZABLE_SPACE_PRODUCT_TOPOLOGY; + COUNTABLE_SUBSET_NUM; METRIZABLE_SPACE_DISCRETE_TOPOLOGY]);; + +let ZERO_DIMENSIONAL_CANTOR_SPACE = prove + (`cantor_space dimension_le &0`, + REWRITE_TAC[DIMENSION_LE_0_NEIGHBOURHOOD_BASE_OF_CLOPEN] THEN + SIMP_TAC[OPEN_NEIGHBOURHOOD_BASE_OF; + MESON[] `!(top:A topology) (s:A->bool). + closed_in top s /\ open_in top s ==> open_in top s`] THEN + REWRITE_TAC[cantor_space] THEN + MAP_EVERY X_GEN_TAC [`w:(num->bool)->bool`; `x:num->bool`] THEN STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [OPEN_IN_PRODUCT_TOPOLOGY_ALT]) THEN + DISCH_THEN(MP_TAC o SPEC `x:num->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u:num->(bool->bool)` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `cartesian_product (:num) (u:num->bool->bool)` THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [REWRITE_TAC[CLOSED_IN_CARTESIAN_PRODUCT] THEN DISJ2_TAC THEN GEN_TAC THEN + REWRITE_TAC[IN_UNIV; CLOSED_IN_DISCRETE_TOPOLOGY] THEN SET_TAC[]; + REWRITE_TAC[OPEN_IN_CARTESIAN_PRODUCT_GEN] THEN DISJ2_TAC THEN + ASM_REWRITE_TAC[TOPSPACE_DISCRETE_TOPOLOGY]]);; + +let NONEMPTY_TOPSPACE_CANTOR_SPACE = prove + (`~(topspace cantor_space = {})`, + REWRITE_TAC[TOPSPACE_CANTOR_SPACE; UNIV_NOT_EMPTY]);; + +(* The Cantor space has no isolated points (is "perfect") *) + +let PERFECT_CANTOR_SPACE = prove + (`!x:num->bool. x IN topspace cantor_space + ==> x IN cantor_space derived_set_of (topspace cantor_space)`, + REWRITE_TAC[TOPSPACE_CANTOR_SPACE; IN_UNIV] THEN X_GEN_TAC `x:num->bool` THEN + REWRITE_TAC[IN_DERIVED_SET_OF; TOPSPACE_CANTOR_SPACE; IN_UNIV] THEN + X_GEN_TAC `t:(num->bool)->bool` THEN STRIP_TAC THEN + RULE_ASSUM_TAC(REWRITE_RULE[cantor_space]) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `x:num->bool` o + GEN_REWRITE_RULE I [OPEN_IN_PRODUCT_TOPOLOGY_ALT]) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u:num->(bool->bool)` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(X_CHOOSE_TAC `N:num` o + GEN_REWRITE_RULE I [FINITE_SUBSET_NUMSEG]) THEN + SUBGOAL_THEN `(u:num->bool->bool) (SUC N) = (:bool)` ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o REWRITE_RULE[SUBSET; IN_ELIM_THM; IN_UNIV; + IN_NUMSEG; TOPSPACE_DISCRETE_TOPOLOGY]) THEN + MESON_TAC[ARITH_RULE `~(SUC N <= N)`]; ALL_TAC] THEN + EXISTS_TAC `\n:num. if n = SUC N then ~(x n) else (x:num->bool) n` THEN + CONJ_TAC THENL + [DISCH_THEN(MP_TAC o C AP_THM `SUC N`) THEN REWRITE_TAC[] THEN MESON_TAC[]; + FIRST_X_ASSUM(MATCH_MP_TAC o REWRITE_RULE[SUBSET]) THEN + UNDISCH_TAC `x IN cartesian_product (:num) (u:num->bool->bool)` THEN + REWRITE_TAC[cartesian_product; IN_ELIM_THM; IN_UNIV; EXTENSIONAL_UNIV] THEN + DISCH_TAC THEN GEN_TAC THEN COND_CASES_TAC THEN ASM_SIMP_TAC[IN_UNIV]]);; + +let PERFECT_CANTOR_SPACE_EQ = prove + (`cantor_space derived_set_of (topspace cantor_space) = + topspace cantor_space`, + MATCH_MP_TAC SUBSET_ANTISYM THEN + REWRITE_TAC[DERIVED_SET_OF_SUBSET_TOPSPACE; SUBSET; PERFECT_CANTOR_SPACE]);; + +(* Each term is non-negative *) + +let CANTOR_TERM_POS = prove + (`!a:num->bool k. &0 <= cantor_term a k`, + REWRITE_TAC[cantor_term] THEN REPEAT GEN_TAC THEN + MATCH_MP_TAC REAL_LE_DIV THEN CONJ_TAC THENL + [COND_CASES_TAC; MATCH_MP_TAC REAL_POW_LE] THEN REAL_ARITH_TAC);; + +(* Each term bounded by corresponding geometric term *) + +let CANTOR_TERM_BOUND = prove + (`!a:num->bool k. cantor_term a k <= &2 / &3 pow (k + 1)`, + REWRITE_TAC[cantor_term] THEN REPEAT GEN_TAC THEN + SIMP_TAC[REAL_LE_DIV2_EQ; REAL_POW_LT; REAL_ARITH `&0 < &3`] THEN + COND_CASES_TAC THEN REAL_ARITH_TAC);; + +(* Monotonicity of partial sums: more terms of non-negative series *) + +let CANTOR_PARTIAL_SUM_MONO = prove + (`!a:num->bool m n. m <= n + ==> sum(0..m) (cantor_term a) <= sum(0..n) (cantor_term a)`, + REPEAT STRIP_TAC THEN MATCH_MP_TAC SUM_SUBSET_SIMPLE THEN + REWRITE_TAC[FINITE_NUMSEG; IN_DIFF; CANTOR_TERM_POS; + SUBSET; IN_NUMSEG] THEN ASM_ARITH_TAC);; + +(* Partial sum formula for the geometric series sum_{k=0}^n 2/3^{k+1} *) + +let SUM_TWOTHIRDS = prove + (`!n. sum(0..n) (\k. &2 / &3 pow (k + 1)) = &1 - (&1 / &3) pow (n + 1)`, + INDUCT_TAC THENL + [REWRITE_TAC[SUM_SING_NUMSEG] THEN CONV_TAC NUM_REDUCE_CONV THEN + CONV_TAC REAL_RAT_REDUCE_CONV; + REWRITE_TAC[SUM_CLAUSES_NUMSEG; LE_0] THEN + ASM_REWRITE_TAC[ADD1; GSYM ADD_ASSOC] THEN CONV_TAC NUM_REDUCE_CONV THEN + REWRITE_TAC[ARITH_RULE `n + 2 = SUC(n + 1)`; + real_pow; REAL_POW_DIV; REAL_POW_ONE] THEN + SUBGOAL_THEN `~(&3 pow (n + 1) = &0)` MP_TAC THENL + [REWRITE_TAC[REAL_POW_EQ_0] THEN REAL_ARITH_TAC; CONV_TAC REAL_FIELD]]);; + +(* The geometric dominating series sums to 1 *) + +let TWOTHIRDS_SUMS = prove + (`((\k. &2 / &3 pow (k + 1)) real_sums &1) (from 0)`, + REWRITE_TAC[REAL_SERIES_FROM; SUM_TWOTHIRDS; REALLIM_SEQUENTIALLY] THEN + X_GEN_TAC `e:real` THEN DISCH_TAC THEN + MP_TAC(SPECL [`&1 / &3`; `e:real`] REAL_ARCH_POW_INV) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN CONV_TAC REAL_RAT_REDUCE_CONV; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_TAC `N:num`) THEN EXISTS_TAC `N:num` THEN + X_GEN_TAC `n:num` THEN DISCH_TAC THEN + MATCH_MP_TAC(REAL_ARITH `&0 < x /\ x < e ==> abs((&1 - x) - &1) < e`) THEN + CONJ_TAC THENL + [MATCH_MP_TAC REAL_POW_LT THEN CONV_TAC REAL_RAT_REDUCE_CONV; + MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `(&1 / &3) pow N` THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC REAL_POW_MONO_INV THEN + CONV_TAC REAL_RAT_REDUCE_CONV THEN ASM_ARITH_TAC]);; + +(* Cantor terms are summable by comparison with the geometric series *) + +let CANTOR_MAP_SUMMABLE = prove + (`!a:num->bool. real_summable (from 0) (cantor_term a)`, + GEN_TAC THEN MATCH_MP_TAC REAL_SUMMABLE_COMPARISON THEN + EXISTS_TAC `\k. &2 / &3 pow (k + 1)` THEN CONJ_TAC THENL + [MESON_TAC[TWOTHIRDS_SUMS; REAL_SUMS_SUMMABLE]; + EXISTS_TAC `0` THEN REPEAT STRIP_TAC THEN + MATCH_MP_TAC(REAL_ARITH `&0 <= x /\ x <= y ==> abs x <= y`) THEN + REWRITE_TAC[CANTOR_TERM_POS; CANTOR_TERM_BOUND]]);; + +(* The series converges to cantor_map *) + +let CANTOR_MAP_SUMS = prove + (`!a:num->bool. (cantor_term a real_sums cantor_map a) (from 0)`, + GEN_TAC THEN REWRITE_TAC[cantor_map; REAL_SUMS_INFSUM; CANTOR_MAP_SUMMABLE]);; + +(* Upper bound: each term <= 2/3^{k+1}, and the geometric series sums to 1 *) + +let CANTOR_MAP_LE_ONE = prove + (`!a:num->bool. cantor_map a <= &1`, + GEN_TAC THEN MATCH_MP_TAC REAL_SERIES_LE THEN + MAP_EVERY EXISTS_TAC + [`cantor_term (a:num->bool)`; `\k. &2 / &3 pow (k + 1)`; `from 0`] THEN + REWRITE_TAC[CANTOR_MAP_SUMS; TWOTHIRDS_SUMS; IN_FROM; CANTOR_TERM_BOUND]);; + +(* Partial sums bounded by the limit (monotone convergence) *) + +let CANTOR_MAP_GE_PARTIAL_SUM = prove + (`!a:num->bool n. sum(0..n) (cantor_term a) <= cantor_map a`, + REPEAT GEN_TAC THEN MATCH_MP_TAC(ISPEC `sequentially` REALLIM_LBOUND) THEN + EXISTS_TAC `\m. sum(0..m) (cantor_term (a:num->bool))` THEN CONJ_TAC THENL + [MP_TAC(SPEC `a:num->bool` CANTOR_MAP_SUMS) THEN + REWRITE_TAC[REAL_SERIES_FROM]; + REWRITE_TAC[TRIVIAL_LIMIT_SEQUENTIALLY; EVENTUALLY_SEQUENTIALLY] THEN + EXISTS_TAC `n:num` THEN REPEAT STRIP_TAC THEN + MATCH_MP_TAC CANTOR_PARTIAL_SUM_MONO THEN + ASM_REWRITE_TAC[]]);; + +(* Tail bound: cantor_map - partial_sum <= geometric tail *) + +let CANTOR_MAP_PARTIAL_SUM_BOUND = prove + (`!a:num->bool n. cantor_map a - sum(0..n) (cantor_term a) <= + (&1 / &3) pow (n + 1)`, + REPEAT GEN_TAC THEN MATCH_MP_TAC(REAL_ARITH `x <= y + z ==> x - y <= z`) THEN + MATCH_MP_TAC(ISPEC `sequentially` REALLIM_UBOUND) THEN + EXISTS_TAC `\m. sum(0..m) (cantor_term (a:num->bool))` THEN CONJ_TAC THENL + [MP_TAC(SPEC `a:num->bool` CANTOR_MAP_SUMS) THEN + REWRITE_TAC[REAL_SERIES_FROM]; ALL_TAC] THEN + REWRITE_TAC[TRIVIAL_LIMIT_SEQUENTIALLY; EVENTUALLY_SEQUENTIALLY] THEN + EXISTS_TAC `n:num` THEN X_GEN_TAC `m:num` THEN DISCH_TAC THEN + MP_TAC(ISPECL [`cantor_term (a:num->bool)`; `0`; `n:num`; `m:num`] + SUM_COMBINE_R) THEN + ANTS_TAC THENL [ASM_ARITH_TAC; DISCH_THEN(SUBST1_TAC o SYM)] THEN + MATCH_MP_TAC(REAL_ARITH `t <= b ==> p + t <= p + b`) THEN + MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `sum(n+1..m) (\k. &2 / &3 pow (k + 1))` THEN CONJ_TAC THENL + [MATCH_MP_TAC SUM_LE_NUMSEG THEN SIMP_TAC[CANTOR_TERM_BOUND]; + MP_TAC(ISPECL [`\k. &2 / &3 pow (k + 1)`; `0`; `n:num`; `m:num`] + SUM_COMBINE_R) THEN + ANTS_TAC THENL [ASM_ARITH_TAC; REWRITE_TAC[SUM_TWOTHIRDS]] THEN + MP_TAC(SPEC `m + 1` (MATCH_MP REAL_POW_LE + (REAL_ARITH `&0 <= &1 / &3`))) THEN REAL_ARITH_TAC]);; + +(* Non-negativity: follows from partial sums being non-negative *) + +let CANTOR_MAP_POS = prove + (`!a:num->bool. &0 <= cantor_map a`, + GEN_TAC THEN + MP_TAC(SPECL [`a:num->bool`; `0`] CANTOR_MAP_GE_PARTIAL_SUM) THEN + MP_TAC(SPECL [`a:num->bool`; `0`] CANTOR_TERM_POS) THEN + REWRITE_TAC[SUM_SING_NUMSEG] THEN REAL_ARITH_TAC);; + +let CANTOR_MAP_RANGE = prove + (`!a:num->bool. cantor_map a IN real_interval[&0,&1]`, + REWRITE_TAC[IN_REAL_INTERVAL; CANTOR_MAP_POS; CANTOR_MAP_LE_ONE]);; + +(* Term continuity: each cantor_term a k is continuous in a *) + +let CANTOR_TERM_CONTINUOUS = prove + (`!k. continuous_map (cantor_space, euclideanreal) + (\a:num->bool. cantor_term a k)`, + GEN_TAC THEN REWRITE_TAC[cantor_term] THEN SUBGOAL_THEN + `(\a:num->bool. (if a k then &2 else &0) / &3 pow (k + 1)) = + (\b:bool. (if b then &2 else &0) / &3 pow (k + 1)) o (\a:num->bool. a k)` + SUBST1_TAC THENL [REWRITE_TAC[FUN_EQ_THM; o_THM]; ALL_TAC] THEN + MATCH_MP_TAC CONTINUOUS_MAP_COMPOSE THEN + EXISTS_TAC `discrete_topology (:bool)` THEN CONJ_TAC THENL + [REWRITE_TAC[cantor_space] THEN + MATCH_MP_TAC CONTINUOUS_MAP_PRODUCT_PROJECTION THEN REWRITE_TAC[IN_UNIV]; + REWRITE_TAC[CONTINUOUS_MAP_FROM_DISCRETE_TOPOLOGY; + TOPSPACE_EUCLIDEANREAL; SUBSET_UNIV]]);; + +(* Cantor map continuity: uniform limit of continuous partial sums *) +let CANTOR_MAP_CONTINUOUS = prove + (`continuous_map (cantor_space, euclideanreal) cantor_map`, + MATCH_MP_TAC(REWRITE_RULE[MTOPOLOGY_REAL_EUCLIDEAN_METRIC] + (ISPECL [`sequentially`; `cantor_space`; `real_euclidean_metric`; + `\n (a:num->bool). sum(0..n) (cantor_term a)`; `cantor_map`] + CONTINUOUS_MAP_UNIFORM_LIMIT_ALT)) THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + REWRITE_TAC[TRIVIAL_LIMIT_SEQUENTIALLY; TOPSPACE_CANTOR_SPACE; SUBSET_UNIV; + REAL_EUCLIDEAN_METRIC; MTOPOLOGY_REAL_EUCLIDEAN_METRIC; + EVENTUALLY_SEQUENTIALLY; IN_UNIV] THEN + CONJ_TAC THENL + [EXISTS_TAC `0` THEN REPEAT STRIP_TAC THEN REWRITE_TAC[cantor_term] THEN + MATCH_MP_TAC CONTINUOUS_MAP_SUM THEN + REWRITE_TAC[FINITE_NUMSEG; IN_NUMSEG] THEN + REPEAT STRIP_TAC THEN REWRITE_TAC[GSYM cantor_term; CANTOR_TERM_CONTINUOUS]; + X_GEN_TAC `e:real` THEN DISCH_TAC THEN + MP_TAC(SPECL [`&1 / &3`; `e:real`] REAL_ARCH_POW_INV) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN CONV_TAC REAL_RAT_REDUCE_CONV; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_TAC `N:num`) THEN EXISTS_TAC `N:num` THEN + X_GEN_TAC `n:num` THEN DISCH_TAC THEN X_GEN_TAC `x:num->bool` THEN + MP_TAC(SPECL [`x:num->bool`; `n:num`] CANTOR_MAP_GE_PARTIAL_SUM) THEN + MP_TAC(SPECL [`x:num->bool`; `n:num`] CANTOR_MAP_PARTIAL_SUM_BOUND) THEN + SUBGOAL_THEN `(&1 / &3) pow (n + 1) <= (&1 / &3) pow N` MP_TAC THENL + [MATCH_MP_TAC REAL_POW_MONO_INV THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN + ASM_ARITH_TAC; + ASM_REAL_ARITH_TAC]]);; + +(* At the first disagreement k where a k /\ ~b k, the partial sums differ *) + +let CANTOR_PARTIAL_SUM_DIFF_AT_K = prove + (`!a b:num->bool k. + (!j. j < k ==> a j = b j) /\ a k /\ ~(b k) + ==> sum(0..k) (cantor_term a) = + sum(0..k) (cantor_term b) + &2 / &3 pow (k + 1)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + MATCH_MP_TAC(REAL_ARITH `s - t = d ==> s = t + d`) THEN + REWRITE_TAC[GSYM SUM_SUB_NUMSEG] THEN + SUBGOAL_THEN + `sum(0..k) (\j:num. cantor_term (a:num->bool) j - cantor_term b j) = + sum(0..k) (\j. if j = k then &2 / &3 pow (k + 1) else &0)` + SUBST1_TAC THENL + [MATCH_MP_TAC SUM_EQ_NUMSEG THEN X_GEN_TAC `j:num` THEN + STRIP_TAC THEN REWRITE_TAC[cantor_term] THEN ASM_CASES_TAC `j:num = k` THEN + ASM_REWRITE_TAC[] THENL [REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(a:num->bool) j = b j` + (fun th -> REWRITE_TAC[th] THEN REAL_ARITH_TAC) THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; + REWRITE_TAC[SUM_DELTA; IN_NUMSEG; LE_0; LE_REFL]]);; + +(* If a and b first disagree at k with a(k) true, then cantor_map b < cantor_map a *) + +let CANTOR_MAP_STRICT_LT = prove + (`!a b:num->bool k. + (!j. j < k ==> a j = b j) /\ a k /\ ~(b k) + ==> cantor_map b < cantor_map a`, + REPEAT GEN_TAC THEN STRIP_TAC THEN MP_TAC(SPECL + [`a:num->bool`; `b:num->bool`; `k:num`] CANTOR_PARTIAL_SUM_DIFF_AT_K) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + MP_TAC(SPECL [`b:num->bool`; `k:num`] CANTOR_MAP_PARTIAL_SUM_BOUND) THEN + MP_TAC(SPECL [`a:num->bool`; `k:num`] CANTOR_MAP_GE_PARTIAL_SUM) THEN + SUBGOAL_THEN `(&1 / &3) pow (k + 1) < &2 / &3 pow (k + 1)` MP_TAC THENL + [SIMP_TAC[REAL_POW_DIV; REAL_POW_ONE; REAL_LT_DIV2_EQ; REAL_POW_LT; + REAL_ARITH `&0 < &3`] THEN REAL_ARITH_TAC; + ASM_REAL_ARITH_TAC]);; + +(* Injectivity of cantor_map *) + +let CANTOR_MAP_INJECTIVE = prove + (`!a b:num->bool. cantor_map a = cantor_map b <=> a = b`, + REPEAT GEN_TAC THEN EQ_TAC THENL + [ALL_TAC; MESON_TAC[]] THEN + ONCE_REWRITE_TAC[GSYM CONTRAPOS_THM] THEN + REWRITE_TAC[FUN_EQ_THM; NOT_FORALL_THM] THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [num_WOP]) THEN + REWRITE_TAC[NOT_CLAUSES] THEN + DISCH_THEN(X_CHOOSE_THEN `k:num` STRIP_ASSUME_TAC) THEN + MATCH_MP_TAC(REAL_ARITH `a < b \/ b < a ==> ~(a = b)`) THEN + ASM_MESON_TAC[CANTOR_MAP_STRICT_LT]);; + +let CANTOR_MAP_EMBEDDING = prove + (`embedding_map (cantor_space,euclideanreal) cantor_map`, + MATCH_MP_TAC CONTINUOUS_IMP_EMBEDDING_MAP THEN + REWRITE_TAC[COMPACT_SPACE_CANTOR_SPACE; HAUSDORFF_SPACE_EUCLIDEANREAL; + CANTOR_MAP_CONTINUOUS; TOPSPACE_CANTOR_SPACE; IN_UNIV] THEN + MESON_TAC[CANTOR_MAP_INJECTIVE]);; + +let CANTOR_MAP_CLOSED_IMAGE = prove + (`closed_in euclideanreal (IMAGE cantor_map (:num->bool))`, + MESON_TAC[COMPACT_IN_IMP_CLOSED_IN; IMAGE_COMPACT_IN; + HAUSDORFF_SPACE_EUCLIDEANREAL; CANTOR_MAP_CONTINUOUS; + COMPACT_SPACE_CANTOR_SPACE; compact_space; TOPSPACE_CANTOR_SPACE]);; + +let CANTOR_MAP_IMAGE_SUBSET_INTERVAL = prove + (`IMAGE cantor_map (:num->bool) SUBSET real_interval [&0,&1]`, + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_UNIV; CANTOR_MAP_RANGE]);; + +let CANTOR_MAP_CLOSED_IN_INTERVAL = prove + (`closed_in (subtopology euclideanreal (real_interval [&0,&1])) + (IMAGE cantor_map (:num->bool))`, + MATCH_MP_TAC CLOSED_IN_SUBSET_TOPSPACE THEN + REWRITE_TAC[CANTOR_MAP_CLOSED_IMAGE; CANTOR_MAP_IMAGE_SUBSET_INTERVAL]);; + +let CANTOR_SET_SUBSET_INTERVAL = prove + (`cantor_set SUBSET real_interval [&0,&1]`, + REWRITE_TAC[cantor_set; CANTOR_MAP_IMAGE_SUBSET_INTERVAL]);; + +let CLOSED_IN_CANTOR_SET = prove + (`closed_in euclideanreal cantor_set`, + REWRITE_TAC[cantor_set; CANTOR_MAP_CLOSED_IMAGE]);; + +let CLOSED_IN_CANTOR_SET_INTERVAL = prove + (`closed_in (subtopology euclideanreal (real_interval [&0,&1])) cantor_set`, + REWRITE_TAC[cantor_set; CANTOR_MAP_CLOSED_IN_INTERVAL]);; + +let CANTOR_SPACE_HOMEOMORPHIC_CANTOR_SET = prove + (`cantor_space homeomorphic_space + subtopology euclideanreal cantor_set`, + MATCH_MP_TAC HOMEOMORPHIC_MAP_IMP_HOMEOMORPHIC_SPACE THEN + EXISTS_TAC `cantor_map` THEN MP_TAC CANTOR_MAP_EMBEDDING THEN + REWRITE_TAC[embedding_map; TOPSPACE_CANTOR_SPACE; cantor_set]);; + +(* ------------------------------------------------------------------------- *) +(* Alexandroff-Hausdorff Theorem: H-Y Theorem 3-28. *) +(* Every nonempty compact metrizable space is a continuous image of *) +(* the Cantor space. *) +(* ------------------------------------------------------------------------- *) + +(* Key refinement lemma: refine a locally constant assignment *) +let LOCALLY_CONSTANT_REFINEMENT = prove + (`!m:A metric (h:(num->bool)->(A->bool)) e. + compact_space (mtopology m) /\ + &0 < e /\ + (!x. closed_in (mtopology m) (h x)) /\ + (!x. ~(h x = {})) /\ + (!x. h x SUBSET mspace m) /\ + (!x:num->bool. ?u. open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> h y = h x)) /\ + (!a. a IN mspace m ==> ?x. a IN h x) + ==> ?h':(num->bool)->(A->bool). + (!x. closed_in (mtopology m) (h' x)) /\ + (!x. ~(h' x = {})) /\ + (!x. h' x SUBSET mspace m) /\ + (!x. mdiameter m (h' x) < e) /\ + (!x. h' x SUBSET h x) /\ + (!x. ?u. open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> h' y = h' x)) /\ + (!a. a IN mspace m ==> ?x. a IN h' x)`, + let COMPACT_SPACE_FINITE_CLOSED_COVER = prove + (`!m:A metric e. + compact_space (mtopology m) /\ ~(mspace m = {}) /\ &0 < e + ==> ?c. FINITE c /\ ~(c = {}) /\ + (!s. s IN c ==> closed_in (mtopology m) s) /\ + (!s. s IN c ==> ~(s = {})) /\ + (!s. s IN c ==> mdiameter m s < e) /\ + UNIONS c = mspace m`, + REPEAT STRIP_TAC THEN + SUBGOAL_THEN `totally_bounded_in m (mspace m:A->bool)` MP_TAC THENL + [ASM_MESON_TAC[COMPACT_SPACE_EQ_MCOMPLETE_TOTALLY_BOUNDED_IN]; ALL_TAC] THEN + REWRITE_TAC[totally_bounded_in] THEN DISCH_THEN(MP_TAC o SPEC `e / &3`) THEN + ASM_SIMP_TAC[REAL_LT_DIV; REAL_OF_NUM_LT; ARITH] THEN + DISCH_THEN(X_CHOOSE_THEN `k:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `IMAGE (\x:A. mcball m (x, e / &3)) k` THEN + CONJ_TAC THENL [ASM_SIMP_TAC[FINITE_IMAGE]; ALL_TAC] THEN + CONJ_TAC THENL [REWRITE_TAC[IMAGE_EQ_EMPTY] THEN + SUBGOAL_THEN `~(k:A->bool = {})` (fun th -> REWRITE_TAC[th]) THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + DISCH_THEN(X_CHOOSE_TAC `a:A`) THEN + SUBGOAL_THEN `(a:A) IN UNIONS {mball m (x,e / &3) | x IN k}` + MP_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[FORALL_IN_IMAGE] THEN + CONJ_TAC THENL + [GEN_TAC THEN DISCH_TAC THEN REWRITE_TAC[CLOSED_IN_MCBALL]; ALL_TAC] THEN - EXPAND_TAC "f" THEN REWRITE_TAC[INTERS_GSPEC; IN_ELIM_THM] THEN - REWRITE_TAC[NOT_EXISTS_THM; IN_CROSS; IN_ELIM_THM] THEN - X_GEN_TAC `y:A` THEN - DISCH_THEN(CONJUNCTS_THEN2 (MP_TAC o SPEC `i:K`) ASSUME_TAC) THEN - ASM_REWRITE_TAC[] THEN DISCH_TAC THEN - FIRST_X_ASSUM(CONJUNCTS_THEN MP_TAC) THEN - DISCH_THEN(MP_TAC o CONJUNCT2) THEN ASM_REWRITE_TAC[RESTRICTION] THEN - DISCH_TAC THEN ASM_REWRITE_TAC[IN_MBALL] THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN - REWRITE_TAC[REAL_NOT_LT] THEN - TRANS_TAC REAL_LE_TRANS `(d:K->A->real) i y` THEN CONJ_TAC THENL - [MATCH_MP_TAC REAL_LE_LINV THEN ASM_SIMP_TAC[] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_REAL_INTERVAL]) THEN - REAL_ARITH_TAC; - EXPAND_TAC "d" THEN REWRITE_TAC[] THEN - COND_CASES_TAC THENL [ASM SET_TAC[]; REWRITE_TAC[]] THEN - MATCH_MP_TAC INF_LE_ELEMENT THEN CONJ_TAC THENL - [EXISTS_TAC `&0` THEN - ASM_SIMP_TAC[FORALL_IN_GSPEC; IN_DIFF; MDIST_POS_LE]; - REWRITE_TAC[IN_ELIM_THM] THEN EXISTS_TAC `x:A` THEN - ASM_REWRITE_TAC[IN_DIFF] THEN ASM_MESON_TAC[MDIST_SYM]]]; - REWRITE_TAC[IN_IMAGE] THEN EXISTS_TAC `x:A` THEN - ASM_REWRITE_TAC[] THEN EXPAND_TAC "f" THEN REWRITE_TAC[PAIR_EQ] THEN - GEN_REWRITE_TAC I [FUN_EQ_THM] THEN X_GEN_TAC `i:K` THEN - REWRITE_TAC[RESTRICTION] THEN - COND_CASES_TAC THENL - [ALL_TAC; - RULE_ASSUM_TAC(REWRITE_RULE[EXTENSIONAL]) THEN ASM SET_TAC[]] THEN - REWRITE_TAC[REAL_ARITH `x = y <=> ~(&0 < abs(x - y))`] THEN DISCH_TAC THEN - FIRST_ASSUM(MP_TAC o - MATCH_MP (REWRITE_RULE[IMP_CONJ] CONTINUOUS_MAP_REAL_INV) o - SPEC `i:K`) THEN - ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY; REAL_LT_IMP_NZ; IN_INTER] THEN - ABBREV_TAC `e = abs (ds i - inv((d:K->A->real) i x))` THEN - REWRITE_TAC[continuous_map] THEN DISCH_THEN(MP_TAC o SPEC - `real_interval(inv((d:K->A->real) i x) - e / &2,inv(d i x) + e / &2)` o - CONJUNCT2) THEN - REWRITE_TAC[GSYM REAL_OPEN_IN; REAL_OPEN_REAL_INTERVAL] THEN - ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY_SUBSET; TOPSPACE_MTOPOLOGY] THEN - REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN - DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + CONJ_TAC THENL [X_GEN_TAC `x:A` THEN DISCH_TAC THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN EXISTS_TAC `x:A` THEN + REWRITE_TAC[IN_MCBALL] THEN + SUBGOAL_THEN `(x:A) IN mspace m` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + ASM_SIMP_TAC[MDIST_REFL] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + CONJ_TAC THENL [X_GEN_TAC `x:A` THEN DISCH_TAC THEN + MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `&2 * e / &3` THEN + CONJ_TAC THENL [MATCH_MP_TAC MDIAMETER_LE THEN + CONJ_TAC THENL [REWRITE_TAC[MCBALL_SUBSET_MSPACE]; ALL_TAC] THEN + CONJ_TAC THENL [DISJ2_TAC THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[IN_MCBALL] THEN + MAP_EVERY X_GEN_TAC [`y:A`; `z:A`] THEN STRIP_TAC THEN + MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `mdist m (y:A,x) + mdist m (x,z)` THEN + CONJ_TAC THENL [ASM_MESON_TAC[MDIST_TRIANGLE]; ALL_TAC] THEN + SUBGOAL_THEN `mdist m (y:A,x) <= e / &3` ASSUME_TAC THENL + [ASM_MESON_TAC[MDIST_SYM]; ASM_REAL_ARITH_TAC]; ASM_REAL_ARITH_TAC]; + ALL_TAC] THEN + REWRITE_TAC[GSYM SUBSET_ANTISYM_EQ] THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_IMAGE] THEN + GEN_TAC THEN DISCH_TAC THEN REWRITE_TAC[MCBALL_SUBSET_MSPACE]; + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `y:A` THEN DISCH_TAC THEN + REWRITE_TAC[UNIONS_IMAGE; IN_ELIM_THM] THEN + SUBGOAL_THEN `(y:A) IN UNIONS {mball m (x,e / &3) | x IN k}` MP_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `b:A->bool` + (CONJUNCTS_THEN2 + (X_CHOOSE_THEN `z:A` STRIP_ASSUME_TAC) + ASSUME_TAC)) THEN EXISTS_TAC `z:A` THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `(y:A) IN b` THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[IN_MBALL; IN_MCBALL] THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC]) in + let COMPACT_SUBSET_FINITE_CLOSED_COVER = prove + (`!m:A metric s e. + compact_space (mtopology m) /\ closed_in (mtopology m) s /\ + ~(s = {}) /\ &0 < e + ==> ?c. FINITE c /\ ~(c = {}) /\ + (!t. t IN c ==> closed_in (mtopology m) t) /\ + (!t. t IN c ==> ~(t = {})) /\ + (!t. t IN c ==> t SUBSET s) /\ + (!t. t IN c ==> mdiameter m t < e) /\ + UNIONS c = s`, + REPEAT STRIP_TAC THEN + SUBGOAL_THEN `(s:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + SUBGOAL_THEN `~(mspace m:A->bool = {})` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + MP_TAC(SPECL [`m:A metric`; `e:real`] COMPACT_SPACE_FINITE_CLOSED_COVER) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `bigc:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC + `IMAGE (\u:A->bool. u INTER s) bigc DELETE ({}:A->bool)` THEN + CONJ_TAC THENL [ASM_SIMP_TAC[FINITE_DELETE; FINITE_IMAGE]; ALL_TAC] THEN + CONJ_TAC THENL [REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + UNDISCH_TAC `~(s:A->bool = {})` THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN DISCH_THEN(X_CHOOSE_TAC `y:A`) THEN + SUBGOAL_THEN `(y:A) IN UNIONS bigc` MP_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(u:A->bool) INTER s` THEN REWRITE_TAC[IN_DELETE; IN_IMAGE] THEN + CONJ_TAC THENL + [EXISTS_TAC `u:A->bool` THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM SET_TAC[]; ALL_TAC] THEN + (* closed_in *) + CONJ_TAC THENL + [REWRITE_TAC[IN_DELETE; IN_IMAGE] THEN + X_GEN_TAC `t:A->bool` THEN DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) + ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CLOSED_IN_INTER THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + (* ~(t = {}) *) + CONJ_TAC THENL [REWRITE_TAC[IN_DELETE] THEN MESON_TAC[]; ALL_TAC] THEN + (* t SUBSET s *) + CONJ_TAC THENL + [REWRITE_TAC[IN_DELETE; IN_IMAGE] THEN + X_GEN_TAC `t:A->bool` THEN DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) + ASSUME_TAC) THEN + ASM SET_TAC[]; + ALL_TAC] THEN + (* mdiameter < e *) + CONJ_TAC THENL + [REWRITE_TAC[IN_DELETE; IN_IMAGE] THEN + X_GEN_TAC `t:A->bool` THEN DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) + ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LET_TRANS THEN + EXISTS_TAC `mdiameter m (u:A->bool)` THEN CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_SUBSET THEN CONJ_TAC THENL [SET_TAC[]; + ASM_MESON_TAC[CLOSED_IN_COMPACT_SPACE; COMPACT_IN_IMP_MBOUNDED]]; + ASM_MESON_TAC[]]; ALL_TAC] THEN + (* UNIONS c = s *) + REWRITE_TAC[GSYM SUBSET_ANTISYM_EQ] THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET] THEN + REWRITE_TAC[IN_DELETE; IN_IMAGE] THEN + X_GEN_TAC `t:A->bool` THEN DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) + ASSUME_TAC) THEN + ASM SET_TAC[]; + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `y:A` THEN DISCH_TAC THEN + REWRITE_TAC[IN_UNIONS] THEN + SUBGOAL_THEN `(y:A) IN UNIONS bigc` MP_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(u:A->bool) INTER s` THEN + CONJ_TAC THENL [REWRITE_TAC[IN_DELETE; IN_IMAGE] THEN + CONJ_TAC THENL [EXISTS_TAC `u:A->bool` THEN + ASM_REWRITE_TAC[]; ASM SET_TAC[]]; + ASM SET_TAC[]]]) in + let fiber_openness_tac = + FIRST_X_ASSUM(MP_TAC o SPEC `z:num->bool`) THEN + DISCH_THEN(X_CHOOSE_THEN `u:(num->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `u:(num->bool)->bool` THEN + REPLICATE_TAC 2 (CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; ALL_TAC]) THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `w:num->bool` THEN DISCH_TAC THEN ASM_MESON_TAC[] in + let LOCALLY_CONSTANT_CANTOR_SPACE_FIBER_OPEN = prove + (`!h:(num->bool)->(A->bool) s. + (!x:num->bool. ?u. open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> h y = h x)) + ==> open_in cantor_space {x:num->bool | h x = s}`, + REPEAT STRIP_TAC THEN ONCE_REWRITE_TAC[OPEN_IN_SUBOPEN] THEN + X_GEN_TAC `z:num->bool` THEN + REWRITE_TAC[IN_ELIM_THM; TOPSPACE_CANTOR_SPACE; IN_UNIV] THEN + DISCH_TAC THEN fiber_openness_tac) in + let LOCALLY_CONSTANT_CANTOR_SPACE_FIBER_CLOSED = prove + (`!h:(num->bool)->(A->bool) s. + (!x:num->bool. ?u. open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> h y = h x)) + ==> closed_in cantor_space {x:num->bool | h x = s}`, + REPEAT STRIP_TAC THEN REWRITE_TAC[closed_in; TOPSPACE_CANTOR_SPACE] THEN + CONJ_TAC THENL [SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(:num->bool) DIFF {x | (h:(num->bool)->(A->bool)) x = s} = + {x:num->bool | ~(h x = s)}` SUBST1_TAC THENL [SET_TAC[]; ALL_TAC] THEN + ONCE_REWRITE_TAC[OPEN_IN_SUBOPEN] THEN X_GEN_TAC `z:num->bool` THEN + REWRITE_TAC[IN_ELIM_THM] THEN DISCH_TAC THEN fiber_openness_tac) in + let LOCALLY_CONSTANT_CANTOR_SPACE_FINITE_IMAGE = prove + (`!h:(num->bool)->(A->bool). + (!x:num->bool. ?u. open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> h y = h x)) + ==> FINITE(IMAGE h (:num->bool))`, GEN_TAC THEN DISCH_TAC THEN + POP_ASSUM(X_CHOOSE_THEN `uf:(num->bool)->(num->bool)->bool` + ASSUME_TAC o REWRITE_RULE[SKOLEM_THM]) THEN + (* Get finite subcover from compactness of cantor_space *) + SUBGOAL_THEN `?bigv:((num->bool)->bool)->bool. + FINITE bigv /\ + bigv SUBSET IMAGE (uf:(num->bool)->(num->bool)->bool) (:num->bool) /\ + (:num->bool) SUBSET UNIONS bigv` + STRIP_ASSUME_TAC THENL [MP_TAC COMPACT_SPACE_CANTOR_SPACE THEN + REWRITE_TAC[COMPACT_SPACE_ALT; TOPSPACE_CANTOR_SPACE] THEN + DISCH_THEN(MP_TAC o SPEC + `IMAGE (uf:(num->bool)->(num->bool)->bool) (:num->bool)`) THEN + ANTS_TAC THENL [CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_IMAGE; IN_UNIV] THEN GEN_TAC THEN + ASM_MESON_TAC[]; + REWRITE_TAC[SUBSET; IN_UNIV; IN_UNIONS] THEN + X_GEN_TAC `z:num->bool` THEN + EXISTS_TAC `(uf:(num->bool)->(num->bool)->bool) z` THEN + CONJ_TAC THENL [REWRITE_TAC[IN_IMAGE; IN_UNIV] THEN + EXISTS_TAC `z:num->bool` THEN + REFL_TAC; ASM_MESON_TAC[]]]; MESON_TAC[]]; ALL_TAC] THEN + (* Pick centers: sel v satisfies uf(sel v) = v for v IN bigv *) + SUBGOAL_THEN `?sel:((num->bool)->bool)->(num->bool). + !v:(num->bool)->bool. v IN bigv + ==> (uf:(num->bool)->(num->bool)->bool) (sel v) = v` + STRIP_ASSUME_TAC THENL + [REWRITE_TAC[GSYM SKOLEM_THM] THEN UNDISCH_TAC + `bigv SUBSET IMAGE + (uf:(num->bool)->(num->bool)->bool) + (:num->bool)` THEN + REWRITE_TAC[SUBSET; IN_IMAGE; IN_UNIV] THEN MESON_TAC[]; ALL_TAC] THEN + (* IMAGE h UNIV SUBSET IMAGE h (IMAGE sel bigv) *) + MATCH_MP_TAC FINITE_SUBSET THEN EXISTS_TAC + `IMAGE (h:(num->bool)->(A->bool)) + (IMAGE (sel:((num->bool)->bool)->(num->bool)) + bigv)` THEN CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN MATCH_MP_TAC FINITE_IMAGE THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_UNIV] THEN + X_GEN_TAC `y:num->bool` THEN + (* Find v IN bigv containing y *) + SUBGOAL_THEN `?v:(num->bool)->bool. v IN bigv /\ (y:num->bool) IN v` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `(:num->bool) SUBSET UNIONS bigv` THEN + REWRITE_TAC[SUBSET; IN_UNIV; IN_UNIONS] THEN MESON_TAC[]; ALL_TAC] THEN + (* h y = h(sel v) because both are in v = uf(sel v) where h is constant *) + SUBGOAL_THEN `(h:(num->bool)->(A->bool)) y = + h ((sel:((num->bool)->bool)->(num->bool)) + v)` SUBST1_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + (* h(sel v) IN IMAGE h (IMAGE sel bigv) *) + REWRITE_TAC[IN_IMAGE] THEN + EXISTS_TAC `(sel:((num->bool)->bool)->(num->bool)) v` THEN + CONJ_TAC THENL [REFL_TAC; + EXISTS_TAC `v:(num->bool)->bool` THEN ASM_REWRITE_TAC[]]) in + let CANTOR_SPACE_OPEN_HAS_TWO_POINTS = prove + (`!s:(num->bool)->bool. + open_in cantor_space s /\ ~(s = {}) + ==> ?x y. x IN s /\ y IN s /\ ~(x = y)`, + REPEAT STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + DISCH_THEN(X_CHOOSE_TAC `x:num->bool`) THEN + SUBGOAL_THEN `(x:num->bool) IN topspace cantor_space` ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; ALL_TAC] THEN + MP_TAC(SPEC `x:num->bool` PERFECT_CANTOR_SPACE) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[IN_DERIVED_SET_OF] THEN DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPEC `s:(num->bool)->bool`)) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[TOPSPACE_CANTOR_SPACE; IN_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `y:num->bool` STRIP_ASSUME_TAC) THEN + MAP_EVERY EXISTS_TAC [`x:num->bool`; `y:num->bool`] THEN + ASM_REWRITE_TAC[]) in + let CANTOR_SPACE_PROPER_CLOPEN_SUBSET = prove + (`!s:(num->bool)->bool. + open_in cantor_space s /\ closed_in cantor_space s /\ ~(s = {}) + ==> ?t. open_in cantor_space t /\ closed_in cantor_space t /\ + ~(t = {}) /\ t SUBSET s /\ + ~(s DIFF t = {})`, REPEAT STRIP_TAC THEN + MP_TAC(SPEC `s:(num->bool)->bool` CANTOR_SPACE_OPEN_HAS_TWO_POINTS) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `x:num->bool` + (X_CHOOSE_THEN `y:num->bool` STRIP_ASSUME_TAC)) THEN + SUBGOAL_THEN `open_in cantor_space (s DIFF {y:num->bool})` ASSUME_TAC THENL + [MATCH_MP_TAC OPEN_IN_DIFF THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CLOSED_IN_HAUSDORFF_SING THEN + REWRITE_TAC[HAUSDORFF_SPACE_CANTOR_SPACE] THEN + ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; ALL_TAC] THEN + SUBGOAL_THEN `(x:num->bool) IN s DIFF {y}` ASSUME_TAC THENL + [ASM_REWRITE_TAC[IN_DIFF; IN_SING]; ALL_TAC] THEN + MP_TAC ZERO_DIMENSIONAL_CANTOR_SPACE THEN + REWRITE_TAC[DIMENSION_LE_0_NEIGHBOURHOOD_BASE_OF_CLOPEN] THEN + SUBGOAL_THEN `!u:(num->bool)->bool. + closed_in cantor_space u /\ open_in cantor_space u + ==> open_in cantor_space u` + (fun th -> SIMP_TAC[OPEN_NEIGHBOURHOOD_BASE_OF; th]) THENL [MESON_TAC[]; + ALL_TAC] THEN + DISCH_THEN(MP_TAC o SPECL + [`s DIFF {y:num->bool}`; `x:num->bool`]) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `t:(num->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `t:(num->bool)->bool` THEN + ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THEN ASM SET_TAC[]) in + let CANTOR_SPACE_CLOPEN_PARTITION = prove + (`!k s:(num->bool)->bool. + open_in cantor_space s /\ closed_in cantor_space s /\ + ~(s = {}) /\ 1 <= k + ==> ?p. p HAS_SIZE k /\ + (!t. t IN p ==> open_in cantor_space t) /\ + (!t. t IN p ==> closed_in cantor_space t) /\ + (!t. t IN p ==> ~(t = {})) /\ + UNIONS p = s /\ pairwise DISJOINT p`, + INDUCT_TAC THENL [ARITH_TAC; + X_GEN_TAC `s:(num->bool)->bool` THEN STRIP_TAC THEN + ASM_CASES_TAC `k = 0` THENL + [(* SUC 0 = 1: partition is {s} *) + EXISTS_TAC `{s:(num->bool)->bool}` THEN + ASM_REWRITE_TAC[IN_SING; UNIONS_1; PAIRWISE_SING] THEN CONJ_TAC THENL + [REWRITE_TAC[HAS_SIZE; FINITE_INSERT; FINITE_EMPTY] THEN + SIMP_TAC[CARD_CLAUSES; FINITE_EMPTY; NOT_IN_EMPTY] THEN + ASM_ARITH_TAC; ASM_MESON_TAC[]]; + (* SUC k for k >= 1: split and use IH *) + MP_TAC(SPEC `s:(num->bool)->bool` + CANTOR_SPACE_PROPER_CLOPEN_SUBSET) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `t:(num->bool)->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN + `open_in cantor_space (s DIFF t:(num->bool)->bool)` + ASSUME_TAC THENL [MATCH_MP_TAC OPEN_IN_DIFF THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `closed_in cantor_space (s DIFF t:(num->bool)->bool)` + ASSUME_TAC THENL [MATCH_MP_TAC CLOSED_IN_DIFF THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `s DIFF t:(num->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN + ANTS_TAC THENL [UNDISCH_TAC `~(k = 0)` THEN ARITH_TAC; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `p:((num->bool)->bool)->bool` + STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `~((t:(num->bool)->bool) IN p)` ASSUME_TAC THENL + [DISCH_TAC THEN SUBGOAL_THEN `(t:(num->bool)->bool) SUBSET s DIFF t` + MP_TAC THENL [ASM SET_TAC[]; ASM SET_TAC[]]; ALL_TAC] THEN + EXISTS_TAC `(t:(num->bool)->bool) INSERT p` THEN CONJ_TAC THENL + [UNDISCH_TAC `(p:((num->bool)->bool)->bool) HAS_SIZE k` THEN + REWRITE_TAC[HAS_SIZE; FINITE_INSERT] THEN STRIP_TAC THEN + UNDISCH_TAC `~((t:(num->bool)->bool) IN p)` THEN + ASM_SIMP_TAC[CARD_CLAUSES] THEN ARITH_TAC; ALL_TAC] THEN + REPLICATE_TAC 3 + (CONJ_TAC THENL [REWRITE_TAC[IN_INSERT] THEN + ASM_MESON_TAC[]; ALL_TAC]) THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_INSERT] THEN + ASM SET_TAC[]; REWRITE_TAC[PAIRWISE_INSERT] THEN + CONJ_TAC THENL [X_GEN_TAC `u:(num->bool)->bool` THEN STRIP_TAC THEN + SUBGOAL_THEN `(u:(num->bool)->bool) SUBSET s DIFF t` + ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + CONJ_TAC THEN REWRITE_TAC[DISJOINT] THEN + ASM SET_TAC[]; ASM_REWRITE_TAC[]]]]]) in + REPEAT STRIP_TAC THEN + (* Label key hypotheses for later use *) + SUBGOAL_THEN `!x:num->bool. ?u:(num->bool)->bool. + open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> (h:(num->bool)->(A->bool)) y = h x)` + (LABEL_TAC "h_loc") THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `!a:A. a IN mspace m ==> ?x:num->bool. a IN (h:(num->bool)->(A->bool)) x` + (LABEL_TAC "h_surj") THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* A: Basic setup *) + SUBGOAL_THEN `~(mspace m:A->bool = {})` ASSUME_TAC THENL + [ASM_MESON_TAC[MEMBER_NOT_EMPTY; SUBSET; NOT_IN_EMPTY]; ALL_TAC] THEN + SUBGOAL_THEN `FINITE(IMAGE (h:(num->bool)->(A->bool)) (:num->bool))` + ASSUME_TAC THENL + [MATCH_MP_TAC LOCALLY_CONSTANT_CANTOR_SPACE_FINITE_IMAGE THEN + ASM_MESON_TAC[]; ALL_TAC] THEN + (* B: Covers - Skolemize *) + SUBGOAL_THEN `!s:A->bool. s IN IMAGE h (:num->bool) + ==> ?c. FINITE c /\ ~(c = {}) /\ + (!t. t IN c ==> closed_in (mtopology m) t) /\ + (!t. t IN c ==> ~(t = {})) /\ + (!t. t IN c ==> t SUBSET s) /\ + (!t. t IN c ==> mdiameter m t < e) /\ + UNIONS c = s` + MP_TAC THENL [REWRITE_TAC[FORALL_IN_IMAGE; IN_UNIV] THEN + X_GEN_TAC `x:num->bool` THEN + MATCH_MP_TAC COMPACT_SUBSET_FINITE_CLOSED_COVER THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `cov:(A->bool)->((A->bool)->bool)` + (LABEL_TAC "cov_props") o + REWRITE_RULE[RIGHT_IMP_EXISTS_THM; SKOLEM_THM]) THEN + (* C: Fibers are nonempty clopen *) + SUBGOAL_THEN `!s:A->bool. s IN IMAGE h (:num->bool) + ==> open_in cantor_space {x:num->bool | h x = s} /\ + closed_in cantor_space {x:num->bool | h x = s} /\ + ~({x:num->bool | h x = s} = {})` + ASSUME_TAC THENL + [REWRITE_TAC[FORALL_IN_IMAGE; IN_UNIV] THEN X_GEN_TAC `x:num->bool` THEN + REPEAT CONJ_TAC THENL + [MATCH_MP_TAC LOCALLY_CONSTANT_CANTOR_SPACE_FIBER_OPEN THEN + ASM_MESON_TAC[]; + MATCH_MP_TAC LOCALLY_CONSTANT_CANTOR_SPACE_FIBER_CLOSED THEN + ASM_MESON_TAC[]; + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + EXISTS_TAC `x:num->bool` THEN REFL_TAC]; ALL_TAC] THEN + (* D: Partitions - Skolemize *) + SUBGOAL_THEN `!s:A->bool. s IN IMAGE h (:num->bool) + ==> ?p. p HAS_SIZE CARD((cov:(A->bool)->((A->bool)->bool)) s) /\ + (!t. t IN p ==> open_in cantor_space t) /\ + (!t. t IN p ==> closed_in cantor_space t) /\ + (!t. t IN p ==> ~(t = {})) /\ + UNIONS p = {x:num->bool | h x = s} /\ + pairwise DISJOINT p` + MP_TAC THENL [X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC CANTOR_SPACE_CLOPEN_PARTITION THEN ASM_SIMP_TAC[] THEN + MATCH_MP_TAC(ARITH_RULE `~(n = 0) ==> 1 <= n`) THEN + SUBGOAL_THEN `FINITE((cov:(A->bool)->((A->bool)->bool)) s)` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + SIMP_TAC[CARD_EQ_0] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN + `part:(A->bool)->(((num->bool)->bool)->bool)` + (LABEL_TAC "part_props") o + REWRITE_RULE[RIGHT_IMP_EXISTS_THM; SKOLEM_THM]) THEN + (* E: Bijections - Skolemize *) + SUBGOAL_THEN `!s:A->bool. s IN IMAGE h (:num->bool) + ==> ?f:((num->bool)->bool)->(A->bool). + (!t. t IN (part:(A->bool)->(((num->bool)->bool)->bool)) s + ==> f t IN (cov:(A->bool)->((A->bool)->bool)) s) /\ + (!u. u IN cov s ==> ?t. t IN part s /\ f t = u) /\ + (!t1 t2. t1 IN part s /\ t2 IN part s /\ f t1 = f t2 + ==> t1 = t2)` + MP_TAC THENL [X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC CARD_EQ_BIJECTION THEN + SUBGOAL_THEN `(part:(A->bool)->(((num->bool)->bool)->bool)) s + HAS_SIZE CARD((cov:(A->bool)->((A->bool)->bool)) s)` + MP_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[HAS_SIZE] THEN STRIP_TAC THEN ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `bij:(A->bool)->((num->bool)->bool)->(A->bool)` + (LABEL_TAC "bij_props") o + REWRITE_RULE[RIGHT_IMP_EXISTS_THM; SKOLEM_THM]) THEN + (* F: Helper - every x IN IMAGE h *) + SUBGOAL_THEN `!x:num->bool. + (h:(num->bool)->(A->bool)) x IN IMAGE h (:num->bool)` + (LABEL_TAC "h_in_image") THENL [REWRITE_TAC[IN_IMAGE; IN_UNIV] THEN + MESON_TAC[]; ALL_TAC] THEN + (* G: For any x, @t selects a valid partition piece containing x *) + SUBGOAL_THEN `!x:num->bool. + (@t. t IN (part:(A->bool)->(((num->bool)->bool)->bool)) + ((h:(num->bool)->(A->bool)) x) /\ + x IN t) + IN part (h x) /\ + x IN (@t. t IN part (h x) /\ x IN t)` + (LABEL_TAC "piece_valid") THENL + [X_GEN_TAC `x:num->bool` THEN CONV_TAC SELECT_CONV THEN + SUBGOAL_THEN `(x:num->bool) IN + UNIONS((part:(A->bool)->(((num->bool)->bool)->bool)) + ((h:(num->bool)->(A->bool)) x))` + MP_TAC THENL [SUBGOAL_THEN + `UNIONS((part:(A->bool)->(((num->bool)->bool)->bool)) + ((h:(num->bool)->(A->bool)) x)) = + {z:num->bool | h z = h x}` + SUBST1_TAC THENL [USE_THEN "part_props" (MP_TAC o SPEC + `(h:(num->bool)->(A->bool)) x`) THEN + USE_THEN "h_in_image" (fun th -> REWRITE_TAC[th]) THEN + SIMP_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_ELIM_THM]; + REWRITE_TAC[IN_UNIONS] THEN MESON_TAC[]]; ALL_TAC] THEN + (* H: Uniqueness - if q IN part(h x) and x IN q, then @t = q *) + SUBGOAL_THEN `!x:num->bool q:(num->bool)->bool. + q IN (part:(A->bool)->(((num->bool)->bool)->bool)) + ((h:(num->bool)->(A->bool)) x) /\ x IN q + ==> (@t. t IN part (h x) /\ x IN t) = q` + (LABEL_TAC "piece_unique") THENL + [REPEAT STRIP_TAC THEN + USE_THEN "piece_valid" (MP_TAC o SPEC `x:num->bool`) THEN STRIP_TAC THEN + USE_THEN "part_props" (MP_TAC o SPEC `(h:(num->bool)->(A->bool)) x`) THEN + USE_THEN "h_in_image" (fun th -> REWRITE_TAC[th]) THEN STRIP_TAC THEN + UNDISCH_TAC + `pairwise DISJOINT + ((part:(A->bool)->(((num->bool)->bool)->bool)) + ((h:(num->bool)->(A->bool)) x))` THEN + REWRITE_TAC[pairwise] THEN DISCH_TAC THEN ASM_CASES_TAC + `(@t:(num->bool)->bool. + t IN (part:(A->bool)->(((num->bool)->bool)->bool)) + ((h:(num->bool)->(A->bool)) x) /\ + x IN t) = q` THEN ASM_REWRITE_TAC[] THEN FIRST_X_ASSUM(MP_TAC o SPECL - [`u:A->bool`; - `{z | z IN topspace(product_topology k (\i:K. euclideanreal)) /\ - z i IN real_interval(ds i - e / &2,ds i + e / &2)}`]) THEN - ASM_REWRITE_TAC[IN_ELIM_THM; NOT_IMP] THEN REPEAT CONJ_TAC THENL - [FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (SET_RULE - `s = u INTER t ==> x IN s ==> x IN u`)) THEN - REWRITE_TAC[IN_REAL_INTERVAL; IN_ELIM_THM] THEN - CONJ_TAC THENL [ASM SET_TAC[]; ASM_REAL_ARITH_TAC]; - REWRITE_TAC[TOPSPACE_PRODUCT_TOPOLOGY; cartesian_product] THEN - ASM_REWRITE_TAC[o_THM; TOPSPACE_EUCLIDEANREAL; IN_UNIV; IN_ELIM_THM]; - REWRITE_TAC[IN_REAL_INTERVAL] THEN ASM_REAL_ARITH_TAC; - MATCH_MP_TAC OPEN_IN_CONTINUOUS_MAP_PREIMAGE THEN - EXISTS_TAC `euclideanreal` THEN - ASM_SIMP_TAC[CONTINUOUS_MAP_PRODUCT_PROJECTION] THEN - REWRITE_TAC[GSYM REAL_OPEN_IN; REAL_OPEN_REAL_INTERVAL]; + [`@t:(num->bool)->bool. + t IN (part:(A->bool)->(((num->bool)->bool)->bool)) + ((h:(num->bool)->(A->bool)) x) /\ + x IN t`; `q:(num->bool)->bool`]) THEN + ASM_REWRITE_TAC[DISJOINT] THEN ASM SET_TAC[]; ALL_TAC] THEN + (* I: Define h' *) + EXISTS_TAC + `\x:num->bool. + (bij:(A->bool)->((num->bool)->bool)->(A->bool)) + ((h:(num->bool)->(A->bool)) x) + (@t:(num->bool)->bool. + t IN (part:(A->bool)->(((num->bool)->bool)->bool)) (h x) /\ + x IN t)` THEN REWRITE_TAC[] THEN + (* bij(h x)(@t...) IN cov(h x) for all x *) + SUBGOAL_THEN `!x:num->bool. + (bij:(A->bool)->((num->bool)->bool)->(A->bool)) + ((h:(num->bool)->(A->bool)) x) + (@t:(num->bool)->bool. + t IN (part:(A->bool)->(((num->bool)->bool)->bool)) (h x) /\ + x IN t) IN + (cov:(A->bool)->((A->bool)->bool)) (h x)` + (LABEL_TAC "val_in_cov") THENL + [GEN_TAC THEN + USE_THEN "bij_props" (MP_TAC o SPEC `(h:(num->bool)->(A->bool)) x`) THEN + USE_THEN "h_in_image" (fun th -> REWRITE_TAC[th]) THEN + STRIP_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN + USE_THEN "piece_valid" (MP_TAC o SPEC `x:num->bool`) THEN + SIMP_TAC[]; ALL_TAC] THEN + (let cov_tac = + USE_THEN "cov_props" (MP_TAC o SPEC `(h:(num->bool)->(A->bool)) x`) THEN + USE_THEN "h_in_image" (fun th -> REWRITE_TAC[th]) THEN + STRIP_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN + USE_THEN "val_in_cov" (ACCEPT_TAC o SPEC `x:num->bool`) in + REPEAT CONJ_TAC THENL [GEN_TAC THEN cov_tac; GEN_TAC THEN cov_tac; + GEN_TAC THEN TRANS_TAC SUBSET_TRANS `(h:(num->bool)->(A->bool)) x` THEN + ASM_REWRITE_TAC[] THEN cov_tac; GEN_TAC THEN cov_tac; GEN_TAC THEN cov_tac; + (* 6: locally constant *) + X_GEN_TAC `x:num->bool` THEN + USE_THEN "h_loc" (MP_TAC o SPEC `x:num->bool`) THEN + DISCH_THEN(X_CHOOSE_THEN `u:(num->bool)->bool` STRIP_ASSUME_TAC) THEN + ABBREV_TAC + `px:(num->bool)->bool = + @t. t IN (part:(A->bool)->(((num->bool)->bool)->bool)) + ((h:(num->bool)->(A->bool)) x) /\ x IN t` THEN + EXISTS_TAC `u INTER (px:(num->bool)->bool)` THEN + REPEAT CONJ_TAC THENL [(* open *) + MATCH_MP_TAC OPEN_IN_INTER THEN ASM_REWRITE_TAC[] THEN + USE_THEN "part_props" (MP_TAC o SPEC `(h:(num->bool)->(A->bool)) x`) THEN + USE_THEN "h_in_image" (fun th -> REWRITE_TAC[th]) THEN + STRIP_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN EXPAND_TAC "px" THEN + USE_THEN "piece_valid" (MP_TAC o SPEC `x:num->bool`) THEN SIMP_TAC[]; + (* x IN u INTER px *) + REWRITE_TAC[IN_INTER] THEN ASM_REWRITE_TAC[] THEN EXPAND_TAC "px" THEN + USE_THEN "piece_valid" (MP_TAC o SPEC `x:num->bool`) THEN SIMP_TAC[]; + (* constancy *) + X_GEN_TAC `y:num->bool` THEN REWRITE_TAC[IN_INTER] THEN STRIP_TAC THEN + SUBGOAL_THEN `(h:(num->bool)->(A->bool)) y = h x` + ASSUME_TAC THENL [FIRST_X_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(@t:(num->bool)->bool. + t IN (part:(A->bool)->(((num->bool)->bool)->bool)) + ((h:(num->bool)->(A->bool)) y) /\ y IN t) = px` + (fun th -> ASM_REWRITE_TAC[th]) THEN + USE_THEN "piece_unique" (fun th -> MATCH_MP_TAC th) THEN + ASM_REWRITE_TAC[] THEN + EXPAND_TAC "px" THEN + USE_THEN "piece_valid" (MP_TAC o SPEC `x:num->bool`) THEN SIMP_TAC[]]; + (* 7: surjective *) + X_GEN_TAC `a:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `?x0:num->bool. a IN (h:(num->bool)->(A->bool)) x0` + (X_CHOOSE_TAC `x0:num->bool`) THENL + [USE_THEN "h_surj" (fun th -> MATCH_MP_TAC th) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `?c:A->bool. c IN (cov:(A->bool)->((A->bool)->bool)) + ((h:(num->bool)->(A->bool)) x0) /\ a IN c` + STRIP_ASSUME_TAC THENL + [USE_THEN "cov_props" (MP_TAC o SPEC `(h:(num->bool)->(A->bool)) x0`) THEN + USE_THEN "h_in_image" (fun th -> REWRITE_TAC[th]) THEN STRIP_TAC THEN + SUBGOAL_THEN `(a:A) IN UNIONS((cov:(A->bool)->((A->bool)->bool)) + ((h:(num->bool)->(A->bool)) x0))` + MP_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `c0:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `c0:A->bool` THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `?q:(num->bool)->bool. + q IN (part:(A->bool)->(((num->bool)->bool)->bool)) + ((h:(num->bool)->(A->bool)) x0) /\ + (bij:(A->bool)->((num->bool)->bool)->(A->bool)) (h x0) q = c` + STRIP_ASSUME_TAC THENL [USE_THEN "bij_props" (fun bp -> + USE_THEN "h_in_image" (fun hi -> MESON_TAC[REWRITE_RULE[hi] + (SPEC `(h:(num->bool)->(A->bool)) x0` bp); + ASSUME `c:A->bool IN + (cov:(A->bool)->((A->bool)->bool)) ((h:(num->bool)->(A->bool)) + x0)`])); ALL_TAC] THEN + SUBGOAL_THEN `?y:num->bool. y IN (q:(num->bool)->bool)` + (X_CHOOSE_TAC `y:num->bool`) THENL [REWRITE_TAC[MEMBER_NOT_EMPTY] THEN + USE_THEN "part_props" (MP_TAC o SPEC `(h:(num->bool)->(A->bool)) x0`) + THEN + USE_THEN "h_in_image" (fun th -> REWRITE_TAC[th]) THEN + STRIP_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(h:(num->bool)->(A->bool)) y = h x0` + ASSUME_TAC THENL [USE_THEN "part_props" (MP_TAC o SPEC + `(h:(num->bool)->(A->bool)) x0`) THEN + USE_THEN "h_in_image" (fun th -> REWRITE_TAC[th]) THEN STRIP_TAC THEN + SUBGOAL_THEN `(y:num->bool) IN + UNIONS((part:(A->bool)->(((num->bool)->bool)->bool)) + ((h:(num->bool)->(A->bool)) + x0))` MP_TAC THENL [REWRITE_TAC[IN_UNIONS] THEN + EXISTS_TAC `q:(num->bool)->bool` THEN ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[] THEN REWRITE_TAC[IN_ELIM_THM]]; ALL_TAC] THEN + EXISTS_TAC `y:num->bool` THEN SUBGOAL_THEN `(@t:(num->bool)->bool. + t IN (part:(A->bool)->(((num->bool)->bool)->bool)) + ((h:(num->bool)->(A->bool)) y) /\ y IN t) = q` + (fun th -> REWRITE_TAC[th]) THENL + [USE_THEN "piece_unique" (fun th -> MATCH_MP_TAC th) THEN + ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[]]]));; + +(* Main theorem: Alexandroff-Hausdorff *) +let ALEXANDROFF_HAUSDORFF = prove + (`!top:A topology. + compact_space top /\ metrizable_space top /\ ~(topspace top = {}) + ==> ?f. continuous_map(cantor_space, top) f /\ + IMAGE f (topspace cantor_space) = topspace top`, + let TOWER_CONSTRUCTION_BASE = prove + (`!m:A metric. + compact_space (mtopology m) /\ ~(mspace m = {}) + ==> ?h0:(num->bool)->(A->bool). + (!x. closed_in (mtopology m) (h0 x)) /\ + (!x. ~(h0 x = {})) /\ + (!x. h0 x SUBSET mspace m) /\ + (!x. mdiameter m (h0 x) < inv(&1)) /\ + (!x:num->bool. ?u. open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> h0 y = h0 x)) /\ + (!a. a IN mspace m ==> ?x. a IN h0 x)`, + REPEAT STRIP_TAC THEN + MP_TAC(ISPECL [`m:A metric`; `(\x:num->bool. mspace(m:A metric))`; + `inv(&1)`] LOCALLY_CONSTANT_REFINEMENT) THEN + REWRITE_TAC[SUBSET_REFL] THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[REAL_LT_INV_EQ; REAL_OF_NUM_LT; + ARITH_RULE `0 < 1`] THEN + REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY; CLOSED_IN_TOPSPACE] THEN + GEN_TAC THEN EXISTS_TAC `topspace cantor_space` THEN + REWRITE_TAC[OPEN_IN_TOPSPACE; TOPSPACE_CANTOR_SPACE; IN_UNIV]; + DISCH_THEN(X_CHOOSE_THEN `h0:(num->bool)->(A->bool)` + STRIP_ASSUME_TAC) THEN + EXISTS_TAC `h0:(num->bool)->(A->bool)` THEN ASM_REWRITE_TAC[]]) + and TOWER_CONSTRUCTION_STEP = prove + (`!m:A metric n (h:(num->bool)->(A->bool)). + compact_space (mtopology m) /\ + (!x. closed_in (mtopology m) (h x)) /\ + (!x. ~(h x = {})) /\ + (!x. h x SUBSET mspace m) /\ + (!x. mdiameter m (h x) < inv(&(SUC n))) /\ + (!x:num->bool. ?u. open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> h y = h x)) /\ + (!a. a IN mspace m ==> ?x. a IN h x) + ==> ?h':(num->bool)->(A->bool). + (!x. closed_in (mtopology m) (h' x)) /\ + (!x. ~(h' x = {})) /\ + (!x. h' x SUBSET mspace m) /\ + (!x. mdiameter m (h' x) < inv(&(SUC(SUC n)))) /\ + (!x. h' x SUBSET h x) /\ + (!x:num->bool. ?u. open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> h' y = h' x)) /\ + (!a. a IN mspace m ==> ?x. a IN h' x)`, + REPEAT STRIP_TAC THEN + MP_TAC(ISPECL [`m:A metric`; `h:(num->bool)->(A->bool)`; + `inv(&(SUC(SUC n)))`] LOCALLY_CONSTANT_REFINEMENT) THEN + ASM_REWRITE_TAC[REAL_LT_INV_EQ; REAL_OF_NUM_LT; LT_0] THEN + MESON_TAC[]) in + let tower_step_tac = + MP_TAC(ISPECL [`m:A metric`; `n:num`; + `(g:num->(num->bool)->(A->bool)) n`] TOWER_CONSTRUCTION_STEP) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(fun step_thm -> MP_TAC(SELECT_RULE step_thm)) THEN + USE_THEN "g_step" (fun th -> REWRITE_TAC[GSYM(SPEC `n:num` th)]) in + let TOWER_CONSTRUCTION_INDUCTION = prove + (`!m:A metric (h0:(num->bool)->(A->bool)). + compact_space (mtopology m) /\ ~(mspace m = {}) /\ mcomplete m /\ + (!x. closed_in (mtopology m) (h0 x)) /\ + (!x. ~(h0 x = {})) /\ + (!x. h0 x SUBSET mspace m) /\ + (!x. mdiameter m (h0 x) < inv(&1)) /\ + (!x:num->bool. ?u. open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> h0 y = h0 x)) /\ + (!a. a IN mspace m ==> ?x. a IN h0 x) + ==> ?g. (!n:num. !x:num->bool. + closed_in (mtopology m) (g n x)) /\ + (!n:num. !x:num->bool. ~(g n x = {})) /\ + (!n:num. !x:num->bool. g n x SUBSET mspace m) /\ + (!n:num. !x:num->bool. + mdiameter m (g n x) < inv(&(SUC n))) /\ + (!n:num. !x:num->bool. g (SUC n) x SUBSET g n x) /\ + (!n:num. !x:num->bool. ?u:(num->bool)->bool. + open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> g n y = g n x)) /\ + (!n:num. !a:A. a IN mspace m + ==> ?x:num->bool. a IN g n x)`, + REPEAT STRIP_TAC THEN + (CHOOSE_THEN (fun g_eq -> + CONJUNCTS_THEN2 (LABEL_TAC "g_base") (LABEL_TAC "g_step") g_eq) o + prove_recursive_functions_exist num_RECURSION) + `(g:num->(num->bool)->(A->bool)) 0 = h0 /\ + (!n. g (SUC n) = + @(h':(num->bool)->(A->bool)). + (!x. closed_in (mtopology (m:A metric)) (h' x)) /\ + (!x. ~(h' x = {})) /\ + (!x. h' x SUBSET mspace m) /\ + (!x. mdiameter m (h' x) < inv(&(SUC(SUC n)))) /\ + (!x. h' x SUBSET g n x) /\ + (!x:num->bool. ?u. open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> h' y = h' x)) /\ + (!a. a IN mspace m ==> ?x. a IN h' x))` THEN + SUBGOAL_THEN `!n. (!x. closed_in (mtopology (m:A metric)) (g n x)) /\ + (!x. ~(g n x = {})) /\ + (!x. g n x SUBSET mspace m) /\ + (!x. mdiameter m (g n x) < inv(&(SUC n))) /\ + (!x:num->bool. ?u. open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> g n y = g n x)) /\ + (!a. a IN mspace m ==> ?x. a IN g n x)` + ASSUME_TAC THENL + [INDUCT_TAC THENL + [USE_THEN "g_base" (fun th -> REWRITE_TAC[th]) THEN + REWRITE_TAC[ARITH_RULE `SUC 0 = 1`] THEN ASM_MESON_TAC[]; + tower_step_tac THEN STRIP_TAC THEN ASM_REWRITE_TAC[]]; ALL_TAC] THEN - EXPAND_TAC "f" THEN REWRITE_TAC[IN_CROSS; IN_ELIM_THM] THEN - ASM_REWRITE_TAC[RESTRICTION; NOT_EXISTS_THM] THEN X_GEN_TAC `y:A` THEN - GEN_REWRITE_TAC RAND_CONV [CONJ_ASSOC] THEN - DISCH_THEN(CONJUNCTS_THEN2 MP_TAC ASSUME_TAC) THEN - FIRST_ASSUM(MATCH_MP_TAC o MATCH_MP (SET_RULE - `t = u INTER s i - ==> i IN k /\ ~(y IN t) - ==> y IN INTERS {s i | i IN k} /\ y IN u ==> F`)) THEN - ASM_REWRITE_TAC[IN_ELIM_THM] THEN - DISCH_THEN(MP_TAC o CONJUNCT2) THEN - FIRST_X_ASSUM(MP_TAC o CONJUNCT2) THEN - REWRITE_TAC[IN_REAL_INTERVAL] THEN - EXPAND_TAC "e" THEN REAL_ARITH_TAC]);; - -let OPEN_HOMEOMORPHIC_SPACE_CLOSED_IN_PRODUCT = prove - (`!top (s:A->bool). - metrizable_space top /\ open_in top s - ==> ?t. closed_in (prod_topology top euclideanreal) t /\ - subtopology top s homeomorphic_space - subtopology (prod_topology top euclideanreal) t`, + SUBGOAL_THEN `!n. !x:num->bool. + (g:num->(num->bool)->(A->bool)) (SUC n) x SUBSET g n x` + ASSUME_TAC THENL + [GEN_TAC THEN tower_step_tac THEN MESON_TAC[]; ALL_TAC] THEN + EXISTS_TAC `g:num->(num->bool)->(A->bool)` THEN ASM_REWRITE_TAC[]) in + let SMALL_DIAMETER_SUBSET_MCBALL = prove + (`!m:A metric s a e. + mbounded m s /\ a IN s /\ mdiameter m s < e + ==> s SUBSET mcball m (a, e)`, + REPEAT STRIP_TAC THEN REWRITE_TAC[SUBSET; IN_MCBALL] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(s:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[MBOUNDED_SUBSET_MSPACE]; ALL_TAC] THEN + SUBGOAL_THEN `(y:A) IN mspace m /\ (a:A) IN mspace m` + STRIP_ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `mdiameter m (s:A->bool)` THEN CONJ_TAC THENL + [ASM_MESON_TAC[MDIAMETER_BOUNDED_BOUND]; ASM_REAL_ARITH_TAC]) in + let TOWER_CONSTRUCTION = prove + (`!m:A metric. + compact_space (mtopology m) /\ ~(mspace m = {}) /\ mcomplete m + ==> ?g. (!n:num. !x:num->bool. + closed_in (mtopology m) (g n x)) /\ + (!n:num. !x:num->bool. ~(g n x = {})) /\ + (!n:num. !x:num->bool. g n x SUBSET mspace m) /\ + (!n:num. !x:num->bool. + mdiameter m (g n x) < inv(&(SUC n))) /\ + (!n:num. !x:num->bool. g (SUC n) x SUBSET g n x) /\ + (!n:num. !x:num->bool. ?u:(num->bool)->bool. + open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> g n y = g n x)) /\ + (!n:num. !a:A. a IN mspace m + ==> ?x:num->bool. a IN g n x)`, + REPEAT STRIP_TAC THEN + MP_TAC(ISPEC `m:A metric` TOWER_CONSTRUCTION_BASE) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `h0:(num->bool)->(A->bool)` + STRIP_ASSUME_TAC) THEN + MP_TAC(ISPECL [`m:A metric`; `h0:(num->bool)->(A->bool)`] + TOWER_CONSTRUCTION_INDUCTION) THEN + ASM_REWRITE_TAC[]) in REPEAT STRIP_TAC THEN - MP_TAC(ISPECL [`top:A topology`; `(\x. s):1->A->bool`; `{one}`] - GDELTA_HOMEOMORPHIC_SPACE_CLOSED_IN_PRODUCT) THEN - ASM_REWRITE_TAC[SET_RULE `INTERS {s |i| i IN {a}} = s`] THEN - DISCH_THEN(X_CHOOSE_THEN `t:A#(1->real)->bool` STRIP_ASSUME_TAC) THEN + (* Get compatible metric *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [metrizable_space]) THEN + DISCH_THEN(X_CHOOSE_TAC `m:A metric`) THEN + SUBGOAL_THEN `compact_space (mtopology m:A topology)` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] + THEN + SUBGOAL_THEN `~(mspace m:A->bool = {})` ASSUME_TAC THENL + [ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + SUBGOAL_THEN `mcomplete (m:A metric)` ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_SPACE_IMP_MCOMPLETE]; ALL_TAC] THEN + ASM_REWRITE_TAC[TOPSPACE_CANTOR_SPACE] THEN + (* Step 1: Get tower from TOWER_CONSTRUCTION *) + MP_TAC(ISPEC `m:A metric` TOWER_CONSTRUCTION) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `g:num->(num->bool)->(A->bool)` STRIP_ASSUME_TAC) + THEN + (* Step 2: For each x, the nested intersection is a singleton *) + SUBGOAL_THEN `!x:num->bool. ?a:A. a IN mspace m /\ + INTERS {(g:num->(num->bool)->(A->bool)) n x | n | n IN (:num)} = {a}` + MP_TAC THENL [X_GEN_TAC `x:num->bool` THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [MCOMPLETE_NEST_SING]) THEN + DISCH_THEN(MP_TAC o + SPEC `\n:num. (g:num->(num->bool)->(A->bool)) n x`) THEN + REWRITE_TAC[] THEN ANTS_TAC THENL + [REPEAT CONJ_TAC THENL [(* closed_in *) ASM_REWRITE_TAC[]; + (* nonempty *) + ASM_REWRITE_TAC[]; + (* monotonicity: !p q. p <= q ==> g q x SUBSET g p x *) + MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN REWRITE_TAC[SUBSET_REFL] THEN + CONJ_TAC THENL [MESON_TAC[SUBSET_TRANS]; ASM_REWRITE_TAC[]]; + (* small diameter: ?n a. g n x SUBSET mcball m (a,e) *) + X_GEN_TAC `e:real` THEN DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [REAL_ARCH_INV]) THEN + DISCH_THEN(X_CHOOSE_THEN `N:num` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `?nn:num. N = SUC nn` + (X_CHOOSE_TAC `nn:num`) THENL [ASM_MESON_TAC[num_CASES]; + ALL_TAC] THEN + EXISTS_TAC `nn:num` THEN + SUBGOAL_THEN `~((g:num->(num->bool)->(A->bool)) nn x = {})` + MP_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + DISCH_THEN(X_CHOOSE_TAC `a:A`) THEN + EXISTS_TAC `a:A` THEN MATCH_MP_TAC SMALL_DIAMETER_SUBSET_MCBALL THEN + ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ] + COMPACT_IN_IMP_MBOUNDED) THEN + MATCH_MP_TAC CLOSED_IN_COMPACT_SPACE THEN ASM_REWRITE_TAC[]; + MATCH_MP_TAC REAL_LT_TRANS THEN + EXISTS_TAC `inv(&(SUC nn))` THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `N = SUC nn` THEN + DISCH_THEN SUBST_ALL_TAC THEN ASM_REWRITE_TAC[]]]; + MESON_TAC[]]; ALL_TAC] THEN REWRITE_TAC[SKOLEM_THM] THEN + DISCH_THEN(X_CHOOSE_TAC `f:(num->bool)->A`) THEN + EXISTS_TAC `f:(num->bool)->A` THEN + (* Step 3: f(x) IN g n x for all n *) + SUBGOAL_THEN `!(n:num) (x:num->bool). (f:(num->bool)->A) x IN + (g:num->(num->bool)->(A->bool)) n x` + ASSUME_TAC THENL [REPEAT GEN_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `x:num->bool`) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (fun th -> MP_TAC(REWRITE_RULE[EXTENSION; IN_INTERS; IN_SING; + IN_ELIM_THM; IN_UNIV] th))) THEN + MESON_TAC[]; ALL_TAC] THEN + (* Step 4: f maps into topspace = mspace m *) + SUBGOAL_THEN `!x:num->bool. (f:(num->bool)->A) x IN mspace m` + ASSUME_TAC THENL [GEN_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`0`; `x:num->bool`]) THEN + ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + CONJ_TAC THENL [(* Step 5: f is continuous *) + REWRITE_TAC[continuous_map; TOPSPACE_CANTOR_SPACE; IN_UNIV; + TOPSPACE_MTOPOLOGY] THEN CONJ_TAC THENL + [REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_UNIV] THEN + FIRST_ASSUM MATCH_ACCEPT_TAC; ALL_TAC] THEN X_GEN_TAC `u:A->bool` THEN + DISCH_TAC THEN + ONCE_REWRITE_TAC[OPEN_IN_SUBOPEN] THEN X_GEN_TAC `x':num->bool` THEN + REWRITE_TAC[IN_ELIM_THM] THEN DISCH_TAC THEN + (* Get epsilon ball around f(x') in u *) + SUBGOAL_THEN + `?r. &0 < r /\ mball m ((f:(num->bool)->A) x', r) SUBSET (u:A->bool)` + STRIP_ASSUME_TAC THENL [UNDISCH_TAC `open_in (mtopology m) (u:A->bool)` + THEN + REWRITE_TAC[OPEN_IN_MTOPOLOGY] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `(f:(num->bool)->A) x'`) THEN ANTS_TAC THENL + [UNDISCH_TAC `(f:(num->bool)->A) x' IN (u:A->bool)` THEN REWRITE_TAC[]; + MESON_TAC[]]; ALL_TAC] THEN + (* Pick nn with inv(&(SUC nn)) < r *) + SUBGOAL_THEN `?nn:num. inv(&(SUC nn)) < r` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `&0 < r` THEN + GEN_REWRITE_TAC LAND_CONV [REAL_ARCH_INV] THEN + DISCH_THEN(X_CHOOSE_THEN `N:num` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `?pn:num. N = SUC pn` (X_CHOOSE_TAC `pn:num`) THENL + [UNDISCH_TAC `~(N = 0)` THEN MESON_TAC[num_CASES]; ALL_TAC] THEN + EXISTS_TAC `pn:num` THEN + UNDISCH_TAC `N = SUC pn` THEN DISCH_THEN SUBST_ALL_TAC THEN + FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + (* Get open V from local constancy of g at level nn *) + SUBGOAL_THEN `?v:(num->bool)->bool. open_in cantor_space v /\ x' IN v /\ + (!y:num->bool. y IN v ==> + (g:num->(num->bool)->(A->bool)) nn y = g nn x')` + STRIP_ASSUME_TAC THENL [UNDISCH_TAC `!n:num. !x:num->bool. + ?u:(num->bool)->bool. open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> (g:num->(num->bool)->(A->bool)) n y = g n x)` THEN + DISCH_THEN(MP_TAC o SPECL [`nn:num`; `x':num->bool`]) THEN + MESON_TAC[]; ALL_TAC] THEN + (* v is the required open set *) + EXISTS_TAC `v:(num->bool)->bool` THEN + REWRITE_TAC[TOPSPACE_CANTOR_SPACE; IN_UNIV] THEN + REPLICATE_TAC 2 (CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; ALL_TAC]) THEN + (* Show v SUBSET {x | f x IN u}: for y IN v, f(y) IN u *) + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN X_GEN_TAC `y:num->bool` THEN + DISCH_TAC THEN + (* f(y) IN g nn x' (via local constancy), both in g nn x' *) + SUBGOAL_THEN + `(f:(num->bool)->A) y IN (g:num->(num->bool)->(A->bool)) nn x'` + ASSUME_TAC THENL [SUBGOAL_THEN + `(g:num->(num->bool)->(A->bool)) nn y = g nn x'` + (fun th -> REWRITE_TAC[GSYM th]) THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + UNDISCH_TAC `!n:num. !x:num->bool. + (f:(num->bool)->A) x IN (g:num->(num->bool)->(A->bool)) n x` THEN + DISCH_THEN(MP_TAC o SPECL [`nn:num`; `y:num->bool`]) THEN + REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `(f:(num->bool)->A) x' IN (g:num->(num->bool)->(A->bool)) nn x'` + ASSUME_TAC THENL [UNDISCH_TAC `!n:num. !x:num->bool. + (f:(num->bool)->A) x IN (g:num->(num->bool)->(A->bool)) n x` THEN + DISCH_THEN(MP_TAC o SPECL [`nn:num`; `x':num->bool`]) THEN + REWRITE_TAC[]; ALL_TAC] THEN + (* g nn x' is bounded *) + SUBGOAL_THEN `mbounded m ((g:num->(num->bool)->(A->bool)) nn x')` + ASSUME_TAC THENL [MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ] + COMPACT_IN_IMP_MBOUNDED) THEN + MATCH_MP_TAC CLOSED_IN_COMPACT_SPACE THEN + UNDISCH_TAC `compact_space (mtopology m:A topology)` THEN + UNDISCH_TAC `!n:num. !x:num->bool. + closed_in (mtopology m) ((g:num->(num->bool)->(A->bool)) n x)` THEN + DISCH_THEN(MP_TAC o SPECL [`nn:num`; `x':num->bool`]) THEN + SIMP_TAC[]; ALL_TAC] THEN + (* mdist(f(x'), f(y)) < r via diameter bound *) + SUBGOAL_THEN `mdist m ((f:(num->bool)->A) x', f y) < r` ASSUME_TAC THENL + [MATCH_MP_TAC REAL_LET_TRANS THEN + EXISTS_TAC `mdiameter m ((g:num->(num->bool)->(A->bool)) nn x')` THEN + CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN + UNDISCH_TAC `mbounded m ((g:num->(num->bool)->(A->bool)) nn x')` THEN + UNDISCH_TAC `(f:(num->bool)->A) x' IN + (g:num->(num->bool)->(A->bool)) nn + x'` THEN UNDISCH_TAC `(f:(num->bool)->A) y IN + (g:num->(num->bool)->(A->bool)) nn x'` THEN + REWRITE_TAC[] THEN MESON_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC REAL_LT_TRANS THEN + EXISTS_TAC `inv(&(SUC nn))` THEN + CONJ_TAC THENL [UNDISCH_TAC `!n:num. !x:num->bool. + mdiameter m ((g:num->(num->bool)->(A->bool)) n x) < inv(&(SUC + n))` THEN + DISCH_THEN(MP_TAC o SPECL [`nn:num`; `x':num->bool`]) THEN + REWRITE_TAC[]; + FIRST_ASSUM ACCEPT_TAC]; ALL_TAC] THEN + (* f(y) IN mball m (f(x'), r) SUBSET u *) + SUBGOAL_THEN `(f:(num->bool)->A) y IN mball m (f x', r)` + ASSUME_TAC THENL [REWRITE_TAC[IN_MBALL] THEN + UNDISCH_TAC `!x:num->bool. (f:(num->bool)->A) x IN mspace m` THEN + DISCH_THEN(fun th -> + MP_TAC(SPEC `x':num->bool` th) THEN MP_TAC(SPEC `y:num->bool` th)) THEN + UNDISCH_TAC `mdist m ((f:(num->bool)->A) x', f y) < r` THEN + REWRITE_TAC[] THEN MESON_TAC[]; ALL_TAC] THEN + UNDISCH_TAC `mball m ((f:(num->bool)->A) x', r) SUBSET (u:A->bool)` THEN + UNDISCH_TAC `(f:(num->bool)->A) y IN mball m (f x', r)` THEN + REWRITE_TAC[SUBSET] THEN MESON_TAC[]; + (* Step 6: f is surjective *) + REWRITE_TAC[GSYM SUBSET_ANTISYM_EQ; TOPSPACE_MTOPOLOGY] THEN CONJ_TAC THENL + [REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_UNIV] THEN + FIRST_ASSUM MATCH_ACCEPT_TAC; ALL_TAC] THEN + REWRITE_TAC[SUBSET; IN_IMAGE; IN_UNIV] THEN X_GEN_TAC `a:A` THEN + DISCH_TAC THEN + (* First show {x | a IN g n x} is closed in cantor_space for each n *) + SUBGOAL_THEN `!n:num. closed_in cantor_space + {x:num->bool | (a:A) IN (g:num->(num->bool)->(A->bool)) n x}` + ASSUME_TAC THENL [GEN_TAC THEN + REWRITE_TAC[closed_in; TOPSPACE_CANTOR_SPACE] THEN + CONJ_TAC THENL [SET_TAC[]; ALL_TAC] THEN SUBGOAL_THEN `(:num->bool) DIFF + {x | (a:A) IN (g:num->(num->bool)->(A->bool)) n x} = + {x:num->bool | ~(a IN g n + x)}` SUBST1_TAC THENL [SET_TAC[]; ALL_TAC] THEN + ONCE_REWRITE_TAC[OPEN_IN_SUBOPEN] THEN X_GEN_TAC `z:num->bool` THEN + REWRITE_TAC[IN_ELIM_THM; TOPSPACE_CANTOR_SPACE; IN_UNIV] THEN + DISCH_TAC THEN + UNDISCH_TAC `!n:num. !x:num->bool. + ?u:(num->bool)->bool. open_in cantor_space u /\ x IN u /\ + (!y. y IN u ==> (g:num->(num->bool)->(A->bool)) n y = g n x)` THEN + DISCH_THEN(MP_TAC o SPECL [`n:num`; `z:num->bool`]) THEN + DISCH_THEN(X_CHOOSE_THEN `w:(num->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `w:(num->bool)->bool` THEN + REPLICATE_TAC 2 (CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; ALL_TAC]) THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN X_GEN_TAC `z':num->bool` THEN + DISCH_TAC THEN + SUBGOAL_THEN `(g:num->(num->bool)->(A->bool)) n z' = g n z` + SUBST1_TAC THENL [FIRST_X_ASSUM MATCH_MP_TAC THEN + FIRST_ASSUM ACCEPT_TAC; + FIRST_ASSUM ACCEPT_TAC]; ALL_TAC] THEN + (* Find z in INTERS of all these sets *) + SUBGOAL_THEN `?z:num->bool. !n:num. + (a:A) IN (g:num->(num->bool)->(A->bool)) n z` + STRIP_ASSUME_TAC THENL [MP_TAC(ISPECL [`cantor_space`; + `\n:num. {x:num->bool | + (a:A) IN (g:num->(num->bool)->(A->bool)) n + x}`] COMPACT_SPACE_IMP_NEST) THEN + REWRITE_TAC[COMPACT_SPACE_CANTOR_SPACE] THEN + ANTS_TAC THENL [REPEAT CONJ_TAC THENL + [(* closedness *) FIRST_ASSUM MATCH_ACCEPT_TAC; + (* nonemptiness *) + GEN_TAC THEN REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + UNDISCH_TAC + `!n:num. !a:A. a IN mspace m ==> ?x:num->bool. a IN g n x` THEN + DISCH_THEN(MP_TAC o SPECL [`n:num`; `a:A`]) THEN + UNDISCH_TAC `(a:A) IN mspace m` THEN + REWRITE_TAC[] THEN MESON_TAC[]; + (* monotonicity *) + MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN + REPEAT CONJ_TAC THENL [SET_TAC[]; SET_TAC[]; + GEN_TAC THEN REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `z:num->bool` THEN DISCH_TAC THEN + UNDISCH_TAC `!n:num. !x:num->bool. + (g:num->(num->bool)->(A->bool)) (SUC n) x SUBSET g n x` THEN + DISCH_THEN(MP_TAC o SPECL [`n:num`; `z:num->bool`]) THEN + UNDISCH_TAC + `(a:A) IN (g:num->(num->bool)->(A->bool)) (SUC n) z` THEN + REWRITE_TAC[SUBSET] THEN MESON_TAC[]]]; ALL_TAC] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + DISCH_THEN(X_CHOOSE_TAC `z:num->bool`) THEN + EXISTS_TAC `z:num->bool` THEN GEN_TAC THEN + (* z IN INTERS {c n | n}, extract z IN c n *) + FIRST_X_ASSUM(MP_TAC) THEN + REWRITE_TAC[IN_INTERS; IN_ELIM_THM; IN_UNIV] THEN + DISCH_THEN(MP_TAC o SPEC + `{x:num->bool | + (a:A) IN (g:num->(num->bool)->(A->bool)) n x}`) THEN + ANTS_TAC THENL [EXISTS_TAC `n:num` THEN REWRITE_TAC[]; + REWRITE_TAC[IN_ELIM_THM]]; ALL_TAC] THEN + (* a IN g n z for all n, and INTERS {g n z | n} = {f z} *) + EXISTS_TAC `z:num->bool` THEN + (* Get INTERS {g n z | n} = {f z} from SKOLEM assumption *) + SUBGOAL_THEN + `INTERS {(g:num->(num->bool)->(A->bool)) n z | n | n IN (:num)} = + {(f:(num->bool)->A) z}` + ASSUME_TAC THENL [FIRST_ASSUM(ACCEPT_TAC o CONJUNCT2 o SPEC + `z:num->bool`); ALL_TAC] THEN + SUBGOAL_THEN `(a:A) IN {(f:(num->bool)->A) z}` MP_TAC THENL + [FIRST_ASSUM(fun th -> REWRITE_TAC[GSYM th]) THEN + REWRITE_TAC[IN_INTERS; IN_ELIM_THM; IN_UNIV] THEN + X_GEN_TAC `s:A->bool` THEN + DISCH_THEN(X_CHOOSE_THEN `k:num` SUBST1_TAC) THEN UNDISCH_TAC `!n:num. + (a:A) IN (g:num->(num->bool)->(A->bool)) n z` THEN + DISCH_THEN(ACCEPT_TAC o SPEC `k:num`); REWRITE_TAC[IN_SING]]]);; + +(* ------------------------------------------------------------------ *) +(* Peano space properties: ULC and path-connectedness. *) +(* ULC: Whyburn, Analytic Topology, Ch. I Sec. 15 (15.5); *) +(* H-Y Theorem 3-13; Willard, General Topology, 31.4. *) +(* ------------------------------------------------------------------ *) + +(* Uniform local connectedness for compact metrizable locally connected spaces: + For every e > 0, there exists d > 0 such that any two points within d + lie in a connected set of diameter < e. *) +let DENSE_FUNCTION_ON_DYADIC = prove + (`!m:A metric e. + mcomplete m /\ &0 < e /\ + (!eps. &0 < eps + ==> ?del. &0 < del /\ + !x y:A. x IN mspace m /\ y IN mspace m /\ + mdist m (x,y) < del + ==> ?c. connected_in(mtopology m) c /\ + x IN c /\ y IN c /\ + mbounded m c /\ + mdiameter m c < eps) + ==> ?d. &0 < d /\ + !x y:A. x IN mspace m /\ y IN mspace m /\ mdist m (x,y) < d + ==> ?f s. s SUBSET real_interval[&0,&1] /\ + real_interval[&0,&1] SUBSET + euclideanreal closure_of s /\ + &0 IN s /\ &1 IN s /\ + (f:real->A)(&0) = x /\ f(&1) = y /\ + IMAGE f s SUBSET mspace m /\ + (!a. a IN s ==> mdist m (x,f a) <= e / &4) /\ + uniformly_continuous_map + (submetric real_euclidean_metric s, m) f`, + let FINITE_BOUND_NUM = prove + (`!f:num->num n. ?M. !k. k < n ==> f k <= M`, + GEN_TAC THEN INDUCT_TAC THENL [EXISTS_TAC `0` THEN ARITH_TAC; + FIRST_X_ASSUM(X_CHOOSE_TAC `M0:num`) THEN + EXISTS_TAC `M0 + (f:num->num) n` THEN GEN_TAC THEN DISCH_TAC THEN + ASM_CASES_TAC `k:num = n` THENL [ASM_REWRITE_TAC[] THEN ARITH_TAC; + SUBGOAL_THEN `k < n:num` (fun th -> + FIRST_X_ASSUM(MP_TAC o C MATCH_MP th)) THENL [ASM_ARITH_TAC; + ARITH_TAC]]]) in + let UNIT_INTERVAL_APPROX = prove + (`!M:num t:real. + 1 <= M /\ &0 <= t /\ t <= &1 + ==> ?k. k <= M /\ abs(t - &k / &M) <= inv(&M)`, + REPEAT STRIP_TAC THEN SUBGOAL_THEN `&0 < &M` ASSUME_TAC THENL + [REWRITE_TAC[REAL_OF_NUM_LT] THEN ASM_ARITH_TAC; ALL_TAC] THEN + (* Find minimal k with t * &M < &(SUC k) using num_WOP *) + SUBGOAL_THEN `?k:num. t * &M < &(SUC k) /\ + !j:num. j < k ==> ~(t * &M < &(SUC j))` + STRIP_ASSUME_TAC THENL + [MP_TAC(ISPEC `\j:num. t * &M < &(SUC j)` num_WOP) THEN REWRITE_TAC[] THEN + DISCH_THEN(fun th -> REWRITE_TAC[GSYM th]) THEN EXISTS_TAC `M:num` THEN + MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `&M:real` THEN CONJ_TAC THENL + [GEN_REWRITE_TAC RAND_CONV [GSYM REAL_MUL_LID] THEN + MATCH_MP_TAC REAL_LE_RMUL THEN + ASM_REWRITE_TAC[REAL_POS]; + REWRITE_TAC[REAL_OF_NUM_LT] THEN ARITH_TAC]; ALL_TAC] THEN + EXISTS_TAC `k:num` THEN + (* Prove k <= M *) + SUBGOAL_THEN `k:num <= M` ASSUME_TAC THENL + [REWRITE_TAC[GSYM NOT_LT] THEN DISCH_TAC THEN + SUBGOAL_THEN `t * &M < &(SUC M)` ASSUME_TAC THENL + [MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `&M:real` THEN CONJ_TAC THENL + [GEN_REWRITE_TAC RAND_CONV [GSYM REAL_MUL_LID] THEN + MATCH_MP_TAC REAL_LE_RMUL THEN ASM_REWRITE_TAC[REAL_POS]; + REWRITE_TAC[REAL_OF_NUM_LT] THEN ARITH_TAC]; ALL_TAC] THEN + UNDISCH_TAC `!j:num. j < k ==> ~(t * &M < &(SUC j))` THEN + DISCH_THEN(MP_TAC o SPEC `M:num`) THEN + ANTS_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + ASM_MESON_TAC[]; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + (* Prove &k <= t * &M *) + SUBGOAL_THEN `&k <= t * &M` ASSUME_TAC THENL [ASM_CASES_TAC `k = 0` THENL + [ASM_REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LE_MUL THEN + ASM_REWRITE_TAC[REAL_POS]; + UNDISCH_TAC `!j:num. j < k ==> ~(t * &M < &(SUC j))` THEN + DISCH_THEN(MP_TAC o SPEC `k - 1`) THEN + ANTS_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `SUC(k - 1) = k` (fun th -> REWRITE_TAC[th]) THENL + [ASM_ARITH_TAC; + REWRITE_TAC[REAL_NOT_LT]]]; ALL_TAC] THEN + (* Prove abs(t - &k / &M) <= inv(&M) *) + MATCH_MP_TAC(REAL_ARITH + `a <= t /\ t - a < e ==> abs(t - a) <= e`) THEN CONJ_TAC THENL + [(* &k / &M <= t *) ASM_SIMP_TAC[REAL_LE_LDIV_EQ] THEN + ONCE_REWRITE_TAC[REAL_MUL_SYM] THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `&(SUC k) / &M = &k / &M + inv(&M)` + ASSUME_TAC THENL + [REWRITE_TAC[real_div; GSYM REAL_OF_NUM_SUC; REAL_ADD_RDISTRIB; + REAL_MUL_LID]; ALL_TAC] THEN + SUBGOAL_THEN `t < &(SUC k) / &M` ASSUME_TAC THENL + [ASM_SIMP_TAC[REAL_LT_RDIV_EQ] THEN + ONCE_REWRITE_TAC[REAL_MUL_SYM] THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_REAL_ARITH_TAC) in + let resolve_select_tac cont_tac = + DISCH_THEN(X_CHOOSE_THEN `nn:num` + (X_CHOOSE_THEN `kk:num` + STRIP_ASSUME_TAC)) THEN ASM_REWRITE_TAC[] THEN REWRITE_TAC[] THEN + SUBGOAL_THEN `(@z:A. ?n k:num. + k <= (N:num->num) n /\ + &kk / &(N nn) = &k / &(N n) /\ + z = (h:num->num->A) n k) = h nn kk` + SUBST1_TAC THENL [MATCH_MP_TAC SELECT_UNIQUE THEN X_GEN_TAC `z:A` THEN + EQ_TAC THENL + [DISCH_THEN(fun th -> + X_CHOOSE_THEN `n1:num` + (X_CHOOSE_THEN `k1:num` + STRIP_ASSUME_TAC) (REWRITE_RULE[] th)) THEN ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`n1:num`; `nn:num`; + `k1:num`; `kk:num`]) THEN ASM_REWRITE_TAC[] THEN MESON_TAC[]; + DISCH_TAC THEN ASM_REWRITE_TAC[] THEN MAP_EVERY EXISTS_TAC + [`nn:num`; `kk:num`] THEN ASM_REWRITE_TAC[]]; cont_tac] in + let resolve_select_B_tac eq_tm n_tm k_tm = + MATCH_MP_TAC SELECT_UNIQUE THEN X_GEN_TAC `z:A` THEN + EQ_TAC THENL [DISCH_THEN(fun th -> + X_CHOOSE_THEN `n1:num` + (X_CHOOSE_THEN `k1:num` STRIP_ASSUME_TAC) (REWRITE_RULE[] th)) THEN + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN eq_tm ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`n1:num`; n_tm; `k1:num`; k_tm]) THEN + ASM_REWRITE_TAC[] THEN SIMP_TAC[]; DISCH_TAC THEN ASM_REWRITE_TAC[] THEN + MAP_EVERY EXISTS_TAC [n_tm; k_tm] THEN ASM_REWRITE_TAC[]] in + let le_ldiv_Nn_tac = + MATCH_MP_TAC LE_LDIV THEN CONJ_TAC THENL + [REWRITE_TAC[GSYM LT_NZ; ARITH_RULE `0 < n <=> 1 <= n`] THEN + SUBGOAL_THEN `~((N:num->num) n = 0)` ASSUME_TAC THENL + [MATCH_MP_TAC(ARITH_RULE `1 <= n ==> ~(n = 0)`) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_SIMP_TAC[LE_RDIV_EQ] THEN REWRITE_TAC[MULT_CLAUSES] THEN + MATCH_MP_TAC LE_TRANS THEN EXISTS_TAC `2 * (N:num->num) n` THEN + ASM_REWRITE_TAC[] THEN ARITH_TAC; + SUBGOAL_THEN `N(SUC n) DIV (N:num->num) n * N n = N(SUC n)` + SUBST1_TAC THENL + [ASM_MESON_TAC[DIVIDES_DIV_MULT]; + ASM_REWRITE_TAC[]]] in + let divides_N_tac = + REWRITE_TAC[GSYM DIVIDES_DIV_MULT] THEN USE_THEN "6d" MATCH_MP_TAC in + let num_field_tac = + REWRITE_TAC[GSYM REAL_OF_NUM_EQ; GSYM REAL_OF_NUM_MUL] THEN + CONV_TAC REAL_FIELD in + let mdist_fk_self_zero_tac = + SUBGOAL_THEN `mdist m ((fk:num->num->A)(kk DIV M)((Mk:num->num)(kk DIV M)), + fk(kk DIV M)(Mk(kk DIV M))) = &0` + (fun th -> REWRITE_TAC[th]) THENL [MATCH_MP_TAC MDIST_REFL THEN + SUBGOAL_THEN `(Mk:num->num)(kk DIV M) <= Mk(kk DIV M)` MP_TAC THENL + [ARITH_TAC; ALL_TAC] THEN + ASM_MESON_TAC[]; + UNDISCH_TAC `!n. &0 < (dl:num->real) n` THEN + DISCH_THEN(ACCEPT_TAC o SPEC `SUC(SUC n)`)] in + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Step 1: Skolemize ULC to get delta function *) + SUBGOAL_THEN `?del. !eps. &0 < eps + ==> &0 < (del:real->real) eps /\ + !x y:A. x IN mspace m /\ y IN mspace m /\ + mdist m (x,y) < del eps + ==> ?c. connected_in(mtopology m) c /\ + x IN c /\ y IN c /\ + mbounded m c /\ + mdiameter m c < eps` + STRIP_ASSUME_TAC THENL [REWRITE_TAC[GSYM SKOLEM_THM] THEN + X_GEN_TAC `eps:real` THEN + FIRST_X_ASSUM(MP_TAC o SPEC `eps:real`) THEN ASM_CASES_TAC `&0 < eps` THENL + [ASM_REWRITE_TAC[] THEN + DISCH_THEN ACCEPT_TAC; ASM_REWRITE_TAC[]]; ALL_TAC] THEN + (* Step 2: Build eps/delta sequence with all needed properties *) + SUBGOAL_THEN `?ep dl. (ep:num->real) 0 = e / &8 /\ + (dl:num->real) 0 = (del:real->real)(e / &8) /\ + (!n. ep(SUC n) = min (dl n) (ep n / &4)) /\ + (!n. dl n = del(ep n)) /\ + (!n. &0 < ep n) /\ + (!n. &0 < dl n) /\ + (!n. ep(SUC n) <= dl n) /\ + (!n. ep(SUC n) <= ep n / &4) /\ + (!n. ep n <= e / &8 / &4 pow n)` + STRIP_ASSUME_TAC THENL [(* Construct ep via num_RECURSION *) MP_TAC(ISPECL + [`e / &8`; + `\(v:real) (n:num). min ((del:real->real) v) (v / &4)`] num_RECURSION) + THEN REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `ep:num->real` STRIP_ASSUME_TAC) THEN + (* Provide witnesses *) + EXISTS_TAC `ep:num->real` THEN + EXISTS_TAC `\n:num. (del:real->real)((ep:num->real) n)` THEN + REWRITE_TAC[] THEN REPLICATE_TAC 3 + (CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC]) THEN + (* &0 < ep n *) + SUBGOAL_THEN `!n. &0 < (ep:num->real) n` ASSUME_TAC THENL [INDUCT_TAC THENL + [ASM_REWRITE_TAC[] THEN + ASM_REAL_ARITH_TAC; ASM_REWRITE_TAC[REAL_LT_MIN] THEN CONJ_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `(ep:num->real) n` o + check (is_forall o concl) o + check (free_in `del:real->real` o concl)) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(ACCEPT_TAC o CONJUNCT1); + ASM_REAL_ARITH_TAC]]; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + (* &0 < dl n = &0 < del(ep n) *) + CONJ_TAC THENL [GEN_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `(ep:num->real) n` o + check (is_forall o concl) o + check (free_in `del:real->real` o concl)) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(ACCEPT_TAC o CONJUNCT1); ALL_TAC] THEN + (* ep(SUC n) <= dl n and ep(SUC n) <= ep n / 4 *) + CONJ_TAC THENL + [GEN_TAC THEN ASM_REWRITE_TAC[REAL_MIN_LE] THEN DISJ1_TAC THEN + REAL_ARITH_TAC; ALL_TAC] THEN + CONJ_TAC THENL + [GEN_TAC THEN ASM_REWRITE_TAC[REAL_MIN_LE] THEN DISJ2_TAC THEN + REAL_ARITH_TAC; ALL_TAC] THEN + (* ep n <= e / 8 / 4^n *) + INDUCT_TAC THENL [ASM_REWRITE_TAC[real_pow; REAL_DIV_1; REAL_LE_REFL]; + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `(ep:num->real) n / &4` THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[REAL_MIN_LE] THEN DISJ2_TAC THEN + REAL_ARITH_TAC; + MATCH_MP_TAC REAL_LE_TRANS THEN EXISTS_TAC `(e / &8 / &4 pow n) / &4` THEN + CONJ_TAC THENL + [MATCH_MP_TAC(REAL_ARITH `a <= b ==> a / &4 <= b / &4`) THEN + ASM_REWRITE_TAC[]; + REWRITE_TAC[real_pow; real_div; REAL_INV_MUL] THEN + REWRITE_TAC[REAL_MUL_AC] THEN REWRITE_TAC[REAL_LE_REFL]]]]; ALL_TAC] THEN + (* Step 3: Take d = dl 0 *) + EXISTS_TAC `(dl:num->real) 0` THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN + (* Step 4: Get initial connected set *) + SUBGOAL_THEN `?c. connected_in(mtopology m) c /\ (x:A) IN c /\ y IN c /\ + mbounded m c /\ mdiameter m c < e / &8` + (X_CHOOSE_THEN `C0:A->bool` STRIP_ASSUME_TAC) THENL [FIRST_ASSUM(MP_TAC o + SPEC `e / &8` o + check (is_forall o concl) o check (free_in `del:real->real` o concl)) THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPECL [`x:A`; `y:A`])) THEN + ANTS_TAC THENL + [UNDISCH_TAC `mdist m (x:A,y) < (dl:num->real) 0` THEN + UNDISCH_TAC `(dl:num->real) 0 = (del:real->real)(e / &8)` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN DISCH_TAC THEN + ASM_REWRITE_TAC[]; + DISCH_THEN ACCEPT_TAC]; ALL_TAC] THEN + (* Step 5: Build chain hierarchy using CONNECTED_METRIC_CHAIN. + At level n we have N(n)+1 points forming a chain with consecutive + distance < dl(SUC n). Level n+1 refines level n: N(n) | N(SUC n) + and old points are preserved at positions k * (N(SUC n) DIV N(n)). + The key fix vs the old dyadic approach: we use VARIABLE-length chains + (not single midpoints) so that consecutive distances actually decrease. + Proximity: every point at level n+1 is within ep(SUC n) of some + point at level n. This allows proving the distance-from-x bound. *) + SUBGOAL_THEN `?N h. + (h:num->num->A) 0 0 = x /\ h 0 (N 0) = y /\ + (!n. 1 <= N n) /\ + (!n. N n divides N(SUC n)) /\ + (!n. 2 * N n <= N(SUC n)) /\ + (!n k. k <= N n ==> h n k IN mspace m) /\ + (!n k. k < N n + ==> mdist m (h n k, h n (SUC k)) < (dl:num->real)(SUC n)) /\ + (!n k. k <= N n + ==> h (SUC n) (k * (N(SUC n) DIV N n)) = h n k) /\ + (!k. k <= N 0 ==> (h:num->num->A) 0 k IN C0) /\ + (!n k. k <= N(SUC n) + ==> mdist m ((h:num->num->A) n (k DIV (N(SUC n) DIV N n)), + h (SUC n) k) + < (ep:num->real)(SUC n))` + STRIP_ASSUME_TAC THENL [(* Step 5: C0 SUBSET mspace m *) + SUBGOAL_THEN `C0 SUBSET mspace (m:A metric)` ASSUME_TAC THENL + [REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY] THEN + MATCH_MP_TAC CONNECTED_IN_SUBSET_TOPSPACE THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Step 5b: One-step chain refinement property *) + SUBGOAL_THEN `!n (Nn:num) (hn:num->A). + 1 <= Nn /\ + hn 0 = x /\ hn Nn = y /\ + (!k. k <= Nn ==> hn k IN mspace m) /\ + (!k. k < Nn + ==> mdist m (hn k, hn(SUC k)) < (dl:num->real)(SUC n)) + ==> ?Nn' hn'. + Nn divides Nn' /\ 2 * Nn <= Nn' /\ 1 <= Nn' /\ + hn' 0 = x /\ hn' Nn' = y /\ + (!k. k <= Nn' ==> hn' k IN mspace m) /\ + (!k. k < Nn' + ==> mdist m (hn' k, hn'(SUC k)) < dl(SUC(SUC n))) /\ + (!k. k <= Nn ==> hn'(k * (Nn' DIV Nn)) = hn k) /\ + (!k. k <= Nn' + ==> mdist m (hn (k DIV (Nn' DIV Nn)), hn' k) + < (ep:num->real)(SUC n))` + ASSUME_TAC THENL [REPEAT GEN_TAC THEN STRIP_TAC THEN + (* 5b-A: For each segment k, get sub-chain via ULC + chain lemma *) + SUBGOAL_THEN `!k. k < Nn + ==> ?Mk fk. + 1 <= Mk /\ + (fk:num->A) 0 = hn k /\ fk Mk = hn(SUC k:num) /\ + (!j. j <= Mk ==> fk j IN mspace m) /\ + (!j. j < Mk + ==> mdist m (fk j, fk(SUC j)) + < (dl:num->real)(SUC(SUC n))) /\ + (!j. j <= Mk + ==> mdist m ((hn:num->A) k, fk j) + < (ep:num->real)(SUC n))` + ASSUME_TAC THENL [X_GEN_TAC `k:num` THEN DISCH_TAC THEN + (* hn k, hn(SUC k) IN mspace m *) + SUBGOAL_THEN `(hn:num->A) k IN mspace m /\ hn(SUC k) IN mspace m` + STRIP_ASSUME_TAC THENL + [CONJ_TAC THEN + UNDISCH_TAC `!k:num. k <= Nn ==> (hn:num->A) k IN mspace m` THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_ARITH_TAC; ALL_TAC] THEN + (* Get connected set c via ULC *) + SUBGOAL_THEN `?c. connected_in(mtopology m) (c:A->bool) /\ + (hn:num->A) k IN c /\ hn(SUC k) IN c /\ + mbounded m c /\ mdiameter m c < (ep:num->real)(SUC n)` + (X_CHOOSE_THEN `c:A->bool` STRIP_ASSUME_TAC) THENL [UNDISCH_TAC + `!eps. &0 < eps + ==> &0 < (del:real->real) eps /\ + (!x y:A. x IN mspace m /\ y IN mspace m /\ + mdist m (x,y) < del eps + ==> ?c. connected_in(mtopology m) c /\ + x IN c /\ y IN c /\ mbounded m c /\ + mdiameter m c < eps)` THEN + DISCH_THEN(MP_TAC o SPEC `(ep:num->real)(SUC n)`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPECL [`(hn:num->A) k`; `(hn:num->A)(SUC k)`])) THEN + ANTS_TAC THENL + [UNDISCH_TAC + `!n:num. (dl:num->real) n = (del:real->real)((ep:num->real) n)` THEN + DISCH_THEN(fun th -> REWRITE_TAC[SYM(SPEC `SUC n` th)]) THEN + ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[]; DISCH_THEN ACCEPT_TAC]; ALL_TAC] THEN + (* c SUBSET mspace m *) + SUBGOAL_THEN `(c:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY] THEN + MATCH_MP_TAC CONNECTED_IN_SUBSET_TOPSPACE THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Get chain in c via CONNECTED_IN_IMP_WELLCHAINED *) + MP_TAC(ISPECL [`m:A metric`; `c:A->bool`; + `(dl:num->real)(SUC(SUC n))`; + `(hn:num->A) k`; + `(hn:num->A)(SUC k)`] + CONNECTED_IN_IMP_WELLCHAINED) THEN + ANTS_TAC THENL + [REPEAT CONJ_TAC THEN TRY(FIRST_ASSUM ACCEPT_TAC) THEN + UNDISCH_TAC `!n. &0 < (dl:num->real) n` THEN + DISCH_THEN(ACCEPT_TAC o SPEC `SUC(SUC n)`); ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `fk0:num->A` + (X_CHOOSE_THEN `Nk:num` STRIP_ASSUME_TAC)) THEN + ASM_CASES_TAC `Nk = 0` THENL + [(* Nk = 0: hn k = hn(SUC k), use constant chain of length 1 *) + SUBGOAL_THEN `(hn:num->A)(SUC k) = hn k` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + MAP_EVERY EXISTS_TAC [`1`; `\j:num. (hn:num->A) k`] THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + REPEAT CONJ_TAC THENL [ARITH_TAC; REFL_TAC; ASM_MESON_TAC[]; GEN_TAC THEN + DISCH_TAC THEN + UNDISCH_TAC `(hn:num->A) k IN mspace m` THEN SIMP_TAC[]; GEN_TAC THEN + DISCH_TAC THEN + SUBGOAL_THEN `mdist m ((hn:num->A) k, hn k) = &0` SUBST1_TAC THENL + [MATCH_MP_TAC MDIST_REFL THEN + UNDISCH_TAC `(hn:num->A) k IN mspace m` THEN SIMP_TAC[]; ALL_TAC] THEN + UNDISCH_TAC `!n. &0 < (dl:num->real) n` THEN + DISCH_THEN(ACCEPT_TAC o SPEC `SUC(SUC n)`); GEN_TAC THEN DISCH_TAC THEN + SUBGOAL_THEN `mdist m ((hn:num->A) k, hn k) = &0` SUBST1_TAC THENL + [MATCH_MP_TAC MDIST_REFL THEN + UNDISCH_TAC `(hn:num->A) k IN mspace m` THEN SIMP_TAC[]; ALL_TAC] THEN + UNDISCH_TAC `!n. &0 < (ep:num->real) n` THEN + DISCH_THEN(ACCEPT_TAC o SPEC `SUC n`)]; + (* Nk > 0: use fk0 chain directly *) + MAP_EVERY EXISTS_TAC [`Nk:num`; `fk0:num->A`] THEN + REPEAT CONJ_TAC THENL [ASM_ARITH_TAC; + ASM_REWRITE_TAC[]; ASM_REWRITE_TAC[]; GEN_TAC THEN DISCH_TAC THEN + UNDISCH_TAC `(c:A->bool) SUBSET mspace m` THEN + REWRITE_TAC[SUBSET] THEN DISCH_THEN MATCH_MP_TAC THEN + ASM_MESON_TAC[]; ASM_MESON_TAC[]; + GEN_TAC THEN DISCH_TAC THEN MATCH_MP_TAC REAL_LET_TRANS THEN + EXISTS_TAC `mdiameter m (c:A->bool)` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN + ASM_MESON_TAC[]]]; ALL_TAC] THEN + (* 5b-B: Skolemize to get Mk and fk functions *) + FIRST_X_ASSUM(MP_TAC o + REWRITE_RULE[RIGHT_IMP_EXISTS_THM; SKOLEM_THM]) THEN + DISCH_THEN(X_CHOOSE_THEN `Mk:num->num` + (X_CHOOSE_THEN `fk:num->num->A` STRIP_ASSUME_TAC)) THEN + (* 5b-C: Choose M >= max(Mk(k)) and M >= 2 *) + SUBGOAL_THEN `?M. 2 <= M /\ (!k. k < Nn ==> (Mk:num->num) k <= M)` + (X_CHOOSE_THEN `M:num` STRIP_ASSUME_TAC) THENL + [MP_TAC(ISPECL [`Mk:num->num`; `Nn:num`] FINITE_BOUND_NUM) THEN + DISCH_THEN(X_CHOOSE_TAC `M0:num`) THEN EXISTS_TAC `M0 + 2` THEN + CONJ_TAC THENL [ARITH_TAC; ALL_TAC] THEN GEN_TAC THEN DISCH_TAC THEN + UNDISCH_TAC `!k:num. k < Nn ==> (Mk:num->num) k <= M0` THEN + DISCH_THEN(MP_TAC o SPEC `k:num`) THEN ASM_REWRITE_TAC[] THEN + ARITH_TAC; ALL_TAC] THEN + (* 5b-D: Define Nn' = Nn * M and hn' by concatenating padded sub-chains *) + ABBREV_TAC `hn' = \j:num. + if j DIV M < Nn + then (fk:num->num->A) (j DIV M) (MIN (j MOD M) ((Mk:num->num) (j DIV M))) + else y:A` THEN EXISTS_TAC `(Nn:num) * + M` THEN EXISTS_TAC `hn':num->A` THEN + (* Useful facts about M *) + SUBGOAL_THEN `~(M = 0)` ASSUME_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `1 <= M` ASSUME_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(Nn * M) DIV M = Nn` ASSUME_TAC THENL + [ONCE_REWRITE_TAC[MULT_SYM] THEN ASM_SIMP_TAC[DIV_MULT]; ALL_TAC] THEN + SUBGOAL_THEN `(Nn * M) MOD M = 0` ASSUME_TAC THENL + [ONCE_REWRITE_TAC[MULT_SYM] THEN ASM_SIMP_TAC[MOD_MULT]; ALL_TAC] THEN + SUBGOAL_THEN `~(Nn = 0)` ASSUME_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(Nn * M) DIV Nn = M` ASSUME_TAC THENL + [ASM_SIMP_TAC[DIV_MULT]; ALL_TAC] THEN + REPEAT CONJ_TAC THENL + [(* Nn divides Nn * M *) + REWRITE_TAC[num_divides] THEN REWRITE_TAC[int_divides] THEN + EXISTS_TAC `&M:int` THEN REWRITE_TAC[INT_OF_NUM_MUL]; + (* 2 * Nn <= Nn * M *) + SUBGOAL_THEN `Nn * 2 <= Nn * M` MP_TAC THENL + [REWRITE_TAC[LE_MULT_LCANCEL] THEN DISJ2_TAC THEN + ASM_ARITH_TAC; ARITH_TAC]; + (* 1 <= Nn * M *) + ONCE_REWRITE_TAC[ARITH_RULE `1 = 1 * 1`] THEN MATCH_MP_TAC LE_MULT2 THEN + ASM_ARITH_TAC; + (* hn' 0 = x *) + EXPAND_TAC "hn'" THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + REWRITE_TAC[DIV_0; MOD_0] THEN + SUBGOAL_THEN `0 < Nn` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_ARITH_TAC; ALL_TAC] THEN REWRITE_TAC[ARITH_RULE `MIN 0 n = 0`] THEN + SUBGOAL_THEN `(fk:num->num->A) 0 0 = (hn:num->A) 0` SUBST1_TAC THENL + [SUBGOAL_THEN `0 < Nn` ASSUME_TAC THENL [ASM_ARITH_TAC; ASM_MESON_TAC[]]; + ASM_REWRITE_TAC[]]; + (* hn'(Nn * M) = y *) + EXPAND_TAC "hn'" THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + ASM_REWRITE_TAC[LT_REFL]; + (* !k. k <= Nn*M ==> hn' k IN mspace m *) + X_GEN_TAC `kk:num` THEN DISCH_TAC THEN + EXPAND_TAC "hn'" THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + COND_CASES_TAC THENL + [SUBGOAL_THEN `MIN (kk MOD M) ((Mk:num->num) (kk DIV M)) + <= Mk(kk DIV M)` MP_TAC THENL [ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `kk DIV M < Nn` MP_TAC THENL + [ASM_ARITH_TAC; ALL_TAC] THEN ASM_MESON_TAC[]; + UNDISCH_TAC `(y:A) IN mspace m` THEN SIMP_TAC[]]; + (* !k. k < Nn*M ==> mdist m (hn' k, hn'(SUC k)) < dl(SUC(SUC n)) *) + X_GEN_TAC `kk:num` THEN DISCH_TAC THEN + (* kk DIV M < Nn *) + SUBGOAL_THEN `kk DIV M < Nn` ASSUME_TAC THENL [ASM_SIMP_TAC[RDIV_LT_EQ] + THEN + ONCE_REWRITE_TAC[MULT_SYM] THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* kk MOD M < M *) + SUBGOAL_THEN `kk MOD M < M` ASSUME_TAC THENL + [MP_TAC(SPECL [`kk:num`; `M:num`] DIVISION) THEN + ASM_MESON_TAC[]; ALL_TAC] THEN + (* Case: interior vs boundary *) + ASM_CASES_TAC `SUC(kk MOD M) < M` THENL [(* Interior: SUC kk stays in + same block *) + SUBGOAL_THEN `(hn':num->A) kk = + (fk:num->num->A)(kk DIV M) + (MIN (kk MOD M) ((Mk:num->num)(kk DIV M)))` + SUBST1_TAC THENL [EXPAND_TAC "hn'" THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + COND_CASES_TAC THENL [REFL_TAC; ASM_MESON_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `(hn':num->A)(SUC kk) = + (fk:num->num->A)(kk DIV M) + (MIN (SUC(kk MOD M)) ((Mk:num->num)(kk DIV M)))` + SUBST1_TAC THENL [EXPAND_TAC "hn'" THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + SUBGOAL_THEN `(SUC kk) DIV M = kk DIV M /\ + (SUC kk) MOD M = SUC(kk MOD M)` + (fun th -> REWRITE_TAC[CONJUNCT1 th; CONJUNCT2 th]) THENL + [MATCH_MP_TAC DIVMOD_UNIQ THEN CONJ_TAC THENL + [MP_TAC(SPECL [`kk:num`; `M:num`] (CONJUNCT1 DIVISION_SIMP)) THEN + ARITH_TAC; + ASM_ARITH_TAC]; ALL_TAC] THEN + COND_CASES_TAC THENL [REFL_TAC; ASM_MESON_TAC[]]; ALL_TAC] THEN + ASM_CASES_TAC `kk MOD M < (Mk:num->num)(kk DIV M)` THENL + [(* Unclamped: consecutive in sub-chain *) + SUBGOAL_THEN `MIN (kk MOD M) ((Mk:num->num)(kk DIV M)) = kk MOD M` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN + `MIN (SUC(kk MOD M)) ((Mk:num->num)(kk DIV M)) = SUC(kk MOD M)` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + ASM_MESON_TAC[]; + (* Clamped: both map to Mk q, distance 0 *) + SUBGOAL_THEN `MIN (kk MOD M) ((Mk:num->num)(kk DIV M)) = Mk(kk DIV M)` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN + `MIN (SUC(kk MOD M)) ((Mk:num->num)(kk DIV M)) = Mk(kk DIV M)` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + mdist_fk_self_zero_tac]; + (* Boundary: SUC kk crosses to next block *) + SUBGOAL_THEN `kk MOD M = M - 1` ASSUME_TAC THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(hn':num->A) kk = + (fk:num->num->A)(kk DIV M) + (MIN (M - 1) ((Mk:num->num)(kk DIV M)))` + SUBST1_TAC THENL [EXPAND_TAC "hn'" THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + SUBGOAL_THEN `kk MOD M = M - 1` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + COND_CASES_TAC THENL [REFL_TAC; ASM_MESON_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `(hn':num->A)(SUC kk) = (hn:num->A)(SUC(kk DIV M))` + SUBST1_TAC THENL [EXPAND_TAC "hn'" THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + SUBGOAL_THEN `(SUC kk) DIV M = SUC(kk DIV M) /\ (SUC kk) MOD M = 0` + (fun th -> REWRITE_TAC[CONJUNCT1 th; CONJUNCT2 th]) THENL + [MATCH_MP_TAC DIVMOD_UNIQ THEN CONJ_TAC THENL + [REWRITE_TAC[ADD_CLAUSES; MULT_CLAUSES] THEN + MP_TAC(SPECL [`kk:num`; `M:num`] + (CONJUNCT1 DIVISION_SIMP)) THEN UNDISCH_TAC `kk MOD M = M - 1` THEN + UNDISCH_TAC `2 <= M` THEN SPEC_TAC(`kk DIV M * M`, `qm:num`) THEN + ARITH_TAC; + ASM_ARITH_TAC]; ALL_TAC] THEN + REWRITE_TAC[ARITH_RULE `MIN 0 n = 0`] THEN + COND_CASES_TAC THENL [ASM_MESON_TAC[]; + SUBGOAL_THEN `SUC(kk DIV M) = Nn` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + ASM_MESON_TAC[]]; ALL_TAC] THEN + (* Replace hn(SUC q) by fk q (Mk q) *) + SUBGOAL_THEN `(hn:num->A)(SUC(kk DIV M)) = + (fk:num->num->A)(kk DIV M)((Mk:num->num)(kk DIV M))` + SUBST1_TAC THENL [CONV_TAC SYM_CONV THEN ASM_MESON_TAC[]; ALL_TAC] THEN + ASM_CASES_TAC `(Mk:num->num)(kk DIV M) <= M - 1` THENL + [(* MIN(M-1)(Mk q) = Mk q: distance 0 *) + SUBGOAL_THEN `MIN (M - 1) ((Mk:num->num)(kk DIV M)) = Mk(kk DIV M)` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + mdist_fk_self_zero_tac; + (* Mk q = M: chain step from M-1 to SUC(M-1) *) + SUBGOAL_THEN `(Mk:num->num)(kk DIV M) = M` ASSUME_TAC THENL + [SUBGOAL_THEN `(Mk:num->num)(kk DIV M) <= M` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] + THEN + UNDISCH_TAC `~((Mk:num->num)(kk DIV M) <= M - 1)` THEN + ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `MIN (M - 1) ((Mk:num->num)(kk DIV M)) = M - 1` + (fun th -> REWRITE_TAC[th]) THENL + [UNDISCH_TAC `(Mk:num->num)(kk DIV M) = M` THEN + UNDISCH_TAC `1 <= M` THEN ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(Mk:num->num)(kk DIV M) = SUC(M - 1)` + (fun th -> REWRITE_TAC[th]) THENL + [UNDISCH_TAC `(Mk:num->num)(kk DIV M) = M` THEN + UNDISCH_TAC `1 <= M` THEN ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `M - 1 < (Mk:num->num)(kk DIV M)` MP_TAC THENL + [UNDISCH_TAC `(Mk:num->num)(kk DIV M) = M` THEN + UNDISCH_TAC `1 <= M` THEN ARITH_TAC; ALL_TAC] THEN ASM_MESON_TAC[]]]; + (* !k. k <= Nn ==> hn'(k * (Nn*M DIV Nn)) = hn k *) + SUBGOAL_THEN `(Nn * M) DIV Nn = M` + (fun th -> ONCE_REWRITE_TAC[th]) THENL + [MATCH_MP_TAC DIV_MULT THEN ASM_ARITH_TAC; ALL_TAC] THEN + X_GEN_TAC `kk:num` THEN DISCH_TAC THEN + EXPAND_TAC "hn'" THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + SUBGOAL_THEN `(kk * M) DIV M = kk /\ (kk * M) MOD M = 0` + (fun th -> REWRITE_TAC[CONJUNCT1 th; CONJUNCT2 th]) THENL + [CONJ_TAC THENL [ONCE_REWRITE_TAC[MULT_SYM] THEN + MATCH_MP_TAC DIV_MULT THEN ASM_ARITH_TAC; + ONCE_REWRITE_TAC[MULT_SYM] THEN REWRITE_TAC[MOD_MULT]]; ALL_TAC] THEN + ASM_CASES_TAC `kk < Nn:num` THENL + [ASM_REWRITE_TAC[ARITH_RULE `MIN 0 n = 0`] THEN ASM_MESON_TAC[]; + SUBGOAL_THEN `kk = Nn:num` SUBST_ALL_TAC THENL + [ASM_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[LT_REFL] THEN + ASM_MESON_TAC[]]; + (* !k. k <= Nn*M ==> mdist m (hn(k DIV M), hn' k) < ep(SUC n) *) + X_GEN_TAC `kk:num` THEN DISCH_TAC THEN + (* Only rewrite (Nn * M) DIV Nn to M; avoid expanding ep *) + SUBGOAL_THEN `(Nn * M) DIV Nn = M` + (fun th -> REWRITE_TAC[th]) THENL + [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + EXPAND_TAC "hn'" THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + COND_CASES_TAC THENL + [SUBGOAL_THEN `MIN (kk MOD M) ((Mk:num->num) (kk DIV M)) <= Mk(kk DIV M)` + MP_TAC THENL [ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `kk DIV M < Nn` MP_TAC THENL + [ASM_ARITH_TAC; ALL_TAC] THEN ASM_MESON_TAC[]; + (* kk DIV M >= Nn, so kk DIV M = Nn, hn(Nn) = y *) + SUBGOAL_THEN `kk DIV M = Nn` ASSUME_TAC THENL [SUBGOAL_THEN + `kk DIV M <= Nn` MP_TAC THENL + [MATCH_MP_TAC LE_LDIV THEN CONJ_TAC THENL [ASM_REWRITE_TAC[]; + ONCE_REWRITE_TAC[MULT_SYM] THEN ASM_REWRITE_TAC[]]; + UNDISCH_TAC `~(kk DIV M < Nn:num)` THEN ARITH_TAC]; ALL_TAC] THEN + (* Only rewrite kk DIV M to Nn; avoid expanding ep or hn Nn *) + FIRST_ASSUM(fun th -> REWRITE_TAC[th]) THEN + SUBGOAL_THEN `mdist m ((hn:num->A) Nn, (y:A)) = &0` + (fun th -> REWRITE_TAC[th]) THENL + [SUBGOAL_THEN `(y:A) = (hn:num->A) Nn` SUBST1_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN MATCH_MP_TAC MDIST_REFL THEN + SUBGOAL_THEN `Nn <= Nn` MP_TAC THENL + [ARITH_TAC; ALL_TAC] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + UNDISCH_TAC `!n. &0 < (ep:num->real) n` THEN + DISCH_THEN(ACCEPT_TAC o SPEC `SUC n`)]]; ALL_TAC] THEN + (* Step 5c: Skolemize the step function *) + FIRST_X_ASSUM(MP_TAC o + REWRITE_RULE[RIGHT_IMP_EXISTS_THM; SKOLEM_THM]) THEN + REWRITE_TAC[FORALL_AND_THM] THEN STRIP_TAC THEN + (* Step 5d: Get base chain via CONNECTED_IN_IMP_WELLCHAINED *) + MP_TAC(ISPECL [`m:A metric`; `C0:A->bool`; + `(dl:num->real) 1`; `x:A`; `y:A`] + CONNECTED_IN_IMP_WELLCHAINED) THEN + ANTS_TAC THENL + [REPEAT CONJ_TAC THEN TRY(FIRST_ASSUM ACCEPT_TAC) THEN + UNDISCH_TAC `!n. &0 < (dl:num->real) n` THEN + DISCH_THEN(ACCEPT_TAC o SPEC `1`); ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `g0:num->A` + (X_CHOOSE_THEN `N0:num` STRIP_ASSUME_TAC)) THEN + (* Step 5e: Ensure 1 <= N0 by padding if N0 = 0 *) + SUBGOAL_THEN `?N0' g0'. 1 <= N0' /\ + (g0':num->A) 0 = x /\ g0' N0' = y /\ + (!k. k <= N0' ==> g0' k IN mspace m) /\ + (!k. k < N0' + ==> mdist m (g0' k, g0'(SUC k)) + < (dl:num->real) 1) /\ + (!k. k <= N0' ==> g0' k IN C0)` + STRIP_ASSUME_TAC THENL [ASM_CASES_TAC `N0 = 0` THENL + [(* N0 = 0: x = y since g0(0) = x and g0(0) = g0(N0) = y *) + EXISTS_TAC `1` THEN EXISTS_TAC `\k:num. (x:A)` THEN + REWRITE_TAC[ARITH_RULE `1 <= 1`] THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + SUBGOAL_THEN `(x:A) = y` ASSUME_TAC THENL + [UNDISCH_TAC `(g0:num->A) N0 = y` THEN UNDISCH_TAC `N0 = 0` THEN + DISCH_THEN SUBST1_TAC THEN + UNDISCH_TAC `(g0:num->A) 0 = x` THEN DISCH_THEN(SUBST1_TAC o SYM) THEN + DISCH_THEN ACCEPT_TAC; ALL_TAC] THEN UNDISCH_TAC `(x:A) = y` THEN + DISCH_THEN(fun th -> REWRITE_TAC[SYM th]) THEN + SUBGOAL_THEN `mdist m (x:A, x) = &0` + (fun th -> REWRITE_TAC[th]) THENL + [MATCH_MP_TAC MDIST_REFL THEN FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + REPEAT CONJ_TAC THENL + [REPEAT STRIP_TAC THEN FIRST_ASSUM ACCEPT_TAC; + REPEAT STRIP_TAC THEN UNDISCH_TAC `!n. &0 < (dl:num->real) n` THEN + DISCH_THEN(MP_TAC o SPEC `1`) THEN REAL_ARITH_TAC; + REPEAT STRIP_TAC THEN FIRST_ASSUM ACCEPT_TAC]; + (* N0 > 0: use g0 directly *) + EXISTS_TAC `N0:num` THEN EXISTS_TAC `g0:num->A` THEN + ASM_REWRITE_TAC[ARITH_RULE `1 <= n <=> ~(n = 0)`] THEN + (* After ASM_REWRITE_TAC: C0 membership and chain distance resolved, + only g0 k IN mspace m remains *) + REPEAT STRIP_TAC THEN UNDISCH_TAC `C0 SUBSET mspace (m:A metric)` THEN + REWRITE_TAC[SUBSET] THEN DISCH_THEN MATCH_MP_TAC THEN + UNDISCH_TAC `!i:num. i <= N0 ==> (g0:num->A) i IN C0` THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_ARITH_TAC]; ALL_TAC] THEN + (* Step 5f: Build the recursion on pairs (N(n), h(n)) *) + MP_TAC(ISPECL [`(N0', g0'):num#(num->A)`; + `\(p:num#(num->A)) (n:num). + ((Nn':num->num->(num->A)->num) n (FST p) (SND p), + (hn':num->num->(num->A)->num->A) n (FST p) (SND p))`] + num_RECURSION) THEN REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `fn:num->num#(num->A)` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `\n:num. FST((fn:num->num#(num->A)) n)` THEN + EXISTS_TAC `\n:num. SND((fn:num->num#(num->A)) n)` THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + (* Prove clean SUC equations for FST/SND of fn *) + SUBGOAL_THEN `!n. FST((fn:num->num#(num->A))(SUC n)) = + (Nn':num->num->(num->A)->num) n (FST(fn n)) (SND(fn n)) /\ + SND((fn:num->num#(num->A))(SUC n)) = + (hn':num->num->(num->A)->num->A) n (FST(fn n)) (SND(fn n))` + ASSUME_TAC THENL [GEN_TAC THEN ASM_REWRITE_TAC[] THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN REWRITE_TAC[FST; SND]; ALL_TAC] THEN + (* Prove the invariant by induction: conditions hold at each level *) + SUBGOAL_THEN `!n. 1 <= FST((fn:num->num#(num->A)) n) /\ + SND(fn n) 0 = (x:A) /\ + SND(fn n) (FST(fn n)) = y /\ + (!k. k <= FST(fn n) ==> SND(fn n) k IN mspace m) /\ + (!k. k < FST(fn n) + ==> mdist m (SND(fn n) k, SND(fn n) (SUC k)) + < (dl:num->real) (SUC n))` + MP_TAC THENL [INDUCT_TAC THENL + [(* Base case: fn 0 = (N0', + g0') *) REWRITE_TAC[ARITH_RULE `SUC 0 = 1`] THEN + SUBGOAL_THEN + `FST((fn:num->num#(num->A)) 0) = N0' /\ + SND((fn:num->num#(num->A)) 0) = g0'` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_REWRITE_TAC[FST; SND]; ALL_TAC] THEN + REPEAT CONJ_TAC THEN FIRST_ASSUM ACCEPT_TAC; + (* Inductive step: use SUC equation + refinement *) + FIRST_ASSUM(fun suceq -> + REWRITE_TAC[CONJUNCT1(SPEC `n:num` suceq); + CONJUNCT2(SPEC `n:num` suceq)]) THEN + FIRST_ASSUM(MP_TAC o SPECL + [`n:num`; `FST((fn:num->num#(num->A)) n)`; + `SND((fn:num->num#(num->A)) n)`]) THEN + ANTS_TAC THENL [FIRST_X_ASSUM ACCEPT_TAC; ALL_TAC] THEN STRIP_TAC THEN + REPEAT CONJ_TAC THEN FIRST_ASSUM ACCEPT_TAC]; ALL_TAC] THEN + (* Split invariant into individual assumptions *) + REWRITE_TAC[FORALL_AND_THM] THEN STRIP_TAC THEN + (* Prove step properties: divisibility, doubling, embedding, proximity *) + SUBGOAL_THEN `!n. FST((fn:num->num#(num->A)) n) divides FST(fn(SUC n)) /\ + 2 * FST(fn n) <= FST(fn(SUC n)) /\ + (!k. k <= FST(fn n) + ==> SND(fn(SUC n)) + (k * FST(fn(SUC n)) DIV FST(fn n)) = + SND(fn n) k) /\ + (!k. k <= FST(fn(SUC n)) + ==> mdist m (SND((fn:num->num#(num->A)) n) + (k DIV (FST(fn(SUC n)) DIV FST(fn n))), + SND(fn(SUC n)) k) < ep(SUC + n))` MP_TAC THENL [X_GEN_TAC `nn:num` THEN + (* Inline SUC equation to rewrite fn(SUC nn) *) + SUBGOAL_THEN + `FST((fn:num->num#(num->A))(SUC nn)) = + (Nn':num->num->(num->A)->num) + nn (FST(fn nn)) (SND(fn nn)) /\ + SND((fn:num->num#(num->A))(SUC nn)) = + (hn':num->num->(num->A)->num->A) + nn (FST(fn nn)) (SND(fn nn))` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_REWRITE_TAC[] THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + REWRITE_TAC[FST; SND]; ALL_TAC] THEN + (* Apply refinement *) + FIRST_ASSUM(MP_TAC o SPECL + [`nn:num`; `FST((fn:num->num#(num->A)) nn)`; + `SND((fn:num->num#(num->A)) nn)`]) THEN + ANTS_TAC THENL [REPLICATE_TAC 4 + (CONJ_TAC THENL [FIRST_ASSUM(ACCEPT_TAC o SPEC `nn:num`); ALL_TAC]) THEN + GEN_TAC THEN DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o SPECL [`nn:num`; `k:num`]) THEN + ANTS_TAC THENL [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + DISCH_THEN ACCEPT_TAC; ALL_TAC] THEN STRIP_TAC THEN + REPEAT CONJ_TAC THEN FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + (* Split step properties into individual assumptions *) + REWRITE_TAC[FORALL_AND_THM] THEN STRIP_TAC THEN + (* Rewrite base: FST(fn 0) = N0', SND(fn 0) = g0' *) + SUBGOAL_THEN + `FST((fn:num->num#(num->A)) 0) = N0' /\ + SND((fn:num->num#(num->A)) 0) = g0'` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_REWRITE_TAC[FST; SND]; ALL_TAC] THEN + (* 10 conjuncts: each matches a split assumption exactly *) + REPEAT CONJ_TAC THEN TRY(FIRST_ASSUM ACCEPT_TAC) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Step 5g: Prove distance-from-x bound for all chain points. + By induction: h(0,k) IN C0 so within diam(C0) < e/8 of x. + By proximity, h(n+1,k) is within ep(SUC n) of some h(n,k0). + Total: mdist(x, h(n,k)) <= e/8 + sum_{j=1}^{n} ep(j) + <= e/8 + (e/8)*(1/3) = e/6 <= e/4. *) + SUBGOAL_THEN + `!n k. k <= N n ==> mdist m (x:A, (h:num->num->A) n k) <= e / &4` + ASSUME_TAC THENL [(* Use induction with decreasing headroom. + Prove intermediate: mdist(x, h n k) <= e/4 - e/12 * inv(4^n) + which is <= e/4 for all n. *) + SUBGOAL_THEN `!n k. k <= N n + ==> mdist m (x:A, (h:num->num->A) n k) + <= e / &4 - e / &12 * inv(&4 pow n)` ASSUME_TAC THENL [ALL_TAC; + (* Derive <= e/4 from the tight bound *) + REPEAT STRIP_TAC THEN MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `e / &4 - e / &12 * inv(&4 pow n)` THEN CONJ_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + MATCH_MP_TAC(REAL_ARITH `&0 <= b ==> a - b <= a`) THEN + MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC THENL [ASM_REAL_ARITH_TAC; + MATCH_MP_TAC REAL_LE_INV THEN MATCH_MP_TAC REAL_POW_LE THEN + REAL_ARITH_TAC]]] THEN + INDUCT_TAC THENL [(* Base case: n = 0. Need mdist(x, + h 0 k) <= e/4 - e/12 = e/6 *) + REWRITE_TAC[real_pow; REAL_INV_1; REAL_MUL_RID] THEN X_GEN_TAC `k:num` THEN + DISCH_TAC THEN + (* mdist(x, h 0 k) <= mdiameter m C0 < e/8 <= e/6 *) + MATCH_MP_TAC REAL_LE_TRANS THEN EXISTS_TAC `mdiameter m (C0:A->bool)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN + REPLICATE_TAC 2 (CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; ALL_TAC]) THEN + FIRST_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC REAL_LT_IMP_LE THEN MATCH_MP_TAC REAL_LT_TRANS THEN + EXISTS_TAC `e / &8` THEN ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC; + (* Inductive step: n -> SUC n *) + X_GEN_TAC `k:num` THEN DISCH_TAC THEN + (* Get proximity bound for specific witness *) + ABBREV_TAC `k0 = k DIV (N(SUC n) DIV (N:num->num) n)` THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`n:num`; `k:num`]) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + (* Prove k0 <= N n *) + SUBGOAL_THEN `k0 <= (N:num->num) n` ASSUME_TAC THENL + [EXPAND_TAC "k0" THEN le_ldiv_Nn_tac; ALL_TAC] THEN + (* Triangle inequality *) + MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC + `mdist m (x:A, (h:num->num->A) n k0) + mdist m (h n k0, h (SUC n) k)` + THEN + CONJ_TAC THENL [MATCH_MP_TAC MDIST_TRIANGLE THEN ASM_REWRITE_TAC[] THEN + REPEAT CONJ_TAC THEN TRY(FIRST_ASSUM MATCH_MP_TAC) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Bound each term *) + MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `(e / &4 - e / &12 * inv(&4 pow n)) + e / &8 / &4 pow (SUC n)` + THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_LE_ADD2 THEN CONJ_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `(ep:num->real)(SUC n)` THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_LT_IMP_LE THEN + ASM_REWRITE_TAC[]; ASM_REWRITE_TAC[]]]; ALL_TAC] THEN + (* Key arithmetic: simplify 4^(SUC n) = 4 * 4^n *) + SUBGOAL_THEN `&4 pow (SUC n) = &4 * &4 pow n` SUBST1_TAC THENL + [REWRITE_TAC[real_pow]; ALL_TAC] THEN + SUBGOAL_THEN `&0 < &4 pow n` ASSUME_TAC THENL + [MATCH_MP_TAC REAL_POW_LT THEN REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `&0 < &4 * &4 pow n` ASSUME_TAC THENL + [MATCH_MP_TAC REAL_LT_MUL THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + (* Unfold nested division e/8/(4*4^n) to expose inv for substitution *) + SUBGOAL_THEN `e / &8 / (&4 * &4 pow n) = (e / &8) * inv(&4 * &4 pow n)` + SUBST1_TAC THENL [REWRITE_TAC[real_div]; ALL_TAC] THEN + (* Convert inv(4 * 4^n) = inv(4) * inv(4^n) *) + SUBGOAL_THEN `inv(&4 * &4 pow n) = inv(&4) * inv(&4 pow n)` + SUBST1_TAC THENL [REWRITE_TAC[REAL_INV_MUL]; ALL_TAC] THEN + (* Abbreviate p = inv(4^n) *) + ABBREV_TAC `p = inv(&4 pow n)` THEN SUBGOAL_THEN `&0 < p` ASSUME_TAC THENL + [EXPAND_TAC "p" THEN MATCH_MP_TAC REAL_LT_INV THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Now goal is linear in e and p with inv(&4) = 1/4 *) + SUBGOAL_THEN `inv(&4) = &1 / &4` SUBST1_TAC THENL + [CONV_TAC REAL_RAT_REDUCE_CONV; ALL_TAC] THEN + (* ASM_REAL_ARITH_TAC fails on bilinear terms e*p. + Strategy: MP_TAC the key facts and use REAL_ARITH_TAC (non-ASM) + which treats bilinear products as opaque atoms. *) + SUBGOAL_THEN `&0 < e * p / &32` MP_TAC THENL [SUBGOAL_THEN `&0 < e * p` + (fun th -> MP_TAC th THEN REAL_ARITH_TAC) THEN + MATCH_MP_TAC REAL_LT_MUL THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(e / &4 - e / &12 * (&1 / &4 * p)) - + ((e / &4 - e / &12 * p) + (e / &8) * (&1 / &4 * p)) = + e * p / &32` + MP_TAC THENL [CONV_TAC REAL_FIELD; ALL_TAC] THEN + REAL_ARITH_TAC]; ALL_TAC] THEN + (* Step 6: Define s = {k / N(n) | n,k} and f(k/N(n)) = h n k. *) + (* 6a: N n is never 0 *) + SUBGOAL_THEN `!n. ~((N:num->num) n = 0)` ASSUME_TAC THENL [GEN_TAC THEN + MATCH_MP_TAC(ARITH_RULE `1 <= n ==> ~(n = 0)`) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* 6b: h n 0 = x for all n *) + SUBGOAL_THEN `!n. (h:num->num->A) n 0 = x` ASSUME_TAC THENL [INDUCT_TAC + THENL [ASM_REWRITE_TAC[]; + SUBGOAL_THEN `(h:num->num->A) (SUC n) (0 * N(SUC n) DIV N n) = h n 0` + MP_TAC THENL [FIRST_ASSUM(MATCH_MP_TAC o SPECL [`n:num`; `0`]) THEN + REWRITE_TAC[LE_0]; + REWRITE_TAC[MULT_CLAUSES; DIV_0] THEN ASM_REWRITE_TAC[]]]; ALL_TAC] THEN + (* 6c: h n (N n) = y for all n *) + SUBGOAL_THEN `!n. (h:num->num->A) n (N n) = y` ASSUME_TAC THENL + [INDUCT_TAC THENL [ASM_REWRITE_TAC[]; + SUBGOAL_THEN `(N:num->num)(SUC n) = N n * (N(SUC n) DIV N n)` + SUBST1_TAC THENL [ASM_MESON_TAC[DIVIDES_DIV_MULT; MULT_SYM]; + ALL_TAC] THEN + SUBGOAL_THEN + `(h:num->num->A) (SUC n) (N n * (N(SUC n) DIV N n)) = h n (N n)` + MP_TAC THENL + [FIRST_ASSUM(MATCH_MP_TAC o SPECL [`n:num`; `(N:num->num) n`]) THEN + REWRITE_TAC[LE_REFL]; + ASM_REWRITE_TAC[]]]; ALL_TAC] THEN + (* 6d: transitive divisibility *) + SUBGOAL_THEN `!n1 n2. n1 <= n2 ==> (N:num->num) n1 divides N n2` + (LABEL_TAC "6d") THENL [GEN_TAC THEN INDUCT_TAC THENL + [REWRITE_TAC[LE] THEN DISCH_THEN SUBST1_TAC THEN CONV_TAC NUMBER_RULE; + REWRITE_TAC[LE] THEN STRIP_TAC THENL [ASM_REWRITE_TAC[] THEN + CONV_TAC NUMBER_RULE; + SUBGOAL_THEN `(N:num->num) n1 divides N n2` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(N:num->num) n2 divides N(SUC n2)` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[NUMBER_RULE + `a divides b /\ b divides c ==> a divides c`]]]; ALL_TAC] THEN + (* Helper: DIV distributes over mult when divisible *) + SUBGOAL_THEN `!a b k:num. ~(a = 0) /\ a divides b + ==> (k * b) DIV a = k * (b DIV a)` + (LABEL_TAC "DIV_DISTRIB") THENL + [REPEAT STRIP_TAC THEN MATCH_MP_TAC DIV_UNIQ THEN EXISTS_TAC `0` THEN + REWRITE_TAC[ADD_CLAUSES] THEN CONJ_TAC THENL + [ONCE_REWRITE_TAC[GSYM MULT_ASSOC] THEN AP_TERM_TAC THEN + ASM_MESON_TAC[DIVIDES_DIV_MULT]; + ASM_ARITH_TAC]; ALL_TAC] THEN + (* 6e: iterated embedding *) + SUBGOAL_THEN `!n1 n2 k:num. n1 <= n2 /\ k <= (N:num->num) n1 + ==> (h:num->num->A) n2 (k * N n2 DIV N n1) = h n1 k` + ASSUME_TAC THENL [GEN_TAC THEN + INDUCT_TAC THENL [(* Base: n2 = 0, so n1 = 0 *) + REWRITE_TAC[LE] THEN X_GEN_TAC `k:num` THEN STRIP_TAC THEN + ASM_REWRITE_TAC[] THEN + ASM_SIMP_TAC[DIV_REFL] THEN REWRITE_TAC[MULT_CLAUSES]; + (* Step: n2 = SUC n2 *) + REWRITE_TAC[LE] THEN X_GEN_TAC `k:num` THEN + STRIP_TAC THENL [(* n1 = SUC n2 *) + ASM_REWRITE_TAC[] THEN ASM_SIMP_TAC[DIV_REFL] THEN + REWRITE_TAC[MULT_CLAUSES]; + (* n1 <= n2: the main inductive case *) + SUBGOAL_THEN `(N:num->num) n1 divides N n2` ASSUME_TAC THENL + [USE_THEN "6d" (fun th -> MATCH_MP_TAC th) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(N:num->num) n2 divides N(SUC n2)` ASSUME_TAC THENL + [USE_THEN "6d" (fun th -> MATCH_MP_TAC th) THEN ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(N:num->num) n1 divides N(SUC n2)` ASSUME_TAC THENL + [USE_THEN "6d" (fun th -> MATCH_MP_TAC th) THEN + UNDISCH_TAC `n1:num <= n2` THEN ARITH_TAC; ALL_TAC] THEN + (* Decompose: N(SUC n2)/N n1 = + (N n2/N n1) * (N(SUC n2)/N n2) *) + SUBGOAL_THEN `(N:num->num)(SUC n2) DIV N n1 = + N n2 DIV N n1 * (N(SUC n2) DIV N n2)` + SUBST1_TAC THENL + [MATCH_MP_TAC DIV_UNIQ THEN EXISTS_TAC `0` THEN + REWRITE_TAC[ADD_CLAUSES] THEN CONJ_TAC THENL + [CONV_TAC SYM_CONV THEN + GEN_REWRITE_TAC (LAND_CONV o LAND_CONV) [MULT_SYM] THEN + ONCE_REWRITE_TAC[GSYM MULT_ASSOC] THEN + SUBGOAL_THEN `(N:num->num) n2 DIV N n1 * N n1 = N n2` + SUBST1_TAC THENL [ASM_REWRITE_TAC[GSYM DIVIDES_DIV_MULT]; + ASM_REWRITE_TAC[GSYM DIVIDES_DIV_MULT]]; + ASM_REWRITE_TAC[ARITH_RULE `0 < n <=> ~(n = 0)`]]; ALL_TAC] THEN + (* k * ((N n2/N n1) * (N(SUC n2)/N n2)) + -> (k * (N n2/N n1)) * (N(SUC n2)/N n2) *) REWRITE_TAC[MULT_ASSOC] THEN + (* Apply embedding: h(SUC n2)(j * d) = h n2 j + with j = k * (N n2 DIV N n1) *) + SUBGOAL_THEN `(h:num->num->A) (SUC n2) + ((k * (N:num->num) n2 DIV N n1) * + (N(SUC n2) DIV N n2)) + = h n2 (k * N n2 DIV N n1)` + SUBST1_TAC THENL [FIRST_ASSUM(MATCH_MP_TAC o SPECL [`n2:num`; + `k * (N:num->num) n2 DIV N n1`]) THEN MATCH_MP_TAC LE_TRANS THEN + EXISTS_TAC `(N:num->num) n1 * N n2 DIV N n1` THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[LE_MULT_RCANCEL]; + ONCE_REWRITE_TAC[MULT_SYM] THEN + SUBGOAL_THEN `(N:num->num) n2 DIV N n1 * N n1 = N n2` + SUBST1_TAC THENL [ASM_REWRITE_TAC[GSYM DIVIDES_DIV_MULT]; + REWRITE_TAC[LE_REFL]]]; ALL_TAC] THEN + (* Apply IH: h n2 (k * N n2/N n1) = h n1 k *) + FIRST_X_ASSUM(fun th -> + MATCH_MP_TAC th THEN ASM_REWRITE_TAC[])]]; ALL_TAC] THEN + (* 6f: well-definedness *) + SUBGOAL_THEN `!n1 n2 k1 k2. k1 <= (N:num->num) n1 /\ k2 <= N n2 /\ + &k1 / &(N n1) = &k2 / &(N n2) + ==> (h:num->num->A) n1 k1 = h n2 k2` + ASSUME_TAC THENL [REPEAT GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN `~((N:num->num) n1 = 0) /\ ~(N n2 = 0)` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[ARITH_RULE `1 <= n ==> ~(n = 0)`]; + ALL_TAC] THEN + DISJ_CASES_TAC + (SPECL [`n1:num`; `n2:num`] LE_CASES) THENL [(* n1 <= n2 *) + SUBGOAL_THEN `(N:num->num) n1 divides N n2` + ASSUME_TAC THENL [USE_THEN "6d" MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `k2 = k1 * (N:num->num) n2 DIV N n1` + SUBST1_TAC THENL [SUBGOAL_THEN `(N:num->num) n2 DIV N n1 * N n1 = N n2` + ASSUME_TAC THENL [ASM_REWRITE_TAC[GSYM DIVIDES_DIV_MULT]; ALL_TAC] THEN + UNDISCH_TAC + `&k1 / &((N:num->num) n1) = + &k2 / &(N n2)` THEN UNDISCH_TAC + `(N:num->num) n2 DIV N n1 * + N n1 = N n2` THEN UNDISCH_TAC `~((N:num->num) n1 = 0)` THEN + UNDISCH_TAC `~((N:num->num) n2 = 0)` THEN num_field_tac; ALL_TAC] THEN + CONV_TAC SYM_CONV THEN FIRST_X_ASSUM(fun th -> MATCH_MP_TAC th THEN + ASM_REWRITE_TAC[]); + (* n2 <= n1 *) + SUBGOAL_THEN `(N:num->num) n2 divides N n1` + ASSUME_TAC THENL [USE_THEN "6d" MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `k1 = k2 * (N:num->num) n1 DIV N n2` + SUBST1_TAC THENL [SUBGOAL_THEN `(N:num->num) n1 DIV N n2 * N n2 = N n1` + ASSUME_TAC THENL [ASM_REWRITE_TAC[GSYM DIVIDES_DIV_MULT]; ALL_TAC] THEN + UNDISCH_TAC + `&k1 / &((N:num->num) n1) = + &k2 / &(N n2)` THEN UNDISCH_TAC + `(N:num->num) n1 DIV N n2 * + N n2 = N n1` THEN UNDISCH_TAC `~((N:num->num) n1 = 0)` THEN + UNDISCH_TAC `~((N:num->num) n2 = 0)` THEN num_field_tac; ALL_TAC] THEN + FIRST_X_ASSUM(fun th -> + MATCH_MP_TAC th THEN ASM_REWRITE_TAC[])]; ALL_TAC] THEN + (* Key distance lemma: every h n k is within + e/4 of x *) + SUBGOAL_THEN `!n k. k <= (N:num->num) n + ==> mdist m (x:A, (h:num->num->A) n k) + <= e / &4` + ASSUME_TAC THENL [SUBGOAL_THEN `!n k. k <= (N:num->num) n + ==> mdist m (x:A, (h:num->num->A) n k) + < e / &8 * + sum(0..n) (\i. inv(&4) pow i)` + ASSUME_TAC THENL [INDUCT_TAC THENL + [(* Base case: n = 0 *) X_GEN_TAC `k:num` THEN DISCH_TAC THEN + SIMP_TAC[SUM_SING_NUMSEG; real_pow; REAL_MUL_RID] THEN + MATCH_MP_TAC REAL_LET_TRANS THEN + EXISTS_TAC `mdiameter m (C0:A->bool)` THEN CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN + REPLICATE_TAC 2 (CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC]) THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ASM_REWRITE_TAC[]]; + (* Inductive case: n -> SUC n *) + X_GEN_TAC `k:num` THEN DISCH_TAC THEN + (* k0 = k DIV (N(SUC n) DIV N n) is the projection to level n *) + (* Get the proximity bound *) + SUBGOAL_THEN + `mdist m ((h:num->num->A) n (k DIV (N(SUC n) DIV (N:num->num) n)), + h (SUC n) k) < ep(SUC n)` + ASSUME_TAC THENL [FIRST_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Prove k0 <= N n *) + SUBGOAL_THEN + `k DIV (N(SUC n) DIV (N:num->num) n) <= N n` ASSUME_TAC THENL + [le_ldiv_Nn_tac; ALL_TAC] THEN + (* Triangle inequality using k0 *) + MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC + `mdist m (x:A, (h:num->num->A) n + (k DIV (N(SUC n) DIV N n))) + + mdist m (h n (k DIV (N(SUC n) DIV N n)), + h (SUC n) k)` THEN CONJ_TAC THENL + [MATCH_MP_TAC MDIST_TRIANGLE THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THEN FIRST_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Expand sum(0..SUC n) and distribute *) + SIMP_TAC[SUM_CLAUSES_NUMSEG; LE_0] THEN + REWRITE_TAC[REAL_ADD_LDISTRIB] THEN + (* Split: IH part + ep bound part *) + MATCH_MP_TAC REAL_LTE_ADD2 THEN CONJ_TAC THENL + [(* IH: mdist m (x, h n k0) < e/8 * sum(0..n)(...) *) + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + (* ep bound *) + MATCH_MP_TAC REAL_LE_TRANS THEN EXISTS_TAC `ep(SUC n):real` THEN + CONJ_TAC THENL + [MATCH_MP_TAC REAL_LT_IMP_LE THEN + ASM_REWRITE_TAC[]; MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `e / &8 / &4 pow (SUC n)` THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; + REWRITE_TAC[real_div; REAL_POW_INV; REAL_LE_REFL]]]]]; ALL_TAC] THEN + GEN_TAC THEN GEN_TAC THEN DISCH_TAC THEN MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC + `e / &8 * sum(0..n) (\i. inv(&4) pow i)` THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_LT_IMP_LE THEN FIRST_X_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `e / &8 * &2` THEN + CONJ_TAC THENL [MATCH_MP_TAC REAL_LE_LMUL THEN + CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `~(inv(&4) = &1)` + ASSUME_TAC THENL [CONV_TAC REAL_RAT_REDUCE_CONV; ALL_TAC] THEN + ASM_REWRITE_TAC[SUM_GP; + ARITH_RULE `~(n < 0)`; + real_pow; REAL_INV_1; REAL_MUL_LID] THEN MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `&1 / (&1 - inv(&4))` THEN + CONJ_TAC THENL [SUBGOAL_THEN `&0 < &1 - inv(&4)` + ASSUME_TAC THENL [CONV_TAC REAL_RAT_REDUCE_CONV; ALL_TAC] THEN + ASM_SIMP_TAC[REAL_LE_DIV2_EQ] THEN MATCH_MP_TAC(REAL_ARITH + `&0 <= x ==> &1 - x <= &1`) THEN MATCH_MP_TAC REAL_LE_MUL THEN + CONJ_TAC THENL [CONV_TAC REAL_RAT_REDUCE_CONV; + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV]; + CONV_TAC REAL_RAT_REDUCE_CONV]; ASM_REAL_ARITH_TAC]; ALL_TAC] THEN + (* Provide witnesses for f and s *) + EXISTS_TAC + `\a:real. @z:A. ?n k:num. k <= (N:num->num) n /\ + a = &k / &(N n) /\ z = (h:num->num->A) n k` THEN EXISTS_TAC + `{a:real | ?n k:num. k <= (N:num->num) n /\ a = &k / &(N n)}` THEN + REPEAT CONJ_TAC THENL + [(* 1. s SUBSET real_interval[&0,&1] *) + REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_REAL_INTERVAL] THEN + X_GEN_TAC `a:real` THEN + DISCH_THEN(X_CHOOSE_THEN `nn:num` (X_CHOOSE_THEN `kk:num` + STRIP_ASSUME_TAC)) THEN ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_LE_DIV THEN REWRITE_TAC[REAL_POS]; + SUBGOAL_THEN `&0 < &((N:num->num) nn)` ASSUME_TAC THENL + [REWRITE_TAC[REAL_OF_NUM_LT] THEN + ASM_MESON_TAC[ARITH_RULE `1 <= n ==> 0 < n`]; ALL_TAC] THEN + ASM_SIMP_TAC[REAL_LE_LDIV_EQ] THEN + REWRITE_TAC[REAL_MUL_LID; REAL_OF_NUM_LE] THEN ASM_REWRITE_TAC[]]; + (* 2. density: real_interval[&0,&1] SUBSET closure s *) + REWRITE_TAC[SUBSET; IN_REAL_INTERVAL] THEN X_GEN_TAC `t:real` THEN + STRIP_TAC THEN + REWRITE_TAC[GSYM MTOPOLOGY_REAL_EUCLIDEAN_METRIC] THEN + REWRITE_TAC[METRIC_CLOSURE_OF; IN_ELIM_THM; REAL_EUCLIDEAN_METRIC; IN_UNIV; + IN_MBALL] THEN + X_GEN_TAC `r:real` THEN DISCH_TAC THEN + (* Exponential growth: 2^n <= N n *) + SUBGOAL_THEN `!nn:num. 2 EXP nn <= (N:num->num) nn` + ASSUME_TAC THENL + [INDUCT_TAC THENL [REWRITE_TAC[EXP] THEN + ASM_MESON_TAC[]; MATCH_MP_TAC LE_TRANS THEN + EXISTS_TAC `2 * (N:num->num) nn` THEN ASM_REWRITE_TAC[EXP] THEN + ASM_REWRITE_TAC[LE_MULT_LCANCEL]]; ALL_TAC] THEN + (* Find n0 with inv(&(N n0)) < r via REAL_ARCH_POW2 *) + MP_TAC(SPEC `inv(r)` REAL_ARCH_POW2) THEN + DISCH_THEN(X_CHOOSE_TAC `n0:num`) THEN + SUBGOAL_THEN `inv(&((N:num->num) n0)) < r` ASSUME_TAC THENL [MATCH_MP_TAC + REAL_LET_TRANS THEN + EXISTS_TAC `inv(&2 pow n0)` THEN + CONJ_TAC THENL [MATCH_MP_TAC REAL_LE_INV2 THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_POW_LT THEN REAL_ARITH_TAC; + ASM_REWRITE_TAC[REAL_OF_NUM_POW; REAL_OF_NUM_LE]]; + MATCH_MP_TAC REAL_LT_LINV THEN ASM_REWRITE_TAC[]]; ALL_TAC] THEN + (* Apply UNIT_INTERVAL_APPROX *) + MP_TAC(SPECL [`(N:num->num) n0`; `t:real`] UNIT_INTERVAL_APPROX) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `kk:num` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `&kk / &((N:num->num) n0)` THEN CONJ_TAC THENL + [MAP_EVERY EXISTS_TAC [`n0:num`; `kk:num`] THEN ASM_REWRITE_TAC[]; + MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `inv(&((N:num->num) n0))` THEN + CONJ_TAC THENL + [ASM_REWRITE_TAC[REAL_ABS_SUB]; ASM_REWRITE_TAC[]]]; + (* 3. &0 IN s *) + REWRITE_TAC[IN_ELIM_THM] THEN MAP_EVERY EXISTS_TAC [`0`; `0`] THEN + REWRITE_TAC[LE_0; real_div; REAL_MUL_LZERO]; + (* 4. &1 IN s *) + REWRITE_TAC[IN_ELIM_THM] THEN + MAP_EVERY EXISTS_TAC [`0`; `(N:num->num) 0`] THEN REWRITE_TAC[LE_REFL] THEN + CONV_TAC SYM_CONV THEN MATCH_MP_TAC REAL_DIV_REFL THEN + ASM_SIMP_TAC[REAL_OF_NUM_EQ]; + (* 5. f(&0) = x *) + REWRITE_TAC[] THEN MATCH_MP_TAC SELECT_UNIQUE THEN X_GEN_TAC `z:A` THEN + EQ_TAC THENL + [DISCH_THEN(fun th -> + X_CHOOSE_THEN `nn:num` + (X_CHOOSE_THEN `kk:num` + STRIP_ASSUME_TAC) + (REWRITE_RULE[] th)) THEN SUBGOAL_THEN `kk = 0` SUBST_ALL_TAC THENL + [UNDISCH_TAC `&0 = &kk / &((N:num->num) nn)` THEN + REWRITE_TAC[EQ_SYM_EQ; REAL_DIV_EQ_0; + REAL_OF_NUM_EQ] THEN ASM_MESON_TAC[ARITH_RULE + `1 <= n ==> ~(n = 0)`]; ALL_TAC] THEN ASM_MESON_TAC[]; DISCH_TAC THEN + ASM_REWRITE_TAC[] THEN + MAP_EVERY EXISTS_TAC [`0`; `0`] THEN + ASM_REWRITE_TAC[LE_0; real_div; REAL_MUL_LZERO]]; + (* 6. f(&1) = y *) + REWRITE_TAC[] THEN MATCH_MP_TAC SELECT_UNIQUE THEN X_GEN_TAC `z:A` THEN + EQ_TAC THENL + [DISCH_THEN(fun th -> + X_CHOOSE_THEN `nn:num` + (X_CHOOSE_THEN `kk:num` + STRIP_ASSUME_TAC) + (REWRITE_RULE[] th)) THEN SUBGOAL_THEN `kk = (N:num->num) nn` + SUBST_ALL_TAC THENL [SUBGOAL_THEN `~(&((N:num->num) nn) = &0)` MP_TAC + THENL [ASM_REWRITE_TAC[REAL_OF_NUM_EQ]; ALL_TAC] THEN + UNDISCH_TAC `&1 = &kk / &((N:num->num) nn)` THEN + REWRITE_TAC[GSYM REAL_OF_NUM_EQ] THEN CONV_TAC REAL_FIELD; ALL_TAC] THEN + ASM_MESON_TAC[]; + DISCH_TAC THEN ASM_REWRITE_TAC[] THEN + MAP_EVERY EXISTS_TAC [`0`; `(N:num->num) 0`] THEN + REWRITE_TAC[LE_REFL] THEN CONJ_TAC THENL + [CONV_TAC SYM_CONV THEN MATCH_MP_TAC REAL_DIV_REFL THEN + ASM_SIMP_TAC[REAL_OF_NUM_EQ]; + ASM_MESON_TAC[]]]; + (* 7. IMAGE f s SUBSET mspace m *) + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; + IN_ELIM_THM] THEN X_GEN_TAC `a:real` THEN resolve_select_tac + (FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]); + (* 8. distance bound: !a. a IN s ==> mdist m (x,f a) <= e/4 *) + REWRITE_TAC[IN_ELIM_THM] THEN X_GEN_TAC `a:real` THEN resolve_select_tac + (FIRST_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]); + (* 9. uniform continuity *) + (* Step A: Adjacency bound - derive from ULC + step size *) + SUBGOAL_THEN `!n k. k < (N:num->num) n + ==> mdist m ((h:num->num->A) n k, h n (SUC k)) + < (ep:num->real)(SUC n)` + (LABEL_TAC "adj") THENL [REPEAT GEN_TAC THEN DISCH_TAC THEN + (* h n k, h n (SUC k) IN mspace m *) + SUBGOAL_THEN `k <= (N:num->num) n /\ SUC k <= N n` + STRIP_ASSUME_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(h:num->num->A) n k IN mspace m /\ h n (SUC k) IN mspace m` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + (* mdist < dl(SUC n) from step-size bound *) + SUBGOAL_THEN `mdist m ((h:num->num->A) n k, h n (SUC k)) + < (dl:num->real)(SUC + n)` ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + (* Get connected set c via ULC *) + SUBGOAL_THEN `?c. connected_in(mtopology m) (c:A->bool) /\ + (h:num->num->A) n k IN c /\ h n (SUC k) IN c /\ + mbounded m c /\ + mdiameter m c < (ep:num->real)(SUC n)` + (X_CHOOSE_THEN `c:A->bool` STRIP_ASSUME_TAC) THENL + [FIRST_ASSUM(MP_TAC o SPEC `(ep:num->real)(SUC n)` o + check (is_forall o concl) o check (free_in `del:real->real` o concl)) + THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPECL + [`(h:num->num->A) n k`; + `(h:num->num->A) n (SUC k)`])) THEN ANTS_TAC THENL + [UNDISCH_TAC + `!n:num. (dl:num->real) n = (del:real->real)((ep:num->real) n)` THEN + DISCH_THEN(fun th -> + REWRITE_TAC[SYM(SPEC `SUC n` th)]) THEN ASM_REWRITE_TAC[]; + DISCH_THEN ACCEPT_TAC]; ALL_TAC] THEN + (* mdist <= mdiameter < ep(SUC n) *) + MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `mdiameter m (c:A->bool)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN ASM_REWRITE_TAC[]; + FIRST_ASSUM ACCEPT_TAC]; ALL_TAC] THEN + (* Step B: Telescoping bound *) + SUBGOAL_THEN `!n0 n k. n0 <= n /\ k <= (N:num->num) n + ==> mdist m ((h:num->num->A) n0 + (k DIV (N n DIV N n0)), + h n k) + <= (ep:num->real) n0 / &3` + (LABEL_TAC "telesc") THENL [X_GEN_TAC `n0:num` THEN + (* Prove tighter bound: mdist <= ep(n0)/3 - ep(n)/3 *) + SUBGOAL_THEN `!n k. n0 <= n /\ k <= (N:num->num) n + ==> mdist m ((h:num->num->A) n0 + (k DIV (N n DIV N n0)), + h n k) + <= (ep:num->real) n0 / &3 - ep n / &3` + (fun th -> REPEAT STRIP_TAC THEN MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `(ep:num->real) n0 / &3 - ep n / &3` THEN + CONJ_TAC THENL [MATCH_MP_TAC th THEN ASM_REWRITE_TAC[]; + MATCH_MP_TAC(REAL_ARITH `&0 < x ==> a - x / &3 <= a`) THEN + ASM_REWRITE_TAC[]]) THEN + INDUCT_TAC THENL + [(* Base: n = 0. If n0 <= 0 then n0 = 0 *) X_GEN_TAC `k:num` THEN + STRIP_TAC THEN + SUBGOAL_THEN `n0 = 0` SUBST_ALL_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + ASM_SIMP_TAC[DIV_REFL] THEN + REWRITE_TAC[DIV_1; REAL_SUB_REFL] THEN + SUBGOAL_THEN `(h:num->num->A) 0 k IN mspace m` ASSUME_TAC THENL + [FIRST_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_SIMP_TAC[MDIST_REFL; REAL_LE_REFL]; + (* Step: n -> SUC n *) + X_GEN_TAC `k:num` THEN STRIP_TAC THEN + (* Case: n0 = SUC n, base case at this level *) + ASM_CASES_TAC `n0 = SUC n` THENL + [ASM_REWRITE_TAC[] THEN ASM_SIMP_TAC[DIV_REFL] THEN + REWRITE_TAC[DIV_1; REAL_SUB_REFL] THEN + SUBGOAL_THEN `(h:num->num->A) (SUC n) k IN mspace m` + ASSUME_TAC THENL [FIRST_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_SIMP_TAC[MDIST_REFL; REAL_LE_REFL]; ALL_TAC] THEN + (* So n0 <= n *) + SUBGOAL_THEN `n0:num <= n` ASSUME_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + (* Let k' = k DIV (N(SUC n) DIV N n) *) + ABBREV_TAC `k' = k DIV (N(SUC n) DIV (N:num->num) n)` THEN + (* k' <= N n *) + SUBGOAL_THEN `k' <= (N:num->num) n` ASSUME_TAC THENL + [EXPAND_TAC "k'" THEN le_ldiv_Nn_tac; ALL_TAC] THEN + (* DIV_DIV key: k DIV (N(SUC n) DIV N n0) = + k' DIV (N n DIV N n0) *) + (* Key DIV fact: (N(SUC n) DIV N n) * (N n DIV N n0) = + N(SUC n) DIV N n0 *) + SUBGOAL_THEN `(N(SUC n) DIV (N:num->num) n) * (N n DIV N n0) = + N(SUC n) DIV N n0` + ASSUME_TAC THENL [(* Proof: a * b = c follows from DIVIDES_DIV_MULT *) + SUBGOAL_THEN `(N:num->num) n DIV N n0 * N n0 = N n` + ASSUME_TAC THENL [divides_N_tac THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(N:num->num)(SUC n) DIV N n * N n = N(SUC n)` + ASSUME_TAC THENL [divides_N_tac THEN ASM_ARITH_TAC; ALL_TAC] THEN + CONV_TAC SYM_CONV THEN + MATCH_MP_TAC DIV_UNIQ THEN EXISTS_TAC `0` THEN + REWRITE_TAC[ADD_CLAUSES] THEN CONJ_TAC THENL + [ONCE_REWRITE_TAC[GSYM MULT_ASSOC] THEN ASM_REWRITE_TAC[]; + MATCH_MP_TAC(ARITH_RULE `1 <= n ==> 0 < n`) THEN + ASM_REWRITE_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `k DIV ((N:num->num)(SUC n) DIV N n0) = + k' DIV (N n DIV N n0)` SUBST1_TAC THENL [EXPAND_TAC "k'" THEN + REWRITE_TAC[DIV_DIV] THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC + `mdist m ((h:num->num->A) n0 (k' DIV (N n DIV N n0)), + h n k') + mdist m (h n k', h (SUC n) k)` THEN + CONJ_TAC THENL [MATCH_MP_TAC MDIST_TRIANGLE THEN + (* Need: h n0 (...) IN mspace m, h n k' IN mspace m, + h(SUC n) k IN mspace m *) + SUBGOAL_THEN `k' DIV ((N:num->num) n DIV N n0) <= N n0` + ASSUME_TAC THENL [MATCH_MP_TAC LE_LDIV THEN CONJ_TAC THENL + [SUBGOAL_THEN `(N:num->num) n DIV N n0 * N n0 = N n` + ASSUME_TAC THENL [divides_N_tac THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `~((N:num->num) n0 = 0)` ASSUME_TAC THENL + [MATCH_MP_TAC(ARITH_RULE `1 <= n ==> ~(n = 0)`) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* N n DIV N n0 * N n0 = N n, ~(N n = 0) ==> ~(N n DIV N n0 = 0) *) + SUBGOAL_THEN `~((N:num->num) n = 0)` ASSUME_TAC THENL + [MATCH_MP_TAC(ARITH_RULE `1 <= n ==> ~(n = 0)`) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[MULT_CLAUSES]; + SUBGOAL_THEN `(N:num->num) n DIV N n0 * N n0 = N n` + SUBST1_TAC THENL [divides_N_tac THEN ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[]]]; ALL_TAC] THEN + CONJ_TAC THENL [FIRST_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + CONJ_TAC THEN FIRST_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Bound: IH part <= ep(n0)/3 - ep(n)/3, + one-step part < ep(SUC n) *) MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `(ep:num->real) n0 / &3 - ep n / &3 + + ep(SUC + n)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC REAL_LE_ADD2 THEN CONJ_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + MATCH_MP_TAC REAL_LT_IMP_LE THEN EXPAND_TAC "k'" THEN + FIRST_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]]; ALL_TAC] THEN + (* Arithmetic: ep(n0)/3 - ep(n)/3 + ep(SUC n) <= + ep(n0)/3 - ep(SUC n)/3 + iff 4*ep(SUC n)/3 <= ep(n)/3 + iff 4*ep(SUC n) <= ep(n) *) + MATCH_MP_TAC(REAL_ARITH + `&4 * esn <= en + ==> en0 - en / &3 + esn <= en0 - esn / + &3`) THEN MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `&4 * (ep:num->real) n / &4` THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_LE_LMUL THEN + CONJ_TAC THENL [REAL_ARITH_TAC; ASM_REWRITE_TAC[]]; + SUBGOAL_THEN `&0 < (ep:num->real) n` MP_TAC THENL + [ASM_REWRITE_TAC[]; CONV_TAC REAL_FIELD]]]; ALL_TAC] THEN + (* Now prove uniform continuity *) + REWRITE_TAC[uniformly_continuous_map; SUBMETRIC; REAL_EUCLIDEAN_METRIC; + IN_INTER; + IN_UNIV] THEN CONJ_TAC THENL + [(* IMAGE subset *) REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; + IN_ELIM_THM; IN_INTER; IN_UNIV] THEN X_GEN_TAC `aa:real` THEN + resolve_select_tac + (FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]); ALL_TAC] THEN + (* eps-delta *) + X_GEN_TAC `eps:real` THEN DISCH_TAC THEN + SUBGOAL_THEN `?n0. (ep:num->real) n0 < eps` STRIP_ASSUME_TAC THENL + [(* ep(n) <= e/8 * (1/4)^n -> 0. Find n0 with ep(n0) < eps. *) + SUBGOAL_THEN `?nn:num. inv(&4) pow nn < eps / (e / &8)` + (X_CHOOSE_TAC `nn:num`) THENL [MATCH_MP_TAC REAL_ARCH_POW_INV THEN + CONJ_TAC THENL + [MATCH_MP_TAC REAL_LT_DIV THEN CONJ_TAC THENL [ASM_REWRITE_TAC[]; + MATCH_MP_TAC REAL_LT_DIV THEN ASM_REWRITE_TAC[] THEN REAL_ARITH_TAC]; + CONV_TAC REAL_RAT_REDUCE_CONV]; ALL_TAC] THEN EXISTS_TAC `nn:num` THEN + MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `e / &8 / &4 pow nn` THEN + ASM_REWRITE_TAC[] THEN + (* Goal: e / &8 / &4 pow nn < eps *) + (* Have: inv(&4) pow nn < eps / (e / &8) *) + (* Equiv to: (e/8) * inv(4)^nn < eps *) + SUBGOAL_THEN `&0 < e / &8` ASSUME_TAC THENL [MATCH_MP_TAC REAL_LT_DIV THEN + ASM_REWRITE_TAC[] THEN REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `e / &8 / &4 pow nn = + (e / &8) * inv(&4) pow nn` SUBST1_TAC THENL + [REWRITE_TAC[real_div; REAL_INV_POW]; ALL_TAC] THEN + SUBGOAL_THEN `eps = (e / &8) * (eps / (e / &8))` + (fun th -> GEN_REWRITE_TAC RAND_CONV [th]) THENL [SUBGOAL_THEN + `~(e / &8 = &0)` MP_TAC THENL + [ASM_REAL_ARITH_TAC; CONV_TAC REAL_FIELD]; ALL_TAC] THEN + ASM_SIMP_TAC[REAL_LT_LMUL_EQ]; ALL_TAC] THEN + EXISTS_TAC `inv(&((N:num->num) n0))` THEN + CONJ_TAC THENL + [MATCH_MP_TAC REAL_LT_INV THEN REWRITE_TAC[REAL_OF_NUM_LT] THEN + MATCH_MP_TAC(ARITH_RULE + `1 <= n ==> 0 < n`) THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_ELIM_THM] THEN X_GEN_TAC `a1:real` THEN + X_GEN_TAC `a2:real` THEN STRIP_TAC THEN + (* Resolve @z for a2 *) + SUBGOAL_THEN `(@z:A. ?nn kk:num. kk <= (N:num->num) nn /\ + a2 = &kk / &(N nn) /\ z = (h:num->num->A) nn kk) = h n' k'` + SUBST1_TAC THENL [resolve_select_B_tac + `&k1 / &((N:num->num) n1) = &k' / &(N n')` `n':num` `k':num`; + ALL_TAC] THEN + (* Resolve @z for a1 *) + SUBGOAL_THEN `(@z:A. ?nn kk:num. kk <= (N:num->num) nn /\ + a1 = &kk / &(N nn) /\ z = (h:num->num->A) nn kk) = h n k` + SUBST1_TAC THENL [resolve_select_B_tac + `&k1 / &((N:num->num) n1) = &k / &(N n)` `n:num` `k:num`; ALL_TAC] THEN + (* Now goal: mdist m (h n' k', h n k) < eps *) + (* Lift both to common level M *) + ABBREV_TAC `M = n + n' + n0:num` THEN + SUBGOAL_THEN `n:num <= M /\ n':num <= M /\ n0:num <= M` + STRIP_ASSUME_TAC THENL [EXPAND_TAC "M" THEN ARITH_TAC; ALL_TAC] THEN + (* Establish non-zero conditions *) + SUBGOAL_THEN `~((N:num->num) n = 0) /\ ~(N n' = 0) /\ + ~(N n0 = 0) /\ ~(N M = 0)` STRIP_ASSUME_TAC THENL [REPEAT CONJ_TAC THEN + MATCH_MP_TAC(ARITH_RULE `1 <= n ==> ~(n = 0)`) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + ABBREV_TAC `K = k * (N:num->num) M DIV N n` THEN + ABBREV_TAC `K' = k' * (N:num->num) M DIV N n'` THEN + (* h M K = h n k via embedding *) + SUBGOAL_THEN `(h:num->num->A) M K = h n k` ASSUME_TAC THENL [EXPAND_TAC "K" + THEN + SUBGOAL_THEN `n:num <= M /\ k <= (N:num->num) n` MP_TAC THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(fun th -> + FIRST_X_ASSUM(fun emb -> + MP_TAC(MATCH_MP emb th))) THEN SIMP_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(h:num->num->A) M K' = h n' k'` ASSUME_TAC THENL [EXPAND_TAC + "K'" THEN + SUBGOAL_THEN `n':num <= M /\ k' <= (N:num->num) n'` MP_TAC THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(fun th -> + FIRST_X_ASSUM(fun emb -> + MP_TAC(MATCH_MP emb th))) THEN SIMP_TAC[]; ALL_TAC] THEN + (* Rewrite goal to use level M *) + SUBGOAL_THEN `mdist m ((h:num->num->A) n' k', h n k) = + mdist m (h M K', + h M K)` SUBST1_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* K, K' <= N M *) + (let prove_K_le_NM label exists_tm div_tm = + EXPAND_TAC label THEN MATCH_MP_TAC LE_TRANS THEN EXISTS_TAC exists_tm THEN + CONJ_TAC THENL + [REWRITE_TAC[LE_MULT_RCANCEL] THEN DISJ1_TAC THEN ASM_REWRITE_TAC[]; + ONCE_REWRITE_TAC[MULT_SYM] THEN SUBGOAL_THEN div_tm + (fun th -> REWRITE_TAC[th; LE_REFL]) THEN divides_N_tac THEN + ASM_REWRITE_TAC[]] in + SUBGOAL_THEN `K <= (N:num->num) M` ASSUME_TAC THENL [prove_K_le_NM "K" + `(N:num->num) n * N M DIV N n` + `(N:num->num) M DIV N n * N n = N M`; ALL_TAC] THEN + SUBGOAL_THEN `K' <= (N:num->num) M` ASSUME_TAC THENL [prove_K_le_NM "K'" + `(N:num->num) n' * N M DIV N n'` + `(N:num->num) M DIV N n' * N n' = N M`; ALL_TAC]) THEN + (* D, J, J' *) + ABBREV_TAC `D = (N:num->num) M DIV N n0` THEN ABBREV_TAC `J = K DIV D` THEN + ABBREV_TAC `J' = K' DIV D` THEN + SUBGOAL_THEN `D * (N:num->num) n0 = N M` ASSUME_TAC THENL + [EXPAND_TAC "D" THEN divides_N_tac THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `~(D = 0)` ASSUME_TAC THENL + [DISCH_TAC THEN SUBGOAL_THEN `(N:num->num) M = 0` MP_TAC THENL + [ASM_MESON_TAC[MULT_CLAUSES]; ASM_REWRITE_TAC[]]; ALL_TAC] THEN + (let prove_J_le_Nn0 label = + EXPAND_TAC label THEN MATCH_MP_TAC LE_LDIV THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `D * (N:num->num) n0 = N M` (fun th -> ASM_REWRITE_TAC[th]) + THEN + ASM_REWRITE_TAC[] in + SUBGOAL_THEN `J <= (N:num->num) n0` ASSUME_TAC THENL + [prove_J_le_Nn0 "J"; ALL_TAC] THEN + SUBGOAL_THEN `J' <= (N:num->num) n0` ASSUME_TAC THENL [prove_J_le_Nn0 "J'"; + ALL_TAC]) THEN + (* |K - K'| < D *) + SUBGOAL_THEN `K < K' + D /\ K' < K + (D:num)` + STRIP_ASSUME_TAC THENL [SUBGOAL_THEN `&0 < &((N:num->num) M)` ASSUME_TAC + THENL + [REWRITE_TAC[REAL_OF_NUM_LT] THEN ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `a1 = &K / &((N:num->num) M)` ASSUME_TAC THENL + [EXPAND_TAC "K" THEN SUBGOAL_THEN `(N:num->num) M DIV N n * N n = N M` + MP_TAC THENL [divides_N_tac THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + MP_TAC(ASSUME `a1 = &k / &((N:num->num) n)`) THEN + MP_TAC(ASSUME `~((N:num->num) n = 0)`) THEN + MP_TAC(ASSUME `~((N:num->num) M = 0)`) THEN num_field_tac; ALL_TAC] THEN + SUBGOAL_THEN `a2 = &K' / &((N:num->num) M)` ASSUME_TAC THENL + [EXPAND_TAC "K'" THEN SUBGOAL_THEN `(N:num->num) M DIV N n' * N n' = N M` + MP_TAC THENL [divides_N_tac THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + MP_TAC(ASSUME `a2 = &k' / &((N:num->num) n')`) THEN + MP_TAC(ASSUME `~((N:num->num) n' = 0)`) THEN + MP_TAC(ASSUME `~((N:num->num) M = 0)`) THEN num_field_tac; ALL_TAC] THEN + SUBGOAL_THEN `inv(&((N:num->num) n0)) = &D / &(N M)` + ASSUME_TAC THENL + [MP_TAC(ASSUME `D * (N:num->num) n0 = N M`) THEN + MP_TAC(ASSUME `~((N:num->num) n0 = 0)`) THEN + MP_TAC(ASSUME `~((N:num->num) M = 0)`) THEN num_field_tac; ALL_TAC] THEN + SUBGOAL_THEN `abs(&K - &K') < &D` MP_TAC THENL + [MP_TAC(ASSUME `abs(a1 - a2) < inv(&((N:num->num) n0))`) THEN + SUBST1_TAC(ASSUME `a1 = &K / &((N:num->num) M)`) THEN + SUBST1_TAC(ASSUME `a2 = &K' / &((N:num->num) M)`) THEN + SUBST1_TAC(ASSUME `inv(&((N:num->num) n0)) = &D / &(N M)`) THEN + (* Now: abs(K/NM - K'/NM) < D/NM ==> abs(K-K') < D *) + SUBGOAL_THEN `&K / &((N:num->num) M) - &K' / &(N M) = + (&K - &K') / &(N M)` + SUBST1_TAC THENL [MATCH_MP_TAC(REAL_FIELD + `~(z = &0) ==> x / z - y / z = (x - y) / z`) THEN + ASM_REWRITE_TAC[REAL_OF_NUM_EQ]; ALL_TAC] THEN + REWRITE_TAC[REAL_ABS_DIV; REAL_ABS_NUM] THEN + ASM_MESON_TAC[REAL_LT_DIV2_EQ]; ALL_TAC] THEN + REWRITE_TAC[GSYM REAL_OF_NUM_ADD; + GSYM REAL_OF_NUM_LT] THEN REAL_ARITH_TAC; ALL_TAC] THEN + (* J and J' differ by at most 1 *) + SUBGOAL_THEN `J = J' \/ J = SUC J' \/ J' = SUC J` + ASSUME_TAC THENL [SUBGOAL_THEN `J <= J' + 1 /\ J' <= J + 1` MP_TAC THENL + [CONJ_TAC THENL [EXPAND_TAC "J" THEN ASM_SIMP_TAC[LE_LDIV_EQ] THEN + REWRITE_TAC[ARITH_RULE `(n + 1) + 1 = SUC(n + 1)`; + MULT_CLAUSES] THEN ONCE_REWRITE_TAC[ADD_SYM] THEN + TRANS_TAC LT_TRANS `K' + D:num` THEN + CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; + REWRITE_TAC[LT_ADD_RCANCEL] THEN EXPAND_TAC "J'" THEN + ASM_SIMP_TAC[GSYM RDIV_LT_EQ] THEN ARITH_TAC]; + EXPAND_TAC "J'" THEN ASM_SIMP_TAC[LE_LDIV_EQ] THEN + REWRITE_TAC[ARITH_RULE `(n + 1) + 1 = SUC(n + 1)`; + MULT_CLAUSES] THEN ONCE_REWRITE_TAC[ADD_SYM] THEN + TRANS_TAC LT_TRANS `K + D:num` THEN + CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; + REWRITE_TAC[LT_ADD_RCANCEL] THEN EXPAND_TAC "J" THEN + ASM_SIMP_TAC[GSYM RDIV_LT_EQ] THEN + ARITH_TAC]]; ARITH_TAC]; ALL_TAC] THEN + (* Triangle inequality: mdist(h M K', h M K) < eps *) + MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `(ep:num->real) n0` THEN + ASM_REWRITE_TAC[] THEN + (* Bound via intermediate points h n0 J', h n0 J *) + SUBGOAL_THEN `(h:num->num->A) n0 J IN mspace m /\ h n0 J' IN mspace m /\ + h M K IN mspace m /\ h M K' IN mspace m` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC + `mdist m ((h:num->num->A) M K', h n0 J') + + mdist m (h n0 J', h n0 J) + mdist m (h n0 J, h M K)` THEN + CONJ_TAC THENL [MATCH_MP_TAC REAL_LE_TRANS THEN EXISTS_TAC + `mdist m ((h:num->num->A) M K', h n0 J') + + mdist m (h n0 J', h M K)` THEN ASM_SIMP_TAC[MDIST_TRIANGLE] THEN + MATCH_MP_TAC REAL_LE_LADD_IMP THEN + ASM_SIMP_TAC[MDIST_TRIANGLE; REAL_LE_REFL]; ALL_TAC] THEN + (* Bound each term *) + SUBGOAL_THEN + `mdist m ((h:num->num->A) M K', h n0 J') <= (ep:num->real) n0 / &3 /\ + mdist m (h n0 J, h M K) <= ep n0 / &3 /\ + mdist m (h n0 J', h n0 J) <= ep(SUC n0)` + STRIP_ASSUME_TAC THENL [REPEAT CONJ_TAC THENL + [(* mdist(h M K', h n0 J') = mdist(h n0 J', h M K') <= ep n0/3 *) + SUBGOAL_THEN `mdist m ((h:num->num->A) M K', h n0 J') = + mdist m (h n0 J', + h M K')` SUBST1_TAC THENL [ASM_SIMP_TAC[MDIST_SYM]; ALL_TAC] THEN + SUBGOAL_THEN `(h:num->num->A) n0 J' = + h n0 (K' DIV ((N:num->num) M DIV N n0))` + SUBST1_TAC THENL [AP_TERM_TAC THEN EXPAND_TAC "J'" THEN + EXPAND_TAC "D" THEN REFL_TAC; + USE_THEN "telesc" MATCH_MP_TAC THEN ASM_REWRITE_TAC[]]; + (* mdist(h n0 J, h M K) <= ep n0 / 3 *) + SUBGOAL_THEN `(h:num->num->A) n0 J = + h n0 (K DIV ((N:num->num) M DIV N n0))` + SUBST1_TAC THENL [AP_TERM_TAC THEN EXPAND_TAC "J" THEN + EXPAND_TAC "D" THEN REFL_TAC; + USE_THEN "telesc" MATCH_MP_TAC THEN ASM_REWRITE_TAC[]]; + (* mdist(h n0 J', h n0 J) <= ep(SUC n0) *) + FIRST_X_ASSUM(DISJ_CASES_THEN2 SUBST_ALL_TAC + (DISJ_CASES_THEN2 SUBST_ALL_TAC SUBST_ALL_TAC)) THENL + [MATCH_MP_TAC(REAL_ARITH `a = &0 /\ &0 < b ==> a <= b`) THEN + ASM_MESON_TAC[MDIST_REFL]; + MATCH_MP_TAC REAL_LT_IMP_LE THEN + USE_THEN "adj" (MP_TAC o SPECL [`n0:num`; `J':num`]) THEN + ANTS_TAC THENL [ASM_ARITH_TAC; SIMP_TAC[]]; + SUBGOAL_THEN `mdist m ((h:num->num->A) n0 (SUC J), h n0 J) = + mdist m (h n0 J, + h n0 (SUC + J))` SUBST1_TAC THENL [ASM_MESON_TAC[MDIST_SYM]; ALL_TAC] THEN + MATCH_MP_TAC REAL_LT_IMP_LE THEN + USE_THEN "adj" (MP_TAC o SPECL [`n0:num`; `J:num`]) THEN + ANTS_TAC THENL [ASM_ARITH_TAC; SIMP_TAC[]]]]; ALL_TAC] THEN + REPEAT(FIRST_X_ASSUM(fun th -> + let c = concl th in + if not (is_forall c) && + can (find_term (fun t -> + try fst(dest_const t) = "mdist" with Failure _ -> false)) c + then MP_TAC th else failwith "not mdist bound")) THEN + MP_TAC(SPEC `n0:num` (ASSUME `!n. (ep:num->real)(SUC n) <= ep n / &4`)) THEN + MP_TAC(SPEC `n0:num` (ASSUME `!n. &0 < (ep:num->real) n`)) THEN + REAL_ARITH_TAC]);; + +(* Core lemma: nearby points in compact metrizable locally connected space + can be joined by a path of small diameter. + Proof uses multi-scale ULC chain construction (Willard 31.4): + 1. Get ULC sequences eps_k, del_k at decreasing scales + 2. Build iterated chains: refine at each level + 3. Define function on dense set, show uniformly continuous + 4. Extend to [0,1] via extension theorem + 5. Extension gives continuous path with small diameter *) +let COMPACT_LOCALLY_CONNECTED_NEARBY_PATH = prove + (`!m:A metric. + compact_space (mtopology m) /\ locally_connected_space (mtopology m) + ==> !e. &0 < e + ==> ?d. &0 < d /\ + !x y. x IN mspace m /\ y IN mspace m /\ + mdist m (x,y) < d + ==> ?g. path_in (mtopology m) g /\ + g(&0) = x /\ g(&1) = y /\ + IMAGE g (real_interval[&0,&1]) + SUBSET mspace m /\ + mdiameter m + (IMAGE g (real_interval[&0,&1])) < e`, + let COMPACT_METRIZABLE_LOCALLY_CONNECTED_IMP_ULC = prove + (`!m:A metric. + compact_space (mtopology m) /\ locally_connected_space (mtopology m) + ==> !e. &0 < e + ==> ?d. &0 < d /\ + !x y. x IN mspace m /\ y IN mspace m /\ + mdist m (x,y) < d + ==> ?c. connected_in (mtopology m) c /\ + x IN c /\ y IN c /\ + mbounded m c /\ + mdiameter m c < e`, + REPEAT STRIP_TAC THEN SUBGOAL_THEN `ulc_space (m:A metric)` MP_TAC THENL + [MATCH_MP_TAC COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE THEN + ASM_REWRITE_TAC[GSYM TOPSPACE_MTOPOLOGY; GSYM compact_space]; + ALL_TAC] THEN + REWRITE_TAC[ulc_space] THEN DISCH_THEN(MP_TAC o SPEC `e / &2`) THEN + ASM_SIMP_TAC[REAL_HALF] THEN + DISCH_THEN(X_CHOOSE_THEN `d:real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `d:real` THEN ASM_REWRITE_TAC[] THEN + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`x:A`; `y:A`]) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `c:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `c:A->bool` THEN ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC) in + GEN_TAC THEN STRIP_TAC THEN X_GEN_TAC `e:real` THEN DISCH_TAC THEN + (* mcomplete m *) + SUBGOAL_THEN `mcomplete (m:A metric)` ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_SPACE_IMP_MCOMPLETE]; ALL_TAC] THEN + (* Get ULC function: for any eps > 0, get del > 0 *) + SUBGOAL_THEN `!eps. &0 < eps + ==> ?del. &0 < del /\ + !x y:A. x IN mspace m /\ y IN mspace m /\ + mdist m (x,y) < del + ==> ?c. connected_in(mtopology m) c /\ + x IN c /\ y IN c /\ + mbounded m c /\ + mdiameter m c < eps` + (LABEL_TAC "ULC") THENL [GEN_TAC THEN DISCH_TAC THEN + MP_TAC(ISPEC `m:A metric` COMPACT_METRIZABLE_LOCALLY_CONNECTED_IMP_ULC) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN(MP_TAC o SPEC `eps:real`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN ACCEPT_TAC; ALL_TAC] THEN + (* Key subgoal: for any x, y close enough, construct a path. + We use the multi-scale chain construction + extension theorem. + The function on a dense subset of [0,1] is uniformly continuous, + and its extension gives the desired continuous path. *) + SUBGOAL_THEN `?d. &0 < d /\ + !x y:A. x IN mspace m /\ y IN mspace m /\ mdist m (x,y) < d + ==> ?f s. s SUBSET real_interval[&0,&1] /\ + real_interval[&0,&1] SUBSET + euclideanreal closure_of s /\ + &0 IN s /\ &1 IN s /\ + (f:real->A)(&0) = x /\ f(&1) = y /\ + IMAGE f s SUBSET mspace m /\ + (!a. a IN s ==> mdist m (x,f a) <= e / &4) /\ + uniformly_continuous_map + (submetric real_euclidean_metric s, m) f` + STRIP_ASSUME_TAC THENL + [MP_TAC(ISPECL [`m:A metric`; `e:real`] DENSE_FUNCTION_ON_DYADIC) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN GEN_TAC THEN DISCH_TAC THEN + USE_THEN "ULC" (MP_TAC o SPEC `eps:real`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN ACCEPT_TAC; DISCH_THEN ACCEPT_TAC]; ALL_TAC] THEN + (* Use the dense function subgoal to prove the main theorem *) + EXISTS_TAC `d:real` THEN ASM_REWRITE_TAC[] THEN + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`x:A`; `y:A`]) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `f:real->A` (X_CHOOSE_THEN `s:real->bool` + STRIP_ASSUME_TAC)) THEN + (* Apply extension theorem *) + MP_TAC(ISPECL [`real_euclidean_metric`; `m:A metric`; + `f:real->A`; `s:real->bool`; `real_interval[&0,&1]`] + UNIFORMLY_CONTINUOUS_MAP_EXTENDS_TO_INTERMEDIATE_CLOSURE_OF) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[MTOPOLOGY_REAL_EUCLIDEAN_METRIC]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `g:real->A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `g:real->A` THEN + (* g is a path: uniformly continuous on submetric => continuous_map *) SUBGOAL_THEN - `prod_topology (top:A topology) (product_topology {one} (\i. euclideanreal)) - homeomorphic_space prod_topology top euclideanreal` - MP_TAC THENL - [MATCH_MP_TAC HOMEOMORPHIC_SPACE_PROD_TOPOLOGY THEN - REWRITE_TAC[HOMEOMORPHIC_SPACE_SINGLETON_PRODUCT; HOMEOMORPHIC_SPACE_REFL]; - REWRITE_TAC[HOMEOMORPHIC_SPACE; LEFT_IMP_EXISTS_THM]] THEN - X_GEN_TAC `f:A#(1->real)->A#real` THEN DISCH_TAC THEN - EXISTS_TAC `IMAGE (f:A#(1->real)->A#real) t` THEN CONJ_TAC THENL - [ASM_MESON_TAC[HOMEOMORPHIC_MAP_CLOSEDNESS_EQ]; ALL_TAC] THEN - REWRITE_TAC[GSYM HOMEOMORPHIC_SPACE] THEN - FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (ONCE_REWRITE_RULE[IMP_CONJ] - HOMEOMORPHIC_SPACE_TRANS)) THEN - REWRITE_TAC[HOMEOMORPHIC_SPACE] THEN EXISTS_TAC `f:A#(1->real)->A#real` THEN - MATCH_MP_TAC HOMEOMORPHIC_MAP_SUBTOPOLOGIES THEN - ASM_REWRITE_TAC[] THEN - RULE_ASSUM_TAC(REWRITE_RULE[HOMEOMORPHIC_EQ_EVERYTHING_MAP]) THEN - FIRST_ASSUM(MP_TAC o MATCH_MP CLOSED_IN_SUBSET) THEN ASM SET_TAC[]);; - -let COMPLETELY_METRIZABLE_SPACE_GDELTA_IN_ALT = prove - (`!top s:A->bool. - completely_metrizable_space top /\ - (COUNTABLE INTERSECTION_OF open_in top) s - ==> completely_metrizable_space (subtopology top s)`, - REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM; FORALL_INTERSECTION_OF] THEN - X_GEN_TAC `top:A topology` THEN DISCH_TAC THEN - X_GEN_TAC `u:(A->bool)->bool` THEN REPEAT DISCH_TAC THEN - REPEAT STRIP_TAC THEN - MP_TAC(ISPECL [`top:A topology`; `(\x:A->bool. x)`; `u:(A->bool)->bool`] - GDELTA_HOMEOMORPHIC_SPACE_CLOSED_IN_PRODUCT) THEN - ASM_SIMP_TAC[COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE; IN_GSPEC] THEN - DISCH_THEN(X_CHOOSE_THEN `c:A#((A->bool)->real)->bool` STRIP_ASSUME_TAC) THEN - FIRST_X_ASSUM(SUBST1_TAC o - MATCH_MP HOMEOMORPHIC_COMPLETELY_METRIZABLE_SPACE) THEN - MATCH_MP_TAC COMPLETELY_METRIZABLE_SPACE_CLOSED_IN THEN - ASM_REWRITE_TAC[COMPLETELY_METRIZABLE_SPACE_PROD_TOPOLOGY] THEN - REWRITE_TAC[COMPLETELY_METRIZABLE_SPACE_EUCLIDEANREAL; - COMPLETELY_METRIZABLE_SPACE_PRODUCT_TOPOLOGY] THEN - ASM_SIMP_TAC[COUNTABLE_RESTRICT]);; - -let COMPLETELY_METRIZABLE_SPACE_GDELTA_IN = prove - (`!top s:A->bool. - completely_metrizable_space top /\ gdelta_in top s - ==> completely_metrizable_space (subtopology top s)`, - SIMP_TAC[GDELTA_IN_ALT; COMPLETELY_METRIZABLE_SPACE_GDELTA_IN_ALT]);; - -let COMPLETELY_METRIZABLE_SPACE_OPEN_IN = prove - (`!top s:A->bool. - completely_metrizable_space top /\ open_in top s - ==> completely_metrizable_space (subtopology top s)`, - SIMP_TAC[COMPLETELY_METRIZABLE_SPACE_GDELTA_IN; OPEN_IMP_GDELTA_IN]);; + `continuous_map(subtopology euclideanreal (real_interval[&0,&1]), + mtopology m) (g:real->A)` ASSUME_TAC THENL + [REWRITE_TAC[GSYM MTOPOLOGY_REAL_EUCLIDEAN_METRIC; + GSYM MTOPOLOGY_SUBMETRIC] THEN + MATCH_MP_TAC UNIFORMLY_CONTINUOUS_IMP_CONTINUOUS_MAP THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[path_in] THEN + (* g(0) = x and g(1) = y *) + REPLICATE_TAC 2 (CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC]) THEN + (* IMAGE g [0,1] SUBSET mspace m *) + SUBGOAL_THEN `IMAGE (g:real->A) (real_interval[&0,&1]) SUBSET mspace m` + ASSUME_TAC + THENL [UNDISCH_TAC `uniformly_continuous_map + (submetric real_euclidean_metric (real_interval[&0,&1]),m) + (g:real->A)` THEN + REWRITE_TAC[uniformly_continuous_map; SUBMETRIC; REAL_EUCLIDEAN_METRIC; + INTER_UNIV] THEN SET_TAC[]; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + (* mdiameter bound *) + MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `e / &2` THEN CONJ_TAC THENL + [SUBGOAL_THEN `!a:real. a IN real_interval[&0,&1] + ==> mdist m (x:A,(g:real->A) a) <= e / &4` + ASSUME_TAC THENL [(* Proof: preimage of mcball(x,e/4) under g is closed + in subtopology, + contains s (dense), so equals all of [0,1]. *) X_GEN_TAC `a:real` THEN + DISCH_TAC THEN + (* The preimage set *) + ABBREV_TAC `P = {t:real | t IN real_interval[&0,&1] /\ + (g:real->A) t IN mcball m (x:A, e / &4)}` THEN + (* P is closed in subtopology *) + SUBGOAL_THEN `closed_in (subtopology euclideanreal (real_interval[&0,&1])) + (P:real->bool)` ASSUME_TAC THENL + [EXPAND_TAC "P" THEN SUBGOAL_THEN + `{t:real | t IN real_interval[&0,&1] /\ + (g:real->A) t IN mcball m (x:A, e / &4)} = + {t | t IN topspace(subtopology euclideanreal (real_interval[&0,&1])) + /\ g t IN mcball m (x, e / &4)}` + SUBST1_TAC THENL [REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY]; + ALL_TAC] THEN + MATCH_MP_TAC CLOSED_IN_CONTINUOUS_MAP_PREIMAGE THEN + EXISTS_TAC `mtopology (m:A metric)` THEN + ASM_REWRITE_TAC[CLOSED_IN_MCBALL]; ALL_TAC] THEN + (* s SUBSET P *) + SUBGOAL_THEN `(s:real->bool) SUBSET P` ASSUME_TAC THENL + [EXPAND_TAC "P" THEN REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_MCBALL] THEN + X_GEN_TAC `b:real` THEN DISCH_TAC THEN + SUBGOAL_THEN `(g:real->A) b = (f:real->A) b` SUBST1_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] + THEN + ASM SET_TAC[]; ALL_TAC] THEN + (* Closure of s in subtopology = real_interval[0,1] *) + SUBGOAL_THEN + `(subtopology euclideanreal (real_interval[&0,&1])) closure_of s = + real_interval[&0,&1]` ASSUME_TAC THENL + [MP_TAC(ISPECL [`euclideanreal`; `real_interval[&0,&1]`; + `s:real->bool`] CLOSURE_OF_SUBTOPOLOGY_OPEN) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + UNDISCH_TAC + `real_interval[&0,&1] SUBSET euclideanreal closure_of s` THEN + SET_TAC[]; ALL_TAC] THEN + (* a IN P by CLOSURE_OF_MINIMAL *) + SUBGOAL_THEN `(a:real) IN P` MP_TAC THENL [MP_TAC(ISPECL + [`subtopology euclideanreal (real_interval[&0,&1])`; + `s:real->bool`; `P:real->bool`] CLOSURE_OF_MINIMAL) THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; ALL_TAC] THEN + EXPAND_TAC "P" THEN REWRITE_TAC[IN_ELIM_THM; IN_MCBALL] THEN + MESON_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC MDIAMETER_LE THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[FORALL_IN_IMAGE_2] THEN + MAP_EVERY X_GEN_TAC [`u:real`; `v:real`] THEN STRIP_TAC THEN + SUBGOAL_THEN `(g:real->A) u IN mspace m /\ g v IN mspace m /\ + (x:A) IN mspace + m` STRIP_ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `mdist m ((g:real->A) u, x:A) + mdist m (x:A, g v)` THEN + CONJ_TAC THENL [ASM_SIMP_TAC[MDIST_TRIANGLE]; ALL_TAC] THEN + SUBGOAL_THEN `mdist m ((g:real->A) u, x:A) = mdist m (x,g u)` + SUBST1_TAC THENL [ASM_MESON_TAC[MDIST_SYM]; ALL_TAC] THEN + MATCH_MP_TAC REAL_LE_TRANS THEN EXISTS_TAC `e / &4 + e / &4` THEN + CONJ_TAC THENL [MATCH_MP_TAC REAL_LE_ADD2 THEN + ASM_SIMP_TAC[]; ASM_REAL_ARITH_TAC]; + ASM_REAL_ARITH_TAC]);; -let LOCALLY_COMPACT_IMP_COMPLETELY_METRIZABLE_SPACE = prove +(* Key: compact metrizable locally connected => *) +(* locally path connected. Use nearby paths + chains. *) +let COMPACT_METRIZABLE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED = prove (`!top:A topology. - metrizable_space top /\ locally_compact_space top - ==> completely_metrizable_space top`, - REWRITE_TAC[IMP_CONJ; FORALL_METRIZABLE_SPACE] THEN - X_GEN_TAC `m:A metric` THEN DISCH_TAC THEN - MP_TAC(ISPEC `m:A metric` METRIC_COMPLETION) THEN - REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`m':(A->real)metric`; `f:A->A->real`] THEN - STRIP_TAC THEN - SUBGOAL_THEN - `mtopology m homeomorphic_space - subtopology (mtopology m') (IMAGE (f:A->A->real) (mspace m))` - ASSUME_TAC THENL - [MP_TAC(ISPECL [`m:A metric`; `m':(A->real)metric`; `f:A->A->real`] - ISOMETRY_IMP_EMBEDDING_MAP) THEN - ASM_SIMP_TAC[SUBSET_REFL] THEN - DISCH_THEN(MP_TAC o MATCH_MP EMBEDDING_MAP_IMP_HOMEOMORPHIC_SPACE) THEN - REWRITE_TAC[TOPSPACE_MTOPOLOGY]; - ALL_TAC] THEN - FIRST_ASSUM(SUBST1_TAC o - MATCH_MP HOMEOMORPHIC_COMPLETELY_METRIZABLE_SPACE) THEN - FIRST_X_ASSUM(MP_TAC o - MATCH_MP HOMEOMORPHIC_LOCALLY_COMPACT_SPACE) THEN - ASM_REWRITE_TAC[] THEN DISCH_THEN(MP_TAC o MATCH_MP - (ONCE_REWRITE_RULE[IMP_CONJ_ALT] (REWRITE_RULE[CONJ_ASSOC] - LOCALLY_COMPACT_SUBSPACE_OPEN_IN_CLOSURE_OF))) THEN - ASM_REWRITE_TAC[HAUSDORFF_SPACE_MTOPOLOGY; SUBTOPOLOGY_MSPACE] THEN - ASM_REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN DISCH_TAC THEN - MATCH_MP_TAC COMPLETELY_METRIZABLE_SPACE_OPEN_IN THEN - ASM_SIMP_TAC[COMPLETELY_METRIZABLE_SPACE_MTOPOLOGY]);; + compact_space top /\ metrizable_space top /\ + locally_connected_space top + ==> locally_path_connected_space top`, + GEN_TAC THEN STRIP_TAC THEN + FIRST_X_ASSUM(X_CHOOSE_THEN `m:A metric` SUBST_ALL_TAC o + GEN_REWRITE_RULE I [metrizable_space]) THEN + REWRITE_TAC[LOCALLY_PATH_CONNECTED_SPACE_IM_KLEINEN] THEN + MAP_EVERY X_GEN_TAC [`v:A->bool`; `x:A`] THEN STRIP_TAC THEN + (* x IN mspace m *) + SUBGOAL_THEN `(x:A) IN mspace m` ASSUME_TAC THENL + [UNDISCH_TAC `open_in (mtopology m) (v:A->bool)` THEN + REWRITE_TAC[OPEN_IN_MTOPOLOGY] THEN ASM SET_TAC[]; ALL_TAC] THEN + (* Get r > 0 with mball(x, r) SUBSET v *) + SUBGOAL_THEN `?r. &0 < r /\ mball m (x:A, r) SUBSET v` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `open_in (mtopology m) (v:A->bool)` THEN + REWRITE_TAC[OPEN_IN_MTOPOLOGY] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `x:A`)) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* Get d from nearby path lemma for epsilon = r/2 *) + MP_TAC(ISPEC `m:A metric` COMPACT_LOCALLY_CONNECTED_NEARBY_PATH) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(MP_TAC o SPEC `r / &2`) THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `d:real` STRIP_ASSUME_TAC) THEN + (* Take u = mball(x, min(d, r/2)) *) + EXISTS_TAC `mball m (x:A, min d (r / &2))` THEN + SUBGOAL_THEN `&0 < min d (r / &2)` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + REPEAT CONJ_TAC THENL [(* open_in *) REWRITE_TAC[OPEN_IN_MBALL]; + (* x IN mball *) + ASM_SIMP_TAC[CENTRE_IN_MBALL]; + (* mball SUBSET v *) + MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC `mball m (x:A, r)` THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC MBALL_SUBSET_CONCENTRIC THEN ASM_REAL_ARITH_TAC; + (* !y. y IN mball ==> path_connected_in *) + X_GEN_TAC `y:A` THEN REWRITE_TAC[IN_MBALL] THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`x:A`; `y:A`]) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `g:real->A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `IMAGE (g:real->A) (real_interval[&0,&1])` THEN + REPEAT CONJ_TAC THENL + [(* path_connected_in *) + MATCH_MP_TAC PATH_CONNECTED_IN_PATH_IMAGE THEN ASM_REWRITE_TAC[]; + (* IMAGE SUBSET v *) + MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC `mball m (x:A, r)` THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[SUBSET; IN_MBALL] THEN X_GEN_TAC `z:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(z:A) IN mspace m` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC REAL_LET_TRANS THEN + EXISTS_TAC `mdiameter m (IMAGE (g:real->A) (real_interval[&0,&1]))` THEN + CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL + [MATCH_MP_TAC COMPACT_IN_IMP_MBOUNDED THEN + MATCH_MP_TAC COMPACT_IN_PATH_IMAGE THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[IN_IMAGE] THEN EXISTS_TAC `&0` THEN + ASM_REWRITE_TAC[IN_REAL_INTERVAL] THEN + CONV_TAC REAL_RAT_REDUCE_CONV]; ASM_REAL_ARITH_TAC]; + (* x IN IMAGE *) + REWRITE_TAC[IN_IMAGE] THEN EXISTS_TAC `&0` THEN + ASM_REWRITE_TAC[IN_REAL_INTERVAL] THEN CONV_TAC REAL_RAT_REDUCE_CONV; + (* y IN IMAGE *) + REWRITE_TAC[IN_IMAGE] THEN EXISTS_TAC `&1` THEN + ASM_REWRITE_TAC[IN_REAL_INTERVAL] THEN CONV_TAC REAL_RAT_REDUCE_CONV]]);; -let COMPLETELY_METRIZABLE_SPACE_IMP_GDELTA_IN = prove - (`!top s:A->bool. - metrizable_space top /\ s SUBSET topspace top /\ - completely_metrizable_space (subtopology top s) - ==> gdelta_in top s`, +(* Compact metrizable connected locally connected => path connected *) +let COMPACT_METRIZABLE_PEANO_IMP_PATH_CONNECTED = prove + (`!top:A topology. + compact_space top /\ metrizable_space top /\ + connected_space top /\ locally_connected_space top + ==> path_connected_space top`, + let LOCALLY_PATH_CONNECTED_CONNECTED_IMP_PATH_CONNECTED_SPACE = prove + (`!top:A topology. + locally_path_connected_space top /\ connected_space top + ==> path_connected_space top`, + MESON_TAC[PATH_CONNECTED_EQ_CONNECTED_SPACE]) in REPEAT STRIP_TAC THEN - MP_TAC(ISPECL [`top:A topology`; `s:A->bool`; - `subtopology top s:A topology`; `\x:A. x`] - LAVRENTIEV_EXTENSION) THEN - ASM_REWRITE_TAC[CONTINUOUS_MAP_ID; LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`u:A->bool`; `f:A->A`] THEN STRIP_TAC THEN - SUBGOAL_THEN `s:A->bool = u` (fun th -> ASM_REWRITE_TAC[th]) THEN - ASM_REWRITE_TAC[GSYM SUBSET_ANTISYM_EQ] THEN - FIRST_ASSUM(MP_TAC o MATCH_MP CONTINUOUS_MAP_IMAGE_SUBSET_TOPSPACE) THEN - ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY_SUBSET; GDELTA_IN_SUBSET] THEN - MATCH_MP_TAC(SET_RULE - `(!x. x IN u ==> f x = x) ==> IMAGE f u SUBSET s ==> u SUBSET s`) THEN - MP_TAC(ISPECL - [`subtopology top u:A topology`; `subtopology top u:A topology`; - `f:A->A`; `\x:A. x`] FORALL_IN_CLOSURE_OF_EQ) THEN - ASM_SIMP_TAC[CLOSURE_OF_SUBTOPOLOGY; CONTINUOUS_MAP_ID; SET_RULE - `s SUBSET u ==> u INTER s = s`] THEN - ANTS_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN - ASM_SIMP_TAC[HAUSDORFF_SPACE_SUBTOPOLOGY; - METRIZABLE_IMP_HAUSDORFF_SPACE] THEN - UNDISCH_TAC - `continuous_map (subtopology top u,subtopology top s) (f:A->A)` THEN - SIMP_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN ASM SET_TAC[]);; - -let COMPLETELY_METRIZABLE_SPACE_EQ_GDELTA_IN = prove - (`!top s:A->bool. - completely_metrizable_space top /\ s SUBSET topspace top - ==> (completely_metrizable_space (subtopology top s) <=> - gdelta_in top s)`, - MESON_TAC[COMPLETELY_METRIZABLE_SPACE_GDELTA_IN; - COMPLETELY_METRIZABLE_SPACE_IMP_GDELTA_IN; - COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE]);; - -let GDELTA_IN_EQ_COMPLETELY_METRIZABLE_SPACE = prove - (`!top s:A->bool. - completely_metrizable_space top - ==> (gdelta_in top s <=> - s SUBSET topspace top /\ - completely_metrizable_space (subtopology top s))`, - MESON_TAC[GDELTA_IN_ALT; COMPLETELY_METRIZABLE_SPACE_EQ_GDELTA_IN]);; + MATCH_MP_TAC(ISPEC `top:A topology` + LOCALLY_PATH_CONNECTED_CONNECTED_IMP_PATH_CONNECTED_SPACE) THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC COMPACT_METRIZABLE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED + THEN + ASM_REWRITE_TAC[]);; (* ------------------------------------------------------------------------- *) -(* Basic definition of the small inductive dimension relation ind t <= n. *) -(* We plan to prove most of the theorems in R^n so this is as good a *) -(* definition as any other, but the present stuff works in any top space. *) +(* Hahn-Mazurkiewicz theorem (backward direction). *) +(* Whyburn, Analytic Topology, Theorem (4.1); H-Y Theorem 3-30; *) +(* Willard, General Topology, Theorem 31.5. *) +(* Every compact, connected, locally connected, metrizable, nonempty space *) +(* is a continuous image of [0,1]. *) (* ------------------------------------------------------------------------- *) -parse_as_infix("dimension_le",(12,"right"));; +(* Gap-filling extension: extend continuous surjection from closed C in [0,1] *) +(* Proof sketch: X is path-connected (Peano space). For each gap (a,b) of + [0,1] \ C, connect f(a) to f(b) by a path. Use ULPC for diameter control + near boundary points of C. Define F by f on C and paths on gaps. *) +let PEANO_GAP_FILLING_EXTENSION = prove + (`!top:A topology (f:real->A) C. + compact_space top /\ metrizable_space top /\ + connected_space top /\ locally_connected_space top /\ + ~(topspace top = {}) /\ + C SUBSET real_interval[&0,&1] /\ + closed_in (subtopology euclideanreal (real_interval[&0,&1])) C /\ + continuous_map (subtopology euclideanreal C, top) f /\ + IMAGE f C = topspace top + ==> ?F. continuous_map + (subtopology euclideanreal (real_interval[&0,&1]), top) F /\ + IMAGE F (real_interval[&0,&1]) = topspace + top`, + let SUP_IN_REAL_CLOSED = prove + (`!s. real_closed s /\ ~(s = {}) /\ (?b. !x. x IN s ==> x <= b) + ==> sup s IN s`, + GEN_TAC THEN STRIP_TAC THEN + ASM_CASES_TAC `sup s IN (s:real->bool)` THENL [ASM_REWRITE_TAC[]; + ALL_TAC] THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [real_closed]) THEN + REWRITE_TAC[real_open; IN_DIFF; IN_UNIV] THEN + DISCH_THEN(MP_TAC o SPEC `sup s`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `e:real` STRIP_ASSUME_TAC) THEN + MP_TAC(SPECL [`s:real->bool`; `sup s - e`] SUP_APPROACH) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ASM_REAL_ARITH_TAC]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `y:real` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(y:real) <= sup s` ASSUME_TAC THENL + [MP_TAC(ISPECL [`s:real->bool`; `y:real`] ELEMENT_LE_SUP) THEN + ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `abs(y - sup s) < e` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN ASM_MESON_TAC[]) in + let INF_IN_REAL_CLOSED = prove + (`!s. real_closed s /\ ~(s = {}) /\ (?b. !x. x IN s ==> b <= x) + ==> inf s IN s`, + GEN_TAC THEN STRIP_TAC THEN + ASM_CASES_TAC `inf s IN (s:real->bool)` THENL [ASM_REWRITE_TAC[]; + ALL_TAC] THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [real_closed]) THEN + REWRITE_TAC[real_open; IN_DIFF; IN_UNIV] THEN + DISCH_THEN(MP_TAC o SPEC `inf s`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `e:real` STRIP_ASSUME_TAC) THEN + MP_TAC(SPEC `s:real->bool` INF) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN STRIP_TAC THEN + SUBGOAL_THEN `inf s + e / &2 <= inf s` MP_TAC THENL [FIRST_X_ASSUM + MATCH_MP_TAC THEN + X_GEN_TAC `y:real` THEN DISCH_TAC THEN + SUBGOAL_THEN `inf s <= (y:real)` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `~(abs(y - inf s) < e)` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + ASM_REAL_ARITH_TAC; + ASM_REAL_ARITH_TAC]) in + let DIAMETER_CONTROLLED_PATH_CHOICE = prove + (`!m:A metric. + compact_space (mtopology m) /\ locally_connected_space (mtopology m) /\ + connected_space (mtopology m) /\ ~(mspace m = {}) + ==> ?PP. (!x y. x IN mspace m /\ y IN mspace m + ==> path_in (mtopology m) (PP x y) /\ + PP x y (&0) = x /\ PP x y (&1) = y /\ + IMAGE (PP x y) (real_interval[&0,&1]) + SUBSET mspace m) /\ + (!e. &0 < e + ==> ?d. &0 < d /\ + !x y. x IN mspace m /\ y IN mspace m /\ + mdist m (x,y) < d + ==> mdiameter m + (IMAGE (PP x y) + (real_interval[&0,&1])) < + e)`, + GEN_TAC THEN STRIP_TAC THEN + (* Get path_connected_space *) + SUBGOAL_THEN + `path_connected_space (mtopology (m:A metric))` + ASSUME_TAC THENL + [MATCH_MP_TAC COMPACT_METRIZABLE_PEANO_IMP_PATH_CONNECTED THEN + ASM_REWRITE_TAC[METRIZABLE_SPACE_MTOPOLOGY]; ALL_TAC] THEN + (* Skolemize ULPC to get DELTA function *) + MP_TAC(ISPEC `m:A metric` COMPACT_LOCALLY_CONNECTED_NEARBY_PATH) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o REWRITE_RULE[RIGHT_IMP_EXISTS_THM; SKOLEM_THM]) THEN + DISCH_THEN(X_CHOOSE_THEN `DELTA:real->real` (LABEL_TAC "ULPC")) THEN + (* For each (x,y), produce a path with controlled diameter *) + SUBGOAL_THEN `!x y:A. x IN mspace m /\ y IN mspace m + ==> ?g. path_in (mtopology m) g /\ g(&0) = x /\ g(&1) = y /\ + IMAGE g (real_interval[&0,&1]) SUBSET mspace m /\ + !e. &0 < e /\ mdist m (x:A,y) < DELTA e + ==> mdiameter m (IMAGE g (real_interval[&0,&1])) + < e + mdist m (x,y)` + ASSUME_TAC THENL [REPEAT GEN_TAC THEN STRIP_TAC THEN + ASM_CASES_TAC `x:A = y` THENL + [(* Case x = y: use constant path *) + EXISTS_TAC `(\t:real. x:A)` THEN REWRITE_TAC[] THEN + ASM_REWRITE_TAC[] THEN + REPEAT CONJ_TAC THENL [REWRITE_TAC[path_in; CONTINUOUS_MAP_CONST; + TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY; TOPSPACE_MTOPOLOGY] THEN + DISJ2_TAC THEN ASM_REWRITE_TAC[]; + SUBGOAL_THEN `~(real_interval[&0,&1] = {})` ASSUME_TAC THENL + [REWRITE_TAC[REAL_INTERVAL_NE_EMPTY] THEN REAL_ARITH_TAC; ALL_TAC] THEN + ASM_SIMP_TAC[IMAGE_CONST] THEN ASM SET_TAC[]; + REPEAT STRIP_TAC THEN + SUBGOAL_THEN `~(real_interval[&0,&1] = {})` ASSUME_TAC THENL + [REWRITE_TAC[REAL_INTERVAL_NE_EMPTY] THEN REAL_ARITH_TAC; ALL_TAC] THEN + ASM_SIMP_TAC[IMAGE_CONST; MDIAMETER_SING] THEN + ASM_SIMP_TAC[MDIST_REFL] THEN ASM_REAL_ARITH_TAC]; + (* Case x <> y *) + ASM_CASES_TAC `{e:real | &0 < e /\ mdist m (x:A,y) < DELTA e} = {}` THENL + [(* Sub-case: S empty - any path works, condition is vacuous *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [path_connected_space]) THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY] THEN + DISCH_THEN(MP_TAC o SPECL [`x:A`; `y:A`]) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `g:real->A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `g:real->A` THEN ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [UNDISCH_TAC `path_in (mtopology (m:A metric)) (g:real->A)` THEN + REWRITE_TAC[path_in; continuous_map; TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY; + TOPSPACE_MTOPOLOGY] THEN MESON_TAC[SUBSET; IN_IMAGE]; + REPEAT STRIP_TAC THEN + UNDISCH_TAC `{e:real | &0 < e /\ mdist m (x:A,y) < DELTA e} = {}` THEN + REWRITE_TAC[EXTENSION; IN_ELIM_THM; NOT_IN_EMPTY] THEN + DISCH_THEN(MP_TAC o SPEC `e:real`) THEN ASM_REWRITE_TAC[]]; + (* Sub-case: S nonempty - use infimum argument *) + ABBREV_TAC `S0 = {e:real | &0 < e /\ mdist m (x:A,y) < DELTA e}` THEN + SUBGOAL_THEN `?b:real. !e. e IN S0 ==> b <= e` ASSUME_TAC THENL + [EXISTS_TAC `&0` THEN EXPAND_TAC "S0" THEN + REWRITE_TAC[IN_ELIM_THM] THEN REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `mdist m (x:A,y) > &0` ASSUME_TAC THENL + [ASM_MESON_TAC[MDIST_POS_EQ; REAL_LT_LE; real_gt]; ALL_TAC] THEN + (* inf S0 + mdist > inf S0, so by INF_APPROACH get e' in S0 *) + SUBGOAL_THEN `inf S0 < inf S0 + mdist m (x:A,y)` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + MP_TAC(SPECL [`S0:real->bool`; `inf S0 + mdist m (x:A,y)`] + INF_APPROACH) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `e0:real` STRIP_ASSUME_TAC) THEN + (* e0 IN S0 means 0 < e0 and mdist < DELTA(e0) *) + SUBGOAL_THEN `&0 < e0 /\ mdist m (x:A,y) < DELTA(e0:real)` + STRIP_ASSUME_TAC THENL [UNDISCH_TAC `e0 IN (S0:real->bool)` THEN + EXPAND_TAC "S0" THEN REWRITE_TAC[IN_ELIM_THM]; ALL_TAC] THEN + (* Use ULPC with e = e0 to get path *) + USE_THEN "ULPC" (MP_TAC o SPEC `e0:real`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `gg:A->A->real->A` (MP_TAC o SPECL [`x:A`; `y:A`]))) THEN + ASM_REWRITE_TAC[] THEN STRIP_TAC THEN + EXISTS_TAC `(gg:A->A->real->A) x y` THEN ASM_REWRITE_TAC[] THEN + REPEAT STRIP_TAC THEN + (* Need: diam(g) < e + mdist(x,y) *) + (* Have: diam(g) < e0, e0 < inf S0 + mdist, and we show inf S0 <= e *) + SUBGOAL_THEN `inf S0 <= (e:real)` ASSUME_TAC THENL + [MATCH_MP_TAC INF_LE_ELEMENT THEN CONJ_TAC THENL [ASM_MESON_TAC[]; + EXPAND_TAC "S0" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_REWRITE_TAC[]]; ALL_TAC] THEN + ASM_REAL_ARITH_TAC]]; + (* Skolemize to get PP *) + FIRST_X_ASSUM(MP_TAC o + REWRITE_RULE[RIGHT_IMP_EXISTS_THM; SKOLEM_THM]) THEN + DISCH_THEN(X_CHOOSE_THEN `PP:A->A->real->A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `PP:A->A->real->A` THEN CONJ_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + (* Diameter control: given e, use d = min(DELTA(e/2), e/2) *) + X_GEN_TAC `e:real` THEN DISCH_TAC THEN + SUBGOAL_THEN `&0 < e / &2` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + USE_THEN "ULPC" (MP_TAC o SPEC `e / &2`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (K ALL_TAC)) THEN + EXISTS_TAC `min (DELTA(e / &2)) (e / &2)` THEN + CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + MAP_EVERY X_GEN_TAC [`x:A`; `y:A`] THEN STRIP_TAC THEN + SUBGOAL_THEN `mdist m (x:A,y) < DELTA(e / &2)` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `mdist m (x:A,y) < e / &2` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN + `mdiameter m (IMAGE ((PP:A->A->real->A) x y) (real_interval[&0,&1])) + < e / &2 + mdist m (x:A,y)` ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPECL [`x:A`; `y:A`]) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(fun th -> MP_TAC(SPEC `e / &2` + (CONJUNCT2(CONJUNCT2(CONJUNCT2(CONJUNCT2 th)))))) THEN + ASM_REWRITE_TAC[]; ASM_REAL_ARITH_TAC]]) in + let c_in_01_tac thms = + UNDISCH_TAC `(C:real->bool) SUBSET real_interval[&0,&1]` THEN + REWRITE_TAC[SUBSET; IN_REAL_INTERVAL] THEN MESON_TAC thms in + let sup_in_C_tac = + MATCH_MP_TAC SUP_IN_REAL_CLOSED THEN + CONJ_TAC THENL [MATCH_MP_TAC REAL_CLOSED_INTER THEN + ASM_REWRITE_TAC[REAL_CLOSED_HALFSPACE_LE]; ASM_REWRITE_TAC[] THEN + EXISTS_TAC `&1` THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN c_in_01_tac []] in + let inf_in_C_tac = + MATCH_MP_TAC INF_IN_REAL_CLOSED THEN + CONJ_TAC THENL [MATCH_MP_TAC REAL_CLOSED_INTER THEN + ASM_REWRITE_TAC[GSYM real_ge; REAL_CLOSED_HALFSPACE_GE]; + ASM_REWRITE_TAC[] THEN EXISTS_TAC `&0` THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN c_in_01_tac []] in + let x_in_01_tac = + SUBGOAL_THEN `x IN real_interval[&0,&1]` MP_TAC THENL + [ASM SET_TAC[]; REWRITE_TAC[IN_REAL_INTERVAL] THEN REAL_ARITH_TAC] in + let continuous_to_metric_tac = + ONCE_REWRITE_TAC + [SYM(ASSUME `mtopology (m:A metric) = (top:A topology)`)] THEN + REWRITE_TAC[CONTINUOUS_MAP_TO_METRIC; + TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] in + let f_in_top_tac = + UNDISCH_TAC `!t:real. t IN C ==> (f:real->A) t IN topspace top` THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[] in + let div_bounds_tac = + CONJ_TAC THENL [MATCH_MP_TAC REAL_LE_DIV THEN ASM_REAL_ARITH_TAC; + ASM_SIMP_TAC[REAL_LE_LDIV_EQ] THEN ASM_REAL_ARITH_TAC] in + let real_closed_C_tac = + SUBGOAL_THEN `real_closed (C:real->bool)` ASSUME_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_TRANS_FULL; REAL_CLOSED_IN; + REAL_CLOSED_REAL_INTERVAL]; ALL_TAC] in + let min_pos_tac = + CONJ_TAC THENL [REWRITE_TAC[REAL_LT_MIN] THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC REAL_LT_MUL THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + CONJ_TAC THENL [REAL_ARITH_TAC; ALL_TAC] in + let mdist_sym_subst tm = + SUBGOAL_THEN tm SUBST1_TAC THENL [MATCH_MP_TAC MDIST_SYM THEN + ASM_MESON_TAC[]; ALL_TAC] in + let element_le_sup_inter_tac = + MATCH_MP_TAC ELEMENT_LE_SUP THEN CONJ_TAC THENL + [EXISTS_TAC `&1` THEN REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + ASM_MESON_TAC[]; + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN ASM_REWRITE_TAC[] THEN + TRY ASM_REAL_ARITH_TAC] in + let inf_le_element_inter_tac = + MATCH_MP_TAC INF_LE_ELEMENT THEN CONJ_TAC THENL + [EXISTS_TAC `&0` THEN REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + ASM_MESON_TAC[]; + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN ASM_REWRITE_TAC[] THEN + TRY ASM_REAL_ARITH_TAC] in + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* X is path-connected *) + SUBGOAL_THEN `path_connected_space (top:A topology)` ASSUME_TAC THENL + [MATCH_MP_TAC COMPACT_METRIZABLE_PEANO_IMP_PATH_CONNECTED THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* For any x,y in topspace top, there is a path *) + SUBGOAL_THEN `!x y:A. x IN topspace top /\ y IN topspace top + ==> ?g. path_in top g /\ g(&0) = x /\ g(&1) = y` + (LABEL_TAC "PATHS") THENL [REWRITE_TAC[GSYM path_component_of] THEN + ASM_MESON_TAC[PATH_CONNECTED_SPACE_IFF_PATH_COMPONENT]; ALL_TAC] THEN + (* C nonempty *) + SUBGOAL_THEN `~(C:real->bool = {})` ASSUME_TAC THENL + [DISCH_TAC THEN UNDISCH_TAC `IMAGE (f:real->A) C = topspace top` THEN + ASM_REWRITE_TAC[IMAGE_CLAUSES] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + (* f maps C into topspace top *) + SUBGOAL_THEN `IMAGE (f:real->A) C SUBSET topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET_REFL]; ALL_TAC] THEN + SUBGOAL_THEN `!t. t IN C ==> (f:real->A) t IN topspace top` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + (* Pick a fixed point x0 in topspace top *) + SUBGOAL_THEN `?x0:A. x0 IN topspace top` STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[MEMBER_NOT_EMPTY]; ALL_TAC] THEN + (* Main construction: existence of continuous extension FF *) + SUBGOAL_THEN `?FF:real->A. + (!t. t IN C ==> FF t = f t) /\ + (!t. t IN real_interval[&0,&1] ==> FF t IN topspace top) /\ + continuous_map + (subtopology euclideanreal (real_interval[&0,&1]), top) FF` + STRIP_ASSUME_TAC THENL [(* This is the core gap-filling construction *) + (* Extract metric from metrizable_space *) + SUBGOAL_THEN `?m:A metric. mtopology m = top` + (X_CHOOSE_THEN `m:A metric` ASSUME_TAC) THENL + [ASM_MESON_TAC[metrizable_space]; ALL_TAC] THEN + SUBGOAL_THEN `mspace (m:A metric) = topspace (top:A topology)` ASSUME_TAC + THENL + [ASM_MESON_TAC[TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + (* Get PP with diameter control from DIAMETER_CONTROLLED_PATH_CHOICE *) + MP_TAC(ISPEC `m:A metric` DIAMETER_CONTROLLED_PATH_CHOICE) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `PP:A->A->real->A` MP_TAC) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(CONJUNCTS_THEN2 (LABEL_TAC "PP") (LABEL_TAC "DIAM_CTRL")) THEN + EXISTS_TAC + `\t:real. if t IN C then (f:real->A) t + else if (C:real->bool) INTER {s:real | s <= t} = {} + then f(inf C) + else if (C:real->bool) INTER {s:real | t <= s} = {} + then f(sup C) + else (PP:A->A->real->A) + (f(sup (C INTER {s:real | s <= t}))) + (f(inf (C INTER {s:real | t <= s}))) + ((t - sup (C INTER {s:real | s <= t})) / + (inf (C INTER {s:real | t <= s}) - sup (C INTER {s:real + | s <= t})))` THEN + BETA_TAC THEN REPEAT CONJ_TAC THENL + [(* 1. Agreement: !t. t IN C ==> FF t = f t *) GEN_TAC THEN DISCH_TAC THEN + COND_CASES_TAC THENL [REFL_TAC; ASM_MESON_TAC[]]; + (* 2. Maps into topspace *) + X_GEN_TAC `t:real` THEN DISCH_TAC THEN real_closed_C_tac THEN + COND_CASES_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN COND_CASES_TAC THENL + [SUBGOAL_THEN `inf C IN (C:real->bool)` (fun th -> ASM_MESON_TAC[th]) THEN + MATCH_MP_TAC INF_IN_REAL_CLOSED THEN ASM_REWRITE_TAC[] THEN + c_in_01_tac [REAL_LE_REFL]; ALL_TAC] THEN COND_CASES_TAC THENL + [SUBGOAL_THEN `sup C IN (C:real->bool)` (fun th -> ASM_MESON_TAC[th]) THEN + MATCH_MP_TAC SUP_IN_REAL_CLOSED THEN ASM_REWRITE_TAC[] THEN + c_in_01_tac [REAL_LE_REFL]; ALL_TAC] THEN + ABBREV_TAC `CL = C INTER {s:real | s <= t}` THEN + ABBREV_TAC `CR = C INTER {s:real | t <= s}` THEN + SUBGOAL_THEN `real_closed (CL:real->bool)` ASSUME_TAC THENL + [EXPAND_TAC "CL" THEN MATCH_MP_TAC REAL_CLOSED_INTER THEN + ASM_REWRITE_TAC[REAL_CLOSED_HALFSPACE_LE]; ALL_TAC] THEN + SUBGOAL_THEN `real_closed (CR:real->bool)` ASSUME_TAC THENL + [EXPAND_TAC "CR" THEN MATCH_MP_TAC REAL_CLOSED_INTER THEN + ASM_REWRITE_TAC[GSYM real_ge; REAL_CLOSED_HALFSPACE_GE]; ALL_TAC] THEN + SUBGOAL_THEN `(?b. !x:real. x IN CL ==> x <= b)` ASSUME_TAC THENL + [EXISTS_TAC `&1` THEN EXPAND_TAC "CL" THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN c_in_01_tac []; ALL_TAC] THEN + SUBGOAL_THEN `(?b:real. !x. x IN CR ==> b <= x)` ASSUME_TAC THENL + [EXISTS_TAC `&0` THEN EXPAND_TAC "CR" THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN c_in_01_tac []; ALL_TAC] THEN + SUBGOAL_THEN `sup CL IN (CL:real->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC SUP_IN_REAL_CLOSED THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `inf CR IN (CR:real->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC INF_IN_REAL_CLOSED THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `sup CL IN (C:real->bool)` ASSUME_TAC THENL + [UNDISCH_TAC `sup CL IN (CL:real->bool)` THEN + EXPAND_TAC "CL" THEN REWRITE_TAC[IN_INTER] THEN MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `inf CR IN (C:real->bool)` ASSUME_TAC THENL + [UNDISCH_TAC `inf CR IN (CR:real->bool)` THEN + EXPAND_TAC "CR" THEN REWRITE_TAC[IN_INTER] THEN MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(f:real->A) (sup CL) IN topspace top` ASSUME_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(f:real->A) (inf CR) IN topspace top` ASSUME_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `path_in top ((PP:A->A->real->A) (f(sup CL)) (f(inf CR)))` + ASSUME_TAC THENL [USE_THEN "PP" (MP_TAC o SPECL + [`(f:real->A) (sup CL)`; `(f:real->A) (inf CR)`]) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN SIMP_TAC[]; ALL_TAC] THEN + (* Use path_in: continuous_map ==> membership in topspace *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [path_in]) THEN + REWRITE_TAC[continuous_map; TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN + DISCH_THEN(MATCH_MP_TAC o CONJUNCT1) THEN + (* Goal: (t - sup CL) / (inf CR - sup CL) IN real_interval[&0,&1] *) + REWRITE_TAC[IN_REAL_INTERVAL] THEN + SUBGOAL_THEN `sup CL <= t` ASSUME_TAC THENL + [UNDISCH_TAC `sup CL IN (CL:real->bool)` THEN + EXPAND_TAC "CL" THEN REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `t <= inf CR` ASSUME_TAC THENL [UNDISCH_TAC + `inf CR IN (CR:real->bool)` THEN + EXPAND_TAC "CR" THEN REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `sup CL < inf CR` ASSUME_TAC THENL [ASM_CASES_TAC + `sup CL = inf CR` THENL + [SUBGOAL_THEN `t = sup CL` ASSUME_TAC THENL + [UNDISCH_TAC `sup CL <= t` THEN UNDISCH_TAC `t <= inf CR` THEN + UNDISCH_TAC `sup CL = inf CR` THEN REAL_ARITH_TAC; ALL_TAC] THEN + UNDISCH_TAC `~(t IN (C:real->bool))` THEN ASM_MESON_TAC[]; + UNDISCH_TAC `~(sup CL = inf CR)` THEN + UNDISCH_TAC `sup CL <= t` THEN UNDISCH_TAC `t <= inf CR` THEN + REAL_ARITH_TAC]; ALL_TAC] THEN + SUBGOAL_THEN `&0 < inf CR - sup CL` ASSUME_TAC THENL + [UNDISCH_TAC `sup CL < inf CR` THEN REAL_ARITH_TAC; ALL_TAC] THEN + CONJ_TAC THENL [MATCH_MP_TAC REAL_LE_DIV THEN + UNDISCH_TAC `sup CL <= t` THEN + UNDISCH_TAC `sup CL < inf CR` THEN REAL_ARITH_TAC; + ASM_SIMP_TAC[REAL_LE_LDIV_EQ] THEN UNDISCH_TAC `t <= inf CR` THEN + UNDISCH_TAC `sup CL <= t` THEN REAL_ARITH_TAC]; + (* 3. Continuity of FF *) + (* Convert codomain top to mtopology m for metric characterization *) + continuous_to_metric_tac THEN CONV_TAC(ONCE_DEPTH_CONV BETA_CONV) THEN + X_GEN_TAC `t0:real` THEN DISCH_TAC THEN X_GEN_TAC `r:real` THEN + DISCH_TAC THEN + (* Case split on t0 IN C *) + ASM_CASES_TAC `t0 IN (C:real->bool)` THENL + [(* Case t0 IN C: FF(t0) = f(t0) *) ASM_REWRITE_TAC[] THEN + (* Get delta from diameter control for r/3 *) + USE_THEN "DIAM_CTRL" (MP_TAC o SPEC `r / &3`) THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `dc:real` + (CONJUNCTS_THEN2 ASSUME_TAC (LABEL_TAC "DC"))) THEN + (* Get delta from continuity of f at t0 in the metric m *) + SUBGOAL_THEN `?df. &0 < df /\ + !t. t IN C /\ abs(t - t0) < df + ==> mdist m ((f:real->A) t, f t0) < min (dc / &2) (r / &3)` + (X_CHOOSE_THEN `df:real` STRIP_ASSUME_TAC) THENL + [(* Derive from continuous_map (subtopology euclideanreal C, top) f *) + MP_TAC(ASSUME + `continuous_map (subtopology euclideanreal C, (top:A topology)) + (f:real->A)`) THEN continuous_to_metric_tac THEN + DISCH_THEN(MP_TAC o SPEC `t0:real`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC `min (dc / &2) (r / &3)`) THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `u:real->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [OPEN_IN_SUBTOPOLOGY]) THEN + DISCH_THEN(X_CHOOSE_THEN `V:real->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `t0 IN (V:real->bool)` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + UNDISCH_TAC `open_in euclideanreal (V:real->bool)` THEN + REWRITE_TAC[GSYM REAL_OPEN_IN; real_open] THEN + DISCH_THEN(MP_TAC o SPEC `t0:real`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `df:real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `df:real` THEN ASM_REWRITE_TAC[] THEN X_GEN_TAC `t:real` THEN + STRIP_TAC THEN + SUBGOAL_THEN `(t:real) IN V` ASSUME_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(t:real) IN u` ASSUME_TAC THENL + [ASM_REWRITE_TAC[IN_INTER] THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + UNDISCH_TAC + `!y:real. y IN u + ==> (f:real->A) y IN mball m (f t0,min (dc / &2) (r / &3))` THEN + DISCH_THEN(MP_TAC o SPEC `t:real`) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[IN_MBALL] THEN ASM_MESON_TAC[MDIST_SYM]; ALL_TAC] THEN + SUBGOAL_THEN `?dr:real. &0 < dr /\ dr <= df /\ + (!t'. t0 < t' /\ t' < t0 + dr /\ + t' IN real_interval[&0,&1] /\ ~(t' IN C) /\ + ~(C INTER {s:real | s <= t'} = {}) /\ + ~(C INTER {s:real | t' <= s} = {}) + ==> inf(C INTER {s:real | t' <= s}) < t0 + df \/ + (sup(C INTER {s:real | s <= t'}) = t0 /\ + mdist m ((PP:A->A->real->A) (f t0) + (f (inf(C INTER {s:real | t' <= s}))) + ((t' - t0) / + (inf(C INTER {s:real | t' <= s}) - t0)), + (f:real->A) t0) < r))` + (X_CHOOSE_THEN `dr:real` (fun th -> + let th1,th2 = CONJ_PAIR th in + let th2a,th3 = CONJ_PAIR th2 in + ASSUME_TAC th1 THEN ASSUME_TAC th2a THEN LABEL_TAC "DR" th3)) THENL + [ASM_CASES_TAC `?c:real. c IN C /\ t0 < c /\ c < t0 + df` THENL + [(* C-point in (t0, t0+df): delta_r = c - t0, all gaps have both close *) + FIRST_X_ASSUM(X_CHOOSE_THEN `cr:real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `cr - t0` THEN + REPLICATE_TAC 2 + (CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC]) THEN + REPEAT STRIP_TAC THEN DISJ1_TAC THEN + MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `cr:real` THEN + CONJ_TAC THENL [MATCH_MP_TAC INF_LE_ELEMENT THEN CONJ_TAC THENL + [EXISTS_TAC `&0` THEN REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + REPEAT STRIP_TAC THEN + UNDISCH_TAC `C SUBSET real_interval[&0,&1]` THEN + REWRITE_TAC[SUBSET; IN_REAL_INTERVAL] THEN + ASM_MESON_TAC[REAL_LE_TRANS]; + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ASM_REAL_ARITH_TAC]]; + ASM_REAL_ARITH_TAC]; + (* No C-point in (t0, t0+df) *) + real_closed_C_tac THEN + ASM_CASES_TAC `C INTER {s:real | t0 + df <= s} = {}` THENL + [(* vacuous *) + EXISTS_TAC `df:real` THEN CONJ_TAC THENL + [UNDISCH_TAC `&0 < df` THEN REAL_ARITH_TAC; ALL_TAC] THEN + CONJ_TAC THENL [REAL_ARITH_TAC; ALL_TAC] THEN X_GEN_TAC `t':real` THEN + STRIP_TAC THEN + SUBGOAL_THEN `C INTER {s:real | t' <= s} = {}` (fun th -> + ASM_MESON_TAC[th]) THEN + REWRITE_TAC[EXTENSION; IN_INTER; IN_ELIM_THM; NOT_IN_EMPTY] THEN + X_GEN_TAC `c:real` THEN REWRITE_TAC[DE_MORGAN_THM] THEN + ASM_CASES_TAC `(c:real) IN C` THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[REAL_NOT_LE] THEN + MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `t0:real` THEN + ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `~(?c:real. c IN C /\ t0 < c /\ c < t0 + df)` THEN + REWRITE_TAC[NOT_EXISTS_THM; DE_MORGAN_THM; REAL_NOT_LT] THEN + DISCH_THEN(MP_TAC o SPEC `c:real`) THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `C INTER {s:real | t0 + df <= s} = {}` THEN + REWRITE_TAC[EXTENSION; IN_INTER; IN_ELIM_THM; NOT_IN_EMPTY] THEN + DISCH_THEN(MP_TAC o SPEC `c:real`) THEN ASM_REWRITE_TAC[] THEN + REAL_ARITH_TAC; + (* C has points >= t0+df: nonempty case *) + ABBREV_TAC `b0 = inf(C INTER {s:real | t0 + df <= s})` THEN + SUBGOAL_THEN `(b0:real) IN C /\ t0 + df <= b0` + STRIP_ASSUME_TAC THENL [SUBGOAL_THEN + `b0 IN C INTER {s:real | t0 + df <= s}` MP_TAC THENL + [EXPAND_TAC "b0" THEN inf_in_C_tac; + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN STRIP_TAC THEN + ASM_REWRITE_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `(f:real->A) t0 IN topspace top /\ f b0 IN topspace top` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + USE_THEN "PP" (MP_TAC o SPECL + [`(f:real->A) t0`; `(f:real->A) b0`]) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN STRIP_TAC THEN + SUBGOAL_THEN `?del'. &0 < del' /\ + !y. y IN real_interval[&0,&1] /\ abs(y) < del' + ==> mdist (m:A metric) ((f:real->A) t0, + (PP:A->A->real->A) (f t0) (f (b0:real)) y) < r` + (X_CHOOSE_THEN `del':real` STRIP_ASSUME_TAC) THENL [MP_TAC(ISPECL + [`submetric real_euclidean_metric (real_interval[&0,&1])`; + `(m:A metric)`; + `(PP:A->A->real->A) ((f:real->A) t0) (f b0)`] + METRIC_CONTINUOUS_MAP) THEN + REWRITE_TAC[MTOPOLOGY_SUBMETRIC; MTOPOLOGY_REAL_EUCLIDEAN_METRIC] THEN + SUBGOAL_THEN `mtopology (m:A metric) = top` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[GSYM path_in] THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o CONJUNCT2) THEN + DISCH_THEN(MP_TAC o SPECL [`&0`; `r:real`]) THEN + ASM_REWRITE_TAC[SUBMETRIC; REAL_EUCLIDEAN_METRIC; INTER_UNIV] THEN + ANTS_TAC THENL + [REWRITE_TAC[IN_REAL_INTERVAL] THEN REAL_ARITH_TAC; + ALL_TAC] THEN + REWRITE_TAC[REAL_SUB_RZERO] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `t0 < (b0:real)` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + EXISTS_TAC `min df (del' * (b0 - t0))` THEN min_pos_tac THEN + X_GEN_TAC `t':real` THEN STRIP_TAC THEN DISJ2_TAC THEN + SUBGOAL_THEN `C INTER {s:real | t' <= s} = C INTER {s | t0 + df <= s}` + ASSUME_TAC THENL [REWRITE_TAC[EXTENSION; IN_INTER; IN_ELIM_THM] THEN + X_GEN_TAC `c':real` THEN EQ_TAC THEN STRIP_TAC THEN + ASM_REWRITE_TAC[] THENL + [UNDISCH_TAC `~(?c:real. c IN C /\ t0 < c /\ c < t0 + df)` THEN + REWRITE_TAC[NOT_EXISTS_THM; DE_MORGAN_THM; REAL_NOT_LT] THEN + DISCH_THEN(MP_TAC o SPEC `c':real`) THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `t' <= (c':real)` THEN UNDISCH_TAC `t0 < (t':real)` THEN + REAL_ARITH_TAC; + UNDISCH_TAC `t' < t0 + min df (del' * ((b0:real) - t0))` THEN + UNDISCH_TAC `t0 + df <= (c':real)` THEN + REAL_ARITH_TAC]; ALL_TAC] THEN + SUBGOAL_THEN `inf(C INTER {s:real | t' <= s}) = b0` + ASSUME_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [MATCH_MP_TAC REAL_SUP_UNIQUE THEN + CONJ_TAC THENL [REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + X_GEN_TAC `c':real` THEN STRIP_TAC THEN + UNDISCH_TAC `~(?c:real. c IN C /\ t0 < c /\ c < t0 + df)` THEN + REWRITE_TAC[NOT_EXISTS_THM; DE_MORGAN_THM; REAL_NOT_LT] THEN + DISCH_THEN(MP_TAC o SPEC `c':real`) THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `c' <= (t':real)` THEN + UNDISCH_TAC `t' < t0 + min df (del' * ((b0:real) - t0))` THEN + REAL_ARITH_TAC; + X_GEN_TAC `b2:real` THEN DISCH_TAC THEN EXISTS_TAC `t0:real` THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN ASM_REWRITE_TAC[] THEN + ASM_REAL_ARITH_TAC]; + (* mdist bound: parameter properties *) + SUBGOAL_THEN `(t' - t0) / (b0 - t0) IN real_interval[&0,&1]` + ASSUME_TAC THENL [REWRITE_TAC[IN_REAL_INTERVAL] THEN + SUBGOAL_THEN `&0 < b0 - t0` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN div_bounds_tac; ALL_TAC] THEN + SUBGOAL_THEN `abs((t' - t0) / (b0 - t0)) < del'` + ASSUME_TAC THENL [REWRITE_TAC[REAL_ABS_DIV] THEN + SUBGOAL_THEN `abs(t' - t0) = t' - t0` SUBST1_TAC THENL + [REWRITE_TAC[REAL_ABS_REFL] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `abs(b0 - t0) = b0 - t0` SUBST1_TAC THENL + [REWRITE_TAC[REAL_ABS_REFL] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + ASM_SIMP_TAC[REAL_LT_LDIV_EQ; + REAL_ARITH `t0 < b0 ==> &0 < b0 - t0`] THEN + UNDISCH_TAC `t' < t0 + min df (del' * (b0 - t0))` THEN + REAL_ARITH_TAC; ALL_TAC] THEN + (* PP value in mspace m *) + SUBGOAL_THEN + `(PP:A->A->real->A) ((f:real->A) t0) + (f b0) ((t' - t0) / (b0 - t0)) + IN mspace (m:A metric)` + ASSUME_TAC THENL + [ASM_MESON_TAC[SUBSET; IN_IMAGE]; ALL_TAC] THEN + (* Apply MDIST_SYM *) + SUBGOAL_THEN + `mdist (m:A metric) + ((PP:A->A->real->A) ((f:real->A) t0) + (f b0) ((t' - t0) / (b0 - t0)), + f t0) = + mdist m (f t0, + PP (f t0) (f b0) + ((t' - t0) / (b0 - t0)))` + SUBST1_TAC THENL [MATCH_MP_TAC MDIST_SYM THEN + ASM_MESON_TAC[]; ALL_TAC] THEN + (* Apply del' continuity bound *) + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]]]]; ALL_TAC] THEN + SUBGOAL_THEN `?dl:real. &0 < dl /\ dl <= df /\ + (!t'. t0 - dl < t' /\ t' < t0 /\ + t' IN real_interval[&0,&1] /\ ~(t' IN C) /\ + ~(C INTER {s:real | s <= t'} = {}) /\ + ~(C INTER {s:real | t' <= s} = {}) + ==> t0 - sup(C INTER {s:real | s <= t'}) < df \/ + (inf(C INTER {s:real | t' <= s}) = t0 /\ + mdist m ((PP:A->A->real->A) + (f (sup(C INTER {s:real | s <= t'}))) + (f t0) + ((t' - sup(C INTER {s:real | s <= t'})) / + (t0 - sup(C INTER {s:real | s <= t'}))), + (f:real->A) t0) < r))` + (X_CHOOSE_THEN `dl:real` (fun th -> + let th1,th2 = CONJ_PAIR th in + let th2a,th3 = CONJ_PAIR th2 in + ASSUME_TAC th1 THEN ASSUME_TAC th2a THEN LABEL_TAC "DL" th3)) THENL + [ASM_CASES_TAC `?c:real. c IN C /\ t0 - df < c /\ c < t0` THENL + [(* C-point in (t0-df, t0): dl = t0 - cl *) + FIRST_X_ASSUM(X_CHOOSE_THEN `cl:real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `t0 - cl` THEN + CONJ_TAC THENL + [UNDISCH_TAC `(cl:real) < t0` THEN REAL_ARITH_TAC; + ALL_TAC] THEN + CONJ_TAC THENL [UNDISCH_TAC `t0 - df < (cl:real)` THEN + REAL_ARITH_TAC; ALL_TAC] THEN + REPEAT STRIP_TAC THEN DISJ1_TAC THEN + MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `t0 - cl` THEN + CONJ_TAC THENL + [MATCH_MP_TAC(REAL_ARITH `a <= b ==> c - b <= c - a`) THEN + MATCH_MP_TAC ELEMENT_LE_SUP THEN + CONJ_TAC THENL + [EXISTS_TAC `&1` THEN REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + REPEAT STRIP_TAC THEN + UNDISCH_TAC `C SUBSET real_interval[&0,&1]` THEN + REWRITE_TAC[SUBSET; IN_REAL_INTERVAL] THEN + ASM_MESON_TAC[REAL_LE_TRANS]; + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; + UNDISCH_TAC `t0 - (t0 - cl) < (t':real)` THEN REAL_ARITH_TAC]]; + UNDISCH_TAC `t0 - df < (cl:real)` THEN REAL_ARITH_TAC]; + (* No C-point in (t0-df, t0) *) + real_closed_C_tac THEN + ASM_CASES_TAC `C INTER {s:real | s <= t0 - df} = {}` THENL + [(* Vacuous *) + EXISTS_TAC `df:real` THEN CONJ_TAC THENL + [UNDISCH_TAC `&0 < df` THEN REAL_ARITH_TAC; ALL_TAC] THEN + CONJ_TAC THENL [REAL_ARITH_TAC; ALL_TAC] THEN X_GEN_TAC `t':real` THEN + STRIP_TAC THEN + SUBGOAL_THEN `C INTER {s:real | s <= t'} = {}` (fun th -> + ASM_MESON_TAC[th]) THEN + REWRITE_TAC[EXTENSION; IN_INTER; IN_ELIM_THM; NOT_IN_EMPTY] THEN + X_GEN_TAC `c:real` THEN REWRITE_TAC[DE_MORGAN_THM] THEN + ASM_CASES_TAC `(c:real) IN C` THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[REAL_NOT_LE] THEN + MATCH_MP_TAC REAL_LTE_TRANS THEN EXISTS_TAC `t0:real` THEN + CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + UNDISCH_TAC `~(?c:real. c IN C /\ t0 - df < c /\ c < t0)` THEN + REWRITE_TAC[NOT_EXISTS_THM; DE_MORGAN_THM; REAL_NOT_LT] THEN + DISCH_THEN(MP_TAC o SPEC `c:real`) THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `C INTER {s:real | s <= t0 - df} = {}` THEN + REWRITE_TAC[EXTENSION; IN_INTER; IN_ELIM_THM; NOT_IN_EMPTY] THEN + DISCH_THEN(MP_TAC o SPEC `c:real`) THEN ASM_REWRITE_TAC[] THEN + REAL_ARITH_TAC; + (* C has points <= t0-df: nonempty case *) + ABBREV_TAC `a0 = sup(C INTER {s:real | s <= t0 - df})` THEN + SUBGOAL_THEN `(a0:real) IN C /\ a0 <= t0 - df` + STRIP_ASSUME_TAC THENL [SUBGOAL_THEN + `a0 IN C INTER {s:real | s <= t0 - df}` MP_TAC THENL + [EXPAND_TAC "a0" THEN sup_in_C_tac; + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN STRIP_TAC THEN + ASM_REWRITE_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `(f:real->A) a0 IN topspace top /\ f t0 IN topspace top` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + USE_THEN "PP" (MP_TAC o SPECL + [`(f:real->A) a0`; `(f:real->A) t0`]) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN STRIP_TAC THEN + SUBGOAL_THEN `?del'. &0 < del' /\ + !y. y IN real_interval[&0,&1] /\ abs(y - &1) < del' + ==> mdist (m:A metric) ((f:real->A) t0, + (PP:A->A->real->A) (f a0) (f t0) y) < r` + (X_CHOOSE_THEN `del':real` STRIP_ASSUME_TAC) THENL [MP_TAC(ISPECL + [`submetric real_euclidean_metric (real_interval[&0,&1])`; + `(m:A metric)`; + `(PP:A->A->real->A) ((f:real->A) a0) (f t0)`] + METRIC_CONTINUOUS_MAP) THEN + REWRITE_TAC[MTOPOLOGY_SUBMETRIC; MTOPOLOGY_REAL_EUCLIDEAN_METRIC] THEN + SUBGOAL_THEN `mtopology (m:A metric) = top` + (fun th -> REWRITE_TAC[th]) THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[GSYM path_in] THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o CONJUNCT2) THEN + DISCH_THEN(MP_TAC o SPECL [`&1`; `r:real`]) THEN + ASM_REWRITE_TAC[SUBMETRIC; REAL_EUCLIDEAN_METRIC; INTER_UNIV] THEN + ANTS_TAC THENL + [REWRITE_TAC[IN_REAL_INTERVAL] THEN REAL_ARITH_TAC; + ALL_TAC] THEN + REWRITE_TAC[REAL_SUB_RZERO] THEN + DISCH_THEN(X_CHOOSE_THEN `d1:real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `d1:real` THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `y:real` THEN STRIP_TAC THEN + SUBGOAL_THEN + `mdist m ((PP:A->A->real->A) ((f:real->A) a0) (f t0) (&1), + PP (f a0) (f t0) y) < r` MP_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[REAL_EUCLIDEAN_METRIC; IN_REAL_INTERVAL] THEN + ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `y IN real_interval[&0,&1]` THEN + REWRITE_TAC[IN_REAL_INTERVAL] THEN REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(PP:A->A->real->A) ((f:real->A) a0) (f t0) (&1) = f t0` + SUBST1_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `mdist (m:A metric) ((PP:A->A->real->A) ((f:real->A) a0) (f t0) y, + (f:real->A) t0) = + mdist m (f t0, + PP (f a0) (f t0) + y)` SUBST1_TAC THENL [MATCH_MP_TAC MDIST_SYM THEN + ASM_MESON_TAC[SUBSET; IN_IMAGE]; SIMP_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `a0 < (t0:real)` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + EXISTS_TAC `min df (del' * (t0 - a0))` THEN min_pos_tac THEN + X_GEN_TAC `t':real` THEN STRIP_TAC THEN DISJ2_TAC THEN + SUBGOAL_THEN `C INTER {s:real | s <= t'} = C INTER {s | s <= t0 - df}` + ASSUME_TAC THENL [REWRITE_TAC[EXTENSION; IN_INTER; IN_ELIM_THM] THEN + X_GEN_TAC `c':real` THEN EQ_TAC THEN STRIP_TAC THEN + ASM_REWRITE_TAC[] THENL + [UNDISCH_TAC `~(?c:real. c IN C /\ t0 - df < c /\ c < t0)` THEN + REWRITE_TAC[NOT_EXISTS_THM; DE_MORGAN_THM; REAL_NOT_LT] THEN + DISCH_THEN(MP_TAC o SPEC `c':real`) THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `c' <= (t':real)` THEN UNDISCH_TAC `(t':real) < t0` THEN + REAL_ARITH_TAC; + UNDISCH_TAC `t0 - min df (del' * ((t0:real) - a0)) < t'` THEN + UNDISCH_TAC `c' <= t0 - (df:real)` THEN + REAL_ARITH_TAC]; ALL_TAC] THEN + SUBGOAL_THEN `sup(C INTER {s:real | s <= t'}) = a0` + ASSUME_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `inf(C INTER {s:real | t' <= s}) = t0` + ASSUME_TAC THENL + [MATCH_MP_TAC REAL_INF_UNIQUE THEN + CONJ_TAC THENL [REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + X_GEN_TAC `c':real` THEN STRIP_TAC THEN + UNDISCH_TAC `~(?c:real. c IN C /\ t0 - df < c /\ c < t0)` THEN + REWRITE_TAC[NOT_EXISTS_THM; DE_MORGAN_THM; REAL_NOT_LT] THEN + DISCH_THEN(MP_TAC o SPEC `c':real`) THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `t' <= (c':real)` THEN UNDISCH_TAC + `t0 - min df (del' * ((t0:real) - a0)) < t'` THEN REAL_ARITH_TAC; + X_GEN_TAC `b2:real` THEN DISCH_TAC THEN EXISTS_TAC `t0:real` THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN ASM_REWRITE_TAC[] THEN + ASM_REAL_ARITH_TAC]; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + (* Parameter (t'-a0)/(t0-a0) in [0,1] *) + SUBGOAL_THEN `(t' - a0) / (t0 - a0) IN real_interval[&0,&1]` + ASSUME_TAC THENL [REWRITE_TAC[IN_REAL_INTERVAL] THEN + SUBGOAL_THEN `&0 < t0 - a0` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN div_bounds_tac; ALL_TAC] THEN + (* |param - 1| < del' *) + SUBGOAL_THEN `abs((t' - a0) / (t0 - a0) - &1) < del'` + ASSUME_TAC THENL [SUBGOAL_THEN `&0 < t0 - a0` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(t' - a0) / (t0 - a0) - &1 = --((t0 - t') / (t0 - a0))` + SUBST1_TAC THENL [UNDISCH_TAC `a0 < (t0:real)` THEN + CONV_TAC REAL_FIELD; ALL_TAC] THEN + REWRITE_TAC[REAL_ABS_NEG; REAL_ABS_DIV] THEN + SUBGOAL_THEN `abs(t0 - t') = t0 - t'` SUBST1_TAC THENL + [REWRITE_TAC[REAL_ABS_REFL] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `abs(t0 - a0) = t0 - a0` SUBST1_TAC THENL + [REWRITE_TAC[REAL_ABS_REFL] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + ASM_SIMP_TAC[REAL_LT_LDIV_EQ] THEN UNDISCH_TAC + `t0 - min df (del' * ((t0:real) - a0)) < t'` THEN + REAL_ARITH_TAC; ALL_TAC] THEN + (* PP value in mspace m *) + SUBGOAL_THEN `(PP:A->A->real->A) ((f:real->A) a0) (f t0) + ((t' - a0) / (t0 - a0)) IN mspace (m:A metric)` + ASSUME_TAC THENL [ASM_MESON_TAC[SUBSET; IN_IMAGE]; ALL_TAC] THEN + (* Apply MDIST_SYM *) + SUBGOAL_THEN `mdist (m:A metric) + ((PP:A->A->real->A) ((f:real->A) a0) (f t0) + ((t' - a0) / (t0 - a0)), f t0) = + mdist m (f t0, PP (f a0) (f t0) + ((t' - a0) / (t0 - a0)))` + SUBST1_TAC THENL [MATCH_MP_TAC MDIST_SYM THEN + ASM_MESON_TAC[]; ALL_TAC] THEN + (* Apply del' continuity bound *) + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]]]; ALL_TAC] THEN + ABBREV_TAC `delta:real = min dr dl` THEN + SUBGOAL_THEN `&0 < delta /\ delta <= df /\ delta <= dr /\ delta <= dl` + STRIP_ASSUME_TAC THENL [EXPAND_TAC "delta" THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN EXISTS_TAC + `{y:real | y IN real_interval[&0,&1] /\ abs(y - t0) < delta}` THEN + REPEAT CONJ_TAC THENL + [(* Open in subtopology *) + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY; TOPSPACE_EUCLIDEANREAL] THEN + EXISTS_TAC `{y:real | abs(y - t0) < delta}` THEN CONJ_TAC THENL + [REWRITE_TAC[GSYM REAL_OPEN_IN; real_open; IN_ELIM_THM] THEN + X_GEN_TAC `s:real` THEN DISCH_TAC THEN + EXISTS_TAC `delta - abs(s - t0)` THEN + CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + X_GEN_TAC `s':real` THEN DISCH_TAC THEN ASM_REAL_ARITH_TAC; + REWRITE_TAC[EXTENSION; IN_INTER; IN_ELIM_THM; IN_UNIV] THEN + MESON_TAC[]]; + (* t0 IN U *) + REWRITE_TAC[IN_ELIM_THM] THEN CONJ_TAC THENL + [UNDISCH_TAC `(C:real->bool) SUBSET real_interval[&0,&1]` THEN + ASM SET_TAC[]; + ASM_REAL_ARITH_TAC]; + (* Main estimate: FF(y) IN mball m (f(t0), r) for y IN U *) + X_GEN_TAC `t':real` THEN REWRITE_TAC[IN_ELIM_THM] THEN STRIP_TAC THEN + (* Derive abs(t'-t0) < df from delta <= df *) + SUBGOAL_THEN `abs(t':real - t0) < df` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[IN_MBALL] THEN + ASM_CASES_TAC `t' IN (C:real->bool)` THENL [(* Sub-case t' IN C: FF(t') + = f(t') *) + ASM_REWRITE_TAC[] THEN + REPLICATE_TAC 2 (CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC]) THEN + mdist_sym_subst + `mdist m ((f:real->A) t0, f t') = mdist m (f t', f t0)` THEN + MATCH_MP_TAC REAL_LT_TRANS THEN EXISTS_TAC `min (dc / &2) (r / &3)` THEN + CONJ_TAC THENL [FIRST_X_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; ASM_REAL_ARITH_TAC]; + (* Sub-case t' NOT IN C *) + ASM_REWRITE_TAC[] THEN + ASM_CASES_TAC `(C:real->bool) INTER {s:real | s <= t'} = {}` THENL + [(* Degenerate: all C above t', FF(t') = f(inf C) *) + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `inf C IN (C:real->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC INF_IN_REAL_CLOSED THEN CONJ_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_TRANS_FULL; REAL_CLOSED_IN; + REAL_CLOSED_REAL_INTERVAL]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + EXISTS_TAC `&0` THEN X_GEN_TAC `x:real` THEN DISCH_TAC THEN + x_in_01_tac; ALL_TAC] THEN + SUBGOAL_THEN `abs(inf C - t0) < df` ASSUME_TAC THENL + [SUBGOAL_THEN `t' < inf (C:real->bool)` ASSUME_TAC THENL + [REWRITE_TAC[REAL_LT_LE] THEN + CONJ_TAC THENL [MATCH_MP_TAC REAL_LE_INF THEN CONJ_TAC THENL + [UNDISCH_TAC `~((C:real->bool) = {})` THEN SET_TAC[]; ALL_TAC] THEN + X_GEN_TAC `c:real` THEN DISCH_TAC THEN UNDISCH_TAC + `(C:real->bool) INTER {s:real | s <= t'} = {}` THEN + REWRITE_TAC[EXTENSION; NOT_IN_EMPTY; IN_INTER; IN_ELIM_THM] THEN + DISCH_THEN(MP_TAC o SPEC `c:real`) THEN ASM_REWRITE_TAC[] THEN + REAL_ARITH_TAC; + DISCH_TAC THEN + UNDISCH_TAC `~(t' IN (C:real->bool))` THEN + ASM_REWRITE_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `inf C <= t0` ASSUME_TAC THENL + [MATCH_MP_TAC INF_LE_ELEMENT THEN CONJ_TAC THENL + [EXISTS_TAC `&0` THEN X_GEN_TAC `x:real` THEN DISCH_TAC THEN + x_in_01_tac; + ASM_REWRITE_TAC[]]; ALL_TAC] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(f:real->A)(inf C) IN topspace top` + ASSUME_TAC THENL [f_in_top_tac; ALL_TAC] THEN + SUBGOAL_THEN `mdist m ((f:real->A)(inf C), f t0) < + min (dc / &2) (r / &3)` ASSUME_TAC THENL [UNDISCH_TAC + `!t:real. t IN C /\ abs(t - t0) < df + ==> mdist m ((f:real->A) t, + f t0) < min (dc / &2) (r / &3)` THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + REPLICATE_TAC 2 (CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC]) THEN + mdist_sym_subst + `mdist m ((f:real->A) t0, f(inf C)) = mdist m (f(inf C), f t0)` THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + ASM_CASES_TAC `(C:real->bool) INTER {s:real | t' <= s} = {}` THENL + [(* Degenerate: all C below t', FF(t') = f(sup C) *) + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `sup C IN (C:real->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC SUP_IN_REAL_CLOSED THEN CONJ_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_TRANS_FULL; REAL_CLOSED_IN; + REAL_CLOSED_REAL_INTERVAL]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + EXISTS_TAC `&1` THEN X_GEN_TAC `x:real` THEN DISCH_TAC THEN + x_in_01_tac; ALL_TAC] THEN + SUBGOAL_THEN `abs(sup C - t0) < df` ASSUME_TAC THENL + [SUBGOAL_THEN `sup (C:real->bool) < t'` ASSUME_TAC THENL + [REWRITE_TAC[REAL_LT_LE] THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_SUP_LE THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `c:real` THEN DISCH_TAC THEN UNDISCH_TAC + `(C:real->bool) INTER {s:real | t' <= s} = {}` THEN + REWRITE_TAC[EXTENSION; NOT_IN_EMPTY; IN_INTER; IN_ELIM_THM] THEN + DISCH_THEN(MP_TAC o SPEC `c:real`) THEN ASM_REWRITE_TAC[] THEN + REAL_ARITH_TAC; + DISCH_TAC THEN UNDISCH_TAC `sup C IN (C:real->bool)` THEN + ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `~(t' IN (C:real->bool))` THEN + REWRITE_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `t0 <= sup (C:real->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC REAL_LE_SUP THEN + MAP_EVERY EXISTS_TAC [`&1`; `t0:real`] THEN + REPEAT CONJ_TAC THENL [ASM_REWRITE_TAC[]; REAL_ARITH_TAC; + X_GEN_TAC `x:real` THEN DISCH_TAC THEN x_in_01_tac]; ALL_TAC] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(f:real->A)(sup C) IN topspace top` + ASSUME_TAC THENL [f_in_top_tac; ALL_TAC] THEN + SUBGOAL_THEN `mdist m ((f:real->A)(sup C), f t0) < + min (dc / &2) (r / &3)` ASSUME_TAC THENL [UNDISCH_TAC + `!t:real. t IN C /\ abs(t - t0) < df + ==> mdist m ((f:real->A) t, + f t0) < min (dc / &2) (r / &3)` THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + REPLICATE_TAC 2 (CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC]) THEN + mdist_sym_subst + `mdist m ((f:real->A) t0, f(sup C)) = mdist m (f(sup C), f t0)` THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + (* Main gap case: both intersections non-empty *) + ASM_REWRITE_TAC[] THEN real_closed_C_tac THEN + SUBGOAL_THEN `sup(C INTER {s:real | s <= t'}) IN + C INTER {s:real | s <= + t'}` ASSUME_TAC THENL [sup_in_C_tac; ALL_TAC] THEN + SUBGOAL_THEN `inf(C INTER {s:real | t' <= s}) IN + C INTER {s:real | t' <= + s}` ASSUME_TAC THENL [inf_in_C_tac; ALL_TAC] THEN + ABBREV_TAC `a':real = sup(C INTER {s:real | s <= t'})` THEN + ABBREV_TAC `b':real = inf(C INTER {s:real | t' <= s})` THEN + SUBGOAL_THEN `a' IN (C:real->bool)` ASSUME_TAC THENL + [UNDISCH_TAC `a' IN C INTER {s:real | s <= t'}` THEN + REWRITE_TAC[IN_INTER] THEN MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `b' IN (C:real->bool)` ASSUME_TAC THENL + [UNDISCH_TAC `b' IN C INTER {s:real | t' <= s}` THEN + REWRITE_TAC[IN_INTER] THEN MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `a' <= t' /\ t' <= b'` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `a' IN C INTER {s:real | s <= t'}` THEN + UNDISCH_TAC `b' IN C INTER {s:real | t' <= s}` THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `a' < b'` ASSUME_TAC THENL [SUBGOAL_THEN `a' < t'` + ASSUME_TAC THENL + [REWRITE_TAC[REAL_LT_LE] THEN CONJ_TAC THENL [ASM_REWRITE_TAC[]; + DISCH_TAC THEN UNDISCH_TAC `~(t' IN (C:real->bool))` THEN + ASM_MESON_TAC[]]; ALL_TAC] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(f:real->A) a' IN topspace top /\ + (f:real->A) b' IN topspace top` + STRIP_ASSUME_TAC THENL + [CONJ_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(t' - a') / (b' - a') IN real_interval[&0,&1]` ASSUME_TAC + THENL + [REWRITE_TAC[IN_REAL_INTERVAL] THEN + SUBGOAL_THEN `&0 < b' - a'` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN div_bounds_tac; ALL_TAC] THEN + REPEAT CONJ_TAC THENL + [(* f t0 IN topspace top *) ASM_MESON_TAC[]; + (* PP-val IN topspace top *) + USE_THEN "PP" (fun th -> + MP_TAC(CONJUNCT2(CONJUNCT2(CONJUNCT2(MATCH_MP th + (CONJ (ASSUME `(f:real->A) a' IN topspace top`) + (ASSUME `(f:real->A) b' IN topspace top`))))))) THEN + REWRITE_TAC[SUBSET] THEN DISCH_THEN MATCH_MP_TAC THEN + REWRITE_TAC[IN_IMAGE] THEN + EXISTS_TAC `(t' - a') / (b' - a')` THEN ASM_REWRITE_TAC[]; + (* mdist m (f t0, PP(f a', f b', val)) < r *) + SUBGOAL_THEN `t0 <= a' \/ b' <= t0` MP_TAC THENL + [ASM_CASES_TAC `t0:real <= a'` THENL [DISJ1_TAC THEN + FIRST_ASSUM ACCEPT_TAC; + ASM_CASES_TAC `b':real <= t0` THENL [DISJ2_TAC THEN + FIRST_ASSUM ACCEPT_TAC; + (* a' < t0 < b' contradicts t0 IN C *) + SUBGOAL_THEN `a' < t0 /\ t0 < b'` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + UNDISCH_TAC `t0 IN (C:real->bool)` THEN REWRITE_TAC[] THEN + ASM_CASES_TAC `t0:real <= t'` THENL + [EXPAND_TAC "a'" THEN + MP_TAC(SPEC `C INTER {s:real | s <= t'}` SUP) THEN ANTS_TAC THENL + [CONJ_TAC THENL [UNDISCH_TAC `~(C INTER {s:real | s <= t'} = {})` + THEN SET_TAC[]; + EXISTS_TAC `&1` THEN REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + c_in_01_tac []]; + DISCH_THEN(MP_TAC o SPEC `t0:real` o CONJUNCT1) THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN REPEAT DISCH_TAC THEN + DISJ1_TAC THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]]; + EXPAND_TAC "b'" THEN + MP_TAC(SPEC `C INTER {s:real | t' <= s}` INF) THEN ANTS_TAC THENL + [CONJ_TAC THENL [UNDISCH_TAC `~(C INTER {s:real | t' <= s} = {})` + THEN SET_TAC[]; + EXISTS_TAC `&0` THEN REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + c_in_01_tac []]; + DISCH_THEN(MP_TAC o SPEC `t0:real` o CONJUNCT1) THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + REPEAT DISCH_TAC THEN DISJ2_TAC THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC]]]]; ALL_TAC] THEN + (let both_close_tac = + SUBGOAL_THEN `(f:real->A) t0 IN topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] + THEN + SUBGOAL_THEN `abs(a':real - t0) < df /\ abs(b':real - t0) < df` + STRIP_ASSUME_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN + `mdist m ((f:real->A) a', f t0) < min (dc / &2) (r / &3) /\ + mdist m ((f:real->A) b', f t0) < min (dc / &2) (r / &3)` + STRIP_ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `mdist m ((f:real->A) a', f b') < dc` + ASSUME_TAC THENL [MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC + `mdist m ((f:real->A) a', f t0) + mdist m (f t0, f b')` THEN + CONJ_TAC THENL + [MATCH_MP_TAC MDIST_TRIANGLE THEN ASM_REWRITE_TAC[]; + mdist_sym_subst + `mdist m ((f:real->A) t0, f b') = mdist m (f b', f t0)` THEN + ASM_REAL_ARITH_TAC]; ALL_TAC] THEN + SUBGOAL_THEN + `mdiameter m (IMAGE ((PP:A->A->real->A) ((f:real->A) a') (f b')) + (real_interval[&0,&1])) < r / &3` + ASSUME_TAC THENL [USE_THEN "DC" MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `mbounded m (IMAGE ((PP:A->A->real->A) ((f:real->A) a') (f b')) + (real_interval[&0,&1]))` + ASSUME_TAC THENL [MATCH_MP_TAC COMPACT_IN_IMP_MBOUNDED THEN + ONCE_REWRITE_TAC + [SYM(ASSUME `mtopology (m:A metric) = (top:A topology)`)] THEN + MATCH_MP_TAC COMPACT_IN_PATH_IMAGE THEN + ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(f:real->A) a' IN + IMAGE ((PP:A->A->real->A) ((f:real->A) a') (f b')) + (real_interval[&0,&1])` + ASSUME_TAC THENL [REWRITE_TAC[IN_IMAGE] THEN EXISTS_TAC `&0` THEN + CONJ_TAC THENL [CONV_TAC SYM_CONV THEN ASM_MESON_TAC[]; + REWRITE_TAC[IN_REAL_INTERVAL] THEN REAL_ARITH_TAC]; ALL_TAC] THEN + SUBGOAL_THEN `(PP:A->A->real->A) ((f:real->A) a') (f b') + ((t' - a') / (b' - a')) + IN IMAGE ((PP:A->A->real->A) ((f:real->A) a') (f b')) + (real_interval[&0,&1])` + ASSUME_TAC THENL + [REWRITE_TAC[IN_IMAGE] THEN + EXISTS_TAC `(t' - a') / (b' - a')` THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `mdist m ((f:real->A) a', + (PP:A->A->real->A) ((f:real->A) a') (f b') + ((t' - a') / (b' - a'))) < r / &3` + ASSUME_TAC THENL [MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC + `mdiameter m (IMAGE ((PP:A->A->real->A) ((f:real->A) a') (f b')) + (real_interval[&0,&1]))` THEN CONJ_TAC THENL + [MATCH_MP_TAC MDIAMETER_BOUNDED_BOUND THEN ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `(PP:A->A->real->A) ((f:real->A) a') (f b') + ((t' - a') / (b' - a')) IN topspace top` + ASSUME_TAC THENL [ASM_MESON_TAC[SUBSET; FUN_IN_IMAGE]; + ALL_TAC] THEN + MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC + `mdist m ((f:real->A) t0, f a') + + mdist m (f a', (PP:A->A->real->A) ((f:real->A) a') (f b') + ((t' - a') / (b' - a')))` THEN CONJ_TAC THENL + [MATCH_MP_TAC MDIST_TRIANGLE THEN ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[SUBSET; FUN_IN_IMAGE]; ALL_TAC] THEN mdist_sym_subst + `mdist m ((f:real->A) t0, f a') = mdist m (f a', f t0)` THEN + ASM_REAL_ARITH_TAC in + STRIP_TAC THENL [(* Branch: t0 <= a' *) + ASM_CASES_TAC `b':real - t0 < df` THENL [both_close_tac; + (* One far endpoint: t0 <= a', b' >= t0+df, use DR *) + SUBGOAL_THEN `t0:real < t'` ASSUME_TAC THENL + [MATCH_MP_TAC REAL_LET_TRANS THEN EXISTS_TAC `a':real` THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[REAL_LT_LE] THEN CONJ_TAC THENL [ASM_REWRITE_TAC[]; + DISCH_TAC THEN UNDISCH_TAC `~(t' IN (C:real->bool))` THEN + ASM_MESON_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `t':real < t0 + dr` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + USE_THEN "DR" (MP_TAC o SPEC `t':real`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `~(inf(C INTER {s:real | t' <= s}) < t0 + df)` + ASSUME_TAC THENL [ONCE_ASM_REWRITE_TAC[] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + DISCH_THEN(DISJ_CASES_TAC) THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(CONJUNCTS_THEN2 ASSUME_TAC ASSUME_TAC) THEN + SUBGOAL_THEN `a':real = t0` ASSUME_TAC THENL + [UNDISCH_TAC `sup(C INTER {s:real | s <= t'}) = a'` THEN + ASM_MESON_TAC[]; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + (* Prove f t0 IN topspace top *) + SUBGOAL_THEN `(f:real->A) t0 IN topspace top` ASSUME_TAC THENL + [f_in_top_tac; ALL_TAC] THEN + (* Prove PP value IN topspace top *) + SUBGOAL_THEN `(PP:A->A->real->A) ((f:real->A) t0) (f b') + ((t' - t0) / (b' - t0)) IN topspace top` + ASSUME_TAC THENL [USE_THEN "PP" + (MP_TAC o SPECL [`(f:real->A) t0`; `(f:real->A) b'`]) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(fun th -> + let _,rest = CONJ_PAIR th in + let _,rest2 = CONJ_PAIR rest in + let _,th4 = CONJ_PAIR rest2 in + MP_TAC th4) THEN REWRITE_TAC[SUBSET; IN_IMAGE] THEN + DISCH_THEN MATCH_MP_TAC THEN + EXISTS_TAC `(t' - t0) / (b' - t0)` THEN REWRITE_TAC[] THEN + UNDISCH_TAC + `(t' - a') / (b' - a') IN real_interval[&0,&1]` THEN + UNDISCH_TAC `a':real = t0` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]); ALL_TAC] THEN + (* Apply MDIST_SYM to swap arguments *) + mdist_sym_subst + `mdist m ((f:real->A) t0, + (PP:A->A->real->A) (f t0) (f b') + ((t' - t0) / (b' - t0))) = + mdist m (PP (f t0) (f b') ((t' - t0) / (b' - t0)), f t0)` THEN + (* Match with assumption after rewriting inf = b' *) + UNDISCH_TAC + `mdist m ((PP:A->A->real->A) ((f:real->A) t0) + ((f:real->A) (inf (C INTER {s:real | t' <= s}))) + ((t' - t0) / (inf (C INTER {s:real | t' <= s}) - t0)), + (f:real->A) t0) < r` THEN ASM_REWRITE_TAC[]]; + (* Branch: b' <= t0 *) + ASM_CASES_TAC `t0 - a':real < df` THENL [both_close_tac; + (* Far endpoint a': a' far from t0, b' close, use DL *) + SUBGOAL_THEN `t':real < t0` ASSUME_TAC THENL + [REWRITE_TAC[REAL_LT_LE] THEN CONJ_TAC THENL [ASM_REAL_ARITH_TAC; + DISCH_TAC THEN UNDISCH_TAC `~(t' IN (C:real->bool))` THEN + ASM_MESON_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `t0 - dl < t':real` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + USE_THEN "DL" (MP_TAC o SPEC `t':real`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `~(t0 - sup(C INTER {s:real | s <= t'}) < df)` + ASSUME_TAC THENL [ONCE_ASM_REWRITE_TAC[] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + DISCH_THEN(DISJ_CASES_TAC) THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(CONJUNCTS_THEN2 ASSUME_TAC ASSUME_TAC) THEN + SUBGOAL_THEN `b':real = t0` ASSUME_TAC THENL + [UNDISCH_TAC `inf(C INTER {s:real | t' <= s}) = b'` THEN + ASM_MESON_TAC[]; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + (* Prove f t0 IN topspace top *) + SUBGOAL_THEN `(f:real->A) t0 IN topspace top` ASSUME_TAC THENL + [f_in_top_tac; ALL_TAC] THEN + (* Prove PP value IN topspace top *) + SUBGOAL_THEN `(PP:A->A->real->A) ((f:real->A) a') (f t0) + ((t' - a') / (t0 - a')) IN topspace top` + ASSUME_TAC THENL [USE_THEN "PP" + (MP_TAC o SPECL [`(f:real->A) a'`; `(f:real->A) t0`]) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(fun th -> + let _,rest = CONJ_PAIR th in + let _,rest2 = CONJ_PAIR rest in + let _,th4 = CONJ_PAIR rest2 in + MP_TAC th4) THEN REWRITE_TAC[SUBSET; IN_IMAGE] THEN + DISCH_THEN MATCH_MP_TAC THEN + EXISTS_TAC `(t' - a') / (t0 - a')` THEN REWRITE_TAC[] THEN + UNDISCH_TAC + `(t' - a') / (b' - a') IN real_interval[&0,&1]` THEN + UNDISCH_TAC `b':real = t0` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]); ALL_TAC] THEN + (* Apply MDIST_SYM to swap arguments *) + mdist_sym_subst + `mdist m ((f:real->A) t0, + (PP:A->A->real->A) (f a') (f t0) + ((t' - a') / (t0 - a'))) = + mdist m (PP (f a') (f t0) ((t' - a') / (t0 - a')), f t0)` THEN + (* Match with DL assumption after rewriting sup = a' *) + UNDISCH_TAC + `mdist m ((PP:A->A->real->A) + ((f:real->A) (sup (C INTER {s:real | s <= t'}))) + ((f:real->A) t0) + ((t' - sup (C INTER {s:real | s <= t'})) / + (t0 - sup (C INTER {s:real | s <= t'}))), + (f:real->A) t0) < r` THEN ASM_REWRITE_TAC[]]])]]]; + (* Case t0 NOT IN C *) + ASM_REWRITE_TAC[] THEN real_closed_C_tac THEN + ASM_CASES_TAC `(C:real->bool) INTER {s:real | s <= t0} = {}` THENL + [(* Degenerate: C INTER {s <= t0} = {}, all C above t0 *) + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `inf C IN (C:real->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC INF_IN_REAL_CLOSED THEN ASM_REWRITE_TAC[] THEN + c_in_01_tac [REAL_LE_REFL]; ALL_TAC] THEN + SUBGOAL_THEN `t0 < inf (C:real->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC(REAL_ARITH `~(x <= t) ==> t < x`) THEN DISCH_TAC THEN + SUBGOAL_THEN `inf C IN (C:real->bool) INTER {s:real | s <= t0}` + MP_TAC THENL [REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[NOT_IN_EMPTY]]; ALL_TAC] THEN + SUBGOAL_THEN `(f:real->A)(inf C) IN topspace top` ASSUME_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + EXISTS_TAC `{y:real | y IN real_interval[&0,&1] /\ y < inf C}` THEN + REPEAT CONJ_TAC THENL + [REWRITE_TAC[OPEN_IN_SUBTOPOLOGY; TOPSPACE_EUCLIDEANREAL] THEN + EXISTS_TAC `{y:real | y < inf C}` THEN CONJ_TAC THENL + [REWRITE_TAC[GSYM REAL_OPEN_IN; REAL_OPEN_HALFSPACE_LT]; + REWRITE_TAC[EXTENSION; IN_INTER; IN_ELIM_THM; IN_UNIV] THEN + MESON_TAC[]]; + REWRITE_TAC[IN_ELIM_THM] THEN ASM_REWRITE_TAC[]; + X_GEN_TAC `z:real` THEN REWRITE_TAC[IN_ELIM_THM] THEN STRIP_TAC THEN + SUBGOAL_THEN `(C:real->bool) INTER {s:real | s <= z} = {}` + ASSUME_TAC THENL [REWRITE_TAC[EXTENSION; IN_INTER; IN_ELIM_THM; + NOT_IN_EMPTY] THEN + X_GEN_TAC `w:real` THEN STRIP_TAC THEN + MP_TAC(SPEC `C:real->bool` INF) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN c_in_01_tac [REAL_LE_REFL]; + DISCH_THEN(MP_TAC o SPEC `w:real` o CONJUNCT1) THEN + ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC]; ALL_TAC] THEN + SUBGOAL_THEN `~(z IN (C:real->bool))` ASSUME_TAC THENL + [DISCH_TAC THEN + UNDISCH_TAC `(C:real->bool) INTER {s:real | s <= z} = {}` THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN EXISTS_TAC `z:real` THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + ASM_REWRITE_TAC[REAL_LE_REFL]; ALL_TAC] THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CENTRE_IN_MBALL THEN ASM_REWRITE_TAC[]]; ALL_TAC] THEN + ASM_CASES_TAC `(C:real->bool) INTER {s:real | t0 <= s} = {}` THENL + [(* Degenerate: C INTER {t0 <= s} = {}, all C below t0 *) + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `sup C IN (C:real->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC SUP_IN_REAL_CLOSED THEN ASM_REWRITE_TAC[] THEN + c_in_01_tac [REAL_LE_REFL]; ALL_TAC] THEN + SUBGOAL_THEN `sup (C:real->bool) < t0` ASSUME_TAC THENL + [MATCH_MP_TAC(REAL_ARITH `~(t <= x) ==> x < t`) THEN DISCH_TAC THEN + SUBGOAL_THEN `sup C IN (C:real->bool) INTER {s:real | t0 <= s}` + MP_TAC THENL [REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN + ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[NOT_IN_EMPTY]]; ALL_TAC] THEN + SUBGOAL_THEN `(f:real->A)(sup C) IN topspace top` ASSUME_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + EXISTS_TAC `{y:real | y IN real_interval[&0,&1] /\ sup C < y}` THEN + REPEAT CONJ_TAC THENL + [REWRITE_TAC[OPEN_IN_SUBTOPOLOGY; TOPSPACE_EUCLIDEANREAL] THEN + EXISTS_TAC `{y:real | sup C < y}` THEN + CONJ_TAC THENL [REWRITE_TAC[GSYM REAL_OPEN_IN; + REWRITE_RULE[real_gt] REAL_OPEN_HALFSPACE_GT]; + REWRITE_TAC[EXTENSION; IN_INTER; IN_ELIM_THM; IN_UNIV] THEN + MESON_TAC[]]; + REWRITE_TAC[IN_ELIM_THM] THEN ASM_REWRITE_TAC[]; + (* Main estimate for case 2 *) + X_GEN_TAC `z:real` THEN REWRITE_TAC[IN_ELIM_THM] THEN STRIP_TAC THEN + (let c_sup_ants = + MP_TAC(SPEC `C:real->bool` SUP) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN EXISTS_TAC `&1` THEN X_GEN_TAC `x:real` THEN + DISCH_TAC THEN + x_in_01_tac; ALL_TAC] in + SUBGOAL_THEN `(C:real->bool) INTER {s:real | z <= s} = {}` + ASSUME_TAC THENL [REWRITE_TAC[EXTENSION; IN_INTER; IN_ELIM_THM; + NOT_IN_EMPTY] THEN + X_GEN_TAC `w:real` THEN STRIP_TAC THEN c_sup_ants THEN + DISCH_THEN(MP_TAC o SPEC `w:real` o CONJUNCT1) THEN + ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `~(z IN (C:real->bool))` ASSUME_TAC THENL [DISCH_TAC THEN + c_sup_ants THEN + DISCH_THEN(MP_TAC o SPEC `z:real` o CONJUNCT1) THEN + ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC; ALL_TAC]) THEN + (* After rewriting, goal has if CINTER{s<=z}={} then f(inf C) else f(sup C) *) + ASM_REWRITE_TAC[] THEN COND_CASES_TAC THENL + [(* CINTER{s<=z}={}: impossible since CINTER{z<=s}={} and C!={} *) + UNDISCH_TAC `~((C:real->bool) = {})` THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + DISCH_THEN(X_CHOOSE_TAC `c0:real`) THEN + SUBGOAL_THEN `c0:real <= z` ASSUME_TAC THENL + [UNDISCH_TAC `(C:real->bool) INTER {s:real | z <= s} = {}` THEN + REWRITE_TAC[EXTENSION; NOT_IN_EMPTY; IN_INTER; IN_ELIM_THM] THEN + DISCH_THEN(MP_TAC o SPEC `c0:real`) THEN + ASM_REWRITE_TAC[] THEN REAL_ARITH_TAC; ALL_TAC] THEN + UNDISCH_TAC `(C:real->bool) INTER {s:real | s <= z} = {}` THEN + REWRITE_TAC[EXTENSION; NOT_IN_EMPTY; IN_INTER; IN_ELIM_THM] THEN + DISCH_THEN(MP_TAC o SPEC `c0:real`) THEN ASM_REWRITE_TAC[]; + MATCH_MP_TAC CENTRE_IN_MBALL THEN ASM_REWRITE_TAC[]]]; ALL_TAC] THEN + (* Main case: t0 in interior of gap (a0, b0) *) + ASM_REWRITE_TAC[] THEN + ABBREV_TAC `a0 = sup (C INTER {s:real | s <= t0})` THEN + ABBREV_TAC `b0 = inf (C INTER {s:real | t0 <= s})` THEN + SUBGOAL_THEN `a0 IN (C:real->bool) /\ b0 IN C /\ + a0 < t0 /\ t0 < b0 /\ + (f:real->A) a0 IN topspace top /\ + f b0 IN topspace top` STRIP_ASSUME_TAC THENL + [SUBGOAL_THEN `a0 IN C INTER {s:real | s <= t0}` MP_TAC THENL + [EXPAND_TAC "a0" THEN sup_in_C_tac; + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN STRIP_TAC] THEN + SUBGOAL_THEN `b0 IN C INTER {s:real | t0 <= s}` MP_TAC THENL + [EXPAND_TAC "b0" THEN inf_in_C_tac; + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN STRIP_TAC] THEN + ASM_REWRITE_TAC[] THEN + REPEAT CONJ_TAC THENL [MATCH_MP_TAC(REAL_ARITH + `a <= t /\ ~(a = t) ==> a < t`) THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + MATCH_MP_TAC(REAL_ARITH `t <= b /\ ~(t = b) ==> t < b`) THEN + ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[]; ASM_MESON_TAC[]; ASM_MESON_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `path_in top ((PP:A->A->real->A) ((f:real->A) a0) (f b0))` + ASSUME_TAC THENL [USE_THEN "PP" (MP_TAC o SPECL [`(f:real->A) a0`; + `(f:real->A) b0`]) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; SIMP_TAC[]]; ALL_TAC] THEN + ABBREV_TAC `s0 = (t0 - a0) / (b0 - a0)` THEN + SUBGOAL_THEN `s0 IN real_interval[&0,&1]` ASSUME_TAC THENL + [EXPAND_TAC "s0" THEN REWRITE_TAC[IN_REAL_INTERVAL] THEN + SUBGOAL_THEN `&0 < b0 - a0` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN div_bounds_tac; ALL_TAC] THEN + UNDISCH_TAC `path_in top ((PP:A->A->real->A) ((f:real->A) a0) (f b0))` + THEN + REWRITE_TAC[path_in] THEN continuous_to_metric_tac THEN + DISCH_THEN(MP_TAC o SPEC `s0:real`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC `r:real`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `V:real->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [OPEN_IN_SUBTOPOLOGY]) THEN + DISCH_THEN(X_CHOOSE_THEN `W:real->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `s0 IN (W:real->bool)` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + UNDISCH_TAC `open_in euclideanreal (W:real->bool)` THEN + REWRITE_TAC[GSYM REAL_OPEN_IN; real_open] THEN + DISCH_THEN(MP_TAC o SPEC `s0:real`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `ds:real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `{y:real | y IN real_interval[&0,&1] /\ + a0 < y /\ y < b0 /\ + abs((y - a0) / (b0 - a0) - s0) < + ds}` THEN REPEAT CONJ_TAC THENL + [(* open_in *) + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY; TOPSPACE_EUCLIDEANREAL] THEN + EXISTS_TAC `{y:real | a0 < y /\ y < b0 /\ + abs((y - a0) / (b0 - a0) - s0) < + ds}` THEN CONJ_TAC THENL + [REWRITE_TAC[GSYM REAL_OPEN_IN; real_open; IN_ELIM_THM] THEN + X_GEN_TAC `u:real` THEN STRIP_TAC THEN + SUBGOAL_THEN `&0 < b0 - a0` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + EXISTS_TAC `min (min (u - a0) (b0 - u)) + ((ds - abs((u - a0) / (b0 - a0) - s0)) * + (b0 - a0))` THEN CONJ_TAC THENL + [REWRITE_TAC[REAL_LT_MIN] THEN CONJ_TAC THENL [ASM_REAL_ARITH_TAC; + MATCH_MP_TAC REAL_LT_MUL THEN ASM_REAL_ARITH_TAC]; ALL_TAC] THEN + X_GEN_TAC `v:real` THEN DISCH_TAC THEN REWRITE_TAC[IN_ELIM_THM] THEN + REPEAT CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ASM_REAL_ARITH_TAC; + (* abs((v-a0)/(b0-a0) - s0) < ds *) + SUBGOAL_THEN `&0 < b0 - a0` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `abs(v - u) / (b0 - a0) < + ds - abs((u - a0) / (b0 - a0) - s0)` + ASSUME_TAC THENL [ASM_SIMP_TAC[REAL_LT_LDIV_EQ] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `abs((v - a0) / (b0 - a0) - s0) <= + abs((u - a0) / (b0 - a0) - s0) + + abs((v - a0) / (b0 - a0) - (u - a0) / (b0 - a0))` + MP_TAC THENL [REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `(v - a0) / (b0 - a0) - (u - a0) / (b0 - a0) = + (v - u) / (b0 - a0)` SUBST1_TAC THENL + [SUBGOAL_THEN `~(b0 - a0 = &0)` MP_TAC THENL + [ASM_REAL_ARITH_TAC; CONV_TAC REAL_FIELD]; ALL_TAC] THEN + SUBGOAL_THEN `abs((v - u) / (b0 - a0)) = + abs(v - u) / (b0 - + a0)` SUBST1_TAC THENL [REWRITE_TAC[REAL_ABS_DIV] THEN + AP_TERM_TAC THEN ASM_REAL_ARITH_TAC; ASM_REAL_ARITH_TAC]]; + REWRITE_TAC[EXTENSION; IN_INTER; IN_ELIM_THM; IN_UNIV] THEN + MESON_TAC[]]; + (* t0 IN U *) + REWRITE_TAC[IN_ELIM_THM] THEN ASM_REWRITE_TAC[] THEN EXPAND_TAC "s0" THEN + REWRITE_TAC[REAL_SUB_REFL; REAL_ABS_0] THEN ASM_REAL_ARITH_TAC; + (* main estimate *) + X_GEN_TAC `y:real` THEN REWRITE_TAC[IN_ELIM_THM] THEN STRIP_TAC THEN + (* Helper: C elements are in [0,1] *) + SUBGOAL_THEN `!x:real. x IN C ==> &0 <= x /\ x <= &1` + (LABEL_TAC "C01") THENL [GEN_TAC THEN DISCH_TAC THEN + SUBGOAL_THEN `x:real IN real_interval[&0,&1]` MP_TAC THENL + [ASM SET_TAC[]; REWRITE_TAC[IN_REAL_INTERVAL] THEN + REAL_ARITH_TAC]; ALL_TAC] THEN + (* Gap property: every C-point is <= a0 or >= b0 *) + SUBGOAL_THEN `!c:real. c IN C ==> c <= a0 \/ b0 <= c` + ASSUME_TAC THENL [X_GEN_TAC `c:real` THEN DISCH_TAC THEN + ASM_CASES_TAC `c:real <= t0` THENL + [DISJ1_TAC THEN EXPAND_TAC "a0" THEN element_le_sup_inter_tac; + DISJ2_TAC THEN EXPAND_TAC "b0" THEN + inf_le_element_inter_tac]; ALL_TAC] THEN + (* y not in C *) + SUBGOAL_THEN `~(y IN (C:real->bool))` ASSUME_TAC THENL + [DISCH_TAC THEN FIRST_X_ASSUM(MP_TAC o SPEC `y:real`) THEN + ASM_REWRITE_TAC[] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + (* Intersections non-empty *) + SUBGOAL_THEN `~((C:real->bool) INTER {s:real | s <= y} = {})` + ASSUME_TAC THENL [REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + EXISTS_TAC `a0:real` THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN ASM_REWRITE_TAC[] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `~((C:real->bool) INTER {s:real | y <= s} = {})` + ASSUME_TAC THENL [REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + EXISTS_TAC `b0:real` THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN ASM_REWRITE_TAC[] THEN + ASM_REAL_ARITH_TAC; ALL_TAC] THEN + (* sup(C INTER {s <= y}) = a0 *) + SUBGOAL_THEN `sup ((C:real->bool) INTER {s:real | s <= y}) = a0` + ASSUME_TAC THENL [MATCH_MP_TAC(REAL_ARITH + `a <= s /\ s <= a ==> s = a`) THEN CONJ_TAC THENL + [(* a0 <= sup: a0 is in the set *) element_le_sup_inter_tac; + (* sup <= a0: a0 is an upper bound *) + MP_TAC(SPEC `(C:real->bool) INTER {s:real | s <= y}` SUP) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN EXISTS_TAC `&1` THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN ASM_MESON_TAC[]; + DISCH_THEN(MP_TAC o CONJUNCT2) THEN + DISCH_THEN(MP_TAC o SPEC `a0:real`) THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN DISCH_THEN MATCH_MP_TAC THEN + REPEAT STRIP_TAC THEN FIRST_X_ASSUM(MP_TAC o SPEC `x:real`) THEN + ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC]]; ALL_TAC] THEN + (* inf(C INTER {y <= s}) = b0 *) + SUBGOAL_THEN `inf ((C:real->bool) INTER {s:real | y <= s}) = b0` + ASSUME_TAC THENL [MATCH_MP_TAC(REAL_ARITH + `s <= b /\ b <= s ==> s = b`) THEN CONJ_TAC THENL + [(* inf <= b0: b0 is in the set *) inf_le_element_inter_tac; + (* b0 <= inf: b0 is a lower bound *) + MP_TAC(SPEC `(C:real->bool) INTER {s:real | y <= s}` INF) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN EXISTS_TAC `&0` THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN ASM_MESON_TAC[]; + DISCH_THEN(MP_TAC o CONJUNCT2) THEN + DISCH_THEN(MP_TAC o SPEC `b0:real`) THEN + REWRITE_TAC[IN_INTER; IN_ELIM_THM] THEN DISCH_THEN MATCH_MP_TAC THEN + REPEAT STRIP_TAC THEN FIRST_X_ASSUM(MP_TAC o SPEC `x:real`) THEN + ASM_REWRITE_TAC[] THEN ASM_REAL_ARITH_TAC]]; ALL_TAC] THEN + (* Simplify conditionals in FF *) + REPLICATE_TAC 3 (COND_CASES_TAC THENL [ASM_MESON_TAC[]; ALL_TAC]) THEN + ASM_REWRITE_TAC[] THEN + (* Apply V property *) + SUBGOAL_THEN `(y - a0) / (b0 - a0) IN (V:real->bool)` ASSUME_TAC THENL + [ASM_REWRITE_TAC[IN_INTER; IN_REAL_INTERVAL] THEN + SUBGOAL_THEN `&0 < b0 - a0` ASSUME_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + CONJ_TAC THENL [FIRST_X_ASSUM MATCH_MP_TAC THEN + REWRITE_TAC[REAL_ABS_DIV] THEN + SUBGOAL_THEN `abs(b0 - a0) = b0 - a0` SUBST1_TAC THENL + [ASM_REAL_ARITH_TAC; ALL_TAC] + THEN + ASM_SIMP_TAC[REAL_LT_LDIV_EQ] THEN + ASM_REAL_ARITH_TAC; div_bounds_tac]; ALL_TAC] THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]]]]; ALL_TAC] THEN + EXISTS_TAC `FF:real->A` THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[EXTENSION; IN_IMAGE] THEN X_GEN_TAC `y:A` THEN EQ_TAC THENL + [REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY] THEN + DISCH_THEN(X_CHOOSE_THEN `t:real` STRIP_ASSUME_TAC) THEN ASM_MESON_TAC[]; + DISCH_TAC THEN SUBGOAL_THEN `(y:A) IN IMAGE (f:real->A) C` MP_TAC THENL + [ASM SET_TAC[]; REWRITE_TAC[IN_IMAGE]] THEN + DISCH_THEN(X_CHOOSE_THEN `c:real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `c:real` THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ASM SET_TAC[]]]);; + +(* Backward direction: Peano space is continuous image of [0,1] *) +(* Proof: compose Alexandroff-Hausdorff surjection with inverse of Cantor + embedding, then extend via gap-filling *) +let HAHN_MAZURKIEWICZ_IMP = prove + (`!top:A topology. + compact_space top /\ + connected_space top /\ + locally_connected_space top /\ + metrizable_space top /\ + ~(topspace top = {}) + ==> ?f. continuous_map + (subtopology euclideanreal (real_interval[&0,&1]),top) f /\ + IMAGE f (real_interval[&0,&1]) = topspace top`, + GEN_TAC THEN STRIP_TAC THEN + (* Get surjection g: cantor_space -> top from Alexandroff-Hausdorff *) + MP_TAC(ISPEC `top:A topology` ALEXANDROFF_HAUSDORFF) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `g:(num->bool)->A` STRIP_ASSUME_TAC) THEN + (* Get inverse cinv of cantor_map from the embedding *) + MP_TAC CANTOR_MAP_EMBEDDING THEN + REWRITE_TAC[embedding_map; TOPSPACE_CANTOR_SPACE] THEN + GEN_REWRITE_TAC (LAND_CONV o ONCE_DEPTH_CONV) [HOMEOMORPHIC_MAP_MAPS] THEN + DISCH_THEN(X_CHOOSE_THEN `cinv:real->num->bool` MP_TAC) THEN + REWRITE_TAC[homeomorphic_maps; TOPSPACE_CANTOR_SPACE; + TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY; IN_UNIV] THEN STRIP_TAC THEN + (* Apply gap-filling: g o cinv is continuous surjection from + IMAGE cantor_map UNIV (closed in [0,1]) to top *) MP_TAC(ISPECL + [`top:A topology`; + `(g:(num->bool)->A) o (cinv:real->num->bool)`; + `IMAGE cantor_map (:num->bool)`] + PEANO_GAP_FILLING_EXTENSION) THEN ANTS_TAC THENL + [ASM_REWRITE_TAC[CANTOR_MAP_IMAGE_SUBSET_INTERVAL; + CANTOR_MAP_CLOSED_IN_INTERVAL] THEN + CONJ_TAC THENL [(* continuous_map (subtopology euclideanreal C, + top) (g o cinv) *) + MATCH_MP_TAC CONTINUOUS_MAP_COMPOSE THEN EXISTS_TAC `cantor_space` THEN + ASM_REWRITE_TAC[]; + (* IMAGE (g o cinv) C = topspace top *) + REWRITE_TAC[IMAGE_o] THEN SUBGOAL_THEN + `IMAGE (cinv:real->num->bool) (IMAGE cantor_map (:num->bool)) = + topspace cantor_space` (fun th -> ASM_REWRITE_TAC[th]) THEN + REWRITE_TAC[TOPSPACE_CANTOR_SPACE; EXTENSION; IN_IMAGE; IN_UNIV] THEN + ASM_MESON_TAC[]]; + MESON_TAC[]]);; -let DIMENSION_LE_RULES,DIMENSION_LE_INDUCT,DIMENSION_LE_CASES = - new_inductive_definition - `!top n. -- &1 <= n /\ - (!v a. open_in top v /\ a IN v - ==> ?u. a IN u /\ u SUBSET v /\ open_in top u /\ - subtopology top (top frontier_of u) - dimension_le (n - &1)) - ==> (top:A topology) dimension_le (n:int)`;; +(* The full Hahn-Mazurkiewicz theorem: Whyburn (4.1); H-Y 3-30; Willard 31.5 *) +let HAHN_MAZURKIEWICZ = prove + (`!top:A topology. + hausdorff_space top + ==> ((?f. continuous_map + (subtopology euclideanreal (real_interval[&0,&1]),top) + f /\ + IMAGE f (real_interval[&0,&1]) = topspace top) <=> + compact_space top /\ + connected_space top /\ + locally_connected_space top /\ + metrizable_space top /\ + ~(topspace top = {}))`, + let HAHN_MAZURKIEWICZ_FORWARD = prove + (`!top:A topology f. + hausdorff_space top /\ + continuous_map + (subtopology euclideanreal (real_interval[&0,&1]),top) f /\ + IMAGE f (real_interval[&0,&1]) = topspace top + ==> compact_space top /\ connected_space top /\ + locally_connected_space top /\ metrizable_space top`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + ABBREV_TAC + `sub = subtopology euclideanreal (real_interval[&0:real,&1])` THEN + SUBGOAL_THEN `compact_space (sub:real topology)` ASSUME_TAC THENL + [EXPAND_TAC "sub" THEN MATCH_MP_TAC COMPACT_SPACE_SUBTOPOLOGY THEN + REWRITE_TAC[COMPACT_IN_EUCLIDEANREAL_INTERVAL]; ALL_TAC] THEN + SUBGOAL_THEN + `topspace (sub:real topology) = real_interval[&0:real,&1]` + ASSUME_TAC THENL + [EXPAND_TAC "sub" THEN + REWRITE_TAC[TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY]; ALL_TAC] THEN + SUBGOAL_THEN `quotient_map(sub:real topology,top:A topology) f` + ASSUME_TAC THENL + [MATCH_MP_TAC CONTINUOUS_IMP_QUOTIENT_MAP THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `connected_space (sub:real topology)` ASSUME_TAC THENL + [EXPAND_TAC "sub" THEN MATCH_MP_TAC CONNECTED_SPACE_SUBTOPOLOGY THEN + REWRITE_TAC[CONNECTED_IN_EUCLIDEANREAL_INTERVAL]; ALL_TAC] THEN + SUBGOAL_THEN `locally_connected_space (sub:real topology)` + ASSUME_TAC THENL + [EXPAND_TAC "sub" THEN + REWRITE_TAC[LOCALLY_CONNECTED_REAL_INTERVAL]; ALL_TAC] THEN + REPEAT CONJ_TAC THENL + [ASM_MESON_TAC[COMPACT_SPACE_QUOTIENT_MAP_IMAGE]; + ASM_MESON_TAC[CONNECTED_SPACE_QUOTIENT_MAP_IMAGE]; + ASM_MESON_TAC[LOCALLY_CONNECTED_SPACE_QUOTIENT_MAP_IMAGE]; + MATCH_MP_TAC URYSOHN_METRIZATION THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL + [ASM_MESON_TAC[COMPACT_HAUSDORFF_IMP_REGULAR_SPACE; + COMPACT_SPACE_QUOTIENT_MAP_IMAGE]; ALL_TAC] THEN + MP_TAC(ISPECL [`f:real->A`; `sub:real topology`; `top:A topology`] + SECOND_COUNTABLE_CLOSED_MAP_IMAGE) THEN + ASM_REWRITE_TAC[] THEN DISCH_THEN MATCH_MP_TAC THEN + REPEAT CONJ_TAC THENL + [MATCH_MP_TAC CONTINUOUS_IMP_CLOSED_MAP THEN ASM_REWRITE_TAC[]; + EXPAND_TAC "sub" THEN + MATCH_MP_TAC SECOND_COUNTABLE_SUBTOPOLOGY THEN + MATCH_MP_TAC SEPARABLE_METRIZABLE_IMP_SECOND_COUNTABLE THEN + REWRITE_TAC[METRIZABLE_SPACE_EUCLIDEANREAL; separable_space; + TOPSPACE_EUCLIDEANREAL] THEN + EXISTS_TAC `rational` THEN + REWRITE_TAC[COUNTABLE_RATIONAL; SUBSET_UNIV; + EUCLIDEANREAL_CLOSURE_OF_RATIONAL]]]) in + GEN_TAC THEN DISCH_TAC THEN EQ_TAC THENL + [DISCH_THEN(X_CHOOSE_THEN `f:real->A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN + `compact_space top /\ connected_space top /\ + locally_connected_space top /\ + metrizable_space (top:A topology)` STRIP_ASSUME_TAC THENL + [MATCH_MP_TAC HAHN_MAZURKIEWICZ_FORWARD THEN + EXISTS_TAC `f:real->A` THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + EXISTS_TAC `(f:real->A) (&0)` THEN + FIRST_X_ASSUM(fun th -> GEN_REWRITE_TAC RAND_CONV [SYM th]) THEN + REWRITE_TAC[IN_IMAGE] THEN EXISTS_TAC `&0` THEN + REWRITE_TAC[IN_REAL_INTERVAL] THEN REAL_ARITH_TAC; + STRIP_TAC THEN MATCH_MP_TAC HAHN_MAZURKIEWICZ_IMP THEN + ASM_REWRITE_TAC[]]);; -let DIMENSION_LE_NEIGHBOURHOOD_BASE = prove - (`!(top:A topology) n. - top dimension_le n <=> - -- &1 <= n /\ - neighbourhood_base_of - (\u. open_in top u /\ - (subtopology top (top frontier_of u)) - dimension_le (n - &1)) top`, - REPEAT GEN_TAC THEN SIMP_TAC[OPEN_NEIGHBOURHOOD_BASE_OF] THEN - GEN_REWRITE_TAC LAND_CONV [DIMENSION_LE_CASES] THEN MESON_TAC[]);; +(* Compact case: H-Y Theorem 3-15; Whyburn (5.1). Compact + connected + *) +(* locally connected ==> path connected, via H-M backward (the space is *) +(* a continuous image of [0,1], which is path connected). *) -let DIMENSION_LE_BOUND = prove - (`!top:(A)topology n. top dimension_le n ==> -- &1 <= n`, - MATCH_MP_TAC DIMENSION_LE_INDUCT THEN SIMP_TAC[]);; +let COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED = prove + (`!m:A metric s. + compact_in (mtopology m) s /\ + connected_in (mtopology m) s /\ + locally_connected_space (subtopology (mtopology m) s) + ==> path_connected_space (subtopology (mtopology m) s)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN `(s:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN + ASM_CASES_TAC `s:A->bool = {}` THENL + [MATCH_MP_TAC PATH_CONNECTED_SPACE_TOPSPACE_EMPTY THEN + ASM_REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; TOPSPACE_MTOPOLOGY] THEN + ASM SET_TAC[]; + ALL_TAC] THEN + ABBREV_TAC `top = subtopology (mtopology m) (s:A->bool)` THEN + MP_TAC(ISPEC `top:A topology` HAHN_MAZURKIEWICZ_IMP) THEN + ANTS_TAC THENL + [EXPAND_TAC "top" THEN REPEAT CONJ_TAC THENL + [MATCH_MP_TAC COMPACT_SPACE_SUBTOPOLOGY THEN ASM_REWRITE_TAC[]; + ASM_MESON_TAC[CONNECTED_SPACE_SUBTOPOLOGY; connected_in]; + ASM_REWRITE_TAC[]; + MATCH_MP_TAC METRIZABLE_SPACE_SUBTOPOLOGY THEN + REWRITE_TAC[METRIZABLE_SPACE_MTOPOLOGY]; + REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; TOPSPACE_MTOPOLOGY] THEN + ASM SET_TAC[]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `f:real->A` STRIP_ASSUME_TAC) THEN + REWRITE_TAC[GSYM PATH_CONNECTED_IN_TOPSPACE] THEN + FIRST_ASSUM(SUBST1_TAC o SYM) THEN + MATCH_MP_TAC PATH_CONNECTED_IN_CONTINUOUS_MAP_IMAGE THEN + EXISTS_TAC + `subtopology euclideanreal (real_interval[&0,&1])` THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[path_connected_in; TOPSPACE_EUCLIDEANREAL_SUBTOPOLOGY; + SUBSET_REFL; SUBTOPOLOGY_SUBTOPOLOGY; INTER_IDEMPOT] THEN + MP_TAC(CONJUNCT1 PATH_CONNECTED_IN_EUCLIDEANREAL_INTERVAL) THEN + SIMP_TAC[path_connected_in; TOPSPACE_EUCLIDEANREAL; SUBSET_UNIV]);; -let DIMENSION_LE_MONO = prove - (`!top:(A)topology m n. top dimension_le m /\ m <= n ==> top dimension_le n`, - REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN - MATCH_MP_TAC DIMENSION_LE_INDUCT THEN - MAP_EVERY X_GEN_TAC [`top:(A)topology`; `m:int`] THEN STRIP_TAC THEN - X_GEN_TAC `n:int` THEN DISCH_TAC THEN - GEN_REWRITE_TAC I [DIMENSION_LE_CASES] THEN - CONJ_TAC THENL [ASM_MESON_TAC[INT_LE_TRANS]; ALL_TAC] THEN - MAP_EVERY X_GEN_TAC [`v:A->bool`; `a:A`] THEN STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`v:A->bool`; `a:A`]) THEN - ASM_REWRITE_TAC[] THEN MATCH_MP_TAC MONO_EXISTS THEN - GEN_TAC THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN - FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_INT_ARITH_TAC);; +(* Mcomplete case: Whyburn, Analytic Topology, Theorem (5.4); H-Y 3-17. *) +(* Any two points sit inside an LC continuum (by the Imbedding Theorem), *) +(* and the compact case gives path-connectedness of that continuum. *) -let DIMENSION_LE_EQ_EMPTY = prove - (`!top:(A)topology. top dimension_le (-- &1) <=> topspace top = {}`, - REPEAT GEN_TAC THEN ONCE_REWRITE_TAC[DIMENSION_LE_CASES] THEN - CONV_TAC INT_REDUCE_CONV THEN - SUBGOAL_THEN `!top:A topology. ~(top dimension_le --(&2))` - (fun th -> REWRITE_TAC[th]) - THENL - [GEN_TAC THEN DISCH_THEN(MP_TAC o MATCH_MP DIMENSION_LE_BOUND) THEN - INT_ARITH_TAC; - EQ_TAC THENL - [DISCH_THEN(MP_TAC o SPEC `topspace top:A->bool`) THEN - REWRITE_TAC[OPEN_IN_TOPSPACE] THEN SET_TAC[]; - REPEAT STRIP_TAC THEN - FIRST_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN - ASM SET_TAC[]]]);; +let MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_IN = + prove + (`!m:A metric s. + mcomplete(submetric m s) /\ + connected_in (mtopology m) s /\ + locally_connected_space (subtopology (mtopology m) s) + ==> path_connected_space (subtopology (mtopology m) s)`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN `(s:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[CONNECTED_IN_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN + REWRITE_TAC[path_connected_space; TOPSPACE_SUBTOPOLOGY; + TOPSPACE_MTOPOLOGY] THEN + ASM_SIMP_TAC[SET_RULE `s SUBSET t ==> t INTER s = (s:A->bool)`] THEN + MAP_EVERY X_GEN_TAC [`a:A`; `b:A`] THEN STRIP_TAC THEN + MP_TAC(ISPECL [`m:A metric`; `s:A->bool`; `a:A`; `b:A`] + MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM_IN) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `K:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(K:A->bool) SUBSET mspace m` ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBSET_TOPSPACE; TOPSPACE_MTOPOLOGY]; + ALL_TAC] THEN + SUBGOAL_THEN + `path_connected_space (subtopology (mtopology m) (K:A->bool))` + MP_TAC THENL + [MATCH_MP_TAC + COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[path_connected_space; TOPSPACE_SUBTOPOLOGY; + TOPSPACE_MTOPOLOGY] THEN + ASM_SIMP_TAC[SET_RULE `K SUBSET t ==> t INTER K = (K:A->bool)`] THEN + DISCH_THEN(MP_TAC o SPECL [`a:A`; `b:A`]) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `g:real->A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `g:real->A` THEN ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [path_in]) THEN + REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; path_in] THEN + STRIP_TAC THEN REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]);; -let DIMENSION_LE_0_NEIGHBOURHOOD_BASE_OF_CLOPEN = prove - (`!top:A topology. - top dimension_le &0 <=> - neighbourhood_base_of (\u. closed_in top u /\ open_in top u) top`, - GEN_TAC THEN GEN_REWRITE_TAC LAND_CONV [DIMENSION_LE_NEIGHBOURHOOD_BASE] THEN - CONV_TAC INT_REDUCE_CONV THEN - REWRITE_TAC[DIMENSION_LE_EQ_EMPTY; TOPSPACE_SUBTOPOLOGY] THEN - AP_THM_TAC THEN AP_TERM_TAC THEN ABS_TAC THEN - SIMP_TAC[FRONTIER_OF_SUBSET_TOPSPACE; SET_RULE - `s SUBSET u ==> u INTER s = s`] THEN - MESON_TAC[FRONTIER_OF_EQ_EMPTY; OPEN_IN_SUBSET]);; +let MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED = prove + (`!m:A metric. + mcomplete m /\ + connected_space (mtopology m) /\ + locally_connected_space (mtopology m) + ==> path_connected_space (mtopology m)`, + GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPECL [`m:A metric`; `mspace m:A->bool`] + MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_IN) THEN + ASM_SIMP_TAC[SUBMETRIC_MSPACE; SUBTOPOLOGY_MSPACE; connected_in; + TOPSPACE_MTOPOLOGY; SUBSET_REFL]);; -let DIMENSION_LE_SUBTOPOLOGY = prove - (`!top n s:A->bool. - top dimension_le n ==> (subtopology top s) dimension_le n`, - REWRITE_TAC[RIGHT_FORALL_IMP_THM] THEN MATCH_MP_TAC DIMENSION_LE_INDUCT THEN - MAP_EVERY X_GEN_TAC [`top:A topology`; `n:int`] THEN STRIP_TAC THEN - X_GEN_TAC `s:A->bool` THEN GEN_REWRITE_TAC I [DIMENSION_LE_CASES] THEN - ASM_REWRITE_TAC[] THEN MAP_EVERY X_GEN_TAC [`u':A->bool`; `a:A`] THEN - GEN_REWRITE_TAC (LAND_CONV o LAND_CONV) [OPEN_IN_SUBTOPOLOGY] THEN - REWRITE_TAC[IMP_CONJ; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN DISCH_THEN SUBST1_TAC THEN - REWRITE_TAC[IN_INTER] THEN STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`u:A->bool`; `a:A`]) THEN - ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `v:A->bool` THEN STRIP_TAC THEN - EXISTS_TAC `s INTER v:A->bool` THEN - ASM_REWRITE_TAC[IN_INTER] THEN REPEAT CONJ_TAC THENL - [ASM SET_TAC[]; - REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN ASM_MESON_TAC[INTER_COMM]; - FIRST_X_ASSUM(MP_TAC o SPEC - `subtopology top s frontier_of (s INTER v):A->bool`) THEN - REWRITE_TAC[SUBTOPOLOGY_SUBTOPOLOGY] THEN - MATCH_MP_TAC EQ_IMP THEN AP_THM_TAC THEN AP_TERM_TAC THEN - AP_TERM_TAC THEN MATCH_MP_TAC(SET_RULE - `s SUBSET u /\ s SUBSET t ==> t INTER s = u INTER s`) THEN - REWRITE_TAC[FRONTIER_OF_SUBSET_SUBTOPOLOGY] THEN - REWRITE_TAC[FRONTIER_OF_CLOSURES; CLOSURE_OF_SUBTOPOLOGY] THEN - REWRITE_TAC[TOPSPACE_SUBTOPOLOGY; INTER_ASSOC] THEN - MATCH_MP_TAC(SET_RULE - `t SUBSET u /\ v SUBSET w - ==> s INTER t INTER s INTER v SUBSET u INTER w`) THEN - CONJ_TAC THEN MATCH_MP_TAC CLOSURE_OF_MONO THEN SET_TAC[]]);; +(* Whyburn, Analytic Topology, Corollaries (5.2)-(5.3). *) +let LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_SPACE = prove + (`!m:A metric s. + locally_compact_space (subtopology (mtopology m) s) /\ + connected_in (mtopology m) s /\ + locally_connected_space (subtopology (mtopology m) s) + ==> path_connected_space (subtopology (mtopology m) s)`, + REPEAT STRIP_TAC THEN SUBGOAL_THEN + `locally_path_connected_space (subtopology (mtopology m) (s:A->bool))` + ASSUME_TAC THENL [REWRITE_TAC[locally_path_connected_space] THEN + MP_TAC(ISPECL [`m:A metric`; `s:A->bool`] LOCALLY_CONNECTED_CONTINUUM_SPACE) THEN + DISCH_THEN(MP_TAC o snd o EQ_IMP_RULE) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN MP_TAC(ISPECL + [`subtopology (mtopology m) (s:A->bool)`; + `\c:A->bool. compact_in (subtopology (mtopology m) s) c /\ + connected_in (subtopology (mtopology m) s) c /\ + locally_connected_space + (subtopology (mtopology m) c)`; `path_connected_in + (subtopology (mtopology m) s):(A->bool)->bool`] + NEIGHBOURHOOD_BASE_OF_MONO) THEN ANTS_TAC THENL + [CONJ_TAC THENL [X_GEN_TAC `c:A->bool` THEN + REWRITE_TAC[COMPACT_IN_SUBTOPOLOGY; CONNECTED_IN_SUBTOPOLOGY] THEN + STRIP_TAC THEN SUBGOAL_THEN `(c:A->bool) SUBSET topspace(mtopology m)` + ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBSET_TOPSPACE]; ALL_TAC] THEN + REWRITE_TAC[path_connected_in; TOPSPACE_SUBTOPOLOGY; + SUBTOPOLOGY_SUBTOPOLOGY] THEN ASM_SIMP_TAC[SET_RULE + `(c:A->bool) SUBSET s ==> s INTER c = c`] THEN CONJ_TAC THENL + [ASM SET_TAC[]; MATCH_MP_TAC + COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED THEN + ASM_REWRITE_TAC[]]; ASM_REWRITE_TAC[]]; + DISCH_THEN ACCEPT_TAC]; ASM_MESON_TAC[PATH_CONNECTED_EQ_CONNECTED_SPACE; + CONNECTED_SPACE_SUBTOPOLOGY]]);; + +(* The locally-path-connected part extracted as a standalone theorem: *) +(* locally compact + locally connected ==> locally path connected. *) + +let LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_SPACE = prove + (`!m:A metric s. + locally_compact_space(subtopology (mtopology m) s) /\ + locally_connected_space(subtopology (mtopology m) s) + ==> locally_path_connected_space(subtopology (mtopology m) s)`, + REPEAT STRIP_TAC THEN REWRITE_TAC[locally_path_connected_space] THEN + MP_TAC(ISPECL [`m:A metric`; `s:A->bool`] LOCALLY_CONNECTED_CONTINUUM_SPACE) THEN + DISCH_THEN(MP_TAC o snd o EQ_IMP_RULE) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN MP_TAC(ISPECL + [`subtopology (mtopology m) (s:A->bool)`; + `\c:A->bool. compact_in (subtopology (mtopology m) s) c /\ + connected_in (subtopology (mtopology m) s) c /\ + locally_connected_space (subtopology (mtopology m) c)`; + `path_connected_in (subtopology (mtopology m) s):(A->bool)->bool`] + NEIGHBOURHOOD_BASE_OF_MONO) THEN ANTS_TAC THENL + [CONJ_TAC THENL [X_GEN_TAC `c:A->bool` THEN + REWRITE_TAC[COMPACT_IN_SUBTOPOLOGY; CONNECTED_IN_SUBTOPOLOGY] THEN + STRIP_TAC THEN + SUBGOAL_THEN `(c:A->bool) SUBSET topspace(mtopology m)` ASSUME_TAC THENL + [ASM_MESON_TAC[COMPACT_IN_SUBSET_TOPSPACE]; ALL_TAC] THEN + REWRITE_TAC[path_connected_in; TOPSPACE_SUBTOPOLOGY; + SUBTOPOLOGY_SUBTOPOLOGY] THEN + ASM_SIMP_TAC[SET_RULE `(c:A->bool) SUBSET s ==> s INTER c = c`] THEN + CONJ_TAC THENL [ASM SET_TAC[]; MATCH_MP_TAC + COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED THEN + ASM_REWRITE_TAC[]]; ASM_REWRITE_TAC[]]; DISCH_THEN ACCEPT_TAC]);; + +let LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_SPACE = prove + (`!m:A metric s. + locally_compact_space(subtopology (mtopology m) s) + ==> (locally_path_connected_space(subtopology (mtopology m) s) <=> + locally_connected_space(subtopology (mtopology m) s))`, + MESON_TAC[LOCALLY_PATH_CONNECTED_IMP_LOCALLY_CONNECTED_SPACE; + LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_SPACE]);; -let DIMENSION_LE_SUBTOPOLOGIES = prove - (`!top n s t:A->bool. - s SUBSET t /\ - subtopology top t dimension_le n - ==> (subtopology top s) dimension_le n`, - REPEAT STRIP_TAC THEN FIRST_ASSUM(MP_TAC o - ISPEC `s:A->bool` o MATCH_MP DIMENSION_LE_SUBTOPOLOGY) THEN - REWRITE_TAC[SUBTOPOLOGY_SUBTOPOLOGY] THEN - ASM_SIMP_TAC[SET_RULE `s SUBSET t ==> t INTER s = s`]);; +let MCOMPLETE_IN_LOCALLY_COMPACT_IMP_LOCALLY_COMPACT = prove + (`!m:A metric s. + locally_compact_space(mtopology m) /\ + mcomplete(submetric m s) /\ + s SUBSET mspace m + ==> locally_compact_space(subtopology (mtopology m) s)`, + REPEAT STRIP_TAC THEN MATCH_MP_TAC LOCALLY_COMPACT_SPACE_CLOSED_SUBSET THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC MCOMPLETE_IMP_CLOSED_IN THEN + ASM_REWRITE_TAC[]);; -let DIMENSION_LE_EQ_SUBTOPOLOGY = prove - (`!top s:A->bool n. - (subtopology top s) dimension_le n <=> - -- &1 <= n /\ - !v a. open_in top v /\ a IN v /\ a IN s - ==> ?u. a IN u /\ u SUBSET v /\ open_in top u /\ - subtopology top - ((subtopology top s frontier_of (s INTER u))) - dimension_le (n - &1)`, - REPEAT GEN_TAC THEN - GEN_REWRITE_TAC LAND_CONV [DIMENSION_LE_CASES] THEN - REWRITE_TAC[SUBTOPOLOGY_SUBTOPOLOGY; OPEN_IN_SUBTOPOLOGY] THEN - REWRITE_TAC[LEFT_AND_EXISTS_THM; LEFT_IMP_EXISTS_THM] THEN - ONCE_REWRITE_TAC[MESON[] - `(!v a t. (P t /\ Q v t) /\ R a v t ==> S a v t) <=> - (!t a v. Q v t ==> P t /\ R a v t ==> S a v t)`] THEN - REWRITE_TAC[FORALL_UNWIND_THM2] THEN AP_TERM_TAC THEN - AP_TERM_TAC THEN GEN_REWRITE_TAC I [FUN_EQ_THM] THEN - X_GEN_TAC `v:A->bool` THEN REWRITE_TAC[] THEN - AP_TERM_TAC THEN GEN_REWRITE_TAC I [FUN_EQ_THM] THEN - X_GEN_TAC `a:A` THEN REWRITE_TAC[IN_INTER] THEN - MATCH_MP_TAC(TAUT `(p ==> (q <=> r)) ==> (p ==> q <=> p ==> r)`) THEN - STRIP_TAC THEN REWRITE_TAC[RIGHT_AND_EXISTS_THM] THEN - GEN_REWRITE_TAC LAND_CONV [SWAP_EXISTS_THM] THEN - ONCE_REWRITE_TAC[TAUT - `p /\ q /\ (r /\ s) /\ t <=> s /\ p /\ q /\ r /\ t`] THEN - ASM_REWRITE_TAC[UNWIND_THM2; IN_INTER] THEN - EQ_TAC THEN DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN - EXISTS_TAC `u INTER v:A->bool` THEN - ASM_SIMP_TAC[IN_INTER; OPEN_IN_INTER] THEN - (CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC]) THEN - ASM_SIMP_TAC[SET_RULE `u SUBSET v ==> u INTER v = u`; - SET_RULE `u INTER s SUBSET v INTER s - ==> s INTER u INTER v = s INTER u`] THEN - POP_ASSUM_LIST(MP_TAC o end_itlist CONJ o rev) THEN - ASM_SIMP_TAC[FRONTIER_OF_SUBSET_SUBTOPOLOGY; - SET_RULE `v SUBSET u ==> u INTER v = v`] THEN - STRIP_TAC THEN ONCE_REWRITE_TAC[INTER_COMM] THEN ASM_REWRITE_TAC[]);; +(* mcomplete + locally connected ==> locally path connected. *) +(* Uses Alexandrov's theorem (open subsets of completely metrizable *) +(* spaces are completely metrizable) combined with the Menger theorem. *) -let HOMEOMORPHIC_SPACE_DIMENSION_LE = prove - (`!(top:A topology) (top':B topology) n. - top homeomorphic_space top' - ==> (top dimension_le n <=> top' dimension_le n)`, - let lemma = prove - (`!n (top:A topology) (top':B topology). - top homeomorphic_space top' /\ top dimension_le (&n - &1) - ==> top' dimension_le (&n - &1)`, - INDUCT_TAC THENL - [CONV_TAC INT_REDUCE_CONV THEN REWRITE_TAC[DIMENSION_LE_EQ_EMPTY] THEN - MESON_TAC[HOMEOMORPHIC_EMPTY_SPACE]; - REWRITE_TAC[GSYM INT_OF_NUM_SUC; INT_ARITH `(x + y) - y:int = x`]] THEN - MAP_EVERY X_GEN_TAC [`top:A topology`; `top':B topology`] THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN - ONCE_REWRITE_TAC[DIMENSION_LE_CASES] THEN - STRIP_TAC THEN ASM_REWRITE_TAC[] THEN - FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [homeomorphic_space]) THEN - REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`f:A->B`; `g:B->A`] THEN STRIP_TAC THEN - MAP_EVERY X_GEN_TAC [`v:B->bool`; `b:B`] THEN STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`IMAGE (g:B->A) v`; `(g:B->A) b`]) THEN - ANTS_TAC THENL - [ASM_MESON_TAC[HOMEOMORPHIC_MAPS_MAP; HOMEOMORPHIC_IMP_OPEN_MAP; - open_map; FUN_IN_IMAGE]; - DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC)] THEN - EXISTS_TAC `IMAGE (f:A->B) u` THEN REPEAT CONJ_TAC THENL - [REPEAT(FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET)) THEN - RULE_ASSUM_TAC(REWRITE_RULE[homeomorphic_maps; continuous_map]) THEN - ASM SET_TAC[]; - REPEAT(FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET)) THEN - RULE_ASSUM_TAC(REWRITE_RULE[homeomorphic_maps; continuous_map]) THEN - ASM SET_TAC[]; - ASM_MESON_TAC[HOMEOMORPHIC_MAPS_MAP; HOMEOMORPHIC_MAP_OPENNESS_EQ]; - FIRST_X_ASSUM MATCH_MP_TAC THEN - EXISTS_TAC `subtopology top (top frontier_of u:A->bool)` THEN - ASM_REWRITE_TAC[homeomorphic_space] THEN - MAP_EVERY EXISTS_TAC [`f:A->B`; `g:B->A`] THEN - MATCH_MP_TAC HOMEOMORPHIC_MAPS_SUBTOPOLOGIES THEN - ASM_SIMP_TAC[FRONTIER_OF_SUBSET_TOPSPACE; SET_RULE - `s SUBSET t ==> t INTER s = s`] THEN - CONV_TAC SYM_CONV THEN MATCH_MP_TAC HOMEOMORPHIC_MAP_FRONTIER_OF THEN - ASM_MESON_TAC[OPEN_IN_SUBSET; HOMEOMORPHIC_MAPS_MAP]]) in - REPEAT STRIP_TAC THEN ASM_CASES_TAC `-- &1:int <= n` THENL - [ALL_TAC; ASM_MESON_TAC[DIMENSION_LE_BOUND]] THEN - SUBST1_TAC(INT_ARITH `n:int = (n + &1) - &1`) THEN - FIRST_X_ASSUM(MP_TAC o MATCH_MP - (INT_ARITH `--x:int <= y ==> &0 <= y + x`)) THEN - REWRITE_TAC[GSYM INT_OF_NUM_EXISTS; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `n:num` THEN DISCH_THEN SUBST1_TAC THEN - EQ_TAC THEN MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ] lemma) THEN - ASM_MESON_TAC[HOMEOMORPHIC_SPACE_SYM]);; +let MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED = prove + (`!m:A metric. + mcomplete m /\ locally_connected_space (mtopology m) + ==> locally_path_connected_space (mtopology m)`, + GEN_TAC THEN STRIP_TAC THEN + REWRITE_TAC[LOCALLY_PATH_CONNECTED_SPACE] THEN + MAP_EVERY X_GEN_TAC [`w:A->bool`; `x:A`] THEN STRIP_TAC THEN + SUBGOAL_THEN + `?u:A->bool. open_in (mtopology m) u /\ + connected_in (mtopology m) u /\ x IN u /\ u SUBSET w` + (X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THENL + [ASM_MESON_TAC[LOCALLY_CONNECTED_SPACE]; ALL_TAC] THEN + EXISTS_TAC `u:A->bool` THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[path_connected_in; TOPSPACE_MTOPOLOGY] THEN + CONJ_TAC THENL + [ASM_MESON_TAC[connected_in; TOPSPACE_MTOPOLOGY]; ALL_TAC] THEN + MP_TAC(ISPECL [`mtopology(m:A metric)`; `u:A->bool`] + COMPLETELY_METRIZABLE_SPACE_OPEN_IN) THEN + ASM_SIMP_TAC[COMPLETELY_METRIZABLE_SPACE_MTOPOLOGY] THEN + REWRITE_TAC[completely_metrizable_space] THEN + DISCH_THEN(X_CHOOSE_THEN `m':A metric` STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC + MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [ASM_MESON_TAC[connected_in]; + ASM_MESON_TAC[LOCALLY_CONNECTED_SPACE_OPEN_SUBSET]]);; -let DIMENSION_LE_RETRACTION_MAP_IMAGE = prove - (`!top top' n (r:A->B). - retraction_map(top,top') r /\ top dimension_le n - ==> top' dimension_le n`, - GEN_REWRITE_TAC I [MESON[] `(!x y z. P x y z) <=> (!z x y. P x y z)`] THEN - GEN_TAC THEN MATCH_MP_TAC HEREDITARY_IMP_RETRACTIVE_PROPERTY THEN - REWRITE_TAC[DIMENSION_LE_SUBTOPOLOGY; HOMEOMORPHIC_SPACE_DIMENSION_LE]);; +let MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED = prove + (`!m:A metric. + mcomplete m + ==> (locally_path_connected_space(mtopology m) <=> + locally_connected_space(mtopology m))`, + MESON_TAC[LOCALLY_PATH_CONNECTED_IMP_LOCALLY_CONNECTED_SPACE; + MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED]);; -let DIMENSION_LE_DISCRETE_TOPOLOGY = prove - (`!u:A->bool. (discrete_topology u) dimension_le &0`, - GEN_TAC THEN ONCE_REWRITE_TAC[DIMENSION_LE_CASES] THEN - CONV_TAC INT_REDUCE_CONV THEN - REWRITE_TAC[OPEN_IN_DISCRETE_TOPOLOGY; DISCRETE_TOPOLOGY_FRONTIER_OF] THEN - REWRITE_TAC[DIMENSION_LE_EQ_EMPTY; TOPSPACE_SUBTOPOLOGY; INTER_EMPTY] THEN - SET_TAC[]);; +let COMPLETELY_METRIZABLE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED = + prove + (`!top:A topology. + completely_metrizable_space top + ==> (locally_path_connected_space top <=> + locally_connected_space top)`, + GEN_TAC THEN REWRITE_TAC[completely_metrizable_space] THEN + DISCH_THEN(X_CHOOSE_THEN `m:A metric` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST1_TAC)) THEN + MATCH_MP_TAC + MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED THEN + ASM_REWRITE_TAC[]);; -let ZERO_DIMENSIONAL_IMP_COMPLETELY_REGULAR_SPACE = prove - (`!top:A topology. top dimension_le &0 ==> completely_regular_space top`, - GEN_TAC THEN REWRITE_TAC[DIMENSION_LE_0_NEIGHBOURHOOD_BASE_OF_CLOPEN] THEN - SIMP_TAC[OPEN_NEIGHBOURHOOD_BASE_OF] THEN DISCH_TAC THEN - REWRITE_TAC[completely_regular_space; IN_DIFF] THEN - MAP_EVERY X_GEN_TAC [`c:A->bool`; `a:A`] THEN STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`topspace top DIFF c:A->bool`; `a:A`]) THEN - ASM_SIMP_TAC[IN_DIFF; OPEN_IN_DIFF; OPEN_IN_TOPSPACE] THEN - DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN - EXISTS_TAC `(\x. if x IN u then &0 else &1):A->real` THEN - ASM_REWRITE_TAC[] THEN CONJ_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN - REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; SUBSET; FORALL_IN_IMAGE] THEN - CONJ_TAC THENL [ALL_TAC; ASM_MESON_TAC[ENDS_IN_UNIT_REAL_INTERVAL]] THEN - REWRITE_TAC[continuous_map; TOPSPACE_EUCLIDEANREAL; IN_UNIV] THEN - X_GEN_TAC `r:real->bool` THEN DISCH_TAC THEN REWRITE_TAC[TAUT - `(if p then a else b) IN r <=> p /\ a IN r \/ ~p /\ b IN r`] THEN - MAP_EVERY ASM_CASES_TAC [`(&0:real) IN r`; `(&1:real) IN r`] THEN - ASM_REWRITE_TAC[EMPTY_GSPEC; OPEN_IN_EMPTY; OPEN_IN_TOPSPACE; - IN_GSPEC; TAUT `p \/ ~p`] THEN - ASM_REWRITE_TAC[GSYM DIFF; GSYM INTER] THEN - ASM_SIMP_TAC[OPEN_IN_TOPSPACE; OPEN_IN_INTER; OPEN_IN_DIFF]);; +(* completely_metrizable_space + connected + locally connected *) +(* ==> path connected. (Menger via completely_metrizable_space) *) -let ZERO_DIMENSIONAL_IMP_REGULAR_SPACE = prove - (`!top:A topology. top dimension_le &0 ==> regular_space top`, - MESON_TAC[COMPLETELY_REGULAR_IMP_REGULAR_SPACE; - ZERO_DIMENSIONAL_IMP_COMPLETELY_REGULAR_SPACE]);; +let COMPLETELY_METRIZABLE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED = + prove + (`!top:A topology. + completely_metrizable_space top /\ + connected_space top /\ + locally_connected_space top + ==> path_connected_space top`, + GEN_TAC THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [completely_metrizable_space]) THEN + DISCH_THEN(X_CHOOSE_THEN `m:A metric` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST_ALL_TAC)) THEN + MATCH_MP_TAC + MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED THEN + ASM_REWRITE_TAC[]);; (* ------------------------------------------------------------------------- *) (* Theorems from Kuratowski's "Remark on an Invariance Theorem", Fundamenta *) diff --git a/Multivariate/multivariate_database.ml b/Multivariate/multivariate_database.ml index f4d6767e..1728e68f 100644 --- a/Multivariate/multivariate_database.ml +++ b/Multivariate/multivariate_database.ml @@ -488,6 +488,7 @@ theorems := "ALEXANDER_SUBBASE_THEOREM_ALT",ALEXANDER_SUBBASE_THEOREM_ALT; "ALEXANDROFF_COMPACTIFICATION_DENSE",ALEXANDROFF_COMPACTIFICATION_DENSE; "ALEXANDROFF_COMPACTIFICATION_UNIQUE",ALEXANDROFF_COMPACTIFICATION_UNIQUE; +"ALEXANDROFF_HAUSDORFF",ALEXANDROFF_HAUSDORFF; "ALL",ALL; "ALL2",ALL2; "ALL2_ALL",ALL2_ALL; @@ -1182,6 +1183,27 @@ theorems := "CANTOR_BAIRE_STATIONARY_PRINCIPLE",CANTOR_BAIRE_STATIONARY_PRINCIPLE; "CANTOR_BENDIXSON",CANTOR_BENDIXSON; "CANTOR_BENDIXSON_GEN",CANTOR_BENDIXSON_GEN; +"CANTOR_MAP_CLOSED_IMAGE",CANTOR_MAP_CLOSED_IMAGE; +"CANTOR_MAP_CLOSED_IN_INTERVAL",CANTOR_MAP_CLOSED_IN_INTERVAL; +"CANTOR_MAP_CONTINUOUS",CANTOR_MAP_CONTINUOUS; +"CANTOR_MAP_EMBEDDING",CANTOR_MAP_EMBEDDING; +"CANTOR_MAP_GE_PARTIAL_SUM",CANTOR_MAP_GE_PARTIAL_SUM; +"CANTOR_MAP_IMAGE_SUBSET_INTERVAL",CANTOR_MAP_IMAGE_SUBSET_INTERVAL; +"CANTOR_MAP_INJECTIVE",CANTOR_MAP_INJECTIVE; +"CANTOR_MAP_LE_ONE",CANTOR_MAP_LE_ONE; +"CANTOR_MAP_PARTIAL_SUM_BOUND",CANTOR_MAP_PARTIAL_SUM_BOUND; +"CANTOR_MAP_POS",CANTOR_MAP_POS; +"CANTOR_MAP_RANGE",CANTOR_MAP_RANGE; +"CANTOR_MAP_STRICT_LT",CANTOR_MAP_STRICT_LT; +"CANTOR_MAP_SUMMABLE",CANTOR_MAP_SUMMABLE; +"CANTOR_MAP_SUMS",CANTOR_MAP_SUMS; +"CANTOR_PARTIAL_SUM_DIFF_AT_K",CANTOR_PARTIAL_SUM_DIFF_AT_K; +"CANTOR_PARTIAL_SUM_MONO",CANTOR_PARTIAL_SUM_MONO; +"CANTOR_SET_SUBSET_INTERVAL",CANTOR_SET_SUBSET_INTERVAL; +"CANTOR_SPACE_HOMEOMORPHIC_CANTOR_SET",CANTOR_SPACE_HOMEOMORPHIC_CANTOR_SET; +"CANTOR_TERM_BOUND",CANTOR_TERM_BOUND; +"CANTOR_TERM_CONTINUOUS",CANTOR_TERM_CONTINUOUS; +"CANTOR_TERM_POS",CANTOR_TERM_POS; "CANTOR_THM",CANTOR_THM; "CANTOR_THM_UNIV",CANTOR_THM_UNIV; "CAPPED_METRIC",CAPPED_METRIC; @@ -1656,11 +1678,14 @@ theorems := "CHAIN_BOUNDARY_SINGULAR_SUBDIVISION",CHAIN_BOUNDARY_SINGULAR_SUBDIVISION; "CHAIN_BOUNDARY_SUB",CHAIN_BOUNDARY_SUB; "CHAIN_BOUNDARY_SUM",CHAIN_BOUNDARY_SUM; +"CHAIN_FROM_OPEN_COVER",CHAIN_FROM_OPEN_COVER; "CHAIN_GROUP",CHAIN_GROUP; +"CHAIN_HIERARCHY",CHAIN_HIERARCHY; "CHAIN_HOMOTOPIC_IMP_HOMOLOGOUS_REL",CHAIN_HOMOTOPIC_IMP_HOMOLOGOUS_REL; "CHAIN_HOMOTOPIC_ITERATED_SINGULAR_SUBDIVISION",CHAIN_HOMOTOPIC_ITERATED_SINGULAR_SUBDIVISION; "CHAIN_HOMOTOPIC_SIMPLICIAL_SUBDIVISION",CHAIN_HOMOTOPIC_SIMPLICIAL_SUBDIVISION; "CHAIN_HOMOTOPIC_SINGULAR_SUBDIVISION",CHAIN_HOMOTOPIC_SINGULAR_SUBDIVISION; +"CHAIN_IN_OPEN_CONNECTED_SET",CHAIN_IN_OPEN_CONNECTED_SET; "CHAIN_MAP_0",CHAIN_MAP_0; "CHAIN_MAP_ADD",CHAIN_MAP_ADD; "CHAIN_MAP_CMUL",CHAIN_MAP_CMUL; @@ -1674,6 +1699,7 @@ theorems := "CHAIN_MAP_SIMPLICIAL_CONE",CHAIN_MAP_SIMPLICIAL_CONE; "CHAIN_MAP_SUB",CHAIN_MAP_SUB; "CHAIN_MAP_SUM",CHAIN_MAP_SUM; +"CHAIN_REFINEMENT_STEP",CHAIN_REFINEMENT_STEP; "CHAIN_SUBSET",CHAIN_SUBSET; "CHARACTERISTIC_POLYNOMIAL",CHARACTERISTIC_POLYNOMIAL; "CHINESE_REMAINDER",CHINESE_REMAINDER; @@ -1773,6 +1799,8 @@ theorems := "CLOSED_IN_ALEXANDROFF_COMPACTIFICATION_IMAGE_INL",CLOSED_IN_ALEXANDROFF_COMPACTIFICATION_IMAGE_INL; "CLOSED_IN_ANALYTIC",CLOSED_IN_ANALYTIC; "CLOSED_IN_BOREL",CLOSED_IN_BOREL; +"CLOSED_IN_CANTOR_SET",CLOSED_IN_CANTOR_SET; +"CLOSED_IN_CANTOR_SET_INTERVAL",CLOSED_IN_CANTOR_SET_INTERVAL; "CLOSED_IN_CARTESIAN_PRODUCT",CLOSED_IN_CARTESIAN_PRODUCT; "CLOSED_IN_CLOSED",CLOSED_IN_CLOSED; "CLOSED_IN_CLOSED_EQ",CLOSED_IN_CLOSED_EQ; @@ -2051,6 +2079,7 @@ theorems := "CLOSURE_OF_CLOSURE_OF",CLOSURE_OF_CLOSURE_OF; "CLOSURE_OF_COMPLEMENT",CLOSURE_OF_COMPLEMENT; "CLOSURE_OF_CROSS",CLOSURE_OF_CROSS; +"CLOSURE_OF_DYADIC_RATIONALS_IN_UNIT_INTERVAL",CLOSURE_OF_DYADIC_RATIONALS_IN_UNIT_INTERVAL; "CLOSURE_OF_EMPTY",CLOSURE_OF_EMPTY; "CLOSURE_OF_EQ",CLOSURE_OF_EQ; "CLOSURE_OF_EQ_EMPTY",CLOSURE_OF_EQ_EMPTY; @@ -2215,6 +2244,8 @@ theorems := "COMPACT_CLOSURE_OF_IMP_TOTALLY_BOUNDED_IN",COMPACT_CLOSURE_OF_IMP_TOTALLY_BOUNDED_IN; "COMPACT_COMPONENTS",COMPACT_COMPONENTS; "COMPACT_CONNECTED_COMPONENT",COMPACT_CONNECTED_COMPONENT; +"COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED",COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED; +"COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN",COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN; "COMPACT_CONTINUOUS_IMAGE",COMPACT_CONTINUOUS_IMAGE; "COMPACT_CONTINUOUS_IMAGE_EQ",COMPACT_CONTINUOUS_IMAGE_EQ; "COMPACT_CONVEX_COLLINEAR_SEGMENT",COMPACT_CONVEX_COLLINEAR_SEGMENT; @@ -2249,6 +2280,7 @@ theorems := "COMPACT_IMP_K_SPACE",COMPACT_IMP_K_SPACE; "COMPACT_IMP_LINDELOF_SPACE",COMPACT_IMP_LINDELOF_SPACE; "COMPACT_IMP_LOCALLY_COMPACT_SPACE",COMPACT_IMP_LOCALLY_COMPACT_SPACE; +"COMPACT_IMP_PARACOMPACT_SPACE",COMPACT_IMP_PARACOMPACT_SPACE; "COMPACT_IMP_PERFECT_MAP",COMPACT_IMP_PERFECT_MAP; "COMPACT_IMP_PROPER_MAP",COMPACT_IMP_PROPER_MAP; "COMPACT_IMP_PROPER_MAP_GEN",COMPACT_IMP_PROPER_MAP_GEN; @@ -2280,6 +2312,11 @@ theorems := "COMPACT_IN_IMP_TOTALLY_BOUNDED_IN_EXPLICIT",COMPACT_IN_IMP_TOTALLY_BOUNDED_IN_EXPLICIT; "COMPACT_IN_INTER",COMPACT_IN_INTER; "COMPACT_IN_KIFICATION",COMPACT_IN_KIFICATION; +"COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE",COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE; +"COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE_ALT",COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE_ALT; +"COMPACT_IN_LOCALLY_CONNECTED_IMP_FCCOVERABLE_SPACE",COMPACT_IN_LOCALLY_CONNECTED_IMP_FCCOVERABLE_SPACE; +"COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE",COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE; +"COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE_ALT",COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE_ALT; "COMPACT_IN_MSPACE_CFUNSPACE",COMPACT_IN_MSPACE_CFUNSPACE; "COMPACT_IN_PATH_IMAGE",COMPACT_IN_PATH_IMAGE; "COMPACT_IN_PROPER_MAP_PREIMAGE",COMPACT_IN_PROPER_MAP_PREIMAGE; @@ -2288,13 +2325,16 @@ theorems := "COMPACT_IN_SEQUENTIALLY",COMPACT_IN_SEQUENTIALLY; "COMPACT_IN_SING",COMPACT_IN_SING; "COMPACT_IN_STANDARD_SIMPLEX",COMPACT_IN_STANDARD_SIMPLEX; +"COMPACT_IN_SUBMETRIC_EUCLIDEAN_MSPACE",COMPACT_IN_SUBMETRIC_EUCLIDEAN_MSPACE; "COMPACT_IN_SUBSET_TOPSPACE",COMPACT_IN_SUBSET_TOPSPACE; "COMPACT_IN_SUBSPACE",COMPACT_IN_SUBSPACE; "COMPACT_IN_SUBTOPOLOGY",COMPACT_IN_SUBTOPOLOGY; +"COMPACT_IN_SUBTOPOLOGY_EUCLIDEAN",COMPACT_IN_SUBTOPOLOGY_EUCLIDEAN; "COMPACT_IN_SUBTOPOLOGY_IMP_COMPACT",COMPACT_IN_SUBTOPOLOGY_IMP_COMPACT; "COMPACT_IN_UNION",COMPACT_IN_UNION; "COMPACT_IN_UNIONS",COMPACT_IN_UNIONS; "COMPACT_KC_EQ_MAXIMAL_COMPACT_SPACE",COMPACT_KC_EQ_MAXIMAL_COMPACT_SPACE; +"COMPACT_LF_OPEN_NEIGHBORHOOD",COMPACT_LF_OPEN_NEIGHBORHOOD; "COMPACT_LINEAR_IMAGE",COMPACT_LINEAR_IMAGE; "COMPACT_LINEAR_IMAGE_EQ",COMPACT_LINEAR_IMAGE_EQ; "COMPACT_LOCALLY_CONNECTED_EQ_FCCCOVERABLE",COMPACT_LOCALLY_CONNECTED_EQ_FCCCOVERABLE; @@ -2302,8 +2342,12 @@ theorems := "COMPACT_LOCALLY_CONNECTED_IMP_FCCOVERABLE",COMPACT_LOCALLY_CONNECTED_IMP_FCCOVERABLE; "COMPACT_LOCALLY_CONNECTED_IMP_ULC",COMPACT_LOCALLY_CONNECTED_IMP_ULC; "COMPACT_LOCALLY_CONNECTED_IMP_ULC_ALT",COMPACT_LOCALLY_CONNECTED_IMP_ULC_ALT; +"COMPACT_LOCALLY_CONNECTED_NEARBY_PATH",COMPACT_LOCALLY_CONNECTED_NEARBY_PATH; +"COMPACT_METRIZABLE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED",COMPACT_METRIZABLE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED; +"COMPACT_METRIZABLE_PEANO_IMP_PATH_CONNECTED",COMPACT_METRIZABLE_PEANO_IMP_PATH_CONNECTED; "COMPACT_NEGATIONS",COMPACT_NEGATIONS; "COMPACT_NEST",COMPACT_NEST; +"COMPACT_NESTED_INTERS",COMPACT_NESTED_INTERS; "COMPACT_OPEN",COMPACT_OPEN; "COMPACT_PARTITION_CONTAINING_CLOSED",COMPACT_PARTITION_CONTAINING_CLOSED; "COMPACT_PARTITION_CONTAINING_POINTS",COMPACT_PARTITION_CONTAINING_POINTS; @@ -2326,6 +2370,7 @@ theorems := "COMPACT_SPACE",COMPACT_SPACE; "COMPACT_SPACE_ALEXANDROFF_COMPACTIFICATION",COMPACT_SPACE_ALEXANDROFF_COMPACTIFICATION; "COMPACT_SPACE_ALT",COMPACT_SPACE_ALT; +"COMPACT_SPACE_CANTOR_SPACE",COMPACT_SPACE_CANTOR_SPACE; "COMPACT_SPACE_CONTRACTIVE",COMPACT_SPACE_CONTRACTIVE; "COMPACT_SPACE_DISCRETE_TOPOLOGY",COMPACT_SPACE_DISCRETE_TOPOLOGY; "COMPACT_SPACE_EQ_BOLZANO_WEIERSTRASS",COMPACT_SPACE_EQ_BOLZANO_WEIERSTRASS; @@ -2353,6 +2398,7 @@ theorems := "COMPACT_SUP_MAXDISTANCE",COMPACT_SUP_MAXDISTANCE; "COMPACT_TRANSLATION",COMPACT_TRANSLATION; "COMPACT_TRANSLATION_EQ",COMPACT_TRANSLATION_EQ; +"COMPACT_TUBE_COVER",COMPACT_TUBE_COVER; "COMPACT_UNIFORMLY_CONTINUOUS",COMPACT_UNIFORMLY_CONTINUOUS; "COMPACT_UNIFORMLY_EQUICONTINUOUS",COMPACT_UNIFORMLY_EQUICONTINUOUS; "COMPACT_UNION",COMPACT_UNION; @@ -2366,8 +2412,10 @@ theorems := "COMPLEMENT_PATH_COMPONENTS_OF_UNIONS",COMPLEMENT_PATH_COMPONENTS_OF_UNIONS; "COMPLEMENT_PATH_COMPONENT_UNIONS",COMPLEMENT_PATH_COMPONENT_UNIONS; "COMPLEMENT_QUASI_COMPONENTS_OF_UNIONS",COMPLEMENT_QUASI_COMPONENTS_OF_UNIONS; +"COMPLETELY_METRIZABLE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED",COMPLETELY_METRIZABLE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED; "COMPLETELY_METRIZABLE_EUCLIDEAN_SPACE",COMPLETELY_METRIZABLE_EUCLIDEAN_SPACE; "COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE",COMPLETELY_METRIZABLE_IMP_METRIZABLE_SPACE; +"COMPLETELY_METRIZABLE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED",COMPLETELY_METRIZABLE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED; "COMPLETELY_METRIZABLE_SPACE_CLOSED_IN",COMPLETELY_METRIZABLE_SPACE_CLOSED_IN; "COMPLETELY_METRIZABLE_SPACE_DISCRETE_TOPOLOGY",COMPLETELY_METRIZABLE_SPACE_DISCRETE_TOPOLOGY; "COMPLETELY_METRIZABLE_SPACE_EQ_GDELTA_IN",COMPLETELY_METRIZABLE_SPACE_EQ_GDELTA_IN; @@ -2604,7 +2652,9 @@ theorems := "CONNECTED_COMPONENT_OF_EQUIV",CONNECTED_COMPONENT_OF_EQUIV; "CONNECTED_COMPONENT_OF_EQ_EMPTY",CONNECTED_COMPONENT_OF_EQ_EMPTY; "CONNECTED_COMPONENT_OF_EQ_OVERLAP",CONNECTED_COMPONENT_OF_EQ_OVERLAP; +"CONNECTED_COMPONENT_OF_EQ_WELLCHAINED",CONNECTED_COMPONENT_OF_EQ_WELLCHAINED; "CONNECTED_COMPONENT_OF_EUCLIDEAN",CONNECTED_COMPONENT_OF_EUCLIDEAN; +"CONNECTED_COMPONENT_OF_IMP_WELLCHAINED",CONNECTED_COMPONENT_OF_IMP_WELLCHAINED; "CONNECTED_COMPONENT_OF_MAXIMAL",CONNECTED_COMPONENT_OF_MAXIMAL; "CONNECTED_COMPONENT_OF_MONO",CONNECTED_COMPONENT_OF_MONO; "CONNECTED_COMPONENT_OF_NONOVERLAP",CONNECTED_COMPONENT_OF_NONOVERLAP; @@ -2667,6 +2717,7 @@ theorems := "CONNECTED_EQ_CONNECTED_COMPONENT_EQ",CONNECTED_EQ_CONNECTED_COMPONENT_EQ; "CONNECTED_EQ_NONSEPARATED_CLOSED_COMPLEMENT_COMPONENT",CONNECTED_EQ_NONSEPARATED_CLOSED_COMPLEMENT_COMPONENT; "CONNECTED_EQ_WELLCHAINED",CONNECTED_EQ_WELLCHAINED; +"CONNECTED_EQ_WELLCHAINED_IN",CONNECTED_EQ_WELLCHAINED_IN; "CONNECTED_EUCLIDEAN_SPACE",CONNECTED_EUCLIDEAN_SPACE; "CONNECTED_FINITE_EQ_LOWDIM",CONNECTED_FINITE_EQ_LOWDIM; "CONNECTED_FINITE_IFF_COUNTABLE",CONNECTED_FINITE_IFF_COUNTABLE; @@ -2700,6 +2751,9 @@ theorems := "CONNECTED_INTER_RELATIVE_FRONTIER",CONNECTED_INTER_RELATIVE_FRONTIER; "CONNECTED_IN_ABSOLUTE",CONNECTED_IN_ABSOLUTE; "CONNECTED_IN_CARTESIAN_PRODUCT",CONNECTED_IN_CARTESIAN_PRODUCT; +"CONNECTED_IN_CHAIN",CONNECTED_IN_CHAIN; +"CONNECTED_IN_CHAIN_GEN",CONNECTED_IN_CHAIN_GEN; +"CONNECTED_IN_CHAIN_UNIONS",CONNECTED_IN_CHAIN_UNIONS; "CONNECTED_IN_CLOPEN_CASES",CONNECTED_IN_CLOPEN_CASES; "CONNECTED_IN_CLOSED_IN",CONNECTED_IN_CLOSED_IN; "CONNECTED_IN_CLOSURE_OF",CONNECTED_IN_CLOSURE_OF; @@ -2716,11 +2770,15 @@ theorems := "CONNECTED_IN_EUCLIDEANREAL",CONNECTED_IN_EUCLIDEANREAL; "CONNECTED_IN_EUCLIDEANREAL_INTERVAL",CONNECTED_IN_EUCLIDEANREAL_INTERVAL; "CONNECTED_IN_EUCLIDEAN_COMPLEMENTS",CONNECTED_IN_EUCLIDEAN_COMPLEMENTS; +"CONNECTED_IN_IFF_CONNECTED_COMPONENT_OF",CONNECTED_IN_IFF_CONNECTED_COMPONENT_OF; "CONNECTED_IN_IMP_PERFECT",CONNECTED_IN_IMP_PERFECT; "CONNECTED_IN_IMP_PERFECT_GEN",CONNECTED_IN_IMP_PERFECT_GEN; +"CONNECTED_IN_IMP_WELLCHAINED",CONNECTED_IN_IMP_WELLCHAINED; "CONNECTED_IN_INTERMEDIATE_CLOSURE_OF",CONNECTED_IN_INTERMEDIATE_CLOSURE_OF; "CONNECTED_IN_INTER_FRONTIER_OF",CONNECTED_IN_INTER_FRONTIER_OF; "CONNECTED_IN_MONOTONE_QUOTIENT_MAP_PREIMAGE",CONNECTED_IN_MONOTONE_QUOTIENT_MAP_PREIMAGE; +"CONNECTED_IN_NEST",CONNECTED_IN_NEST; +"CONNECTED_IN_NEST_GEN",CONNECTED_IN_NEST_GEN; "CONNECTED_IN_NONSEPARATED_UNION",CONNECTED_IN_NONSEPARATED_UNION; "CONNECTED_IN_PATH_IMAGE",CONNECTED_IN_PATH_IMAGE; "CONNECTED_IN_SEPARATION",CONNECTED_IN_SEPARATION; @@ -2728,12 +2786,16 @@ theorems := "CONNECTED_IN_SING",CONNECTED_IN_SING; "CONNECTED_IN_SPHERE_DELETE_INTERIOR_POINT_EQ",CONNECTED_IN_SPHERE_DELETE_INTERIOR_POINT_EQ; "CONNECTED_IN_STANDARD_SIMPLEX",CONNECTED_IN_STANDARD_SIMPLEX; +"CONNECTED_IN_SUBMETRIC_EUCLIDEAN",CONNECTED_IN_SUBMETRIC_EUCLIDEAN; +"CONNECTED_IN_SUBMETRIC_EUCLIDEAN_MSPACE",CONNECTED_IN_SUBMETRIC_EUCLIDEAN_MSPACE; "CONNECTED_IN_SUBSET_SEPARATED_UNION",CONNECTED_IN_SUBSET_SEPARATED_UNION; "CONNECTED_IN_SUBSET_TOPSPACE",CONNECTED_IN_SUBSET_TOPSPACE; "CONNECTED_IN_SUBTOPOLOGY",CONNECTED_IN_SUBTOPOLOGY; +"CONNECTED_IN_SUBTOPOLOGY_EUCLIDEAN",CONNECTED_IN_SUBTOPOLOGY_EUCLIDEAN; "CONNECTED_IN_TOPSPACE",CONNECTED_IN_TOPSPACE; "CONNECTED_IN_UNION",CONNECTED_IN_UNION; "CONNECTED_IN_UNIONS",CONNECTED_IN_UNIONS; +"CONNECTED_IN_UNIONS_STRONG",CONNECTED_IN_UNIONS_STRONG; "CONNECTED_IVT_COMPONENT",CONNECTED_IVT_COMPONENT; "CONNECTED_IVT_HYPERPLANE",CONNECTED_IVT_HYPERPLANE; "CONNECTED_JACOBIAN_GRAPH",CONNECTED_JACOBIAN_GRAPH; @@ -3128,6 +3190,7 @@ theorems := "CONTINUOUS_MAP_SQRT",CONTINUOUS_MAP_SQRT; "CONTINUOUS_MAP_SQUARE_ROOT",CONTINUOUS_MAP_SQUARE_ROOT; "CONTINUOUS_MAP_SUM",CONTINUOUS_MAP_SUM; +"CONTINUOUS_MAP_SUM_LOCALLY_FINITE",CONTINUOUS_MAP_SUM_LOCALLY_FINITE; "CONTINUOUS_MAP_SUP",CONTINUOUS_MAP_SUP; "CONTINUOUS_MAP_TO_METRIC",CONTINUOUS_MAP_TO_METRIC; "CONTINUOUS_MAP_UNIFORMLY_CAUCHY_LIMIT",CONTINUOUS_MAP_UNIFORMLY_CAUCHY_LIMIT; @@ -3732,6 +3795,7 @@ theorems := "COUNTABLE_IMP_DISCONNECTED",COUNTABLE_IMP_DISCONNECTED; "COUNTABLE_IMP_FSIGMA",COUNTABLE_IMP_FSIGMA; "COUNTABLE_IMP_LINDELOF_SPACE",COUNTABLE_IMP_LINDELOF_SPACE; +"COUNTABLE_IMP_SIGMA_LOCALLY_FINITE_IN",COUNTABLE_IMP_SIGMA_LOCALLY_FINITE_IN; "COUNTABLE_INSERT",COUNTABLE_INSERT; "COUNTABLE_INTEGER",COUNTABLE_INTEGER; "COUNTABLE_INTEGER_COORDINATES",COUNTABLE_INTEGER_COORDINATES; @@ -3953,6 +4017,7 @@ theorems := "DENSE_COMPLEMENT_CONVEX_CLOSED",DENSE_COMPLEMENT_CONVEX_CLOSED; "DENSE_COMPLEMENT_OPEN_IN_AFFINE_HULL",DENSE_COMPLEMENT_OPEN_IN_AFFINE_HULL; "DENSE_COMPLEMENT_SUBSPACE",DENSE_COMPLEMENT_SUBSPACE; +"DENSE_FUNCTION_ON_DYADIC",DENSE_FUNCTION_ON_DYADIC; "DENSE_GDELTA_IMP_LARGE",DENSE_GDELTA_IMP_LARGE; "DENSE_IMP_PERFECT",DENSE_IMP_PERFECT; "DENSE_INTERSECTS_OPEN",DENSE_INTERSECTS_OPEN; @@ -4708,6 +4773,7 @@ theorems := "EMBEDDING_IMP_MONOTONE_MAP",EMBEDDING_IMP_MONOTONE_MAP; "EMBEDDING_IMP_OPEN_MAP",EMBEDDING_IMP_OPEN_MAP; "EMBEDDING_IMP_OPEN_MAP_EQ",EMBEDDING_IMP_OPEN_MAP_EQ; +"EMBEDDING_INTO_METRIZABLE_IMP_METRIZABLE",EMBEDDING_INTO_METRIZABLE_IMP_METRIZABLE; "EMBEDDING_MAP_COMPONENT_INJECTION",EMBEDDING_MAP_COMPONENT_INJECTION; "EMBEDDING_MAP_COMPOSE",EMBEDDING_MAP_COMPOSE; "EMBEDDING_MAP_EQ",EMBEDDING_MAP_EQ; @@ -4800,6 +4866,7 @@ theorems := "ENR_TRANSLATION",ENR_TRANSLATION; "ENR_TRIANGULATION",ENR_TRIANGULATION; "ENR_UNIV",ENR_UNIV; +"EPSILON_ABSORBING_IMP_CLOPEN",EPSILON_ABSORBING_IMP_CLOPEN; "EPSILON_DELTA_MINIMAL",EPSILON_DELTA_MINIMAL; "EQUIINTEGRABLE_ADD",EQUIINTEGRABLE_ADD; "EQUIINTEGRABLE_CLOSED_INTERVAL_RESTRICTIONS",EQUIINTEGRABLE_CLOSED_INTERVAL_RESTRICTIONS; @@ -5069,6 +5136,8 @@ theorems := "EXISTS_VECTOR_4",EXISTS_VECTOR_4; "EXP",EXP; "EXPAND_CLOSED_OPEN_INTERVAL",EXPAND_CLOSED_OPEN_INTERVAL; +"EXPANSION_SET_CONTAINS",EXPANSION_SET_CONTAINS; +"EXPANSION_SET_OPEN",EXPANSION_SET_OPEN; "EXPLICIT_SUBSET_INTERIOR_CONVEX_HULL",EXPLICIT_SUBSET_INTERIOR_CONVEX_HULL; "EXPLICIT_SUBSET_INTERIOR_CONVEX_HULL_MINIMAL",EXPLICIT_SUBSET_INTERIOR_CONVEX_HULL_MINIMAL; "EXPLICIT_SUBSET_RELATIVE_INTERIOR_CONVEX_HULL",EXPLICIT_SUBSET_RELATIVE_INTERIOR_CONVEX_HULL; @@ -5257,6 +5326,14 @@ theorems := "FATOU_STRONG",FATOU_STRONG; "FCCOVERABLE_IMP_LOCALLY_CONNECTED",FCCOVERABLE_IMP_LOCALLY_CONNECTED; "FCCOVERABLE_INTERMEDIATE_CLOSURE",FCCOVERABLE_INTERMEDIATE_CLOSURE; +"FCCOVERABLE_IN_COMPACT_LOCALLY_CONNECTED",FCCOVERABLE_IN_COMPACT_LOCALLY_CONNECTED; +"FCCOVERABLE_IN_EUCLIDEAN_METRIC",FCCOVERABLE_IN_EUCLIDEAN_METRIC; +"FCCOVERABLE_IN_IMP_FCCOVERABLE_SPACE_SUBMETRIC",FCCOVERABLE_IN_IMP_FCCOVERABLE_SPACE_SUBMETRIC; +"FCCOVERABLE_IN_IMP_LOCALLY_CONNECTED_SPACE",FCCOVERABLE_IN_IMP_LOCALLY_CONNECTED_SPACE; +"FCCOVERABLE_SPACE_EQ_FCCOVERABLE_IN_MSPACE",FCCOVERABLE_SPACE_EQ_FCCOVERABLE_IN_MSPACE; +"FCCOVERABLE_SPACE_IMP_LOCALLY_CONNECTED_SPACE",FCCOVERABLE_SPACE_IMP_LOCALLY_CONNECTED_SPACE; +"FCCOVERABLE_SPACE_INTERMEDIATE_CLOSURE",FCCOVERABLE_SPACE_INTERMEDIATE_CLOSURE; +"FCCOVERABLE_SPACE_SUBMETRIC_EUCLIDEAN",FCCOVERABLE_SPACE_SUBMETRIC_EUCLIDEAN; "FCONS",FCONS; "FCONS_UNDO",FCONS_UNDO; "FGSIGMA_BAIRE_PREIMAGE_OPEN_ALT",FGSIGMA_BAIRE_PREIMAGE_OPEN_ALT; @@ -5328,6 +5405,9 @@ theorems := "FINITE_COMPONENTS_PUNCTURED_CONNECTED_SUBSET_SPHERE",FINITE_COMPONENTS_PUNCTURED_CONNECTED_SUBSET_SPHERE; "FINITE_COMPONENTS_PUNCTURED_CONVEX",FINITE_COMPONENTS_PUNCTURED_CONVEX; "FINITE_COMPONENTS_UNION",FINITE_COMPONENTS_UNION; +"FINITE_CONNECTED_COMPONENTS_CLOPEN_UNION",FINITE_CONNECTED_COMPONENTS_CLOPEN_UNION; +"FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED",FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED; +"FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED_EUCLIDEAN",FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED_EUCLIDEAN; "FINITE_CONNECTED_COMPONENTS_OF_FINITE",FINITE_CONNECTED_COMPONENTS_OF_FINITE; "FINITE_CROSS",FINITE_CROSS; "FINITE_CROSS_EQ",FINITE_CROSS_EQ; @@ -5992,6 +6072,7 @@ theorems := "GDELTA_BAIRE_PREIMAGE_CLOSED",GDELTA_BAIRE_PREIMAGE_CLOSED; "GDELTA_BAIRE_PREIMAGE_CLOSED_GEN",GDELTA_BAIRE_PREIMAGE_CLOSED_GEN; "GDELTA_COMPLEMENT",GDELTA_COMPLEMENT; +"GDELTA_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED",GDELTA_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED; "GDELTA_CONTINUOUS_FUNCTION_MINIMA",GDELTA_CONTINUOUS_FUNCTION_MINIMA; "GDELTA_DESCENDING",GDELTA_DESCENDING; "GDELTA_DIFF",GDELTA_DIFF; @@ -6024,8 +6105,10 @@ theorems := "GDELTA_IN_UNION",GDELTA_IN_UNION; "GDELTA_LINEAR_IMAGE",GDELTA_LINEAR_IMAGE; "GDELTA_LOCALLY_COMPACT",GDELTA_LOCALLY_COMPACT; +"GDELTA_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED",GDELTA_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED; "GDELTA_LOCALLY_EQ",GDELTA_LOCALLY_EQ; "GDELTA_LOCALLY_GEN",GDELTA_LOCALLY_GEN; +"GDELTA_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED",GDELTA_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED; "GDELTA_LOCALLY_TRANS",GDELTA_LOCALLY_TRANS; "GDELTA_PCROSS",GDELTA_PCROSS; "GDELTA_PCROSS_EQ",GDELTA_PCROSS_EQ; @@ -6676,6 +6759,8 @@ theorems := "HADAMARD_INEQUALITY_COLUMN",HADAMARD_INEQUALITY_COLUMN; "HADAMARD_INEQUALITY_PSD",HADAMARD_INEQUALITY_PSD; "HADAMARD_INEQUALITY_ROW",HADAMARD_INEQUALITY_ROW; +"HAHN_MAZURKIEWICZ",HAHN_MAZURKIEWICZ; +"HAHN_MAZURKIEWICZ_IMP",HAHN_MAZURKIEWICZ_IMP; "HAIRY_BALL_THEOREM",HAIRY_BALL_THEOREM; "HAIRY_BALL_THEOREM_ALT",HAIRY_BALL_THEOREM_ALT; "HALFSPACE_EQ_EMPTY_GE",HALFSPACE_EQ_EMPTY_GE; @@ -7147,6 +7232,7 @@ theorems := "HAUSDORFF_NORMAL_SPACE_CLOSED_CONTINUOUS_MAP_IMAGE",HAUSDORFF_NORMAL_SPACE_CLOSED_CONTINUOUS_MAP_IMAGE; "HAUSDORFF_SPACE_ALEXANDROFF_COMPACTIFICATION",HAUSDORFF_SPACE_ALEXANDROFF_COMPACTIFICATION; "HAUSDORFF_SPACE_ALEXANDROFF_COMPACTIFICATION_ASYMMETRIC_PROD",HAUSDORFF_SPACE_ALEXANDROFF_COMPACTIFICATION_ASYMMETRIC_PROD; +"HAUSDORFF_SPACE_CANTOR_SPACE",HAUSDORFF_SPACE_CANTOR_SPACE; "HAUSDORFF_SPACE_CLOSED_CONTINUOUS_MAP_IMAGE",HAUSDORFF_SPACE_CLOSED_CONTINUOUS_MAP_IMAGE; "HAUSDORFF_SPACE_CLOSED_CONTINUOUS_MAP_IMAGE_EQ",HAUSDORFF_SPACE_CLOSED_CONTINUOUS_MAP_IMAGE_EQ; "HAUSDORFF_SPACE_CLOSED_IN_DIAGONAL",HAUSDORFF_SPACE_CLOSED_IN_DIAGONAL; @@ -7366,6 +7452,7 @@ theorems := "HOMEOMORPHIC_OPEN_INTERVALS_1",HOMEOMORPHIC_OPEN_INTERVALS_1; "HOMEOMORPHIC_OPEN_INTERVAL_UNIV",HOMEOMORPHIC_OPEN_INTERVAL_UNIV; "HOMEOMORPHIC_OPEN_INTERVAL_UNIV_1",HOMEOMORPHIC_OPEN_INTERVAL_UNIV_1; +"HOMEOMORPHIC_PARACOMPACT_SPACE",HOMEOMORPHIC_PARACOMPACT_SPACE; "HOMEOMORPHIC_PATH_CONNECTEDNESS",HOMEOMORPHIC_PATH_CONNECTEDNESS; "HOMEOMORPHIC_PATH_CONNECTED_SPACE",HOMEOMORPHIC_PATH_CONNECTED_SPACE; "HOMEOMORPHIC_PCROSS",HOMEOMORPHIC_PCROSS; @@ -8970,6 +9057,7 @@ theorems := "IN_CLOSURE_CONNECTED_COMPONENT",IN_CLOSURE_CONNECTED_COMPONENT; "IN_CLOSURE_DELETE",IN_CLOSURE_DELETE; "IN_CLOSURE_OF",IN_CLOSURE_OF; +"IN_CLOSURE_OF_IMP_SUBSET_MCBALL",IN_CLOSURE_OF_IMP_SUBSET_MCBALL; "IN_COMPONENTS",IN_COMPONENTS; "IN_COMPONENTS_CONNECTED",IN_COMPONENTS_CONNECTED; "IN_COMPONENTS_MAXIMAL",IN_COMPONENTS_MAXIMAL; @@ -9696,6 +9784,9 @@ theorems := "LE_SUC",LE_SUC; "LE_SUC_LT",LE_SUC_LT; "LE_TRANS",LE_TRANS; +"LF_CLOSED_PERFECT_MAP_IMAGE",LF_CLOSED_PERFECT_MAP_IMAGE; +"LF_COVERING_IMP_LF_CLOSED",LF_COVERING_IMP_LF_CLOSED; +"LF_COVERING_IMP_LF_OPEN",LF_COVERING_IMP_LF_OPEN; "LIEB",LIEB; "LIFT_ADD",LIFT_ADD; "LIFT_CMUL",LIFT_CMUL; @@ -9946,6 +10037,7 @@ theorems := "LIM_WITHIN_UNION",LIM_WITHIN_UNION; "LIM_WITHIN_ZERO",LIM_WITHIN_ZERO; "LINDELOF",LINDELOF; +"LINDELOF_HAUSDORFF_REGULAR_EQ_PARACOMPACT",LINDELOF_HAUSDORFF_REGULAR_EQ_PARACOMPACT; "LINDELOF_OPEN_IN",LINDELOF_OPEN_IN; "LINDELOF_SPACE_ALT",LINDELOF_SPACE_ALT; "LINDELOF_SPACE_CLOSED_IN_SUBTOPOLOGY",LINDELOF_SPACE_CLOSED_IN_SUBTOPOLOGY; @@ -10167,6 +10259,8 @@ theorems := "LOCALLY_COMPACT_COMPACT_ALT",LOCALLY_COMPACT_COMPACT_ALT; "LOCALLY_COMPACT_COMPACT_SUBOPEN",LOCALLY_COMPACT_COMPACT_SUBOPEN; "LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED",LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED; +"LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN",LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN; +"LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_SPACE",LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_SPACE; "LOCALLY_COMPACT_DELETE",LOCALLY_COMPACT_DELETE; "LOCALLY_COMPACT_EUCLIDEAN_SPACE",LOCALLY_COMPACT_EUCLIDEAN_SPACE; "LOCALLY_COMPACT_HAUSDORFF_IMP_REGULAR_SPACE",LOCALLY_COMPACT_HAUSDORFF_IMP_REGULAR_SPACE; @@ -10186,12 +10280,17 @@ theorems := "LOCALLY_COMPACT_KC_SPACE_ALT",LOCALLY_COMPACT_KC_SPACE_ALT; "LOCALLY_COMPACT_LINEAR_IMAGE_EQ",LOCALLY_COMPACT_LINEAR_IMAGE_EQ; "LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED",LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED; +"LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN",LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN; +"LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_SPACE",LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_SPACE; "LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED",LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED; +"LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN",LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN; +"LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_SPACE",LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_SPACE; "LOCALLY_COMPACT_OPEN_IN",LOCALLY_COMPACT_OPEN_IN; "LOCALLY_COMPACT_OPEN_INTER_CLOSURE",LOCALLY_COMPACT_OPEN_INTER_CLOSURE; "LOCALLY_COMPACT_OPEN_UNION",LOCALLY_COMPACT_OPEN_UNION; "LOCALLY_COMPACT_OPEN_UNIONS",LOCALLY_COMPACT_OPEN_UNIONS; "LOCALLY_COMPACT_PATH_CONNECTED_EQ_CONNECTED",LOCALLY_COMPACT_PATH_CONNECTED_EQ_CONNECTED; +"LOCALLY_COMPACT_PATH_CONNECTED_EQ_CONNECTED_EUCLIDEAN",LOCALLY_COMPACT_PATH_CONNECTED_EQ_CONNECTED_EUCLIDEAN; "LOCALLY_COMPACT_PCROSS",LOCALLY_COMPACT_PCROSS; "LOCALLY_COMPACT_PCROSS_EQ",LOCALLY_COMPACT_PCROSS_EQ; "LOCALLY_COMPACT_PROPER_CONTINUOUS_PREIMAGE",LOCALLY_COMPACT_PROPER_CONTINUOUS_PREIMAGE; @@ -10206,6 +10305,7 @@ theorems := "LOCALLY_COMPACT_SPACE_CONTINUOUS_OPEN_MAP_IMAGE",LOCALLY_COMPACT_SPACE_CONTINUOUS_OPEN_MAP_IMAGE; "LOCALLY_COMPACT_SPACE_DISCRETE_TOPOLOGY",LOCALLY_COMPACT_SPACE_DISCRETE_TOPOLOGY; "LOCALLY_COMPACT_SPACE_EUCLIDEANREAL",LOCALLY_COMPACT_SPACE_EUCLIDEANREAL; +"LOCALLY_COMPACT_SPACE_IMP_GDELTA_IN",LOCALLY_COMPACT_SPACE_IMP_GDELTA_IN; "LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE",LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE; "LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE_CLOSED_IN",LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE_CLOSED_IN; "LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE_CLOSURE_OF",LOCALLY_COMPACT_SPACE_NEIGHBOURHOOD_BASE_CLOSURE_OF; @@ -10217,6 +10317,7 @@ theorems := "LOCALLY_COMPACT_SPACE_PRODUCT_TOPOLOGY",LOCALLY_COMPACT_SPACE_PRODUCT_TOPOLOGY; "LOCALLY_COMPACT_SPACE_PROD_TOPOLOGY",LOCALLY_COMPACT_SPACE_PROD_TOPOLOGY; "LOCALLY_COMPACT_SPACE_RETRACTION_MAP_IMAGE",LOCALLY_COMPACT_SPACE_RETRACTION_MAP_IMAGE; +"LOCALLY_COMPACT_SPACE_SUBMETRIC_EUCLIDEAN",LOCALLY_COMPACT_SPACE_SUBMETRIC_EUCLIDEAN; "LOCALLY_COMPACT_SPACE_SUBTOPOLOGY_EUCLIDEAN",LOCALLY_COMPACT_SPACE_SUBTOPOLOGY_EUCLIDEAN; "LOCALLY_COMPACT_SPACE_SUM_TOPOLOGY",LOCALLY_COMPACT_SPACE_SUM_TOPOLOGY; "LOCALLY_COMPACT_SUBSPACE_CLOSED_INTER_OPEN_IN",LOCALLY_COMPACT_SUBSPACE_CLOSED_INTER_OPEN_IN; @@ -10234,6 +10335,7 @@ theorems := "LOCALLY_CONNECTED_CONNECTED_COMPONENT",LOCALLY_CONNECTED_CONNECTED_COMPONENT; "LOCALLY_CONNECTED_CONTINUOUS_IMAGE_COMPACT",LOCALLY_CONNECTED_CONTINUOUS_IMAGE_COMPACT; "LOCALLY_CONNECTED_CONTINUUM",LOCALLY_CONNECTED_CONTINUUM; +"LOCALLY_CONNECTED_CONTINUUM_SPACE",LOCALLY_CONNECTED_CONTINUUM_SPACE; "LOCALLY_CONNECTED_EUCLIDEAN_SPACE",LOCALLY_CONNECTED_EUCLIDEAN_SPACE; "LOCALLY_CONNECTED_FROM_UNION_AND_INTER",LOCALLY_CONNECTED_FROM_UNION_AND_INTER; "LOCALLY_CONNECTED_FROM_UNION_AND_INTER_GEN",LOCALLY_CONNECTED_FROM_UNION_AND_INTER_GEN; @@ -10262,6 +10364,7 @@ theorems := "LOCALLY_CONNECTED_SPACE_PROD_TOPOLOGY",LOCALLY_CONNECTED_SPACE_PROD_TOPOLOGY; "LOCALLY_CONNECTED_SPACE_QUOTIENT_MAP_IMAGE",LOCALLY_CONNECTED_SPACE_QUOTIENT_MAP_IMAGE; "LOCALLY_CONNECTED_SPACE_RETRACTION_MAP_IMAGE",LOCALLY_CONNECTED_SPACE_RETRACTION_MAP_IMAGE; +"LOCALLY_CONNECTED_SPACE_SUBMETRIC_EUCLIDEAN",LOCALLY_CONNECTED_SPACE_SUBMETRIC_EUCLIDEAN; "LOCALLY_CONNECTED_SPACE_SUBTOPOLOGY_EUCLIDEAN",LOCALLY_CONNECTED_SPACE_SUBTOPOLOGY_EUCLIDEAN; "LOCALLY_CONNECTED_SPACE_SUM_TOPOLOGY",LOCALLY_CONNECTED_SPACE_SUM_TOPOLOGY; "LOCALLY_CONNECTED_SPHERE",LOCALLY_CONNECTED_SPHERE; @@ -10271,6 +10374,7 @@ theorems := "LOCALLY_CONNECTED_UNIV",LOCALLY_CONNECTED_UNIV; "LOCALLY_CONSTANT",LOCALLY_CONSTANT; "LOCALLY_CONSTANT_IMP_CONSTANT",LOCALLY_CONSTANT_IMP_CONSTANT; +"LOCALLY_CONSTANT_REFINEMENT",LOCALLY_CONSTANT_REFINEMENT; "LOCALLY_CONTINUOUS_ON",LOCALLY_CONTINUOUS_ON; "LOCALLY_CONTINUOUS_ON_ALT",LOCALLY_CONTINUOUS_ON_ALT; "LOCALLY_CONTINUOUS_ON_EXPLICIT",LOCALLY_CONTINUOUS_ON_EXPLICIT; @@ -10285,14 +10389,18 @@ theorems := "LOCALLY_EQ_COMPACTLY",LOCALLY_EQ_COMPACTLY; "LOCALLY_FCCOVERABLE",LOCALLY_FCCOVERABLE; "LOCALLY_FCCOVERABLE_ALT",LOCALLY_FCCOVERABLE_ALT; +"LOCALLY_FCCOVERABLE_SPACE",LOCALLY_FCCOVERABLE_SPACE; +"LOCALLY_FCCOVERABLE_SPACE_CHAIN",LOCALLY_FCCOVERABLE_SPACE_CHAIN; "LOCALLY_FINE_COVERING_COMPACT",LOCALLY_FINE_COVERING_COMPACT; "LOCALLY_FINITE_COVER_OF_COMPACT_SPACE",LOCALLY_FINITE_COVER_OF_COMPACT_SPACE; "LOCALLY_FINITE_COVER_OF_LINDELOF_SPACE",LOCALLY_FINITE_COVER_OF_LINDELOF_SPACE; "LOCALLY_FINITE_IN_CLOSURES",LOCALLY_FINITE_IN_CLOSURES; +"LOCALLY_FINITE_IN_HOMEOMORPHIC_IMAGE",LOCALLY_FINITE_IN_HOMEOMORPHIC_IMAGE; "LOCALLY_FINITE_IN_REFINEMENT",LOCALLY_FINITE_IN_REFINEMENT; "LOCALLY_FINITE_IN_SUBSET",LOCALLY_FINITE_IN_SUBSET; "LOCALLY_FINITE_IN_SUBTOPOLOGY",LOCALLY_FINITE_IN_SUBTOPOLOGY; "LOCALLY_FINITE_IN_SUBTOPOLOGY_EQ",LOCALLY_FINITE_IN_SUBTOPOLOGY_EQ; +"LOCALLY_FINITE_PRODUCT_TUBES",LOCALLY_FINITE_PRODUCT_TUBES; "LOCALLY_IMP_COUNTABLE_UNION_OF",LOCALLY_IMP_COUNTABLE_UNION_OF; "LOCALLY_IMP_FINITE_UNION_OF",LOCALLY_IMP_FINITE_UNION_OF; "LOCALLY_INJECTIVE_LINEAR_IMAGE",LOCALLY_INJECTIVE_LINEAR_IMAGE; @@ -10772,6 +10880,7 @@ theorems := "MBALL_EMPTY_ALT",MBALL_EMPTY_ALT; "MBALL_EQ_EMPTY",MBALL_EQ_EMPTY; "MBALL_EUCLIDEAN",MBALL_EUCLIDEAN; +"MBALL_INTER_DSEPARATED_SINGLETON",MBALL_INTER_DSEPARATED_SINGLETON; "MBALL_PROD_METRIC_SUBSET",MBALL_PROD_METRIC_SUBSET; "MBALL_REAL_INTERVAL",MBALL_REAL_INTERVAL; "MBALL_SUBMETRIC",MBALL_SUBMETRIC; @@ -10790,12 +10899,14 @@ theorems := "MBOUNDED",MBOUNDED; "MBOUNDED_ALT",MBOUNDED_ALT; "MBOUNDED_ALT_POS",MBOUNDED_ALT_POS; +"MBOUNDED_AND_MDIAMETER_LE",MBOUNDED_AND_MDIAMETER_LE; "MBOUNDED_CLOSURE_OF",MBOUNDED_CLOSURE_OF; "MBOUNDED_CLOSURE_OF_EQ",MBOUNDED_CLOSURE_OF_EQ; "MBOUNDED_CROSS",MBOUNDED_CROSS; "MBOUNDED_DISCRETE_METRIC",MBOUNDED_DISCRETE_METRIC; "MBOUNDED_EMPTY",MBOUNDED_EMPTY; "MBOUNDED_EUCLIDEAN",MBOUNDED_EUCLIDEAN; +"MBOUNDED_IMP_IN_MSPACE",MBOUNDED_IMP_IN_MSPACE; "MBOUNDED_INSERT",MBOUNDED_INSERT; "MBOUNDED_INTER",MBOUNDED_INTER; "MBOUNDED_LIPSCHITZ_CONTINUOUS_IMAGE",MBOUNDED_LIPSCHITZ_CONTINUOUS_IMAGE; @@ -10805,6 +10916,7 @@ theorems := "MBOUNDED_PROD_METRIC",MBOUNDED_PROD_METRIC; "MBOUNDED_REAL_EUCLIDEAN_METRIC",MBOUNDED_REAL_EUCLIDEAN_METRIC; "MBOUNDED_SUBMETRIC",MBOUNDED_SUBMETRIC; +"MBOUNDED_SUBMETRIC_EUCLIDEAN",MBOUNDED_SUBMETRIC_EUCLIDEAN; "MBOUNDED_SUBSET",MBOUNDED_SUBSET; "MBOUNDED_SUBSET_MSPACE",MBOUNDED_SUBSET_MSPACE; "MBOUNDED_UNION",MBOUNDED_UNION; @@ -10827,15 +10939,27 @@ theorems := "MCOMPLETE_ALT",MCOMPLETE_ALT; "MCOMPLETE_CAPPED_METRIC",MCOMPLETE_CAPPED_METRIC; "MCOMPLETE_CFUNSPACE",MCOMPLETE_CFUNSPACE; +"MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED",MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED; +"MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN",MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN; +"MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_IN",MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_IN; "MCOMPLETE_DISCRETE_METRIC",MCOMPLETE_DISCRETE_METRIC; +"MCOMPLETE_DYADIC_APPROXIMATION",MCOMPLETE_DYADIC_APPROXIMATION; "MCOMPLETE_EMPTY_MSPACE",MCOMPLETE_EMPTY_MSPACE; "MCOMPLETE_EUCLIDEAN",MCOMPLETE_EUCLIDEAN; "MCOMPLETE_FIP",MCOMPLETE_FIP; "MCOMPLETE_FIP_SING",MCOMPLETE_FIP_SING; "MCOMPLETE_FUNSPACE",MCOMPLETE_FUNSPACE; +"MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM",MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM; +"MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM_IN",MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM_IN; "MCOMPLETE_IMP_CLOSED_IN",MCOMPLETE_IMP_CLOSED_IN; +"MCOMPLETE_IMP_LOCALLY_COMPACT_EUCLIDEAN",MCOMPLETE_IMP_LOCALLY_COMPACT_EUCLIDEAN; "MCOMPLETE_INTER",MCOMPLETE_INTER; "MCOMPLETE_INTERS",MCOMPLETE_INTERS; +"MCOMPLETE_IN_LOCALLY_COMPACT_IMP_LOCALLY_COMPACT",MCOMPLETE_IN_LOCALLY_COMPACT_IMP_LOCALLY_COMPACT; +"MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED",MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED; +"MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN",MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN; +"MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED",MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED; +"MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN",MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN; "MCOMPLETE_NEST",MCOMPLETE_NEST; "MCOMPLETE_NEST_SING",MCOMPLETE_NEST_SING; "MCOMPLETE_PROD_METRIC",MCOMPLETE_PROD_METRIC; @@ -10844,6 +10968,23 @@ theorems := "MCOMPLETE_SUBMETRIC_REAL_EUCLIDEAN_METRIC",MCOMPLETE_SUBMETRIC_REAL_EUCLIDEAN_METRIC; "MCOMPLETE_UNION",MCOMPLETE_UNION; "MCOMPLETE_UNIONS",MCOMPLETE_UNIONS; +"MDIAMETER_BOUNDED",MDIAMETER_BOUNDED; +"MDIAMETER_BOUNDED_BOUND",MDIAMETER_BOUNDED_BOUND; +"MDIAMETER_CLOSURE",MDIAMETER_CLOSURE; +"MDIAMETER_COMPACT_ATTAINED",MDIAMETER_COMPACT_ATTAINED; +"MDIAMETER_EMPTY",MDIAMETER_EMPTY; +"MDIAMETER_EQ_0",MDIAMETER_EQ_0; +"MDIAMETER_EUCLIDEAN",MDIAMETER_EUCLIDEAN; +"MDIAMETER_LE",MDIAMETER_LE; +"MDIAMETER_POS_LE",MDIAMETER_POS_LE; +"MDIAMETER_SING",MDIAMETER_SING; +"MDIAMETER_SUBMETRIC",MDIAMETER_SUBMETRIC; +"MDIAMETER_SUBMETRIC_EUCLIDEAN",MDIAMETER_SUBMETRIC_EUCLIDEAN; +"MDIAMETER_SUBSET",MDIAMETER_SUBSET; +"MDIAMETER_SUBSET_MBALL",MDIAMETER_SUBSET_MBALL; +"MDIAMETER_SUBSET_MCBALL",MDIAMETER_SUBSET_MCBALL; +"MDIAMETER_SUBSET_MCBALL_NONEMPTY",MDIAMETER_SUBSET_MCBALL_NONEMPTY; +"MDIAMETER_UNION_LE",MDIAMETER_UNION_LE; "MDIST",MDIST; "MDIST_0",MDIST_0; "MDIST_CAPPED",MDIST_CAPPED; @@ -10857,6 +10998,7 @@ theorems := "MDIST_REVERSE_TRIANGLE",MDIST_REVERSE_TRIANGLE; "MDIST_SYM",MDIST_SYM; "MDIST_TRIANGLE",MDIST_TRIANGLE; +"MDIST_TRIANGLE_LT",MDIST_TRIANGLE_LT; "MEASURABLE",MEASURABLE; "MEASURABLE_ABSOLUTELY_CONTINUOUS_IMAGE",MEASURABLE_ABSOLUTELY_CONTINUOUS_IMAGE; "MEASURABLE_ADDITIVE_IMP_LINEAR",MEASURABLE_ADDITIVE_IMP_LINEAR; @@ -11177,6 +11319,7 @@ theorems := "METRIC_COMPLETION",METRIC_COMPLETION; "METRIC_COMPLETION_EXPLICIT",METRIC_COMPLETION_EXPLICIT; "METRIC_CONTINUOUS_MAP",METRIC_CONTINUOUS_MAP; +"METRIC_COVER_SIGMA_LOCALLY_FINITE",METRIC_COVER_SIGMA_LOCALLY_FINITE; "METRIC_DERIVED_SET_OF",METRIC_DERIVED_SET_OF; "METRIC_INJECTIVE_IMAGE",METRIC_INJECTIVE_IMAGE; "METRIC_INTERIOR_OF",METRIC_INTERIOR_OF; @@ -11189,8 +11332,11 @@ theorems := "METRIZABLE_IMP_KC_SPACE",METRIZABLE_IMP_KC_SPACE; "METRIZABLE_IMP_K_SPACE",METRIZABLE_IMP_K_SPACE; "METRIZABLE_IMP_NORMAL_SPACE",METRIZABLE_IMP_NORMAL_SPACE; +"METRIZABLE_IMP_PARACOMPACT_SPACE",METRIZABLE_IMP_PARACOMPACT_SPACE; "METRIZABLE_IMP_REGULAR_SPACE",METRIZABLE_IMP_REGULAR_SPACE; "METRIZABLE_IMP_T1_SPACE",METRIZABLE_IMP_T1_SPACE; +"METRIZABLE_PRODUCT_EUCLIDEANREAL_NUM",METRIZABLE_PRODUCT_EUCLIDEANREAL_NUM; +"METRIZABLE_SPACE_CANTOR_SPACE",METRIZABLE_SPACE_CANTOR_SPACE; "METRIZABLE_SPACE_COMPLETION",METRIZABLE_SPACE_COMPLETION; "METRIZABLE_SPACE_DISCRETE_TOPOLOGY",METRIZABLE_SPACE_DISCRETE_TOPOLOGY; "METRIZABLE_SPACE_EUCLIDEAN",METRIZABLE_SPACE_EUCLIDEAN; @@ -11201,6 +11347,7 @@ theorems := "METRIZABLE_SPACE_RETRACTION_MAP_IMAGE",METRIZABLE_SPACE_RETRACTION_MAP_IMAGE; "METRIZABLE_SPACE_SEPARATION",METRIZABLE_SPACE_SEPARATION; "METRIZABLE_SPACE_SUBTOPOLOGY",METRIZABLE_SPACE_SUBTOPOLOGY; +"MICHAEL_LEMMA",MICHAEL_LEMMA; "MIDPOINTS_IN_CONVEX_HULL",MIDPOINTS_IN_CONVEX_HULL; "MIDPOINT_BETWEEN",MIDPOINT_BETWEEN; "MIDPOINT_COLLINEAR",MIDPOINT_COLLINEAR; @@ -11331,6 +11478,7 @@ theorems := "MTOPOLOGY_PROD_METRIC",MTOPOLOGY_PROD_METRIC; "MTOPOLOGY_REAL_EUCLIDEAN_METRIC",MTOPOLOGY_REAL_EUCLIDEAN_METRIC; "MTOPOLOGY_SUBMETRIC",MTOPOLOGY_SUBMETRIC; +"MTOPOLOGY_SUBMETRIC_EUCLIDEAN",MTOPOLOGY_SUBMETRIC_EUCLIDEAN; "MULT",MULT; "MULTIPART_MEASURES",MULTIPART_MEASURES; "MULTIPLES_EQ",MULTIPLES_EQ; @@ -11539,6 +11687,7 @@ theorems := "NEIGHBOURHOOD_BASE_OF_UNLOCALIZED",NEIGHBOURHOOD_BASE_OF_UNLOCALIZED; "NEIGHBOURHOOD_BASE_OF_WITH_SUBSET",NEIGHBOURHOOD_BASE_OF_WITH_SUBSET; "NEIGHBOURHOOD_EXTENSION_INTO_ANR",NEIGHBOURHOOD_EXTENSION_INTO_ANR; +"NESTED_COMPACT_APPROX",NESTED_COMPACT_APPROX; "NET",NET; "NETLIMITS_ATPOINTOF",NETLIMITS_ATPOINTOF; "NETLIMITS_AT_INFINITY",NETLIMITS_AT_INFINITY; @@ -11575,6 +11724,7 @@ theorems := "NONEMPTY_SIMPLE_PATH_ENDLESS",NONEMPTY_SIMPLE_PATH_ENDLESS; "NONEMPTY_SPAN",NONEMPTY_SPAN; "NONEMPTY_STANDARD_SIMPLEX",NONEMPTY_STANDARD_SIMPLEX; +"NONEMPTY_TOPSPACE_CANTOR_SPACE",NONEMPTY_TOPSPACE_CANTOR_SPACE; "NONNEGATIVE_ABSOLUTELY_INTEGRABLE",NONNEGATIVE_ABSOLUTELY_INTEGRABLE; "NONNEGATIVE_ABSOLUTELY_INTEGRABLE_AE",NONNEGATIVE_ABSOLUTELY_INTEGRABLE_AE; "NONNEGATIVE_INTEGER",NONNEGATIVE_INTEGER; @@ -12032,6 +12182,7 @@ theorems := "OPEN_COMPONENTS",OPEN_COMPONENTS; "OPEN_CONIC_HULL",OPEN_CONIC_HULL; "OPEN_CONNECTED_COMPONENT",OPEN_CONNECTED_COMPONENT; +"OPEN_CONNECTED_FINE_COVER",OPEN_CONNECTED_FINE_COVER; "OPEN_CONTAINS_BALL",OPEN_CONTAINS_BALL; "OPEN_CONTAINS_BALL_EQ",OPEN_CONTAINS_BALL_EQ; "OPEN_CONTAINS_CBALL",OPEN_CONTAINS_CBALL; @@ -12520,8 +12671,25 @@ theorems := "PAIR_EXISTS_THM",PAIR_EXISTS_THM; "PAIR_SURJECTIVE",PAIR_SURJECTIVE; "PARACOMPACT",PARACOMPACT; -"PARACOMPACT_CLOSED",PARACOMPACT_CLOSED; -"PARACOMPACT_CLOSED_IN",PARACOMPACT_CLOSED_IN; +"PARACOMPACT_HAUSDORFF_CLOSURE_REFINEMENT",PARACOMPACT_HAUSDORFF_CLOSURE_REFINEMENT; +"PARACOMPACT_HAUSDORFF_EXPANSION_LEMMA",PARACOMPACT_HAUSDORFF_EXPANSION_LEMMA; +"PARACOMPACT_HAUSDORFF_IMP_NORMAL_SPACE",PARACOMPACT_HAUSDORFF_IMP_NORMAL_SPACE; +"PARACOMPACT_HAUSDORFF_IMP_REGULAR_SPACE",PARACOMPACT_HAUSDORFF_IMP_REGULAR_SPACE; +"PARACOMPACT_HAUSDORFF_INDEXED_SHRINKING",PARACOMPACT_HAUSDORFF_INDEXED_SHRINKING; +"PARACOMPACT_PARTITION_OF_UNITY",PARACOMPACT_PARTITION_OF_UNITY; +"PARACOMPACT_SPACE_CLOSED_SUBSET",PARACOMPACT_SPACE_CLOSED_SUBSET; +"PARACOMPACT_SPACE_DISCRETE_TOPOLOGY",PARACOMPACT_SPACE_DISCRETE_TOPOLOGY; +"PARACOMPACT_SPACE_EQ_CLOSED_REFINEMENT",PARACOMPACT_SPACE_EQ_CLOSED_REFINEMENT; +"PARACOMPACT_SPACE_EQ_LOCALLY_FINITE_REFINEMENT",PARACOMPACT_SPACE_EQ_LOCALLY_FINITE_REFINEMENT; +"PARACOMPACT_SPACE_EUCLIDEAN",PARACOMPACT_SPACE_EUCLIDEAN; +"PARACOMPACT_SPACE_EUCLIDEAN_SUBTOPOLOGY",PARACOMPACT_SPACE_EUCLIDEAN_SUBTOPOLOGY; +"PARACOMPACT_SPACE_FSIGMA_SUBSET",PARACOMPACT_SPACE_FSIGMA_SUBSET; +"PARACOMPACT_SPACE_MTOPOLOGY",PARACOMPACT_SPACE_MTOPOLOGY; +"PARACOMPACT_SPACE_PERFECT_MAP_IMAGE",PARACOMPACT_SPACE_PERFECT_MAP_IMAGE; +"PARACOMPACT_SPACE_PERFECT_MAP_PREIMAGE",PARACOMPACT_SPACE_PERFECT_MAP_PREIMAGE; +"PARACOMPACT_SPACE_PRODUCT_COMPACT_LEFT",PARACOMPACT_SPACE_PRODUCT_COMPACT_LEFT; +"PARACOMPACT_SPACE_PRODUCT_COMPACT_RIGHT",PARACOMPACT_SPACE_PRODUCT_COMPACT_RIGHT; +"PARACOMPACT_SPACE_RETRACTION_MAP_IMAGE",PARACOMPACT_SPACE_RETRACTION_MAP_IMAGE; "PARTIAL_DIVISION_EXTEND",PARTIAL_DIVISION_EXTEND; "PARTIAL_DIVISION_EXTEND_1",PARTIAL_DIVISION_EXTEND_1; "PARTIAL_DIVISION_EXTEND_INTERVAL",PARTIAL_DIVISION_EXTEND_INTERVAL; @@ -12824,6 +12992,9 @@ theorems := "PCROSS_UNION",PCROSS_UNION; "PCROSS_UNIONS",PCROSS_UNIONS; "PCROSS_UNIONS_UNIONS",PCROSS_UNIONS_UNIONS; +"PEANO_GAP_FILLING_EXTENSION",PEANO_GAP_FILLING_EXTENSION; +"PERFECT_CANTOR_SPACE",PERFECT_CANTOR_SPACE; +"PERFECT_CANTOR_SPACE_EQ",PERFECT_CANTOR_SPACE_EQ; "PERFECT_FROM_CLOSURE",PERFECT_FROM_CLOSURE; "PERFECT_IMP_CLOSED_MAP",PERFECT_IMP_CLOSED_MAP; "PERFECT_IMP_CONTINUOUS_MAP",PERFECT_IMP_CONTINUOUS_MAP; @@ -13498,6 +13669,12 @@ theorems := "RAY_TO_FRONTIER",RAY_TO_FRONTIER; "RAY_TO_RELATIVE_FRONTIER",RAY_TO_RELATIVE_FRONTIER; "RDIV_LT_EQ",RDIV_LT_EQ; +"REALLIM_CONST",REALLIM_CONST; +"REALLIM_LBOUND",REALLIM_LBOUND; +"REALLIM_LE",REALLIM_LE; +"REALLIM_SEQUENTIALLY",REALLIM_SEQUENTIALLY; +"REALLIM_SUB",REALLIM_SUB; +"REALLIM_UBOUND",REALLIM_UBOUND; "REAL_ABS_0",REAL_ABS_0; "REAL_ABS_1",REAL_ABS_1; "REAL_ABS_ABS",REAL_ABS_ABS; @@ -13977,6 +14154,8 @@ theorems := "REAL_POW_ZPOW",REAL_POW_ZPOW; "REAL_RNEG_UNIQ",REAL_RNEG_UNIQ; "REAL_RSQRT_LE",REAL_RSQRT_LE; +"REAL_SERIES_FROM",REAL_SERIES_FROM; +"REAL_SERIES_LE",REAL_SERIES_LE; "REAL_SETDIST_LT_EXISTS",REAL_SETDIST_LT_EXISTS; "REAL_SGN",REAL_SGN; "REAL_SGNS_EQ",REAL_SGNS_EQ; @@ -14031,6 +14210,10 @@ theorems := "REAL_SUB_SUB",REAL_SUB_SUB; "REAL_SUB_SUB2",REAL_SUB_SUB2; "REAL_SUB_TRIANGLE",REAL_SUB_TRIANGLE; +"REAL_SUMMABLE_CAUCHY",REAL_SUMMABLE_CAUCHY; +"REAL_SUMMABLE_COMPARISON",REAL_SUMMABLE_COMPARISON; +"REAL_SUMS_INFSUM",REAL_SUMS_INFSUM; +"REAL_SUMS_SUMMABLE",REAL_SUMS_SUMMABLE; "REAL_SUP_ASCLOSE",REAL_SUP_ASCLOSE; "REAL_SUP_BOUNDS",REAL_SUP_BOUNDS; "REAL_SUP_EQ_INF",REAL_SUP_EQ_INF; @@ -14121,11 +14304,13 @@ theorems := "REGULAR_CLOSURE_INTERIOR",REGULAR_CLOSURE_INTERIOR; "REGULAR_CLOSURE_OF_IMP_THIN_FRONTIER_OF",REGULAR_CLOSURE_OF_IMP_THIN_FRONTIER_OF; "REGULAR_CLOSURE_OF_INTERIOR_OF",REGULAR_CLOSURE_OF_INTERIOR_OF; +"REGULAR_CLOSURE_REFINEMENT_COVERS",REGULAR_CLOSURE_REFINEMENT_COVERS; "REGULAR_INTERIOR_CLOSURE",REGULAR_INTERIOR_CLOSURE; "REGULAR_INTERIOR_IMP_THIN_FRONTIER",REGULAR_INTERIOR_IMP_THIN_FRONTIER; "REGULAR_INTERIOR_OF_CLOSURE_OF",REGULAR_INTERIOR_OF_CLOSURE_OF; "REGULAR_INTERIOR_OF_IMP_THIN_FRONTIER_OF",REGULAR_INTERIOR_OF_IMP_THIN_FRONTIER_OF; "REGULAR_LINDELOF_IMP_NORMAL_SPACE",REGULAR_LINDELOF_IMP_NORMAL_SPACE; +"REGULAR_LINDELOF_IMP_PARACOMPACT_SPACE",REGULAR_LINDELOF_IMP_PARACOMPACT_SPACE; "REGULAR_OPEN",REGULAR_OPEN; "REGULAR_OPEN_IN",REGULAR_OPEN_IN; "REGULAR_OPEN_INTER",REGULAR_OPEN_INTER; @@ -14133,6 +14318,7 @@ theorems := "REGULAR_POLYTOPE_EXISTS",REGULAR_POLYTOPE_EXISTS; "REGULAR_POLYTOPE_WITH_BARYCENTRE_EXISTS",REGULAR_POLYTOPE_WITH_BARYCENTRE_EXISTS; "REGULAR_POLYTOPE_WITH_BARYCENTRE_EXISTS_ALT",REGULAR_POLYTOPE_WITH_BARYCENTRE_EXISTS_ALT; +"REGULAR_SECOND_COUNTABLE_HAUSDORFF_IMP_NORMAL_SPACE",REGULAR_SECOND_COUNTABLE_HAUSDORFF_IMP_NORMAL_SPACE; "REGULAR_SECOND_COUNTABLE_IMP_HEREDITARILY_NORMAL_SPACE",REGULAR_SECOND_COUNTABLE_IMP_HEREDITARILY_NORMAL_SPACE; "REGULAR_SPACE",REGULAR_SPACE; "REGULAR_SPACE_ALEXANDROFF_COMPACTIFICATION",REGULAR_SPACE_ALEXANDROFF_COMPACTIFICATION; @@ -14429,13 +14615,16 @@ theorems := "SCHAUDER_UNIV",SCHAUDER_UNIV; "SCHREIER_TRANSVERSAL_LEMMA",SCHREIER_TRANSVERSAL_LEMMA; "SECOND_COUNTABLE",SECOND_COUNTABLE; +"SECOND_COUNTABLE_CLOSED_MAP_IMAGE",SECOND_COUNTABLE_CLOSED_MAP_IMAGE; "SECOND_COUNTABLE_DISCRETE_TOPOLOGY",SECOND_COUNTABLE_DISCRETE_TOPOLOGY; "SECOND_COUNTABLE_IMP_FIRST_COUNTABLE",SECOND_COUNTABLE_IMP_FIRST_COUNTABLE; "SECOND_COUNTABLE_IMP_LINDELOF_SPACE",SECOND_COUNTABLE_IMP_LINDELOF_SPACE; "SECOND_COUNTABLE_IMP_SEPARABLE_SPACE",SECOND_COUNTABLE_IMP_SEPARABLE_SPACE; +"SECOND_COUNTABLE_LOCALLY_COMPACT_HAUSDORFF_IMP_PARACOMPACT",SECOND_COUNTABLE_LOCALLY_COMPACT_HAUSDORFF_IMP_PARACOMPACT; "SECOND_COUNTABLE_NEIGHBOURHOOD_BASE",SECOND_COUNTABLE_NEIGHBOURHOOD_BASE; "SECOND_COUNTABLE_NEIGHBOURHOOD_BASE_ALT",SECOND_COUNTABLE_NEIGHBOURHOOD_BASE_ALT; "SECOND_COUNTABLE_OPEN_MAP_IMAGE",SECOND_COUNTABLE_OPEN_MAP_IMAGE; +"SECOND_COUNTABLE_REGULAR_IMP_PARACOMPACT_SPACE",SECOND_COUNTABLE_REGULAR_IMP_PARACOMPACT_SPACE; "SECOND_COUNTABLE_RETRACTION_MAP_IMAGE",SECOND_COUNTABLE_RETRACTION_MAP_IMAGE; "SECOND_COUNTABLE_SUBTOPOLOGY",SECOND_COUNTABLE_SUBTOPOLOGY; "SECOND_MEAN_VALUE_THEOREM",SECOND_MEAN_VALUE_THEOREM; @@ -14493,8 +14682,12 @@ theorems := "SELF_ADJOINT_ORTHOGONAL_EIGENVECTORS",SELF_ADJOINT_ORTHOGONAL_EIGENVECTORS; "SEMI_LOCALLY_CONNECTED",SEMI_LOCALLY_CONNECTED; "SEMI_LOCALLY_CONNECTED_COMPACT",SEMI_LOCALLY_CONNECTED_COMPACT; +"SEMI_LOCALLY_CONNECTED_COMPACT_SPACE",SEMI_LOCALLY_CONNECTED_COMPACT_SPACE; +"SEMI_LOCALLY_CONNECTED_CONNECTED",SEMI_LOCALLY_CONNECTED_CONNECTED; "SEMI_LOCALLY_CONNECTED_GEN",SEMI_LOCALLY_CONNECTED_GEN; +"SEMI_LOCALLY_CONNECTED_GEN_SPACE",SEMI_LOCALLY_CONNECTED_GEN_SPACE; "SEPARABLE",SEPARABLE; +"SEPARABLE_METRIZABLE_IMP_SECOND_COUNTABLE",SEPARABLE_METRIZABLE_IMP_SECOND_COUNTABLE; "SEPARABLE_SPACE_CONTINUOUS_MAP_IMAGE",SEPARABLE_SPACE_CONTINUOUS_MAP_IMAGE; "SEPARABLE_SPACE_DISCRETE_TOPOLOGY",SEPARABLE_SPACE_DISCRETE_TOPOLOGY; "SEPARABLE_SPACE_OPEN_SUBSET",SEPARABLE_SPACE_OPEN_SUBSET; @@ -14550,6 +14743,7 @@ theorems := "SEPARATE_CLOSED_CONES",SEPARATE_CLOSED_CONES; "SEPARATE_COMPACT_CLOSED",SEPARATE_COMPACT_CLOSED; "SEPARATE_POINT_CLOSED",SEPARATE_POINT_CLOSED; +"SEPARATING_FUNCTIONS_INJECTIVE",SEPARATING_FUNCTIONS_INJECTIVE; "SEPARATING_HYPERPLANE_AFFINE_AFFINE",SEPARATING_HYPERPLANE_AFFINE_AFFINE; "SEPARATING_HYPERPLANE_AFFINE_HULLS",SEPARATING_HYPERPLANE_AFFINE_HULLS; "SEPARATING_HYPERPLANE_CLOSED_0",SEPARATING_HYPERPLANE_CLOSED_0; @@ -14744,6 +14938,7 @@ theorems := "SHORT_FIVE_LEMMA_EPI",SHORT_FIVE_LEMMA_EPI; "SHORT_FIVE_LEMMA_MONO",SHORT_FIVE_LEMMA_MONO; "SIGMA_COMPACT",SIGMA_COMPACT; +"SIGMA_LOCALLY_FINITE_IMP_LOCALLY_FINITE_COVERING",SIGMA_LOCALLY_FINITE_IMP_LOCALLY_FINITE_COVERING; "SIGN_CARTESIAN_PRODUCT",SIGN_CARTESIAN_PRODUCT; "SIGN_COMPOSE",SIGN_COMPOSE; "SIGN_CYCLIC",SIGN_CYCLIC; @@ -15192,6 +15387,7 @@ theorems := "SUBMATROID_SPAN",SUBMATROID_SPAN; "SUBMATROID_SUBSET",SUBMATROID_SUBSET; "SUBMETRIC",SUBMETRIC; +"SUBMETRIC_EUCLIDEAN_METRIC",SUBMETRIC_EUCLIDEAN_METRIC; "SUBMETRIC_MSPACE",SUBMETRIC_MSPACE; "SUBMETRIC_PROD_METRIC",SUBMETRIC_PROD_METRIC; "SUBMETRIC_RESTRICT",SUBMETRIC_RESTRICT; @@ -15514,6 +15710,7 @@ theorems := "SUM_SWAP",SUM_SWAP; "SUM_SWAP_NUMSEG",SUM_SWAP_NUMSEG; "SUM_TRIV_NUMSEG",SUM_TRIV_NUMSEG; +"SUM_TWOTHIRDS",SUM_TWOTHIRDS; "SUM_UNION",SUM_UNION; "SUM_UNIONS_NONZERO",SUM_UNIONS_NONZERO; "SUM_UNION_EQ",SUM_UNION_EQ; @@ -15715,6 +15912,7 @@ theorems := "TENDSTO_ALT",TENDSTO_ALT; "TENDSTO_ALT_WITHIN",TENDSTO_ALT_WITHIN; "TENDSTO_LIM",TENDSTO_LIM; +"TENDSTO_REAL_EPS_DELTA",TENDSTO_REAL_EPS_DELTA; "THIN_FRONTIER_CIC",THIN_FRONTIER_CIC; "THIN_FRONTIER_ICI",THIN_FRONTIER_ICI; "THIN_FRONTIER_OF_CIC",THIN_FRONTIER_OF_CIC; @@ -15750,6 +15948,7 @@ theorems := "TOPOLOGY_FINER_SUBTOPOLOGY",TOPOLOGY_FINER_SUBTOPOLOGY; "TOPSPACE_ALEXANDROFF_COMPACTIFICATION",TOPSPACE_ALEXANDROFF_COMPACTIFICATION; "TOPSPACE_ALEXANDROFF_COMPACTIFICATION_DELETE",TOPSPACE_ALEXANDROFF_COMPACTIFICATION_DELETE; +"TOPSPACE_CANTOR_SPACE",TOPSPACE_CANTOR_SPACE; "TOPSPACE_DISCRETE_TOPOLOGY",TOPSPACE_DISCRETE_TOPOLOGY; "TOPSPACE_EUCLIDEAN",TOPSPACE_EUCLIDEAN; "TOPSPACE_EUCLIDEANREAL",TOPSPACE_EUCLIDEANREAL; @@ -15785,6 +15984,7 @@ theorems := "TOSET_TRIVIAL",TOSET_TRIVIAL; "TOSET_num",TOSET_num; "TOTALLY_BOUNDED_HAUSDIST",TOTALLY_BOUNDED_HAUSDIST; +"TOTALLY_BOUNDED_IMP_DISCRETE_FINITE",TOTALLY_BOUNDED_IMP_DISCRETE_FINITE; "TOTALLY_BOUNDED_IN_ABSOLUTE",TOTALLY_BOUNDED_IN_ABSOLUTE; "TOTALLY_BOUNDED_IN_CAUCHY_CONTINUOUS_IMAGE",TOTALLY_BOUNDED_IN_CAUCHY_CONTINUOUS_IMAGE; "TOTALLY_BOUNDED_IN_CAUCHY_SEQUENCE",TOTALLY_BOUNDED_IN_CAUCHY_SEQUENCE; @@ -15803,6 +16003,7 @@ theorems := "TOTALLY_BOUNDED_IN_SUBSET",TOTALLY_BOUNDED_IN_SUBSET; "TOTALLY_BOUNDED_IN_UNION",TOTALLY_BOUNDED_IN_UNION; "TOTALLY_BOUNDED_IN_UNIONS",TOTALLY_BOUNDED_IN_UNIONS; +"TOTALLY_BOUNDED_ULC_SPACE_IMP_FCCOVERABLE_SPACE",TOTALLY_BOUNDED_ULC_SPACE_IMP_FCCOVERABLE_SPACE; "TRACE_0",TRACE_0; "TRACE_ADD",TRACE_ADD; "TRACE_CMUL",TRACE_CMUL; @@ -15969,10 +16170,13 @@ theorems := "TUBE_LEMMA_RIGHT",TUBE_LEMMA_RIGHT; "TUKEY",TUKEY; "TWO",TWO; +"TWOTHIRDS_SUMS",TWOTHIRDS_SUMS; "TWO_SIDED_LIMIT_AT",TWO_SIDED_LIMIT_AT; "TWO_SIDED_LIMIT_WITHIN",TWO_SIDED_LIMIT_WITHIN; "T_DEF",T_DEF; "ULC_IMP_LOCALLY_CONNECTED",ULC_IMP_LOCALLY_CONNECTED; +"ULC_SPACE_IMP_LOCALLY_CONNECTED_SPACE",ULC_SPACE_IMP_LOCALLY_CONNECTED_SPACE; +"ULC_SPACE_SUBMETRIC_EUCLIDEAN",ULC_SPACE_SUBMETRIC_EUCLIDEAN; "UNBOUNDED_COMPLEMENT_COMPONENT_CONVEX",UNBOUNDED_COMPLEMENT_COMPONENT_CONVEX; "UNBOUNDED_COMPLEMENT_CONVEX",UNBOUNDED_COMPLEMENT_CONVEX; "UNBOUNDED_COMPONENTS_COMPLEMENT_ABSOLUTE_RETRACT",UNBOUNDED_COMPONENTS_COMPLEMENT_ABSOLUTE_RETRACT; @@ -16164,6 +16368,8 @@ theorems := "URYSOHN_LEMMA_ALT",URYSOHN_LEMMA_ALT; "URYSOHN_LOCAL",URYSOHN_LOCAL; "URYSOHN_LOCAL_STRONG",URYSOHN_LOCAL_STRONG; +"URYSOHN_METRIZATION",URYSOHN_METRIZATION; +"URYSOHN_METRIZATION_EQ",URYSOHN_METRIZATION_EQ; "URYSOHN_STRONG",URYSOHN_STRONG; "VARIATION_EQUAL_LEMMA",VARIATION_EQUAL_LEMMA; "VECTORIZE_0",VECTORIZE_0; @@ -16406,8 +16612,11 @@ theorems := "WEAKLY_LOCALLY_PATH_CONNECTED_IMP_WEAKLY_LOCALLY_CONNECTED_AT",WEAKLY_LOCALLY_PATH_CONNECTED_IMP_WEAKLY_LOCALLY_CONNECTED_AT; "WEAK_LEBESGUE_POINTS_IMP_IVT",WEAK_LEBESGUE_POINTS_IMP_IVT; "WELLCHAINED_ELEMENTS",WELLCHAINED_ELEMENTS; +"WELLCHAINED_ELEMENTS_EUCLIDEAN",WELLCHAINED_ELEMENTS_EUCLIDEAN; "WELLCHAINED_INTERS",WELLCHAINED_INTERS; +"WELLCHAINED_INTERS_EUCLIDEAN",WELLCHAINED_INTERS_EUCLIDEAN; "WELLCHAINED_SETS",WELLCHAINED_SETS; +"WELLCHAINED_SETS_EUCLIDEAN",WELLCHAINED_SETS_EUCLIDEAN; "WF",WF; "WF_ANTISYM",WF_ANTISYM; "WF_CARD_LT",WF_CARD_LT; @@ -16505,6 +16714,7 @@ theorems := "ZERO_AE_DERIVATIVE_IMP_CONSTANT",ZERO_AE_DERIVATIVE_IMP_CONSTANT; "ZERO_AE_DERIVATIVE_IMP_CONSTANT_GEN",ZERO_AE_DERIVATIVE_IMP_CONSTANT_GEN; "ZERO_DEF",ZERO_DEF; +"ZERO_DIMENSIONAL_CANTOR_SPACE",ZERO_DIMENSIONAL_CANTOR_SPACE; "ZERO_DIMENSIONAL_IMP_COMPLETELY_REGULAR_SPACE",ZERO_DIMENSIONAL_IMP_COMPLETELY_REGULAR_SPACE; "ZERO_DIMENSIONAL_IMP_REGULAR_SPACE",ZERO_DIMENSIONAL_IMP_REGULAR_SPACE; "ZERO_ONE_OR_PRIME",ZERO_ONE_OR_PRIME; @@ -16564,6 +16774,10 @@ theorems := "brouwer_degree",brouwer_degree; "brouwer_degree1",brouwer_degree1; "brouwer_degree2",brouwer_degree2; +"cantor_map",cantor_map; +"cantor_set",cantor_set; +"cantor_space",cantor_space; +"cantor_term",cantor_term; "capped_metric",capped_metric; "cart_tybij",cart_tybij; "cartesian_product",cartesian_product; @@ -16663,6 +16877,8 @@ theorems := "extreme_point_of",extreme_point_of; "face_of",face_of; "facet_of",facet_of; +"fccoverable_in",fccoverable_in; +"fccoverable_space",fccoverable_space; "fine",fine; "finite_diff_tybij",finite_diff_tybij; "finite_image_tybij",finite_image_tybij; @@ -16905,6 +17121,7 @@ theorems := "mbounded",mbounded; "mcball",mcball; "mcomplete",mcomplete; +"mdiameter",mdiameter; "mdist",mdist; "measurable",measurable; "measurable_on",measurable_on; @@ -17003,6 +17220,7 @@ theorems := "pair_INDUCT",pair_INDUCT; "pair_RECURSION",pair_RECURSION; "pairwise",pairwise; +"paracompact_space",paracompact_space; "pastecart",pastecart; "path",path; "path_component",path_component; @@ -17058,6 +17276,7 @@ theorems := "real_euclidean_metric",real_euclidean_metric; "real_ge",real_ge; "real_gt",real_gt; +"real_infsum",real_infsum; "real_interval",real_interval; "real_inv",real_inv; "real_inv_th",real_inv_th; @@ -17077,7 +17296,10 @@ theorems := "real_pow",real_pow; "real_sgn",real_sgn; "real_sub",real_sub; +"real_summable",real_summable; +"real_sums",real_sums; "real_zpow",real_zpow; +"reallim",reallim; "rectifiable_path",rectifiable_path; "reduced_homology_group",reduced_homology_group; "reflect_along",reflect_along; @@ -17115,6 +17337,7 @@ theorems := "setdist",setdist; "shiftpath",shiftpath; "short_exact_sequence",short_exact_sequence; +"sigma_locally_finite_in",sigma_locally_finite_in; "sign",sign; "simple_path",simple_path; "simplex",simplex; @@ -17177,6 +17400,7 @@ theorems := "tagged_partial_division_of",tagged_partial_division_of; "tailadmissible",tailadmissible; "tendsto",tendsto; +"tendsto_real_def",tendsto_real_def; "topcontinuous_at",topcontinuous_at; "topology_tybij",topology_tybij; "topology_tybij_th",topology_tybij_th; @@ -17200,6 +17424,7 @@ theorems := "tybit0_RECURSION",tybit0_RECURSION; "tybit1_INDUCT",tybit1_INDUCT; "tybit1_RECURSION",tybit1_RECURSION; +"ulc_space",ulc_space; "uniformly_continuous_map",uniformly_continuous_map; "uniformly_continuous_on",uniformly_continuous_on; "vec",vec; diff --git a/Multivariate/paracompact.ml b/Multivariate/paracompact.ml new file mode 100644 index 00000000..b11c4282 --- /dev/null +++ b/Multivariate/paracompact.ml @@ -0,0 +1,5976 @@ +(* ========================================================================= *) +(* More advanced or exotic results around paracompact spaces. This includes *) +(* Nagata-Smirnov metrization results as well as Michael's characterization *) +(* of paracompact spaces via closure-preserving closed refinements. *) +(* ========================================================================= *) + +needs "Multivariate/metric.ml";; + +(* Engelking Section 5.2: Countably paracompact space *) +let countably_paracompact_space = new_definition + `countably_paracompact_space (top:A topology) <=> + !U. COUNTABLE U /\ + (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?V. (!v. v IN V ==> open_in top v) /\ + UNIONS V = topspace top /\ + (!v. v IN V ==> ?u. u IN U /\ v SUBSET u) /\ + locally_finite_in top V`;; + +(* Paracompact implies countably paracompact *) +let PARACOMPACT_IMP_COUNTABLY_PARACOMPACT_SPACE = prove + (`!top:A topology. + paracompact_space top ==> countably_paracompact_space top`, + GEN_TAC THEN REWRITE_TAC[paracompact_space; countably_paracompact_space] THEN + DISCH_TAC THEN X_GEN_TAC `U:(A->bool)->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]);; + +(* Corollary: Metrizable implies countably paracompact *) +let METRIZABLE_IMP_COUNTABLY_PARACOMPACT_SPACE = prove + (`!top:A topology. + metrizable_space top ==> countably_paracompact_space top`, + GEN_TAC THEN DISCH_TAC THEN + MATCH_MP_TAC PARACOMPACT_IMP_COUNTABLY_PARACOMPACT_SPACE THEN + MATCH_MP_TAC METRIZABLE_IMP_PARACOMPACT_SPACE THEN + ASM_REWRITE_TAC[]);; + +(* Forward direction of Dowker characterization: countably paracompact + implies the shrinking condition. Does NOT need normality. *) +let COUNTABLY_PARACOMPACT_IMP_DOWKER = prove + (`!top:A topology. + countably_paracompact_space top + ==> !f. (!n. closed_in top (f n)) /\ + (!n. f(SUC n) SUBSET f n) /\ + INTERS {f n | n IN (:num)} = {} + ==> ?g. (!n. open_in top (g n)) /\ + (!n. f n SUBSET g n) /\ + INTERS {g n | n IN (:num)} = {}`, + let DECREASING_CHAIN_SUBSET = prove + (`!f:num->(A->bool). + (!n. f(SUC n) SUBSET f n) ==> !m n. m <= n ==> f n SUBSET f m`, + GEN_TAC THEN DISCH_TAC THEN GEN_TAC THEN INDUCT_TAC THENL + [REWRITE_TAC[LE] THEN DISCH_THEN SUBST1_TAC THEN SET_TAC[]; + REWRITE_TAC[LE] THEN STRIP_TAC THENL + [ASM_REWRITE_TAC[SUBSET_REFL]; + ASM SET_TAC[]]]) in + GEN_TAC THEN REWRITE_TAC[countably_paracompact_space] THEN + DISCH_TAC THEN X_GEN_TAC `f:num->(A->bool)` THEN STRIP_TAC THEN + (* From INTERS = {}: every element avoids some f(n) *) + SUBGOAL_THEN `!x:A. ?n:num. ~(x IN f n)` ASSUME_TAC THENL + [GEN_TAC THEN + UNDISCH_TAC `INTERS {(f:num->(A->bool)) n | n IN (:num)} = {}` THEN + REWRITE_TAC[EXTENSION; NOT_IN_EMPTY; IN_INTERS; IN_ELIM_THM; IN_UNIV] THEN + MESON_TAC[]; + ALL_TAC] THEN + (* Apply countable paracompactness to {topspace DIFF f(n)} *) + FIRST_X_ASSUM(MP_TAC o SPEC + `IMAGE (\n:num. topspace top DIFF (f:num->(A->bool)) n) (:num)`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [MATCH_MP_TAC COUNTABLE_IMAGE THEN REWRITE_TAC[NUM_COUNTABLE]; ALL_TAC] THEN + CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_IMAGE; IN_UNIV] THEN GEN_TAC THEN + MATCH_MP_TAC OPEN_IN_DIFF THEN ASM_REWRITE_TAC[OPEN_IN_TOPSPACE]; + ALL_TAC] THEN + REWRITE_TAC[GSYM SUBSET_ANTISYM_EQ] THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_IMAGE; IN_UNIV] THEN + GEN_TAC THEN + MATCH_MP_TAC(SET_RULE `(s:A->bool) SUBSET t ==> t DIFF s SUBSET t`) THEN + MATCH_MP_TAC CLOSED_IN_SUBSET THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[SUBSET; IN_UNIONS; EXISTS_IN_IMAGE; IN_UNIV; IN_DIFF] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `x:A`) THEN + DISCH_THEN(X_CHOOSE_TAC `m:num`) THEN + EXISTS_TAC `m:num` THEN ASM_REWRITE_TAC[]]; + DISCH_THEN(X_CHOOSE_THEN `V:(A->bool)->bool` STRIP_ASSUME_TAC)] THEN + (* Skolemize the refinement to get nv *) + SUBGOAL_THEN + `?nv:(A->bool)->num. !v:A->bool. v IN V + ==> v SUBSET topspace top DIFF (f:num->(A->bool))(nv v)` + (X_CHOOSE_TAC `nv:(A->bool)->num`) THENL + [REWRITE_TAC[GSYM SKOLEM_THM] THEN X_GEN_TAC `v:A->bool` THEN + ASM_CASES_TAC `(v:A->bool) IN V` THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `v:A->bool`) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[EXISTS_IN_IMAGE; IN_UNIV] THEN MESON_TAC[]; + EXISTS_TAC `0` THEN ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + (* Define g(n) = UNIONS {v IN V | v meets f(n)} *) + EXISTS_TAC + `\n:num. UNIONS {v:A->bool | v IN V /\ + ~(v INTER (f:num->(A->bool)) n = {})}` THEN + REWRITE_TAC[] THEN + (* Remove !x. ?n. ~(x IN f n) to reduce assumption count *) + UNDISCH_THEN `!x:A. ?n:num. ~(x IN f n)` (K ALL_TAC) THEN + CONJ_TAC THENL + [(* g(n) is open: union of open sets from V *) + GEN_TAC THEN MATCH_MP_TAC OPEN_IN_UNIONS THEN + REWRITE_TAC[IN_ELIM_THM] THEN REPEAT STRIP_TAC THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN CONJ_TAC THENL + [(* f(n) SUBSET g(n) *) + X_GEN_TAC `n:num` THEN REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN topspace top` ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o MATCH_MP CLOSED_IN_SUBSET o SPEC `n:num`) THEN + ASM SET_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `(x:A) IN UNIONS V` MP_TAC THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `v0:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `v0:A->bool` THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN EXISTS_TAC `x:A` THEN + ASM_REWRITE_TAC[IN_INTER]; + ALL_TAC] THEN + (* INTERS {g n | n IN (:num)} = {} *) + (* First prove pointwise: every x avoids some g(n) *) + SUBGOAL_THEN + `!x:A. ?n:num. ~(x IN UNIONS {v:A->bool | v IN V /\ + ~(v INTER (f:num->(A->bool)) n = {})})` + ASSUME_TAC THENL + [X_GEN_TAC `x:A` THEN + ASM_CASES_TAC `(x:A) IN topspace top` THENL + [ALL_TAC; + (* x not in topspace: x not in any v IN V, so x not in g(0) *) + EXISTS_TAC `0` THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; NOT_EXISTS_THM; DE_MORGAN_THM] THEN + X_GEN_TAC `w:A->bool` THEN + ASM_CASES_TAC `(w:A->bool) IN V` THENL + [DISJ2_TAC THEN + UNDISCH_TAC `locally_finite_in top (V:(A->bool)->bool)` THEN + REWRITE_TAC[locally_finite_in] THEN + DISCH_THEN(MP_TAC o SPEC `w:A->bool` o CONJUNCT1) THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + ASM_REWRITE_TAC[]]] THEN + (* x in topspace: use local finiteness to bound *) + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [locally_finite_in]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPEC `x:A`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `FINITE {v:A->bool | v IN V /\ (x:A) IN v}` + ASSUME_TAC THENL + [MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `{v:A->bool | v IN V /\ ~(v INTER u = {})}` THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `w:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN EXISTS_TAC `x:A` THEN + ASM_REWRITE_TAC[IN_INTER]; + ALL_TAC] THEN + FIRST_ASSUM(MP_TAC o SPEC `nv:(A->bool)->num` o + MATCH_MP UPPER_BOUND_FINITE_SET) THEN + DISCH_THEN(X_CHOOSE_TAC `N:num`) THEN + EXISTS_TAC `N:num` THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; NOT_EXISTS_THM] THEN + X_GEN_TAC `w:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 (CONJUNCTS_THEN2 ASSUME_TAC ASSUME_TAC) + ASSUME_TAC) THEN + (* w IN V, ~(w INTER f N = {}), x IN w *) + FIRST_X_ASSUM(MP_TAC o SPEC `w:A->bool`) THEN + ASM_REWRITE_TAC[IN_ELIM_THM] THEN DISCH_TAC THEN + SUBGOAL_THEN `(f:num->(A->bool)) N SUBSET f(nv(w:A->bool))` + ASSUME_TAC THENL + [FIRST_ASSUM(fun th -> + MATCH_MP_TAC(SPECL [`(nv:(A->bool)->num) w`; `N:num`] + (MATCH_MP DECREASING_CHAIN_SUBSET th))) THEN + FIRST_ASSUM ACCEPT_TAC; + ALL_TAC] THEN + UNDISCH_TAC + `!v:A->bool. v IN V + ==> v SUBSET topspace top DIFF (f:num->(A->bool)) + ((nv:(A->bool)->num) v)` THEN + DISCH_THEN(MP_TAC o SPEC `w:A->bool`) THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `~((w:A->bool) INTER (f:num->(A->bool)) N = {})` THEN + UNDISCH_TAC `(f:num->(A->bool)) N SUBSET f((nv:(A->bool)->num) w)` THEN + SET_TAC[]; + ALL_TAC] THEN + (* Now derive INTERS = {} from the pointwise claim *) + MATCH_MP_TAC(SET_RULE `(!x:A. ~(x IN s)) ==> s = {}`) THEN + X_GEN_TAC `y:A` THEN REWRITE_TAC[IN_INTERS] THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `y:A`) THEN + DISCH_THEN(X_CHOOSE_TAC `n0:num`) THEN + FIRST_X_ASSUM(MP_TAC o SPEC + `UNIONS {v:A->bool | v IN V /\ + ~(v INTER (f:num->(A->bool)) (n0:num) = {})}`) THEN + ANTS_TAC THENL + [REWRITE_TAC[IN_ELIM_THM; IN_UNIV] THEN + EXISTS_TAC `n0:num` THEN REWRITE_TAC[]; + DISCH_TAC THEN + UNDISCH_TAC + `~((y:A) IN UNIONS {v:A->bool | v IN V /\ + ~(v INTER (f:num->(A->bool)) (n0:num) = {})})` THEN + ASM_REWRITE_TAC[]]);; + +(* Backward direction of Dowker: Dowker condition + normality implies + countably paracompact *) +let DOWKER_BACKWARD = prove + (`!top:A topology. + normal_space top /\ + (!f. (!n. closed_in top (f n)) /\ + (!n. f(SUC n) SUBSET f n) /\ + INTERS {f n | n IN (:num)} = {} + ==> ?g. (!n. open_in top (g n)) /\ + (!n. f n SUBSET g n) /\ + INTERS {g n | n IN (:num)} = {}) + ==> countably_paracompact_space top`, + GEN_TAC THEN DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (LABEL_TAC "dowker")) THEN + REWRITE_TAC[countably_paracompact_space] THEN + X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + ASM_CASES_TAC `U:(A->bool)->bool = {}` THENL + [EXISTS_TAC `{}:(A->bool)->bool` THEN + UNDISCH_TAC `UNIONS U = topspace (top:A topology)` THEN + ASM_REWRITE_TAC[UNIONS_0; NOT_IN_EMPTY] THEN DISCH_TAC THEN + REWRITE_TAC[locally_finite_in; NOT_IN_EMPTY] THEN + FIRST_X_ASSUM(SUBST1_TAC o SYM) THEN REWRITE_TAC[NOT_IN_EMPTY]; + ALL_TAC] THEN + FIRST_ASSUM(MP_TAC o + MATCH_MP(REWRITE_RULE[IMP_CONJ] COUNTABLE_AS_IMAGE)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u:num->A->bool` SUBST_ALL_TAC) THEN + RULE_ASSUM_TAC(REWRITE_RULE[FORALL_IN_IMAGE; IN_UNIV]) THEN + UNDISCH_THEN `COUNTABLE(IMAGE (u:num->A->bool) (:num))` (K ALL_TAC) THEN + REMOVE_THEN "dowker" (MP_TAC o SPEC + `\n:num. topspace top DIFF + UNIONS(IMAGE (u:num->A->bool) {i:num | i <= n})`) THEN + BETA_TAC THEN + ANTS_TAC THENL + [REPEAT CONJ_TAC THENL + [GEN_TAC THEN MATCH_MP_TAC CLOSED_IN_DIFF THEN + REWRITE_TAC[CLOSED_IN_TOPSPACE] THEN + MATCH_MP_TAC OPEN_IN_UNIONS THEN + REWRITE_TAC[FORALL_IN_IMAGE] THEN ASM_REWRITE_TAC[]; + GEN_TAC THEN + MATCH_MP_TAC(SET_RULE + `(s:(A->bool)->bool) SUBSET t + ==> u DIFF UNIONS t SUBSET u DIFF UNIONS s`) THEN + MATCH_MP_TAC IMAGE_SUBSET THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN ARITH_TAC; + REWRITE_TAC[EXTENSION; NOT_IN_EMPTY; IN_INTERS; + FORALL_IN_GSPEC; IN_UNIV] THEN + X_GEN_TAC `x:A` THEN REWRITE_TAC[NOT_FORALL_THM] THEN + ASM_CASES_TAC `(x:A) IN topspace top` THENL + [SUBGOAL_THEN `?k:num. (x:A) IN u k` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC + `UNIONS(IMAGE (u:num->A->bool) (:num)) = topspace top` THEN + REWRITE_TAC[EXTENSION; IN_UNIONS; EXISTS_IN_IMAGE; IN_UNIV] THEN + ASM_MESON_TAC[]; + EXISTS_TAC `k:num` THEN + REWRITE_TAC[IN_DIFF; IN_UNIONS; EXISTS_IN_IMAGE; IN_ELIM_THM] THEN + ASM_MESON_TAC[LE_REFL]]; + EXISTS_TAC `0` THEN ASM_REWRITE_TAC[IN_DIFF]]]; + DISCH_THEN(X_CHOOSE_THEN `g:num->A->bool` STRIP_ASSUME_TAC)] THEN + SUBGOAL_THEN + `?H:num->A->bool. !n. open_in top (H n) /\ + topspace top DIFF UNIONS(IMAGE (u:num->A->bool) {i | i <= n}) + SUBSET H n /\ + top closure_of H n SUBSET (g:num->A->bool) n` + (X_CHOOSE_TAC `H:num->A->bool`) THENL + [REWRITE_TAC[GSYM SKOLEM_THM] THEN X_GEN_TAC `n:num` THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [NORMAL_SPACE_ALT]) THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CLOSED_IN_DIFF THEN REWRITE_TAC[CLOSED_IN_TOPSPACE] THEN + MATCH_MP_TAC OPEN_IN_UNIONS THEN + REWRITE_TAC[FORALL_IN_IMAGE] THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + EXISTS_TAC + `IMAGE (\n:num. (u:num->A->bool) n INTER + INTERS(IMAGE (H:num->A->bool) {i:num | i < n})) (:num)` THEN + REWRITE_TAC[FORALL_IN_IMAGE; IN_UNIV] THEN + CONJ_TAC THENL + [(* V_n is open *) + X_GEN_TAC `n:num` THEN + ASM_CASES_TAC `n = 0` THENL + [ASM_REWRITE_TAC[LT; EMPTY_GSPEC; NOT_IN_EMPTY; IMAGE_CLAUSES; INTERS_0; + INTER_UNIV]; + MATCH_MP_TAC OPEN_IN_INTER THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC OPEN_IN_INTERS THEN + REWRITE_TAC[FORALL_IN_IMAGE; IN_ELIM_THM] THEN + REPEAT CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN REWRITE_TAC[FINITE_NUMSEG_LT]; + REWRITE_TAC[IMAGE_EQ_EMPTY] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + EXISTS_TAC `0` THEN ASM_ARITH_TAC; + GEN_TAC THEN DISCH_TAC THEN ASM_REWRITE_TAC[]]]; + ALL_TAC] THEN CONJ_TAC THENL + [(* UNIONS V = topspace *) + REWRITE_TAC[GSYM SUBSET_ANTISYM_EQ] THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_IMAGE; IN_UNIV] THEN + X_GEN_TAC `n:num` THEN + MATCH_MP_TAC(SET_RULE + `(s:A->bool) SUBSET t ==> s INTER u SUBSET t`) THEN + MATCH_MP_TAC OPEN_IN_SUBSET THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[SUBSET; IN_UNIONS; EXISTS_IN_IMAGE; IN_UNIV] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `?n:num. (x:A) IN u n` MP_TAC THENL + [UNDISCH_TAC + `UNIONS(IMAGE (u:num->A->bool) (:num)) = topspace top` THEN + REWRITE_TAC[EXTENSION; IN_UNIONS; EXISTS_IN_IMAGE; IN_UNIV] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + MESON_TAC[]; + GEN_REWRITE_TAC LAND_CONV [num_WOP] THEN + DISCH_THEN(X_CHOOSE_THEN `n:num` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `n:num` THEN REWRITE_TAC[IN_INTER; IN_INTERS; + FORALL_IN_IMAGE; IN_ELIM_THM] THEN + ASM_REWRITE_TAC[] THEN X_GEN_TAC `j:num` THEN DISCH_TAC THEN + SUBGOAL_THEN + `(x:A) IN topspace top DIFF + UNIONS(IMAGE (u:num->A->bool) {i:num | i <= j})` MP_TAC + THENL + [REWRITE_TAC[IN_DIFF; IN_UNIONS; EXISTS_IN_IMAGE; IN_ELIM_THM] THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[NOT_EXISTS_THM; + TAUT `~(p /\ q) <=> p ==> ~q`] THEN + X_GEN_TAC `i:num` THEN DISCH_TAC THEN + FIRST_X_ASSUM MATCH_MP_TAC THEN + MATCH_MP_TAC LET_TRANS THEN EXISTS_TAC `j:num` THEN + ASM_REWRITE_TAC[]; + FIRST_ASSUM(MP_TAC o CONJUNCT1 o CONJUNCT2 o SPEC `j:num`) THEN + REWRITE_TAC[SUBSET] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN + DISCH_THEN ACCEPT_TAC]]]; + ALL_TAC] THEN CONJ_TAC THENL + [(* V refines U *) + X_GEN_TAC `n:num` THEN + EXISTS_TAC `(u:num->A->bool) n` THEN + REWRITE_TAC[IN_IMAGE; IN_UNIV] THEN + CONJ_TAC THENL [MESON_TAC[]; SET_TAC[]]; + ALL_TAC] THEN + (* Locally finite *) + REWRITE_TAC[locally_finite_in] THEN CONJ_TAC THENL + [(* V_n SUBSET topspace *) + REWRITE_TAC[FORALL_IN_IMAGE; IN_UNIV] THEN X_GEN_TAC `n:num` THEN + MATCH_MP_TAC(SET_RULE + `(s:A->bool) SUBSET t ==> s INTER u SUBSET t`) THEN + MATCH_MP_TAC OPEN_IN_SUBSET THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `?n0:num. ~((x:A) IN (g:num->A->bool) n0)` + (X_CHOOSE_TAC `n0:num`) THENL + [FIRST_ASSUM(MP_TAC o check (fun th -> + try snd(dest_eq(concl th)) = `{}:A->bool` with _ -> false)) THEN + REWRITE_TAC[EXTENSION; IN_INTERS; NOT_IN_EMPTY; + FORALL_IN_GSPEC; IN_UNIV] THEN + MESON_TAC[]; + ALL_TAC] THEN + EXISTS_TAC `topspace top DIFF top closure_of (H:num->A->bool) n0` THEN + REPEAT CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_DIFF THEN REWRITE_TAC[OPEN_IN_TOPSPACE] THEN + REWRITE_TAC[CLOSED_IN_CLOSURE_OF]; + (* x IN topspace DIFF closure_of H n0 *) + ASM_REWRITE_TAC[IN_DIFF] THEN + FIRST_ASSUM(MP_TAC o CONJUNCT2 o CONJUNCT2 o SPEC `n0:num`) THEN + FIRST_X_ASSUM(fun th -> + if is_neg(concl th) then MP_TAC th else failwith "x") THEN + SET_TAC[]; + (* FINITE {v IN V | v INTER w != {}} *) + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC + `IMAGE (\n:num. (u:num->A->bool) n INTER + INTERS(IMAGE (H:num->A->bool) {i:num | i < n})) + {j:num | j <= n0}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN REWRITE_TAC[FINITE_NUMSEG_LE]; + REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_IMAGE; IN_UNIV] THEN + X_GEN_TAC `s:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `m:num` ASSUME_TAC) ASSUME_TAC) THEN + FIRST_X_ASSUM(fun th -> + if is_eq(concl th) then SUBST_ALL_TAC th else failwith "") THEN + EXISTS_TAC `m:num` THEN REWRITE_TAC[IN_ELIM_THM] THEN + REWRITE_TAC[GSYM NOT_LT] THEN DISCH_TAC THEN + FIRST_X_ASSUM(fun th -> + if (is_neg (concl th)) then MP_TAC th else failwith "not neg") THEN + REWRITE_TAC[] THEN + MATCH_MP_TAC(SET_RULE + `(s:A->bool) SUBSET c ==> s INTER (t DIFF c) = {}`) THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `(H:num->A->bool) n0` THEN + CONJ_TAC THENL + [MATCH_MP_TAC(SET_RULE + `(h:A->bool) IN s ==> t INTER INTERS s SUBSET h`) THEN + REWRITE_TAC[IN_IMAGE; IN_ELIM_THM] THEN + EXISTS_TAC `n0:num` THEN + ASM_REWRITE_TAC[] THEN ASM_ARITH_TAC; + MATCH_MP_TAC CLOSURE_OF_SUBSET THEN + MATCH_MP_TAC OPEN_IN_SUBSET THEN ASM_REWRITE_TAC[]]]]);; + +(* Engelking 5.2.1/5.2.2 (Dowker): Characterization of countably paracompact + normal spaces *) +let NORMAL_COUNTABLY_PARACOMPACT_CHARACTERIZATION = prove + (`!top:A topology. + normal_space top + ==> (countably_paracompact_space top <=> + !f. (!n. closed_in top (f n)) /\ + (!n. f(SUC n) SUBSET f n) /\ + INTERS {f n | n IN (:num)} = {} + ==> ?g. (!n. open_in top (g n)) /\ + (!n. f n SUBSET g n) /\ + INTERS {g n | n IN (:num)} = {})`, + GEN_TAC THEN DISCH_TAC THEN EQ_TAC THENL + [(* Forward direction: doesn't need normality *) + MATCH_ACCEPT_TAC COUNTABLY_PARACOMPACT_IMP_DOWKER; + (* Backward direction: needs normality *) + DISCH_TAC THEN MATCH_MP_TAC DOWKER_BACKWARD THEN + ASM_REWRITE_TAC[]]);; + +(* Closed subspace of countably paracompact is countably paracompact *) +let COUNTABLY_PARACOMPACT_SPACE_CLOSED_SUBSET = prove + (`!top s:A->bool. + countably_paracompact_space top /\ closed_in top s + ==> countably_paracompact_space(subtopology top s)`, + REPEAT GEN_TAC THEN REWRITE_TAC[countably_paracompact_space] THEN STRIP_TAC THEN + ASM_SIMP_TAC[TOPSPACE_SUBTOPOLOGY_SUBSET; CLOSED_IN_SUBSET] THEN + X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + (* Each u in U is open in subtopology, so u = s INTER f(u) for some choice f *) + SUBGOAL_THEN + `?f:(A->bool)->(A->bool). + !u. u IN U ==> open_in top (f u) /\ u = s INTER f u` + (X_CHOOSE_TAC `f:(A->bool)->(A->bool)`) THENL + [REWRITE_TAC[GSYM SKOLEM_THM] THEN X_GEN_TAC `u:A->bool` THEN + ASM_CASES_TAC `(u:A->bool) IN U` THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `u:A->bool`) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN MESON_TAC[INTER_COMM]; + EXISTS_TAC `{}:A->bool` THEN ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + (* Apply countably_paracompact to (topspace DIFF s) INSERT IMAGE f U *) + FIRST_X_ASSUM(MP_TAC o SPEC + `(topspace top DIFF s:A->bool) INSERT IMAGE (f:(A->bool)->(A->bool)) U`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [REWRITE_TAC[COUNTABLE_INSERT] THEN + MATCH_MP_TAC COUNTABLE_IMAGE THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_INSERT; FORALL_IN_IMAGE] THEN + CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_DIFF THEN REWRITE_TAC[OPEN_IN_TOPSPACE] THEN + ASM_REWRITE_TAC[]; + GEN_TAC THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `x:A->bool`) THEN ASM_REWRITE_TAC[] THEN + SIMP_TAC[]]; + ALL_TAC] THEN + REWRITE_TAC[UNIONS_INSERT] THEN + SUBGOAL_THEN `(s:A->bool) SUBSET topspace top` ASSUME_TAC THENL + [FIRST_ASSUM(ACCEPT_TAC o MATCH_MP CLOSED_IN_SUBSET); ALL_TAC] THEN + SUBGOAL_THEN `!u:A->bool. u IN U ==> u SUBSET (f:(A->bool)->(A->bool)) u` + ASSUME_TAC THENL + [REPEAT STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `u:A->bool`) THEN ASM_REWRITE_TAC[] THEN + SET_TAC[]; ALL_TAC] THEN + UNDISCH_THEN `COUNTABLE(U:(A->bool)->bool)` (K ALL_TAC) THEN + SUBGOAL_THEN + `!u:A->bool. u IN U ==> (f:(A->bool)->(A->bool)) u SUBSET topspace top` + ASSUME_TAC THENL + [GEN_TAC THEN DISCH_TAC THEN MATCH_MP_TAC OPEN_IN_SUBSET THEN + FIRST_X_ASSUM(K ALL_TAC o SPEC `u:A->bool`) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `u:A->bool`) THEN + ASM_REWRITE_TAC[] THEN SIMP_TAC[]; + ALL_TAC] THEN + UNDISCH_THEN + `!u:A->bool. u IN U ==> open_in top ((f:(A->bool)->(A->bool)) u) /\ + u = s INTER f u` (K ALL_TAC) THEN + UNDISCH_THEN `closed_in top (s:A->bool)` (K ALL_TAC) THEN + ASM SET_TAC[]; + DISCH_THEN(X_CHOOSE_THEN `V:(A->bool)->bool` STRIP_ASSUME_TAC)] THEN + (* Remove COUNTABLE from context - causes ASM tactics to hang *) + UNDISCH_THEN `COUNTABLE(U:(A->bool)->bool)` (K ALL_TAC) THEN + (* Produce the subtopology cover: {s INTER v | v IN V, not(v SUBSET DIFF s)} *) + EXISTS_TAC + `{s INTER v:A->bool | v | v IN V /\ ~(v SUBSET topspace top DIFF s)}` THEN + REPEAT CONJ_TAC THENL + [(* open_in subtopology for each s INTER v *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN REPEAT STRIP_TAC THEN + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN + EXISTS_TAC `v:A->bool` THEN CONJ_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN FIRST_ASSUM ACCEPT_TAC; + MATCH_ACCEPT_TAC INTER_COMM]; + (* UNIONS covers s *) + REWRITE_TAC[GSYM SUBSET_ANTISYM_EQ; UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + CONJ_TAC THENL + [REPEAT STRIP_TAC THEN REWRITE_TAC[INTER_SUBSET]; ALL_TAC] THEN + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN topspace top` ASSUME_TAC THENL + [FIRST_ASSUM(MP_TAC o MATCH_MP CLOSED_IN_SUBSET) THEN + UNDISCH_TAC `(x:A) IN s` THEN SET_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `(x:A) IN UNIONS V` MP_TAC THENL + [UNDISCH_TAC `UNIONS (V:(A->bool)->bool) = topspace top` THEN + DISCH_THEN SUBST1_TAC THEN FIRST_ASSUM ACCEPT_TAC; + ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `s INTER v:A->bool` THEN + CONJ_TAC THENL + [EXISTS_TAC `v:A->bool` THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `(x:A) IN v` THEN UNDISCH_TAC `(x:A) IN s` THEN SET_TAC[]; + REWRITE_TAC[IN_INTER] THEN ASM_REWRITE_TAC[]]; + (* Refinement: each s INTER v refines some u IN U *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN REPEAT STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `v:A->bool`) THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[EXISTS_IN_INSERT; EXISTS_IN_IMAGE] THEN + STRIP_TAC THENL + [UNDISCH_TAC `~((v:A->bool) SUBSET topspace top DIFF s)` THEN + ASM_REWRITE_TAC[]; + (* Case: x IN U /\ v SUBSET f x *) + EXISTS_TAC `x:A->bool` THEN CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + (* Goal: s INTER v SUBSET x *) + FIRST_X_ASSUM(K ALL_TAC o SPEC `x:A->bool`) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `x:A->bool`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(CONJUNCTS_THEN2 (K ALL_TAC) SUBST1_TAC) THEN + (* Goal: s INTER v SUBSET s INTER f x *) + UNDISCH_TAC `(v:A->bool) SUBSET (f:(A->bool)->(A->bool)) x` THEN + SET_TAC[]]; + (* Locally finite in subtopology *) + MATCH_MP_TAC LOCALLY_FINITE_IN_SUBTOPOLOGY THEN + REWRITE_TAC[FORALL_IN_GSPEC; INTER_SUBSET] THEN + MATCH_MP_TAC LOCALLY_FINITE_IN_SUBSET THEN + EXISTS_TAC `{(s:A->bool) INTER v | v IN V}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC LOCALLY_FINITE_IN_REFINEMENT THEN + REWRITE_TAC[INTER_SUBSET] THEN ASM_REWRITE_TAC[]; + SET_TAC[]]]);; + +(* Product with compact preserves countable paracompactness *) +(* Same tube argument as PARACOMPACT_SPACE_PRODUCT_COMPACT_LEFT + but indexes by finite subsets F of U (countable). *) + +let COUNTABLY_PARACOMPACT_SPACE_PRODUCT_COMPACT = prove + (`!(top:A topology) (top':B topology). + countably_paracompact_space top /\ compact_space top' + ==> countably_paracompact_space(prod_topology top top')`, + REPEAT STRIP_TAC THEN + REWRITE_TAC[countably_paracompact_space; TOPSPACE_PROD_TOPOLOGY] THEN + X_GEN_TAC `U:((A#B)->bool)->bool` THEN STRIP_TAC THEN + (* Step 1: Tube lemma - for each x, get V(x) and finite Ux(x) *) + SUBGOAL_THEN + `!x:A. x IN topspace top + ==> ?v (Ux:((A#B)->bool)->bool). open_in top v /\ x IN v /\ + FINITE Ux /\ Ux SUBSET U /\ + (v:A->bool) CROSS topspace top' SUBSET UNIONS Ux` + ASSUME_TAC THENL + [X_GEN_TAC `x:A` THEN DISCH_TAC THEN + MATCH_MP_TAC COMPACT_TUBE_COVER THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[SUBSET; FORALL_PAIR_THM; IN_CROSS; IN_SING; IN_UNIONS] THEN + MAP_EVERY X_GEN_TAC [`a:A`; `b:B`] THEN STRIP_TAC THEN + ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [EXTENSION]) THEN + DISCH_THEN(MP_TAC o SPEC `(x:A,b:B)`) THEN + REWRITE_TAC[IN_UNIONS; IN_CROSS] THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Skolemize to get V and Ux *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [SKOLEM_THM_GEN]) THEN + DISCH_THEN(X_CHOOSE_THEN `V:A->(A->bool)` MP_TAC) THEN + REWRITE_TAC[SKOLEM_THM_GEN] THEN + DISCH_THEN(X_CHOOSE_THEN `Ux:A->((A#B)->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Step 2: Group V(x) by the value of Ux(x) to get a countable cover of top *) + ABBREV_TAC + `W = \(G:((A#B)->bool)->bool). + UNIONS {(V:A->(A->bool)) x | x | x IN topspace top /\ + (Ux:A->((A#B)->bool)->bool) x = G}` THEN + (* Key property: W(Ux p) CROSS topspace top' SUBSET UNIONS(Ux p) *) + SUBGOAL_THEN + `!p:A. p IN topspace top + ==> (W:(((A#B)->bool)->bool)->(A->bool))(Ux p) CROSS topspace top' + SUBSET UNIONS ((Ux:A->((A#B)->bool)->bool) p)` + ASSUME_TAC THENL + [X_GEN_TAC `p:A` THEN DISCH_TAC THEN EXPAND_TAC "W" THEN + REWRITE_TAC[] THEN + REWRITE_TAC[SUBSET; FORALL_PAIR_THM; IN_CROSS] THEN + MAP_EVERY X_GEN_TAC [`a:A`; `b:B`] THEN STRIP_TAC THEN + (* a IN UNIONS {V x | ...}, b IN topspace top'. Unpack the UNIONS. *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_UNIONS]) THEN + REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `t:A->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_THEN `x0:A` STRIP_ASSUME_TAC) + ASSUME_TAC)) THEN + (* x0 IN topspace top, Ux x0 = Ux p, t = V x0, a IN t *) + REWRITE_TAC[IN_UNIONS] THEN + SUBGOAL_THEN + `(a:A,b:B) IN UNIONS ((Ux:A->((A#B)->bool)->bool) x0)` MP_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `x0:A`) THEN ASM_REWRITE_TAC[] THEN + STRIP_TAC THEN + FIRST_X_ASSUM(MATCH_MP_TAC o REWRITE_RULE[SUBSET]) THEN + REWRITE_TAC[IN_CROSS] THEN ASM_MESON_TAC[]; + ASM_MESON_TAC[IN_UNIONS]]; + ALL_TAC] THEN + (* Remove COUNTABLE U from context to prevent ASM_ tactic explosions. + First establish the countability we need. *) + SUBGOAL_THEN + `COUNTABLE (IMAGE (Ux:A->((A#B)->bool)->bool) (topspace top))` + ASSUME_TAC THENL + [MATCH_MP_TAC COUNTABLE_SUBSET THEN + EXISTS_TAC `{G:((A#B)->bool)->bool | G SUBSET U /\ FINITE G}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC COUNTABLE_FINITE_SUBSETS THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[SUBSET; IN_IMAGE; IN_ELIM_THM] THEN + X_GEN_TAC `G:((A#B)->bool)->bool` THEN + DISCH_THEN(X_CHOOSE_THEN `y:A` STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `y:A`) THEN ASM_REWRITE_TAC[] THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN ASM SET_TAC[]]; + ALL_TAC] THEN + UNDISCH_THEN `COUNTABLE(U:((A#B)->bool)->bool)` (K ALL_TAC) THEN + (* Apply countably_paracompact_space to the grouped cover *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [countably_paracompact_space]) THEN + DISCH_THEN(MP_TAC o SPEC + `IMAGE (W:(((A#B)->bool)->bool)->(A->bool)) + (IMAGE (Ux:A->((A#B)->bool)->bool) (topspace top))`) THEN + ANTS_TAC THENL + [(* Remove W key property to prevent FIRST_X_ASSUM from matching it + instead of the tube lemma. Not needed inside ANTS_TAC. *) + UNDISCH_THEN + `!p:A. p IN topspace top + ==> (W:(((A#B)->bool)->bool)->(A->bool)) + ((Ux:A->((A#B)->bool)->bool) p) CROSS + topspace (top':B topology) SUBSET UNIONS (Ux p)` + (K ALL_TAC) THEN + REPEAT CONJ_TAC THENL + [(* Countable *) + MATCH_MP_TAC COUNTABLE_IMAGE THEN ASM_REWRITE_TAC[]; + (* Each element is open - FORALL_IN_IMAGE applies twice due to + IMAGE W (IMAGE Ux ...), so universally quantified var is :A *) + REWRITE_TAC[FORALL_IN_IMAGE] THEN + X_GEN_TAC `q:A` THEN DISCH_TAC THEN + EXPAND_TAC "W" THEN REWRITE_TAC[] THEN + MATCH_MP_TAC OPEN_IN_UNIONS THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN + X_GEN_TAC `y:A` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `y:A`) THEN ASM_REWRITE_TAC[] THEN + SIMP_TAC[]; + (* Covers topspace top - EXISTS_IN_IMAGE applies twice similarly *) + REWRITE_TAC[EXTENSION; IN_UNIONS; EXISTS_IN_IMAGE] THEN + X_GEN_TAC `x:A` THEN EQ_TAC THENL + [DISCH_THEN(X_CHOOSE_THEN `q:A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN + `open_in top ((W:(((A#B)->bool)->bool)->(A->bool)) + ((Ux:A->((A#B)->bool)->bool) q))` + MP_TAC THENL + [EXPAND_TAC "W" THEN REWRITE_TAC[] THEN + MATCH_MP_TAC OPEN_IN_UNIONS THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN + X_GEN_TAC `y:A` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `y:A`) THEN ASM_REWRITE_TAC[] THEN + SIMP_TAC[]; + DISCH_THEN(MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN ASM SET_TAC[]]; + DISCH_TAC THEN + EXISTS_TAC `x:A` THEN + CONJ_TAC THENL + [ASM_REWRITE_TAC[]; + EXPAND_TAC "W" THEN REWRITE_TAC[] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `(V:A->(A->bool)) x` THEN + CONJ_TAC THENL + [EXISTS_TAC `x:A` THEN ASM_REWRITE_TAC[]; + FIRST_X_ASSUM(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + SIMP_TAC[]]]]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `Z:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Step 3: For each z in Z, pick xw(z) in topspace top *) + SUBGOAL_THEN + `?xw:(A->bool)->A. !z. z IN Z + ==> xw z IN topspace top /\ + z SUBSET (W:(((A#B)->bool)->bool)->(A->bool)) + ((Ux:A->((A#B)->bool)->bool)(xw z))` + STRIP_ASSUME_TAC THENL + [REWRITE_TAC[GSYM SKOLEM_THM_GEN] THEN + X_GEN_TAC `z:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `z:A->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `c:A->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_IMAGE]) THEN + DISCH_THEN(X_CHOOSE_THEN `G:((A#B)->bool)->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_IMAGE]) THEN + DISCH_THEN(X_CHOOSE_THEN `p:A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `p:A` THEN ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[SUBSET_TRANS]; + ALL_TAC] THEN + (* Step 4: Build the product refinement *) + EXISTS_TAC `{(z:A->bool) CROSS topspace top' INTER (u:(A#B)->bool) | + z IN Z /\ u IN (Ux:A->((A#B)->bool)->bool)((xw:(A->bool)->A) z)}` THEN + REPEAT CONJ_TAC THENL + [(* Each element is open in the product *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN + MAP_EVERY X_GEN_TAC [`z:A->bool`; `u:(A#B)->bool`] THEN STRIP_TAC THEN + MATCH_MP_TAC OPEN_IN_INTER THEN CONJ_TAC THENL + [ASM_SIMP_TAC[OPEN_IN_CROSS; OPEN_IN_TOPSPACE]; + ASM_MESON_TAC[SUBSET]]; + (* Covers the product space *) + REWRITE_TAC[EXTENSION; IN_UNIONS; IN_ELIM_THM; FORALL_PAIR_THM; + IN_CROSS] THEN + MAP_EVERY X_GEN_TAC [`a:A`; `b:B`] THEN EQ_TAC THENL + [(* Forward: element of tube => in product topspace *) + DISCH_THEN(X_CHOOSE_THEN `s:(A#B)->bool` STRIP_ASSUME_TAC) THEN + RULE_ASSUM_TAC(REWRITE_RULE[IN_INTER; IN_CROSS]) THEN + RULE_ASSUM_TAC(REWRITE_RULE[locally_finite_in]) THEN + ASM_MESON_TAC[SUBSET]; + (* Backward: (a,b) in product topspace => find a tube *) + STRIP_TAC THEN + SUBGOAL_THEN `(a:A) IN UNIONS Z` MP_TAC THENL + [FIRST_X_ASSUM(fun th -> GEN_REWRITE_TAC RAND_CONV [th]) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `z:A->bool` STRIP_ASSUME_TAC) THEN + (* a IN W(Ux(xw z)) since z SUBSET W(Ux(xw z)) *) + SUBGOAL_THEN + `(a:A,b:B) IN UNIONS ((Ux:A->((A#B)->bool)->bool)((xw:(A->bool)->A) z))` + MP_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `(xw:(A->bool)->A) z`) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + STRIP_TAC THEN + FIRST_X_ASSUM(MATCH_MP_TAC o REWRITE_RULE[SUBSET; FORALL_PAIR_THM; + IN_CROSS]) THEN + ASM_MESON_TAC[SUBSET]; + ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `u:(A#B)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(z:A->bool) CROSS topspace top' INTER (u:(A#B)->bool)` THEN + CONJ_TAC THENL + [EXISTS_TAC `z:A->bool` THEN EXISTS_TAC `u:(A#B)->bool` THEN + ASM_REWRITE_TAC[]; + REWRITE_TAC[IN_INTER; IN_CROSS] THEN ASM_REWRITE_TAC[]]]; + (* Each element refines U *) + EXISTS_TAC `\v:(A#B)->bool. @u:(A#B)->bool. + ?w:A->bool. (w IN Z /\ u IN (Ux:A->((A#B)->bool)->bool) + ((xw:(A->bool)->A) w)) /\ + v = w CROSS topspace top' INTER u` THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN + MAP_EVERY X_GEN_TAC [`z:A->bool`; `u:(A#B)->bool`] THEN STRIP_TAC THEN + REWRITE_TAC[] THEN + SUBGOAL_THEN `?u':(A#B)->bool. ?w':A->bool. + (w' IN Z /\ u' IN (Ux:A->((A#B)->bool)->bool)((xw:(A->bool)->A) w')) /\ + (z:A->bool) CROSS topspace top' INTER (u:(A#B)->bool) = + w' CROSS topspace top' INTER u'` + MP_TAC THENL + [EXISTS_TAC `u:(A#B)->bool` THEN EXISTS_TAC `z:A->bool` THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + DISCH_THEN(MP_TAC o SELECT_RULE) THEN + DISCH_THEN(X_CHOOSE_THEN `w':A->bool` STRIP_ASSUME_TAC) THEN + CONJ_TAC THENL [ASM_MESON_TAC[SUBSET]; ASM SET_TAC[]]; + (* Locally finite - use LOCALLY_FINITE_PRODUCT_TUBES *) + MATCH_MP_TAC LOCALLY_FINITE_PRODUCT_TUBES THEN + EXISTS_TAC `U:((A#B)->bool)->bool` THEN + ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[SUBSET_TRANS]]);; + +(* ------------------------------------------------------------------------- *) +(* Nagata-Smirnov metrization (Munkres Sections 39-40) *) +(* ------------------------------------------------------------------------- *) + +(* Helper: In a regular space with sigma-locally-finite open base, + every closed set is G_delta *) +let CLOSED_G_DELTA_IN_SIGMA_LOCALLY_FINITE_BASE = prove + (`!top:A topology C (B:(A->bool)->bool). + regular_space top /\ + closed_in top C /\ + (!b. b IN B ==> open_in top b) /\ + (!x u. open_in top u /\ x IN u + ==> ?b. b IN B /\ x IN b /\ b SUBSET u) /\ + sigma_locally_finite_in top B + ==> gdelta_in top C`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Unfold sigma_locally_finite_in to get Bn *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [sigma_locally_finite_in]) THEN + DISCH_THEN(X_CHOOSE_THEN `Bn:num->(A->bool)->bool` STRIP_ASSUME_TAC) THEN + REWRITE_TAC[GDELTA_IN_ALT] THEN + CONJ_TAC THENL [ASM_MESON_TAC[CLOSED_IN_SUBSET]; ALL_TAC] THEN + (* For each n, Sn = {b in Bn(n) : closure_of b disjoint from C} *) + ABBREV_TAC + `Sn = \n:num. {b:A->bool | b IN Bn n /\ + top closure_of b INTER C = {}}` THEN + SUBGOAL_THEN `!n:num. locally_finite_in top ((Sn:num->(A->bool)->bool) n)` + ASSUME_TAC THENL + [X_GEN_TAC `n:num` THEN + SUBGOAL_THEN + `(Sn:num->(A->bool)->bool) n SUBSET (Bn:num->(A->bool)->bool) n` + MP_TAC THENL + [EXPAND_TAC "Sn" THEN SET_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[LOCALLY_FINITE_IN_SUBSET]; + ALL_TAC] THEN + (* closure of UNIONS(Sn n) is disjoint from C *) + SUBGOAL_THEN + `!n:num. top closure_of + (UNIONS ((Sn:num->(A->bool)->bool) n)) INTER C = {}` + ASSUME_TAC THENL + [X_GEN_TAC `n:num` THEN ASM_SIMP_TAC[CLOSURE_OF_LOCALLY_FINITE_UNIONS] THEN + REWRITE_TAC[INTER_UNIONS; EMPTY_UNIONS; FORALL_IN_GSPEC] THEN + X_GEN_TAC `b:A->bool` THEN + EXPAND_TAC "Sn" THEN REWRITE_TAC[IN_ELIM_THM] THEN + MESON_TAC[]; + ALL_TAC] THEN + (* For x not in C, x is in UNIONS(Sn m) for some m *) + SUBGOAL_THEN + `!x:A. x IN topspace top /\ ~(x IN C) + ==> ?m:num. x IN UNIONS ((Sn:num->(A->bool)->bool) m)` + ASSUME_TAC THENL + [X_GEN_TAC `x:A` THEN STRIP_TAC THEN + (* Use regularity: for x in open topspace\C, get closed v with x in u + subset v subset topspace\C *) + MP_TAC(REWRITE_RULE[NEIGHBOURHOOD_BASE_OF] + (REWRITE_RULE[GSYM NEIGHBOURHOOD_BASE_OF_CLOSED_IN] + (ASSUME `regular_space (top:A topology)`))) THEN + DISCH_THEN(MP_TAC o SPECL + [`topspace top DIFF C:A->bool`; `x:A`]) THEN + ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_TOPSPACE; IN_DIFF] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` + (X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC)) THEN + (* Use base property to find b in B with x in b subset u *) + FIRST_X_ASSUM(MP_TAC o SPECL [`x:A`; `u:A->bool`]) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `b:A->bool` STRIP_ASSUME_TAC) THEN + (* b subset u subset v (closed), so cl(b) subset v subset topspace\C *) + SUBGOAL_THEN `top closure_of (b:A->bool) INTER C = {}` ASSUME_TAC THENL + [SUBGOAL_THEN `top closure_of (b:A->bool) SUBSET v` ASSUME_TAC THENL + [MATCH_MP_TAC CLOSURE_OF_MINIMAL THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + ASM SET_TAC[]]; + ALL_TAC] THEN + (* b in B = UNIONS {Bn n | n}, so b in Bn m for some m *) + SUBGOAL_THEN `?m:num. (b:A->bool) IN (Bn:num->(A->bool)->bool) m` + (X_CHOOSE_THEN `m:num` ASSUME_TAC) THENL + [FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_UNIONS]) THEN + REWRITE_TAC[IN_ELIM_THM; IN_UNIV] THEN MESON_TAC[]; + ALL_TAC] THEN + (* Therefore b in Sn m, and x in UNIONS(Sn m) *) + EXISTS_TAC `m:num` THEN REWRITE_TAC[IN_UNIONS] THEN + EXISTS_TAC `b:A->bool` THEN ASM_REWRITE_TAC[] THEN + EXPAND_TAC "Sn" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Now build the gdelta_in witness *) + REWRITE_TAC[INTERSECTION_OF] THEN + EXISTS_TAC `IMAGE (\n:num. topspace top DIFF + top closure_of (UNIONS ((Sn:num->(A->bool)->bool) n))) + (:num)` THEN + REWRITE_TAC[FORALL_IN_IMAGE; IN_UNIV] THEN + REPEAT CONJ_TAC THENL + [(* COUNTABLE *) + MATCH_MP_TAC COUNTABLE_IMAGE THEN REWRITE_TAC[NUM_COUNTABLE]; + (* Each element is open *) + X_GEN_TAC `n:num` THEN MATCH_MP_TAC OPEN_IN_DIFF THEN + REWRITE_TAC[OPEN_IN_TOPSPACE; CLOSED_IN_CLOSURE_OF]; + (* INTERS = C *) + REWRITE_TAC[EXTENSION; IN_INTERS; FORALL_IN_IMAGE; IN_UNIV; IN_DIFF] THEN + X_GEN_TAC `x:A` THEN EQ_TAC THENL + [(* INTERS subset C: if x in all Gn then x in C *) + DISCH_TAC THEN + (* Suppose x not in C. Then x in UNIONS(Sn m) for some m. *) + ASM_CASES_TAC `(x:A) IN C` THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `(x:A) IN topspace top` ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `0`) THEN + MP_TAC(ISPECL [`top:A topology`; + `UNIONS ((Sn:num->(A->bool)->bool) 0)`] + CLOSURE_OF_SUBSET_TOPSPACE) THEN + SET_TAC[]; + ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `m:num` ASSUME_TAC) THEN + (* x in UNIONS(Sn m) implies x in cl(UNIONS(Sn m)), contradiction *) + FIRST_X_ASSUM(MP_TAC o SPEC `m:num`) THEN + REWRITE_TAC[] THEN + MP_TAC(ISPECL [`top:A topology`; + `UNIONS ((Sn:num->(A->bool)->bool) m)`] + CLOSURE_OF_SUBSET) THEN + SUBGOAL_THEN + `UNIONS ((Sn:num->(A->bool)->bool) m) SUBSET topspace top` + (fun th -> REWRITE_TAC[th]) THENL + [REWRITE_TAC[UNIONS_SUBSET] THEN + ASM_MESON_TAC[locally_finite_in]; + ASM SET_TAC[]]; + (* C subset INTERS: if x in C then x in each Gn *) + DISCH_TAC THEN X_GEN_TAC `n:num` THEN CONJ_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET; SUBSET]; + FIRST_X_ASSUM(MP_TAC o SPEC `n:num`) THEN + MP_TAC(ISPECL [`top:A topology`; + `UNIONS ((Sn:num->(A->bool)->bool) n)`] + CLOSURE_OF_SUBSET_TOPSPACE) THEN + ASM SET_TAC[]]]]);; + +(* Helper: In a normal space, for a closed G_delta set A, + there exists continuous f with f^{-1}(0) = A *) +let URYSOHN_FUNCTION_G_DELTA = prove + (`!top:A topology A. + normal_space top /\ closed_in top A /\ gdelta_in top A + ==> ?f. continuous_map(top,euclideanreal) f /\ + (!x. x IN topspace top ==> &0 <= f x /\ f x <= &1) /\ + (!x. x IN topspace top ==> (f x = &0 <=> x IN A))`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Step 1: Extract countable family of open sets from gdelta_in *) + UNDISCH_TAC `gdelta_in (top:A topology) (A:A->bool)` THEN + REWRITE_TAC[GDELTA_IN_ALT; INTERSECTION_OF] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `u:(A->bool)->bool` STRIP_ASSUME_TAC)) THEN + MP_TAC(ISPEC `(topspace top:A->bool) INSERT u` COUNTABLE_AS_IMAGE) THEN + ANTS_TAC THENL + [ASM_SIMP_TAC[COUNTABLE_INSERT] THEN SET_TAC[]; + DISCH_THEN(X_CHOOSE_TAC `U:num->A->bool`)] THEN + SUBGOAL_THEN `!n:num. open_in top ((U:num->A->bool) n)` ASSUME_TAC THENL + [GEN_TAC THEN + SUBGOAL_THEN `(U:num->A->bool) n IN (topspace top:A->bool) INSERT u` + MP_TAC THENL + [FIRST_ASSUM(fun th -> GEN_REWRITE_TAC RAND_CONV [th]) THEN + REWRITE_TAC[IN_IMAGE; IN_UNIV] THEN MESON_TAC[]; + REWRITE_TAC[IN_INSERT] THEN + DISCH_THEN(DISJ_CASES_TAC) THENL + [ASM_REWRITE_TAC[OPEN_IN_TOPSPACE]; ASM_MESON_TAC[]]]; + ALL_TAC] THEN + SUBGOAL_THEN `(A:A->bool) = INTERS {U n | n IN (:num)}` ASSUME_TAC THENL + [SUBGOAL_THEN + `{(U:num->A->bool) n | n IN (:num)} = topspace top INSERT u` + SUBST1_TAC THENL + [REWRITE_TAC[SIMPLE_IMAGE] THEN FIRST_ASSUM(ACCEPT_TAC o SYM); + REWRITE_TAC[INTERS_INSERT] THEN ASM SET_TAC[]]; + ALL_TAC] THEN + SUBGOAL_THEN `!n:num. (A:A->bool) SUBSET U n` ASSUME_TAC THENL + [GEN_TAC THEN FIRST_ASSUM(fun th -> + GEN_REWRITE_TAC LAND_CONV [th]) THEN + REWRITE_TAC[SUBSET; IN_INTERS; FORALL_IN_GSPEC; IN_UNIV] THEN + MESON_TAC[]; + ALL_TAC] THEN + (* Step 2: Get Urysohn functions for each n *) + SUBGOAL_THEN + `!n. ?fn:A->real. + continuous_map + (top, subtopology euclideanreal (real_interval[&0,&1])) fn /\ + (!x. x IN A ==> fn x = &0) /\ + (!x. x IN topspace top DIFF (U:num->A->bool) n ==> fn x = &1)` + MP_TAC THENL + [GEN_TAC THEN + MP_TAC(ISPECL [`top:A topology`; `A:A->bool`; + `topspace top DIFF (U:num->A->bool) n`; + `&0`; `&1`] URYSOHN_LEMMA) THEN + ASM_REWRITE_TAC[REAL_POS] THEN ANTS_TAC THENL + [CONJ_TAC THENL + [MATCH_MP_TAC CLOSED_IN_DIFF THEN + ASM_REWRITE_TAC[CLOSED_IN_TOPSPACE]; + REWRITE_TAC[DISJOINT] THEN ASM SET_TAC[]]; + MESON_TAC[]]; + REWRITE_TAC[SKOLEM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `fn:num->A->real` MP_TAC) THEN + REWRITE_TAC[FORALL_AND_THM] THEN STRIP_TAC] THEN + (* Extract continuity into euclideanreal and bounds *) + SUBGOAL_THEN + `(!n:num. continuous_map(top,euclideanreal) ((fn:num->A->real) n)) /\ + (!n x:A. x IN topspace top ==> &0 <= fn n x /\ fn n x <= &1)` + STRIP_ASSUME_TAC THENL + [CONJ_TAC THENL + [GEN_TAC THEN + SUBGOAL_THEN + `continuous_map + (top:A topology, + subtopology euclideanreal (real_interval [&0,&1])) + ((fn:num->A->real) n)` + MP_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY] THEN MESON_TAC[]; + REPEAT GEN_TAC THEN DISCH_TAC THEN + SUBGOAL_THEN + `continuous_map + (top:A topology, + subtopology euclideanreal (real_interval [&0,&1])) + ((fn:num->A->real) n)` + MP_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[CONTINUOUS_MAP_IN_SUBTOPOLOGY; + SUBSET; FORALL_IN_IMAGE; IN_REAL_INTERVAL] THEN + STRIP_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + (* Step 3: Prove partial sums are continuous *) + SUBGOAL_THEN + `!n. continuous_map(top:A topology, euclideanreal) + (\x. sum(0..n) (\k. (fn:num->A->real) k x * inv(&2) pow (k + 1)))` + ASSUME_TAC THENL + [GEN_TAC THEN MATCH_MP_TAC CONTINUOUS_MAP_SUM THEN + REWRITE_TAC[FINITE_NUMSEG; IN_NUMSEG] THEN + REPEAT STRIP_TAC THEN MATCH_MP_TAC CONTINUOUS_MAP_REAL_RMUL THEN + ASM_SIMP_TAC[ETA_AX]; + ALL_TAC] THEN + (* Step 4: Apply uniform Cauchy limit to get limit function *) + MP_TAC(ISPECL + [`top:A topology`; `real_euclidean_metric`; + `(\n x:A. sum(0..n) + (\k. (fn:num->A->real) k x * inv(&2) pow (k + 1))):num->A->real`] + CONTINUOUS_MAP_UNIFORMLY_CAUCHY_LIMIT) THEN + ASM_REWRITE_TAC[TRIVIAL_LIMIT_SEQUENTIALLY; MTOPOLOGY_REAL_EUCLIDEAN_METRIC; + EVENTUALLY_TRUE; MCOMPLETE_REAL_EUCLIDEAN_METRIC] THEN + REWRITE_TAC[REAL_EUCLIDEAN_METRIC] THEN + DISCH_TAC THEN + (* Get the limit function via CONTINUOUS_MAP_UNIFORMLY_CAUCHY_LIMIT *) + SUBGOAL_THEN + `?g:A->real. continuous_map(top,euclideanreal) g /\ + (!e. &0 < e + ==> eventually + (\n. !(x:A). x IN topspace top + ==> abs(g x - sum (0..n) + (\k. (fn:num->A->real) k x * + inv(&2) pow (k + 1))) < e) + sequentially)` + (X_CHOOSE_THEN `g:A->real` STRIP_ASSUME_TAC) THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN + X_GEN_TAC `e:real` THEN DISCH_TAC THEN + MP_TAC(ISPECL [`inv(&2)`; `e:real`] ARCH_EVENTUALLY_POW_INV) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN CONV_TAC REAL_RAT_REDUCE_CONV; ALL_TAC] THEN + REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `N:num` THEN DISCH_TAC THEN + MATCH_MP_TAC WLOG_LT THEN REPEAT CONJ_TAC THENL + [REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[REAL_SUB_REFL; REAL_ABS_NUM]; + MESON_TAC[REAL_ABS_SUB]; + (* Case m < n *) + MAP_EVERY X_GEN_TAC [`m:num`; `nn:num`] THEN DISCH_TAC THEN + REPEAT STRIP_TAC THEN + SUBGOAL_THEN + `sum(0..nn) (\k. (fn:num->A->real) k x * inv(&2) pow (k + 1)) - + sum(0..m) (\k. fn k x * inv(&2) pow (k + 1)) = + sum(m+1..nn) (\k. fn k x * inv(&2) pow (k + 1))` + ASSUME_TAC THENL + [MP_TAC(ISPECL + [`\k. (fn:num->A->real) k x * inv(&2) pow (k + 1)`; + `0`; `m:num`; `nn:num`] SUM_COMBINE_R) THEN + ANTS_TAC THENL [ASM_ARITH_TAC; REAL_ARITH_TAC]; + ALL_TAC] THEN + SUBGOAL_THEN + `&0 <= sum(m+1..nn) + (\k. (fn:num->A->real) k x * inv(&2) pow (k + 1))` + ASSUME_TAC THENL + [MATCH_MP_TAC SUM_POS_LE_NUMSEG THEN REPEAT STRIP_TAC THEN + BETA_TAC THEN MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET; SUBSET]; + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV]; + ALL_TAC] THEN + TRANS_TAC REAL_LET_TRANS + `sum(m+1..nn) (\k. (fn:num->A->real) k x * inv(&2) pow (k + 1))` THEN + CONJ_TAC THENL + [MATCH_MP_TAC(REAL_ARITH + `a - b = c /\ &0 <= c ==> abs(a - b) <= c`) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + TRANS_TAC REAL_LET_TRANS + `sum(m+1..nn) (\k. inv(&2) pow (k + 1))` THEN + CONJ_TAC THENL + [MATCH_MP_TAC SUM_LE_NUMSEG THEN REPEAT STRIP_TAC THEN + BETA_TAC THEN + GEN_REWRITE_TAC RAND_CONV [GSYM REAL_MUL_LID] THEN + MATCH_MP_TAC REAL_LE_RMUL THEN CONJ_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET; SUBSET]; + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV]; + ALL_TAC] THEN + TRANS_TAC REAL_LET_TRANS `inv(&2) pow m` THEN CONJ_TAC THENL + [(* Geometric sum bound using SUM_GP_MULTIPLIED *) + REWRITE_TAC[GSYM ADD1; CONJUNCT2 real_pow; SUM_LMUL] THEN + MP_TAC(ISPECL [`inv(&2)`; `SUC m`; `nn:num`] SUM_GP_MULTIPLIED) THEN + ANTS_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + SUBGOAL_THEN `&1 - inv(&2) = inv(&2)` + (fun th -> REWRITE_TAC[th]) THENL + [CONV_TAC REAL_RAT_REDUCE_CONV; ALL_TAC] THEN + DISCH_THEN SUBST1_TAC THEN + MATCH_MP_TAC(REAL_ARITH `a <= b /\ &0 <= c ==> a - c <= b`) THEN + CONJ_TAC THENL + [MATCH_MP_TAC REAL_POW_MONO_INV THEN + CONV_TAC REAL_RAT_REDUCE_CONV THEN ARITH_TAC; + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV]; + FIRST_X_ASSUM(MP_TAC o SPEC `m:num`) THEN + ANTS_TAC THENL [ASM_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[REAL_ABS_POW; REAL_ABS_INV; REAL_ABS_NUM] THEN + SIMP_TAC[]]]; + (* Step 5: g already extracted by SUBGOAL_THEN, prove properties *) + EXISTS_TAC `g:A->real` THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL + [(* Part 1: &0 <= g x /\ g x <= &1 *) + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN + `!m. &0 <= sum(0..m) + (\k. (fn:num->A->real) k x * inv(&2) pow (k+1)) /\ + sum(0..m) + (\k. fn k x * inv(&2) pow (k+1)) <= &1` + ASSUME_TAC THENL + [GEN_TAC THEN CONJ_TAC THENL + [MATCH_MP_TAC SUM_POS_LE_NUMSEG THEN REPEAT STRIP_TAC THEN + BETA_TAC THEN MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC THENL + [ASM_MESON_TAC[]; + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV]; + TRANS_TAC REAL_LE_TRANS + `sum(0..m) (\k. inv(&2) pow (k + 1))` THEN + CONJ_TAC THENL + [MATCH_MP_TAC SUM_LE_NUMSEG THEN REPEAT STRIP_TAC THEN + BETA_TAC THEN + GEN_REWRITE_TAC RAND_CONV [GSYM REAL_MUL_LID] THEN + MATCH_MP_TAC REAL_LE_RMUL THEN CONJ_TAC THENL + [ASM_MESON_TAC[]; + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV]; + REWRITE_TAC[GSYM ADD1; CONJUNCT2 real_pow; SUM_LMUL] THEN + MP_TAC(ISPECL [`inv(&2)`; `0`; `m:num`] SUM_GP_MULTIPLIED) THEN + REWRITE_TAC[LE_0] THEN + SUBGOAL_THEN `&1 - inv(&2) = inv(&2)` + (fun th -> REWRITE_TAC[th]) THENL + [CONV_TAC REAL_RAT_REDUCE_CONV; ALL_TAC] THEN + REWRITE_TAC[CONJUNCT1 real_pow] THEN + DISCH_THEN SUBST1_TAC THEN + MATCH_MP_TAC(REAL_ARITH `&0 <= b ==> &1 - b <= &1`) THEN + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV]]; + ALL_TAC] THEN + CONJ_TAC THENL + [(* &0 <= g x *) + REWRITE_TAC[GSYM REAL_NOT_LT] THEN DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o SPEC `--((g:A->real) x)`) THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN + DISCH_THEN(X_CHOOSE_THEN `N:num` (MP_TAC o SPEC `N:num`)) THEN + REWRITE_TAC[LE_REFL] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `N:num`) THEN + UNDISCH_TAC `(g:A->real) x < &0` THEN REAL_ARITH_TAC; + (* g x <= &1 *) + REWRITE_TAC[GSYM REAL_NOT_LT] THEN DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o SPEC `(g:A->real) x - &1`) THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN + DISCH_THEN(X_CHOOSE_THEN `N:num` (MP_TAC o SPEC `N:num`)) THEN + REWRITE_TAC[LE_REFL] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `N:num`) THEN + UNDISCH_TAC `&1 < (g:A->real) x` THEN REAL_ARITH_TAC]; + (* Part 2: g x = 0 iff x in INTERS{U n | n} *) + X_GEN_TAC `x:A` THEN DISCH_TAC THEN EQ_TAC THENL + [(* g x = 0 ==> x IN INTERS{U n | n} *) + DISCH_TAC THEN + REWRITE_TAC[IN_INTERS; FORALL_IN_GSPEC; IN_UNIV] THEN + X_GEN_TAC `n:num` THEN + MATCH_MP_TAC(TAUT `(~p ==> F) ==> p`) THEN DISCH_TAC THEN + SUBGOAL_THEN `(fn:num->A->real) n x = &1` ASSUME_TAC THENL + [FIRST_ASSUM MATCH_MP_TAC THEN ASM SET_TAC[]; ALL_TAC] THEN + FIRST_ASSUM(MP_TAC o SPEC `inv(&2) pow (n + 1)`) THEN + ANTS_TAC THENL + [MATCH_MP_TAC REAL_POW_LT THEN CONV_TAC REAL_RAT_REDUCE_CONV; + ALL_TAC] THEN + REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN + DISCH_THEN(X_CHOOSE_TAC `N:num`) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `N + n:num`) THEN + ANTS_TAC THENL [ARITH_TAC; ALL_TAC] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + ASM_REWRITE_TAC[REAL_SUB_LZERO; REAL_ABS_NEG] THEN + SUBGOAL_THEN + `inv(&2) pow (n + 1) <= + sum(0..N + n) + (\k. (fn:num->A->real) k x * inv(&2) pow (k + 1))` + MP_TAC THENL + [MP_TAC(ISPECL [`n..n`; `0..N + n`; + `\k:num. (fn:num->A->real) k (x:A) * inv(&2) pow (k + 1)`] + SUM_SUBSET_SIMPLE) THEN + ANTS_TAC THENL + [REWRITE_TAC[FINITE_NUMSEG; SUBSET_NUMSEG] THEN + CONJ_TAC THENL [ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[IN_DIFF; IN_NUMSEG] THEN + REPEAT STRIP_TAC THEN BETA_TAC THEN + MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC THENL + [ASM_MESON_TAC[]; + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV]; + REWRITE_TAC[SUM_SING_NUMSEG] THEN BETA_TAC THEN + ASM_REWRITE_TAC[REAL_MUL_LID]]; + ALL_TAC] THEN + SUBGOAL_THEN + `&0 <= sum(0..N + n) + (\k. (fn:num->A->real) k x * inv(&2) pow (k + 1))` + MP_TAC THENL + [MATCH_MP_TAC SUM_POS_LE_NUMSEG THEN REPEAT STRIP_TAC THEN + BETA_TAC THEN MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC THENL + [ASM_MESON_TAC[]; + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV]; + REAL_ARITH_TAC]; + (* x IN INTERS{U n | n} ==> g x = 0 *) + DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN A` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `!n:num. (fn:num->A->real) n x = &0` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `!m. sum(0..m) + (\k. (fn:num->A->real) k x * inv(&2) pow (k+1)) = &0` + ASSUME_TAC THENL + [GEN_TAC THEN MATCH_MP_TAC SUM_EQ_0_NUMSEG THEN + REPEAT STRIP_TAC THEN BETA_TAC THEN + ASM_REWRITE_TAC[REAL_MUL_LZERO]; + ALL_TAC] THEN + MATCH_MP_TAC(TAUT `(~p ==> F) ==> p`) THEN DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o SPEC `abs((g:A->real) x)`) THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN + DISCH_THEN(X_CHOOSE_THEN `N:num` (MP_TAC o SPEC `N:num`)) THEN + REWRITE_TAC[LE_REFL] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN + ASM_REWRITE_TAC[REAL_SUB_RZERO] THEN + REAL_ARITH_TAC]]]);; + +(* Helper: open sets in regular spaces with sigma-LF base have + "closure covers": W = UNIONS{En n} with closure(En n) SUBSET W *) +let OPEN_SIGMA_LF_CLOSURE_COVER = prove + (`!top:A topology B W. + regular_space top /\ open_in top W /\ + (!b. b IN B ==> open_in top b) /\ + (!x u. open_in top u /\ x IN u + ==> ?b. b IN B /\ x IN b /\ b SUBSET u) /\ + sigma_locally_finite_in top B + ==> ?En. (!n. open_in top (En n)) /\ + (!n. top closure_of (En n) SUBSET W) /\ + W SUBSET UNIONS {En n | n IN (:num)}`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [sigma_locally_finite_in]) THEN + DISCH_THEN(X_CHOOSE_THEN `Bn:num->(A->bool)->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN + `!n:num (b:A->bool). b IN (Bn:num->(A->bool)->bool) n ==> open_in top b` + ASSUME_TAC THENL + [REPEAT STRIP_TAC THEN FIRST_ASSUM MATCH_MP_TAC THEN + ASM_REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + EXISTS_TAC `(Bn:num->(A->bool)->bool) (n:num)` THEN + ASM_REWRITE_TAC[] THEN EXISTS_TAC `n:num` THEN REWRITE_TAC[]; + ALL_TAC] THEN + EXISTS_TAC `\n. UNIONS {b:A->bool | b IN (Bn:num->(A->bool)->bool) n /\ + top closure_of b SUBSET W}` THEN + SUBGOAL_THEN + `!n. locally_finite_in top + {b:A->bool | b IN (Bn:num->(A->bool)->bool) n /\ + top closure_of b SUBSET W}` + ASSUME_TAC THENL + [GEN_TAC THEN MATCH_MP_TAC LOCALLY_FINITE_IN_SUBSET THEN + EXISTS_TAC `(Bn:num->(A->bool)->bool) n` THEN ASM SET_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [(* open *) + GEN_TAC THEN MATCH_MP_TAC OPEN_IN_UNIONS THEN ASM SET_TAC[]; + (* closure SUBSET W *) + GEN_TAC THEN ASM_SIMP_TAC[CLOSURE_OF_LOCALLY_FINITE_UNIONS] THEN + REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC; IN_ELIM_THM] THEN + SIMP_TAC[]; + (* covering: W SUBSET UNIONS *) + ONCE_REWRITE_TAC[SUBSET] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + MP_TAC(REWRITE_RULE[NEIGHBOURHOOD_BASE_OF] + (REWRITE_RULE[GSYM NEIGHBOURHOOD_BASE_OF_CLOSED_IN] + (ASSUME `regular_space (top:A topology)`))) THEN + DISCH_THEN(MP_TAC o SPECL [`W:A->bool`; `x:A`]) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` + (X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC)) THEN + SUBGOAL_THEN + `?b:A->bool. b IN B /\ (x:A) IN b /\ b SUBSET (u:A->bool)` + (X_CHOOSE_THEN `b:A->bool` STRIP_ASSUME_TAC) THENL + [FIRST_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `top closure_of (b:A->bool) SUBSET W` ASSUME_TAC THENL + [MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC `v:A->bool` THEN + CONJ_TAC THENL + [MATCH_MP_TAC CLOSURE_OF_MINIMAL THEN CONJ_TAC THENL + [MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC `u:A->bool` THEN + ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[]]; + ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + SUBGOAL_THEN `?m:num. (b:A->bool) IN (Bn:num->(A->bool)->bool) m` + (X_CHOOSE_THEN `m:num` ASSUME_TAC) THENL + [UNDISCH_TAC `(b:A->bool) IN B` THEN + ASM_REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `t:(A->bool)->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_TAC `p:num`) ASSUME_TAC)) THEN + FIRST_X_ASSUM SUBST_ALL_TAC THEN + EXISTS_TAC `p:num` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + EXISTS_TAC + `UNIONS {b':A->bool | b' IN (Bn:num->(A->bool)->bool) m /\ + top closure_of b' SUBSET W}` THEN + CONJ_TAC THENL + [EXISTS_TAC `m:num` THEN REWRITE_TAC[]; + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `b:A->bool` THEN ASM_REWRITE_TAC[]]]);; + +(* Normal space from regular + sigma-locally-finite base *) +let NORMAL_SPACE_SIGMA_LOCALLY_FINITE_BASE = prove + (`!top:A topology B. + regular_space top /\ + (!b. b IN B ==> open_in top b) /\ + (!x u. open_in top u /\ x IN u + ==> ?b. b IN B /\ x IN b /\ b SUBSET u) /\ + sigma_locally_finite_in top B + ==> normal_space top`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + REWRITE_TAC[normal_space] THEN + MAP_EVERY X_GEN_TAC [`s:A->bool`; `t:A->bool`] THEN STRIP_TAC THEN + (* Get sigma-LF closure covers for the two complements *) + MP_TAC(ISPECL [`top:A topology`; `B:(A->bool)->bool`; + `topspace top DIFF t:A->bool`] + OPEN_SIGMA_LF_CLOSURE_COVER) THEN + ANTS_TAC THENL + [ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_TOPSPACE] THEN + ASM_MESON_TAC[CLOSED_IN_SUBSET; SET_RULE + `(s:A->bool) SUBSET u /\ DISJOINT s t ==> s SUBSET u DIFF t`]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `U:num->A->bool` STRIP_ASSUME_TAC) THEN + MP_TAC(ISPECL [`top:A topology`; `B:(A->bool)->bool`; + `topspace top DIFF s:A->bool`] + OPEN_SIGMA_LF_CLOSURE_COVER) THEN + ANTS_TAC THENL + [ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_TOPSPACE] THEN + ASM_MESON_TAC[CLOSED_IN_SUBSET; SET_RULE + `(t:A->bool) SUBSET u /\ DISJOINT s t ==> t SUBSET u DIFF s`]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `V:num->A->bool` STRIP_ASSUME_TAC) THEN + (* Abbreviate the shrunk open sets *) + ABBREV_TAC + `U' = \n. (U:num->A->bool) n DIFF + UNIONS (IMAGE (\k. top closure_of ((V:num->A->bool) k)) + (0..n))` THEN + ABBREV_TAC + `V' = \n. (V:num->A->bool) n DIFF + UNIONS (IMAGE (\k. top closure_of ((U:num->A->bool) k)) + (0..n))` THEN + EXISTS_TAC `UNIONS {(U':num->A->bool) n | n IN (:num)}` THEN + EXISTS_TAC `UNIONS {(V':num->A->bool) n | n IN (:num)}` THEN + (* Each shrunk set is open *) + SUBGOAL_THEN `!n. open_in top ((U':num->A->bool) n)` ASSUME_TAC THENL + [GEN_TAC THEN EXPAND_TAC "U'" THEN + MATCH_MP_TAC OPEN_IN_DIFF THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CLOSED_IN_UNIONS THEN + SIMP_TAC[FINITE_IMAGE; FINITE_NUMSEG; FORALL_IN_IMAGE] THEN + REWRITE_TAC[CLOSED_IN_CLOSURE_OF]; + ALL_TAC] THEN + SUBGOAL_THEN `!n. open_in top ((V':num->A->bool) n)` ASSUME_TAC THENL + [GEN_TAC THEN EXPAND_TAC "V'" THEN + MATCH_MP_TAC OPEN_IN_DIFF THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CLOSED_IN_UNIONS THEN + SIMP_TAC[FINITE_IMAGE; FINITE_NUMSEG; FORALL_IN_IMAGE] THEN + REWRITE_TAC[CLOSED_IN_CLOSURE_OF]; + ALL_TAC] THEN + REPEAT CONJ_TAC THENL + [(* open_in top U'' *) + MATCH_MP_TAC OPEN_IN_UNIONS THEN + REWRITE_TAC[FORALL_IN_GSPEC; IN_UNIV] THEN ASM_REWRITE_TAC[]; + (* open_in top V'' *) + MATCH_MP_TAC OPEN_IN_UNIONS THEN + REWRITE_TAC[FORALL_IN_GSPEC; IN_UNIV] THEN ASM_REWRITE_TAC[]; + (* s SUBSET UNIONS U' *) + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN UNIONS {(U:num->A->bool) n | n IN (:num)}` + MP_TAC THENL + [SUBGOAL_THEN `(x:A) IN topspace top DIFF t` MP_TAC THENL + [SUBGOAL_THEN `(x:A) IN topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET; SUBSET]; ALL_TAC] THEN + ASM SET_TAC[]; + ASM SET_TAC[]]; + ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `su:A->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_TAC `m:num`) ASSUME_TAC)) THEN + FIRST_X_ASSUM SUBST_ALL_TAC THEN + EXISTS_TAC `(U':num->A->bool) m` THEN + CONJ_TAC THENL [EXISTS_TAC `m:num` THEN REWRITE_TAC[]; ALL_TAC] THEN + EXPAND_TAC "U'" THEN + REWRITE_TAC[IN_DIFF; IN_UNIONS; IN_IMAGE] THEN + ASM_REWRITE_TAC[] THEN REWRITE_TAC[NOT_EXISTS_THM] THEN + X_GEN_TAC `c:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `k:num` (CONJUNCTS_THEN2 ASSUME_TAC ASSUME_TAC)) + ASSUME_TAC) THEN + FIRST_X_ASSUM SUBST_ALL_TAC THEN + UNDISCH_TAC + `!n:num. top closure_of (V:num->A->bool) n + SUBSET topspace top DIFF s` THEN + DISCH_THEN(MP_TAC o SPEC `k:num`) THEN + REWRITE_TAC[SUBSET; IN_DIFF] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[]; + (* t SUBSET UNIONS V' *) + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN UNIONS {(V:num->A->bool) n | n IN (:num)}` + MP_TAC THENL + [SUBGOAL_THEN `(x:A) IN topspace top DIFF s` MP_TAC THENL + [SUBGOAL_THEN `(x:A) IN topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET; SUBSET]; ALL_TAC] THEN + ASM SET_TAC[]; + ASM SET_TAC[]]; + ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `sv:A->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_TAC `m:num`) ASSUME_TAC)) THEN + FIRST_X_ASSUM SUBST_ALL_TAC THEN + EXISTS_TAC `(V':num->A->bool) m` THEN + CONJ_TAC THENL [EXISTS_TAC `m:num` THEN REWRITE_TAC[]; ALL_TAC] THEN + EXPAND_TAC "V'" THEN + REWRITE_TAC[IN_DIFF; IN_UNIONS; IN_IMAGE] THEN + ASM_REWRITE_TAC[] THEN REWRITE_TAC[NOT_EXISTS_THM] THEN + X_GEN_TAC `c:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `k:num` (CONJUNCTS_THEN2 ASSUME_TAC ASSUME_TAC)) + ASSUME_TAC) THEN + FIRST_X_ASSUM SUBST_ALL_TAC THEN + UNDISCH_TAC + `!n:num. top closure_of (U:num->A->bool) n + SUBSET topspace top DIFF t` THEN + DISCH_THEN(MP_TAC o SPEC `k:num`) THEN + REWRITE_TAC[SUBSET; IN_DIFF] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[]; + (* DISJOINT UNIONS U' UNIONS V' *) + REWRITE_TAC[SET_RULE `DISJOINT s t <=> !x:A. x IN s ==> ~(x IN t)`] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + X_GEN_TAC `x:A` THEN DISCH_THEN(X_CHOOSE_THEN `su:A->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_TAC `m:num`) ASSUME_TAC)) THEN + FIRST_X_ASSUM SUBST_ALL_TAC THEN + REWRITE_TAC[NOT_EXISTS_THM] THEN + X_GEN_TAC `sv:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_TAC `p:num`) ASSUME_TAC) THEN + FIRST_X_ASSUM SUBST_ALL_TAC THEN + (* Now have x IN U' m and x IN V' p, goal is F *) + SUBGOAL_THEN + `(x:A) IN (U:num->A->bool) m /\ + (!k. k IN (0..m) + ==> ~(x IN top closure_of ((V:num->A->bool) k)))` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `(x:A) IN (U':num->A->bool) m` THEN + EXPAND_TAC "U'" THEN + REWRITE_TAC[IN_DIFF; IN_UNIONS; IN_IMAGE; NOT_EXISTS_THM] THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `k:num` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `top closure_of ((V:num->A->bool) k)`) THEN + SUBGOAL_THEN + `?k':num. top closure_of ((V:num->A->bool) k) = + top closure_of (V k') /\ k' IN 0..m` + ASSUME_TAC THENL + [EXISTS_TAC `k:num` THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN + `(x:A) IN (V:num->A->bool) p /\ + (!k. k IN (0..p) + ==> ~(x IN top closure_of ((U:num->A->bool) k)))` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `(x:A) IN (V':num->A->bool) p` THEN + EXPAND_TAC "V'" THEN + REWRITE_TAC[IN_DIFF; IN_UNIONS; IN_IMAGE; NOT_EXISTS_THM] THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `k:num` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `top closure_of ((U:num->A->bool) k)`) THEN + SUBGOAL_THEN + `?k':num. top closure_of ((U:num->A->bool) k) = + top closure_of (U k') /\ k' IN 0..p` + ASSUME_TAC THENL + [EXISTS_TAC `k:num` THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + DISJ_CASES_TAC(SPECL [`m:num`; `p:num`] LE_CASES) THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `m:num`) THEN + REWRITE_TAC[IN_NUMSEG; LE_0] THEN ASM_REWRITE_TAC[] THEN + MP_TAC(ISPECL [`top:A topology`; `(U:num->A->bool) m`] + CLOSURE_OF_SUBSET) THEN + ANTS_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET]; ASM_MESON_TAC[SUBSET]]; + UNDISCH_TAC + `!k. k IN 0..m + ==> ~((x:A) IN top closure_of ((V:num->A->bool) k))` THEN + DISCH_THEN(MP_TAC o SPEC `p:num`) THEN + REWRITE_TAC[IN_NUMSEG; LE_0] THEN ASM_REWRITE_TAC[] THEN + MP_TAC(ISPECL [`top:A topology`; `(V:num->A->bool) p`] + CLOSURE_OF_SUBSET) THEN + ANTS_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET]; ASM_MESON_TAC[SUBSET]]]] + );; + +(* Helper: closed sets are Gdelta in regular spaces with sigma-LF base *) +let CLOSED_GDELTA_IN_SIGMA_LF_BASE = prove + (`!top:A topology B s. + regular_space top /\ + (!b. b IN B ==> open_in top b) /\ + (!x u. open_in top u /\ x IN u + ==> ?b. b IN B /\ x IN b /\ b SUBSET u) /\ + sigma_locally_finite_in top B /\ + closed_in top s + ==> gdelta_in top s`, + REPEAT STRIP_TAC THEN + MP_TAC(ISPECL [`top:A topology`; `B:(A->bool)->bool`; + `topspace top DIFF s:A->bool`] + OPEN_SIGMA_LF_CLOSURE_COVER) THEN + ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_TOPSPACE] THEN + DISCH_THEN(X_CHOOSE_THEN `En:num->A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN + `s:A->bool = + INTERS {topspace top DIFF top closure_of (En n) | n IN (:num)}` + SUBST1_TAC THENL + [REWRITE_TAC[EXTENSION; IN_INTERS; FORALL_IN_GSPEC; IN_UNIV; IN_DIFF] THEN + X_GEN_TAC `x:A` THEN EQ_TAC THENL + [(* Forward: x IN s ==> x IN all topspace\cl(En n) *) + DISCH_TAC THEN X_GEN_TAC `n:num` THEN CONJ_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET; SUBSET]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `n:num` o + REWRITE_RULE[SUBSET]) THEN + ASM SET_TAC[]; + (* Backward: x IN all topspace\cl(En n) ==> x IN s *) + DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN topspace top` ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `0`) THEN SET_TAC[]; ALL_TAC] THEN + (* Proof by contradiction *) + MATCH_MP_TAC(TAUT `(~p ==> F) ==> p`) THEN DISCH_TAC THEN + (* Goal: F. Have ~(x IN s), x IN topspace *) + SUBGOAL_THEN `?m:num. (x:A) IN (En:num->A->bool) m` + STRIP_ASSUME_TAC THENL + [SUBGOAL_THEN `(x:A) IN UNIONS {(En:num->A->bool) n | n IN (:num)}` + MP_TAC THENL + [UNDISCH_TAC + `topspace top DIFF s SUBSET + UNIONS {(En:num->A->bool) n | n IN (:num)}` THEN + ASM SET_TAC[]; + SET_TAC[]]; + ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `m:num`) THEN + MP_TAC(ISPECL [`top:A topology`; `(En:num->A->bool) m`] + CLOSURE_OF_SUBSET) THEN + ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET; IN_INTER; IN_DIFF]]; + ALL_TAC] THEN + MATCH_MP_TAC GDELTA_IN_INTERS THEN + SIMP_TAC[SIMPLE_IMAGE; COUNTABLE_IMAGE; NUM_COUNTABLE] THEN + REWRITE_TAC[IMAGE_EQ_EMPTY; FORALL_IN_IMAGE; UNIV_NOT_EMPTY; IN_UNIV] THEN + X_GEN_TAC `n:num` THEN MATCH_MP_TAC OPEN_IMP_GDELTA_IN THEN + MATCH_MP_TAC OPEN_IN_DIFF THEN + REWRITE_TAC[OPEN_IN_TOPSPACE; CLOSED_IN_CLOSURE_OF]);; + +(* Munkres Lemma 40.2: In a normal space, a closed Gdelta set is a zero set. + More precisely: there exists continuous f:[0,1] with f=0 on s, f>0 off s *) +let URYSOHN_FUNCTION_CLOSED_GDELTA = prove + (`!top:A topology s. + normal_space top /\ closed_in top s /\ gdelta_in top s + ==> ?f. continuous_map(top, euclideanreal) f /\ + (!x. x IN topspace top ==> &0 <= f x /\ f x <= &1) /\ + (!x. x IN s ==> f x = &0) /\ + (!x. x IN topspace top DIFF s ==> &0 < f x)`, + REPEAT STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GDELTA_IN_DESCENDING]) THEN + DISCH_THEN(X_CHOOSE_THEN `c:num->A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(s:A->bool) SUBSET topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET]; ALL_TAC] THEN + SUBGOAL_THEN `!n:num. (s:A->bool) SUBSET (c:num->A->bool) n` ASSUME_TAC THENL + [GEN_TAC THEN FIRST_ASSUM(SUBST1_TAC o SYM) THEN + REWRITE_TAC[SUBSET; IN_INTERS; FORALL_IN_GSPEC; IN_UNIV] THEN + MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN + `?h:num->A->real. + (!n. continuous_map(top, euclideanreal) (h n)) /\ + (!n x:A. x IN topspace top ==> &0 <= h n x /\ h n x <= &1) /\ + (!n x:A. x IN s ==> h n x = &0) /\ + (!n x:A. x IN topspace top DIFF (c:num->A->bool) n ==> h n x = &1)` + STRIP_ASSUME_TAC THENL + [SUBGOAL_THEN + `!n:num. ?f:A->real. + continuous_map(top, euclideanreal) f /\ + (!x. x IN topspace top ==> &0 <= f x /\ f x <= &1) /\ + (!x. x IN s ==> f x = &0) /\ + (!x. x IN topspace top DIFF (c:num->A->bool) n ==> f x = &1)` + MP_TAC THENL + [X_GEN_TAC `n:num` THEN + MP_TAC(ISPECL [`top:A topology`; `s:A->bool`; + `topspace top DIFF (c:num->A->bool) n`; + `&0`; `&1`] URYSOHN_LEMMA) THEN + ANTS_TAC THENL + [ASM_SIMP_TAC[REAL_POS; CLOSED_IN_DIFF; CLOSED_IN_TOPSPACE] THEN + ASM SET_TAC[]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `f:A->real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `f:A->real` THEN + CONJ_TAC THENL + [FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [CONTINUOUS_MAP_IN_SUBTOPOLOGY]) THEN + SIMP_TAC[]; + ALL_TAC] THEN + CONJ_TAC THENL + [X_GEN_TAC `y:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(f:A->real) y IN real_interval[&0,&1]` MP_TAC THENL + [FIRST_ASSUM(MP_TAC o + CONJUNCT2 o GEN_REWRITE_RULE I [CONTINUOUS_MAP_IN_SUBTOPOLOGY]) THEN + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE] THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[IN_REAL_INTERVAL]]; + ASM_MESON_TAC[]]; + ALL_TAC] THEN + REWRITE_TAC[SKOLEM_THM] THEN MESON_TAC[]; + ALL_TAC] THEN + (* Apply CONTINUOUS_MAP_UNIFORMLY_CAUCHY_LIMIT to partial sums *) + MP_TAC(ISPECL + [`top:A topology`; `real_euclidean_metric`; + `(\n (x:A). sum(0..n) (\k. (h:num->A->real) k x * + inv(&2 pow (k + 1))))`] + CONTINUOUS_MAP_UNIFORMLY_CAUCHY_LIMIT) THEN + ASM_REWRITE_TAC[TRIVIAL_LIMIT_SEQUENTIALLY; MCOMPLETE_REAL_EUCLIDEAN_METRIC; + MTOPOLOGY_REAL_EUCLIDEAN_METRIC] THEN + ANTS_TAC THENL + [(* Two conditions: eventually continuous, and Cauchy *) + CONJ_TAC THENL + [(* Eventually continuous: each partial sum is continuous *) + REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN EXISTS_TAC `0` THEN + REPEAT STRIP_TAC THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + MATCH_MP_TAC CONTINUOUS_MAP_SUM THEN + REWRITE_TAC[FINITE_NUMSEG] THEN REPEAT STRIP_TAC THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + MATCH_MP_TAC CONTINUOUS_MAP_REAL_RMUL THEN + REWRITE_TAC[ETA_AX] THEN ASM_REWRITE_TAC[]; + (* Cauchy condition: partial sums form a uniform Cauchy sequence *) + REWRITE_TAC[REAL_EUCLIDEAN_METRIC] THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + X_GEN_TAC `e:real` THEN DISCH_TAC THEN + MP_TAC(ISPECL [`inv(&2)`; `e:real`] REAL_ARCH_POW_INV) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN CONV_TAC REAL_RAT_REDUCE_CONV; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_TAC `N:num`) THEN EXISTS_TAC `N:num` THEN + SUBGOAL_THEN + `!a b. sum(a..b) (\k. inv(&2) pow (k + 1)) <= inv(&2) pow a` + ASSUME_TAC THENL + [REPEAT GEN_TAC THEN + SUBGOAL_THEN + `(\k. inv(&2) pow (k + 1)) = + (\k. inv(&2) pow k - inv(&2) pow (k + 1))` + SUBST1_TAC THENL + [REWRITE_TAC[FUN_EQ_THM] THEN GEN_TAC THEN + REWRITE_TAC[GSYM ADD1; real_pow] THEN CONV_TAC REAL_FIELD; + REWRITE_TAC[SUM_DIFFS] THEN COND_CASES_TAC THENL + [MATCH_MP_TAC(REAL_ARITH `&0 <= y ==> x - y <= x`) THEN + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV; + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV]]; + ALL_TAC] THEN + MATCH_MP_TAC WLOG_LT THEN + ASM_REWRITE_TAC[REAL_SUB_REFL; REAL_ABS_NUM] THEN + CONJ_TAC THENL + [MESON_TAC[REAL_ABS_SUB]; ALL_TAC] THEN + MAP_EVERY X_GEN_TAC [`m':num`; `q:num`] THEN DISCH_TAC THEN + X_GEN_TAC `y:A` THEN STRIP_TAC THEN + (* Express difference as partial sum over (m'+1..q) *) + SUBGOAL_THEN + `sum(0..q) (\k. (h:num->A->real) k y * inv (&2 pow (k + 1))) - + sum(0..m') (\k. h k y * inv (&2 pow (k + 1))) = + sum(m'+1..q) (\k. h k y * inv (&2 pow (k + 1)))` + SUBST1_TAC THENL + [MATCH_MP_TAC(REAL_ARITH `a + b = c ==> c - a = b`) THEN + MATCH_MP_TAC SUM_COMBINE_R THEN ASM_ARITH_TAC; + ALL_TAC] THEN + (* The sum is non-negative, so abs = identity *) + SUBGOAL_THEN + `&0 <= sum(m'+1..q) + (\k. (h:num->A->real) k y * inv (&2 pow (k + 1)))` + (fun th -> REWRITE_TAC[MATCH_MP + (REAL_ARITH `&0 <= x ==> abs x = x`) th]) THENL + [MATCH_MP_TAC SUM_POS_LE_NUMSEG THEN REPEAT STRIP_TAC THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC THENL + [ASM_MESON_TAC[]; + MATCH_MP_TAC REAL_LE_INV THEN + MATCH_MP_TAC REAL_POW_LE THEN REAL_ARITH_TAC]; + ALL_TAC] THEN + (* Chain: sum <= geom_sum <= inv(2)^(m'+1) <= inv(2)^N < e *) + TRANS_TAC REAL_LET_TRANS `inv(&2) pow N` THEN + CONJ_TAC THENL + [TRANS_TAC REAL_LE_TRANS `inv(&2) pow (m' + 1)` THEN + CONJ_TAC THENL + [TRANS_TAC REAL_LE_TRANS + `sum(m'+1..q) (\k. inv(&2) pow (k + 1))` THEN + CONJ_TAC THENL + [(* Each term: h k y * inv(2^(k+1)) <= inv(2)^(k+1) *) + MATCH_MP_TAC SUM_LE_NUMSEG THEN X_GEN_TAC `k:num` THEN + STRIP_TAC THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + REWRITE_TAC[REAL_INV_POW] THEN + GEN_REWRITE_TAC RAND_CONV [GSYM REAL_MUL_LID] THEN + MATCH_MP_TAC REAL_LE_RMUL THEN CONJ_TAC THENL + [ASM_MESON_TAC[]; + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV]; + (* Geometric sum <= inv(2)^(m'+1): use helper *) + ASM_MESON_TAC[]]; + (* inv(2)^(m'+1) <= inv(2)^N by monotonicity *) + MATCH_MP_TAC REAL_POW_MONO_INV THEN + CONV_TAC REAL_RAT_REDUCE_CONV THEN ASM_ARITH_TAC]; + ASM_MESON_TAC[]]]; + ALL_TAC] THEN + REWRITE_TAC[REAL_EUCLIDEAN_METRIC] THEN + DISCH_THEN(X_CHOOSE_THEN `g:A->real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `g:A->real` THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL + [(* Part 1: g bounded in [0,1] *) + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + CONJ_TAC THENL + [(* g x >= 0: contradiction if g x < 0 *) + SUBGOAL_THEN `~((g:A->real) x < &0)` + (fun th -> MP_TAC th THEN REAL_ARITH_TAC) THEN + DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o SPEC `--((g:A->real) x)`) THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN + DISCH_THEN(X_CHOOSE_THEN `M:num` (MP_TAC o SPEC `M:num`)) THEN + REWRITE_TAC[LE_REFL] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + (* Need: partial sum >= 0 *) + SUBGOAL_THEN + `&0 <= sum(0..M) + (\k. (h:num->A->real) k x * inv(&2 pow (k + 1)))` + (fun th -> MP_TAC th THEN ASM_REAL_ARITH_TAC) THEN + MATCH_MP_TAC SUM_POS_LE_NUMSEG THEN X_GEN_TAC `i:num` THEN + STRIP_TAC THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC THENL + [ASM_MESON_TAC[]; + MATCH_MP_TAC REAL_LE_INV THEN + MATCH_MP_TAC REAL_POW_LE THEN REAL_ARITH_TAC]; + (* g x <= 1: contradiction if g x > 1 *) + SUBGOAL_THEN `~(&1 < (g:A->real) x)` + (fun th -> MP_TAC th THEN REAL_ARITH_TAC) THEN + DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o SPEC `(g:A->real) x - &1`) THEN + ANTS_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN + DISCH_THEN(X_CHOOSE_THEN `M:num` (MP_TAC o SPEC `M:num`)) THEN + REWRITE_TAC[LE_REFL] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + (* Need: partial sum <= 1 *) + SUBGOAL_THEN + `sum(0..M) (\k. (h:num->A->real) k x * inv(&2 pow (k + 1))) <= &1` + (fun th -> MP_TAC th THEN ASM_REAL_ARITH_TAC) THEN + TRANS_TAC REAL_LE_TRANS + `sum(0..M) (\k. inv(&2) pow (k + 1))` THEN + CONJ_TAC THENL + [MATCH_MP_TAC SUM_LE_NUMSEG THEN X_GEN_TAC `i:num` THEN + STRIP_TAC THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + REWRITE_TAC[REAL_INV_POW] THEN + GEN_REWRITE_TAC RAND_CONV [GSYM REAL_MUL_LID] THEN + MATCH_MP_TAC REAL_LE_RMUL THEN CONJ_TAC THENL + [ASM_MESON_TAC[]; + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV]; + SUBGOAL_THEN + `(\k. inv(&2) pow (k + 1)) = + (\k. inv(&2) pow k - inv(&2) pow (k + 1))` + SUBST1_TAC THENL + [REWRITE_TAC[FUN_EQ_THM] THEN GEN_TAC THEN + REWRITE_TAC[GSYM ADD1; real_pow] THEN CONV_TAC REAL_FIELD; + REWRITE_TAC[SUM_DIFFS] THEN COND_CASES_TAC THENL + [REWRITE_TAC[real_pow] THEN + MATCH_MP_TAC(REAL_ARITH `&0 <= y ==> &1 - y <= &1`) THEN + MATCH_MP_TAC REAL_POW_LE THEN CONV_TAC REAL_RAT_REDUCE_CONV; + CONV_TAC REAL_RAT_REDUCE_CONV]]]]; + ALL_TAC] THEN + CONJ_TAC THENL + [(* Part 2: g = 0 on s *) + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN topspace top` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `!n. sum(0..n) (\k. (h:num->A->real) k x * inv(&2 pow (k+1))) = &0` + ASSUME_TAC THENL + [GEN_TAC THEN MATCH_MP_TAC SUM_EQ_0_NUMSEG THEN + X_GEN_TAC `i:num` THEN STRIP_TAC THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN + SUBGOAL_THEN `(h:num->A->real) i x = &0` SUBST1_TAC THENL + [ASM_MESON_TAC[]; REWRITE_TAC[REAL_MUL_LZERO]]; + ALL_TAC] THEN + SUBGOAL_THEN `~(&0 < abs((g:A->real) x))` + (fun th -> ASM_MESON_TAC[th; + REAL_ARITH `~(&0 < abs x) ==> x = &0`]) THEN + DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o SPEC `abs((g:A->real) x)`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN + DISCH_THEN(X_CHOOSE_THEN `M:num` (MP_TAC o SPEC `M:num`)) THEN + REWRITE_TAC[LE_REFL] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN + ASM_REWRITE_TAC[REAL_SUB_RZERO] THEN ASM_REAL_ARITH_TAC; + (* Part 3: g > 0 on complement of s *) + X_GEN_TAC `x:A` THEN REWRITE_TAC[IN_DIFF] THEN STRIP_TAC THEN + (* x not in s = INTERS{c n}, so there exists n0 with x not in c(n0) *) + SUBGOAL_THEN `?n0:num. ~((x:A) IN c n0)` STRIP_ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + (* h(n0)(x) = 1 *) + SUBGOAL_THEN `(h:num->A->real) n0 x = &1` ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPECL [`n0:num`; `x:A`]) THEN + ASM_REWRITE_TAC[IN_DIFF]; ALL_TAC] THEN + (* For n >= n0, partial sum >= inv(2^(n0+1)) *) + SUBGOAL_THEN + `!n. n0 <= n ==> + inv(&2 pow (n0 + 1)) <= + sum(0..n) (\k. (h:num->A->real) k x * inv(&2 pow (k + 1)))` + ASSUME_TAC THENL + [X_GEN_TAC `n:num` THEN DISCH_TAC THEN + TRANS_TAC REAL_LE_TRANS + `sum {n0} (\k. (h:num->A->real) k x * inv(&2 pow (k + 1)))` THEN + CONJ_TAC THENL + [REWRITE_TAC[SUM_SING] THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + ASM_REWRITE_TAC[REAL_MUL_LID; REAL_LE_REFL]; + MATCH_MP_TAC SUM_SUBSET_SIMPLE THEN + REWRITE_TAC[FINITE_NUMSEG] THEN CONJ_TAC THENL + [REWRITE_TAC[SUBSET; IN_SING; IN_NUMSEG] THEN ASM_ARITH_TAC; + X_GEN_TAC `j:num` THEN REWRITE_TAC[IN_DIFF; IN_NUMSEG; IN_SING] THEN + STRIP_TAC THEN CONV_TAC(DEPTH_CONV BETA_CONV) THEN + MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC THENL + [ASM_MESON_TAC[]; + MATCH_MP_TAC REAL_LE_INV THEN + MATCH_MP_TAC REAL_POW_LE THEN REAL_ARITH_TAC]]]; + ALL_TAC] THEN + (* Contradiction: assume g(x) <= 0 *) + SUBGOAL_THEN `~((g:A->real) x <= &0)` + (fun th -> MP_TAC th THEN REAL_ARITH_TAC) THEN + DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o SPEC `inv(&2 pow (n0 + 1))`) THEN + ANTS_TAC THENL + [MATCH_MP_TAC REAL_LT_INV THEN + MATCH_MP_TAC REAL_POW_LT THEN REAL_ARITH_TAC; ALL_TAC] THEN + REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN + DISCH_THEN(X_CHOOSE_THEN `M:num` ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `M + n0:num`) THEN + REWRITE_TAC[LE_ADD] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `M + n0:num`) THEN + REWRITE_TAC[LE_ADDR] THEN + DISCH_TAC THEN ASM_REAL_ARITH_TAC]);; + +(* Nagata-Smirnov metrization (hard direction): + regular Hausdorff + sigma-locally-finite base => metrizable *) +let NAGATA_SMIRNOV_METRIZATION = prove + (`!top:A topology. + regular_space top /\ hausdorff_space top /\ + (?B. (!b. b IN B ==> open_in top b) /\ + (!x u. open_in top u /\ x IN u + ==> ?b. b IN B /\ x IN b /\ b SUBSET u) /\ + sigma_locally_finite_in top B) + ==> metrizable_space top`, + let REAL_OPEN_ABS_LT = prove + (`!a:real d. &0 < d ==> real_open {t | abs(t - a) < d}`, + REPEAT STRIP_TAC THEN REWRITE_TAC[real_open; IN_ELIM_THM] THEN + X_GEN_TAC `t0:real` THEN DISCH_TAC THEN + EXISTS_TAC `d - abs(t0 - a)` THEN + CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC] THEN + X_GEN_TAC `t':real` THEN ASM_REAL_ARITH_TAC) in + GEN_TAC THEN STRIP_TAC THEN + (* Handle empty topspace *) + ASM_CASES_TAC `topspace top:A->bool = {}` THENL + [SUBGOAL_THEN `top:A topology = discrete_topology ({}:A->bool)` + (fun th -> REWRITE_TAC[th; METRIZABLE_SPACE_DISCRETE_TOPOLOGY]) THEN + REWRITE_TAC[TOPOLOGY_EQ; OPEN_IN_DISCRETE_TOPOLOGY; SUBSET_EMPTY] THEN + GEN_TAC THEN EQ_TAC THENL + [DISCH_THEN(MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN ASM SET_TAC[]; + DISCH_THEN SUBST1_TAC THEN REWRITE_TAC[OPEN_IN_EMPTY]]; + ALL_TAC] THEN + (* Unfold sigma-LF to get Bn decomposition *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [sigma_locally_finite_in]) THEN + DISCH_THEN(X_CHOOSE_THEN `Bn:num->(A->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Reconstruct sigma_locally_finite_in for later use *) + SUBGOAL_THEN `sigma_locally_finite_in top (B:(A->bool)->bool)` + ASSUME_TAC THENL + [REWRITE_TAC[sigma_locally_finite_in] THEN + EXISTS_TAC `Bn:num->(A->bool)->bool` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Show normality *) + SUBGOAL_THEN `normal_space (top:A topology)` ASSUME_TAC THENL + [MATCH_MP_TAC NORMAL_SPACE_SIGMA_LOCALLY_FINITE_BASE THEN + EXISTS_TAC `B:(A->bool)->bool` THEN + REPEAT CONJ_TAC THEN FIRST_ASSUM ACCEPT_TAC; + ALL_TAC] THEN + (* Show closed sets are G_delta *) + SUBGOAL_THEN `!s:A->bool. closed_in top s ==> gdelta_in top s` + ASSUME_TAC THENL + [GEN_TAC THEN DISCH_TAC THEN + MATCH_MP_TAC CLOSED_GDELTA_IN_SIGMA_LF_BASE THEN + EXISTS_TAC `B:(A->bool)->bool` THEN + REPEAT CONJ_TAC THEN FIRST_ASSUM ACCEPT_TAC; + ALL_TAC] THEN + (* Construct separating functions: for each b IN B, get g_b *) + SUBGOAL_THEN + `!b:A->bool. b IN B ==> + ?f. continuous_map(top, euclideanreal) f /\ + (!x. x IN topspace top ==> &0 <= f x /\ f x <= &1) /\ + (!x. x IN topspace top /\ ~(x IN b) ==> f x = &0) /\ + (!x. x IN b ==> &0 < f x)` + MP_TAC THENL + [X_GEN_TAC `b:A->bool` THEN DISCH_TAC THEN + SUBGOAL_THEN `open_in top (b:A->bool)` ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(b:A->bool) SUBSET topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET]; ALL_TAC] THEN + MP_TAC(ISPECL [`top:A topology`; `topspace top DIFF b:A->bool`] + URYSOHN_FUNCTION_CLOSED_GDELTA) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [MATCH_MP_TAC CLOSED_IN_DIFF THEN + ASM_REWRITE_TAC[CLOSED_IN_TOPSPACE]; + FIRST_X_ASSUM MATCH_MP_TAC THEN + MATCH_MP_TAC CLOSED_IN_DIFF THEN + ASM_REWRITE_TAC[CLOSED_IN_TOPSPACE]]; + DISCH_THEN(X_CHOOSE_THEN `f:A->real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `f:A->real` THEN ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL + [REWRITE_TAC[GSYM IN_DIFF] THEN FIRST_ASSUM ACCEPT_TAC; + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + UNDISCH_TAC + `!x:A. x IN topspace top DIFF (topspace top DIFF b) ==> &0 < f x` THEN + DISCH_THEN MATCH_MP_TAC THEN + UNDISCH_TAC `(x:A) IN b` THEN + UNDISCH_TAC `(b:A->bool) SUBSET topspace top` THEN + SET_TAC[]]]; + ALL_TAC] THEN + REWRITE_TAC[RIGHT_IMP_EXISTS_THM; SKOLEM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `g:(A->bool)->A->real` STRIP_ASSUME_TAC) THEN + (* Now: g b continuous, [0,1]-valued, g b = 0 off b, g b > 0 on b *) + (* Show B is nonempty *) + SUBGOAL_THEN `~(B:(A->bool)->bool = {})` ASSUME_TAC THENL + [REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + DISCH_THEN(X_CHOOSE_TAC `a:A`) THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`a:A`; `topspace top:A->bool`]) THEN + REWRITE_TAC[OPEN_IN_TOPSPACE] THEN + ANTS_TAC THENL [FIRST_ASSUM ACCEPT_TAC; MESON_TAC[]]; + ALL_TAC] THEN + (* Define the embedding into funspace *) + ABBREV_TAC + `J = {(n:num,b:A->bool) | b IN Bn n}` THEN + (* J is nonempty since B = UNIONS{Bn n} is nonempty *) + SUBGOAL_THEN `~(J:num#(A->bool)->bool = {})` ASSUME_TAC THENL + [EXPAND_TAC "J" THEN REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + SUBGOAL_THEN `?n0:num (b0:A->bool). b0 IN Bn n0` MP_TAC THENL + [UNDISCH_TAC `~(B:(A->bool)->bool = {})` THEN + UNDISCH_TAC `B = UNIONS {(Bn:num->(A->bool)->bool) n | n IN (:num)}` THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + DISCH_THEN SUBST1_TAC THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN MESON_TAC[]; + REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`n0:num`; `b0:A->bool`] THEN DISCH_TAC THEN + EXISTS_TAC `n0:num,(b0:A->bool)` THEN + EXISTS_TAC `n0:num` THEN EXISTS_TAC `b0:A->bool` THEN + ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + (* Step: Introduce the distance function (uncurried for is_metric_space) *) + SUBGOAL_THEN + `?d:A#A->real. !x y. + d(x,y) = sup {abs(g (b:A->bool) x * inv(&(SUC n)) - + g b y * inv(&(SUC n))) | + n,b | b IN Bn n}` + (X_CHOOSE_TAC `d:A#A->real`) THENL + [EXISTS_TAC `\p:A#A. + sup {abs(g (b:A->bool) (FST p) * inv(&(SUC n)) - + g b (SND p) * inv(&(SUC n))) | + n,b | b IN Bn n}` THEN + CONV_TAC(DEPTH_CONV BETA_CONV) THEN REWRITE_TAC[FST; SND]; + ALL_TAC] THEN + (* Step: The sup set is always nonempty *) + SUBGOAL_THEN + `!x:A y:A. + ~({abs(g (b:A->bool) x * inv(&(SUC n)) - + g b y * inv(&(SUC n))) | + n,b | b IN Bn n} = {})` + ASSUME_TAC THENL + [REPEAT GEN_TAC THEN REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + UNDISCH_TAC `~(J:num#(A->bool)->bool = {})` THEN + EXPAND_TAC "J" THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + MESON_TAC[]; + ALL_TAC] THEN + (* Helper: b IN Bn n ==> b IN B *) + SUBGOAL_THEN `!n:num (b:A->bool). b IN Bn n ==> b IN B` ASSUME_TAC THENL + [REPEAT STRIP_TAC THEN + UNDISCH_TAC `B = UNIONS {(Bn:num->(A->bool)->bool) n | n IN (:num)}` THEN + DISCH_THEN SUBST1_TAC THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + EXISTS_TAC `(Bn:num->(A->bool)->bool) n` THEN + CONJ_TAC THENL + [EXISTS_TAC `n:num` THEN REFL_TAC; + FIRST_ASSUM ACCEPT_TAC]; + ALL_TAC] THEN + (* Helper: extract g bounds for easier use *) + SUBGOAL_THEN + `!b:A->bool x:A. + b IN B /\ x IN topspace top ==> &0 <= g b x /\ g b x <= &1` + ASSUME_TAC THENL + [REPEAT GEN_TAC THEN STRIP_TAC THEN + UNDISCH_TAC `!b:A->bool. b IN B + ==> continuous_map(top,euclideanreal) (g b) /\ + (!x. x IN topspace top ==> &0 <= g b x /\ g b x <= &1) /\ + (!x. x IN topspace top /\ ~(x IN b) ==> g b x = &0) /\ + (!x. x IN b ==> &0 < g b x)` THEN + DISCH_THEN(MP_TAC o SPEC `b:A->bool`) THEN + ANTS_TAC THENL [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + DISCH_THEN(MP_TAC o CONJUNCT1 o CONJUNCT2) THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN + ANTS_TAC THENL [FIRST_ASSUM ACCEPT_TAC; DISCH_THEN ACCEPT_TAC]; + ALL_TAC] THEN + (* Step: The sup set is bounded above by &1 for x,y in topspace *) + SUBGOAL_THEN + `!x:A y:A z. + x IN topspace top /\ y IN topspace top /\ + z IN {abs(g (b:A->bool) x * inv(&(SUC n)) - + g b y * inv(&(SUC n))) | + n,b | b IN Bn n} + ==> z <= &1` + ASSUME_TAC THENL + [REWRITE_TAC[IN_ELIM_THM] THEN REPEAT GEN_TAC THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `n':num` (X_CHOOSE_THEN `b':A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST1_TAC))))) THEN + MATCH_MP_TAC(REAL_ARITH + `&0 <= u /\ u <= &1 /\ &0 <= v /\ v <= &1 ==> abs(u - v) <= &1`) THEN + SUBGOAL_THEN `(b':A->bool) IN B` ASSUME_TAC THENL + [UNDISCH_TAC `!n:num (b:A->bool). b IN Bn n ==> b IN B` THEN + DISCH_THEN(MP_TAC o SPECL [`n':num`; `b':A->bool`]) THEN + ANTS_TAC THENL [FIRST_ASSUM ACCEPT_TAC; DISCH_THEN ACCEPT_TAC]; + ALL_TAC] THEN + SUBGOAL_THEN `&0 <= (g:(A->bool)->A->real) b' x /\ g b' x <= &1` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `!b:A->bool x:A. + b IN B /\ x IN topspace top ==> &0 <= g b x /\ g b x <= &1` THEN + DISCH_THEN(MP_TAC o SPECL [`b':A->bool`; `x:A`]) THEN + ANTS_TAC THENL + [CONJ_TAC THEN FIRST_ASSUM ACCEPT_TAC; DISCH_THEN ACCEPT_TAC]; + ALL_TAC] THEN + SUBGOAL_THEN `&0 <= (g:(A->bool)->A->real) b' y /\ g b' y <= &1` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `!b:A->bool x:A. + b IN B /\ x IN topspace top ==> &0 <= g b x /\ g b x <= &1` THEN + DISCH_THEN(MP_TAC o SPECL [`b':A->bool`; `y:A`]) THEN + ANTS_TAC THENL + [CONJ_TAC THEN FIRST_ASSUM ACCEPT_TAC; DISCH_THEN ACCEPT_TAC]; + ALL_TAC] THEN + SUBGOAL_THEN `&0 <= inv(&(SUC n')) /\ inv(&(SUC n')) <= &1` + STRIP_ASSUME_TAC THENL + [CONJ_TAC THENL + [MATCH_MP_TAC REAL_LE_INV THEN REAL_ARITH_TAC; + MATCH_MP_TAC REAL_INV_LE_1 THEN REWRITE_TAC[REAL_OF_NUM_LE] THEN + ARITH_TAC]; + ALL_TAC] THEN + REPEAT CONJ_TAC THENL + [(* 0 <= g b' x * inv(SUC n') *) + MATCH_MP_TAC REAL_LE_MUL THEN + UNDISCH_TAC `&0 <= (g:(A->bool)->A->real) b' x` THEN + UNDISCH_TAC `&0 <= inv(&(SUC n'))` THEN REAL_ARITH_TAC; + (* g b' x * inv(SUC n') <= 1 *) + MATCH_MP_TAC REAL_LE_TRANS THEN EXISTS_TAC `&1 * &1` THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_LE_MUL2 THEN + UNDISCH_TAC `&0 <= (g:(A->bool)->A->real) b' x` THEN + UNDISCH_TAC `(g:(A->bool)->A->real) b' x <= &1` THEN + UNDISCH_TAC `&0 <= inv(&(SUC n'))` THEN + UNDISCH_TAC `inv(&(SUC n')) <= &1` THEN REAL_ARITH_TAC; + REAL_ARITH_TAC]; + (* 0 <= g b' y * inv(SUC n') *) + MATCH_MP_TAC REAL_LE_MUL THEN + UNDISCH_TAC `&0 <= (g:(A->bool)->A->real) b' y` THEN + UNDISCH_TAC `&0 <= inv(&(SUC n'))` THEN REAL_ARITH_TAC; + (* g b' y * inv(SUC n') <= 1 *) + MATCH_MP_TAC REAL_LE_TRANS THEN EXISTS_TAC `&1 * &1` THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_LE_MUL2 THEN + UNDISCH_TAC `&0 <= (g:(A->bool)->A->real) b' y` THEN + UNDISCH_TAC `(g:(A->bool)->A->real) b' y <= &1` THEN + UNDISCH_TAC `&0 <= inv(&(SUC n'))` THEN + UNDISCH_TAC `inv(&(SUC n')) <= &1` THEN REAL_ARITH_TAC; + REAL_ARITH_TAC]]; + ALL_TAC] THEN + (* Step: is_metric_space -- structured into 4 axioms *) + SUBGOAL_THEN `is_metric_space(topspace top:A->bool, d:A#A->real)` + ASSUME_TAC THENL + [REWRITE_TAC[is_metric_space] THEN REPEAT CONJ_TAC THENL + [(* Non-negativity: d(x,y) >= 0 *) + REPEAT GEN_TAC THEN STRIP_TAC THEN + UNDISCH_TAC `!x:A y:A. d(x,y) = sup {abs(g (b:A->bool) x * + inv(&(SUC n)) - g b y * inv(&(SUC n))) | n,b | b IN Bn n}` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + MATCH_MP_TAC(REAL_ARITH `&0 <= x /\ x <= &1 ==> &0 <= x`) THEN + MATCH_MP_TAC REAL_SUP_BOUNDS THEN CONJ_TAC THENL + [UNDISCH_TAC `!x:A y:A. + ~({abs(g (b:A->bool) x * inv(&(SUC n)) - + g b y * inv(&(SUC n))) | + n,b | b IN Bn n} = {})` THEN + DISCH_THEN(MP_TAC o SPECL [`x:A`; `y:A`]) THEN + DISCH_THEN ACCEPT_TAC; + X_GEN_TAC `w:real` THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `n':num` (X_CHOOSE_THEN `b':A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST1_TAC))) THEN + REWRITE_TAC[REAL_ABS_POS] THEN + UNDISCH_TAC `!x:A y:A z. + x IN topspace top /\ y IN topspace top /\ + z IN {abs(g (b:A->bool) x * inv(&(SUC n)) - + g b y * inv(&(SUC n))) | + n,b | b IN Bn n} + ==> z <= &1` THEN + DISCH_THEN(MP_TAC o SPECL [`x:A`; `y:A`; + `abs((g:(A->bool)->A->real) b' x * inv(&(SUC n')) - + g b' y * inv(&(SUC n')))`]) THEN + ANTS_TAC THENL + [REPEAT CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; + FIRST_ASSUM ACCEPT_TAC; + REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `n':num` THEN EXISTS_TAC `b':A->bool` THEN + CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; REFL_TAC]]; + DISCH_THEN ACCEPT_TAC]]; + (* Identity: d(x,y) = 0 <=> x = y *) + REPEAT GEN_TAC THEN STRIP_TAC THEN EQ_TAC THENL + [(* Forward: d(x,y) = 0 ==> x = y *) + DISCH_TAC THEN + ASM_CASES_TAC `x:A = y` THENL + [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + SUBGOAL_THEN `&0 < (d:A#A->real)(x,y)` (fun th -> + MP_TAC th THEN UNDISCH_TAC `(d:A#A->real)(x,y) = &0` THEN + REAL_ARITH_TAC) THEN + UNDISCH_TAC `!x:A y:A. d(x,y) = sup {abs(g (b:A->bool) x * + inv(&(SUC n)) - g b y * inv(&(SUC n))) | n,b | b IN Bn n}` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + (* Goal: 0 < sup{...} -- find separating base element *) + UNDISCH_TAC `!x:A u. open_in top u /\ x IN u ==> + ?b. b IN B /\ x IN b /\ b SUBSET u` THEN + DISCH_THEN(MP_TAC o SPECL [`x:A`; `topspace top DIFF {y:A}`]) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_DIFF THEN REWRITE_TAC[OPEN_IN_TOPSPACE] THEN + MATCH_MP_TAC CLOSED_IN_HAUSDORFF_SING THEN + CONJ_TAC THEN FIRST_ASSUM ACCEPT_TAC; + REWRITE_TAC[IN_DIFF; IN_SING] THEN + CONJ_TAC THEN FIRST_ASSUM ACCEPT_TAC]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `b0:A->bool` STRIP_ASSUME_TAC) THEN + (* ~(y IN b0) *) + SUBGOAL_THEN `~((y:A) IN b0)` ASSUME_TAC THENL + [UNDISCH_TAC `(b0:A->bool) SUBSET topspace top DIFF {y:A}` THEN + SET_TAC[]; + ALL_TAC] THEN + (* b0 IN Bn n0 for some n0 *) + SUBGOAL_THEN `?n0:num. (b0:A->bool) IN Bn n0` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `(b0:A->bool) IN B` THEN + UNDISCH_TAC `B = UNIONS {(Bn:num->(A->bool)->bool) n | n IN (:num)}` THEN + DISCH_THEN SUBST1_TAC THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `s:(A->bool)->bool` + (CONJUNCTS_THEN2 + (X_CHOOSE_THEN `m:num` ASSUME_TAC) ASSUME_TAC)) THEN + FIRST_X_ASSUM SUBST_ALL_TAC THEN + EXISTS_TAC `m:num` THEN FIRST_ASSUM ACCEPT_TAC; + ALL_TAC] THEN + (* Extract g properties for b0 *) + UNDISCH_TAC `!b:A->bool. b IN B ==> + continuous_map(top,euclideanreal) (g b) /\ + (!x. x IN topspace top ==> &0 <= g b x /\ g b x <= &1) /\ + (!x. x IN topspace top /\ ~(x IN b) ==> g b x = &0) /\ + (!x. x IN b ==> &0 < g b x)` THEN + DISCH_THEN(MP_TAC o SPEC `b0:A->bool`) THEN + ANTS_TAC THENL [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + DISCH_THEN(CONJUNCTS_THEN2 (K ALL_TAC) + (CONJUNCTS_THEN2 (K ALL_TAC) + (CONJUNCTS_THEN2 ASSUME_TAC ASSUME_TAC))) THEN + (* g(b0)(x) > 0 *) + SUBGOAL_THEN `&0 < (g:(A->bool)->A->real) b0 x` ASSUME_TAC THENL + [UNDISCH_TAC `!x:A. x IN b0 ==> &0 < (g:(A->bool)->A->real) b0 x` THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN + ANTS_TAC THENL [FIRST_ASSUM ACCEPT_TAC; DISCH_THEN ACCEPT_TAC]; + ALL_TAC] THEN + (* g(b0)(y) = 0 *) + SUBGOAL_THEN `(g:(A->bool)->A->real) b0 y = &0` ASSUME_TAC THENL + [UNDISCH_TAC + `!x:A. x IN topspace top /\ ~(x IN b0) ==> + (g:(A->bool)->A->real) b0 x = &0` THEN + DISCH_THEN(MP_TAC o SPEC `y:A`) THEN + ANTS_TAC THENL + [CONJ_TAC THEN FIRST_ASSUM ACCEPT_TAC; DISCH_THEN ACCEPT_TAC]; + ALL_TAC] THEN + (* 0 < g b0 x * inv(SUC n0) and this element is in the sup set *) + MATCH_MP_TAC REAL_LTE_TRANS THEN + EXISTS_TAC `(g:(A->bool)->A->real) b0 x * inv(&(SUC n0))` THEN + CONJ_TAC THENL + [(* 0 < g b0 x * inv(SUC n0) *) + MATCH_MP_TAC REAL_LT_MUL THEN CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; + MATCH_MP_TAC REAL_LT_INV THEN + REWRITE_TAC[REAL_OF_NUM_LT] THEN ARITH_TAC]; + (* g b0 x * inv(SUC n0) <= sup{...} *) + SUBGOAL_THEN + `(g:(A->bool)->A->real) b0 x * inv(&(SUC n0)) = + abs(g b0 x * inv(&(SUC n0)) - g b0 y * inv(&(SUC n0)))` + SUBST1_TAC THENL + [UNDISCH_TAC `(g:(A->bool)->A->real) b0 y = &0` THEN + DISCH_THEN SUBST1_TAC THEN + REWRITE_TAC[REAL_MUL_LZERO; REAL_SUB_RZERO] THEN + CONV_TAC SYM_CONV THEN REWRITE_TAC[REAL_ABS_REFL] THEN + MATCH_MP_TAC REAL_LE_MUL THEN CONJ_TAC THENL + [UNDISCH_TAC `&0 < (g:(A->bool)->A->real) b0 x` THEN + REAL_ARITH_TAC; + MATCH_MP_TAC REAL_LE_INV THEN REAL_ARITH_TAC]; + ALL_TAC] THEN + (* abs(...) <= sup{...} via ELEMENT_LE_SUP *) + MATCH_MP_TAC ELEMENT_LE_SUP THEN CONJ_TAC THENL + [(* bounded above *) + EXISTS_TAC `&1` THEN + X_GEN_TAC `w:real` THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `n':num` (X_CHOOSE_THEN `b':A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST1_TAC))) THEN + UNDISCH_TAC `!x:A y:A z. + x IN topspace top /\ y IN topspace top /\ + z IN {abs(g (b:A->bool) x * inv(&(SUC n)) - + g b y * inv(&(SUC n))) | + n,b | b IN Bn n} + ==> z <= &1` THEN + DISCH_THEN(MP_TAC o SPECL [`x:A`; `y:A`; + `abs((g:(A->bool)->A->real) b' x * inv(&(SUC n')) - + g b' y * inv(&(SUC n')))`]) THEN + ANTS_TAC THENL + [REPEAT CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; + FIRST_ASSUM ACCEPT_TAC; + REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `n':num` THEN EXISTS_TAC `b':A->bool` THEN + CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; REFL_TAC]]; + DISCH_THEN ACCEPT_TAC]; + (* element IN S *) + REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `n0:num` THEN EXISTS_TAC `b0:A->bool` THEN + CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; REFL_TAC]]]; + (* Backward: x = y ==> d(x,y) = 0 *) + DISCH_THEN SUBST1_TAC THEN + UNDISCH_TAC `!x:A y:A. d(x,y) = sup {abs(g (b:A->bool) x * + inv(&(SUC n)) - g b y * inv(&(SUC n))) | n,b | b IN Bn n}` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + REWRITE_TAC[REAL_SUB_REFL; REAL_ABS_NUM] THEN + MATCH_MP_TAC(REAL_ARITH `&0 <= x /\ x <= &0 ==> x = &0`) THEN + MATCH_MP_TAC REAL_SUP_BOUNDS THEN CONJ_TAC THENL + [UNDISCH_TAC `!x:A y:A. + ~({abs(g (b:A->bool) x * inv(&(SUC n)) - + g b y * inv(&(SUC n))) | + n,b | b IN Bn n} = {})` THEN + DISCH_THEN(MP_TAC o SPECL [`x:A`; `x:A`]) THEN + REWRITE_TAC[REAL_SUB_REFL; REAL_ABS_NUM]; + X_GEN_TAC `w:real` THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `n':num` (X_CHOOSE_THEN `b':A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST1_TAC))) THEN + REAL_ARITH_TAC]]; + (* Symmetry: d(x,y) = d(y,x) *) + REPEAT GEN_TAC THEN STRIP_TAC THEN + UNDISCH_TAC `!x:A y:A. d(x,y) = sup {abs(g (b:A->bool) x * + inv(&(SUC n)) - g b y * inv(&(SUC n))) | n,b | b IN Bn n}` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + AP_TERM_TAC THEN + GEN_REWRITE_TAC (LAND_CONV o ONCE_DEPTH_CONV) [REAL_ABS_SUB] THEN + REFL_TAC; + (* Triangle inequality: d(x,z) <= d(x,y) + d(y,z) *) + REPEAT GEN_TAC THEN STRIP_TAC THEN + UNDISCH_TAC `!x:A y:A. d(x,y) = sup {abs(g (b:A->bool) x * + inv(&(SUC n)) - g b y * inv(&(SUC n))) | n,b | b IN Bn n}` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + (* Goal: sup S_xz <= sup S_xy + sup S_yz *) + MATCH_MP_TAC REAL_SUP_LE THEN CONJ_TAC THENL + [(* Nonemptiness of S_xz *) + UNDISCH_TAC `!x:A y:A. + ~({abs(g (b:A->bool) x * inv(&(SUC n)) - + g b y * inv(&(SUC n))) | + n,b | b IN Bn n} = {})` THEN + DISCH_THEN(MP_TAC o SPECL [`x:A`; `z:A`]) THEN + DISCH_THEN ACCEPT_TAC; + (* For each element w of S_xz: w <= sup S_xy + sup S_yz *) + X_GEN_TAC `w:real` THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `n':num` (X_CHOOSE_THEN `b':A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST1_TAC))) THEN + (* |a-c| <= |a-b| + |b-c| then bound each by its sup *) + MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `abs((g:(A->bool)->A->real) b' x * inv(&(SUC n')) - + g b' y * inv(&(SUC n'))) + + abs(g b' y * inv(&(SUC n')) - + g b' z * inv(&(SUC n')))` THEN + CONJ_TAC THENL + [(* Real triangle inequality: |a-c| <= |a-b| + |b-c| *) + REAL_ARITH_TAC; + (* |...(x,y)| + |...(y,z)| <= sup S_xy + sup S_yz *) + MATCH_MP_TAC REAL_LE_ADD2 THEN CONJ_TAC THENL + [(* |...(x,y)| <= sup S_xy via ELEMENT_LE_SUP *) + MATCH_MP_TAC ELEMENT_LE_SUP THEN CONJ_TAC THENL + [(* S_xy bounded above *) + EXISTS_TAC `&1` THEN + X_GEN_TAC `v:real` THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `n'':num` (X_CHOOSE_THEN `b'':A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST1_TAC))) THEN + UNDISCH_TAC `!x:A y:A z. + x IN topspace top /\ y IN topspace top /\ + z IN {abs(g (b:A->bool) x * inv(&(SUC n)) - + g b y * inv(&(SUC n))) | + n,b | b IN Bn n} + ==> z <= &1` THEN + DISCH_THEN(MP_TAC o SPECL [`x:A`; `y:A`; + `abs((g:(A->bool)->A->real) b'' x * inv(&(SUC n'')) - + g b'' y * inv(&(SUC n'')))`]) THEN + ANTS_TAC THENL + [REPEAT CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; + FIRST_ASSUM ACCEPT_TAC; + REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `n'':num` THEN EXISTS_TAC `b'':A->bool` THEN + CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; REFL_TAC]]; + DISCH_THEN ACCEPT_TAC]; + (* element IN S_xy *) + REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `n':num` THEN EXISTS_TAC `b':A->bool` THEN + CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; REFL_TAC]]; + (* |...(y,z)| <= sup S_yz via ELEMENT_LE_SUP *) + MATCH_MP_TAC ELEMENT_LE_SUP THEN CONJ_TAC THENL + [(* S_yz bounded above *) + EXISTS_TAC `&1` THEN + X_GEN_TAC `v:real` THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `n'':num` (X_CHOOSE_THEN `b'':A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST1_TAC))) THEN + UNDISCH_TAC `!x:A y:A z. + x IN topspace top /\ y IN topspace top /\ + z IN {abs(g (b:A->bool) x * inv(&(SUC n)) - + g b y * inv(&(SUC n))) | + n,b | b IN Bn n} + ==> z <= &1` THEN + DISCH_THEN(MP_TAC o SPECL [`y:A`; `z:A`; + `abs((g:(A->bool)->A->real) b'' y * inv(&(SUC n'')) - + g b'' z * inv(&(SUC n'')))`]) THEN + ANTS_TAC THENL + [REPEAT CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; + FIRST_ASSUM ACCEPT_TAC; + REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `n'':num` THEN EXISTS_TAC `b'':A->bool` THEN + CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; REFL_TAC]]; + DISCH_THEN ACCEPT_TAC]; + (* element IN S_yz *) + REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `n':num` THEN EXISTS_TAC `b':A->bool` THEN + CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; REFL_TAC]]]]]]; + ALL_TAC] THEN + (* Step: topology equivalence top = mtopology(metric(topspace top, d)) *) + SUBGOAL_THEN + `top:A topology = mtopology(metric(topspace top:A->bool, d:A#A->real))` + (fun th -> REWRITE_TAC[metrizable_space] THEN + EXISTS_TAC `metric(topspace top:A->bool, d:A#A->real)` THEN + ACCEPT_TAC th) THEN + (* Establish mspace and mdist for our metric *) + SUBGOAL_THEN + `mspace(metric(topspace top:A->bool, d:A#A->real)) = topspace top` + ASSUME_TAC THENL + [MATCH_MP_TAC MSPACE THEN FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + SUBGOAL_THEN + `mdist(metric(topspace top:A->bool, d:A#A->real)) = d:A#A->real` + ASSUME_TAC THENL + [MATCH_MP_TAC MDIST THEN FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + (* Helper: d(x,x) = 0 *) + SUBGOAL_THEN `!a:A. a IN topspace top ==> (d:A#A->real)(a,a) = &0` + ASSUME_TAC THENL + [X_GEN_TAC `a:A` THEN DISCH_TAC THEN + MP_TAC(ISPECL [`metric(topspace top:A->bool,d:A#A->real)`; `a:A`] + MDIST_REFL) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* d-ball openness: metric balls are open in top *) + SUBGOAL_THEN + `!x:A r. x IN topspace top /\ &0 < r + ==> open_in top {y | y IN topspace top /\ (d:A#A->real)(x,y) < r}` + ASSUME_TAC THENL + [REPEAT STRIP_TAC THEN + ONCE_REWRITE_TAC[OPEN_IN_SUBOPEN] THEN + X_GEN_TAC `y0:A` THEN REWRITE_TAC[IN_ELIM_THM] THEN STRIP_TAC THEN + ABBREV_TAC `eps = r - (d:A#A->real)(x,y0)` THEN + SUBGOAL_THEN `&0 < eps` ASSUME_TAC THENL + [EXPAND_TAC "eps" THEN + UNDISCH_TAC `(d:A#A->real)(x,y0) < r` THEN REAL_ARITH_TAC; + ALL_TAC] THEN + SUBGOAL_THEN + `?N0:num. ~(N0 = 0) /\ &0 < inv(&N0) /\ inv(&N0) < eps / &4` + STRIP_ASSUME_TAC THENL + [REWRITE_TAC[GSYM REAL_ARCH_INV] THEN + UNDISCH_TAC `&0 < eps` THEN REAL_ARITH_TAC; + ALL_TAC] THEN + (* Get local finiteness neighborhoods for all n (via SKOLEM) *) + SUBGOAL_THEN + `?LF:num->A->bool. !n. open_in top (LF n) /\ y0 IN LF n /\ + FINITE {b:A->bool | b IN Bn n /\ ~(b INTER LF n = {})}` + (X_CHOOSE_TAC `LF:num->A->bool`) THENL + [REWRITE_TAC[GSYM SKOLEM_THM] THEN X_GEN_TAC `nn:num` THEN + SUBGOAL_THEN `locally_finite_in top ((Bn:num->(A->bool)->bool) nn)` + MP_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[locally_finite_in] THEN + DISCH_THEN(CONJUNCTS_THEN2 (K ALL_TAC) (MP_TAC o SPEC `y0:A`)) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* Key subgoal: find V open with y0 IN V and d(y0,z) < eps for z in V *) + SUBGOAL_THEN + `?V:A->bool. open_in top V /\ y0 IN V /\ + !z. z IN V /\ z IN topspace top ==> (d:A#A->real)(y0,z) < eps` + (X_CHOOSE_THEN `V:A->bool` STRIP_ASSUME_TAC) THENL + [ + (* For each n <= N0, get open Vn containing y0 bounding all terms *) + SUBGOAL_THEN + `!n:num. n <= N0 ==> + ?Vn:A->bool. open_in top Vn /\ y0 IN Vn /\ + !z:A (b:A->bool). z IN Vn /\ z IN topspace top /\ + b IN (Bn:num->(A->bool)->bool) n + ==> abs((g:(A->bool)->A->real) b z * inv(&(SUC n)) - + g b y0 * inv(&(SUC n))) <= eps / &2` + ASSUME_TAC THENL + [X_GEN_TAC `nn:num` THEN DISCH_TAC THEN + ABBREV_TAC + `Fb = {b:A->bool | b IN (Bn:num->(A->bool)->bool) nn /\ + ~(b INTER (LF:num->A->bool) nn = {})}` THEN + SUBGOAL_THEN `FINITE (Fb:(A->bool)->bool)` ASSUME_TAC THENL + [EXPAND_TAC "Fb" THEN + UNDISCH_TAC `!n:num. open_in top ((LF:num->A->bool) n) /\ + y0 IN LF n /\ + FINITE {b:A->bool | b IN Bn n /\ ~(b INTER LF n = {})}` THEN + DISCH_THEN(MP_TAC o SPEC `nn:num`) THEN + SIMP_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `!b:A->bool. b IN Fb ==> + ?Wb:A->bool. open_in top Wb /\ y0 IN Wb /\ + !z:A. z IN Wb /\ z IN topspace top + ==> abs((g:(A->bool)->A->real) b z - g b y0) < eps / &2` + ASSUME_TAC THENL + [X_GEN_TAC `b0:A->bool` THEN DISCH_TAC THEN + (* b0 IN Bn nn, hence b0 IN B *) + SUBGOAL_THEN `(b0:A->bool) IN B` ASSUME_TAC THENL + [UNDISCH_TAC `!n:num (b:A->bool). b IN Bn n ==> b IN B` THEN + DISCH_THEN(MP_TAC o SPECL [`nn:num`; `b0:A->bool`]) THEN + ANTS_TAC THENL + [UNDISCH_TAC `(b0:A->bool) IN Fb` THEN + EXPAND_TAC "Fb" THEN REWRITE_TAC[IN_ELIM_THM] THEN + SIMP_TAC[]; + DISCH_THEN ACCEPT_TAC]; ALL_TAC] THEN + (* g b0 is continuous *) + SUBGOAL_THEN + `continuous_map(top,euclideanreal) ((g:(A->bool)->A->real) b0)` + ASSUME_TAC THENL + [UNDISCH_TAC `!b:A->bool. b IN B + ==> continuous_map(top,euclideanreal) (g b) /\ + (!x. x IN topspace top ==> &0 <= g b x /\ g b x <= &1) /\ + (!x. x IN topspace top /\ ~(x IN b) ==> g b x = &0) /\ + (!x. x IN b ==> &0 < g b x)` THEN + DISCH_THEN(MP_TAC o SPEC `b0:A->bool`) THEN + ASM_REWRITE_TAC[] THEN SIMP_TAC[]; + ALL_TAC] THEN + (* The preimage of an open ball around g b0 y0 is open *) + SUBGOAL_THEN + `open_in top {z:A | z IN topspace top /\ + abs((g:(A->bool)->A->real) b0 z - g b0 y0) < eps / &2}` + ASSUME_TAC THENL + [MP_TAC(ISPECL [`(g:(A->bool)->A->real) b0`; `top:A topology`; + `euclideanreal`; + `{t:real | abs(t - (g:(A->bool)->A->real) b0 y0) < eps / &2}`] + OPEN_IN_CONTINUOUS_MAP_PREIMAGE) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN + REWRITE_TAC[GSYM REAL_OPEN_IN] THEN + MATCH_MP_TAC REAL_OPEN_ABS_LT THEN + UNDISCH_TAC `&0 < eps` THEN REAL_ARITH_TAC; + ALL_TAC] THEN + MATCH_MP_TAC(TAUT `(a ==> b) ==> a ==> b`) THEN + DISCH_TAC THEN + SUBGOAL_THEN + `{z:A | z IN topspace top /\ + abs((g:(A->bool)->A->real) b0 z - g b0 y0) < eps / &2} = + {x | x IN topspace top /\ + g b0 x IN {t:real | abs(t - g b0 y0) < eps / &2}}` + SUBST1_TAC THENL + [REWRITE_TAC[EXTENSION; IN_ELIM_THM] THEN MESON_TAC[]; + FIRST_ASSUM ACCEPT_TAC]; + ALL_TAC] THEN + EXISTS_TAC + `{z:A | z IN topspace top /\ + abs((g:(A->bool)->A->real) b0 z - g b0 y0) < eps / &2}` THEN + REPEAT CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; + REWRITE_TAC[IN_ELIM_THM] THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[REAL_SUB_REFL; REAL_ABS_NUM] THEN + UNDISCH_TAC `&0 < eps` THEN REAL_ARITH_TAC; + REWRITE_TAC[IN_ELIM_THM] THEN + REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o REWRITE_RULE[RIGHT_IMP_EXISTS_THM; SKOLEM_THM]) THEN + DISCH_THEN(X_CHOOSE_TAC `Wb:(A->bool)->A->bool`) THEN + ASM_CASES_TAC `Fb:(A->bool)->bool = {}` THENL + [(* Fb = {}: LF nn suffices since all b INTER LF nn = {} *) + EXISTS_TAC `(LF:num->A->bool) nn` THEN + UNDISCH_TAC `!n:num. open_in top ((LF:num->A->bool) n) /\ + y0 IN LF n /\ + FINITE {b:A->bool | b IN Bn n /\ ~(b INTER LF n = {})}` THEN + DISCH_THEN(MP_TAC o SPEC `nn:num`) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 ASSUME_TAC (K ALL_TAC))) THEN + ASM_REWRITE_TAC[] THEN + X_GEN_TAC `z:A` THEN X_GEN_TAC `b:A->bool` THEN STRIP_TAC THEN + (* b INTER LF nn = {} because b NOT IN Fb = {} *) + SUBGOAL_THEN `(b:A->bool) INTER (LF:num->A->bool) nn = {}` + ASSUME_TAC THENL + [UNDISCH_TAC `Fb:(A->bool)->bool = {}` THEN EXPAND_TAC "Fb" THEN + REWRITE_TAC[EXTENSION; NOT_IN_EMPTY; IN_ELIM_THM] THEN + DISCH_THEN(MP_TAC o SPEC `b:A->bool`) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]; + ALL_TAC] THEN + (* y0 NOT IN b and z NOT IN b *) + SUBGOAL_THEN `~((y0:A) IN b)` ASSUME_TAC THENL + [UNDISCH_TAC `(b:A->bool) INTER (LF:num->A->bool) nn = {}` THEN + REWRITE_TAC[EXTENSION; IN_INTER; NOT_IN_EMPTY] THEN + DISCH_THEN(MP_TAC o SPEC `y0:A`) THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `~((z:A) IN b)` ASSUME_TAC THENL + [UNDISCH_TAC `(b:A->bool) INTER (LF:num->A->bool) nn = {}` THEN + REWRITE_TAC[EXTENSION; IN_INTER; NOT_IN_EMPTY] THEN + DISCH_THEN(MP_TAC o SPEC `z:A`) THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* b IN B *) + SUBGOAL_THEN `(b:A->bool) IN B` ASSUME_TAC THENL + [UNDISCH_TAC `!n:num (b:A->bool). b IN Bn n ==> b IN B` THEN + DISCH_THEN(MP_TAC o SPECL [`nn:num`; `b:A->bool`]) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* g b y0 = 0 *) + SUBGOAL_THEN `(g:(A->bool)->A->real) b y0 = &0` ASSUME_TAC THENL + [UNDISCH_TAC `!b:A->bool. b IN B + ==> continuous_map(top,euclideanreal) (g b) /\ + (!x. x IN topspace top ==> &0 <= g b x /\ g b x <= &1) /\ + (!x. x IN topspace top /\ ~(x IN b) ==> g b x = &0) /\ + (!x. x IN b ==> &0 < g b x)` THEN + DISCH_THEN(MP_TAC o SPEC `b:A->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC `y0:A` o el 2 o CONJUNCTS) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* g b z = 0 *) + SUBGOAL_THEN `(g:(A->bool)->A->real) b z = &0` ASSUME_TAC THENL + [UNDISCH_TAC `!b:A->bool. b IN B + ==> continuous_map(top,euclideanreal) (g b) /\ + (!x. x IN topspace top ==> &0 <= g b x /\ g b x <= &1) /\ + (!x. x IN topspace top /\ ~(x IN b) ==> g b x = &0) /\ + (!x. x IN b ==> &0 < g b x)` THEN + DISCH_THEN(MP_TAC o SPEC `b:A->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC `z:A` o el 2 o CONJUNCTS) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + ASM_REWRITE_TAC[REAL_MUL_LZERO; REAL_SUB_REFL; REAL_ABS_NUM] THEN + UNDISCH_TAC `&0 < eps` THEN REAL_ARITH_TAC; + (* Fb != {}: use LF nn INTER INTERS(IMAGE Wb Fb) *) + EXISTS_TAC + `(LF:num->A->bool) nn INTER + INTERS(IMAGE (Wb:(A->bool)->A->bool) Fb)` THEN + REPEAT CONJ_TAC THENL + [(* open_in *) + MATCH_MP_TAC OPEN_IN_INTER THEN CONJ_TAC THENL + [UNDISCH_TAC `!n:num. open_in top ((LF:num->A->bool) n) /\ + y0 IN LF n /\ + FINITE {b:A->bool | b IN Bn n /\ ~(b INTER LF n = {})}` THEN + DISCH_THEN(MP_TAC o SPEC `nn:num`) THEN SIMP_TAC[]; + ALL_TAC] THEN + MATCH_MP_TAC OPEN_IN_INTERS THEN REPEAT CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN FIRST_ASSUM ACCEPT_TAC; + REWRITE_TAC[IMAGE_EQ_EMPTY] THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[FORALL_IN_IMAGE] THEN + X_GEN_TAC `b0:A->bool` THEN DISCH_TAC THEN + UNDISCH_TAC `!b:A->bool. b IN Fb ==> + open_in top ((Wb:(A->bool)->A->bool) b) /\ y0 IN Wb b /\ + !z:A. z IN Wb b /\ z IN topspace top + ==> abs((g:(A->bool)->A->real) b z - g b y0) < eps / &2` THEN + DISCH_THEN(MP_TAC o SPEC `b0:A->bool`) THEN + ASM_REWRITE_TAC[] THEN SIMP_TAC[]]; + (* y0 IN LF nn INTER INTERS(IMAGE Wb Fb) *) + REWRITE_TAC[IN_INTER; IN_INTERS; FORALL_IN_IMAGE] THEN + CONJ_TAC THENL + [UNDISCH_TAC `!n:num. open_in top ((LF:num->A->bool) n) /\ + y0 IN LF n /\ + FINITE {b:A->bool | b IN Bn n /\ ~(b INTER LF n = {})}` THEN + DISCH_THEN(MP_TAC o SPEC `nn:num`) THEN SIMP_TAC[]; + X_GEN_TAC `b0:A->bool` THEN DISCH_TAC THEN + UNDISCH_TAC `!b:A->bool. b IN Fb ==> + open_in top ((Wb:(A->bool)->A->bool) b) /\ y0 IN Wb b /\ + !z:A. z IN Wb b /\ z IN topspace top + ==> abs((g:(A->bool)->A->real) b z - g b y0) < eps / &2` THEN + DISCH_THEN(MP_TAC o SPEC `b0:A->bool`) THEN + ASM_REWRITE_TAC[] THEN SIMP_TAC[]]; + (* The bound *) + REWRITE_TAC[IN_INTER; IN_INTERS; FORALL_IN_IMAGE] THEN + X_GEN_TAC `z:A` THEN X_GEN_TAC `b0:A->bool` THEN STRIP_TAC THEN + SUBGOAL_THEN + `abs((g:(A->bool)->A->real) b0 z * inv(&(SUC nn)) - + g b0 y0 * inv(&(SUC nn))) = + abs(g b0 z - g b0 y0) * inv(&(SUC nn))` + SUBST1_TAC THENL + [REWRITE_TAC[GSYM REAL_SUB_RDISTRIB; REAL_ABS_MUL] THEN + AP_TERM_TAC THEN REWRITE_TAC[REAL_ABS_REFL] THEN + MATCH_MP_TAC REAL_LE_INV THEN REAL_ARITH_TAC; + ALL_TAC] THEN + ASM_CASES_TAC `(b0:A->bool) IN Fb` THENL + [(* b0 IN Fb *) + MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `abs((g:(A->bool)->A->real) b0 z - g b0 y0)` THEN + CONJ_TAC THENL + [GEN_REWRITE_TAC (RAND_CONV) [GSYM REAL_MUL_RID] THEN + MATCH_MP_TAC REAL_LE_LMUL THEN CONJ_TAC THENL + [REAL_ARITH_TAC; + MATCH_MP_TAC REAL_INV_LE_1 THEN + REWRITE_TAC[REAL_OF_NUM_LE] THEN ARITH_TAC]; + MATCH_MP_TAC REAL_LT_IMP_LE THEN + UNDISCH_TAC `!b:A->bool. b IN Fb ==> + open_in top ((Wb:(A->bool)->A->bool) b) /\ y0 IN Wb b /\ + !z:A. z IN Wb b /\ z IN topspace top + ==> abs((g:(A->bool)->A->real) b z - g b y0) < eps / &2` THEN + DISCH_THEN(MP_TAC o SPEC `b0:A->bool`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC `z:A` o CONJUNCT2 o CONJUNCT2) THEN + ANTS_TAC THENL + [SUBGOAL_THEN `(z:A) IN (Wb:(A->bool)->A->bool) b0` + ASSUME_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[]; + DISCH_THEN ACCEPT_TAC]]; + (* b0 NOT IN Fb *) + SUBGOAL_THEN `(b0:A->bool) INTER (LF:num->A->bool) nn = {}` + ASSUME_TAC THENL + [UNDISCH_TAC `~((b0:A->bool) IN Fb)` THEN + EXPAND_TAC "Fb" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `~((y0:A) IN b0)` ASSUME_TAC THENL + [UNDISCH_TAC `(b0:A->bool) INTER (LF:num->A->bool) nn = {}` THEN + REWRITE_TAC[EXTENSION; IN_INTER; NOT_IN_EMPTY] THEN + DISCH_THEN(MP_TAC o SPEC `y0:A`) THEN + UNDISCH_TAC `!n:num. open_in top ((LF:num->A->bool) n) /\ + y0 IN LF n /\ + FINITE {b:A->bool | b IN Bn n /\ ~(b INTER LF n = {})}` THEN + DISCH_THEN(MP_TAC o SPEC `nn:num`) THEN SIMP_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `~((z:A) IN b0)` ASSUME_TAC THENL + [UNDISCH_TAC `(b0:A->bool) INTER (LF:num->A->bool) nn = {}` THEN + REWRITE_TAC[EXTENSION; IN_INTER; NOT_IN_EMPTY] THEN + DISCH_THEN(MP_TAC o SPEC `z:A`) THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `(b0:A->bool) IN B` ASSUME_TAC THENL + [UNDISCH_TAC `!n:num (b:A->bool). b IN Bn n ==> b IN B` THEN + DISCH_THEN(MP_TAC o SPECL [`nn:num`; `b0:A->bool`]) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(g:(A->bool)->A->real) b0 y0 = &0` ASSUME_TAC THENL + [UNDISCH_TAC `!b:A->bool. b IN B + ==> continuous_map(top,euclideanreal) (g b) /\ + (!x. x IN topspace top ==> &0 <= g b x /\ g b x <= &1) /\ + (!x. x IN topspace top /\ ~(x IN b) ==> g b x = &0) /\ + (!x. x IN b ==> &0 < g b x)` THEN + DISCH_THEN(MP_TAC o SPEC `b0:A->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC `y0:A` o el 2 o CONJUNCTS) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(g:(A->bool)->A->real) b0 z = &0` ASSUME_TAC THENL + [UNDISCH_TAC `!b:A->bool. b IN B + ==> continuous_map(top,euclideanreal) (g b) /\ + (!x. x IN topspace top ==> &0 <= g b x /\ g b x <= &1) /\ + (!x. x IN topspace top /\ ~(x IN b) ==> g b x = &0) /\ + (!x. x IN b ==> &0 < g b x)` THEN + DISCH_THEN(MP_TAC o SPEC `b0:A->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC `z:A` o el 2 o CONJUNCTS) THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[REAL_SUB_REFL; REAL_ABS_NUM; REAL_MUL_LZERO] THEN + UNDISCH_TAC `&0 < eps` THEN REAL_ARITH_TAC]]]; + ALL_TAC] THEN + (* Skolemize *) + FIRST_X_ASSUM(MP_TAC o REWRITE_RULE[RIGHT_IMP_EXISTS_THM; SKOLEM_THM]) THEN + DISCH_THEN(X_CHOOSE_TAC `Vn:num->A->bool`) THEN + (* V = INTERS {Vn n | n <= N0} *) + EXISTS_TAC + `INTERS (IMAGE (Vn:num->A->bool) {m:num | m <= N0})` THEN + REPEAT CONJ_TAC THENL + [(* open_in top V *) + MATCH_MP_TAC OPEN_IN_INTERS THEN REPEAT CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN REWRITE_TAC[FINITE_NUMSEG_LE]; + REWRITE_TAC[IMAGE_EQ_EMPTY] THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY] THEN + EXISTS_TAC `0` THEN REWRITE_TAC[IN_ELIM_THM] THEN + UNDISCH_TAC `~(N0 = 0)` THEN ARITH_TAC; + REWRITE_TAC[FORALL_IN_IMAGE; IN_ELIM_THM] THEN + X_GEN_TAC `m:num` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `m:num`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(fun th -> REWRITE_TAC[CONJUNCT1 th])]; + (* y0 IN V *) + REWRITE_TAC[IN_INTERS; FORALL_IN_IMAGE; IN_ELIM_THM] THEN + X_GEN_TAC `m:num` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `m:num`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(fun th -> REWRITE_TAC[CONJUNCT1(CONJUNCT2 th)]); + (* !z. z IN V /\ z IN topspace top ==> d(y0,z) < eps *) + X_GEN_TAC `z:A` THEN + REWRITE_TAC[IN_INTERS; FORALL_IN_IMAGE; IN_ELIM_THM] THEN + STRIP_TAC THEN + (* d(y0,z) = sup{...} *) + UNDISCH_TAC `!x:A y:A. (d:A#A->real)(x,y) = sup {abs(g (b:A->bool) x * + inv(&(SUC n)) - g b y * inv(&(SUC n))) | n,b | b IN Bn n}` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + (* sup S < eps follows from sup S <= eps/2 < eps *) + MATCH_MP_TAC REAL_LET_TRANS THEN + EXISTS_TAC `eps / &2` THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_SUP_LE THEN CONJ_TAC THENL + [(* Nonemptiness *) + UNDISCH_TAC `!x:A y:A. + ~({abs(g (b:A->bool) x * inv(&(SUC n)) - + g b y * inv(&(SUC n))) | + n,b | b IN Bn n} = {})` THEN + DISCH_THEN(MP_TAC o SPECL [`y0:A`; `z:A`]) THEN + DISCH_THEN ACCEPT_TAC; + (* Every element <= eps/2 *) + X_GEN_TAC `w:real` THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `nn':num` (X_CHOOSE_THEN `b':A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST1_TAC))) THEN + ASM_CASES_TAC `(nn':num) <= (N0:num)` THENL + [(* nn' <= N0: use Vn property *) + (* First derive z IN Vn nn' from !m. m <= N0 ==> z IN Vn m *) + SUBGOAL_THEN `(z:A) IN (Vn:num->A->bool) nn'` ASSUME_TAC THENL + [FIRST_X_ASSUM(MP_TAC o SPEC `nn':num`) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + ONCE_REWRITE_TAC[REAL_ABS_SUB] THEN + (* Push the Vn property for nn' *) + FIRST_X_ASSUM(fun th -> + let sp = SPEC `nn':num` th in + try let _,c = dest_imp(concl sp) in + if is_conj c then MP_TAC sp + else failwith "" + with _ -> failwith "") THEN + (* Goal: (nn' <= N0 ==> conj) ==> abs(...) <= eps/2 *) + ANTS_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + DISCH_THEN(fun th -> + MP_TAC(SPECL [`z:A`; `b':A->bool`] (CONJUNCT2(CONJUNCT2 th)))) THEN + ASM_REWRITE_TAC[]; + (* nn' > N0: bound by inv(N0) < eps/4 < eps/2 *) + (* Step 1: b' IN B *) + SUBGOAL_THEN `(b':A->bool) IN B` ASSUME_TAC THENL + [ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Step 2: Factor out inv(SUC nn') *) + SUBGOAL_THEN + `abs((g:(A->bool)->A->real) b' y0 * inv(&(SUC nn')) - + g b' z * inv(&(SUC nn'))) = + abs(g b' y0 - g b' z) * inv(&(SUC nn'))` + SUBST1_TAC THENL + [REWRITE_TAC[GSYM REAL_SUB_RDISTRIB; REAL_ABS_MUL] THEN + AP_TERM_TAC THEN REWRITE_TAC[REAL_ABS_REFL] THEN + MATCH_MP_TAC REAL_LE_INV THEN REWRITE_TAC[REAL_POS]; + ALL_TAC] THEN + (* Step 3: abs(g b' y0 - g b' z) <= 1 *) + SUBGOAL_THEN `abs((g:(A->bool)->A->real) b' y0 - g b' z) <= &1` + ASSUME_TAC THENL + [SUBGOAL_THEN + `&0 <= (g:(A->bool)->A->real) b' y0 /\ g b' y0 <= &1` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN + `&0 <= (g:(A->bool)->A->real) b' z /\ g b' z <= &1` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[]; + ALL_TAC] THEN + ASM_REAL_ARITH_TAC; + ALL_TAC] THEN + (* Step 4: inv(SUC nn') <= inv(N0) *) + SUBGOAL_THEN `inv(&(SUC nn')) <= inv(&(N0:num))` ASSUME_TAC THENL + [MATCH_MP_TAC REAL_LE_INV2 THEN + REWRITE_TAC[REAL_OF_NUM_LT; REAL_OF_NUM_LE] THEN + UNDISCH_TAC `~((nn':num) <= (N0:num))` THEN + UNDISCH_TAC `~(N0:num = 0)` THEN + ARITH_TAC; + ALL_TAC] THEN + (* Step 5: Combine: <= 1 * inv(N0) = inv(N0) < eps/4 < eps/2 *) + MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `&1 * inv(&(N0:num))` THEN CONJ_TAC THENL + [MATCH_MP_TAC REAL_LE_MUL2 THEN + ASM_REWRITE_TAC[REAL_ABS_POS] THEN + MATCH_MP_TAC REAL_LE_INV THEN REWRITE_TAC[REAL_POS]; + REWRITE_TAC[REAL_MUL_LID] THEN + MATCH_MP_TAC REAL_LT_IMP_LE THEN + MATCH_MP_TAC REAL_LT_TRANS THEN + EXISTS_TAC `eps / &4` THEN + ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `&0 < eps` THEN REAL_ARITH_TAC]]]; + (* eps/2 < eps *) + UNDISCH_TAC `&0 < eps` THEN REAL_ARITH_TAC]]; + ALL_TAC] THEN + (* V works: it's contained in the d-ball via triangle inequality *) + EXISTS_TAC `V:A->bool` THEN REPEAT CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; + FIRST_ASSUM ACCEPT_TAC; + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `z:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(z:A) IN topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; ALL_TAC] THEN + CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + (* d(x,z) <= d(x,y0) + d(y0,z) < d(x,y0) + eps = r *) + MATCH_MP_TAC REAL_LET_TRANS THEN + EXISTS_TAC `(d:A#A->real)(x,y0) + d(y0,z)` THEN + CONJ_TAC THENL + [(* triangle inequality: d(x,z) <= d(x,y0) + d(y0,z) *) + MP_TAC(ISPECL [`metric(topspace top:A->bool,d:A#A->real)`; + `x:A`; `y0:A`; `z:A`] MDIST_TRIANGLE) THEN + UNDISCH_TAC + `mspace(metric(topspace top:A->bool,d:A#A->real)) = topspace top` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + UNDISCH_TAC + `mdist(metric(topspace top:A->bool,d:A#A->real)) = (d:A#A->real)` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + DISCH_THEN MATCH_MP_TAC THEN + REPEAT CONJ_TAC THEN FIRST_ASSUM ACCEPT_TAC; + (* d(x,y0) + d(y0,z) < r via d(y0,z) < eps = r - d(x,y0) *) + SUBGOAL_THEN `(d:A#A->real)(y0,z) < eps` MP_TAC THENL + [UNDISCH_TAC + `!z:A. z IN V /\ z IN topspace top ==> (d:A#A->real)(y0,z) < eps` THEN + DISCH_THEN MATCH_MP_TAC THEN + CONJ_TAC THEN FIRST_ASSUM ACCEPT_TAC; + EXPAND_TAC "eps" THEN REAL_ARITH_TAC]]]; + ALL_TAC] THEN + (* Use TOPOLOGY_EQ *) + REWRITE_TAC[TOPOLOGY_EQ] THEN X_GEN_TAC `u:A->bool` THEN EQ_TAC THENL + [(* Forward: open_in top u ==> open_in (mtopology m) u *) + DISCH_TAC THEN REWRITE_TAC[OPEN_IN_MTOPOLOGY] THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_SUBSET THEN FIRST_ASSUM ACCEPT_TAC; + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; ALL_TAC] THEN + (* Find base element b0 with x IN b0 SUBSET u *) + UNDISCH_TAC `!x:A u:A->bool. open_in top u /\ x IN u + ==> ?b. b IN B /\ x IN b /\ b SUBSET u` THEN + DISCH_THEN(MP_TAC o SPECL [`x:A`; `u:A->bool`]) THEN + ANTS_TAC THENL + [CONJ_TAC THEN FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `b0:A->bool` STRIP_ASSUME_TAC) THEN + (* b0 IN Bn n0 for some n0 *) + SUBGOAL_THEN `?n0:num. (b0:A->bool) IN Bn n0` STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `(b0:A->bool) IN B` THEN + UNDISCH_TAC `B = UNIONS {(Bn:num->(A->bool)->bool) n | n IN (:num)}` THEN + DISCH_THEN SUBST1_TAC THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `s:(A->bool)->bool` + (CONJUNCTS_THEN2 + (X_CHOOSE_THEN `mm:num` ASSUME_TAC) ASSUME_TAC)) THEN + FIRST_X_ASSUM SUBST_ALL_TAC THEN + EXISTS_TAC `mm:num` THEN FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + (* Extract g properties for b0 *) + SUBGOAL_THEN + `(!x:A. x IN topspace top /\ ~(x IN b0) ==> + (g:(A->bool)->A->real) b0 x = &0) /\ + (!x:A. x IN b0 ==> &0 < (g:(A->bool)->A->real) b0 x)` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `!b:A->bool. b IN B ==> + continuous_map(top,euclideanreal) (g b) /\ + (!x. x IN topspace top ==> &0 <= g b x /\ g b x <= &1) /\ + (!x. x IN topspace top /\ ~(x IN b) ==> g b x = &0) /\ + (!x. x IN b ==> &0 < g b x)` THEN + DISCH_THEN(MP_TAC o SPEC `b0:A->bool`) THEN + ANTS_TAC THENL [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + DISCH_THEN(CONJUNCTS_THEN2 (K ALL_TAC) + (CONJUNCTS_THEN2 (K ALL_TAC) ACCEPT_TAC)); + ALL_TAC] THEN + SUBGOAL_THEN `&0 < (g:(A->bool)->A->real) b0 x` ASSUME_TAC THENL + [FIRST_ASSUM MATCH_MP_TAC THEN FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + (* r = g(b0)(x) * inv(SUC n0) *) + EXISTS_TAC `(g:(A->bool)->A->real) b0 x * inv(&(SUC n0))` THEN + CONJ_TAC THENL + [MATCH_MP_TAC REAL_LT_MUL THEN CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; + MATCH_MP_TAC REAL_LT_INV THEN + REWRITE_TAC[REAL_OF_NUM_LT] THEN ARITH_TAC]; + (* mball SUBSET u: if d(x,y) < r then y IN b0 SUBSET u *) + REWRITE_TAC[SUBSET; IN_MBALL] THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `y:A` THEN STRIP_TAC THEN + ASM_CASES_TAC `(y:A) IN b0` THENL + [ASM SET_TAC[]; ALL_TAC] THEN + (* ~(y IN b0): derive contradiction *) + SUBGOAL_THEN `(g:(A->bool)->A->real) b0 y = &0` ASSUME_TAC THENL + [UNDISCH_TAC + `!x:A. x IN topspace top /\ ~(x IN b0) ==> + (g:(A->bool)->A->real) b0 x = &0` THEN + DISCH_THEN(MP_TAC o SPEC `y:A`) THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `F` (fun th -> MESON_TAC[th]) THEN + UNDISCH_TAC + `sup {abs ((g:(A->bool)->A->real) b x * inv (&(SUC n)) - + g b y * inv (&(SUC n))) | + n,b | b IN Bn n} < + (g:(A->bool)->A->real) b0 x * inv (&(SUC n0))` THEN + REWRITE_TAC[REAL_NOT_LT] THEN + MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC + `abs((g:(A->bool)->A->real) b0 x * inv(&(SUC n0)) - + g b0 y * inv(&(SUC n0)))` THEN + CONJ_TAC THENL + [ASM_REWRITE_TAC[REAL_MUL_LZERO; REAL_SUB_RZERO] THEN + REAL_ARITH_TAC; + MATCH_MP_TAC ELEMENT_LE_SUP THEN CONJ_TAC THENL + [EXISTS_TAC `&1` THEN + X_GEN_TAC `w:real` THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `n':num` (X_CHOOSE_THEN `b':A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST1_TAC))) THEN + UNDISCH_TAC `!x:A y:A z. + x IN topspace top /\ y IN topspace top /\ + z IN {abs(g (b:A->bool) x * inv(&(SUC n)) - + g b y * inv(&(SUC n))) | + n,b | b IN Bn n} + ==> z <= &1` THEN + DISCH_THEN(MP_TAC o SPECL [`x:A`; `y:A`; + `abs((g:(A->bool)->A->real) b' x * inv(&(SUC n')) - + g b' y * inv(&(SUC n')))`]) THEN + ANTS_TAC THENL + [REPEAT CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; + FIRST_ASSUM ACCEPT_TAC; + REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `n':num` THEN EXISTS_TAC `b':A->bool` THEN + CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; REFL_TAC]]; + DISCH_THEN ACCEPT_TAC]; + REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `n0:num` THEN EXISTS_TAC `b0:A->bool` THEN + CONJ_TAC THENL [FIRST_ASSUM ACCEPT_TAC; REFL_TAC]]]]]; + (* Backward: open_in (mtopology m) u ==> open_in top u *) + DISCH_TAC THEN + (* Extract u SUBSET topspace and ball condition from OPEN_IN_MTOPOLOGY *) + SUBGOAL_THEN + `(u:A->bool) SUBSET topspace top /\ + !x. x IN u ==> + ?r. &0 < r /\ + mball(metric(topspace top:A->bool,d:A#A->real)) (x,r) SUBSET u` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC + `open_in (mtopology(metric(topspace top:A->bool,d:A#A->real))) + (u:A->bool)` THEN + REWRITE_TAC[OPEN_IN_MTOPOLOGY] THEN + UNDISCH_TAC + `mspace(metric(topspace top:A->bool,d:A#A->real)) = topspace top` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + DISCH_THEN ACCEPT_TAC; + ALL_TAC] THEN + (* Use OPEN_IN_SUBOPEN -- ONCE to avoid infinite rewriting loop *) + ONCE_REWRITE_TAC[OPEN_IN_SUBOPEN] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + (* Get x IN topspace top *) + SUBGOAL_THEN `(x:A) IN topspace top` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + (* Get r > 0 and mball SUBSET u *) + UNDISCH_TAC + `!x:A. x IN u + ==> ?r. &0 < r /\ + mball(metric(topspace top:A->bool,d:A#A->real)) (x,r) SUBSET u` THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN + ANTS_TAC THENL [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `r:real` STRIP_ASSUME_TAC) THEN + (* Witness: the d-ball in top *) + EXISTS_TAC `{y:A | y IN topspace top /\ (d:A#A->real)(x,y) < r}` THEN + REPEAT CONJ_TAC THENL + [(* open_in top {y | ...} *) + UNDISCH_TAC `!x:A r. x IN topspace top /\ &0 < r + ==> open_in top {y:A | y IN topspace top /\ (d:A#A->real)(x,y) < r}` THEN + DISCH_THEN MATCH_MP_TAC THEN + CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; FIRST_ASSUM ACCEPT_TAC]; + (* x IN {y | ...} *) + REWRITE_TAC[IN_ELIM_THM] THEN CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; + UNDISCH_TAC `!a:A. a IN topspace top ==> (d:A#A->real)(a,a) = &0` THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN + ANTS_TAC THENL [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + FIRST_ASSUM ACCEPT_TAC]; + (* {y | ...} SUBSET u *) + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `z:A` THEN STRIP_TAC THEN + (* z is in the mball, hence in u *) + UNDISCH_TAC + `mball(metric(topspace top:A->bool,d:A#A->real)) (x:A,r) SUBSET + (u:A->bool)` THEN + REWRITE_TAC[SUBSET; IN_MBALL] THEN + DISCH_THEN MATCH_MP_TAC THEN + UNDISCH_TAC + `mspace(metric(topspace top:A->bool,d:A#A->real)) = topspace top` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + UNDISCH_TAC + `mdist(metric(topspace top:A->bool,d:A#A->real)) = (d:A#A->real)` THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]) THEN + REPEAT CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; + FIRST_ASSUM ACCEPT_TAC; + FIRST_ASSUM ACCEPT_TAC]]]);; + +(* Paracompact Hausdorff locally metrizable => sigma-locally-finite base *) +let PARACOMPACT_LOCALLY_METRIZABLE_SIGMA_LF_BASE = prove + (`!top:A topology. + paracompact_space top /\ hausdorff_space top /\ + (!x. x IN topspace top + ==> ?u. open_in top u /\ x IN u /\ + metrizable_space(subtopology top u)) + ==> ?B. (!b. b IN B ==> open_in top b) /\ + (!x u. open_in top u /\ x IN u + ==> ?b. b IN B /\ x IN b /\ b SUBSET u) /\ + sigma_locally_finite_in top B`, + GEN_TAC THEN STRIP_TAC THEN + (* Step 1: Apply paracompactness to cover by metrizable opens *) + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [paracompact_space]) THEN + DISCH_THEN(MP_TAC o SPEC + `{u:A->bool | open_in top u /\ metrizable_space(subtopology top u)}`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [SET_TAC[]; + REWRITE_TAC[EXTENSION; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN EQ_TAC THENL + [DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; + DISCH_TAC THEN ASM_MESON_TAC[]]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `CC:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Each element of CC is metrizable *) + SUBGOAL_THEN + `!c:A->bool. c IN CC ==> metrizable_space(subtopology top c)` + ASSUME_TAC THENL + [X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `c:A->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_ELIM_THM]) THEN + STRIP_TAC THEN + SUBGOAL_THEN `subtopology (subtopology top u) (c:A->bool) = + subtopology top c` (fun th -> + ASM_MESON_TAC[th; METRIZABLE_SPACE_SUBTOPOLOGY]) THEN + REWRITE_TAC[SUBTOPOLOGY_SUBTOPOLOGY] THEN AP_TERM_TAC THEN ASM SET_TAC[]; + ALL_TAC] THEN + (* Choose metrics for each c in CC *) + SUBGOAL_THEN + `?mc:(A->bool)->A metric. + !c. c IN CC ==> subtopology top c = mtopology (mc c)` + STRIP_ASSUME_TAC THENL + [REWRITE_TAC[GSYM SKOLEM_THM] THEN ASM_MESON_TAC[metrizable_space]; + ALL_TAC] THEN + (* Useful: mspace(mc c) = c for c in CC *) + SUBGOAL_THEN `!c:A->bool. c IN CC ==> mspace((mc:(A->bool)->A metric) c) = c` + ASSUME_TAC THENL + [X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN + SUBGOAL_THEN `subtopology top (c:A->bool) = + mtopology ((mc:(A->bool)->A metric) c)` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(fun th -> + MP_TAC(AP_TERM `topspace:(A)topology->A->bool` th)) THEN + REWRITE_TAC[TOPSPACE_MTOPOLOGY; TOPSPACE_SUBTOPOLOGY] THEN + SUBGOAL_THEN `(c:A->bool) SUBSET topspace top` MP_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET]; ALL_TAC] THEN + DISCH_TAC THEN + SUBGOAL_THEN `topspace top INTER (c:A->bool) = c` + (fun th -> REWRITE_TAC[th]) THENL + [ASM SET_TAC[]; MESON_TAC[]]; + ALL_TAC] THEN + (* Step 2: For each m, get locally finite refinement of 1/(m+1)-balls *) + SUBGOAL_THEN + `!m:num. ?Dm:(A->bool)->bool. + (!d. d IN Dm ==> open_in top d) /\ + UNIONS Dm = topspace top /\ + (!d. d IN Dm ==> + ?c (x:A). c IN CC /\ x IN c /\ + d SUBSET mball ((mc:(A->bool)->A metric) c) + (x, inv(&(m + 1)))) /\ + locally_finite_in top Dm` + MP_TAC THENL + [X_GEN_TAC `m:num` THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [paracompact_space]) THEN + DISCH_THEN(MP_TAC o SPEC + `{mball ((mc:(A->bool)->A metric) c) ((x:A), inv(&(m + 1))) | + c IN CC /\ x IN c}`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [(* All balls are open in top *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN + MAP_EVERY X_GEN_TAC [`c:A->bool`; `x':A`] THEN STRIP_TAC THEN + SUBGOAL_THEN `open_in (subtopology top (c:A->bool)) + (mball ((mc:(A->bool)->A metric) c) ((x':A), inv(&(m + 1))))` + MP_TAC THENL + [SUBGOAL_THEN `subtopology top (c:A->bool) = + mtopology ((mc:(A->bool)->A metric) c)` (fun th -> REWRITE_TAC[th]) + THENL [ASM_MESON_TAC[]; REWRITE_TAC[OPEN_IN_MBALL]]; + ALL_TAC] THEN + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST1_TAC)) THEN + MATCH_MP_TAC OPEN_IN_INTER THEN ASM_MESON_TAC[]; + (* Balls cover topspace *) + REWRITE_TAC[EXTENSION; IN_UNIONS; EXISTS_IN_GSPEC] THEN + X_GEN_TAC `z:A` THEN EQ_TAC THENL + [DISCH_THEN(X_CHOOSE_THEN `c:A->bool` + (X_CHOOSE_THEN `x':A` STRIP_ASSUME_TAC)) THEN + SUBGOAL_THEN `(z:A) IN mspace((mc:(A->bool)->A metric) c)` MP_TAC THENL + [ASM_MESON_TAC[MBALL_SUBSET_MSPACE; SUBSET]; ALL_TAC] THEN + ASM_SIMP_TAC[] THEN ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; + DISCH_TAC THEN + SUBGOAL_THEN `?c:A->bool. c IN CC /\ z IN c` + (X_CHOOSE_THEN `c:A->bool` STRIP_ASSUME_TAC) THENL + [ASM_MESON_TAC[EXTENSION; IN_UNIONS]; ALL_TAC] THEN + MAP_EVERY EXISTS_TAC [`c:A->bool`; `z:A`] THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CENTRE_IN_MBALL THEN ASM_SIMP_TAC[] THEN + REWRITE_TAC[REAL_LT_INV_EQ; REAL_OF_NUM_LT] THEN ARITH_TAC]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `Dm:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `Dm:(A->bool)->bool` THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `d:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `d:A->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `b:A->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_ELIM_THM]) THEN + REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN + MAP_EVERY X_GEN_TAC [`c:A->bool`; `x':A`] THEN STRIP_TAC THEN + MAP_EVERY EXISTS_TAC [`c:A->bool`; `x':A`] THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[SKOLEM_THM] THEN + DISCH_THEN(X_CHOOSE_TAC `D:num->(A->bool)->bool`) THEN + (* Step 3: B = UNIONS {D m | m IN (:num)} *) + EXISTS_TAC `UNIONS {(D:num->(A->bool)->bool) m | m IN (:num)}` THEN + REPEAT CONJ_TAC THENL + [(* All elements of B are open *) + REWRITE_TAC[IN_UNIONS; EXISTS_IN_GSPEC; IN_UNIV] THEN + ASM_MESON_TAC[]; + (* B is a basis *) + MAP_EVERY X_GEN_TAC [`x:A`; `u:A->bool`] THEN STRIP_TAC THEN + SUBGOAL_THEN `(x:A) IN topspace top` ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET; SUBSET]; ALL_TAC] THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [locally_finite_in]) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `x:A`)) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN + `!c:A->bool. c IN CC /\ x IN c + ==> ?e. &0 < e /\ + mball ((mc:(A->bool)->A metric) c) ((x:A),e) SUBSET u INTER c` + MP_TAC THENL + [X_GEN_TAC `c:A->bool` THEN STRIP_TAC THEN + SUBGOAL_THEN `open_in (mtopology((mc:(A->bool)->A metric) c)) + (u INTER c:A->bool)` MP_TAC THENL + [SUBGOAL_THEN `subtopology top (c:A->bool) = + mtopology ((mc:(A->bool)->A metric) c)` (fun th -> REWRITE_TAC[GSYM th]) + THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN + EXISTS_TAC `u:A->bool` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[OPEN_IN_MTOPOLOGY; SUBSET; IN_MBALL] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `x:A`)) THEN + ASM_SIMP_TAC[IN_INTER] THEN + DISCH_THEN(X_CHOOSE_THEN `r:real` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `r:real` THEN ASM_REWRITE_TAC[SUBSET; IN_MBALL; IN_INTER] THEN + X_GEN_TAC `y:A` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `y:A`) THEN + ASM_REWRITE_TAC[IN_INTER] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + DISCH_THEN(MP_TAC o + REWRITE_RULE[RIGHT_IMP_EXISTS_THM; SKOLEM_THM]) THEN + DISCH_THEN(X_CHOOSE_TAC `eps:(A->bool)->real`) THEN + ABBREV_TAC `CC_x = {c:A->bool | c IN CC /\ x IN c}` THEN + SUBGOAL_THEN `FINITE (CC_x:(A->bool)->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `{c:A->bool | c IN CC /\ ~(c INTER w = {})}` THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + EXPAND_TAC "CC_x" THEN REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `c:A->bool` THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_SUBSET) THEN ASM SET_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `~(CC_x:(A->bool)->bool = {})` ASSUME_TAC THENL + [EXPAND_TAC "CC_x" THEN REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + ASM_MESON_TAC[EXTENSION; IN_UNIONS]; ALL_TAC] THEN + SUBGOAL_THEN `&0 < inf (IMAGE (eps:(A->bool)->real) CC_x)` ASSUME_TAC THENL + [ASM_SIMP_TAC[REAL_LT_INF_FINITE; FINITE_IMAGE; IMAGE_EQ_EMPTY] THEN + REWRITE_TAC[FORALL_IN_IMAGE] THEN + EXPAND_TAC "CC_x" THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + MP_TAC(SPEC `inf(IMAGE (eps:(A->bool)->real) CC_x) / &2` REAL_ARCH_INV) THEN + ASM_REWRITE_TAC[REAL_HALF] THEN + DISCH_THEN(X_CHOOSE_THEN `N:num` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `?d:A->bool. d IN (D:num->(A->bool)->bool) (N - 1) /\ x IN d` + (X_CHOOSE_THEN `d:A->bool` STRIP_ASSUME_TAC) THENL + [ASM_MESON_TAC[EXTENSION; IN_UNIONS]; ALL_TAC] THEN + EXISTS_TAC `d:A->bool` THEN + CONJ_TAC THENL + [REWRITE_TAC[IN_UNIONS; EXISTS_IN_GSPEC; IN_UNIV] THEN + EXISTS_TAC `N - 1` THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + (* d refines some ball *) + FIRST_X_ASSUM(MP_TAC o CONJUNCT1 o CONJUNCT2 o CONJUNCT2 o + SPEC `N - 1`) THEN + DISCH_THEN(MP_TAC o SPEC `d:A->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `c0:A->bool` + (X_CHOOSE_THEN `y:A` STRIP_ASSUME_TAC)) THEN + SUBGOAL_THEN `(x:A) IN c0` ASSUME_TAC THENL + [SUBGOAL_THEN `(x:A) IN mspace((mc:(A->bool)->A metric) c0)` MP_TAC THENL + [SUBGOAL_THEN `x IN mball ((mc:(A->bool)->A metric) c0) + ((y:A),inv(&((N - 1) + 1)))` MP_TAC THENL + [ASM SET_TAC[]; MESON_TAC[MBALL_SUBSET_MSPACE; SUBSET]]; + ASM_SIMP_TAC[]]; ALL_TAC] THEN + SUBGOAL_THEN `(c0:A->bool) IN CC_x` ASSUME_TAC THENL + [EXPAND_TAC "CC_x" THEN ASM_REWRITE_TAC[IN_ELIM_THM]; ALL_TAC] THEN + (* d SUBSET u via: d SUBSET mball(y,r) SUBSET + mball(x,eps c0) SUBSET u INTER c0 SUBSET u *) + SUBGOAL_THEN `inf(IMAGE (eps:(A->bool)->real) CC_x) <= eps(c0:A->bool)` + ASSUME_TAC THENL + [MP_TAC(SPEC `IMAGE (eps:(A->bool)->real) CC_x` INF_FINITE) THEN + ASM_SIMP_TAC[FINITE_IMAGE; IMAGE_EQ_EMPTY] THEN + DISCH_THEN(MP_TAC o CONJUNCT2) THEN + DISCH_THEN MATCH_MP_TAC THEN + REWRITE_TAC[IN_IMAGE] THEN EXISTS_TAC `c0:A->bool` THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN + `(d:A->bool) SUBSET + mball((mc:(A->bool)->A metric) c0) ((x:A), eps(c0:A->bool))` + ASSUME_TAC THENL + [MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `mball((mc:(A->bool)->A metric) c0) + ((y:A), inv(&(N - 1 + 1)))` THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC MBALL_SUBSET THEN CONJ_TAC THENL + [ASM_SIMP_TAC[]; + SUBGOAL_THEN + `(x:A) IN mball((mc:(A->bool)->A metric) c0) + ((y:A), inv(&(N - 1 + 1)))` MP_TAC THENL + [ASM SET_TAC[]; + REWRITE_TAC[IN_MBALL] THEN STRIP_TAC] THEN + SUBGOAL_THEN + `mdist ((mc:(A->bool)->A metric) c0) ((y:A),(x:A)) + + inv(&(N - 1 + 1)) < &2 * inv(&(N - 1 + 1))` + ASSUME_TAC THENL + [MATCH_MP_TAC(REAL_ARITH `a < b ==> a + b < &2 * b`) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `&2 * inv(&(N - 1 + 1)) <= eps(c0:A->bool)` + ASSUME_TAC THENL + [MATCH_MP_TAC REAL_LE_TRANS THEN + EXISTS_TAC `inf(IMAGE (eps:(A->bool)->real) CC_x)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC REAL_LT_IMP_LE THEN + SUBGOAL_THEN `(N - 1) + 1 = N` (fun th -> REWRITE_TAC[th]) THENL + [ASM_ARITH_TAC; + MATCH_MP_TAC(REAL_ARITH `a < b / &2 ==> &2 * a < b`) THEN + ASM_REWRITE_TAC[]]; + ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + MATCH_MP_TAC(REAL_ARITH + `a + b < &2 * b /\ &2 * b <= c ==> a + b <= c`) THEN + ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `mball((mc:(A->bool)->A metric) c0) + ((x:A), eps(c0:A->bool))` THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `u INTER (c0:A->bool)` THEN + REWRITE_TAC[INTER_SUBSET] THEN + ASM_SIMP_TAC[]; + (* sigma_locally_finite_in top B *) + REWRITE_TAC[sigma_locally_finite_in] THEN + EXISTS_TAC `D:num->(A->bool)->bool` THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; REWRITE_TAC[]]]);; + +(* ------------------------------------------------------------------------- *) +(* Collectionwise normal spaces (Engelking 5.1.17-5.1.18) *) +(* ------------------------------------------------------------------------- *) + +(* Collectionwise normal space (Engelking 5.1.17) *) +let collectionwise_normal_space = new_definition + `collectionwise_normal_space (top:A topology) <=> + !F. (!c. c IN F ==> closed_in top c) /\ + pairwise DISJOINT F /\ + locally_finite_in top F + ==> ?G. (!c. c IN F ==> open_in top (G c) /\ c SUBSET G c) /\ + pairwise (\c d. DISJOINT (G c) (G d)) F`;; + +(* Helper: If s SUBSET a and t SUBSET b and DISJOINT a b then DISJOINT s t *) +(* Engelking 5.1.18: Paracompact Hausdorff is collectionwise normal + Proof: Given locally finite pairwise disjoint closed family F: + 1. Build open cover {O_c | c in F} UNION {topspace \ UNIONS F} + where O_c = topspace \ UNIONS(F DELETE c) + 2. Get locally finite open refinement W + 3. Each w meeting c is SUBSET O_c, so meets at most one member of F + 4. Apply NORMAL_SPACE_ALT: for each c, get H(c) with cl(H(c)) SUBSET O_c + 5. Define G(c) = H(c) \ UNIONS{cl(H(d)) | d != c} + 6. The cl(H(d)) family is locally finite, so the union is closed, G(c) is open + 7. c SUBSET G(c) since cl(H(d)) INTER c = {} for d != c + 8. G(c) INTER G(d) = {} since G(c) SUBSET cl(H(c)) and G(d) avoids cl(H(c)) *) +let PARACOMPACT_HAUSDORFF_IMP_COLLECTIONWISE_NORMAL = prove + (`!top:A topology. + paracompact_space top /\ hausdorff_space top + ==> collectionwise_normal_space top`, + let DISJOINT_SUBSET_SUBSET = prove + (`!s t a b:A->bool. + s SUBSET a /\ t SUBSET b /\ DISJOINT a b ==> DISJOINT s t`, + SET_TAC[]) in + REPEAT GEN_TAC THEN STRIP_TAC THEN + REWRITE_TAC[collectionwise_normal_space] THEN + X_GEN_TAC `fam:(A->bool)->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 ASSUME_TAC ASSUME_TAC)) THEN + (* normal_space top *) + SUBGOAL_THEN `normal_space (top:A topology)` ASSUME_TAC THENL + [MATCH_MP_TAC PARACOMPACT_HAUSDORFF_IMP_NORMAL_SPACE THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* For each c, UNIONS(F DELETE c) is closed *) + SUBGOAL_THEN + `!c:A->bool. c IN fam ==> closed_in top (UNIONS(fam DELETE c))` + ASSUME_TAC THENL + [X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC CLOSED_IN_LOCALLY_FINITE_UNIONS THEN CONJ_TAC THENL + [REWRITE_TAC[IN_DELETE] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC LOCALLY_FINITE_IN_SUBSET THEN + EXISTS_TAC `fam:(A->bool)->bool` THEN ASM_REWRITE_TAC[DELETE_SUBSET]; + ALL_TAC] THEN + (* UNIONS F is closed *) + SUBGOAL_THEN `closed_in top (UNIONS (fam:(A->bool)->bool))` ASSUME_TAC THENL + [MATCH_MP_TAC CLOSED_IN_LOCALLY_FINITE_UNIONS THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* For each c, c SUBSET topspace DIFF UNIONS(F DELETE c) *) + SUBGOAL_THEN + `!c:A->bool. c IN fam + ==> c SUBSET (topspace top DIFF UNIONS(fam DELETE c))` + ASSUME_TAC THENL + [X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN + REWRITE_TAC[SUBSET; IN_DIFF; IN_UNIONS; IN_DELETE] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN CONJ_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET; SUBSET]; ALL_TAC] THEN + REWRITE_TAC[NOT_EXISTS_THM; DE_MORGAN_THM] THEN + X_GEN_TAC `d:A->bool` THEN + ASM_CASES_TAC `(d:A->bool) = c` THEN ASM_REWRITE_TAC[] THEN + UNDISCH_TAC `pairwise DISJOINT (fam:(A->bool)->bool)` THEN + REWRITE_TAC[pairwise] THEN + DISCH_THEN(MP_TAC o SPECL [`c:A->bool`; `d:A->bool`]) THEN + ASM_REWRITE_TAC[DISJOINT] THEN ASM SET_TAC[]; + ALL_TAC] THEN + (* Apply paracompact_space to get locally finite refinement W *) + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [paracompact_space]) THEN + DISCH_THEN(MP_TAC o SPEC + `(topspace top DIFF UNIONS (fam:(A->bool)->bool)) INSERT + IMAGE (\c:A->bool. topspace top DIFF UNIONS(fam DELETE c)) fam`) THEN + ANTS_TAC THENL + [(* Prove this is an open cover *) + CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_INSERT; FORALL_IN_IMAGE] THEN + ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_TOPSPACE]; + ALL_TAC] THEN + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; IN_INSERT; IN_IMAGE] THEN + REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[SUBSET_DIFF]; ALL_TAC] THEN + REWRITE_TAC[SUBSET; IN_UNIONS; IN_INSERT; IN_IMAGE] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + ASM_CASES_TAC `(x:A) IN UNIONS fam` THENL + [FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_UNIONS]) THEN + DISCH_THEN(X_CHOOSE_THEN `c:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `topspace top DIFF UNIONS((fam:(A->bool)->bool) DELETE c)` THEN + CONJ_TAC THENL + [DISJ2_TAC THEN EXISTS_TAC `c:A->bool` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + ASM_MESON_TAC[SUBSET]; + EXISTS_TAC `topspace top DIFF UNIONS (fam:(A->bool)->bool)` THEN + CONJ_TAC THENL [DISJ1_TAC THEN REFL_TAC; ALL_TAC] THEN + ASM_REWRITE_TAC[IN_DIFF]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `W:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Key: each w meeting c is contained in topspace DIFF UNIONS(F DELETE c) *) + SUBGOAL_THEN + `!w c:A->bool. w IN W /\ c IN fam /\ ~(w INTER c = {}) + ==> w SUBSET topspace top DIFF UNIONS(fam DELETE c)` + ASSUME_TAC THENL + [REPEAT GEN_TAC THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `w:A->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` STRIP_ASSUME_TAC) THEN + UNDISCH_TAC + `(u:A->bool) IN (topspace top DIFF UNIONS (fam:(A->bool)->bool)) INSERT + IMAGE (\c. topspace top DIFF UNIONS(fam DELETE c)) fam` THEN + REWRITE_TAC[IN_INSERT; IN_IMAGE] THEN + DISCH_THEN(DISJ_CASES_THEN2 ASSUME_TAC + (X_CHOOSE_THEN `c':A->bool` STRIP_ASSUME_TAC)) THENL + [(* u = topspace DIFF UNIONS fam: contradicts w INTER c != {} *) + UNDISCH_TAC `~(w INTER c:A->bool = {})` THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + DISCH_THEN(X_CHOOSE_THEN `z:A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(z:A) IN UNIONS fam` MP_TAC THENL + [REWRITE_TAC[IN_UNIONS] THEN EXISTS_TAC `c:A->bool` THEN + ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[SUBSET; IN_DIFF]; ALL_TAC] THEN + ASM_CASES_TAC `c':A->bool = c` THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + (* c' != c: then c SUBSET UNIONS(F DELETE c'), contradicts w INTER c != {} *) + UNDISCH_TAC `~(w INTER c:A->bool = {})` THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + DISCH_THEN(X_CHOOSE_THEN `z:A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(c:A->bool) SUBSET UNIONS(fam DELETE c')` MP_TAC THENL + [REWRITE_TAC[SUBSET; IN_UNIONS; IN_DELETE] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + EXISTS_TAC `c:A->bool` THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[SUBSET; IN_DIFF]; + ALL_TAC] THEN + (* Apply NORMAL_SPACE_ALT: for each c get H(c) open with c SUBSET H(c) + and closure(H(c)) SUBSET UNIONS{w | w IN W, w INTER c != {}} *) + SUBGOAL_THEN + `!c:A->bool. c IN fam + ==> ?v. open_in top v /\ c SUBSET v /\ + top closure_of v SUBSET + UNIONS {w:A->bool | w IN W /\ ~(w INTER c = {})}` + MP_TAC THENL + [X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN + FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [NORMAL_SPACE_ALT]) THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_SIMP_TAC[] THEN CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_UNIONS THEN REWRITE_TAC[IN_ELIM_THM] THEN + ASM_MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN UNIONS W` MP_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET; SUBSET]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `w:A->bool` THEN ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + ALL_TAC] THEN + DISCH_THEN(fun th -> + MP_TAC(REWRITE_RULE[RIGHT_IMP_EXISTS_THM; SKOLEM_THM] th)) THEN + DISCH_THEN(X_CHOOSE_THEN `H:(A->bool)->(A->bool)` STRIP_ASSUME_TAC) THEN + (* closure(H c) SUBSET topspace DIFF UNIONS(F DELETE c) *) + SUBGOAL_THEN + `!c:A->bool. c IN fam + ==> top closure_of ((H:(A->bool)->(A->bool)) c) SUBSET + topspace top DIFF UNIONS(fam DELETE c)` + ASSUME_TAC THENL + [X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `UNIONS {w:A->bool | w IN W /\ ~(w INTER c = {})}` THEN + ASM_SIMP_TAC[] THEN REWRITE_TAC[UNIONS_SUBSET; IN_ELIM_THM] THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Key: closure(H c) INTER d = {} for c != d *) + SUBGOAL_THEN + `!c d:A->bool. c IN fam /\ d IN fam /\ ~(c = d) + ==> DISJOINT (top closure_of ((H:(A->bool)->(A->bool)) c)) d` + ASSUME_TAC THENL + [REPEAT GEN_TAC THEN STRIP_TAC THEN + MATCH_MP_TAC DISJOINT_SUBSET_SUBSET THEN + MAP_EVERY EXISTS_TAC + [`topspace top DIFF UNIONS((fam:(A->bool)->bool) DELETE c)`; + `UNIONS((fam:(A->bool)->bool) DELETE c)`] THEN + REPEAT CONJ_TAC THENL + [ASM_SIMP_TAC[]; + ASM SET_TAC[]; + SET_TAC[]]; + ALL_TAC] THEN + (* {closure(H c) | c IN F} is locally finite *) + SUBGOAL_THEN + `locally_finite_in top + {top closure_of (H:(A->bool)->(A->bool)) c | + c IN (fam:(A->bool)->bool)}` + ASSUME_TAC THENL + [REWRITE_TAC[locally_finite_in; FORALL_IN_GSPEC] THEN CONJ_TAC THENL + [GEN_TAC THEN DISCH_TAC THEN + REWRITE_TAC[CLOSURE_OF_SUBSET_TOPSPACE]; ALL_TAC] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + UNDISCH_TAC `locally_finite_in top (W:(A->bool)->bool)` THEN + REWRITE_TAC[locally_finite_in] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (MP_TAC o SPEC `x:A`)) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `V:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `V:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC + `IMAGE (\w:A->bool. top closure_of ((H:(A->bool)->(A->bool)) + (@c. c IN fam /\ ~(w INTER c = {})))) + {w:A->bool | w IN W /\ ~(V INTER w = {})}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN + ONCE_REWRITE_TAC[INTER_COMM] THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_IMAGE] THEN + X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(CONJUNCTS_THEN ASSUME_TAC) THEN + FIRST_X_ASSUM(X_CHOOSE_THEN `c:A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST_ALL_TAC)) THEN + (* cl(H c) meets V, cl(H c) SUBSET UNIONS{w | w meets c} *) + UNDISCH_TAC `~(top closure_of ((H:(A->bool)->(A->bool)) c) + INTER (V:A->bool) = {})` THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + DISCH_THEN(X_CHOOSE_THEN `z:A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(z:A) IN UNIONS {w:A->bool | w IN W /\ ~(w INTER c = {})}` + MP_TAC THENL + [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `w:A->bool` THEN + CONJ_TAC THENL + [ALL_TAC; ASM_REWRITE_TAC[] THEN ASM SET_TAC[]] THEN + (* Variable capture prevents AP_TERM_TAC, so use SUBGOAL_THEN *) + SUBGOAL_THEN + `(@c':A->bool. c' IN fam /\ (?x:A. x IN w /\ x IN c')) = c` + (fun th -> REWRITE_TAC[th]) THEN + MATCH_MP_TAC SELECT_UNIQUE THEN + X_GEN_TAC `c':A->bool` THEN EQ_TAC THENL + [STRIP_TAC THEN + SUBGOAL_THEN `~(w INTER c':A->bool = {})` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + ASM_CASES_TAC `c':A->bool = c` THEN + ASM_REWRITE_TAC[] THEN + (* c' != c: extract c' IN fam from beta-application, derive contradiction *) + FIRST_X_ASSUM(STRIP_ASSUME_TAC o BETA_RULE o + check (fun th -> is_comb(concl th) && is_abs(rator(concl th)))) THEN + SUBGOAL_THEN + `(w:A->bool) SUBSET topspace top DIFF UNIONS(fam DELETE c':A->bool)` + MP_TAC THENL + [FIRST_ASSUM(MATCH_MP_TAC o SPECL [`w:A->bool`; `c':A->bool`]) THEN + ASM_REWRITE_TAC[]; + UNDISCH_TAC `~(w INTER c:A->bool = {})` THEN + UNDISCH_TAC `(c:A->bool) IN fam` THEN + UNDISCH_TAC `~(c':A->bool = c)` THEN + REWRITE_TAC[SUBSET; IN_DIFF; IN_UNIONS; IN_DELETE; + EXTENSION; IN_INTER; NOT_IN_EMPTY] THEN + MESON_TAC[]]; + DISCH_THEN SUBST_ALL_TAC THEN ASM_REWRITE_TAC[] THEN + ASM SET_TAC[]]; + ALL_TAC] THEN + (* For each c, UNIONS{cl(H d) | d IN F, d != c} is closed *) + SUBGOAL_THEN + `!c:A->bool. c IN fam + ==> closed_in top + (UNIONS {top closure_of (H:(A->bool)->(A->bool)) d | + d IN (fam:(A->bool)->bool) /\ ~(d = c)})` + ASSUME_TAC THENL + [X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC CLOSED_IN_LOCALLY_FINITE_UNIONS THEN CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_GSPEC] THEN MESON_TAC[CLOSED_IN_CLOSURE_OF]; + ALL_TAC] THEN + MATCH_MP_TAC LOCALLY_FINITE_IN_SUBSET THEN + EXISTS_TAC + `{top closure_of (H:(A->bool)->(A->bool)) d | + d IN (fam:(A->bool)->bool)}` THEN ASM SET_TAC[]; + ALL_TAC] THEN + (* Witness with G'(c) = H(c) DIFF UNIONS{cl(H d) | d IN F, d != c} *) + EXISTS_TAC + `\c:A->bool. (H:(A->bool)->(A->bool)) c DIFF + UNIONS {(top:A topology) closure_of H d | + d IN (fam:(A->bool)->bool) /\ ~(d = c)}` THEN + REWRITE_TAC[] THEN CONJ_TAC THENL + [(* For each c: open_in top (G' c) /\ c SUBSET G' c *) + X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN CONJ_TAC THENL + [(* open_in: H(c) is open, UNIONS{...} is closed *) + MATCH_MP_TAC OPEN_IN_DIFF THEN ASM_SIMP_TAC[]; + (* c SUBSET G'(c) *) + REWRITE_TAC[SUBSET; IN_DIFF] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN CONJ_TAC THENL + [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; NOT_EXISTS_THM; FORALL_IN_GSPEC] THEN + X_GEN_TAC `d:A->bool` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPECL [`d:A->bool`; `c:A->bool`]) THEN + ASM_REWRITE_TAC[DISJOINT] THEN ASM SET_TAC[]]; + (* Pairwise disjointness *) + REWRITE_TAC[pairwise] THEN + MAP_EVERY X_GEN_TAC [`c:A->bool`; `d:A->bool`] THEN STRIP_TAC THEN + (* G'(c) SUBSET cl(H c) and G'(d) INTER cl(H c) = {} *) + MATCH_MP_TAC(SET_RULE + `!u:A->bool. s SUBSET u /\ DISJOINT u t ==> DISJOINT s t`) THEN + EXISTS_TAC `top closure_of ((H:(A->bool)->(A->bool)) c)` THEN + CONJ_TAC THENL + [(* G'(c) SUBSET cl(H c): G'(c) SUBSET H(c) SUBSET cl(H c) *) + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `(H:(A->bool)->(A->bool)) c` THEN CONJ_TAC THENL + [SET_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC CLOSURE_OF_SUBSET THEN + ASM_MESON_TAC[OPEN_IN_SUBSET]; + (* DISJOINT (cl H c) (G'(d)) *) + REWRITE_TAC[DISJOINT] THEN + ONCE_REWRITE_TAC[EXTENSION] THEN + REWRITE_TAC[NOT_IN_EMPTY; IN_INTER; IN_DIFF] THEN + X_GEN_TAC `x:A` THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) THEN + REWRITE_TAC[] THEN REWRITE_TAC[IN_UNIONS; EXISTS_IN_GSPEC] THEN + EXISTS_TAC `c:A->bool` THEN ASM_REWRITE_TAC[]]]);; + +(* Collectionwise normal implies normal *) +(* Proof sketch: For disjoint closed sets s, t, apply collectionwise normality + to the two-element family {s, t} to get disjoint open neighborhoods *) +let COLLECTIONWISE_NORMAL_IMP_NORMAL = prove + (`!top:A topology. + collectionwise_normal_space top /\ t1_space top + ==> normal_space top`, + REPEAT GEN_TAC THEN + REWRITE_TAC[collectionwise_normal_space; normal_space] THEN + INTRO_TAC "cn t1" THEN + MAP_EVERY X_GEN_TAC [`s:A->bool`; `t:A->bool`] THEN + INTRO_TAC "cs ct dis" THEN + (* Handle degenerate case s = t first *) + ASM_CASES_TAC `s:A->bool = t` THENL + [ASM_MESON_TAC[DISJOINT_EMPTY_REFL; OPEN_IN_EMPTY; + EMPTY_SUBSET; DISJOINT_EMPTY]; + ALL_TAC] THEN + (* Apply collectionwise normality to the two-element family {s, t} *) + REMOVE_THEN "cn" (MP_TAC o SPEC `{s:A->bool, t}`) THEN + REWRITE_TAC[FORALL_IN_INSERT; NOT_IN_EMPTY] THEN + ASM_REWRITE_TAC[] THEN + (* Prove pairwise DISJOINT {s, t} *) + SUBGOAL_THEN `pairwise DISJOINT {s:A->bool, t}` + (fun th -> REWRITE_TAC[th]) THENL + [REWRITE_TAC[pairwise; IN_INSERT; NOT_IN_EMPTY] THEN + ASM_MESON_TAC[DISJOINT_SYM]; + ALL_TAC] THEN + SUBGOAL_THEN `locally_finite_in top {s:A->bool, t}` + (fun th -> REWRITE_TAC[th]) THENL + [MATCH_MP_TAC FINITE_IMP_LOCALLY_FINITE_IN THEN + REWRITE_TAC[FINITE_INSERT; FINITE_EMPTY] THEN + REWRITE_TAC[UNIONS_INSERT; UNIONS_0; UNION_EMPTY; UNION_SUBSET] THEN + ASM_MESON_TAC[CLOSED_IN_SUBSET]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `G:(A->bool)->(A->bool)` STRIP_ASSUME_TAC) THEN + MAP_EVERY EXISTS_TAC + [`(G:(A->bool)->(A->bool)) s`; + `(G:(A->bool)->(A->bool)) t`] THEN + ASM_REWRITE_TAC[] THEN + UNDISCH_TAC + `pairwise (\c d. DISJOINT ((G:(A->bool)->(A->bool)) c) (G d)) + {s, t}` THEN + REWRITE_TAC[pairwise; IN_INSERT; NOT_IN_EMPTY] THEN + ASM_MESON_TAC[]);; + +(* Metrizable implies collectionwise normal *) +let METRIZABLE_IMP_COLLECTIONWISE_NORMAL = prove + (`!top:A topology. + metrizable_space top ==> collectionwise_normal_space top`, + GEN_TAC THEN DISCH_TAC THEN + MATCH_MP_TAC PARACOMPACT_HAUSDORFF_IMP_COLLECTIONWISE_NORMAL THEN + ASM_SIMP_TAC[METRIZABLE_IMP_PARACOMPACT_SPACE; + METRIZABLE_IMP_HAUSDORFF_SPACE]);; + +(* Cf. Engelking Exercise 5.1.C(a): Closed subspace of + CW normal is CW normal *) +let COLLECTIONWISE_NORMAL_SPACE_CLOSED_SUBSET = prove + (`!top s:A->bool. + collectionwise_normal_space top /\ closed_in top s + ==> collectionwise_normal_space(subtopology top s)`, + REPEAT GEN_TAC THEN REWRITE_TAC[collectionwise_normal_space] THEN + INTRO_TAC "cn cs" THEN X_GEN_TAC `CC:(A->bool)->bool` THEN + INTRO_TAC "closed pw lf" THEN + (* Each c IN CC is closed in top (by CLOSED_IN_CLOSED_SUBTOPOLOGY) *) + SUBGOAL_THEN + `!c:A->bool. c IN CC ==> closed_in top c /\ c SUBSET s` + ASSUME_TAC THENL + [X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `c:A->bool`) THEN ASM_REWRITE_TAC[] THEN + ASM_SIMP_TAC[CLOSED_IN_CLOSED_SUBTOPOLOGY]; + ALL_TAC] THEN + (* CC is locally finite in top (from locally finite in subtopology) *) + SUBGOAL_THEN `locally_finite_in top (CC:(A->bool)->bool)` ASSUME_TAC THENL + [REMOVE_THEN "lf" MP_TAC THEN + ASM_SIMP_TAC[LOCALLY_FINITE_IN_SUBTOPOLOGY_EQ] THEN MESON_TAC[]; + ALL_TAC] THEN + (* Apply collectionwise normality of top to CC *) + FIRST_X_ASSUM(MP_TAC o SPEC `CC:(A->bool)->bool`) THEN + ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `G:(A->bool)->(A->bool)` STRIP_ASSUME_TAC) THEN + (* Define G' c = G c INTER s *) + EXISTS_TAC `\c:A->bool. (G:(A->bool)->(A->bool)) c INTER (s:A->bool)` THEN + REWRITE_TAC[] THEN CONJ_TAC THENL + [X_GEN_TAC `c:A->bool` THEN DISCH_TAC THEN CONJ_TAC THENL + [REWRITE_TAC[OPEN_IN_SUBTOPOLOGY] THEN + EXISTS_TAC `(G:(A->bool)->(A->bool)) c` THEN + ASM_MESON_TAC[]; + FIRST_X_ASSUM(MP_TAC o SPEC `c:A->bool`) THEN ASM_REWRITE_TAC[] THEN + STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `c:A->bool`) THEN ASM_REWRITE_TAC[] THEN + STRIP_TAC THEN ASM SET_TAC[]]; + REWRITE_TAC[pairwise] THEN + MAP_EVERY X_GEN_TAC [`c:A->bool`; `d:A->bool`] THEN STRIP_TAC THEN + MATCH_MP_TAC(SET_RULE + `!a b c:A->bool. DISJOINT a b ==> DISJOINT (a INTER c) (b INTER c)`) THEN + UNDISCH_TAC + `pairwise (\c d. DISJOINT ((G:(A->bool)->(A->bool)) c) (G d)) CC` THEN + REWRITE_TAC[pairwise] THEN + DISCH_THEN(MP_TAC o SPECL [`c:A->bool`; `d:A->bool`]) THEN + ASM_REWRITE_TAC[]]);; + +(* Munkres 42.1 (Smirnov): Paracompact locally metrizable is metrizable *) +let PARACOMPACT_LOCALLY_METRIZABLE_IMP_METRIZABLE = prove + (`!top:A topology. + paracompact_space top /\ hausdorff_space top /\ + (!x. x IN topspace top + ==> ?u. open_in top u /\ x IN u /\ + metrizable_space(subtopology top u)) + ==> metrizable_space top`, + GEN_TAC THEN STRIP_TAC THEN + MATCH_MP_TAC NAGATA_SMIRNOV_METRIZATION THEN + ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [MATCH_MP_TAC NORMAL_T1_IMP_REGULAR_SPACE THEN + CONJ_TAC THENL + [MATCH_MP_TAC COLLECTIONWISE_NORMAL_IMP_NORMAL THEN + ASM_SIMP_TAC[PARACOMPACT_HAUSDORFF_IMP_COLLECTIONWISE_NORMAL; + HAUSDORFF_IMP_T1_SPACE]; + ASM_SIMP_TAC[HAUSDORFF_IMP_T1_SPACE]]; + MP_TAC(SPEC `top:A topology` + PARACOMPACT_LOCALLY_METRIZABLE_SIGMA_LF_BASE) THEN + ASM_REWRITE_TAC[] THEN MESON_TAC[]]);; + +(* ------------------------------------------------------------------------- *) +(* Realcompact spaces (cf. Engelking 3.11) *) +(* ------------------------------------------------------------------------- *) + +(* Realcompact space (cf. Engelking 3.11) + A Tychonoff space X is realcompact if it is homeomorphic to a closed + subspace of some R^kappa. We use topspace top as the index set. *) +let realcompact_space = new_definition + `realcompact_space (top:A topology) <=> + completely_regular_space top /\ + ?f:A->A->real. + embedding_map(top, product_topology (topspace top) (\i. euclideanreal)) f /\ + closed_in (product_topology (topspace top) (\i. euclideanreal)) + (IMAGE f (topspace top))`;; + +(* Realcompact closed subset, product, and Lindelof-Tychonoff results are + standard but require substantial infrastructure beyond what is needed + for the Nagata-Smirnov metrization theorem. *) + +(* ------------------------------------------------------------------------- *) +(* Smirnov metrization and further characterizations *) +(* ------------------------------------------------------------------------- *) + +(* Definition: Locally metrizable space *) +let locally_metrizable_space = new_definition + `locally_metrizable_space (top:A topology) <=> + !x. x IN topspace top + ==> ?U. open_in top U /\ x IN U /\ metrizable_space (subtopology top U)`;; + +(* Smirnov metrization theorem: + A topological space is metrizable iff it is paracompact, Hausdorff, + and locally metrizable. *) +let SMIRNOV_METRIZATION = prove + (`!top:A topology. + metrizable_space top <=> + paracompact_space top /\ hausdorff_space top /\ locally_metrizable_space top`, + GEN_TAC THEN EQ_TAC THENL + [DISCH_TAC THEN REPEAT CONJ_TAC THENL + [ASM_SIMP_TAC[METRIZABLE_IMP_PARACOMPACT_SPACE]; + ASM_MESON_TAC[METRIZABLE_IMP_HAUSDORFF_SPACE]; + REWRITE_TAC[locally_metrizable_space] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + EXISTS_TAC `topspace top:A->bool` THEN + ASM_SIMP_TAC[OPEN_IN_TOPSPACE; SUBTOPOLOGY_TOPSPACE]]; + REWRITE_TAC[locally_metrizable_space] THEN STRIP_TAC THEN + MATCH_MP_TAC PARACOMPACT_LOCALLY_METRIZABLE_IMP_METRIZABLE THEN + ASM_REWRITE_TAC[]]);; + +(* Corollary: Second countable case follows from Urysohn metrization *) +let SMIRNOV_METRIZATION_SECOND_COUNTABLE = prove + (`!top:A topology. + paracompact_space top /\ hausdorff_space top /\ + locally_metrizable_space top /\ second_countable top + ==> metrizable_space top`, + MESON_TAC[SMIRNOV_METRIZATION]);; + +(* ------------------------------------------------------------------ *) +(* Michael's characterization of paracompactness *) +(* and sharper closed map image theorem *) +(* *) +(* E. Michael, "Another note on paracompact spaces", *) +(* Proc. Amer. Math. Soc. 8 (1957), 822-828. *) +(* *) +(* Michael proved that a regular space is paracompact iff every open *) +(* cover has a closure-preserving closed refinement. This gives a *) +(* sharper image theorem: continuous closed surjection from *) +(* paracompact Hausdorff preserves paracompactness (no need for *) +(* compact fibres / perfect map). *) +(* ------------------------------------------------------------------ *) + +(* Helper: earlier pieces of a shrunk sequence are disjoint from later *) + +let SHRINK_DISJOINT_LATER = prove + (`!(f:num->A->bool) m n. + m < n + ==> f m INTER (f n DIFF UNIONS {f k | k < n}) = {}`, + REPEAT STRIP_TAC THEN + MATCH_MP_TAC(SET_RULE + `(s:A->bool) SUBSET t ==> s INTER (u DIFF t) = {}`) THEN + REWRITE_TAC[UNIONS_GSPEC; SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + EXISTS_TAC `m:num` THEN ASM_REWRITE_TAC[]);; + +(* For a sequence of open sets covering topspace, the shrunk pieces + S_n = f(n) \ UNIONS{f(k) | k < n} form a locally finite family *) + +let SHRINK_SEQUENCE_LOCALLY_FINITE = prove + (`!top:A topology f. + (!n. open_in top (f n)) /\ + UNIONS {f n | n IN (:num)} = topspace top + ==> locally_finite_in top + {f n DIFF UNIONS {f k | k < n} | n IN (:num)}`, + REPEAT GEN_TAC THEN STRIP_TAC THEN REWRITE_TAC[locally_finite_in] THEN + CONJ_TAC THENL + [REWRITE_TAC[IN_ELIM_THM; IN_UNIV] THEN GEN_TAC THEN + DISCH_THEN(X_CHOOSE_THEN `n:num` SUBST1_TAC) THEN + MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC `(f:num->A->bool) n` THEN + REWRITE_TAC[SUBSET_DIFF] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `n:num`) THEN SIMP_TAC[OPEN_IN_SUBSET]; + ALL_TAC] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `?m:num. (x:A) IN f m /\ (!k. k < m ==> ~(x IN f k))` + STRIP_ASSUME_TAC THENL + [MP_TAC(ISPEC `\p:num. (x:A) IN f p` num_WOP) THEN REWRITE_TAC[] THEN + DISCH_THEN(SUBST1_TAC o SYM) THEN + SUBGOAL_THEN `(x:A) IN UNIONS {f n | n IN (:num)}` MP_TAC THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN MESON_TAC[]; + ALL_TAC] THEN + EXISTS_TAC `(f:num->A->bool) m` THEN + CONJ_TAC THENL [ASM_SIMP_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC + `IMAGE (\n. (f:num->A->bool) n DIFF UNIONS {f k | k < n}) + {n | n <= m}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN REWRITE_TAC[FINITE_NUMSEG_LE]; + REWRITE_TAC[SUBSET; IN_IMAGE; IN_ELIM_THM; IN_UNIV] THEN + X_GEN_TAC `u:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 (X_CHOOSE_TAC `n:num`) ASSUME_TAC) THEN + EXISTS_TAC `n:num` THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[GSYM NOT_LT] THEN DISCH_TAC THEN + SUBGOAL_THEN + `(f:num->A->bool) m INTER (f n DIFF UNIONS {f k | k < n}) = {}` + ASSUME_TAC THENL + [MATCH_MP_TAC SHRINK_DISJOINT_LATER THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN + `((f:num->A->bool) n DIFF UNIONS {f k | k < n}) INTER f m = {}` + ASSUME_TAC THENL + [ONCE_REWRITE_TAC[INTER_COMM] THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(u:A->bool) INTER (f:num->A->bool) m = {}` + ASSUME_TAC THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN + ASM_MESON_TAC[]]);; + +(* The shrunk sets still cover the space *) + +let SHRINK_SEQUENCE_COVERS = prove + (`!top:A topology f. + UNIONS {f n | n IN (:num)} = topspace top + ==> UNIONS {f n DIFF UNIONS {f k | k < n} | n IN (:num)} = + topspace top`, + REPEAT GEN_TAC THEN DISCH_THEN(LABEL_TAC "cover") THEN + REWRITE_TAC[EXTENSION] THEN X_GEN_TAC `x:A` THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV; IN_DIFF] THEN + EQ_TAC THENL + [DISCH_THEN(X_CHOOSE_THEN `s:A->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_TAC `n:num`) ASSUME_TAC)) THEN + USE_THEN "cover" (SUBST1_TAC o SYM) THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + EXISTS_TAC `(f:num->A->bool) n` THEN + CONJ_TAC THENL + [EXISTS_TAC `n:num` THEN REFL_TAC; ASM SET_TAC[]]; + DISCH_TAC THEN + SUBGOAL_THEN `x:A IN UNIONS {f n | n IN (:num)}` MP_TAC THENL + [USE_THEN "cover" SUBST1_TAC THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `s:A->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_TAC `n':num`) ASSUME_TAC)) THEN + SUBGOAL_THEN `?m:num. (x:A) IN f m /\ (!k. k < m ==> ~(x IN f k))` + STRIP_ASSUME_TAC THENL + [MP_TAC(ISPEC `\p:num. (x:A) IN f p` num_WOP) THEN REWRITE_TAC[] THEN + DISCH_THEN(SUBST1_TAC o SYM) THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + EXISTS_TAC `(f:num->A->bool) m DIFF UNIONS {f k | k < m}` THEN + CONJ_TAC THENL + [EXISTS_TAC `m:num` THEN REFL_TAC; + REWRITE_TAC[IN_DIFF; IN_UNIONS; IN_ELIM_THM] THEN + ASM_MESON_TAC[]]]);; + +(* If {A n | n} is LF and pairwise disjoint, and each f n is LF with + elements subset of A n, then UNIONS {f n | n} is locally finite *) + +let LOCALLY_FINITE_LEVEL_UNION_GEN = prove + (`!top:A topology A f. + locally_finite_in top {A n | n IN (:num)} /\ + (!n. locally_finite_in top ((f:num->(A->bool)->bool) n)) /\ + (!n (s:A->bool). s IN f n ==> s SUBSET A n) /\ + (!m n. ~(m = n) ==> A m INTER A n = {}) + ==> locally_finite_in top (UNIONS {f n | n IN (:num)})`, + REPEAT GEN_TAC THEN + DISCH_THEN(CONJUNCTS_THEN2 (LABEL_TAC "lfA") + (CONJUNCTS_THEN2 (LABEL_TAC "lfF") + (CONJUNCTS_THEN2 (LABEL_TAC "sub") (LABEL_TAC "disj")))) THEN + SUBGOAL_THEN `!n. (A:num->A->bool) n SUBSET topspace top` + (LABEL_TAC "Atop") THENL + [USE_THEN "lfA" MP_TAC THEN + REWRITE_TAC[locally_finite_in; IN_ELIM_THM; IN_UNIV] THEN + MESON_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[locally_finite_in] THEN + SUBGOAL_THEN + `!s:A->bool. s IN UNIONS {(f:num->(A->bool)->bool) n | n IN (:num)} <=> + ?n. s IN f n` + (fun th -> REWRITE_TAC[th]) THENL + [REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN MESON_TAC[]; + ALL_TAC] THEN + CONJ_TAC THENL + [X_GEN_TAC `s:A->bool` THEN + DISCH_THEN(X_CHOOSE_TAC `n:num`) THEN + ASM_MESON_TAC[SUBSET_TRANS]; + ALL_TAC] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + USE_THEN "lfA" (MP_TAC o CONJUNCT2 o REWRITE_RULE[locally_finite_in]) THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `W0:A->bool` STRIP_ASSUME_TAC) THEN + ABBREV_TAC `N0 = {n:num | ~((A:num->A->bool) n INTER W0 = {})}` THEN + SUBGOAL_THEN `FINITE (N0:num->bool)` ASSUME_TAC THENL + [SUBGOAL_THEN + `!n1 n2:num. n1 IN N0 /\ n2 IN N0 /\ + (A:num->A->bool) n1 = A n2 ==> n1 = n2` + (fun th -> REWRITE_TAC[GSYM(MATCH_MP FINITE_IMAGE_INJ_EQ th)]) THENL + [REPEAT GEN_TAC THEN EXPAND_TAC "N0" THEN + REWRITE_TAC[IN_ELIM_THM] THEN STRIP_TAC THEN + ASM_CASES_TAC `n1:num = n2` THEN ASM_REWRITE_TAC[] THEN + USE_THEN "disj" (MP_TAC o SPECL [`n1:num`; `n2:num`]) THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + ALL_TAC] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC + `{u:A->bool | u IN {(A:num->A->bool) k | k IN (:num)} /\ + ~(u INTER W0 = {})}` THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[SUBSET; FORALL_IN_IMAGE; IN_ELIM_THM; IN_UNIV] THEN + GEN_TAC THEN EXPAND_TAC "N0" THEN REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_TAC THEN ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN + `!n:num. ?W:A->bool. open_in top W /\ x IN W /\ + FINITE {s:A->bool | s IN (f:num->(A->bool)->bool) n /\ + ~(s INTER W = {})}` + MP_TAC THENL + [GEN_TAC THEN + USE_THEN "lfF" (fun th -> + MP_TAC(CONJUNCT2(REWRITE_RULE[locally_finite_in] + (SPEC `n:num` th)))) THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[SKOLEM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `Wfn:num->A->bool` MP_TAC) THEN + REWRITE_TAC[FORALL_AND_THM] THEN STRIP_TAC THEN + ASM_CASES_TAC `N0:num->bool = {}` THENL + [EXISTS_TAC `W0:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC(MESON[FINITE_EMPTY] + `(s:(A->bool)->bool) = {} ==> FINITE s`) THEN + REWRITE_TAC[EXTENSION; IN_ELIM_THM; NOT_IN_EMPTY] THEN + X_GEN_TAC `s:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 (X_CHOOSE_TAC `n0:num`) ASSUME_TAC) THEN + SUBGOAL_THEN `n0 IN (N0:num->bool)` MP_TAC THENL + [EXPAND_TAC "N0" THEN REWRITE_TAC[IN_ELIM_THM] THEN + USE_THEN "sub" (MP_TAC o SPECL [`n0:num`; `s:A->bool`]) THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + ASM_REWRITE_TAC[NOT_IN_EMPTY]]; + ALL_TAC] THEN + EXISTS_TAC `W0 INTER INTERS(IMAGE (Wfn:num->A->bool) N0)` THEN + REPEAT CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_INTER THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC OPEN_IN_INTERS THEN + ASM_SIMP_TAC[FINITE_IMAGE; IMAGE_EQ_EMPTY] THEN + REWRITE_TAC[FORALL_IN_IMAGE] THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[IN_INTER; IN_INTERS; FORALL_IN_IMAGE] THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `UNIONS (IMAGE + (\n. {s:A->bool | s IN (f:num->(A->bool)->bool) n /\ + ~(s INTER (Wfn:num->A->bool) n = {})}) + N0)` THEN + CONJ_TAC THENL + [REWRITE_TAC[FINITE_UNIONS; FORALL_IN_IMAGE] THEN + ASM_SIMP_TAC[FINITE_IMAGE]; + ALL_TAC] THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_UNIONS; EXISTS_IN_IMAGE] THEN + X_GEN_TAC `s:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 (X_CHOOSE_TAC `n0:num`) ASSUME_TAC) THEN + EXISTS_TAC `n0:num` THEN + SUBGOAL_THEN `n0 IN (N0:num->bool)` ASSUME_TAC THENL + [EXPAND_TAC "N0" THEN REWRITE_TAC[IN_ELIM_THM] THEN + USE_THEN "sub" (MP_TAC o SPECL [`n0:num`; `s:A->bool`]) THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + ALL_TAC] THEN + ASM_REWRITE_TAC[IN_ELIM_THM] THEN + SUBGOAL_THEN + `INTERS(IMAGE (Wfn:num->A->bool) N0) SUBSET Wfn n0` + MP_TAC THENL + [REWRITE_TAC[SUBSET; IN_INTERS; FORALL_IN_IMAGE] THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + ASM SET_TAC[]);; + +(* Regularity shrink for open covers: each point gets an open nbhd whose + closure is contained in some member of the original cover *) + +let REGULAR_OPEN_COVER_CLOSURE_SHRINK = prove + (`!top:A topology U. + regular_space top /\ + (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?W. (!w. w IN W ==> open_in top w) /\ + UNIONS W = topspace top /\ + (!w. w IN W ==> ?u. u IN U /\ top closure_of w SUBSET u)`, + REPEAT STRIP_TAC THEN + EXISTS_TAC + `{b:A->bool | open_in top b /\ + ?u. u IN U /\ top closure_of b SUBSET u}` THEN + REWRITE_TAC[IN_ELIM_THM] THEN + CONJ_TAC THENL [SIMP_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL + [MATCH_MP_TAC REGULAR_CLOSURE_REFINEMENT_COVERS THEN + ASM_REWRITE_TAC[]; + SIMP_TAC[]]);; + +(* Point-finite CP closed cover is locally finite *) + +let POINT_FINITE_CP_CLOSED_IMP_LOCALLY_FINITE = prove + (`!top:A topology V. + regular_space top /\ + (!v. v IN V ==> closed_in top v) /\ + UNIONS V = topspace top /\ + (!W. W SUBSET V ==> closed_in top (UNIONS W)) /\ + (!x. x IN topspace top ==> FINITE {v | v IN V /\ x IN v}) + ==> locally_finite_in top V`, + REPEAT STRIP_TAC THEN + REWRITE_TAC[locally_finite_in] THEN + CONJ_TAC THENL + [X_GEN_TAC `v:A->bool` THEN DISCH_TAC THEN + ASM_MESON_TAC[closed_in; SUBSET]; + ALL_TAC] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + ABBREV_TAC `CX = UNIONS {v:A->bool | v IN V /\ ~(x IN v)}` THEN + SUBGOAL_THEN `closed_in top (CX:A->bool)` ASSUME_TAC THENL + [EXPAND_TAC "CX" THEN FIRST_X_ASSUM MATCH_MP_TAC THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `~((x:A) IN CX)` ASSUME_TAC THENL + [EXPAND_TAC "CX" THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `(x:A) IN topspace top DIFF CX` ASSUME_TAC THENL + [ASM_REWRITE_TAC[IN_DIFF]; ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [REGULAR_SPACE]) THEN + DISCH_THEN(MP_TAC o SPECL [`CX:A->bool`; `x:A`]) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `O:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `O:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `{v:A->bool | v IN V /\ x IN v}` THEN + CONJ_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `v:A->bool` THEN STRIP_TAC THEN + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `(O:A->bool) SUBSET top closure_of O` ASSUME_TAC THENL + [MATCH_MP_TAC(ISPEC `top:A topology` CLOSURE_OF_SUBSET) THEN + ASM_MESON_TAC[OPEN_IN_SUBSET]; ALL_TAC] THEN + ASM_CASES_TAC `(x:A) IN v` THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `(v:A->bool) SUBSET CX` ASSUME_TAC THENL + [EXPAND_TAC "CX" THEN REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + EXISTS_TAC `v:A->bool` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + UNDISCH_TAC `~(v INTER (O:A->bool) = {})` THEN REWRITE_TAC[] THEN + UNDISCH_TAC `DISJOINT CX (top closure_of (O:A->bool))` THEN + UNDISCH_TAC `(v:A->bool) SUBSET CX` THEN + UNDISCH_TAC `(O:A->bool) SUBSET top closure_of O` THEN + REWRITE_TAC[DISJOINT] THEN SET_TAC[]);; + +(* Munkres Lemma 41.3 (1)=>(3): a sigma-locally-finite open refinement + (with closure containment) gives an LF closed refinement *) + +let CLF_OPEN_CLOSURE_IMP_LF_CLOSED = prove + (`!top:A topology U R. + (!r. r IN R ==> open_in top r) /\ + UNIONS R = topspace top /\ + (!r. r IN R ==> ?u. u IN U /\ top closure_of r SUBSET u) /\ + sigma_locally_finite_in top R + ==> ?V. (!v. v IN V ==> closed_in top v) /\ + UNIONS V = topspace top /\ + (!v. v IN V ==> ?u. u IN U /\ v SUBSET u) /\ + locally_finite_in top V`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [sigma_locally_finite_in]) THEN + DISCH_THEN(X_CHOOSE_THEN `fn:num->(A->bool)->bool` + (CONJUNCTS_THEN2 (LABEL_TAC "fnlf") (LABEL_TAC "fnR"))) THEN + SUBGOAL_THEN `!n:num. (fn:num->(A->bool)->bool) n SUBSET R` + (LABEL_TAC "fnsub") THENL + [GEN_TAC THEN USE_THEN "fnR" (fun th -> REWRITE_TAC[th]) THEN + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + MESON_TAC[]; + ALL_TAC] THEN + ABBREV_TAC `P = \n:num. UNIONS ((fn:num->(A->bool)->bool) n)` THEN + SUBGOAL_THEN `!n:num. open_in top ((P:num->A->bool) n)` + (LABEL_TAC "Popen") THENL + [GEN_TAC THEN EXPAND_TAC "P" THEN + MATCH_MP_TAC OPEN_IN_UNIONS THEN ASM_MESON_TAC[SUBSET]; + ALL_TAC] THEN + SUBGOAL_THEN `UNIONS {(P:num->A->bool) n | n IN (:num)} = topspace top` + (LABEL_TAC "Pcover") THENL + [MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC; IN_UNIV] THEN + ASM_MESON_TAC[OPEN_IN_SUBSET]; + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN UNIONS R` MP_TAC THENL + [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS] THEN + DISCH_THEN(X_CHOOSE_THEN `r:A->bool` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `?n0:num. (r:A->bool) IN (fn:num->(A->bool)->bool) n0` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `(r:A->bool) IN R` THEN + USE_THEN "fnR" SUBST1_TAC THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN MESON_TAC[]; + ALL_TAC] THEN + EXISTS_TAC `(P:num->A->bool) n0` THEN CONJ_TAC THENL + [EXISTS_TAC `n0:num` THEN REFL_TAC; + EXPAND_TAC "P" THEN REWRITE_TAC[IN_UNIONS] THEN + EXISTS_TAC `r:A->bool` THEN ASM_REWRITE_TAC[]]]; + ALL_TAC] THEN + ABBREV_TAC + `S = \n:num. (P:num->A->bool) n DIFF UNIONS {P k | k < n}` THEN + SUBGOAL_THEN + `locally_finite_in top {(S:num->A->bool) n | n IN (:num)}` + (LABEL_TAC "Slf") THENL + [EXPAND_TAC "S" THEN + MATCH_MP_TAC(ISPEC `top:A topology` SHRINK_SEQUENCE_LOCALLY_FINITE) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN + `UNIONS {(S:num->A->bool) n | n IN (:num)} = topspace top` + (LABEL_TAC "Scover") THENL + [EXPAND_TAC "S" THEN + MATCH_MP_TAC(ISPEC `top:A topology` SHRINK_SEQUENCE_COVERS) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `!m n:num. ~(m = n) ==> (S:num->A->bool) m INTER S n = {}` + (LABEL_TAC "Sdisj") THENL + [EXPAND_TAC "S" THEN REPEAT GEN_TAC THEN DISCH_TAC THEN + FIRST_X_ASSUM(DISJ_CASES_TAC o MATCH_MP + (ARITH_RULE `~(m:num = n) ==> m < n \/ n < m`)) THENL + [MP_TAC(SPECL [`P:num->A->bool`; `m:num`; `n:num`] + SHRINK_DISJOINT_LATER) THEN + ASM_REWRITE_TAC[] THEN + DISCH_TAC THEN MATCH_MP_TAC(SET_RULE + `(s:A->bool) INTER t = {} ==> (s DIFF a) INTER t = {}`) THEN + FIRST_ASSUM ACCEPT_TAC; + MP_TAC(SPECL [`P:num->A->bool`; `n:num`; `m:num`] + SHRINK_DISJOINT_LATER) THEN + ASM_REWRITE_TAC[] THEN + DISCH_TAC THEN MATCH_MP_TAC(SET_RULE + `(s:A->bool) INTER t = {} ==> t INTER (s DIFF a) = {}`) THEN + FIRST_ASSUM ACCEPT_TAC]; + ALL_TAC] THEN + ABBREV_TAC + `Dn = \n:num. {r INTER (S:num->A->bool) n | + r | r IN (fn:num->(A->bool)->bool) n}` THEN + SUBGOAL_THEN `!n:num. locally_finite_in top ((Dn:num->(A->bool)->bool) n)` + (LABEL_TAC "Dnlf") THENL + [GEN_TAC THEN EXPAND_TAC "Dn" THEN + REWRITE_TAC[locally_finite_in; FORALL_IN_GSPEC] THEN + CONJ_TAC THENL + [X_GEN_TAC `r:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC `r:A->bool` THEN + REWRITE_TAC[INTER_SUBSET] THEN + USE_THEN "fnlf" (MP_TAC o CONJUNCT1 o + REWRITE_RULE[locally_finite_in] o SPEC `n:num`) THEN + REWRITE_TAC[FORALL_IN_GSPEC] THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + USE_THEN "fnlf" (MP_TAC o CONJUNCT2 o + REWRITE_RULE[locally_finite_in] o SPEC `n:num`) THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `O:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `O:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `IMAGE (\r:A->bool. r INTER (S:num->A->bool) n) + {r | r IN (fn:num->(A->bool)->bool) n /\ + ~(r INTER O = {})}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN ASM_REWRITE_TAC[]; + REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_IMAGE] THEN + X_GEN_TAC `s:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `r:A->bool` STRIP_ASSUME_TAC) ASSUME_TAC) THEN + EXISTS_TAC `r:A->bool` THEN ASM_REWRITE_TAC[IN_ELIM_THM] THEN + UNDISCH_TAC `~((s:A->bool) INTER (O:A->bool) = {})` THEN + UNDISCH_TAC `(s:A->bool) = r INTER (S:num->A->bool) n` THEN + DISCH_THEN SUBST1_TAC THEN + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + MESON_TAC[]]; + ALL_TAC] THEN + SUBGOAL_THEN + `!n:num (s:A->bool). s IN (Dn:num->(A->bool)->bool) n + ==> s SUBSET (S:num->A->bool) n` + (LABEL_TAC "DnsubS") THENL + [GEN_TAC THEN EXPAND_TAC "Dn" THEN REWRITE_TAC[IN_ELIM_THM] THEN + REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[INTER_SUBSET]; + ALL_TAC] THEN + SUBGOAL_THEN + `locally_finite_in top + (UNIONS {(Dn:num->(A->bool)->bool) n | n IN (:num)})` + (LABEL_TAC "Dlf") THENL + [MATCH_MP_TAC(ISPEC `top:A topology` LOCALLY_FINITE_LEVEL_UNION_GEN) THEN + EXISTS_TAC `S:num->A->bool` THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + EXISTS_TAC + `{top closure_of d:A->bool | + d IN UNIONS {(Dn:num->(A->bool)->bool) n | n IN (:num)}}` THEN + CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_GSPEC] THEN + GEN_TAC THEN DISCH_TAC THEN REWRITE_TAC[CLOSED_IN_CLOSURE_OF]; + ALL_TAC] THEN + CONJ_TAC THENL + [MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + GEN_TAC THEN DISCH_TAC THEN REWRITE_TAC[CLOSURE_OF_SUBSET_TOPSPACE]; + USE_THEN "Scover" (fun th -> GEN_REWRITE_TAC LAND_CONV [SYM th]) THEN + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + X_GEN_TAC `x:A` THEN + DISCH_THEN(X_CHOOSE_THEN `s:A->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_TAC `n0:num`) ASSUME_TAC)) THEN + SUBGOAL_THEN `(x:A) IN (P:num->A->bool) n0` ASSUME_TAC THENL + [UNDISCH_TAC `(x:A) IN (s:A->bool)` THEN + ASM_REWRITE_TAC[] THEN EXPAND_TAC "S" THEN + REWRITE_TAC[IN_DIFF] THEN MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `?r:A->bool. r IN (fn:num->(A->bool)->bool) n0 /\ x IN r` + STRIP_ASSUME_TAC THENL + [EXPAND_TAC "P" THEN + UNDISCH_TAC `(x:A) IN (P:num->A->bool) n0` THEN + EXPAND_TAC "P" THEN + REWRITE_TAC[IN_UNIONS] THEN MESON_TAC[]; + ALL_TAC] THEN + EXISTS_TAC `top closure_of (r INTER (S:num->A->bool) n0)` THEN + CONJ_TAC THENL + [EXISTS_TAC `r INTER (S:num->A->bool) n0` THEN CONJ_TAC THENL + [REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + EXISTS_TAC `(Dn:num->(A->bool)->bool) n0` THEN CONJ_TAC THENL + [EXISTS_TAC `n0:num` THEN REFL_TAC; + EXPAND_TAC "Dn" THEN REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `r:A->bool` THEN ASM_REWRITE_TAC[]]; + REFL_TAC]; + SUBGOAL_THEN `(x:A) IN r INTER (S:num->A->bool) n0` ASSUME_TAC THENL + [REWRITE_TAC[IN_INTER] THEN ASM_MESON_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN `r INTER (S:num->A->bool) n0 SUBSET topspace top` + ASSUME_TAC THENL + [MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC `r:A->bool` THEN + REWRITE_TAC[INTER_SUBSET] THEN + USE_THEN "fnlf" (MP_TAC o CONJUNCT1 o + REWRITE_RULE[locally_finite_in] o SPEC `n0:num`) THEN + DISCH_THEN(MP_TAC o SPEC `r:A->bool`) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `r INTER (S:num->A->bool) n0 SUBSET + top closure_of (r INTER (S:num->A->bool) n0)` + ASSUME_TAC THENL + [MATCH_MP_TAC CLOSURE_OF_SUBSET THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + FIRST_X_ASSUM(MATCH_MP_TAC o REWRITE_RULE[SUBSET]) THEN + ASM_REWRITE_TAC[]]]; + ALL_TAC] THEN + CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_GSPEC] THEN + X_GEN_TAC `d:A->bool` THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `Dn0:(A->bool)->bool` + (CONJUNCTS_THEN2 (X_CHOOSE_TAC `n0:num`) ASSUME_TAC)) THEN + SUBGOAL_THEN `?r:A->bool. r IN (fn:num->(A->bool)->bool) n0 /\ + d = r INTER (S:num->A->bool) n0` + STRIP_ASSUME_TAC THENL + [UNDISCH_TAC `(d:A->bool) IN Dn0` THEN ASM_REWRITE_TAC[] THEN + EXPAND_TAC "Dn" THEN REWRITE_TAC[IN_ELIM_THM] THEN MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `(r:A->bool) IN R` ASSUME_TAC THENL + [USE_THEN "fnsub" (MP_TAC o REWRITE_RULE[SUBSET] o SPEC `n0:num`) THEN + DISCH_THEN(MP_TAC o SPEC `r:A->bool`) THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o SPEC `r:A->bool` o + REWRITE_RULE[IMP_CONJ; RIGHT_FORALL_IMP_THM]) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC (LABEL_TAC "clru"))) THEN + EXISTS_TAC `u:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `top closure_of (r:A->bool)` THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CLOSURE_OF_MONO THEN ASM_REWRITE_TAC[INTER_SUBSET]; + MATCH_MP_TAC(ISPEC `top:A topology` LOCALLY_FINITE_IN_CLOSURES) THEN + ASM_REWRITE_TAC[]]);; + +(* Michael's Lemma 1: Indexed CP closed refinement *) + +let CP_INDEXED_CLOSED_COVER = prove + (`!top:A topology U. + (!U'. (!u. u IN U' ==> open_in top u) /\ UNIONS U' = topspace top + ==> ?V. (!v. v IN V ==> closed_in top v) /\ + UNIONS V = topspace top /\ + (!v. v IN V ==> ?u. u IN U' /\ v SUBSET u) /\ + (!W. W SUBSET V ==> closed_in top (UNIONS W))) /\ + (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?c. (!u. u IN U ==> closed_in top (c u)) /\ + (!u. u IN U ==> c u SUBSET u) /\ + UNIONS {c u | u IN U} = topspace top /\ + (!S. S SUBSET U + ==> closed_in top (UNIONS {c u | u IN S}))`, + REPEAT GEN_TAC THEN + DISCH_THEN(CONJUNCTS_THEN2 (LABEL_TAC "hyp") STRIP_ASSUME_TAC) THEN + USE_THEN "hyp" (MP_TAC o SPEC `U:(A->bool)->bool`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `V:(A->bool)->bool` + (CONJUNCTS_THEN2 (LABEL_TAC "Vcl") + (CONJUNCTS_THEN2 (LABEL_TAC "Vcov") + (CONJUNCTS_THEN2 (LABEL_TAC "Vref") (LABEL_TAC "Vcp"))))) THEN + SUBGOAL_THEN + `?f:(A->bool)->(A->bool). !v. v IN V ==> f v IN U /\ v SUBSET f v` + (X_CHOOSE_THEN `f:(A->bool)->(A->bool)` (LABEL_TAC "fprop")) THENL + [REWRITE_TAC[GSYM SKOLEM_THM] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + EXISTS_TAC + `\u:A->bool. UNIONS {v:A->bool | v IN V /\ + (f:(A->bool)->(A->bool)) v = u}` THEN + REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN + USE_THEN "Vcp" MATCH_MP_TAC THEN SET_TAC[]; + X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN + REWRITE_TAC[UNIONS_SUBSET; IN_ELIM_THM] THEN + ASM_MESON_TAC[]; + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + X_GEN_TAC `u:A->bool` THEN DISCH_TAC THEN + REWRITE_TAC[UNIONS_SUBSET; IN_ELIM_THM] THEN + ASM_MESON_TAC[CLOSED_IN_SUBSET; SUBSET]; + REWRITE_TAC[SUBSET; IN_UNIONS; EXISTS_IN_GSPEC] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:A) IN UNIONS V` MP_TAC THENL + [ASM_MESON_TAC[]; REWRITE_TAC[IN_UNIONS]] THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `(f:(A->bool)->(A->bool)) v` THEN + ASM_SIMP_TAC[] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `v:A->bool` THEN ASM_REWRITE_TAC[]]; + X_GEN_TAC `S:(A->bool)->bool` THEN DISCH_TAC THEN + SUBGOAL_THEN + `UNIONS {UNIONS {v:A->bool | v IN V /\ + (f:(A->bool)->(A->bool)) v = u} | u IN S} = + UNIONS {v:A->bool | v IN V /\ (f:(A->bool)->(A->bool)) v IN S}` + SUBST1_TAC THENL + [GEN_REWRITE_TAC I [EXTENSION] THEN X_GEN_TAC `x:A` THEN + EQ_TAC THENL + [DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_UNIONS]) THEN + REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `t:A->bool` + (CONJUNCTS_THEN2 + (X_CHOOSE_THEN `u0:A->bool` STRIP_ASSUME_TAC) + ASSUME_TAC)) THEN + SUBGOAL_THEN `(x:A) IN UNIONS {v:A->bool | v IN V /\ + (f:(A->bool)->(A->bool)) v = u0}` MP_TAC THENL + [ASM_MESON_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `w:A->bool` THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `w:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC + `UNIONS {v':A->bool | v' IN V /\ + (f:(A->bool)->(A->bool)) v' = + (f:(A->bool)->(A->bool)) w}` THEN + CONJ_TAC THENL + [EXISTS_TAC `(f:(A->bool)->(A->bool)) w` THEN + ASM_REWRITE_TAC[]; + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `w:A->bool` THEN ASM_REWRITE_TAC[]]]; + USE_THEN "Vcp" MATCH_MP_TAC THEN SET_TAC[]]]);; + +(* CP closed refinement hypothesis implies normality *) + +let CP_IMPLIES_NORMAL_SPACE = prove + (`!top:A topology. + (!U. (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?V. (!v. v IN V ==> closed_in top v) /\ + UNIONS V = topspace top /\ + (!v. v IN V ==> ?u. u IN U /\ v SUBSET u) /\ + (!W. W SUBSET V ==> closed_in top (UNIONS W))) + ==> normal_space top`, + GEN_TAC THEN DISCH_THEN(LABEL_TAC "cp") THEN + REWRITE_TAC[normal_space] THEN + MAP_EVERY X_GEN_TAC [`s:A->bool`; `t:A->bool`] THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 ASSUME_TAC (LABEL_TAC "disj"))) THEN + SUBGOAL_THEN `s SUBSET topspace (top:A topology) /\ t SUBSET topspace top` + STRIP_ASSUME_TAC THENL + [ASM_MESON_TAC[CLOSED_IN_SUBSET]; ALL_TAC] THEN + USE_THEN "cp" (MP_TAC o SPEC + `{topspace top DIFF s, topspace top DIFF t}:(A->bool)->bool`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_INSERT; NOT_IN_EMPTY] THEN + CONJ_TAC THEN MATCH_MP_TAC OPEN_IN_DIFF THEN + ASM_REWRITE_TAC[OPEN_IN_TOPSPACE]; + REWRITE_TAC[UNIONS_INSERT; UNIONS_0; UNION_EMPTY] THEN + USE_THEN "disj" MP_TAC THEN + REWRITE_TAC[DISJOINT; EXTENSION; IN_INTER; NOT_IN_EMPTY; + IN_UNION; IN_DIFF] THEN + ASM_MESON_TAC[SUBSET]]; + DISCH_THEN(X_CHOOSE_THEN `V:(A->bool)->bool` + (CONJUNCTS_THEN2 (LABEL_TAC "Vcl") + (CONJUNCTS_THEN2 (LABEL_TAC "Vcov") + (CONJUNCTS_THEN2 (LABEL_TAC "Vref") (LABEL_TAC "Vcp"))))) THEN + SUBGOAL_THEN `!v:A->bool. v IN V + ==> v SUBSET topspace top DIFF s \/ + v SUBSET topspace top DIFF t` + (LABEL_TAC "Vdich") THENL + [X_GEN_TAC `v:A->bool` THEN DISCH_TAC THEN + USE_THEN "Vref" (MP_TAC o SPEC `v:A->bool`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `u:A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC ASSUME_TAC)) THEN + FIRST_X_ASSUM(DISJ_CASES_TAC o + REWRITE_RULE[IN_INSERT; NOT_IN_EMPTY]) THENL + [DISJ1_TAC; DISJ2_TAC] THEN + FIRST_X_ASSUM SUBST_ALL_TAC THEN FIRST_ASSUM ACCEPT_TAC; + ALL_TAC] THEN + ABBREV_TAC `V1 = {v:A->bool | v IN V /\ + v SUBSET (topspace top DIFF s)}` THEN + SUBGOAL_THEN `V1 SUBSET (V:(A->bool)->bool)` ASSUME_TAC THENL + [EXPAND_TAC "V1" THEN REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `closed_in top (UNIONS V1:A->bool)` ASSUME_TAC THENL + [USE_THEN "Vcp" MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `closed_in top (UNIONS (V DIFF V1):A->bool)` + ASSUME_TAC THENL + [USE_THEN "Vcp" MATCH_MP_TAC THEN + REWRITE_TAC[SUBSET; IN_DIFF] THEN MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `!v:A->bool. v IN V DIFF V1 + ==> v SUBSET topspace top DIFF t` ASSUME_TAC THENL + [X_GEN_TAC `v:A->bool` THEN EXPAND_TAC "V1" THEN + REWRITE_TAC[IN_DIFF; IN_ELIM_THM] THEN STRIP_TAC THEN + USE_THEN "Vdich" (MP_TAC o SPEC `v:A->bool`) THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN + `UNIONS V1 UNION UNIONS (V DIFF V1:(A->bool)->bool) = + topspace top:A->bool` ASSUME_TAC THENL + [USE_THEN "Vcov" (fun th -> GEN_REWRITE_TAC RAND_CONV [SYM th]) THEN + UNDISCH_TAC `V1 SUBSET (V:(A->bool)->bool)` THEN + REWRITE_TAC[EXTENSION; IN_UNION; IN_UNIONS; IN_DIFF; SUBSET] THEN + MESON_TAC[]; + ALL_TAC] THEN + EXISTS_TAC `topspace top DIFF UNIONS V1:A->bool` THEN + EXISTS_TAC + `topspace top DIFF UNIONS (V DIFF V1:(A->bool)->bool):A->bool` THEN + SUBGOAL_THEN `UNIONS V1 SUBSET topspace top DIFF (s:A->bool)` + ASSUME_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET] THEN + X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN + UNDISCH_TAC `(w:A->bool) IN V1` THEN + EXPAND_TAC "V1" THEN REWRITE_TAC[IN_ELIM_THM] THEN + MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `UNIONS (V DIFF V1) SUBSET topspace top DIFF (t:A->bool)` + ASSUME_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET] THEN ASM_MESON_TAC[]; + ALL_TAC] THEN + REPEAT CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_DIFF THEN ASM_REWRITE_TAC[OPEN_IN_TOPSPACE]; + MATCH_MP_TAC OPEN_IN_DIFF THEN ASM_REWRITE_TAC[OPEN_IN_TOPSPACE]; + ASM SET_TAC[]; + ASM SET_TAC[]; + ASM SET_TAC[]]]);; + +(* Dowker's expansion lemma: pairwise disjoint open sets in a normal space + with a closed union of inscribed subsets can be expanded to a locally + finite family of open sets *) + +let DOWKER_DISCRETE_EXPANSION = prove + (`!top:A topology (s:K->bool) (f:K->A->bool) (d:K->A->bool). + normal_space top /\ + (!k. k IN s ==> open_in top (f k)) /\ + pairwise (\a b. DISJOINT (f a:A->bool) (f b)) s /\ + (!k. k IN s ==> d k SUBSET f k) /\ + closed_in top (UNIONS {d k | k IN s}) + ==> ?w:K->A->bool. + (!k. k IN s ==> open_in top (w k)) /\ + (!k. k IN s ==> d k SUBSET w k) /\ + (!k. k IN s ==> w k SUBSET f k) /\ + locally_finite_in top {w k | k IN s}`, + let FINITE_AT_MOST_ONE = prove + (`!s:A->bool. (!x y. x IN s /\ y IN s ==> x = y) ==> FINITE s`, + GEN_TAC THEN DISCH_TAC THEN + ASM_CASES_TAC `s:A->bool = {}` THENL + [ASM_REWRITE_TAC[FINITE_EMPTY]; + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN + DISCH_THEN(X_CHOOSE_TAC `a:A`) THEN + MATCH_MP_TAC FINITE_SUBSET THEN EXISTS_TAC `{a:A}` THEN + REWRITE_TAC[FINITE_SING] THEN ASM SET_TAC[]]) in + REPEAT GEN_TAC THEN STRIP_TAC THEN + ABBREV_TAC + `S':A->bool = {x | ?v. open_in top v /\ x IN v /\ + !k1:K k2:K. k1 IN s /\ k2 IN s /\ + ~(v INTER (f:K->A->bool) k1 = {}) /\ + ~(v INTER f k2 = {}) ==> k1 = k2}` THEN + SUBGOAL_THEN `open_in top (S':A->bool)` (LABEL_TAC "Sopen") THENL + [EXPAND_TAC "S'" THEN + GEN_REWRITE_TAC I [OPEN_IN_SUBOPEN] THEN + REWRITE_TAC[IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN + DISCH_THEN(X_CHOOSE_THEN `v0:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `v0:A->bool` THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + EXISTS_TAC `v0:A->bool` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `UNIONS {(d:K->A->bool) k | k IN s} SUBSET S'` + (LABEL_TAC "dinS") THENL + [EXPAND_TAC "S'" THEN + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN + DISCH_THEN(X_CHOOSE_THEN `t:A->bool` + (CONJUNCTS_THEN2 + (X_CHOOSE_THEN `k0:K` STRIP_ASSUME_TAC) + ASSUME_TAC)) THEN + EXISTS_TAC `(f:K->A->bool) k0` THEN ASM_SIMP_TAC[] THEN + CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN + MAP_EVERY X_GEN_TAC [`k1:K`; `k2:K`] THEN STRIP_TAC THEN + SUBGOAL_THEN `!k':K. k' IN s /\ ~((f:K->A->bool) k0 INTER f k' = {}) + ==> k' = k0` + (fun th -> ASM_MESON_TAC[th]) THEN + X_GEN_TAC `k':K` THEN STRIP_TAC THEN + MATCH_MP_TAC(TAUT `(~p ==> F) ==> p`) THEN DISCH_TAC THEN + UNDISCH_TAC `~((f:K->A->bool) k0 INTER f k' = {})` THEN + REWRITE_TAC[] THEN + UNDISCH_TAC `pairwise (\a b. DISJOINT ((f:K->A->bool) a) (f b)) s` THEN + REWRITE_TAC[pairwise] THEN + DISCH_THEN(MP_TAC o SPECL [`k0:K`; `k':K`]) THEN + ASM_REWRITE_TAC[DISJOINT]; + ALL_TAC] THEN + SUBGOAL_THEN + `?R:A->bool. open_in top R /\ + UNIONS {(d:K->A->bool) k | k IN s} SUBSET R /\ + top closure_of R SUBSET S'` + (X_CHOOSE_THEN `R:A->bool` STRIP_ASSUME_TAC) THENL + [FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [normal_space]) THEN + DISCH_THEN(MP_TAC o SPECL + [`UNIONS {(d:K->A->bool) k | k IN s}`; + `topspace top DIFF S':A->bool`]) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN CONJ_TAC THENL + [MATCH_MP_TAC CLOSED_IN_DIFF THEN + ASM_REWRITE_TAC[CLOSED_IN_TOPSPACE]; + REWRITE_TAC[DISJOINT] THEN + MATCH_MP_TAC(SET_RULE + `(d:A->bool) SUBSET s /\ s SUBSET u + ==> d INTER (u DIFF s) = {}`) THEN + ASM_SIMP_TAC[OPEN_IN_SUBSET]]; + DISCH_THEN(X_CHOOSE_THEN `u0:A->bool` + (X_CHOOSE_THEN `v0:A->bool` STRIP_ASSUME_TAC)) THEN + EXISTS_TAC `u0:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `topspace top DIFF v0:A->bool` THEN CONJ_TAC THENL + [MATCH_MP_TAC CLOSURE_OF_MINIMAL THEN CONJ_TAC THENL + [SUBGOAL_THEN `u0 SUBSET topspace top:A->bool` MP_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET]; ALL_TAC] THEN + UNDISCH_TAC `DISJOINT u0 (v0:A->bool)` THEN + REWRITE_TAC[DISJOINT] THEN SET_TAC[]; + MATCH_MP_TAC CLOSED_IN_DIFF THEN + ASM_REWRITE_TAC[CLOSED_IN_TOPSPACE]]; + SUBGOAL_THEN `S' SUBSET topspace top:A->bool` MP_TAC THENL + [ASM_MESON_TAC[OPEN_IN_SUBSET]; ALL_TAC] THEN + UNDISCH_TAC `topspace top DIFF S' SUBSET (v0:A->bool)` THEN + SET_TAC[]]]; + ALL_TAC] THEN + EXISTS_TAC `\k:K. (f:K->A->bool) k INTER R` THEN + REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [X_GEN_TAC `k:K` THEN DISCH_TAC THEN + MATCH_MP_TAC OPEN_IN_INTER THEN ASM_SIMP_TAC[]; + X_GEN_TAC `k:K` THEN DISCH_TAC THEN + MATCH_MP_TAC(SET_RULE + `(a:A->bool) SUBSET b /\ a SUBSET c ==> a SUBSET b INTER c`) THEN + ASM_SIMP_TAC[] THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `UNIONS {(d:K->A->bool) k | k IN s}` THEN + ASM_REWRITE_TAC[] THEN + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + EXISTS_TAC `(d:K->A->bool) k` THEN ASM_REWRITE_TAC[] THEN + EXISTS_TAC `k:K` THEN ASM_REWRITE_TAC[]; + GEN_TAC THEN DISCH_TAC THEN REWRITE_TAC[INTER_SUBSET]; + REWRITE_TAC[locally_finite_in] THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + X_GEN_TAC `k:K` THEN DISCH_TAC THEN + MATCH_MP_TAC(SET_RULE + `(a:A->bool) SUBSET t ==> a INTER r SUBSET t`) THEN + ASM_MESON_TAC[OPEN_IN_SUBSET]; + ALL_TAC] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + ASM_CASES_TAC `(x:A) IN top closure_of R` THENL + [SUBGOAL_THEN `(x:A) IN S'` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + UNDISCH_TAC `(x:A) IN S'` THEN EXPAND_TAC "S'" THEN + REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `v1:A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 ASSUME_TAC (LABEL_TAC "atmost1")))) THEN + EXISTS_TAC `v1:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `IMAGE (\k:K. (f:K->A->bool) k INTER R) + {k | k IN s /\ ~((f k INTER R) INTER v1 = {})}` THEN + CONJ_TAC THENL + [MATCH_MP_TAC FINITE_IMAGE THEN + MATCH_MP_TAC FINITE_AT_MOST_ONE THEN + REWRITE_TAC[IN_ELIM_THM] THEN + MAP_EVERY X_GEN_TAC [`k1:K`; `k2:K`] THEN STRIP_TAC THEN + USE_THEN "atmost1" MATCH_MP_TAC THEN + ASM_REWRITE_TAC[] THEN + CONJ_TAC THENL + [UNDISCH_TAC `~(((f:K->A->bool) k1 INTER R) INTER v1 = {})` THEN + SET_TAC[]; + UNDISCH_TAC `~(((f:K->A->bool) k2 INTER R) INTER v1 = {})` THEN + SET_TAC[]]; + REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_IMAGE] THEN + X_GEN_TAC `t:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `k0:K` STRIP_ASSUME_TAC) ASSUME_TAC) THEN + EXISTS_TAC `k0:K` THEN ASM_REWRITE_TAC[IN_ELIM_THM] THEN + ASM_MESON_TAC[]]; + EXISTS_TAC `topspace top DIFF top closure_of R:A->bool` THEN + REPEAT CONJ_TAC THENL + [MATCH_MP_TAC OPEN_IN_DIFF THEN + REWRITE_TAC[OPEN_IN_TOPSPACE; CLOSED_IN_CLOSURE_OF]; + ASM SET_TAC[]; + MATCH_MP_TAC FINITE_SUBSET THEN + EXISTS_TAC `{}:(A->bool)->bool` THEN + REWRITE_TAC[FINITE_EMPTY; SUBSET; NOT_IN_EMPTY; IN_ELIM_THM] THEN + X_GEN_TAC `t:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 + (X_CHOOSE_THEN `k0:K` STRIP_ASSUME_TAC) ASSUME_TAC) THEN + SUBGOAL_THEN `(f:K->A->bool) k0 INTER R SUBSET top closure_of R` + MP_TAC THENL + [MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC `R:A->bool` THEN + REWRITE_TAC[INTER_SUBSET] THEN + MATCH_MP_TAC CLOSURE_OF_SUBSET THEN + ASM_MESON_TAC[OPEN_IN_SUBSET]; + UNDISCH_TAC + `~(t INTER (topspace top DIFF top closure_of R:A->bool) = + {})` THEN + ASM_REWRITE_TAC[] THEN SET_TAC[]]]]]);; + +(* Helper: LF closed refinement property implies paracompactness + (when regularity is available). Uses LF_COVERING_IMP_LF_OPEN. *) + +let CLOSED_REFINEMENT_IMP_PARACOMPACT = prove + (`!top:A topology. + regular_space top /\ + (!U. (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?V. (!v. v IN V ==> closed_in top v) /\ + UNIONS V = topspace top /\ + (!v. v IN V ==> ?u. u IN U /\ v SUBSET u) /\ + locally_finite_in top V) + ==> paracompact_space top`, + GEN_TAC THEN STRIP_TAC THEN + REWRITE_TAC[paracompact_space] THEN + X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + MP_TAC(ISPEC `top:A topology` LF_COVERING_IMP_LF_OPEN) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[] THEN + X_GEN_TAC `B:(A->bool)->bool` THEN STRIP_TAC THEN + FIRST_X_ASSUM(MP_TAC o SPEC `B:(A->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `C:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `C:(A->bool)->bool` THEN ASM_REWRITE_TAC[]; + DISCH_THEN(MP_TAC o SPEC `U:(A->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `W:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `W:(A->bool)->bool` THEN ASM_REWRITE_TAC[]]);; + +let MICHAEL_PARACOMPACT = prove + (`!top:A topology. + regular_space top /\ + (!U. (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?V. (!v. v IN V ==> closed_in top v) /\ + UNIONS V = topspace top /\ + (!v. v IN V ==> ?u. u IN U /\ v SUBSET u) /\ + (!W. W SUBSET V ==> closed_in top (UNIONS W))) + ==> paracompact_space top`, + GEN_TAC THEN + DISCH_THEN(CONJUNCTS_THEN2 (LABEL_TAC "reg") (LABEL_TAC "cp")) THEN + MATCH_MP_TAC CLOSED_REFINEMENT_IMP_PARACOMPACT THEN + ASM_REWRITE_TAC[] THEN + X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + (* Shrink cover by regularity *) + MP_TAC(ISPECL [`top:A topology`; `U:(A->bool)->bool`] + REGULAR_OPEN_COVER_CLOSURE_SHRINK) THEN + ANTS_TAC THENL + [USE_THEN "reg" (fun th -> ASM_REWRITE_TAC[th]); ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `W:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + (* Build sigma-LF open refinement with closure containment in U *) + SUBGOAL_THEN + `?R:(A->bool)->bool. + (!r. r IN R ==> open_in top r) /\ + UNIONS R = topspace top /\ + (!r. r IN R ==> ?u. u IN U /\ top closure_of r SUBSET u) /\ + sigma_locally_finite_in top R` + STRIP_ASSUME_TAC THENL + [(* ============================================================== *) + (* Michael's iterative construction: produce sigma-LF open R *) + (* ============================================================== *) + (* Step 1: Normality from CP *) + SUBGOAL_THEN `normal_space (top:A topology)` (LABEL_TAC "norm") THENL + [MATCH_MP_TAC CP_IMPLIES_NORMAL_SPACE THEN + USE_THEN "cp" ACCEPT_TAC; ALL_TAC] THEN + (* Step 2: Well-order W *) + MP_TAC(ISPEC `W:(A->bool)->bool` WO) THEN + DISCH_THEN(X_CHOOSE_THEN `ord:(A->bool)->(A->bool)->bool` + (CONJUNCTS_THEN2 (LABEL_TAC "wos") (LABEL_TAC "fldW"))) THEN + (* Step 3: Initial CP indexed closed cover of W *) + MP_TAC(ISPECL [`top:A topology`; `W:(A->bool)->bool`] + CP_INDEXED_CLOSED_COVER) THEN + ANTS_TAC THENL + [CONJ_TAC THENL [USE_THEN "cp" ACCEPT_TAC; ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `c0:(A->bool)->(A->bool)` + (CONJUNCTS_THEN2 (LABEL_TAC "c0cl") + (CONJUNCTS_THEN2 (LABEL_TAC "c0sub") + (CONJUNCTS_THEN2 (LABEL_TAC "c0cov") (LABEL_TAC "c0cp"))))) THEN + (* Step 3b: Define nxt using Hilbert choice *) + ABBREV_TAC + `nxt = \(c:(A->bool)->(A->bool)). + @c':(A->bool)->(A->bool). + (!w:A->bool. w IN W ==> closed_in top (c' w)) /\ + (!w:A->bool. w IN W ==> + c' w SUBSET w DIFF + UNIONS {c v | v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v w /\ ~(v = w)}) /\ + UNIONS {c' w | w IN W} = topspace top /\ + (!ss:(A->bool)->bool. ss SUBSET W ==> + closed_in top (UNIONS {c' w | w IN ss}))` THEN + (* Step 4: Build sequence C : num -> ((A->bool) -> (A->bool)) *) + MP_TAC(ISPECL + [`c0:(A->bool)->(A->bool)`; + `\(c:(A->bool)->(A->bool)) (n:num). + (nxt:((A->bool)->(A->bool))->(A->bool)->(A->bool)) c`] + num_RECURSION) THEN + DISCH_THEN(X_CHOOSE_THEN `C:num->(A->bool)->(A->bool)` + (CONJUNCTS_THEN2 (LABEL_TAC "C0") (LABEL_TAC "Csuc"))) THEN + (* Step 4a: C n has the CP properties for all n (by induction) *) + SUBGOAL_THEN + `!n:num. + (!w:A->bool. w IN W ==> closed_in top (C n w)) /\ + (!w:A->bool. w IN W ==> C n w SUBSET w) /\ + UNIONS {(C:num->(A->bool)->(A->bool)) n w | w IN W} = + topspace top /\ + (!ss:(A->bool)->bool. ss SUBSET W ==> + closed_in top (UNIONS {C n w | w IN ss}))` + (LABEL_TAC "Cvalid") THENL + [INDUCT_TAC THENL + [(* Base case: n = 0, C 0 = c0 *) + USE_THEN "C0" (fun th -> REWRITE_TAC[th]) THEN + USE_THEN "c0cl" (fun cl -> + USE_THEN "c0sub" (fun sub -> + USE_THEN "c0cov" (fun cov -> + USE_THEN "c0cp" (fun cp -> + ACCEPT_TAC(CONJ cl (CONJ sub (CONJ cov cp))))))); + (* Inductive step: IH for C n, prove for C(SUC n) *) + POP_ASSUM(fun ih -> + LABEL_TAC "IHcl" (CONJUNCT1 ih) THEN + LABEL_TAC "IHsub" (CONJUNCT1(CONJUNCT2 ih)) THEN + LABEL_TAC "IHcov" (CONJUNCT1(CONJUNCT2(CONJUNCT2 ih))) THEN + LABEL_TAC "IHcp" (CONJUNCT2(CONJUNCT2(CONJUNCT2 ih)))) THEN + (* Step I-1: The predecessor-reduced open sets cover topspace *) + SUBGOAL_THEN + `(!w:A->bool. w IN W ==> + open_in top (w DIFF UNIONS + {(C:num->(A->bool)->(A->bool)) n v | v | + v IN W /\ (ord:(A->bool)->(A->bool)->bool) v w /\ + ~(v = w)})) /\ + UNIONS {w DIFF UNIONS + {(C:num->(A->bool)->(A->bool)) n v | v | + v IN W /\ (ord:(A->bool)->(A->bool)->bool) v w /\ + ~(v = w)} | w | w IN W} = topspace top` + STRIP_ASSUME_TAC THENL + [CONJ_TAC THENL + [(* Each element is open: w is open, UNIONS{C n v|...} closed *) + X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC OPEN_IN_DIFF THEN CONJ_TAC THENL + [ASM_MESON_TAC[]; + USE_THEN "IHcp" (MP_TAC o SPEC + `{v:A->bool | v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v w /\ + ~(v = w)}`) THEN + ANTS_TAC THENL + [REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN MESON_TAC[]; + REWRITE_TAC[IN_ELIM_THM]]]; + (* The family covers topspace *) + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + X_GEN_TAC `ww:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `ww:A->bool` THEN + CONJ_TAC THENL [SET_TAC[]; ASM_MESON_TAC[OPEN_IN_SUBSET]]; + (* topspace SUBSET UNIONS{...} via well-ordering least element *) + REWRITE_TAC[SUBSET] THEN + X_GEN_TAC `xx:A` THEN DISCH_TAC THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + (* Find ord-least ww with xx IN C n ww *) + USE_THEN "wos" + (MP_TAC o CONJUNCT2 o REWRITE_RULE[WOSET]) THEN + USE_THEN "fldW" (fun th -> REWRITE_TAC[th]) THEN + DISCH_THEN(MP_TAC o SPEC + `{w:A->bool | w IN W /\ + (xx:A) IN (C:num->(A->bool)->(A->bool)) n w}`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN MESON_TAC[]; + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + SUBGOAL_THEN + `(xx:A) IN UNIONS + {(C:num->(A->bool)->(A->bool)) n w | w IN W}` + MP_TAC THENL + [USE_THEN "IHcov" (fun th -> ASM_REWRITE_TAC[th]); + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + MESON_TAC[]]]; + ALL_TAC] THEN + REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `ww:A->bool` + STRIP_ASSUME_TAC) THEN + (* ww is ord-least with xx IN C n ww *) + EXISTS_TAC + `ww DIFF UNIONS + {(C:num->(A->bool)->(A->bool)) n v | v | + v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v ww /\ + ~(v = ww)}` THEN + CONJ_TAC THENL + [EXISTS_TAC `ww:A->bool` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[IN_DIFF; IN_UNIONS; IN_ELIM_THM] THEN + CONJ_TAC THENL + [USE_THEN "IHsub" (MP_TAC o SPEC `ww:A->bool`) THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + REWRITE_TAC[NOT_EXISTS_THM; + TAUT `~(p /\ q) <=> p ==> ~q`] THEN + X_GEN_TAC `ss:A->bool` THEN + DISCH_THEN(X_CHOOSE_THEN `vv:A->bool` + STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + MP_TAC(MATCH_MP WOSET_ANTISYM + (ASSUME + `woset(ord:(A->bool)->(A->bool)->bool)`)) THEN + ASM_MESON_TAC[]]]]; + ALL_TAC] THEN + (* Step I-2: Apply CP to get indexed closed cover *) + SUBGOAL_THEN + `?c':(A->bool)->(A->bool). + (!w. w IN W ==> closed_in top (c' w)) /\ + (!w:A->bool. w IN W ==> + c' w SUBSET w DIFF UNIONS + {(C:num->(A->bool)->(A->bool)) n v | + v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v w /\ + ~(v = w)}) /\ + UNIONS {c' w | w IN W} = topspace top /\ + (!ss:(A->bool)->bool. ss SUBSET W ==> + closed_in top (UNIONS {c' w | w IN ss}))` + STRIP_ASSUME_TAC THENL + [(* Apply CP to the open cover *) + USE_THEN "cp" (MP_TAC o SPEC + `{w DIFF UNIONS + {(C:num->(A->bool)->(A->bool)) n v | v | + v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v w /\ + ~(v = w)} | + w | (w:A->bool) IN W}`) THEN + ANTS_TAC THENL + [ASM_REWRITE_TAC[FORALL_IN_GSPEC]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `V:(A->bool)->bool` + (CONJUNCTS_THEN2 (LABEL_TAC "Vcl") + (CONJUNCTS_THEN2 (LABEL_TAC "Vcov") + (CONJUNCTS_THEN2 (LABEL_TAC "Vref") + (LABEL_TAC "Vcp"))))) THEN + (* For each v IN V, pick g(v) IN W with v SUBSET OO(g(v)) *) + SUBGOAL_THEN + `?g:(A->bool)->(A->bool). !v:A->bool. v IN V ==> + g v IN W /\ + v SUBSET g v DIFF UNIONS + {(C:num->(A->bool)->(A->bool)) n u | + u IN W /\ + (ord:(A->bool)->(A->bool)->bool) u (g v) /\ + ~(u = g v)}` + (X_CHOOSE_THEN `g:(A->bool)->(A->bool)` + (LABEL_TAC "gprop")) THENL + [REWRITE_TAC[GSYM SKOLEM_THM] THEN + X_GEN_TAC `v:A->bool` THEN + ASM_CASES_TAC `(v:A->bool) IN V` THENL + [USE_THEN "Vref" (MP_TAC o SPEC `v:A->bool`) THEN + ANTS_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `oo:A->bool` + (CONJUNCTS_THEN2 MP_TAC ASSUME_TAC)) THEN + REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `w':A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST_ALL_TAC)) THEN + EXISTS_TAC `w':A->bool` THEN + DISCH_TAC THEN ASM_REWRITE_TAC[]; + EXISTS_TAC `v:A->bool` THEN ASM_MESON_TAC[]]; + ALL_TAC] THEN + (* Define c'(w) = UNIONS{v IN V | g(v) = w} *) + EXISTS_TAC + `\w:A->bool. UNIONS {v:A->bool | v IN V /\ + (g:(A->bool)->(A->bool)) v = w}` THEN + REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [(* c'(w) closed: {v | v IN V /\ g v = w} SUBSET V *) + X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN + USE_THEN "Vcp" MATCH_MP_TAC THEN SET_TAC[]; + (* c'(w) SUBSET OO(w) *) + X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN + REWRITE_TAC[UNIONS_SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `v:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (fun th -> SUBST_ALL_TAC(SYM th))) THEN + USE_THEN "gprop" (MP_TAC o SPEC `v:A->bool`) THEN + ANTS_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]); + (* UNIONS{c'(w) | w IN W} = topspace *) + USE_THEN "Vcov" (fun th -> REWRITE_TAC[SYM th]) THEN + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN + REWRITE_TAC[UNIONS_SUBSET; IN_ELIM_THM] THEN + SET_TAC[]; + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` + STRIP_ASSUME_TAC) THEN + EXISTS_TAC `UNIONS {v':A->bool | v' IN V /\ + (g:(A->bool)->(A->bool)) v' = + (g:(A->bool)->(A->bool)) v}` THEN + CONJ_TAC THENL + [REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `(g:(A->bool)->(A->bool)) v` THEN + CONJ_TAC THENL + [USE_THEN "gprop" (MP_TAC o SPEC `v:A->bool`) THEN + ANTS_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + MESON_TAC[]; + REFL_TAC]; + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `v:A->bool` THEN ASM_REWRITE_TAC[]]]; + (* CP: UNIONS{c'(w) | w IN ss} closed *) + X_GEN_TAC `ss:(A->bool)->bool` THEN DISCH_TAC THEN + SUBGOAL_THEN + `UNIONS {UNIONS {v:A->bool | v IN V /\ + (g:(A->bool)->(A->bool)) v = w} | + (w:A->bool) IN ss} = + UNIONS {v:A->bool | v IN V /\ g v IN ss}` + (fun th -> REWRITE_TAC[th]) THENL + [MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [(* forward *) + REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + X_GEN_TAC `ww:A->bool` THEN DISCH_TAC THEN + REWRITE_TAC[UNIONS_SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `vv:A->bool` THEN DISCH_TAC THEN + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + EXISTS_TAC `vv:A->bool` THEN + ASM_MESON_TAC[]; + (* backward *) + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `y:A` THEN + DISCH_THEN(X_CHOOSE_THEN `vv:A->bool` + STRIP_ASSUME_TAC) THEN + EXISTS_TAC + `UNIONS {v':A->bool | v' IN V /\ + (g:(A->bool)->(A->bool)) v' = + (g:(A->bool)->(A->bool)) vv}` THEN + CONJ_TAC THENL + [EXISTS_TAC `(g:(A->bool)->(A->bool)) vv` THEN + ASM_REWRITE_TAC[]; + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `vv:A->bool` THEN ASM_REWRITE_TAC[]]]; + USE_THEN "Vcp" MATCH_MP_TAC THEN SET_TAC[]]]; + ALL_TAC] THEN + (* Step I-3: nxt(C n) satisfies the properties via SELECT *) + SUBGOAL_THEN + `(!w:A->bool. w IN W ==> + closed_in top + ((nxt:((A->bool)->(A->bool))->(A->bool)->(A->bool)) + ((C:num->(A->bool)->(A->bool)) n) w)) /\ + (!w:A->bool. w IN W ==> + nxt (C n) w SUBSET w DIFF UNIONS + {C n v | v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v w /\ ~(v = w)}) /\ + UNIONS {nxt (C n) w | w IN W} = topspace top /\ + (!ss:(A->bool)->bool. ss SUBSET W ==> + closed_in top (UNIONS {nxt (C n) w | w IN ss}))` + STRIP_ASSUME_TAC THENL + [(* nxt(C n) = @c'. P(C n, c'), and we have ?c'. P(C n, c') *) + (* Build the existential from assumptions, then use SELECT_RULE *) + SUBGOAL_THEN + `?c':(A->bool)->(A->bool). + (!w. w IN W ==> closed_in top (c' w)) /\ + (!w:A->bool. w IN W ==> + c' w SUBSET w DIFF UNIONS + {(C:num->(A->bool)->(A->bool)) n v | + v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v w /\ + ~(v = w)}) /\ + UNIONS {c' w | w IN W} = topspace top /\ + (!ss:(A->bool)->bool. ss SUBSET W ==> + closed_in top (UNIONS {c' w | w IN ss}))` + MP_TAC THENL + [EXISTS_TAC `c':(A->bool)->(A->bool)` THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + EXPAND_TAC "nxt" THEN REWRITE_TAC[] THEN + DISCH_THEN(fun th -> ACCEPT_TAC(SELECT_RULE th)); + ALL_TAC] THEN + (* Step I-4: Extract the 4 Cvalid properties for C(SUC n) *) + USE_THEN "Csuc" (fun th -> + REWRITE_TAC[SPEC `n:num` th]) THEN + REWRITE_TAC[] THEN + REPEAT CONJ_TAC THENL + [ASM_REWRITE_TAC[]; + (* C(SUC n) w SUBSET w: from nxt SUBSET w DIFF ... SUBSET w *) + X_GEN_TAC `w:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `w DIFF UNIONS + {(C:num->(A->bool)->(A->bool)) n v | + v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v w /\ + ~(v = w)}` THEN + CONJ_TAC THENL + [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + SET_TAC[]]; + ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[]]]; + ALL_TAC] THEN + (* Step 4a2: Stronger subset property via nxt/SELECT *) + SUBGOAL_THEN + `!n:num w:A->bool. w IN W ==> + (C:num->(A->bool)->(A->bool)) (SUC n) w SUBSET + w DIFF UNIONS {C n v | v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v w /\ ~(v = w)}` + (LABEL_TAC "Csub_strong") THENL + [REPEAT STRIP_TAC THEN + USE_THEN "Csuc" (fun th -> REWRITE_TAC[SPEC `n:num` th]) THEN + REWRITE_TAC[] THEN + (* Expand nxt so goal becomes (@c'. P(C n, c')) w SUBSET ... *) + EXPAND_TAC "nxt" THEN REWRITE_TAC[] THEN + (* Show ?c'. P(C n, c'), then SELECT gives the result *) + USE_THEN "Cvalid" (MP_TAC o SPEC `n:num`) THEN + DISCH_THEN(CONJUNCTS_THEN2 (LABEL_TAC "Ccl_n") + (CONJUNCTS_THEN2 (LABEL_TAC "Csb_n") + (CONJUNCTS_THEN2 (LABEL_TAC "Ccv_n") + (LABEL_TAC "Ccp_n")))) THEN + SUBGOAL_THEN + `?c':(A->bool)->(A->bool). + (!w'. w' IN W ==> closed_in top (c' w')) /\ + (!w':A->bool. w' IN W ==> + c' w' SUBSET w' DIFF UNIONS + {(C:num->(A->bool)->(A->bool)) n v | v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v w' /\ ~(v = w')}) /\ + UNIONS {c' w' | w' IN W} = topspace top /\ + (!ss:(A->bool)->bool. ss SUBSET W ==> + closed_in top (UNIONS {c' w' | w' IN ss}))` + (fun th -> + let sr = SELECT_RULE th in + ACCEPT_TAC(MP (SPEC `w:A->bool` (CONJUNCT1(CONJUNCT2 sr))) + (ASSUME `(w:A->bool) IN W`))) THEN + (* Prove existence via cp *) + USE_THEN "cp" (MP_TAC o SPEC + `{w' DIFF UNIONS + {(C:num->(A->bool)->(A->bool)) n v | v | + v IN W /\ (ord:(A->bool)->(A->bool)->bool) v w' /\ + ~(v = w')} | + w' | (w':A->bool) IN W}`) THEN + ANTS_TAC THENL + [REWRITE_TAC[FORALL_IN_GSPEC] THEN CONJ_TAC THENL + [(* Each OO(w') is open *) + X_GEN_TAC `w':A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC OPEN_IN_DIFF THEN CONJ_TAC THENL + [ASM_MESON_TAC[]; + USE_THEN "Ccp_n" (MP_TAC o SPEC + `{v:A->bool | v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v w' /\ + ~(v = w')}`) THEN + ANTS_TAC THENL + [REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN MESON_TAC[]; + REWRITE_TAC[IN_ELIM_THM]]]; + (* UNIONS covers topspace - well-ordering argument *) + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + X_GEN_TAC `w':A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `w':A->bool` THEN + CONJ_TAC THENL [SET_TAC[]; ASM_MESON_TAC[OPEN_IN_SUBSET]]; + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `xx:A` THEN DISCH_TAC THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + USE_THEN "wos" + (MP_TAC o CONJUNCT2 o REWRITE_RULE[WOSET]) THEN + USE_THEN "fldW" (fun th -> REWRITE_TAC[th]) THEN + DISCH_THEN(MP_TAC o SPEC + `{ww:A->bool | ww IN W /\ + (xx:A) IN (C:num->(A->bool)->(A->bool)) n ww}`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN MESON_TAC[]; + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + SUBGOAL_THEN + `(xx:A) IN UNIONS + {(C:num->(A->bool)->(A->bool)) n ww | ww IN W}` + MP_TAC THENL + [USE_THEN "Ccv_n" (fun th -> ASM_REWRITE_TAC[th]); + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + MESON_TAC[]]]; + ALL_TAC] THEN + REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `ww:A->bool` + STRIP_ASSUME_TAC) THEN + EXISTS_TAC + `ww DIFF UNIONS + {(C:num->(A->bool)->(A->bool)) n v | v | + v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v ww /\ + ~(v = ww)}` THEN + CONJ_TAC THENL + [EXISTS_TAC `ww:A->bool` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[IN_DIFF; IN_UNIONS; IN_ELIM_THM] THEN + CONJ_TAC THENL + [USE_THEN "Csb_n" (MP_TAC o SPEC `ww:A->bool`) THEN + ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; + REWRITE_TAC[NOT_EXISTS_THM; + TAUT `~(p /\ q) <=> p ==> ~q`] THEN + X_GEN_TAC `ss:A->bool` THEN + DISCH_THEN(X_CHOOSE_THEN `vv:A->bool` + STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN DISCH_TAC THEN + MP_TAC(MATCH_MP WOSET_ANTISYM + (ASSUME + `woset(ord:(A->bool)->(A->bool)->bool)`)) THEN + ASM_MESON_TAC[]]]]; + ALL_TAC] THEN + (* Got V from CP. Construct c' indexed by W *) + DISCH_THEN(X_CHOOSE_THEN `V2:(A->bool)->bool` + (CONJUNCTS_THEN2 (LABEL_TAC "V2cl") + (CONJUNCTS_THEN2 (LABEL_TAC "V2cov") + (CONJUNCTS_THEN2 (LABEL_TAC "V2ref") + (LABEL_TAC "V2cp"))))) THEN + SUBGOAL_THEN + `?g2:(A->bool)->(A->bool). !v:A->bool. v IN V2 ==> + g2 v IN W /\ + v SUBSET g2 v DIFF UNIONS + {(C:num->(A->bool)->(A->bool)) n u | + u IN W /\ + (ord:(A->bool)->(A->bool)->bool) u (g2 v) /\ + ~(u = g2 v)}` + (X_CHOOSE_THEN `g2:(A->bool)->(A->bool)` + (LABEL_TAC "g2prop")) THENL + [REWRITE_TAC[GSYM SKOLEM_THM] THEN + X_GEN_TAC `v:A->bool` THEN + ASM_CASES_TAC `(v:A->bool) IN V2` THENL + [USE_THEN "V2ref" (MP_TAC o SPEC `v:A->bool`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_ELIM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `oo:A->bool` + (CONJUNCTS_THEN2 MP_TAC ASSUME_TAC)) THEN + DISCH_THEN(X_CHOOSE_THEN `w':A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST_ALL_TAC)) THEN + EXISTS_TAC `w':A->bool` THEN + DISCH_TAC THEN CONJ_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; + FIRST_ASSUM ACCEPT_TAC]; + EXISTS_TAC `v:A->bool` THEN ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + EXISTS_TAC + `\w':A->bool. UNIONS {v:A->bool | v IN V2 /\ + (g2:(A->bool)->(A->bool)) v = w'}` THEN + REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL + [(* closed *) + X_GEN_TAC `w':A->bool` THEN DISCH_TAC THEN + USE_THEN "V2cp" MATCH_MP_TAC THEN SET_TAC[]; + (* subset *) + X_GEN_TAC `w':A->bool` THEN DISCH_TAC THEN + REWRITE_TAC[UNIONS_SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `v:A->bool` THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (fun th -> SUBST_ALL_TAC(SYM th))) THEN + USE_THEN "g2prop" (MP_TAC o SPEC `v:A->bool`) THEN + ANTS_TAC THENL + [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + DISCH_THEN(fun th -> REWRITE_TAC[th]); + (* covering *) + USE_THEN "V2cov" (fun th -> REWRITE_TAC[SYM th]) THEN + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + X_GEN_TAC `w':A->bool` THEN DISCH_TAC THEN + REWRITE_TAC[UNIONS_SUBSET; IN_ELIM_THM] THEN + X_GEN_TAC `v:A->bool` THEN DISCH_TAC THEN + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + EXISTS_TAC `v:A->bool` THEN ASM_MESON_TAC[]; + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `y:A` THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` + STRIP_ASSUME_TAC) THEN + EXISTS_TAC + `UNIONS {v':A->bool | v' IN V2 /\ + (g2:(A->bool)->(A->bool)) v' = g2 v}` THEN + CONJ_TAC THENL + [EXISTS_TAC `(g2:(A->bool)->(A->bool)) v` THEN + CONJ_TAC THENL + [ASM_MESON_TAC[]; + REFL_TAC]; + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `v:A->bool` THEN ASM_REWRITE_TAC[]]]; + (* cp *) + X_GEN_TAC `ss:(A->bool)->bool` THEN DISCH_TAC THEN + SUBGOAL_THEN + `UNIONS {UNIONS {v:A->bool | v IN V2 /\ + (g2:(A->bool)->(A->bool)) v = w'} | + w' | (w':A->bool) IN ss} = + UNIONS {v:A->bool | v IN V2 /\ g2 v IN ss}` + SUBST1_TAC THENL + [MATCH_MP_TAC SUBSET_ANTISYM THEN + REWRITE_TAC[UNIONS_GSPEC; SUBSET; IN_ELIM_THM] THEN + POP_ASSUM_LIST(K ALL_TAC) THEN + CONJ_TAC THEN X_GEN_TAC `a:A` THEN MESON_TAC[]; + USE_THEN "V2cp" MATCH_MP_TAC THEN SET_TAC[]]]; + ALL_TAC] THEN + (* Step 4b: Disjointness: C(SUC n)(w1) INTER C(n)(w2) = {} when w2 < w1 *) + SUBGOAL_THEN + `!n:num w1 w2:A->bool. + w1 IN W /\ w2 IN W /\ + (ord:(A->bool)->(A->bool)->bool) w2 w1 /\ ~(w2 = w1) + ==> (C:num->(A->bool)->(A->bool)) (SUC n) w1 INTER + C n w2 = {}` + (LABEL_TAC "Cdisj") THENL + [REPEAT GEN_TAC THEN STRIP_TAC THEN + SUBGOAL_THEN + `(C:num->(A->bool)->(A->bool)) (SUC n) w1 SUBSET + w1 DIFF UNIONS {C n v | v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v w1 /\ ~(v = w1)}` + ASSUME_TAC THENL + [USE_THEN "Csub_strong" (MP_TAC o SPECL [`n:num`; `w1:A->bool`]) THEN + ANTS_TAC THENL [FIRST_ASSUM ACCEPT_TAC; ALL_TAC] THEN + DISCH_TAC THEN FIRST_ASSUM ACCEPT_TAC; + ALL_TAC] THEN + SUBGOAL_THEN + `(C:num->(A->bool)->(A->bool)) n w2 SUBSET + UNIONS {C n v | v IN W /\ + (ord:(A->bool)->(A->bool)->bool) v w1 /\ ~(v = w1)}` + ASSUME_TAC THENL + [REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + EXISTS_TAC `(C:num->(A->bool)->(A->bool)) n w2` THEN + CONJ_TAC THENL + [EXISTS_TAC `w2:A->bool` THEN ASM_REWRITE_TAC[]; + FIRST_ASSUM ACCEPT_TAC]; + ALL_TAC] THEN + ASM SET_TAC[]; + ALL_TAC] THEN + (* Step 5: Define VV n w = topspace \ UNIONS{C n v | v <> w} *) + ABBREV_TAC `VV = \(n:num) (w:A->bool). + topspace top DIFF + UNIONS {(C:num->(A->bool)->(A->bool)) n v | v IN W /\ + ~(v = w)}` THEN + (* Step 5a: VV n w is open *) + SUBGOAL_THEN + `!n:num w:A->bool. w IN W ==> + open_in top ((VV:num->(A->bool)->(A->bool)) n w)` + (LABEL_TAC "Vopen") THENL + [REPEAT STRIP_TAC THEN EXPAND_TAC "VV" THEN + MATCH_MP_TAC OPEN_IN_DIFF THEN REWRITE_TAC[OPEN_IN_TOPSPACE] THEN + USE_THEN "Cvalid" (MP_TAC o SPEC `n:num`) THEN + DISCH_THEN(MP_TAC o last o CONJUNCTS) THEN + DISCH_THEN(MP_TAC o SPEC `{v:A->bool | v IN W /\ ~(v = w)}`) THEN + ANTS_TAC THENL [SET_TAC[]; ALL_TAC] THEN + SUBGOAL_THEN + `{(C:num->(A->bool)->(A->bool)) n w' | + w' IN {v:A->bool | v IN W /\ ~(v = w)}} = + {C n v | v IN W /\ ~(v = w)}` + (fun th -> REWRITE_TAC[th]) THEN + SET_TAC[]; + ALL_TAC] THEN + (* Step 5b: VV n w SUBSET C n w *) + SUBGOAL_THEN + `!n:num w:A->bool. w IN W ==> + (VV:num->(A->bool)->(A->bool)) n w SUBSET C n w` + (LABEL_TAC "VsubC") THENL + [REPEAT STRIP_TAC THEN EXPAND_TAC "VV" THEN + REWRITE_TAC[SUBSET; IN_DIFF] THEN + X_GEN_TAC `y:A` THEN STRIP_TAC THEN + USE_THEN "Cvalid" (STRIP_ASSUME_TAC o SPEC `n:num`) THEN + SUBGOAL_THEN + `?v:A->bool. v IN W /\ + (y:A) IN (C:num->(A->bool)->(A->bool)) n v` + STRIP_ASSUME_TAC THENL + [SUBGOAL_THEN + `(y:A) IN UNIONS {(C:num->(A->bool)->(A->bool)) n v | v IN W}` + MP_TAC THENL + [ASM_REWRITE_TAC[]; REWRITE_TAC[IN_UNIONS; IN_ELIM_THM]] THEN + MESON_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `v:A->bool = w` (fun th -> ASM_MESON_TAC[th]) THEN + MATCH_MP_TAC(TAUT `(~p ==> F) ==> p`) THEN DISCH_TAC THEN + SUBGOAL_THEN + `(y:A) IN + UNIONS {(C:num->(A->bool)->(A->bool)) n v' | + v' IN W /\ ~(v' = w)}` + MP_TAC THENL + [REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `(C:num->(A->bool)->(A->bool)) n v` THEN + ASM_REWRITE_TAC[] THEN EXISTS_TAC `v:A->bool` THEN + ASM_REWRITE_TAC[]; + ASM_MESON_TAC[]]; + ALL_TAC] THEN + (* Step 5c: VV n w are pairwise disjoint for fixed n *) + SUBGOAL_THEN + `!n:num w1 w2:A->bool. w1 IN W /\ w2 IN W /\ ~(w1 = w2) + ==> (VV:num->(A->bool)->(A->bool)) n w1 INTER VV n w2 = {}` + (LABEL_TAC "Vpd") THENL + [REPEAT GEN_TAC THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC + (CONJUNCTS_THEN2 ASSUME_TAC ASSUME_TAC)) THEN + (* VV n w1 SUBSET C n w1 *) + SUBGOAL_THEN + `(VV:num->(A->bool)->(A->bool)) n w1 SUBSET + (C:num->(A->bool)->(A->bool)) n w1` + ASSUME_TAC THENL + [USE_THEN "VsubC" (fun th -> + MATCH_MP_TAC(SPECL [`n:num`; `w1:A->bool`] th)) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* C n w1 SUBSET UNIONS{C n v | v IN W, v <> w2} since w1 <> w2 *) + SUBGOAL_THEN + `(C:num->(A->bool)->(A->bool)) n w1 SUBSET + UNIONS {C n v | v IN W /\ ~(v = w2)}` + ASSUME_TAC THENL + [REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `y:A` THEN DISCH_TAC THEN + EXISTS_TAC `(C:num->(A->bool)->(A->bool)) n w1` THEN + ASM_REWRITE_TAC[] THEN + EXISTS_TAC `w1:A->bool` THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* VV n w2 INTER C n w1 = {} *) + SUBGOAL_THEN + `(VV:num->(A->bool)->(A->bool)) n w2 INTER + (C:num->(A->bool)->(A->bool)) n w1 = {}` + ASSUME_TAC THENL + [EXPAND_TAC "VV" THEN ASM SET_TAC[]; ALL_TAC] THEN + ASM SET_TAC[]; + ALL_TAC] THEN + (* Step 6: {VV (SUC n) w | n, w} covers X *) + SUBGOAL_THEN + `!x:A. x IN topspace top ==> + ?n:num w:A->bool. w IN W /\ + x IN (VV:num->(A->bool)->(A->bool)) (SUC n) w` + (LABEL_TAC "Vcover") THENL + [X_GEN_TAC `x:A` THEN DISCH_TAC THEN + (* For each n, find the ord-least w with x IN C n w *) + SUBGOAL_THEN + `!n:num. ?w0:A->bool. w0 IN W /\ + (x:A) IN (C:num->(A->bool)->(A->bool)) n w0 /\ + !v. v IN W /\ x IN C n v ==> + (ord:(A->bool)->(A->bool)->bool) w0 v` + MP_TAC THENL + [GEN_TAC THEN + USE_THEN "wos" + (MP_TAC o CONJUNCT2 o REWRITE_RULE[WOSET]) THEN + USE_THEN "fldW" (fun th -> REWRITE_TAC[th]) THEN + DISCH_THEN(MP_TAC o SPEC + `{w:A->bool | w IN W /\ + (x:A) IN (C:num->(A->bool)->(A->bool)) n w}`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN MESON_TAC[]; + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM] THEN + USE_THEN "Cvalid" (MP_TAC o SPEC `n:num`) THEN + DISCH_THEN(MP_TAC o CONJUNCT1 o CONJUNCT2 o CONJUNCT2) THEN + DISCH_TAC THEN + SUBGOAL_THEN + `(x:A) IN UNIONS + {(C:num->(A->bool)->(A->bool)) n w | w IN W}` + MP_TAC THENL + [ASM_REWRITE_TAC[]; + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN MESON_TAC[]]]; + REWRITE_TAC[IN_ELIM_THM] THEN MESON_TAC[]]; + ALL_TAC] THEN + REWRITE_TAC[SKOLEM_THM] THEN + DISCH_THEN(X_CHOOSE_THEN `mn:num->(A->bool)` + (LABEL_TAC "mnprop")) THEN + (* mn(SUC n) <= mn(n) in the well-order *) + SUBGOAL_THEN + `!k:num. (ord:(A->bool)->(A->bool)->bool) + ((mn:num->(A->bool)) (SUC k)) (mn k)` + (LABEL_TAC "mn_dec") THENL + [GEN_TAC THEN + (* By totality: ord mn(SUC k) mn(k) or ord mn(k) mn(SUC k) *) + USE_THEN "wos" (MP_TAC o MATCH_MP WOSET_TOTAL) THEN + USE_THEN "fldW" (fun th -> REWRITE_TAC[th]) THEN + USE_THEN "mnprop" (STRIP_ASSUME_TAC o SPEC `SUC k`) THEN + USE_THEN "mnprop" (STRIP_ASSUME_TAC o SPEC `k:num`) THEN + DISCH_THEN(MP_TAC o SPECL + [`(mn:num->(A->bool)) (SUC k)`; + `(mn:num->(A->bool)) k`]) THEN + ANTS_TAC THENL [ASM_MESON_TAC[IN]; ALL_TAC] THEN + DISCH_THEN(DISJ_CASES_THEN2 + (fun th -> ACCEPT_TAC th) + ASSUME_TAC) THEN + (* Case: ord mn(k) mn(SUC k) *) + ASM_CASES_TAC + `(mn:num->(A->bool)) k = mn (SUC k)` THENL + [(* Equal: use reflexivity *) + USE_THEN "wos" (MP_TAC o MATCH_MP WOSET_REFL) THEN + USE_THEN "fldW" (fun th -> REWRITE_TAC[th]) THEN + ASM_MESON_TAC[IN]; + (* Distinct: derive contradiction via Csub_strong *) + SUBGOAL_THEN + `~((x:A) IN (C:num->(A->bool)->(A->bool)) k + ((mn:num->(A->bool)) k))` + (fun th -> ASM_MESON_TAC[th]) THEN + USE_THEN "Csub_strong" + (MP_TAC o SPECL [`k:num`; + `(mn:num->(A->bool)) (SUC k)`]) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[SUBSET; IN_DIFF; IN_UNIONS; IN_ELIM_THM] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(CONJUNCTS_THEN2 (K ALL_TAC) MP_TAC) THEN + REWRITE_TAC[NOT_EXISTS_THM; + TAUT `~(p /\ q) <=> p ==> ~q`] THEN + ASM_MESON_TAC[]]; + ALL_TAC] THEN + (* Range {mn k | k} has a least element by WOSET_WELL *) + USE_THEN "wos" + (MP_TAC o CONJUNCT2 o REWRITE_RULE[WOSET]) THEN + USE_THEN "fldW" (fun th -> REWRITE_TAC[th]) THEN + DISCH_THEN(MP_TAC o SPEC + `{(mn:num->(A->bool)) k | k IN (:num)}`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_UNIV] THEN + X_GEN_TAC `z:A->bool` THEN + DISCH_THEN(X_CHOOSE_THEN `kk:num` SUBST1_TAC) THEN + USE_THEN "mnprop" (STRIP_ASSUME_TAC o SPEC `kk:num`) THEN + ASM_REWRITE_TAC[]; + REWRITE_TAC[GSYM MEMBER_NOT_EMPTY; IN_ELIM_THM; IN_UNIV] THEN + EXISTS_TAC `(mn:num->(A->bool)) 0` THEN + EXISTS_TAC `0` THEN REWRITE_TAC[]]; + ALL_TAC] THEN + REWRITE_TAC[IN_ELIM_THM; IN_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `w_min:A->bool` MP_TAC) THEN + DISCH_THEN(fun th -> + let eq_th = CONJUNCT1 th and min_th = CONJUNCT2 th in + X_CHOOSE_THEN `n0:num` + (fun eq -> SUBST_ALL_TAC eq THEN + ASSUME_TAC(REWRITE_RULE[eq] min_th)) eq_th) THEN + (* mn(n0) is the least in the range, so mn(n0+1) = mn(n0) *) + SUBGOAL_THEN + `(mn:num->(A->bool)) (SUC n0) = mn n0` + (LABEL_TAC "mn_stab") THENL + [MP_TAC(MATCH_MP WOSET_ANTISYM + (ASSUME `woset(ord:(A->bool)->(A->bool)->bool)`)) THEN + DISCH_THEN MATCH_MP_TAC THEN + CONJ_TAC THENL + [USE_THEN "mn_dec" (ACCEPT_TAC o SPEC `n0:num`); + FIRST_X_ASSUM(MP_TAC o SPEC + `(mn:num->(A->bool)) (SUC n0)`) THEN + ANTS_TAC THENL + [EXISTS_TAC `SUC n0` THEN REWRITE_TAC[]; + REWRITE_TAC[]]]; + ALL_TAC] THEN + (* Now show x IN VV(SUC n0)(mn(n0)) *) + EXISTS_TAC `n0:num` THEN + EXISTS_TAC `(mn:num->(A->bool)) n0` THEN + USE_THEN "mnprop" (STRIP_ASSUME_TAC o SPEC `n0:num`) THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + EXPAND_TAC "VV" THEN REWRITE_TAC[IN_DIFF] THEN + CONJ_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + REWRITE_TAC[NOT_EXISTS_THM; + TAUT `~(p /\ q) <=> p ==> ~q`] THEN + X_GEN_TAC `s:A->bool` THEN + DISCH_THEN(X_CHOOSE_THEN `v:A->bool` STRIP_ASSUME_TAC) THEN + FIRST_X_ASSUM SUBST1_TAC THEN + (* Need: x NOT IN C(SUC n0)(v) *) + GEN_REWRITE_TAC I [TAUT `~p <=> (p ==> F)`] THEN + DISCH_TAC THEN + (* v IN {w | x IN C(SUC n0)(w)}, mn(SUC n0) is least *) + USE_THEN "mnprop" (MP_TAC o SPEC `SUC n0`) THEN + DISCH_THEN(CONJUNCTS_THEN2 (K ALL_TAC) + (CONJUNCTS_THEN2 (K ALL_TAC) + (MP_TAC o SPEC `v:A->bool`))) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + (* ord mn(SUC n0) v, i.e., ord mn(n0) v *) + USE_THEN "mn_stab" (fun th -> REWRITE_TAC[th]) THEN + GEN_REWRITE_TAC I [TAUT `~p <=> (p ==> F)`] THEN + DISCH_THEN ASSUME_TAC THEN + (* Since v != mn(n0) and ord mn(n0) v *) + (* Csub_strong: C(SUC n0)(v) SUBSET v DIFF UNIONS{...} *) + USE_THEN "Csub_strong" + (MP_TAC o SPECL [`n0:num`; `v:A->bool`]) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[SUBSET; IN_DIFF; IN_UNIONS; IN_ELIM_THM] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(CONJUNCTS_THEN2 (K ALL_TAC) ASSUME_TAC) THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + (* Step 7: Apply CP to the cover {VV (SUC n) w} to get cc *) + MP_TAC(ISPECL [`top:A topology`; + `{(VV:num->(A->bool)->(A->bool)) (SUC n) (w:A->bool) | + n IN (:num) /\ w IN W}`] + CP_INDEXED_CLOSED_COVER) THEN + ANTS_TAC THENL + [CONJ_TAC THENL [USE_THEN "cp" ACCEPT_TAC; ALL_TAC] THEN + CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_GSPEC; IN_UNIV] THEN + X_GEN_TAC `nn:num` THEN X_GEN_TAC `ww:A->bool` THEN + DISCH_THEN(fun wW -> + USE_THEN "Vopen" (fun vth -> + ACCEPT_TAC(MP (SPECL [`SUC nn`; `ww:A->bool`] vth) wW))); + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC; IN_UNIV] THEN + REPEAT STRIP_TAC THEN EXPAND_TAC "VV" THEN + REWRITE_TAC[SUBSET_DIFF]; + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + USE_THEN "Vcover" (MP_TAC o SPEC `x:A`) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `n0:num` + (X_CHOOSE_THEN `w0:A->bool` STRIP_ASSUME_TAC)) THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM] THEN + EXISTS_TAC `(VV:num->(A->bool)->(A->bool)) (SUC n0) w0` THEN + CONJ_TAC THENL + [MAP_EVERY EXISTS_TAC [`n0:num`; `w0:A->bool`] THEN + ASM_REWRITE_TAC[IN_UNIV]; ASM_REWRITE_TAC[]]]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `cc:(A->bool)->(A->bool)` + (CONJUNCTS_THEN2 (LABEL_TAC "cccl") + (CONJUNCTS_THEN2 (LABEL_TAC "ccsub") + (CONJUNCTS_THEN2 (LABEL_TAC "cccov") (LABEL_TAC "cccp"))))) THEN + (* Step 8: For each n, apply Dowker *) + SUBGOAL_THEN + `!n:num. ?EE:(A->bool)->(A->bool). + (!w:A->bool. w IN W ==> open_in top (EE w)) /\ + (!w:A->bool. w IN W ==> + cc ((VV:num->(A->bool)->(A->bool)) (SUC n) w) SUBSET EE w) /\ + (!w:A->bool. w IN W ==> EE w SUBSET VV (SUC n) w) /\ + locally_finite_in top {EE w | w IN W}` + (LABEL_TAC "dowker_all") THENL + [X_GEN_TAC `nn:num` THEN + MP_TAC(ISPECL + [`top:A topology`; `W:(A->bool)->bool`; + `\(w:A->bool). (VV:num->(A->bool)->(A->bool)) (SUC nn) w`; + `\(w:A->bool). (cc:(A->bool)->(A->bool)) + ((VV:num->(A->bool)->(A->bool)) (SUC nn) w)`] + DOWKER_DISCRETE_EXPANSION) THEN + REWRITE_TAC[] THEN + DISCH_THEN(fun th -> MATCH_MP_TAC th THEN + CONJ_TAC THENL [USE_THEN "norm" ACCEPT_TAC; ALL_TAC] THEN + CONJ_TAC THENL + [X_GEN_TAC `k:A->bool` THEN + DISCH_THEN(fun kW -> + USE_THEN "Vopen" (fun th -> + ACCEPT_TAC(MP (SPECL [`SUC nn`; `k:A->bool`] th) kW))); + ALL_TAC] THEN + CONJ_TAC THENL + [(* pairwise disjoint *) + REWRITE_TAC[pairwise; DISJOINT] THEN + MAP_EVERY X_GEN_TAC [`a:A->bool`; `b:A->bool`] THEN + DISCH_THEN(fun h -> + USE_THEN "Vpd" (fun vpd -> + ACCEPT_TAC(MP (SPECL [`SUC nn`; `a:A->bool`; `b:A->bool`] + vpd) h))); + ALL_TAC] THEN + CONJ_TAC THENL + [(* cc subset VV *) + X_GEN_TAC `k:A->bool` THEN DISCH_TAC THEN + USE_THEN "ccsub" (MP_TAC o SPEC + `(VV:num->(A->bool)->(A->bool)) (SUC nn) k`) THEN + REWRITE_TAC[IN_ELIM_THM] THEN + ANTS_TAC THENL + [MAP_EVERY EXISTS_TAC [`nn:num`; `k:A->bool`] THEN + REWRITE_TAC[IN_UNIV] THEN FIRST_ASSUM ACCEPT_TAC; + REWRITE_TAC[]]; + ALL_TAC] THEN + (* closed *) + SUBGOAL_THEN + `UNIONS {(cc:(A->bool)->(A->bool)) + ((VV:num->(A->bool)->(A->bool)) (SUC nn) k) | + k IN W} = + UNIONS {cc u | u IN {VV (SUC nn) w | w IN W}}` + SUBST1_TAC THENL + [AP_TERM_TAC THEN SET_TAC[]; + ALL_TAC] THEN + USE_THEN "cccp" MATCH_MP_TAC THEN + REWRITE_TAC[SUBSET; FORALL_IN_GSPEC] THEN + X_GEN_TAC `w':A->bool` THEN DISCH_TAC THEN + REWRITE_TAC[IN_ELIM_THM] THEN + MAP_EVERY EXISTS_TAC [`nn:num`; `w':A->bool`] THEN + REWRITE_TAC[IN_UNIV] THEN FIRST_ASSUM ACCEPT_TAC); + ALL_TAC] THEN + (* Skolemize *) + USE_THEN "dowker_all" (MP_TAC o REWRITE_RULE[SKOLEM_THM]) THEN + DISCH_THEN(X_CHOOSE_THEN `EE:num->(A->bool)->(A->bool)` + (LABEL_TAC "Eprop")) THEN + (* Step 9: Define R and prove all four properties *) + EXISTS_TAC + `UNIONS {{(EE:num->(A->bool)->(A->bool)) n w | w IN W} | + n IN (:num)}` THEN + CONJ_TAC THENL + [(* open_in: each r IN R is open *) + X_GEN_TAC `r:A->bool` THEN DISCH_TAC THEN + POP_ASSUM(MP_TAC o REWRITE_RULE[IN_UNIONS]) THEN + DISCH_THEN(X_CHOOSE_THEN `F':(A->bool)->bool` + (CONJUNCTS_THEN2 MP_TAC ASSUME_TAC)) THEN + GEN_REWRITE_TAC LAND_CONV [IN_ELIM_THM] THEN + REWRITE_TAC[IN_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `nn:num` SUBST_ALL_TAC) THEN + POP_ASSUM(STRIP_ASSUME_TAC o + GEN_REWRITE_RULE I [IN_ELIM_THM]) THEN + USE_THEN "Eprop" (MP_TAC o SPEC `nn:num`) THEN + ASM_MESON_TAC[]; + ALL_TAC] THEN + CONJ_TAC THENL + [(* UNIONS = topspace *) + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [(* SUBSET topspace *) + REWRITE_TAC[UNIONS_SUBSET] THEN + X_GEN_TAC `s:A->bool` THEN DISCH_TAC THEN + POP_ASSUM(MP_TAC o REWRITE_RULE[IN_UNIONS]) THEN + DISCH_THEN(X_CHOOSE_THEN `F':(A->bool)->bool` + (CONJUNCTS_THEN2 MP_TAC ASSUME_TAC)) THEN + GEN_REWRITE_TAC LAND_CONV [IN_ELIM_THM] THEN + REWRITE_TAC[IN_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `nn:num` SUBST_ALL_TAC) THEN + POP_ASSUM(fun th -> + let th' = BETA_RULE(GEN_REWRITE_RULE I [IN_ELIM_THM] th) in + X_CHOOSE_THEN `w':A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST_ALL_TAC) th') THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `(VV:num->(A->bool)->(A->bool)) (SUC nn) w'` THEN + CONJ_TAC THENL + [USE_THEN "Eprop" (fun th -> + MATCH_MP_TAC(CONJUNCT1(CONJUNCT2(CONJUNCT2 + (SPEC `nn:num` th))))) THEN + ASM_REWRITE_TAC[]; + EXPAND_TAC "VV" THEN REWRITE_TAC[SUBSET_DIFF]]; + (* topspace SUBSET *) + REWRITE_TAC[SUBSET] THEN X_GEN_TAC `x:A` THEN DISCH_TAC THEN + REWRITE_TAC[IN_UNIONS] THEN + SUBGOAL_THEN + `(x:A) IN UNIONS {(cc:(A->bool)->(A->bool)) u | + u IN {(VV:num->(A->bool)->(A->bool)) (SUC n) w | + n IN (:num) /\ w IN W}}` + MP_TAC THENL + [USE_THEN "cccov" (fun th -> REWRITE_TAC[th]) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + REWRITE_TAC[IN_UNIONS; IN_ELIM_THM; IN_UNIV] THEN + STRIP_TAC THEN + EXISTS_TAC `(EE:num->(A->bool)->(A->bool)) n w` THEN + CONJ_TAC THENL + [EXISTS_TAC + `{(EE:num->(A->bool)->(A->bool)) n w'' | w'' IN W}` THEN + CONJ_TAC THENL + [REWRITE_TAC[IN_ELIM_THM; IN_UNIV] THEN + EXISTS_TAC `n:num` THEN REWRITE_TAC[]; + REWRITE_TAC[IN_ELIM_THM] THEN + EXISTS_TAC `w:A->bool` THEN ASM_REWRITE_TAC[]]; + (* x IN EE n w: substitute t=cc u, u=VV(SUC n)w *) + FIRST_X_ASSUM SUBST_ALL_TAC THEN + FIRST_X_ASSUM SUBST_ALL_TAC THEN + (* now x IN cc(VV(SUC n) w) is in assumptions *) + USE_THEN "Eprop" (fun th -> + let th_n = SPEC `n:num` th in + let th_sub = CONJUNCT1(CONJUNCT2 th_n) in + MP_TAC(SPEC `w:A->bool` th_sub)) THEN + ANTS_TAC THENL [ASM_REWRITE_TAC[]; ALL_TAC] THEN + REWRITE_TAC[SUBSET] THEN + DISCH_THEN(MP_TAC o SPEC `x:A`) THEN + ASM_REWRITE_TAC[]]]; + ALL_TAC] THEN + CONJ_TAC THENL + [(* closure containment *) + X_GEN_TAC `r:A->bool` THEN DISCH_TAC THEN + POP_ASSUM(MP_TAC o REWRITE_RULE[IN_UNIONS]) THEN + DISCH_THEN(X_CHOOSE_THEN `F':(A->bool)->bool` + (CONJUNCTS_THEN2 MP_TAC ASSUME_TAC)) THEN + GEN_REWRITE_TAC LAND_CONV [IN_ELIM_THM] THEN + REWRITE_TAC[IN_UNIV] THEN + DISCH_THEN(X_CHOOSE_THEN `nn:num` SUBST_ALL_TAC) THEN + POP_ASSUM(fun th -> + let th' = BETA_RULE(GEN_REWRITE_RULE I [IN_ELIM_THM] th) in + X_CHOOSE_THEN `ww:A->bool` + (CONJUNCTS_THEN2 ASSUME_TAC SUBST_ALL_TAC) th') THEN + (* Now r = EE nn ww with ww IN W *) + SUBGOAL_THEN + `(EE:num->(A->bool)->(A->bool)) nn ww SUBSET ww` + ASSUME_TAC THENL + [MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `(VV:num->(A->bool)->(A->bool)) (SUC nn) ww` THEN + CONJ_TAC THENL + [USE_THEN "Eprop" (fun th -> + MATCH_MP_TAC(CONJUNCT1(CONJUNCT2(CONJUNCT2 + (SPEC `nn:num` th))))) THEN + ASM_REWRITE_TAC[]; + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC + `(C:num->(A->bool)->(A->bool)) (SUC nn) ww` THEN + CONJ_TAC THENL + [USE_THEN "VsubC" MATCH_MP_TAC THEN + ASM_REWRITE_TAC[]; + USE_THEN "Cvalid" (fun th -> + MATCH_MP_TAC(CONJUNCT1(CONJUNCT2 + (SPEC `SUC nn` th)))) THEN + ASM_REWRITE_TAC[]]]; + ALL_TAC] THEN + SUBGOAL_THEN + `?u:A->bool. u IN U /\ + top closure_of (ww:A->bool) SUBSET u` + STRIP_ASSUME_TAC THENL + [FIRST_X_ASSUM(MATCH_MP_TAC o SPEC `ww:A->bool`) THEN + ASM_REWRITE_TAC[]; + ALL_TAC] THEN + EXISTS_TAC `u:A->bool` THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `top closure_of (ww:A->bool)` THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC CLOSURE_OF_MONO THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + (* sigma-LF *) + REWRITE_TAC[sigma_locally_finite_in] THEN + EXISTS_TAC + `\nn:num. {(EE:num->(A->bool)->(A->bool)) nn w | w IN W}` THEN + CONJ_TAC THENL + [X_GEN_TAC `nn:num` THEN REWRITE_TAC[] THEN + USE_THEN "Eprop" (fun th -> + ACCEPT_TAC(CONJUNCT2(CONJUNCT2(CONJUNCT2 + (SPEC `nn:num` th))))); + REWRITE_TAC[]]; + MP_TAC(ISPECL [`top:A topology`; `U:(A->bool)->bool`; `R:(A->bool)->bool`] + CLF_OPEN_CLOSURE_IMP_LF_CLOSED) THEN + ASM_REWRITE_TAC[]]);; + +(* Michael's biconditional characterization: for regular spaces, + paracompact iff every open cover has a closure-preserving closed + refinement (i.e., unions of arbitrary subcollections are closed). *) + +let MICHAEL_PARACOMPACT_EQ = prove + (`!top:A topology. + regular_space top + ==> (paracompact_space top <=> + !U. (!u. u IN U ==> open_in top u) /\ UNIONS U = topspace top + ==> ?V. (!v. v IN V ==> closed_in top v) /\ + UNIONS V = topspace top /\ + (!v. v IN V ==> ?u. u IN U /\ v SUBSET u) /\ + (!W. W SUBSET V ==> closed_in top (UNIONS W)))`, + GEN_TAC THEN DISCH_TAC THEN EQ_TAC THENL + [(* Forward: paracompact ==> CP closed refinement. + Get LF closed refinement, then LF closed ==> closure-preserving. *) + DISCH_TAC THEN + X_GEN_TAC `U:(A->bool)->bool` THEN STRIP_TAC THEN + FIRST_ASSUM(MP_TAC o MATCH_MP PARACOMPACT_SPACE_EQ_CLOSED_REFINEMENT) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC `U:(A->bool)->bool`) THEN + ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `V:(A->bool)->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `V:(A->bool)->bool` THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `W:(A->bool)->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC CLOSED_IN_LOCALLY_FINITE_UNIONS THEN + CONJ_TAC THENL [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN + MATCH_MP_TAC LOCALLY_FINITE_IN_SUBSET THEN + EXISTS_TAC `V:(A->bool)->bool` THEN ASM_REWRITE_TAC[]; + (* Backward: CP closed refinement ==> paracompact. + Directly from MICHAEL_PARACOMPACT. *) + DISCH_TAC THEN MATCH_MP_TAC MICHAEL_PARACOMPACT THEN + ASM_REWRITE_TAC[]]);; + +(* Sharper closed map image theorem: paracompact Hausdorff is preserved + by closed continuous surjections (not just perfect maps). + Uses MICHAEL_PARACOMPACT and CP_IMPLIES_NORMAL_SPACE. *) + +let PARACOMPACT_SPACE_CLOSED_MAP_IMAGE = prove + (`!top top' (f:A->B). + paracompact_space top /\ hausdorff_space top /\ + continuous_map(top,top') f /\ + closed_map(top,top') f /\ + IMAGE f (topspace top) = topspace top' + ==> paracompact_space top'`, + REPEAT GEN_TAC THEN STRIP_TAC THEN + (* Step 1: regular_space top *) + SUBGOAL_THEN `regular_space (top:A topology)` ASSUME_TAC THENL + [ASM_MESON_TAC[PARACOMPACT_HAUSDORFF_IMP_REGULAR_SPACE]; ALL_TAC] THEN + (* Step 2: Every open cover of Y has a CP closed refinement *) + SUBGOAL_THEN + `!U:(B->bool)->bool. + (!u:B->bool. u IN U ==> open_in top' u) /\ + UNIONS U = topspace top' + ==> ?V:(B->bool)->bool. + (!v:B->bool. v IN V ==> closed_in top' v) /\ + UNIONS V = topspace top' /\ + (!v:B->bool. v IN V ==> ?u:B->bool. u IN U /\ v SUBSET u) /\ + (!W:(B->bool)->bool. W SUBSET V ==> closed_in top' (UNIONS W))` + (LABEL_TAC "cp'") THENL + [X_GEN_TAC `U:(B->bool)->bool` THEN STRIP_TAC THEN + (* Get LF closed refinement of pullback cover in X *) + FIRST_ASSUM(MP_TAC o MATCH_MP PARACOMPACT_SPACE_EQ_CLOSED_REFINEMENT) THEN + DISCH_THEN(MP_TAC o fst o EQ_IMP_RULE) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(MP_TAC o SPEC + `{({x | x IN topspace top /\ (f:A->B) x IN u}) | u IN U}`) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [REWRITE_TAC[FORALL_IN_GSPEC] THEN X_GEN_TAC `u:B->bool` THEN + DISCH_TAC THEN MATCH_MP_TAC OPEN_IN_CONTINUOUS_MAP_PREIMAGE THEN + EXISTS_TAC `top':B topology` THEN ASM_MESON_TAC[]; + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC; SUBSET; + IN_ELIM_THM] THEN MESON_TAC[]; + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `x:A` THEN DISCH_TAC THEN + SUBGOAL_THEN `(f:A->B) x IN topspace top'` ASSUME_TAC THENL + [ASM_MESON_TAC[continuous_map]; ALL_TAC] THEN + SUBGOAL_THEN `(f:A->B) x IN UNIONS U` MP_TAC THENL + [ASM_MESON_TAC[]; REWRITE_TAC[IN_UNIONS]] THEN + DISCH_THEN(X_CHOOSE_THEN `u:B->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `{x:A | x IN topspace top /\ (f:A->B) x IN u}` THEN + REWRITE_TAC[IN_ELIM_THM] THEN ASM_MESON_TAC[]]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `K:(A->bool)->bool` + (CONJUNCTS_THEN2 (LABEL_TAC "Kclosed") + (CONJUNCTS_THEN2 (LABEL_TAC "Kcov") + (CONJUNCTS_THEN2 (LABEL_TAC "Kref") (LABEL_TAC "Klf"))))) THEN + (* Push forward K via f *) + EXISTS_TAC `{IMAGE (f:A->B) k | k IN K}` THEN + REPEAT CONJ_TAC THENL + [(* Each IMAGE f k is closed in Y *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN + X_GEN_TAC `k:A->bool` THEN DISCH_TAC THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [closed_map]) THEN + DISCH_THEN(MP_TAC o SPEC `k:A->bool`) THEN + ASM_MESON_TAC[]; + (* Covers Y *) + MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL + [REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN + X_GEN_TAC `k:A->bool` THEN DISCH_TAC THEN + MATCH_MP_TAC SUBSET_TRANS THEN + EXISTS_TAC `IMAGE (f:A->B) (topspace top)` THEN + CONJ_TAC THENL + [MATCH_MP_TAC IMAGE_SUBSET THEN + ASM_MESON_TAC[closed_in; SUBSET]; + ASM SET_TAC[]]; + REWRITE_TAC[SUBSET; IN_UNIONS; IN_ELIM_THM] THEN + X_GEN_TAC `y:B` THEN DISCH_TAC THEN + SUBGOAL_THEN `(y:B) IN IMAGE (f:A->B) (topspace top)` MP_TAC THENL + [ASM SET_TAC[]; REWRITE_TAC[IN_IMAGE]] THEN + DISCH_THEN(X_CHOOSE_THEN `x:A` STRIP_ASSUME_TAC) THEN + SUBGOAL_THEN `(x:A) IN UNIONS K` MP_TAC THENL + [ASM SET_TAC[]; REWRITE_TAC[IN_UNIONS]] THEN + DISCH_THEN(X_CHOOSE_THEN `k:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `IMAGE (f:A->B) k` THEN + CONJ_TAC THENL [ASM_MESON_TAC[]; ASM SET_TAC[]]]; + (* Refines U *) + REWRITE_TAC[FORALL_IN_GSPEC] THEN + X_GEN_TAC `k0:A->bool` THEN DISCH_TAC THEN + SUBGOAL_THEN + `?u0:B->bool. u0 IN U /\ + (k0:A->bool) SUBSET + {x | x IN topspace top /\ (f:A->B) x IN u0}` + STRIP_ASSUME_TAC THENL + [SUBGOAL_THEN + `?preimg:(A->bool). + preimg IN + {{x | x IN topspace top /\ (f:A->B) x IN u} | + (u:B->bool) IN U} /\ + (k0:A->bool) SUBSET preimg` STRIP_ASSUME_TAC THENL + [USE_THEN "Kref" MATCH_MP_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [IN_ELIM_THM]) THEN + DISCH_THEN(X_CHOOSE_THEN `u0':B->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `u0':B->bool` THEN ASM_REWRITE_TAC[] THEN + ASM SET_TAC[]; + ALL_TAC] THEN + EXISTS_TAC `u0:B->bool` THEN ASM_REWRITE_TAC[] THEN + REWRITE_TAC[SUBSET; IN_IMAGE] THEN + X_GEN_TAC `y:B` THEN + DISCH_THEN(X_CHOOSE_THEN `a:A` STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `(a:A) IN {x | x IN topspace top /\ (f:A->B) x IN u0}` + MP_TAC THENL [ASM SET_TAC[]; SIMP_TAC[IN_ELIM_THM]]; + (* Closure-preserving: every sub-union is closed *) + X_GEN_TAC `SS:(B->bool)->bool` THEN DISCH_TAC THEN + ABBREV_TAC `S0 = {k:A->bool | k IN K /\ IMAGE (f:A->B) k IN SS}` THEN + SUBGOAL_THEN `(S0:(A->bool)->bool) SUBSET K` ASSUME_TAC THENL + [EXPAND_TAC "S0" THEN REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + REPEAT STRIP_TAC THEN ASM_REWRITE_TAC[]; + ALL_TAC] THEN + SUBGOAL_THEN `SS = {IMAGE (f:A->B) k | k IN S0}` ASSUME_TAC THENL + [EXPAND_TAC "S0" THEN + ONCE_REWRITE_TAC[EXTENSION] THEN REWRITE_TAC[IN_ELIM_THM] THEN + X_GEN_TAC `s:B->bool` THEN EQ_TAC THENL + [DISCH_TAC THEN + UNDISCH_TAC `SS SUBSET {IMAGE (f:A->B) k | k IN K}` THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN + DISCH_THEN(MP_TAC o SPEC `s:B->bool`) THEN ASM_REWRITE_TAC[] THEN + DISCH_THEN(X_CHOOSE_THEN `kk:A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `kk:A->bool` THEN ASM_MESON_TAC[]; + DISCH_THEN(X_CHOOSE_THEN `kk:A->bool` STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + ASM_REWRITE_TAC[] THEN + (* UNIONS {IMAGE f k | k IN S0} = IMAGE f (UNIONS S0) *) + SUBGOAL_THEN `UNIONS {IMAGE (f:A->B) k | k IN S0} = + IMAGE f (UNIONS S0)` SUBST1_TAC THENL + [ONCE_REWRITE_TAC[EXTENSION] THEN + X_GEN_TAC `bb:B` THEN + REWRITE_TAC[IN_UNIONS; IN_IMAGE; IN_ELIM_THM] THEN + EQ_TAC THENL + [DISCH_THEN(X_CHOOSE_THEN `t0:B->bool` MP_TAC) THEN + DISCH_THEN(CONJUNCTS_THEN2 MP_TAC ASSUME_TAC) THEN + DISCH_THEN(X_CHOOSE_THEN `k0':A->bool` STRIP_ASSUME_TAC) THEN + UNDISCH_TAC `(bb:B) IN t0` THEN + ASM_REWRITE_TAC[IN_IMAGE] THEN + DISCH_THEN(X_CHOOSE_THEN `a0:A` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `a0:A` THEN ASM_REWRITE_TAC[] THEN + EXISTS_TAC `k0':A->bool` THEN ASM_REWRITE_TAC[]; + DISCH_THEN(X_CHOOSE_THEN `a0:A` MP_TAC) THEN + DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN + DISCH_THEN(X_CHOOSE_THEN `k0':A->bool` STRIP_ASSUME_TAC) THEN + EXISTS_TAC `IMAGE (f:A->B) k0'` THEN + CONJ_TAC THENL + [EXISTS_TAC `k0':A->bool` THEN ASM_REWRITE_TAC[]; + ASM_REWRITE_TAC[IN_IMAGE] THEN + EXISTS_TAC `a0:A` THEN ASM_REWRITE_TAC[]]]; + ALL_TAC] THEN + (* UNIONS S0 is closed in X *) + SUBGOAL_THEN `closed_in top (UNIONS S0:A->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC CLOSED_IN_LOCALLY_FINITE_UNIONS THEN CONJ_TAC THENL + [REPEAT STRIP_TAC THEN USE_THEN "Kclosed" MATCH_MP_TAC THEN + ASM SET_TAC[]; + MATCH_MP_TAC LOCALLY_FINITE_IN_SUBSET THEN + EXISTS_TAC `K:(A->bool)->bool` THEN ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + (* IMAGE f (closed) is closed *) + UNDISCH_TAC `closed_map(top:A topology,top':B topology) f` THEN + REWRITE_TAC[closed_map] THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[]]; + ALL_TAC] THEN + (* Step 3: CP -> normal *) + SUBGOAL_THEN `normal_space (top':B topology)` ASSUME_TAC THENL + [MATCH_MP_TAC CP_IMPLIES_NORMAL_SPACE THEN + USE_THEN "cp'" ACCEPT_TAC; + ALL_TAC] THEN + (* Step 4: t1_space top' via closed map image *) + SUBGOAL_THEN `t1_space (top':B topology)` ASSUME_TAC THENL + [MATCH_MP_TAC T1_SPACE_CLOSED_MAP_IMAGE THEN + MAP_EVERY EXISTS_TAC [`f:A->B`; `top:A topology`] THEN + ASM_MESON_TAC[HAUSDORFF_IMP_T1_SPACE]; + ALL_TAC] THEN + (* Step 5: normal + T1 -> regular *) + SUBGOAL_THEN `regular_space (top':B topology)` ASSUME_TAC THENL + [ASM_MESON_TAC[NORMAL_T1_IMP_REGULAR_SPACE]; ALL_TAC] THEN + (* Step 6: Apply MICHAEL_PARACOMPACT *) + MATCH_MP_TAC MICHAEL_PARACOMPACT THEN + CONJ_TAC THENL + [ASM_REWRITE_TAC[]; + USE_THEN "cp'" ACCEPT_TAC]);; diff --git a/Multivariate/paths.ml b/Multivariate/paths.ml index ba8fac96..7d258447 100644 --- a/Multivariate/paths.ml +++ b/Multivariate/paths.ml @@ -7854,108 +7854,166 @@ let LOCALLY_PATH_CONNECTED_FROM_UNION_AND_INTER = prove (* is more usually called "Property S" (Whyburn, Hocking & Young etc.) *) (* ------------------------------------------------------------------------- *) +(* Key bridge: submetric euclidean_metric s gives a metric on s where + mtopology = subtopology euclidean s, mspace = s, mdist = dist *) + +let SUBMETRIC_EUCLIDEAN_METRIC = prove + (`(!s:real^N->bool. mspace(submetric euclidean_metric s) = s) /\ + (!s:real^N->bool. mdist(submetric euclidean_metric s) = dist)`, + REWRITE_TAC[SUBMETRIC; EUCLIDEAN_METRIC; INTER_UNIV]);; + +let MTOPOLOGY_SUBMETRIC_EUCLIDEAN = prove + (`!s:real^N->bool. + mtopology(submetric euclidean_metric s) = subtopology euclidean s`, + REWRITE_TAC[MTOPOLOGY_SUBMETRIC; MTOPOLOGY_EUCLIDEAN_METRIC]);; + +(* Helper: connect mbounded/mdiameter through submetric euclidean_metric *) +let MBOUNDED_SUBMETRIC_EUCLIDEAN = prove + (`!s t:real^N->bool. + t SUBSET s ==> (mbounded (submetric euclidean_metric s) t <=> bounded t)`, + REPEAT STRIP_TAC THEN + REWRITE_TAC[MBOUNDED_SUBMETRIC; MBOUNDED_EUCLIDEAN] THEN + ASM_SIMP_TAC[SET_RULE `(t:A->bool) SUBSET s ==> s INTER t = t`]);; + +let MDIAMETER_SUBMETRIC_EUCLIDEAN = prove + (`!s t:real^N->bool. + t SUBSET s + ==> mdiameter (submetric euclidean_metric s) t = diameter t`, + REPEAT STRIP_TAC THEN + REWRITE_TAC[GSYM MDIAMETER_EUCLIDEAN; mdiameter; SUBMETRIC; + EUCLIDEAN_METRIC; INTER_UNIV] THEN + ASM_SIMP_TAC[SET_RULE `(t:A->bool) SUBSET s ==> s INTER t = t`]);; + +let CONNECTED_IN_SUBTOPOLOGY_EUCLIDEAN = prove + (`!s t:real^N->bool. + connected_in (subtopology euclidean s) t <=> t SUBSET s /\ connected t`, + MESON_TAC[CONNECTED_IN_SUBTOPOLOGY; CONNECTED_IN_EUCLIDEAN]);; + +let COMPACT_IN_SUBTOPOLOGY_EUCLIDEAN = prove + (`!s t:real^N->bool. + compact_in (subtopology euclidean s) t <=> t SUBSET s /\ compact t`, + MESON_TAC[COMPACT_IN_SUBTOPOLOGY; COMPACT_IN_EUCLIDEAN]);; + +let CONNECTED_IN_SUBMETRIC_EUCLIDEAN = prove + (`!s t:real^N->bool. + connected_in (mtopology(submetric euclidean_metric s)) t <=> + t SUBSET s /\ connected t`, + REWRITE_TAC[MTOPOLOGY_SUBMETRIC_EUCLIDEAN; + CONNECTED_IN_SUBTOPOLOGY_EUCLIDEAN]);; + +(* Helper bridges for compact/connected/locally_compact/locally_connected *) +let COMPACT_IN_SUBMETRIC_EUCLIDEAN_MSPACE = prove + (`!s:real^N->bool. + compact_in (mtopology(submetric euclidean_metric s)) s <=> compact s`, + REWRITE_TAC[MTOPOLOGY_SUBMETRIC_EUCLIDEAN; + COMPACT_IN_SUBTOPOLOGY_EUCLIDEAN; SUBSET_REFL]);; + +let LOCALLY_CONNECTED_SPACE_SUBMETRIC_EUCLIDEAN = prove + (`!s:real^N->bool. + locally_connected_space(mtopology(submetric euclidean_metric s)) <=> + locally connected s`, + REWRITE_TAC[MTOPOLOGY_SUBMETRIC_EUCLIDEAN; + LOCALLY_CONNECTED_SPACE_SUBTOPOLOGY_EUCLIDEAN]);; + +let LOCALLY_COMPACT_SPACE_SUBMETRIC_EUCLIDEAN = prove + (`!s:real^N->bool. + locally_compact_space(mtopology(submetric euclidean_metric s)) <=> + locally compact s`, + REWRITE_TAC[MTOPOLOGY_SUBMETRIC_EUCLIDEAN; + LOCALLY_COMPACT_SPACE_SUBTOPOLOGY_EUCLIDEAN]);; + +let CONNECTED_IN_SUBMETRIC_EUCLIDEAN_MSPACE = prove + (`!s:real^N->bool. + connected_in (mtopology(submetric euclidean_metric s)) s <=> + connected s`, + REWRITE_TAC[CONNECTED_IN_SUBMETRIC_EUCLIDEAN; SUBSET_REFL]);; + +(* Key bridge: fccoverable_in euclidean_metric s = Euclidean fccoverable_space *) +let FCCOVERABLE_IN_EUCLIDEAN_METRIC = prove + (`!s:real^N->bool. + fccoverable_in euclidean_metric s <=> + (!e. &0 < e ==> ?c. FINITE c /\ UNIONS c = s /\ + !t. t IN c ==> connected t /\ bounded t /\ + diameter t <= e)`, + GEN_TAC THEN REWRITE_TAC[fccoverable_in; EUCLIDEAN_METRIC; SUBSET_UNIV; + MTOPOLOGY_EUCLIDEAN_METRIC; CONNECTED_IN_EUCLIDEAN; + MBOUNDED_EUCLIDEAN; MDIAMETER_EUCLIDEAN]);; + +(* Bridge: fccoverable_space on submetric euclidean_metric s = Euclidean form *) +let FCCOVERABLE_SPACE_SUBMETRIC_EUCLIDEAN = prove + (`!s:real^N->bool. + fccoverable_space (submetric euclidean_metric s) <=> + (!e. &0 < e ==> ?c. FINITE c /\ UNIONS c = s /\ + !t. t IN c ==> connected t /\ bounded t /\ + diameter t <= e)`, + GEN_TAC THEN REWRITE_TAC[fccoverable_space; SUBMETRIC_EUCLIDEAN_METRIC; + CONNECTED_IN_SUBMETRIC_EUCLIDEAN] THEN + EQ_TAC THEN MATCH_MP_TAC MONO_FORALL THEN X_GEN_TAC `e:real` THEN + MATCH_MP_TAC MONO_IMP THEN REWRITE_TAC[] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `c:(real^N->bool)->bool` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + X_GEN_TAC `t:real^N->bool` THEN DISCH_TAC THEN + (SUBGOAL_THEN `(t:real^N->bool) SUBSET s` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC]) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `t:real^N->bool`) THEN ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[MBOUNDED_SUBMETRIC_EUCLIDEAN; MDIAMETER_SUBMETRIC_EUCLIDEAN]);; + +(* Bridge: ulc_space on submetric euclidean_metric s *) +let ULC_SPACE_SUBMETRIC_EUCLIDEAN = prove + (`!s:real^N->bool. + ulc_space (submetric euclidean_metric s) <=> + (!e. &0 < e + ==> ?d. &0 < d /\ + !x y. x IN s /\ y IN s /\ dist(x,y) < d + ==> ?c. x IN c /\ y IN c /\ c SUBSET s /\ + connected c /\ bounded c /\ diameter c <= e)`, + GEN_TAC THEN + REWRITE_TAC[ulc_space; SUBMETRIC_EUCLIDEAN_METRIC; + CONNECTED_IN_SUBMETRIC_EUCLIDEAN] THEN + EQ_TAC THEN + (MATCH_MP_TAC MONO_FORALL THEN X_GEN_TAC `e:real` THEN + MATCH_MP_TAC MONO_IMP THEN REWRITE_TAC[] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `d:real` THEN + MATCH_MP_TAC MONO_AND THEN REWRITE_TAC[] THEN + REPEAT(MATCH_MP_TAC MONO_FORALL THEN GEN_TAC) THEN + MATCH_MP_TAC MONO_IMP THEN REWRITE_TAC[] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `c:real^N->bool` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + ASM_MESON_TAC[MBOUNDED_SUBMETRIC_EUCLIDEAN; + MDIAMETER_SUBMETRIC_EUCLIDEAN]));; + +(* FCCOVERABLE_IMP_LOCALLY_CONNECTED: derive from the metric version *) let FCCOVERABLE_IMP_LOCALLY_CONNECTED = prove (`!s:real^N->bool. (!e. &0 < e ==> ?c. FINITE c /\ UNIONS c = s /\ !t. t IN c ==> connected t /\ bounded t /\ diameter t <= e) ==> locally connected s`, - GEN_TAC THEN REWRITE_TAC[locally] THEN DISCH_TAC THEN - MAP_EVERY X_GEN_TAC [`u:real^N->bool`; `x:real^N`] THEN - DISCH_THEN(CONJUNCTS_THEN2 MP_TAC ASSUME_TAC) THEN - GEN_REWRITE_TAC LAND_CONV [OPEN_IN_CONTAINS_BALL] THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `x:real^N`)) THEN - ASM_REWRITE_TAC[] THEN - DISCH_THEN(X_CHOOSE_THEN `e:real` STRIP_ASSUME_TAC) THEN - FIRST_X_ASSUM(MP_TAC o SPEC `e / &2`) THEN ASM_REWRITE_TAC[REAL_HALF] THEN - DISCH_THEN(X_CHOOSE_THEN `c:(real^N->bool)->bool` STRIP_ASSUME_TAC) THEN - ONCE_REWRITE_TAC[SWAP_EXISTS_THM] THEN - EXISTS_TAC `UNIONS {t | t IN c /\ (x:real^N) IN closure t}` THEN - ONCE_REWRITE_TAC[TAUT - `p /\ q /\ r /\ s /\ t <=> q /\ t /\ p /\ r /\ s`] THEN - REWRITE_TAC[RIGHT_EXISTS_AND_THM] THEN REPEAT CONJ_TAC THENL - [MATCH_MP_TAC CONNECTED_UNIONS_STRONG THEN - ASM_SIMP_TAC[IN_ELIM_THM; GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN - EXISTS_TAC `x:real^N` THEN - SIMP_TAC[INTERS_GSPEC; IN_ELIM_THM; UNIONS_GSPEC; GSYM CONJ_ASSOC] THEN - MATCH_MP_TAC(MESON[] - `(!t. R t ==> Q t) /\ (?t. P t /\ R t) ==> (?t. P t /\ Q t /\ R t)`) THEN - REWRITE_TAC[REWRITE_RULE[SUBSET] CLOSURE_SUBSET] THEN ASM SET_TAC[]; - FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (REWRITE_RULE[IMP_CONJ_ALT] - SUBSET_TRANS)) THEN - REWRITE_TAC[SUBSET_INTER] THEN - CONJ_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN - REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_GSPEC] THEN - X_GEN_TAC `t:real^N->bool` THEN STRIP_TAC THEN - TRANS_TAC SUBSET_TRANS `closure t:real^N->bool` THEN - REWRITE_TAC[CLOSURE_SUBSET] THEN - FIRST_X_ASSUM(MP_TAC o SPEC `t:real^N->bool`) THEN ASM_REWRITE_TAC[] THEN - STRIP_TAC THEN REWRITE_TAC[SUBSET; IN_BALL] THEN - X_GEN_TAC `y:real^N` THEN DISCH_TAC THEN - MATCH_MP_TAC REAL_LET_TRANS THEN - EXISTS_TAC `diameter(t:real^N->bool)` THEN - CONJ_TAC THENL [REWRITE_TAC[dist]; ASM_REAL_ARITH_TAC] THEN - ONCE_REWRITE_TAC[GSYM DIAMETER_CLOSURE] THEN - MATCH_MP_TAC DIAMETER_BOUNDED_BOUND THEN - ASM_SIMP_TAC[BOUNDED_CLOSURE]; - ALL_TAC] THEN - EXISTS_TAC `s INTER ball(x:real^N,e) INTER - interior ((:real^N) DIFF - (s DIFF UNIONS {t | t IN c /\ x IN closure t}))` THEN - REPEAT CONJ_TAC THENL - [MATCH_MP_TAC OPEN_IN_OPEN_INTER THEN - SIMP_TAC[OPEN_INTER; OPEN_BALL; OPEN_INTERIOR]; - ASM_REWRITE_TAC[IN_INTER; CENTRE_IN_BALL] THEN - CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - REWRITE_TAC[INTERIOR_COMPLEMENT; IN_DIFF; IN_UNIV] THEN - DISCH_THEN(MP_TAC o - SPEC `closure(UNIONS {t | t IN c /\ ~((x:real^N) IN closure t)})` o - MATCH_MP(SET_RULE `x IN s ==> !t. s SUBSET t ==> x IN t`)) THEN - REWRITE_TAC[NOT_IMP] THEN CONJ_TAC THENL - [MATCH_MP_TAC SUBSET_CLOSURE THEN ASM SET_TAC[]; - ASM_SIMP_TAC[CLOSURE_UNIONS; FINITE_RESTRICT] THEN ASM SET_TAC[]]; - MATCH_MP_TAC(SET_RULE - `interior t SUBSET t /\ s INTER t SUBSET u - ==> s INTER b INTER interior t SUBSET u`) THEN - REWRITE_TAC[INTERIOR_SUBSET] THEN SET_TAC[]]);; + GEN_TAC THEN DISCH_TAC THEN + MP_TAC(ISPEC `submetric euclidean_metric (s:real^N->bool)` + FCCOVERABLE_SPACE_IMP_LOCALLY_CONNECTED_SPACE) THEN + REWRITE_TAC[LOCALLY_CONNECTED_SPACE_SUBMETRIC_EUCLIDEAN; + FCCOVERABLE_SPACE_SUBMETRIC_EUCLIDEAN] THEN + ASM_MESON_TAC[]);; +(* ULC_IMP_LOCALLY_CONNECTED: derive from the metric version *) let ULC_IMP_LOCALLY_CONNECTED = prove (`!s:real^N->bool. (!e. &0 < e ==> ?d. &0 < d /\ !x y. x IN s /\ y IN s /\ dist(x,y) < d ==> ?c. x IN c /\ y IN c /\ c SUBSET s /\ - connected c /\ bounded c /\ diameter c <= e) + connected c /\ + bounded c /\ diameter c <= e) ==> locally connected s`, - GEN_TAC THEN - REWRITE_TAC[LOCALLY_CONNECTED_IM_KLEINEN] THEN - DISCH_TAC THEN MAP_EVERY X_GEN_TAC [`u:real^N->bool`; `p:real^N`] THEN - DISCH_THEN(CONJUNCTS_THEN2 MP_TAC ASSUME_TAC) THEN - GEN_REWRITE_TAC LAND_CONV [OPEN_IN_CONTAINS_BALL] THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (MP_TAC o SPEC `p:real^N`)) THEN - ASM_REWRITE_TAC[] THEN - DISCH_THEN(X_CHOOSE_THEN `e:real` STRIP_ASSUME_TAC) THEN - FIRST_X_ASSUM(MP_TAC o SPEC `e / &2`) THEN ASM_REWRITE_TAC[REAL_HALF] THEN - DISCH_THEN(X_CHOOSE_THEN `d:real` STRIP_ASSUME_TAC) THEN - EXISTS_TAC `s INTER ball(p:real^N,min d e)` THEN - ASM_SIMP_TAC[OPEN_IN_OPEN_INTER; OPEN_BALL] THEN - ASM_REWRITE_TAC[CENTRE_IN_BALL; REAL_LT_MIN; IN_INTER] THEN - REWRITE_TAC[BALL_MIN_INTER; CONJ_ASSOC] THEN - CONJ_TAC THENL [ASM SET_TAC[]; REWRITE_TAC[GSYM CONJ_ASSOC]] THEN - X_GEN_TAC `x:real^N` THEN REWRITE_TAC[IN_INTER; IN_BALL] THEN STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`p:real^N`; `x:real^N`]) THEN - ASM_REWRITE_TAC[] THEN - ANTS_TAC THENL [ASM SET_TAC[]; MATCH_MP_TAC MONO_EXISTS] THEN - X_GEN_TAC `c:real^N->bool` THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN - FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (SET_RULE - `b INTER s SUBSET u ==> c SUBSET s /\ c SUBSET b ==> c SUBSET u`)) THEN - ASM_REWRITE_TAC[] THEN REWRITE_TAC[SUBSET; IN_BALL] THEN - X_GEN_TAC `y:real^N` THEN DISCH_TAC THEN - FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (REAL_ARITH - `c <= e / &2 ==> &0 < e /\ d <= c ==> d < e`)) THEN - ASM_REWRITE_TAC[dist] THEN MATCH_MP_TAC DIAMETER_BOUNDED_BOUND THEN - ASM_REWRITE_TAC[]);; + GEN_TAC THEN DISCH_TAC THEN + MP_TAC(ISPEC `submetric euclidean_metric (s:real^N->bool)` + ULC_SPACE_IMP_LOCALLY_CONNECTED_SPACE) THEN + REWRITE_TAC[LOCALLY_CONNECTED_SPACE_SUBMETRIC_EUCLIDEAN; + ULC_SPACE_SUBMETRIC_EUCLIDEAN] THEN + DISCH_THEN MATCH_MP_TAC THEN FIRST_ASSUM ACCEPT_TAC);; +(* FCCOVERABLE_INTERMEDIATE_CLOSURE: derive from the metric version *) let FCCOVERABLE_INTERMEDIATE_CLOSURE = prove (`!s t:real^N->bool. s SUBSET t /\ t SUBSET closure s /\ @@ -7966,33 +8024,11 @@ let FCCOVERABLE_INTERMEDIATE_CLOSURE = prove !t. t IN c ==> connected t /\ bounded t /\ diameter t <= e)`, REPEAT GEN_TAC THEN - REPEAT(DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) THEN - MATCH_MP_TAC MONO_FORALL THEN X_GEN_TAC `e:real` THEN - ASM_CASES_TAC `&0 < e` THEN ASM_REWRITE_TAC[] THEN - DISCH_THEN(X_CHOOSE_THEN `c:(real^N->bool)->bool` STRIP_ASSUME_TAC) THEN - EXISTS_TAC `{t INTER closure k:real^N->bool | k IN c}` THEN - ASM_SIMP_TAC[SIMPLE_IMAGE; FINITE_IMAGE; UNIONS_IMAGE; FORALL_IN_IMAGE] THEN - CONJ_TAC THENL - [MATCH_MP_TAC SUBSET_ANTISYM THEN - CONJ_TAC THENL [SET_TAC[]; ALL_TAC] THEN - SIMP_TAC[SUBSET; IN_INTER; IN_ELIM_THM] THEN - FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (SET_RULE - `t SUBSET c ==> (!x. x IN c ==> P x) ==> (!x. x IN t ==> P x)`)) THEN - FIRST_X_ASSUM(SUBST1_TAC o SYM) THEN - ASM_SIMP_TAC[CLOSURE_UNIONS] THEN SET_TAC[]; - X_GEN_TAC `k:real^N->bool` THEN DISCH_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPEC `k:real^N->bool`) THEN - ASM_REWRITE_TAC[] THEN REPEAT STRIP_TAC THENL - [MATCH_MP_TAC CONNECTED_INTERMEDIATE_CLOSURE THEN - EXISTS_TAC `k:real^N->bool` THEN ASM_REWRITE_TAC[INTER_SUBSET] THEN - REWRITE_TAC[SUBSET_INTER; CLOSURE_SUBSET] THEN ASM SET_TAC[]; - ASM_MESON_TAC[BOUNDED_SUBSET; INTER_SUBSET; BOUNDED_CLOSURE]; - FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (REWRITE_RULE[IMP_CONJ_ALT] - REAL_LE_TRANS)) THEN - GEN_REWRITE_TAC RAND_CONV [GSYM DIAMETER_CLOSURE] THEN - MATCH_MP_TAC DIAMETER_SUBSET THEN - ASM_SIMP_TAC[INTER_SUBSET; BOUNDED_CLOSURE]]]);; + REWRITE_TAC[GSYM FCCOVERABLE_IN_EUCLIDEAN_METRIC; + GSYM EUCLIDEAN_CLOSURE_OF; GSYM MTOPOLOGY_EUCLIDEAN_METRIC] THEN + MATCH_ACCEPT_TAC FCCOVERABLE_SPACE_INTERMEDIATE_CLOSURE);; +(* COMPACT_LOCALLY_CONNECTED_IMP_ULC: derive from the metric version *) let COMPACT_LOCALLY_CONNECTED_IMP_ULC = prove (`!s:real^N->bool. compact s /\ locally connected s @@ -8003,78 +8039,15 @@ let COMPACT_LOCALLY_CONNECTED_IMP_ULC = prove connected c /\ bounded c /\ diameter c <= e)`, GEN_TAC THEN STRIP_TAC THEN - X_GEN_TAC `e:real` THEN DISCH_TAC THEN - MATCH_MP_TAC(MESON[] `((!x. ~P x) ==> F) ==> ?x. P x`) THEN - DISCH_THEN(MP_TAC o GEN `n:num` o SPEC `inv(&2 pow n)`) THEN - REWRITE_TAC[REAL_LT_INV_EQ; REAL_LT_POW2; RIGHT_AND_FORALL_THM] THEN - GEN_REWRITE_TAC (RAND_CONV o TOP_DEPTH_CONV) [NOT_FORALL_THM] THEN - REWRITE_TAC[SKOLEM_THM; NOT_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`x:num->real^N`; `y:num->real^N`] THEN - REWRITE_TAC[NOT_IMP; FORALL_AND_THM] THEN STRIP_TAC THEN - MP_TAC(ISPEC `(s:real^N->bool) PCROSS s` compact) THEN - ASM_REWRITE_TAC[COMPACT_PCROSS_EQ] THEN - DISCH_THEN(MP_TAC o SPEC `\n:num. pastecart(x n:real^N) (y n:real^N)`) THEN - ASM_REWRITE_TAC[PASTECART_IN_PCROSS; NOT_IMP] THEN - ASM_REWRITE_TAC[NOT_EXISTS_THM; FORALL_PASTECART; PASTECART_IN_PCROSS] THEN - MAP_EVERY X_GEN_TAC [`w:real^N`; `z:real^N`; `r:num->num`] THEN - REWRITE_TAC[o_DEF; LIM_PASTECART_EQ] THEN STRIP_TAC THEN - SUBGOAL_THEN `w:real^N = z` SUBST_ALL_TAC THENL - [ONCE_REWRITE_TAC[GSYM VECTOR_SUB_EQ] THEN - MATCH_MP_TAC(ISPEC `sequentially` LIM_UNIQUE) THEN - EXISTS_TAC `(\n. x((r:num->num) n) - y(r n)):num->real^N` THEN - ASM_SIMP_TAC[LIM_SUB; TRIVIAL_LIMIT_SEQUENTIALLY] THEN - REWRITE_TAC[LIM_SEQUENTIALLY; DIST_0] THEN X_GEN_TAC `d:real` THEN - DISCH_TAC THEN MP_TAC(ISPEC `max (inv d) (inv e)` REAL_ARCH_POW2) THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `n:num` THEN - REWRITE_TAC[REAL_MAX_LT] THEN STRIP_TAC THEN - X_GEN_TAC `m:num` THEN DISCH_TAC THEN - MATCH_MP_TAC REAL_LET_TRANS THEN - EXISTS_TAC `inv(&2 pow ((r:num->num) m))` THEN - ASM_SIMP_TAC[GSYM dist; REAL_LT_IMP_LE] THEN - GEN_REWRITE_TAC RAND_CONV [GSYM REAL_INV_INV] THEN - MATCH_MP_TAC REAL_LT_INV2 THEN ASM_REWRITE_TAC[REAL_LT_INV_EQ] THEN - TRANS_TAC REAL_LTE_TRANS `&2 pow n` THEN ASM_REWRITE_TAC[] THEN - MATCH_MP_TAC REAL_POW_MONO THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN - TRANS_TAC LE_TRANS `m:num` THEN ASM_MESON_TAC[MONOTONE_BIGGER]; - ALL_TAC] THEN - FIRST_ASSUM(MP_TAC o GEN_REWRITE_RULE I [LOCALLY_CONNECTED]) THEN - DISCH_THEN(MP_TAC o SPECL [`s INTER ball(z:real^N,e / &2)`; `z:real^N`]) THEN - ASM_SIMP_TAC[OPEN_IN_OPEN_INTER; OPEN_BALL; IN_INTER; CENTRE_IN_BALL; - REAL_HALF] THEN - DISCH_THEN(X_CHOOSE_THEN `u:real^N->bool` STRIP_ASSUME_TAC) THEN - SUBGOAL_THEN - `?d. &0 < d /\ ball(z:real^N,d) INTER s SUBSET u` - STRIP_ASSUME_TAC THENL - [FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [open_in]) THEN - DISCH_THEN(MP_TAC o SPEC `z:real^N` o CONJUNCT2) THEN - ASM_REWRITE_TAC[SUBSET; IN_INTER; IN_BALL] THEN MESON_TAC[DIST_SYM]; - ALL_TAC] THEN - MAP_EVERY UNDISCH_TAC - [`((\m:num. (y:num->real^N) (r m)) --> z) sequentially`; - `((\m:num. (x:num->real^N) (r m)) --> z) sequentially`] THEN - REWRITE_TAC[TAUT `p ==> ~q <=> ~(p /\ q)`; tendsto; AND_FORALL_THM] THEN - DISCH_THEN(MP_TAC o SPEC `min d (e / &2)`) THEN - ASM_REWRITE_TAC[REAL_HALF; REAL_LT_MIN; GSYM EVENTUALLY_AND] THEN - REWRITE_TAC[EVENTUALLY_SEQUENTIALLY] THEN - DISCH_THEN(X_CHOOSE_THEN `n:num` (MP_TAC o SPEC `n:num`)) THEN - REWRITE_TAC[LE_REFL] THEN STRIP_TAC THEN - RULE_ASSUM_TAC(REWRITE_RULE[NOT_EXISTS_THM; RIGHT_AND_FORALL_THM; - RIGHT_IMP_FORALL_THM]) THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`(r:num->num) n`; `u:real^N->bool`]) THEN - ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL - [FIRST_X_ASSUM(MATCH_MP_TAC o REWRITE_RULE[SUBSET]) THEN - ASM_REWRITE_TAC[IN_BALL; IN_INTER] THEN ASM_MESON_TAC[DIST_SYM]; - FIRST_X_ASSUM(MATCH_MP_TAC o REWRITE_RULE[SUBSET]) THEN - ASM_REWRITE_TAC[IN_BALL; IN_INTER] THEN ASM_MESON_TAC[DIST_SYM]; - ASM SET_TAC[]; - MATCH_MP_TAC BOUNDED_SUBSET THEN EXISTS_TAC `ball(z:real^N,e / &2)` THEN - REWRITE_TAC[BOUNDED_BALL] THEN ASM SET_TAC[]; - TRANS_TAC REAL_LE_TRANS `diameter(ball(z:real^N,e / &2))` THEN - CONJ_TAC THENL - [MATCH_MP_TAC DIAMETER_SUBSET THEN REWRITE_TAC[BOUNDED_BALL] THEN - ASM SET_TAC[]; - REWRITE_TAC[DIAMETER_BALL] THEN ASM_REAL_ARITH_TAC]]);; - + MP_TAC(ISPEC `submetric euclidean_metric (s:real^N->bool)` + COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE) THEN + REWRITE_TAC[SUBMETRIC_EUCLIDEAN_METRIC; + COMPACT_IN_SUBMETRIC_EUCLIDEAN_MSPACE; + LOCALLY_CONNECTED_SPACE_SUBMETRIC_EUCLIDEAN; + ULC_SPACE_SUBMETRIC_EUCLIDEAN] THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[]);; + +(* COMPACT_LOCALLY_CONNECTED_IMP_ULC_ALT: derive from the above *) let COMPACT_LOCALLY_CONNECTED_IMP_ULC_ALT = prove (`!s:real^N->bool. compact s /\ locally connected s @@ -8101,6 +8074,7 @@ let COMPACT_LOCALLY_CONNECTED_IMP_ULC_ALT = prove REWRITE_TAC[dist] THEN ASM_SIMP_TAC[DIAMETER_BOUNDED_BOUND] THEN ASM_REAL_ARITH_TAC);; +(* BOUNDED_ULC_IMP_FCCOVERABLE: derive from the metric version *) let BOUNDED_ULC_IMP_FCCOVERABLE = prove (`!s:real^N->bool. bounded s /\ @@ -8112,115 +8086,21 @@ let BOUNDED_ULC_IMP_FCCOVERABLE = prove ==> (!e. &0 < e ==> ?c. FINITE c /\ UNIONS c = s /\ !t. t IN c ==> connected t /\ bounded t /\ diameter t <= e)`, - REPEAT GEN_TAC THEN - STRIP_TAC THEN X_GEN_TAC `e:real` THEN DISCH_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPEC `e / &2`) THEN - ASM_REWRITE_TAC[REAL_HALF] THEN - DISCH_THEN(X_CHOOSE_THEN `d:real` STRIP_ASSUME_TAC) THEN - ABBREV_TAC - `M = \p. {x | x IN s /\ - ?c. (p:real^N) IN c /\ (x:real^N) IN c /\ c SUBSET s /\ - connected c /\ bounded c /\ diameter c <= e / &2}` THEN - SUBGOAL_THEN `!p:real^N. p IN s ==> ball(p,d) INTER s SUBSET M p` - ASSUME_TAC THENL - [X_GEN_TAC `p:real^N` THEN DISCH_TAC THEN EXPAND_TAC "M" THEN - REWRITE_TAC[SUBSET; IN_INTER; IN_BALL; IN_ELIM_THM] THEN - X_GEN_TAC `x:real^N` THEN STRIP_TAC THEN ASM_REWRITE_TAC[GSYM SUBSET] THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`p:real^N`; `x:real^N`]) THEN - ASM_MESON_TAC[]; - ALL_TAC] THEN - SUBGOAL_THEN - `?k. FINITE k /\ k SUBSET s /\ - UNIONS(IMAGE (M:real^N->real^N->bool) k) = s` - STRIP_ASSUME_TAC THENL - [ONCE_REWRITE_TAC[MESON[] - `(?x. P x /\ Q x /\ R x) <=> ~(!x. P x /\ Q x ==> ~R x)`] THEN - DISCH_TAC THEN - SUBGOAL_THEN - `?f:num->real^N. - !n. f n IN s DIFF UNIONS(IMAGE ((M:real^N->real^N->bool) o f) - {m | m < n})` - STRIP_ASSUME_TAC THENL - [SUBGOAL_THEN - `?f:num->real^N. - !n. f n = @x. x IN s DIFF UNIONS(IMAGE ((M:real^N->real^N->bool) o f) - {m | m < n})` - MP_TAC THENL - [MATCH_MP_TAC(MATCH_MP WF_REC WF_num) THEN REPEAT STRIP_TAC THEN - REWRITE_TAC[IMAGE_o] THEN - AP_TERM_TAC THEN ABS_TAC THEN REPLICATE_TAC 4 AP_TERM_TAC THEN - ASM SET_TAC[]; - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `f:num->real^N` THEN - DISCH_TAC THEN MATCH_MP_TAC num_WF THEN - X_GEN_TAC `n:num` THEN DISCH_TAC THEN - ONCE_ASM_REWRITE_TAC[] THEN CONV_TAC SELECT_CONV THEN - FIRST_X_ASSUM(MP_TAC o SPEC `IMAGE (f:num->real^N) {m | m < n}`) THEN - SIMP_TAC[FINITE_NUMSEG_LT; FINITE_IMAGE] THEN - ANTS_TAC THENL [ASM SET_TAC[]; REWRITE_TAC[IMAGE_o]] THEN - MATCH_MP_TAC(SET_RULE - `t SUBSET s ==> ~(t = s) ==> ?x. x IN s DIFF t`) THEN - REWRITE_TAC[UNIONS_SUBSET] THEN ONCE_REWRITE_TAC[FORALL_IN_IMAGE] THEN - EXPAND_TAC "M" THEN SET_TAC[]]; - MP_TAC(ISPECL [`IMAGE (f:num->real^N) (:num)`; `d:real`] - DISCRETE_BOUNDED_IMP_FINITE) THEN - ASM_REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM; FORALL_IN_IMAGE] THEN - REWRITE_TAC[IN_UNIV; NOT_IMP] THEN - SUBGOAL_THEN `!m n. norm((f:num->real^N) m - f n) < d ==> m = n` - ASSUME_TAC THENL - [MATCH_MP_TAC WLOG_LT THEN REWRITE_TAC[] THEN - CONJ_TAC THENL [MESON_TAC[NORM_SUB]; ALL_TAC] THEN - MAP_EVERY X_GEN_TAC [`m:num`; `n:num`] THEN REPEAT DISCH_TAC THEN - FIRST_ASSUM(MP_TAC o SPEC `n:num`) THEN - MATCH_MP_TAC(SET_RULE `x IN t ==> x IN s DIFF t ==> P`) THEN - REWRITE_TAC[IN_UNIONS; EXISTS_IN_IMAGE; o_THM; IN_ELIM_THM] THEN - EXISTS_TAC `m:num` THEN ASM_REWRITE_TAC[] THEN - UNDISCH_THEN `!p:real^N. p IN s ==> ball(p,d) INTER s SUBSET M p` - (MP_TAC o SPEC `(f:num->real^N) m`) THEN - ANTS_TAC THENL [ASM SET_TAC[]; REWRITE_TAC[SUBSET]] THEN - DISCH_THEN MATCH_MP_TAC THEN - ASM_REWRITE_TAC[IN_BALL; IN_INTER; dist] THEN - ASM SET_TAC[]; - ALL_TAC] THEN - REPEAT CONJ_TAC THENL - [ASM_MESON_TAC[]; - FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (REWRITE_RULE[IMP_CONJ] - BOUNDED_SUBSET)) THEN ASM SET_TAC[]; - W(MP_TAC o PART_MATCH (lhand o rand) FINITE_IMAGE_INJ_EQ o - rand o snd) THEN - REWRITE_TAC[REWRITE_RULE[INFINITE] num_INFINITE] THEN - DISCH_THEN MATCH_MP_TAC THEN REWRITE_TAC[IN_UNIV] THEN - ASM_MESON_TAC[VECTOR_SUB_REFL; NORM_0]]]; - EXISTS_TAC `IMAGE (M:real^N->real^N->bool) k` THEN - ASM_SIMP_TAC[FINITE_IMAGE; FORALL_IN_IMAGE] THEN - X_GEN_TAC `p:real^N` THEN EXPAND_TAC "M" THEN REWRITE_TAC[] THEN - REPEAT STRIP_TAC THENL - [GEN_REWRITE_TAC I [CONNECTED_IFF_CONNECTED_COMPONENT] THEN - MAP_EVERY X_GEN_TAC [`x:real^N`; `y:real^N`] THEN - REWRITE_TAC[IN_ELIM_THM] THEN - DISCH_THEN(CONJUNCTS_THEN (CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) THEN - DISCH_THEN(X_CHOOSE_THEN `c:real^N->bool` STRIP_ASSUME_TAC) THEN - DISCH_THEN(X_CHOOSE_THEN `d:real^N->bool` STRIP_ASSUME_TAC) THEN - REWRITE_TAC[connected_component] THEN - EXISTS_TAC `c UNION d:real^N->bool` THEN - ASM_REWRITE_TAC[IN_UNION; UNION_SUBSET] THEN CONJ_TAC THENL - [MATCH_MP_TAC CONNECTED_UNION THEN ASM SET_TAC[]; ASM SET_TAC[]]; - MATCH_MP_TAC BOUNDED_SUBSET THEN EXISTS_TAC `s:real^N->bool` THEN - ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; - MATCH_MP_TAC DIAMETER_LE THEN ASM_SIMP_TAC[REAL_LT_IMP_LE] THEN - MAP_EVERY X_GEN_TAC [`x:real^N`; `y:real^N`] THEN - REWRITE_TAC[IN_ELIM_THM] THEN - DISCH_THEN(CONJUNCTS_THEN (CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) THEN - DISCH_THEN(X_CHOOSE_THEN `c:real^N->bool` STRIP_ASSUME_TAC) THEN - DISCH_THEN(X_CHOOSE_THEN `d:real^N->bool` STRIP_ASSUME_TAC) THEN - MATCH_MP_TAC(NORM_ARITH - `!p:real^N. norm(x - p) <= e / &2 /\ norm(y - p) <= e / &2 - ==> norm(x - y) <= e`) THEN - EXISTS_TAC `p:real^N` THEN CONJ_TAC THENL - [TRANS_TAC REAL_LE_TRANS `diameter(d:real^N->bool)`; - TRANS_TAC REAL_LE_TRANS `diameter(c:real^N->bool)`] THEN - ASM_REWRITE_TAC[] THEN MATCH_MP_TAC DIAMETER_BOUNDED_BOUND THEN - ASM_REWRITE_TAC[]]]);; + GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPEC `submetric euclidean_metric (s:real^N->bool)` + TOTALLY_BOUNDED_ULC_SPACE_IMP_FCCOVERABLE_SPACE) THEN + REWRITE_TAC[SUBMETRIC_EUCLIDEAN_METRIC; + ULC_SPACE_SUBMETRIC_EUCLIDEAN; FCCOVERABLE_SPACE_SUBMETRIC_EUCLIDEAN] THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC TOTALLY_BOUNDED_IN_SUBMETRIC THEN + REWRITE_TAC[SUBSET_REFL] THEN + MATCH_MP_TAC COMPACT_CLOSURE_OF_IMP_TOTALLY_BOUNDED_IN THEN + REWRITE_TAC[EUCLIDEAN_METRIC; SUBSET_UNIV; + MTOPOLOGY_EUCLIDEAN_METRIC; EUCLIDEAN_CLOSURE_OF; + COMPACT_IN_EUCLIDEAN; COMPACT_CLOSURE] THEN + ASM_REWRITE_TAC[]);; +(* COMPACT_LOCALLY_CONNECTED_IMP_FCCOVERABLE: simple from above *) let COMPACT_LOCALLY_CONNECTED_IMP_FCCOVERABLE = prove (`!s:real^N->bool. compact s /\ locally connected s @@ -8235,6 +8115,7 @@ let COMPACT_LOCALLY_CONNECTED_IMP_FCCOVERABLE = prove DISCH_THEN(MP_TAC o MATCH_MP BOUNDED_ULC_IMP_FCCOVERABLE) THEN REWRITE_TAC[]);; +(* COMPACT_LOCALLY_CONNECTED_EQ_FCCCOVERABLE *) let COMPACT_LOCALLY_CONNECTED_EQ_FCCCOVERABLE = prove (`!s:real^N->bool. compact s /\ locally connected s <=> @@ -9259,219 +9140,17 @@ let SEMI_LOCALLY_CONNECTED = prove ==> ?u. open_in (subtopology euclidean s) u /\ x IN u /\ u SUBSET v /\ FINITE(components(s DIFF u))`, - REPEAT STRIP_TAC THEN - MP_TAC(ASSUME `locally compact (s:real^N->bool)`) THEN - REWRITE_TAC[locally] THEN - DISCH_THEN(MP_TAC o SPECL [`v:real^N->bool`; `x:real^N`]) THEN - ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`d:real^N->bool`; `c:real^N->bool`] THEN STRIP_TAC THEN - SUBGOAL_THEN - `?u k:real^N->bool. - x IN u /\ u SUBSET k /\ k SUBSET d /\ - open_in (subtopology euclidean s) u /\ - closed_in (subtopology euclidean s) k` - STRIP_ASSUME_TAC THENL - [UNDISCH_TAC `locally compact (s:real^N->bool)` THEN - REWRITE_TAC[locally] THEN - DISCH_THEN(MP_TAC o SPECL [`d:real^N->bool`; `x:real^N`]) THEN - ASM_REWRITE_TAC[] THEN REPEAT(MATCH_MP_TAC MONO_EXISTS THEN GEN_TAC) THEN - STRIP_TAC THEN ASM_REWRITE_TAC[] THEN - ASM_MESON_TAC[CLOSED_SUBSET; COMPACT_IMP_CLOSED; OPEN_IN_IMP_SUBSET; - SUBSET_TRANS]; - ALL_TAC] THEN - SUBGOAL_THEN - `!x:real^N. x IN c DIFF d - ==> ?t. open_in (subtopology euclidean s) t /\ - connected t /\ - x IN t /\ t SUBSET s DIFF k` - MP_TAC THENL - [X_GEN_TAC `y:real^N` THEN REWRITE_TAC[IN_DIFF] THEN STRIP_TAC THEN - FIRST_X_ASSUM(MATCH_MP_TAC o REWRITE_RULE [LOCALLY_CONNECTED]) THEN - ASM_SIMP_TAC[OPEN_IN_DIFF; OPEN_IN_REFL] THEN - REPEAT(FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_IMP_SUBSET)) THEN - ASM SET_TAC[]; - ALL_TAC] THEN - GEN_REWRITE_TAC (LAND_CONV o TOP_DEPTH_CONV) - [RIGHT_IMP_EXISTS_THM; SKOLEM_THM] THEN - DISCH_THEN(X_CHOOSE_THEN `t:real^N->real^N->bool` STRIP_ASSUME_TAC) THEN - SUBGOAL_THEN `compact(c DIFF d:real^N->bool)` MP_TAC THENL - [UNDISCH_TAC `open_in (subtopology euclidean s) (d:real^N->bool)` THEN - REWRITE_TAC[OPEN_IN_OPEN] THEN - DISCH_THEN(X_CHOOSE_THEN `w:real^N->bool` STRIP_ASSUME_TAC) THEN - SUBGOAL_THEN `c DIFF d:real^N->bool = c DIFF w` - (fun th -> ASM_SIMP_TAC[th; COMPACT_DIFF]) THEN - ASM SET_TAC[]; - GEN_REWRITE_TAC LAND_CONV [COMPACT_EQ_HEINE_BOREL_GEN]] THEN - DISCH_THEN(MP_TAC o SPECL - [`IMAGE (t:real^N->real^N->bool) (c DIFF d)`; `s:real^N->bool`]) THEN - ASM_REWRITE_TAC[FORALL_IN_IMAGE] THEN ASM_SIMP_TAC[] THEN - ANTS_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - GEN_REWRITE_TAC (LAND_CONV o BINDER_CONV) - [TAUT `p /\ q /\ r <=> q /\ p /\ r`] THEN - REWRITE_TAC[EXISTS_FINITE_SUBSET_IMAGE] THEN - DISCH_THEN(X_CHOOSE_THEN `q:real^N->bool` STRIP_ASSUME_TAC) THEN - ABBREV_TAC - `r = (s DIFF d) UNION - UNIONS(IMAGE (\x. s INTER closure((t:real^N->real^N->bool) x)) q)` THEN - EXISTS_TAC `s DIFF r:real^N->bool` THEN REPEAT CONJ_TAC THENL - [MATCH_MP_TAC OPEN_IN_DIFF THEN ASM_REWRITE_TAC[OPEN_IN_REFL] THEN - EXPAND_TAC "r" THEN MATCH_MP_TAC CLOSED_IN_UNION THEN - ASM_SIMP_TAC[CLOSED_IN_DIFF; CLOSED_IN_REFL] THEN - MATCH_MP_TAC CLOSED_IN_UNIONS THEN ASM_SIMP_TAC[FINITE_IMAGE] THEN - REWRITE_TAC[FORALL_IN_IMAGE] THEN - SIMP_TAC[CLOSED_IN_CLOSED_INTER; CLOSED_CLOSURE]; - ASM_REWRITE_TAC[IN_DIFF] THEN EXPAND_TAC "r" THEN - REWRITE_TAC[IN_UNION; UNIONS_IMAGE; IN_DIFF; IN_ELIM_THM] THEN - SUBGOAL_THEN `(x:real^N) IN s` ASSUME_TAC THENL - [REPEAT(FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_IMP_SUBSET)) THEN - ASM SET_TAC[]; - ASM_REWRITE_TAC[IN_INTER; NOT_EXISTS_THM]] THEN - X_GEN_TAC `y:real^N` THEN STRIP_TAC THEN - SUBGOAL_THEN `s INTER closure((t:real^N->real^N->bool) y) - SUBSET s DIFF u` - MP_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN - MATCH_MP_TAC CLOSURE_MINIMAL_LOCAL THEN - ASM_SIMP_TAC[CLOSED_IN_DIFF; CLOSED_IN_REFL] THEN ASM SET_TAC[]; - ASM SET_TAC[]; - ALL_TAC] THEN - SUBGOAL_THEN `(r:real^N->bool) SUBSET s` ASSUME_TAC THENL - [EXPAND_TAC "r" THEN MATCH_MP_TAC(SET_RULE - `t SUBSET s ==> (s DIFF d) UNION t SUBSET s`) THEN - REWRITE_TAC[UNIONS_SUBSET; FORALL_IN_IMAGE] THEN SET_TAC[]; - ASM_SIMP_TAC[SET_RULE `r SUBSET s ==> s DIFF (s DIFF r) = r`]] THEN - MATCH_MP_TAC FINITE_SUBSET THEN - EXISTS_TAC `IMAGE (\x:real^N. connected_component r x) q` THEN - ASM_SIMP_TAC[FINITE_IMAGE] THEN - REWRITE_TAC[components; SUBSET; FORALL_IN_GSPEC] THEN - X_GEN_TAC `y:real^N` THEN DISCH_TAC THEN REWRITE_TAC[IN_IMAGE] THEN - ASM_REWRITE_TAC[CONNECTED_COMPONENT_EQ_EQ] THEN - MP_TAC(ASSUME `(y:real^N) IN r`) THEN EXPAND_TAC "r" THEN - GEN_REWRITE_TAC LAND_CONV [IN_UNION] THEN ASM_REWRITE_TAC[] THEN - REWRITE_TAC[IN_DIFF; UNIONS_IMAGE; IN_ELIM_THM] THEN - MATCH_MP_TAC(TAUT - `(q ==> r) /\ (~q /\ p ==> r) ==> p \/ q ==> r`) THEN - CONJ_TAC THENL - [MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `z:real^N` THEN - REWRITE_TAC[IN_INTER] THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN - CONJ_TAC THENL [ASM SET_TAC[]; REWRITE_TAC[connected_component]] THEN - EXISTS_TAC `s INTER closure ((t:real^N->real^N->bool) z)` THEN - REPEAT CONJ_TAC THENL - [MATCH_MP_TAC CONNECTED_INTERMEDIATE_CLOSURE THEN - EXISTS_TAC `(t:real^N->real^N->bool) z` THEN - REWRITE_TAC[INTER_SUBSET] THEN - CONJ_TAC THENL [ASM SET_TAC[]; REWRITE_TAC[SUBSET_INTER]] THEN - REWRITE_TAC[CLOSURE_SUBSET] THEN - FIRST_X_ASSUM(MP_TAC o SPEC `z:real^N`) THEN REWRITE_TAC[open_in] THEN - ASM SET_TAC[]; - EXPAND_TAC "r" THEN REWRITE_TAC[UNIONS_IMAGE] THEN ASM SET_TAC[]; - ASM SET_TAC[]; - ASM_REWRITE_TAC[IN_INTER] THEN - FIRST_X_ASSUM(MP_TAC o SPEC `z:real^N`) THEN REWRITE_TAC[open_in] THEN - MP_TAC(ISPEC `(t:real^N->real^N->bool) z` CLOSURE_SUBSET) THEN - ASM SET_TAC[]]; - ALL_TAC] THEN - ASM_CASES_TAC `(y:real^N) IN d` THEN ASM_REWRITE_TAC[] THEN - ASM_CASES_TAC `(y:real^N) IN s` THEN ASM_REWRITE_TAC[] THEN - ASM_CASES_TAC `(y:real^N) IN c` THENL - [MATCH_MP_TAC(TAUT `p ==> ~p ==> r`) THEN - SUBGOAL_THEN `y IN UNIONS (IMAGE (t:real^N->real^N->bool) q)` - MP_TAC THENL [ASM SET_TAC[]; REWRITE_TAC[UNIONS_IMAGE; IN_ELIM_THM]] THEN - REWRITE_TAC[IN_INTER] THEN ASM_MESON_TAC[CLOSURE_SUBSET; SUBSET]; - DISCH_THEN(K ALL_TAC)] THEN - SUBGOAL_THEN - `~((s INTER closure(connected_component (s DIFF c) y)) INTER c - :real^N->bool = {})` - MP_TAC THENL - [MATCH_MP_TAC(SET_RULE - `~(s INTER l SUBSET s DIFF c) ==> ~((s INTER l) INTER c = {})`) THEN - DISCH_TAC THEN MP_TAC(ISPEC `s:real^N->bool` CONNECTED_CLOPEN) THEN - ASM_REWRITE_TAC[] THEN DISCH_THEN(MP_TAC o SPEC - `connected_component (s DIFF c) y:real^N->bool`) THEN - ASM_REWRITE_TAC[NOT_IMP; CONNECTED_COMPONENT_EQ_EMPTY; IN_DIFF] THEN - REPEAT CONJ_TAC THENL - [TRANS_TAC OPEN_IN_TRANS `s DIFF c:real^N->bool` THEN CONJ_TAC THENL - [MATCH_MP_TAC OPEN_IN_CONNECTED_COMPONENT_LOCALLY_CONNECTED THEN - MATCH_MP_TAC LOCALLY_OPEN_SUBSET THEN - EXISTS_TAC `s:real^N->bool` THEN ASM_REWRITE_TAC[]; - ALL_TAC] THEN - MATCH_MP_TAC OPEN_IN_DIFF THEN ASM_REWRITE_TAC[OPEN_IN_REFL] THEN - ASM_MESON_TAC[CLOSED_SUBSET; COMPACT_IMP_CLOSED; OPEN_IN_IMP_SUBSET; - SUBSET_TRANS]; - REWRITE_TAC[CLOSED_IN_INTER_CLOSURE] THEN - MATCH_MP_TAC SUBSET_ANTISYM THEN CONJ_TAC THENL - [MATCH_MP_TAC CONNECTED_COMPONENT_MAXIMAL THEN - ASM_REWRITE_TAC[IN_INTER] THEN CONJ_TAC THENL - [MATCH_MP_TAC(SET_RULE - `c y /\ c SUBSET closure c ==> y IN closure c`) THEN - ASM_REWRITE_TAC[CLOSURE_SUBSET; CONNECTED_COMPONENT_REFL_EQ] THEN - ASM_REWRITE_TAC[IN_DIFF]; - MATCH_MP_TAC CONNECTED_INTERMEDIATE_CLOSURE THEN - EXISTS_TAC `connected_component (s DIFF c) y:real^N->bool` THEN - REWRITE_TAC[CONNECTED_CONNECTED_COMPONENT; INTER_SUBSET]]; - ALL_TAC] THEN - REWRITE_TAC[SUBSET_INTER; CLOSURE_SUBSET] THEN - TRANS_TAC SUBSET_TRANS `s DIFF c:real^N->bool` THEN - REWRITE_TAC[CONNECTED_COMPONENT_SUBSET] THEN SET_TAC[]; - MATCH_MP_TAC(SET_RULE - `connected_component (s DIFF c) y SUBSET s DIFF c /\ - c SUBSET s /\ ~(c = {}) - ==> ~(connected_component (s DIFF c) y = s)`) THEN - REWRITE_TAC[CONNECTED_COMPONENT_SUBSET] THEN - REPEAT(FIRST_X_ASSUM(MP_TAC o MATCH_MP OPEN_IN_IMP_SUBSET)) THEN - ASM SET_TAC[]]; - ALL_TAC] THEN - REWRITE_TAC[closure] THEN DISCH_THEN(MP_TAC o MATCH_MP (SET_RULE - `~((s INTER (cl UNION l)) INTER c = {}) - ==> cl SUBSET s DIFF c ==> ?x. x IN c /\ x IN s /\ x IN l`)) THEN - REWRITE_TAC[CONNECTED_COMPONENT_SUBSET; IN_ELIM_THM] THEN - DISCH_THEN(X_CHOOSE_THEN `z:real^N` STRIP_ASSUME_TAC) THEN - ASM_CASES_TAC `(z:real^N) IN d` THENL - [MP_TAC(ISPECL [`s:real^N->bool`; - `connected_component (s DIFF c) (y:real^N)`; - `d:real^N->bool`; `z:real^N`] - LIMIT_POINT_OF_LOCAL_IMP) THEN - ASM_REWRITE_TAC[] THEN ANTS_TAC THENL - [TRANS_TAC SUBSET_TRANS `s DIFF c:real^N->bool` THEN - REWRITE_TAC[CONNECTED_COMPONENT_SUBSET] THEN SET_TAC[]; - DISCH_THEN(X_CHOOSE_THEN `w:real^N` STRIP_ASSUME_TAC) THEN - MP_TAC(ISPECL [`s DIFF c:real^N->bool`; `y:real^N`] - CONNECTED_COMPONENT_SUBSET) THEN - ASM SET_TAC[]]; - ALL_TAC] THEN - SUBGOAL_THEN `z IN UNIONS (IMAGE (t:real^N->real^N->bool) q)` MP_TAC THENL - [ASM SET_TAC[]; ALL_TAC] THEN - REWRITE_TAC[UNIONS_IMAGE; IN_ELIM_THM] THEN - DISCH_THEN(X_CHOOSE_THEN `w:real^N` STRIP_ASSUME_TAC) THEN - MP_TAC(ISPECL [`s:real^N->bool`; - `connected_component (s DIFF c) (y:real^N)`; - `(t:real^N->real^N->bool) w`; `z:real^N`] - LIMIT_POINT_OF_LOCAL_IMP) THEN - ASM_REWRITE_TAC[] THEN ANTS_TAC THENL - [CONJ_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN - TRANS_TAC SUBSET_TRANS `s DIFF c:real^N->bool` THEN - REWRITE_TAC[CONNECTED_COMPONENT_SUBSET] THEN SET_TAC[]; - ALL_TAC] THEN - DISCH_THEN(X_CHOOSE_THEN `t:real^N` STRIP_ASSUME_TAC) THEN - EXISTS_TAC `w:real^N` THEN ASM_REWRITE_TAC[] THEN - CONJ_TAC THENL [ASM SET_TAC[]; REWRITE_TAC[connected_component]] THEN - EXISTS_TAC - `connected_component (s DIFF c) y UNION (t:real^N->real^N->bool) w` THEN - REPEAT STRIP_TAC THENL - [MATCH_MP_TAC CONNECTED_UNION THEN - REWRITE_TAC[CONNECTED_CONNECTED_COMPONENT] THEN ASM SET_TAC[]; - EXPAND_TAC "r" THEN MATCH_MP_TAC(SET_RULE - `s SUBSET s' /\ t SUBSET t' ==> s UNION t SUBSET s' UNION t'`) THEN - CONJ_TAC THENL - [TRANS_TAC SUBSET_TRANS `s DIFF c:real^N->bool` THEN - REWRITE_TAC[CONNECTED_COMPONENT_SUBSET] THEN ASM SET_TAC[]; - REWRITE_TAC[UNIONS_IMAGE; IN_ELIM_THM; SUBSET] THEN - FIRST_X_ASSUM(MP_TAC o SPEC `w:real^N`) THEN - REWRITE_TAC[open_in] THEN - MP_TAC(ISPEC `(t:real^N->real^N->bool) w` CLOSURE_SUBSET) THEN - ASM SET_TAC[]]; - MATCH_MP_TAC(SET_RULE `c y ==> y IN c UNION s`) THEN - ASM_REWRITE_TAC[CONNECTED_COMPONENT_REFL_EQ; IN_DIFF]; - ASM SET_TAC[]]);; + GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPEC `submetric euclidean_metric (s:real^N->bool)` + SEMI_LOCALLY_CONNECTED_CONNECTED) THEN + REWRITE_TAC[SUBMETRIC_EUCLIDEAN_METRIC] THEN + ASM_REWRITE_TAC[CONNECTED_IN_SUBMETRIC_EUCLIDEAN_MSPACE; + LOCALLY_COMPACT_SPACE_SUBMETRIC_EUCLIDEAN; + LOCALLY_CONNECTED_SPACE_SUBMETRIC_EUCLIDEAN; + MTOPOLOGY_SUBMETRIC_EUCLIDEAN] THEN + REWRITE_TAC[SUBTOPOLOGY_SUBTOPOLOGY; + SET_RULE `s INTER (s DIFF u) = s DIFF (u:A->bool)`; + EUCLIDEAN_CONNECTED_COMPONENTS_OF]);; let SEMI_LOCALLY_CONNECTED_GEN = prove (`!s:real^N->bool. @@ -9480,64 +9159,17 @@ let SEMI_LOCALLY_CONNECTED_GEN = prove ==> ?u. open_in (subtopology euclidean s) u /\ x IN u /\ u SUBSET v /\ FINITE(components(s DIFF u))`, - REPEAT STRIP_TAC THEN - FIRST_ASSUM(ASSUME_TAC o CONJUNCT1 o REWRITE_RULE[open_in]) THEN - SUBGOAL_THEN `(x:real^N) IN s` ASSUME_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - MP_TAC(ISPEC `connected_component s (x:real^N)` - SEMI_LOCALLY_CONNECTED) THEN - ANTS_TAC THENL - [REWRITE_TAC[CONNECTED_CONNECTED_COMPONENT] THEN - ASM_SIMP_TAC[LOCALLY_CONNECTED_CONNECTED_COMPONENT] THEN - MATCH_MP_TAC LOCALLY_OPEN_SUBSET THEN - EXISTS_TAC `s:real^N->bool` THEN - ASM_SIMP_TAC[OPEN_IN_CONNECTED_COMPONENT_LOCALLY_CONNECTED]; - ALL_TAC] THEN - DISCH_THEN(MP_TAC o SPECL - [`x:real^N`; `connected_component s (x:real^N) INTER v`]) THEN - ASM_REWRITE_TAC[IN_INTER] THEN ANTS_TAC THENL - [CONJ_TAC THENL - [MATCH_MP_TAC OPEN_IN_SUBTOPOLOGY_INTER_SUBSET THEN - EXISTS_TAC `s:real^N->bool` THEN - REWRITE_TAC[CONNECTED_COMPONENT_SUBSET] THEN - ASM_SIMP_TAC[OPEN_IN_INTER; OPEN_IN_REFL]; - REWRITE_TAC[IN] THEN ASM_REWRITE_TAC[CONNECTED_COMPONENT_REFL_EQ]]; - ALL_TAC] THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `u:real^N->bool` THEN - REWRITE_TAC[SUBSET_INTER] THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN - CONJ_TAC THENL - [FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP (REWRITE_RULE[IMP_CONJ] - OPEN_IN_TRANS)) THEN - ASM_SIMP_TAC[OPEN_IN_CONNECTED_COMPONENT_LOCALLY_CONNECTED]; - ALL_TAC] THEN - MATCH_MP_TAC FINITE_SUBSET THEN - EXISTS_TAC `components(connected_component s (x:real^N) DIFF u) UNION - components s` THEN - ASM_REWRITE_TAC[FINITE_UNION] THEN - REWRITE_TAC[components; SUBSET; FORALL_IN_GSPEC] THEN - X_GEN_TAC `y:real^N` THEN REWRITE_TAC[IN_DIFF] THEN STRIP_TAC THEN - ASM_CASES_TAC `(y:real^N) IN connected_component s x` THEN - REWRITE_TAC[IN_UNION] THENL [DISJ1_TAC; DISJ2_TAC] THEN - REWRITE_TAC[IN_ELIM_THM] THEN EXISTS_TAC `y:real^N` THEN - ASM_REWRITE_TAC[] THEN - REWRITE_TAC[FUN_EQ_THM] THEN X_GEN_TAC `z:real^N` THENL - [SUBGOAL_THEN `connected_component s (x:real^N) = connected_component s y` - SUBST1_TAC THENL - [ASM_REWRITE_TAC[CONNECTED_COMPONENT_EQ_EQ] THEN ASM_MESON_TAC[IN]; - ALL_TAC]; - ALL_TAC] THEN - ONCE_REWRITE_TAC[connected_component] THEN - AP_TERM_TAC THEN GEN_REWRITE_TAC I [FUN_EQ_THM] THEN - X_GEN_TAC `c:real^N->bool` THEN - REWRITE_TAC[SET_RULE `s SUBSET t DIFF u <=> s SUBSET t /\ DISJOINT s u`] THEN - EQ_TAC THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THENL - [MATCH_MP_TAC CONNECTED_COMPONENT_MAXIMAL THEN ASM_REWRITE_TAC[]; - ASM_MESON_TAC[SUBSET_TRANS; CONNECTED_COMPONENT_SUBSET]; - MP_TAC(ISPECL [`s:real^N->bool`; `y:real^N`; `x:real^N`] - CONNECTED_COMPONENT_DISJOINT) THEN - ASM_REWRITE_TAC[] THEN MATCH_MP_TAC(SET_RULE - `s' SUBSET s /\ t' SUBSET t ==> DISJOINT s t ==> DISJOINT s' t'`) THEN - ASM_REWRITE_TAC[] THEN MATCH_MP_TAC CONNECTED_COMPONENT_MAXIMAL THEN - ASM_REWRITE_TAC[]]);; + GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPEC `submetric euclidean_metric (s:real^N->bool)` + SEMI_LOCALLY_CONNECTED_GEN_SPACE) THEN + ASM_REWRITE_TAC[SUBMETRIC_EUCLIDEAN_METRIC; + MTOPOLOGY_SUBMETRIC_EUCLIDEAN; + EUCLIDEAN_CONNECTED_COMPONENTS_OF; + LOCALLY_COMPACT_SPACE_SUBMETRIC_EUCLIDEAN; + LOCALLY_CONNECTED_SPACE_SUBMETRIC_EUCLIDEAN] THEN + REWRITE_TAC[SUBTOPOLOGY_SUBTOPOLOGY; + SET_RULE `s INTER (s DIFF u) = s DIFF (u:A->bool)`; + EUCLIDEAN_CONNECTED_COMPONENTS_OF]);; let SEMI_LOCALLY_CONNECTED_COMPACT = prove (`!s:real^N->bool. @@ -9551,6 +9183,198 @@ let SEMI_LOCALLY_CONNECTED_COMPACT = prove ASM_SIMP_TAC[FINITE_COMPONENTS; CLOSED_IMP_LOCALLY_COMPACT; COMPACT_IMP_CLOSED]);; + +(* ------------------------------------------------------------------------- *) +(* Euclidean specializations derived from general metric space theorems. *) +(* These bridge theorems connect the metric space versions in metric.ml *) +(* to the concrete Euclidean topology. *) +(* ------------------------------------------------------------------------- *) + +(* Euclidean version of FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED. + Equivalent to the existing FINITE_COMPONENTS. *) +let FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED_EUCLIDEAN = + prove + (`!s:real^N->bool. + compact s /\ locally connected s + ==> FINITE(components s)`, + GEN_TAC THEN DISCH_TAC THEN + MP_TAC(ISPEC `submetric euclidean_metric (s:real^N->bool)` + FINITE_CONNECTED_COMPONENTS_COMPACT_LOCALLY_CONNECTED) THEN + SIMP_TAC[SUBMETRIC_EUCLIDEAN_METRIC; + COMPACT_IN_SUBTOPOLOGY_EUCLIDEAN; SUBSET_REFL; + LOCALLY_CONNECTED_SPACE_SUBMETRIC_EUCLIDEAN; + MTOPOLOGY_SUBMETRIC_EUCLIDEAN; + EUCLIDEAN_CONNECTED_COMPONENTS_OF] THEN + DISCH_THEN MATCH_MP_TAC THEN FIRST_ASSUM ACCEPT_TAC);; + +(* Euclidean: compact + connected + locally connected + ==> path connected. *) +let COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN = + prove + (`!s:real^N->bool. + compact s /\ connected s /\ locally connected s + ==> path_connected s`, + GEN_TAC THEN DISCH_TAC THEN + MP_TAC(ISPECL [`euclidean_metric:(real^N)metric`; + `s:real^N->bool`] + COMPACT_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED) THEN + REWRITE_TAC[MTOPOLOGY_EUCLIDEAN_METRIC; COMPACT_IN_EUCLIDEAN; + CONNECTED_IN_EUCLIDEAN; + LOCALLY_CONNECTED_SPACE_SUBTOPOLOGY_EUCLIDEAN; + PATH_CONNECTED_SPACE_EUCLIDEAN_SUBTOPOLOGY] THEN + DISCH_THEN MATCH_MP_TAC THEN FIRST_ASSUM ACCEPT_TAC);; + +(* Euclidean: locally compact + connected + locally connected + ==> path connected. *) +let LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN = + prove + (`!s:real^N->bool. + locally compact s /\ connected s /\ locally connected s + ==> path_connected s`, + GEN_TAC THEN DISCH_TAC THEN + MP_TAC(ISPECL [`euclidean_metric:(real^N)metric`; + `s:real^N->bool`] + LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_SPACE) THEN + REWRITE_TAC[MTOPOLOGY_EUCLIDEAN_METRIC; + LOCALLY_COMPACT_SPACE_SUBTOPOLOGY_EUCLIDEAN; + CONNECTED_IN_EUCLIDEAN; + LOCALLY_CONNECTED_SPACE_SUBTOPOLOGY_EUCLIDEAN; + PATH_CONNECTED_SPACE_EUCLIDEAN_SUBTOPOLOGY] THEN + DISCH_THEN MATCH_MP_TAC THEN FIRST_ASSUM ACCEPT_TAC);; + +(* Euclidean: locally compact + locally connected + ==> (path_connected <=> connected). *) +let LOCALLY_COMPACT_PATH_CONNECTED_EQ_CONNECTED_EUCLIDEAN = + prove + (`!s:real^N->bool. + locally compact s /\ locally connected s + ==> (path_connected s <=> connected s)`, + MESON_TAC[LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN; + PATH_CONNECTED_IMP_CONNECTED]);; + +(* Euclidean: locally compact + locally connected + ==> locally path connected. *) +let LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN = + prove + (`!s:real^N->bool. + locally compact s /\ locally connected s + ==> locally path_connected s`, + GEN_TAC THEN DISCH_TAC THEN + MP_TAC(ISPECL [`euclidean_metric:(real^N)metric`; + `s:real^N->bool`] + LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_SPACE) THEN + REWRITE_TAC[MTOPOLOGY_EUCLIDEAN_METRIC; + LOCALLY_COMPACT_SPACE_SUBTOPOLOGY_EUCLIDEAN; + LOCALLY_CONNECTED_SPACE_SUBTOPOLOGY_EUCLIDEAN; + LOCALLY_PATH_CONNECTED_SPACE_SUBTOPOLOGY_EUCLIDEAN] THEN + DISCH_THEN MATCH_MP_TAC THEN FIRST_ASSUM ACCEPT_TAC);; + +(* Euclidean: locally compact + ==> (locally path connected <=> locally connected). *) +let LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN = + prove + (`!s:real^N->bool. + locally compact s + ==> (locally path_connected s <=> + locally connected s)`, + MESON_TAC[ + LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN; + LOCALLY_PATH_CONNECTED_IMP_LOCALLY_CONNECTED]);; + +(* In Euclidean R^N, complete subsets are locally compact. *) +(* Uses: complete => closed (in R^N) => locally compact. *) +let MCOMPLETE_IMP_LOCALLY_COMPACT_EUCLIDEAN = prove + (`!s:real^N->bool. + mcomplete(submetric euclidean_metric s) + ==> locally compact s`, + GEN_TAC THEN DISCH_TAC THEN + MATCH_MP_TAC CLOSED_IMP_LOCALLY_COMPACT THEN + REWRITE_TAC[CLOSED_IN; GSYM MTOPOLOGY_EUCLIDEAN_METRIC] THEN + MATCH_MP_TAC MCOMPLETE_IMP_CLOSED_IN THEN + ASM_REWRITE_TAC[EUCLIDEAN_METRIC; SUBSET_UNIV]);; + +(* In R^N, complete + connected + locally connected + ==> path connected. *) +let MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN = + prove + (`!s:real^N->bool. + mcomplete(submetric euclidean_metric s) /\ + connected s /\ locally connected s + ==> path_connected s`, + GEN_TAC THEN STRIP_TAC THEN + MATCH_MP_TAC + LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN THEN + ASM_SIMP_TAC[MCOMPLETE_IMP_LOCALLY_COMPACT_EUCLIDEAN]);; + +(* In Euclidean R^N: complete + locally connected + ==> locally path connected. *) +let MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN = + prove + (`!s:real^N->bool. + mcomplete(submetric euclidean_metric s) /\ + locally connected s + ==> locally path_connected s`, + GEN_TAC THEN STRIP_TAC THEN MATCH_MP_TAC + LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN THEN + ASM_SIMP_TAC[MCOMPLETE_IMP_LOCALLY_COMPACT_EUCLIDEAN]);; + +(* In Euclidean R^N: complete ==> + (locally path connected <=> locally connected). *) +let MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN = + prove + (`!s:real^N->bool. + mcomplete(submetric euclidean_metric s) + ==> (locally path_connected s <=> + locally connected s)`, + MESON_TAC[ + MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN; + LOCALLY_PATH_CONNECTED_IMP_LOCALLY_CONNECTED]);; + +(* G-delta ==> (locally path connected <=> locally connected). *) +(* Optimal in R^N since gdelta <=> completely metrizable; the locally *) +(* compact version follows since locally compact ==> gdelta. *) + +let GDELTA_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED = prove + (`!s:real^N->bool. + gdelta s + ==> (locally path_connected s <=> + locally connected s)`, + GEN_TAC THEN DISCH_TAC THEN + MP_TAC(ISPEC `subtopology euclidean (s:real^N->bool)` + COMPLETELY_METRIZABLE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED) THEN + ANTS_TAC THENL + [MATCH_MP_TAC COMPLETELY_METRIZABLE_SPACE_GDELTA_IN THEN + ASM_REWRITE_TAC[GDELTA_IN_EUCLIDEAN; + COMPLETELY_METRIZABLE_SPACE_EUCLIDEAN]; + REWRITE_TAC[LOCALLY_PATH_CONNECTED_SPACE_SUBTOPOLOGY_EUCLIDEAN; + LOCALLY_CONNECTED_SPACE_SUBTOPOLOGY_EUCLIDEAN]]);; + +let GDELTA_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED = prove + (`!s:real^N->bool. + gdelta s /\ locally connected s + ==> locally path_connected s`, + MESON_TAC[GDELTA_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED]);; + +(* Gdelta + connected + locally connected ==> path connected. *) +(* Optimal Euclidean form of Menger's theorem *) +(* (gdelta is optimal since gdelta <==> completely metrizable in R^N). *) + +let GDELTA_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED = prove + (`!s:real^N->bool. + gdelta s /\ connected s /\ locally connected s + ==> path_connected s`, + GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPEC `subtopology euclidean (s:real^N->bool)` + COMPLETELY_METRIZABLE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED) THEN + ANTS_TAC THENL + [CONJ_TAC THENL + [MATCH_MP_TAC COMPLETELY_METRIZABLE_SPACE_GDELTA_IN THEN + ASM_REWRITE_TAC[GDELTA_IN_EUCLIDEAN; + COMPLETELY_METRIZABLE_SPACE_EUCLIDEAN]; + ASM_REWRITE_TAC[CONNECTED_SPACE_EUCLIDEAN_SUBTOPOLOGY; + LOCALLY_CONNECTED_SPACE_SUBTOPOLOGY_EUCLIDEAN]]; + REWRITE_TAC[PATH_CONNECTED_SPACE_EUCLIDEAN_SUBTOPOLOGY]]);; + (* ------------------------------------------------------------------------- *) (* Locally convex sets. *) (* ------------------------------------------------------------------------- *) @@ -11619,7 +11443,7 @@ let CONTINUUM_UNION_COMPONENTS_COMPLEMENT = prove (* More compact component properties via the notion of "well-chained". *) (* ------------------------------------------------------------------------- *) -let WELLCHAINED_ELEMENTS = prove +let WELLCHAINED_ELEMENTS_EUCLIDEAN = prove (`!s:real^N->bool a b e. (?p n. p 0 = a /\ p n = b /\ (!i. i <= n ==> p i IN s) /\ @@ -11628,59 +11452,18 @@ let WELLCHAINED_ELEMENTS = prove (!c. c SUBSET s /\ a IN c /\ (!x y. x IN c /\ y IN s /\ dist(x,y) < e ==> y IN c) ==> b IN c)`, - REPEAT GEN_TAC THEN - ASM_CASES_TAC `(a:real^N) IN s` THENL - [ALL_TAC; ASM_MESON_TAC[LE_0]] THEN - ASM_CASES_TAC `(b:real^N) IN s` THENL - [ALL_TAC; ASM_MESON_TAC[LE_REFL]] THEN - ASM_REWRITE_TAC[] THEN EQ_TAC THENL - [REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`p:num->real^N`; `n:num`] THEN STRIP_TAC THEN - X_GEN_TAC `c:real^N->bool` THEN STRIP_TAC THEN - SUBGOAL_THEN `!k. k <= n ==> (p:num->real^N) k IN c` - (fun th -> ASM_MESON_TAC[th; LE_REFL]) THEN - INDUCT_TAC THEN ASM_REWRITE_TAC[] THEN DISCH_TAC THEN - FIRST_X_ASSUM MATCH_MP_TAC THEN EXISTS_TAC `(p:num->real^N) k` THEN - REPEAT CONJ_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; - DISCH_THEN(MP_TAC o SPEC - `{x:real^N | ?p n. p 0 = a /\ p n = x /\ - (!i. i <= n ==> p i IN s) /\ - (!i. i < n ==> dist(p i,p(SUC i)) < e)}`) THEN - ANTS_TAC THENL [ALL_TAC; REWRITE_TAC[IN_ELIM_THM]] THEN - REPEAT CONJ_TAC THENL - [REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN ASM_MESON_TAC[LE_REFL]; - REWRITE_TAC[IN_ELIM_THM] THEN - MAP_EVERY EXISTS_TAC [`(\n. a):num->real^N`; `0`] THEN - ASM_REWRITE_TAC[LT]; - MAP_EVERY X_GEN_TAC [`x:real^N`; `y:real^N`] THEN - DISCH_THEN(CONJUNCTS_THEN2 MP_TAC STRIP_ASSUME_TAC) THEN - REWRITE_TAC[IN_ELIM_THM; LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`p:num->real^N`; `n:num`] THEN STRIP_TAC THEN - EXISTS_TAC `\i. if i <= n then (p:num->real^N) i else y` THEN - EXISTS_TAC `SUC n` THEN - ASM_REWRITE_TAC[LE_0; ARITH_RULE `~(SUC n <= n)`] THEN - REWRITE_TAC[LE; LT; TAUT `p \/ q ==> r <=> (p ==> r) /\ (q ==> r)`; - FORALL_AND_THM; FORALL_UNWIND_THM2] THEN - REWRITE_TAC[LE_REFL; LE_SUC_LT; LT_REFL] THEN - ASM_SIMP_TAC[LT_IMP_LE]]]);; + REWRITE_TAC[GSYM(CONJUNCT1 EUCLIDEAN_METRIC); WELLCHAINED_ELEMENTS]);; -let WELLCHAINED_SETS = prove +let WELLCHAINED_SETS_EUCLIDEAN = prove (`!s:real^N->bool e. (!a b. a IN s /\ b IN s ==> ?p n. p 0 = a /\ p n = b /\ (!i. i <= n ==> p i IN s) /\ (!i. i < n ==> dist(p i,p(SUC i)) < e)) <=> (!c. c SUBSET s /\ ~(c = {}) /\ - (!x y. x IN c /\ y IN s /\ dist(x,y) < e ==> y IN c) ==> c = s)`, - REPEAT GEN_TAC THEN - REWRITE_TAC[WELLCHAINED_ELEMENTS] THEN SIMP_TAC[] THEN - REWRITE_TAC[MESON[] - `(!a b. P a /\ P b ==> !c. Q a b c ==> R a b c) <=> - (!c a b. Q a b c /\ P a /\ P b ==> R a b c)`] THEN - AP_TERM_TAC THEN ABS_TAC THEN - SIMP_TAC[GSYM MEMBER_NOT_EMPTY; GSYM SUBSET_ANTISYM_EQ] THEN - REWRITE_TAC[SUBSET] THEN REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN - MESON_TAC[]);; + (!x y. x IN c /\ y IN s /\ dist(x,y) < e ==> y IN c) + ==> c = s)`, + REWRITE_TAC[GSYM(CONJUNCT1 EUCLIDEAN_METRIC); WELLCHAINED_SETS]);; let CONNECTED_IMP_WELLCHAINED = prove (`!s e a b:real^N. @@ -11688,126 +11471,12 @@ let CONNECTED_IMP_WELLCHAINED = prove ==> ?p n. p 0 = a /\ p n = b /\ (!i. i <= n ==> p i IN s) /\ (!i. i < n ==> dist(p i,p(SUC i)) < e)`, - REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN - REPLICATE_TAC 2 (GEN_TAC THEN DISCH_TAC) THEN - REWRITE_TAC[RIGHT_IMP_FORALL_THM; IMP_IMP] THEN - REWRITE_TAC[WELLCHAINED_SETS] THEN - REPEAT STRIP_TAC THEN ASM_SIMP_TAC[SET_RULE - `c SUBSET s /\ ~(c = {}) - ==> (c = s <=> !a b. a IN s /\ b IN s /\ a IN c ==> b IN c)`] THEN - MATCH_MP_TAC CONNECTED_INDUCTION_SIMPLE THEN ASM_REWRITE_TAC[] THEN - X_GEN_TAC `a:real^N` THEN DISCH_TAC THEN - EXISTS_TAC `s INTER ball(a:real^N,e / &2)` THEN - ASM_SIMP_TAC[IN_INTER; CENTRE_IN_BALL; REAL_HALF] THEN - ASM_SIMP_TAC[OPEN_IN_OPEN_INTER; OPEN_BALL] THEN REWRITE_TAC[IN_BALL] THEN - ASM_MESON_TAC[NORM_ARITH - `dist(a:real^N,x) < e / &2 /\ dist(a,y) < e / &2 ==> dist(x,y) < e`]);; - -let CONNECTED_EQ_WELLCHAINED = prove - (`!s:real^N->bool. - compact s - ==> (connected s <=> - !e a b. &0 < e /\ a IN s /\ b IN s - ==> ?p n. p 0 = a /\ p n = b /\ - (!i. i <= n ==> p i IN s) /\ - (!i. i < n ==> dist(p i,p(SUC i)) < e))`, - REPEAT STRIP_TAC THEN EQ_TAC THENL - [REPEAT STRIP_TAC THEN MATCH_MP_TAC CONNECTED_IMP_WELLCHAINED THEN - ASM_MESON_TAC[]; - ONCE_REWRITE_TAC[IMP_CONJ] THEN REWRITE_TAC[RIGHT_FORALL_IMP_THM]] THEN - REWRITE_TAC[WELLCHAINED_SETS] THEN DISCH_TAC THEN - ASM_CASES_TAC `connected(s:real^N->bool)` THENL - [ASM_REWRITE_TAC[]; REWRITE_TAC[CONNECTED_CLOSED_IN_EQ]] THEN - UNDISCH_TAC `compact(s:real^N->bool)` THEN - SIMP_TAC[CLOSED_IN_COMPACT_EQ] THEN - DISCH_TAC THEN REWRITE_TAC[NOT_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`k1:real^N->bool`; `k2:real^N->bool`] THEN - STRIP_TAC THEN - SUBGOAL_THEN `?a:real^N. a IN k1` STRIP_ASSUME_TAC THENL - [ASM SET_TAC[]; ALL_TAC] THEN - FIRST_X_ASSUM(MP_TAC o SPEC `setdist(k1:real^N->bool,k2)`) THEN - REWRITE_TAC[NOT_IMP; SETDIST_POS_LT] THEN - ASM_SIMP_TAC[SETDIST_EQ_0_COMPACT_CLOSED; COMPACT_IMP_CLOSED] THEN - DISCH_THEN(MP_TAC o SPEC `k1:real^N->bool`) THEN - ASM_REWRITE_TAC[NOT_IMP] THEN CONJ_TAC THENL [ALL_TAC; ASM SET_TAC[]] THEN - ONCE_REWRITE_TAC[TAUT `p /\ q /\ r ==> s <=> p /\ q /\ ~s ==> ~r`] THEN - REWRITE_TAC[REAL_NOT_LT; GSYM IN_DIFF] THEN - REPEAT STRIP_TAC THEN MATCH_MP_TAC SETDIST_LE_DIST THEN ASM SET_TAC[]);; - -let WELLCHAINED_INTERS = prove - (`!s:num->(real^N->bool) d e. - d < e /\ - (!m. compact (s m)) /\ - (!m. s(SUC m) SUBSET s m) /\ - (!m a b. - a IN s m /\ b IN s m - ==> ?p n. p 0 = a /\ p n = b /\ - (!i. i <= n ==> p i IN s m) /\ - (!i. i < n ==> dist(p i,p (SUC i)) < d)) - ==> !a b. a IN INTERS {s m | m IN (:num)} /\ - b IN INTERS {s m | m IN (:num)} - ==> ?p n. p 0 = a /\ p n = b /\ - (!i. i <= n ==> p i IN INTERS {s m | m IN (:num)}) /\ - (!i. i < n ==> dist(p i,p (SUC i)) < e)`, - REWRITE_TAC[WELLCHAINED_SETS] THEN - REPEAT GEN_TAC THEN STRIP_TAC THEN - ABBREV_TAC `k:real^N->bool = INTERS {s m | m IN (:num)}` THEN - ASM_CASES_TAC `k:real^N->bool = {}` THENL [ASM SET_TAC[]; ALL_TAC] THEN - SUBGOAL_THEN `compact(k:real^N->bool)` ASSUME_TAC THENL - [EXPAND_TAC "k" THEN MATCH_MP_TAC COMPACT_INTERS THEN ASM SET_TAC[]; - ALL_TAC] THEN - REWRITE_TAC[GSYM WELLCHAINED_SETS] THEN - MAP_EVERY X_GEN_TAC [`a:real^N`; `b:real^N`] THEN STRIP_TAC THEN - MP_TAC(ISPEC `s:num->real^N->bool` HAUSDIST_COMPACT_INTERS_LIMIT) THEN - ASM_REWRITE_TAC[LIM_SEQUENTIALLY; DIST_0] THEN - DISCH_THEN(MP_TAC o SPEC `(e - d) / &2`) THEN - ASM_REWRITE_TAC[REAL_SUB_LT; REAL_HALF; NORM_LIFT] THEN - DISCH_THEN(X_CHOOSE_THEN `n:num` (MP_TAC o SPEC `n:num`)) THEN - REWRITE_TAC[LE_REFL; real_abs; HAUSDIST_POS_LE] THEN DISCH_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`n:num`; `a:real^N`; `b:real^N`] o - GEN_REWRITE_RULE BINDER_CONV [GSYM WELLCHAINED_SETS]) THEN - ANTS_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - ONCE_REWRITE_TAC[SWAP_EXISTS_THM] THEN MATCH_MP_TAC MONO_EXISTS THEN - X_GEN_TAC `m:num` THEN - DISCH_THEN(X_CHOOSE_THEN `p:num->real^N` STRIP_ASSUME_TAC) THEN - SUBGOAL_THEN - `!i. ?y. i <= m ==> y IN k /\ dist((p:num->real^N) i,y) <= (e - d) / &2` - MP_TAC THENL - [X_GEN_TAC `j:num` THEN - REWRITE_TAC[RIGHT_EXISTS_IMP_THM] THEN DISCH_TAC THEN - MP_TAC(ISPECL [`(s:num->real^N->bool) n`; `k:real^N->bool`] - HAUSDIST_COMPACT_EXISTS) THEN - ASM_SIMP_TAC[COMPACT_IMP_BOUNDED] THEN - DISCH_THEN(MP_TAC o SPEC `(p:num->real^N) j`) THEN ASM_SIMP_TAC[] THEN - MATCH_MP_TAC MONO_EXISTS THEN SIMP_TAC[] THEN ASM_REAL_ARITH_TAC; - REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM]] THEN - X_GEN_TAC `q:num->real^N` THEN DISCH_TAC THEN - EXISTS_TAC `\i. if 0 < i /\ i < m then (q:num->real^N) i else p i` THEN - ASM_SIMP_TAC[LT_REFL] THEN CONJ_TAC THEN X_GEN_TAC `i:num` THENL - [ASM_CASES_TAC `i = 0` THEN ASM_REWRITE_TAC[LT_REFL] THEN - ASM_CASES_TAC `i:num = m` THEN ASM_REWRITE_TAC[LT_REFL] THEN - REPEAT DISCH_TAC THEN REPEAT(COND_CASES_TAC THEN ASM_SIMP_TAC[]) THEN - ASM_ARITH_TAC; - ASM_CASES_TAC `i = 0` THEN ASM_SIMP_TAC[LE_1; LT_0; LT_REFL] THEN - SIMP_TAC[ARITH_RULE `i < m ==> (SUC i < m <=> ~(SUC i = m))`] THEN - REWRITE_TAC[COND_SWAP] THEN DISCH_TAC THEN COND_CASES_TAC THEN - ASM_REWRITE_TAC[] THENL - [ASM_MESON_TAC[REAL_LT_TRANS]; - MATCH_MP_TAC(NORM_ARITH - `dist(a:real^N,p(SUC 0)) < d /\ dist(p(SUC 0),q(SUC 0)) <= (e - d) / &2 - ==> dist(a,q(SUC 0)) < e`) THEN - ASM_MESON_TAC[ARITH_RULE `0 < m ==> SUC 0 <= m`]; - MATCH_MP_TAC(NORM_ARITH - `dist((p:num->real^N) i,b) < d /\ dist(p i,q i) <= (e - d) / &2 - ==> dist(q i,b) < e`) THEN - ASM_MESON_TAC[LT_IMP_LE]; - MATCH_MP_TAC(NORM_ARITH - `dist(p i:real^N,p(SUC i)) < d /\ - dist(p i,q i) <= (e - d) / &2 /\ - dist(p(SUC i),q(SUC i)) <= (e - d) / &2 - ==> dist(q i,q(SUC i)) < e`) THEN - ASM_MESON_TAC[LT_IMP_LE; ARITH_RULE - `i < m /\ ~(SUC i = m) ==> SUC i <= m`]]]);; + REPEAT STRIP_TAC THEN + MP_TAC(ISPECL [`euclidean_metric:(real^N)metric`; `s:real^N->bool`; + `e:real`; `a:real^N`; `b:real^N`] + CONNECTED_IN_IMP_WELLCHAINED) THEN + ASM_REWRITE_TAC[MTOPOLOGY_EUCLIDEAN_METRIC; CONNECTED_IN_EUCLIDEAN; + EUCLIDEAN_METRIC]);; let CONNECTED_COMPONENT_IMP_WELLCHAINED = prove (`!s a b:real^N e. @@ -11815,15 +11484,27 @@ let CONNECTED_COMPONENT_IMP_WELLCHAINED = prove ==> ?p n. p 0 = a /\ p n = b /\ (!i. i <= n ==> p i IN s) /\ (!i. i < n ==> dist(p i,p (SUC i)) < e)`, - REPEAT STRIP_TAC THEN MP_TAC(ISPECL - [`connected_component s (a:real^N)`; `e:real`; `a:real^N`; `b:real^N`] - CONNECTED_IMP_WELLCHAINED) THEN - ASM_REWRITE_TAC[CONNECTED_CONNECTED_COMPONENT] THEN ANTS_TAC THENL - [REWRITE_TAC[IN] THEN ASM_REWRITE_TAC[CONNECTED_COMPONENT_REFL_EQ] THEN - ASM_MESON_TAC[CONNECTED_COMPONENT_IN]; - REPEAT(MATCH_MP_TAC MONO_EXISTS THEN GEN_TAC) THEN MP_TAC - (ISPECL [`s:real^N->bool`; `a:real^N`] CONNECTED_COMPONENT_SUBSET) THEN - ASM SET_TAC[]]);; + REPEAT STRIP_TAC THEN + MP_TAC(ISPECL [`euclidean_metric:(real^N)metric`; `s:real^N->bool`; + `a:real^N`; `b:real^N`; `e:real`] + CONNECTED_COMPONENT_OF_IMP_WELLCHAINED) THEN + ASM_REWRITE_TAC[MTOPOLOGY_EUCLIDEAN_METRIC; EUCLIDEAN_METRIC; + CONNECTED_COMPONENT_OF_EUCLIDEAN]);; + +let CONNECTED_EQ_WELLCHAINED = prove + (`!s:real^N->bool. + compact s + ==> (connected s <=> + !e. &0 < e + ==> !a b. a IN s /\ b IN s + ==> ?p n. p 0 = a /\ p n = b /\ + (!i. i <= n ==> p i IN s) /\ + (!i. i < n ==> dist(p i,p(SUC i)) < e))`, + GEN_TAC THEN DISCH_TAC THEN + MP_TAC(ISPECL [`euclidean_metric:(real^N)metric`; `s:real^N->bool`] + CONNECTED_EQ_WELLCHAINED_IN) THEN + ASM_REWRITE_TAC[MTOPOLOGY_EUCLIDEAN_METRIC; COMPACT_IN_EUCLIDEAN; + CONNECTED_IN_EUCLIDEAN; EUCLIDEAN_METRIC]);; let CONNECTED_COMPONENT_EQ_WELLCHAINED = prove (`!s a b:real^N. @@ -11833,124 +11514,35 @@ let CONNECTED_COMPONENT_EQ_WELLCHAINED = prove !e. &0 < e ==> ?p n. p 0 = a /\ p n = b /\ (!i. i <= n ==> p i IN s) /\ - (!i. i < n ==> dist(p i,p (SUC i)) < e))`, - REPEAT STRIP_TAC THEN EQ_TAC THEN STRIP_TAC THENL - [FIRST_ASSUM(ASSUME_TAC o MATCH_MP CONNECTED_COMPONENT_IN) THEN - ASM_REWRITE_TAC[] THEN REPEAT STRIP_TAC THEN - MATCH_MP_TAC CONNECTED_COMPONENT_IMP_WELLCHAINED THEN ASM_MESON_TAC[]; - ALL_TAC] THEN - ABBREV_TAC - `t = \k. {x | (x:real^N) IN s /\ - ?p n. p 0 = a /\ p n = x /\ - (!i. i <= n ==> p i IN s) /\ - (!i. i < n ==> dist(p i,p(SUC i)) < inv(&k + &1))}` THEN - REWRITE_TAC[connected_component] THEN - EXISTS_TAC `INTERS {t k | k IN (:num)}:real^N->bool` THEN - REPEAT CONJ_TAC THENL - [ALL_TAC; - EXPAND_TAC "t" THEN REWRITE_TAC[INTERS_GSPEC] THEN SET_TAC[]; - EXPAND_TAC "t" THEN REWRITE_TAC[INTERS_GSPEC] THEN - ASM_REWRITE_TAC[IN_ELIM_THM; IN_UNIV] THEN X_GEN_TAC `j:num` THEN - EXISTS_TAC `(\n. a):num->real^N` THEN - ASM_REWRITE_TAC[DIST_REFL; REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`]; - EXPAND_TAC "t" THEN REWRITE_TAC[INTERS_GSPEC; IN_UNIV; IN_ELIM_THM] THEN - X_GEN_TAC `j:num` THEN ASM_REWRITE_TAC[] THEN - FIRST_X_ASSUM MATCH_MP_TAC THEN - ASM_REWRITE_TAC[DIST_REFL; REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`]] THEN - W(MP_TAC o PART_MATCH (lhand o rand) CONNECTED_EQ_WELLCHAINED o snd) THEN - SUBGOAL_THEN `!n. compact((t:num->real^N->bool) n)` ASSUME_TAC THENL - [GEN_TAC THEN MATCH_MP_TAC CLOSED_IN_COMPACT THEN - EXISTS_TAC `s:real^N->bool` THEN ASM_REWRITE_TAC[] THEN - REWRITE_TAC[closed_in; TOPSPACE_EUCLIDEAN_SUBTOPOLOGY] THEN - EXPAND_TAC "t" THEN REWRITE_TAC[SUBSET_RESTRICT] THEN - REWRITE_TAC[open_in; SET_RULE `s DIFF t SUBSET s`] THEN - X_GEN_TAC `x:real^N` THEN REWRITE_TAC[DIFF; IN_ELIM_THM] THEN - ASM_CASES_TAC `(x:real^N) IN s` THEN ASM_REWRITE_TAC[] THEN - DISCH_TAC THEN EXISTS_TAC `inv(&n + &1)` THEN - REWRITE_TAC[REAL_LT_INV_EQ; REAL_ARITH `&0 < &n + &1`] THEN - X_GEN_TAC `y:real^N` THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN - FIRST_X_ASSUM(MP_TAC o check (is_neg o concl)) THEN - REWRITE_TAC[CONTRAPOS_THM; LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`p:num->real^N`; `m:num`] THEN STRIP_TAC THEN - EXISTS_TAC `\j. if j <= m then (p:num->real^N) j else x` THEN - EXISTS_TAC `SUC m` THEN - ASM_REWRITE_TAC[LE_0; ARITH_RULE `~(SUC m <= m)`] THEN - REWRITE_TAC[LE_SUC_LT; LT; LE] THEN - CONJ_TAC THEN X_GEN_TAC `j:num` THEN STRIP_TAC THEN - ASM_SIMP_TAC[LT_IMP_LE; ARITH_RULE `~(SUC m <= m)`; LE_REFL; LT_REFL]; - ALL_TAC] THEN - ANTS_TAC THENL - [MATCH_MP_TAC COMPACT_INTERS THEN - ASM_REWRITE_TAC[FORALL_IN_GSPEC; IN_UNIV] THEN SET_TAC[]; - DISCH_THEN SUBST1_TAC] THEN - SUBGOAL_THEN `!n. t(SUC n):real^N->bool SUBSET t n` ASSUME_TAC THENL - [EXPAND_TAC "t" THEN REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN - REPEAT GEN_TAC THEN MATCH_MP_TAC MONO_AND THEN REWRITE_TAC[] THEN - REPEAT(MATCH_MP_TAC MONO_EXISTS THEN GEN_TAC) THEN - REPEAT(MATCH_MP_TAC MONO_AND THEN REWRITE_TAC[]) THEN - MATCH_MP_TAC MONO_FORALL THEN GEN_TAC THEN - MATCH_MP_TAC MONO_IMP THEN REWRITE_TAC[] THEN - MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ_ALT] REAL_LT_TRANS) THEN - MATCH_MP_TAC REAL_LT_INV2 THEN - REWRITE_TAC[REAL_OF_NUM_ADD; REAL_OF_NUM_LT] THEN ARITH_TAC; - ALL_TAC] THEN - X_GEN_TAC `e:real` THEN ASM_CASES_TAC `&0 < e` THEN ASM_REWRITE_TAC[] THEN - MP_TAC(SPEC `e / &2` ARCH_EVENTUALLY_INV1) THEN - ASM_REWRITE_TAC[REAL_HALF; EVENTUALLY_SEQUENTIALLY] THEN - DISCH_THEN(X_CHOOSE_TAC `N:num`) THEN - SUBGOAL_THEN - `INTERS {t n | n IN (:num)}:real^N->bool = - INTERS {t(N + n) | n IN (:num)}` - SUBST1_TAC THENL - [REWRITE_TAC[GSYM SUBSET_ANTISYM_EQ] THEN CONJ_TAC THENL - [SET_TAC[]; ALL_TAC] THEN - REWRITE_TAC[SUBSET; INTERS_GSPEC; IN_ELIM_THM; IN_UNIV] THEN - SUBGOAL_THEN - `!m n. m <= n ==> (t:num->real^N->bool) n SUBSET t m` - (fun th -> MESON_TAC[th; LE_ADD; ADD_SYM; SUBSET]) THEN - MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN ASM_REWRITE_TAC[] THEN SET_TAC[]; - ALL_TAC] THEN - MATCH_MP_TAC WELLCHAINED_INTERS THEN EXISTS_TAC `e / &2` THEN - CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ASM_REWRITE_TAC[ADD_CLAUSES]] THEN - MAP_EVERY X_GEN_TAC [`m:num`; `x:real^N`; `y:real^N`] THEN - EXPAND_TAC "t" THEN REWRITE_TAC[IN_ELIM_THM] THEN - MAP_EVERY ASM_CASES_TAC [`(x:real^N) IN s`; `(y:real^N) IN s`] THEN - ASM_REWRITE_TAC[IMP_CONJ; LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`p1:num->real^N`; `n1:num`] THEN REPEAT DISCH_TAC THEN - MAP_EVERY X_GEN_TAC [`p2:num->real^N`; `n2:num`] THEN REPEAT DISCH_TAC THEN - EXISTS_TAC - `\j. if j <= n1 then (p1:num->real^N) (n1 - j) else p2(j - n1)` THEN - EXISTS_TAC `n1 + n2:num` THEN - ASM_REWRITE_TAC[LE_0; SUB_0; ADD_SUB2; ARITH_RULE `n - (n + m) = 0`] THEN - REPEAT CONJ_TAC THENL - [REWRITE_TAC[ARITH_RULE `n1 + n2 <= n1 <=> n2 = 0`] THEN ASM_MESON_TAC[]; - X_GEN_TAC `i:num` THEN DISCH_TAC THEN - ASM_CASES_TAC `(i:num) <= n1` THEN ASM_REWRITE_TAC[] THEN - (CONJ_TAC THENL - [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; ALL_TAC]) - THENL - [MAP_EVERY EXISTS_TAC [`p1:num->real^N`; `n1 - i:num`]; - MAP_EVERY EXISTS_TAC [`p2:num->real^N`; `i - n1:num`]] THEN - ASM_REWRITE_TAC[] THEN - REPEAT STRIP_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; - X_GEN_TAC `i:num` THEN DISCH_TAC THEN - ASM_CASES_TAC `SUC i <= n1` THEN - ASM_SIMP_TAC[ARITH_RULE `SUC i <= n ==> i <= n`] THENL - [ASM_SIMP_TAC[ARITH_RULE `SUC i <= n ==> n - i = SUC(n - SUC i)`] THEN - TRANS_TAC REAL_LT_TRANS `inv(&(N + m) + &1)` THEN - ASM_SIMP_TAC[LE_ADD] THEN - ONCE_REWRITE_TAC[DIST_SYM] THEN FIRST_X_ASSUM MATCH_MP_TAC THEN - ASM_ARITH_TAC; - ASM_SIMP_TAC[ARITH_RULE `~(SUC i <= n) ==> (i <= n <=> i = n)`] THEN - COND_CASES_TAC THENL - [ASM_REWRITE_TAC[SUB_REFL; ARITH_RULE `SUC n - n = SUC 0`] THEN - SUBGOAL_THEN `a:real^N = p2 0` SUBST1_TAC THENL - [ASM_REWRITE_TAC[]; ALL_TAC]; - ASM_SIMP_TAC[ARITH_RULE - `~(SUC i <= n) ==> SUC i - n = SUC(i - n)`]] THEN - (TRANS_TAC REAL_LT_TRANS `inv(&(N + m) + &1)` THEN CONJ_TAC THENL - [FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; - ASM_SIMP_TAC[LE_ADD]])]]);; + (!i. i < n ==> dist(p i,p(SUC i)) < e))`, + REPEAT GEN_TAC THEN DISCH_TAC THEN + MP_TAC(ISPECL [`euclidean_metric:(real^N)metric`; `s:real^N->bool`; + `a:real^N`; `b:real^N`] + CONNECTED_COMPONENT_OF_EQ_WELLCHAINED) THEN + ASM_REWRITE_TAC[MTOPOLOGY_EUCLIDEAN_METRIC; COMPACT_IN_EUCLIDEAN; + CONNECTED_COMPONENT_OF_EUCLIDEAN; EUCLIDEAN_METRIC]);; + +let WELLCHAINED_INTERS_EUCLIDEAN = prove + (`!s:num->(real^N->bool) d e. + d < e /\ + (!m. compact (s m)) /\ + (!m. s(SUC m) SUBSET s m) /\ + (!m a b. + a IN s m /\ b IN s m + ==> ?p n. p 0 = a /\ p n = b /\ + (!i. i <= n ==> p i IN s m) /\ + (!i. i < n ==> dist(p i,p (SUC i)) < d)) + ==> !a b. a IN INTERS {s m | m IN (:num)} /\ + b IN INTERS {s m | m IN (:num)} + ==> ?p n. p 0 = a /\ p n = b /\ + (!i. i <= n ==> p i IN INTERS {s m | m IN (:num)}) /\ + (!i. i < n ==> dist(p i,p (SUC i)) < e)`, + REPEAT GEN_TAC THEN DISCH_TAC THEN + MP_TAC(ISPECL [`euclidean_metric:(real^N)metric`; + `s:num->real^N->bool`; `d:real`; `e:real`] + WELLCHAINED_INTERS) THEN + ASM_REWRITE_TAC[MTOPOLOGY_EUCLIDEAN_METRIC; COMPACT_IN_EUCLIDEAN; + EUCLIDEAN_METRIC]);; let COMPACT_PARTITION_CONTAINING_CLOSED = prove (`!s t t':real^N->bool. @@ -12367,664 +11959,16 @@ let LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED = prove (`!s:real^N->bool. locally compact s /\ locally connected s /\ connected s ==> path_connected s`, - SUBGOAL_THEN - `!s:real^N->bool. - compact s /\ connected s /\ locally connected s - ==> path_connected s` - ASSUME_TAC THENL - [ALL_TAC; - REPEAT STRIP_TAC THEN - W(MP_TAC o PART_MATCH (lhand o rand) PATH_CONNECTED_EQ_CONNECTED_LPC o - snd) THEN - ASM_REWRITE_TAC[] THEN DISCH_THEN MATCH_MP_TAC THEN - MATCH_MP_TAC LOCALLY_MONO THEN - EXISTS_TAC - `\c:real^N->bool. compact c /\ connected c /\ locally connected c` THEN - ASM_SIMP_TAC[LOCALLY_CONNECTED_CONTINUUM]] THEN - REPEAT STRIP_TAC THEN REWRITE_TAC[PATH_CONNECTED_IFF_PATH_COMPONENT] THEN - MAP_EVERY X_GEN_TAC [`a:real^N`; `b:real^N`] THEN STRIP_TAC THEN - SUBGOAL_THEN - `?f:real^1->real^N. - f(vec 0) = a /\ f(vec 1) = b /\ - (!x. x IN {lift(&m / &2 pow n) | 0 <= m /\ m <= 2 EXP n} - ==> f x IN s) /\ - f uniformly_continuous_on - {lift(&m / &2 pow n) | 0 <= m /\ m <= 2 EXP n}` - STRIP_ASSUME_TAC THENL - [ALL_TAC; - SUBGOAL_THEN - `interval[vec 0:real^1,vec 1] INTER - {inv(&2 pow n) % m | n,m | !i. 1 <= i /\ i <= dimindex(:1) - ==> integer(m$i)} = - {lift (&m / &2 pow n) | 0 <= m /\ m <= 2 EXP n}` - ASSUME_TAC THENL - [REWRITE_TAC[FORALL_1; DIMINDEX_1; SET_RULE - `s INTER t = u <=> - (!x. x IN t ==> x IN s ==> x IN u) /\ - (!x. x IN u ==> x IN s /\ x IN t)`] THEN - REWRITE_TAC[FORALL_IN_GSPEC; IN_INTERVAL_1; DROP_VEC; LIFT_DROP] THEN - REWRITE_TAC[GSYM drop; FORALL_LIFT; LIFT_DROP; DROP_CMUL] THEN - REWRITE_TAC[ONCE_REWRITE_RULE[REAL_MUL_SYM] (GSYM real_div)] THEN - SIMP_TAC[REAL_LE_LDIV_EQ; REAL_LE_RDIV_EQ; REAL_LT_POW2] THEN - REWRITE_TAC[REAL_MUL_LZERO; REAL_MUL_LID; IMP_CONJ] THEN - REWRITE_TAC[REAL_OF_NUM_POW; REAL_OF_NUM_LE; LE_0] THEN - REWRITE_TAC[MESON[INTEGER_POS; REAL_POS] - `(!m. integer m ==> &0 <= m ==> P m) <=> (!n. P(&n))`] THEN - REWRITE_TAC[IN_ELIM_THM; ONCE_REWRITE_RULE[REAL_MUL_SYM] real_div] THEN - REWRITE_TAC[REAL_OF_NUM_LE; LIFT_CMUL; EXISTS_LIFT; LIFT_DROP] THEN - MESON_TAC[INTEGER_CLOSED]; - ALL_TAC] THEN - MP_TAC(ISPECL - [`f:real^1->real^N`; - `interval[vec 0:real^1,vec 1] INTER - {inv(&2 pow n) % m | n,m | !i. 1 <= i /\ i <= dimindex(:1) - ==> integer(m$i)}`] - UNIFORMLY_CONTINUOUS_EXTENDS_TO_CLOSURE) THEN - SIMP_TAC[CLOSURE_DYADIC_RATIONALS_IN_CONVEX_SET; CONVEX_INTERVAL; - INTERIOR_INTERVAL; UNIT_INTERVAL_NONEMPTY] THEN - ASM_REWRITE_TAC[CLOSURE_INTERVAL] THEN - REWRITE_TAC[path_component] THEN MATCH_MP_TAC MONO_EXISTS THEN - X_GEN_TAC `g:real^1->real^N` THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC (ASSUME_TAC o CONJUNCT1)) THEN - ASM_SIMP_TAC[path; UNIFORMLY_CONTINUOUS_IMP_CONTINUOUS] THEN CONJ_TAC THENL - [MP_TAC(ISPECL - [`g:real^1->real^N`; - `interval[vec 0:real^1,vec 1] INTER - {inv(&2 pow n) % m | n,m | !i. 1 <= i /\ i <= dimindex(:1) - ==> integer(m$i)}`; - `s:real^N->bool`] FORALL_IN_CLOSURE) THEN - SIMP_TAC[CLOSURE_DYADIC_RATIONALS_IN_CONVEX_SET; CONVEX_INTERVAL; - INTERIOR_INTERVAL; UNIT_INTERVAL_NONEMPTY] THEN - ASM_REWRITE_TAC[CLOSURE_INTERVAL] THEN - REWRITE_TAC[path_image; SUBSET; FORALL_IN_IMAGE] THEN - DISCH_THEN MATCH_MP_TAC THEN - ASM_SIMP_TAC[UNIFORMLY_CONTINUOUS_IMP_CONTINUOUS] THEN - ASM_SIMP_TAC[COMPACT_IMP_CLOSED] THEN ASM SET_TAC[]; - CONJ_TAC THEN - FIRST_X_ASSUM(fun th -> GEN_REWRITE_TAC RAND_CONV [SYM th]) THEN - REWRITE_TAC[pathstart; pathfinish] THEN FIRST_X_ASSUM MATCH_MP_TAC THEN - REWRITE_TAC[IN_ELIM_THM] THENL - [EXISTS_TAC `0`; EXISTS_TAC `1`] THEN - EXISTS_TAC `0` THEN - CONV_TAC NUM_REDUCE_CONV THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN - REWRITE_TAC[LIFT_NUM]]] THEN - SUBGOAL_THEN - `?f:real->real^N. - f(&0) = a /\ f(&1) = b /\ - (!m n. m <= 2 EXP n ==> f(&m / &2 pow n) IN s) /\ - (!j. ?d. &0 < d /\ - !n m1 m2. m1 <= 2 EXP n /\ m2 <= 2 EXP n /\ - abs(&m1 / &2 pow n - &m2 / &2 pow n) < d - ==> dist(f(&m1 / &2 pow n),f(&m2 / &2 pow n)) - < inv(&2 pow j))` - STRIP_ASSUME_TAC THENL - [ALL_TAC; - EXISTS_TAC `(f:real->real^N) o drop` THEN - REWRITE_TAC[GSYM LIFT_NUM; uniformly_continuous_on; FORALL_IN_GSPEC; - IMP_CONJ; RIGHT_FORALL_IMP_THM; DIST_LIFT; o_DEF] THEN - ASM_REWRITE_TAC[LE_0; LIFT_DROP] THEN - X_GEN_TAC `e:real` THEN DISCH_TAC THEN - MP_TAC(ISPECL [`inv(&2)`; `e:real`] REAL_ARCH_POW_INV) THEN - REWRITE_TAC[REAL_POW_INV] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN - ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `j:num` THEN DISCH_TAC THEN - FIRST_X_ASSUM(fun th -> - MP_TAC(SPEC `j:num` th) THEN MATCH_MP_TAC MONO_EXISTS) THEN - X_GEN_TAC `d:real` THEN STRIP_TAC THEN - ASM_REWRITE_TAC[RIGHT_IMP_FORALL_THM] THEN - ONCE_REWRITE_TAC[MESON[] - `(!a b c d. P a b c d) <=> (!b d a c. P a b c d)`] THEN - MATCH_MP_TAC WLOG_LE THEN - CONJ_TAC THENL [MESON_TAC[DIST_SYM; REAL_ABS_SUB]; ALL_TAC] THEN - MAP_EVERY X_GEN_TAC [`n1:num`; `n2:num`] THEN DISCH_TAC THEN - MAP_EVERY X_GEN_TAC [`m1:num`; `m2:num`] THEN REPEAT DISCH_TAC THEN - TRANS_TAC REAL_LT_TRANS `inv(&2 pow j)` THEN ASM_REWRITE_TAC[] THEN - FIRST_X_ASSUM(MP_TAC o SPECL - [`n2:num`; `m2:num`; `2 EXP (n2 - n1) * m1`]) THEN - ASM_REWRITE_TAC[] THEN - REWRITE_TAC[GSYM REAL_OF_NUM_LE; GSYM REAL_OF_NUM_MUL] THEN - REWRITE_TAC[GSYM REAL_OF_NUM_POW] THEN - ASM_SIMP_TAC[REAL_POW_SUB; REAL_OF_NUM_EQ; ARITH_EQ] THEN - SIMP_TAC[REAL_LT_POW2; REAL_FIELD - `&0 < n1 /\ &0 < n2 ==> (n2 / n1 * m) / n2 = m / n1`] THEN - DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[] THEN - REWRITE_TAC[REAL_ARITH `a / b * c <= a <=> a * c / b <= a * &1`] THEN - SIMP_TAC[REAL_LE_LMUL_EQ; REAL_LT_POW2; REAL_LE_LDIV_EQ] THEN - REWRITE_TAC[REAL_MUL_LID; REAL_OF_NUM_POW] THEN - ASM_REWRITE_TAC[REAL_OF_NUM_LE]] THEN - SUBGOAL_THEN - `?p f. (!n. p n < p(SUC n)) /\ - f(&0):real^N = a /\ f(&1) = b /\ - (!k1 i1 k2 i2. - k1 <= k2 /\ i1 <= 2 EXP (p k1) /\ i2 <= 2 EXP (p k2) /\ - abs(&i1 / &2 pow (p k1) - &i2 / &2 pow (p k2)) < - inv(&2 pow (p k1)) - ==> ?c. connected c /\ c SUBSET s /\ - c SUBSET ball(f(&i1 / &2 pow (p k1)),&2 / &2 pow k1) /\ - f(&i1 / &2 pow (p k1)) IN c /\ - f(&i2 / &2 pow (p k2)) IN c)` - MP_TAC THENL - [ALL_TAC; - DISCH_THEN(X_CHOOSE_THEN `r:num->num` MP_TAC) THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `f:real->real^N` THEN - STRIP_TAC THEN ASM_REWRITE_TAC[] THEN CONJ_TAC THENL - [MAP_EVERY X_GEN_TAC [`m:num`; `n:num`] THEN STRIP_TAC THEN - MP_TAC(ISPEC `r:num->num` MONOTONE_BIGGER) THEN ANTS_TAC THENL - [MATCH_MP_TAC TRANSITIVE_STEPWISE_LT THEN ASM_REWRITE_TAC[LT_TRANS]; - DISCH_THEN(MP_TAC o SPEC `n:num`) THEN DISCH_TAC] THEN - FIRST_X_ASSUM(MP_TAC o SPECL - [`n:num`; `2 EXP (r n - n) * m`; `n:num`; `2 EXP (r n - n) * m`]) THEN - REWRITE_TAC[LE_REFL; REAL_SUB_REFL; REAL_ABS_NUM] THEN - REWRITE_TAC[CONJ_ASSOC; REAL_LT_INV_EQ; REAL_LT_POW2] THEN - REWRITE_TAC[GSYM REAL_OF_NUM_LE; GSYM REAL_OF_NUM_MUL] THEN - REWRITE_TAC[GSYM REAL_OF_NUM_POW] THEN - ASM_SIMP_TAC[REAL_POW_SUB; REAL_OF_NUM_EQ; ARITH_EQ] THEN - REWRITE_TAC[REAL_ARITH `a / b * c <= a <=> a * c / b <= a * &1`] THEN - SIMP_TAC[REAL_LE_LMUL_EQ; REAL_LT_POW2; REAL_LE_LDIV_EQ] THEN - SIMP_TAC[REAL_LT_POW2; REAL_FIELD - `&0 < n1 /\ &0 < n2 ==> (n2 / n1 * m) / n2 = m / n1`] THEN - ASM_REWRITE_TAC[REAL_MUL_LID; REAL_OF_NUM_POW; REAL_OF_NUM_LE] THEN - SET_TAC[]; - X_GEN_TAC `j:num` THEN EXISTS_TAC `inv(&2 pow (r(j + 2)))` THEN - REWRITE_TAC[REAL_LT_INV_EQ; REAL_LT_POW2] THEN - X_GEN_TAC `n:num` THEN MATCH_MP_TAC WLOG_LT THEN - REWRITE_TAC[DIST_REFL; REAL_LT_INV_EQ; REAL_LT_POW2] THEN CONJ_TAC THENL - [MESON_TAC[DIST_SYM; REAL_ABS_SUB]; ALL_TAC] THEN - MAP_EVERY X_GEN_TAC [`m1:num`; `m2:num`] THEN REPEAT STRIP_TAC THEN - SUBGOAL_THEN `r(j + 2):num < n` ASSUME_TAC THENL - [REWRITE_TAC[GSYM NOT_LE] THEN DISCH_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPEC `inv(&2 pow n)` o MATCH_MP (REAL_ARITH - `a < b ==> !x. x <= a ==> x < b`)) THEN - REWRITE_TAC[REAL_NOT_LT; NOT_IMP] THEN - ASM_SIMP_TAC[REAL_LE_INV2; REAL_LT_POW2; REAL_POW_MONO; - REAL_OF_NUM_LE; ARITH] THEN - REWRITE_TAC[real_div; GSYM REAL_SUB_RDISTRIB; REAL_ABS_MUL] THEN - REWRITE_TAC[REAL_ABS_INV; REAL_ABS_POW; REAL_ABS_NUM] THEN - GEN_REWRITE_TAC LAND_CONV [GSYM REAL_MUL_LID] THEN - SIMP_TAC[REAL_LE_RMUL_EQ; REAL_LT_POW2; REAL_LT_INV_EQ] THEN - MATCH_MP_TAC REAL_ABS_INTEGER_LEMMA THEN - SIMP_TAC[INTEGER_CLOSED; REAL_SUB_0; REAL_OF_NUM_EQ] THEN - ASM_ARITH_TAC; - ALL_TAC] THEN - MP_TAC(ISPEC `r:num->num` MONOTONE_BIGGER) THEN ANTS_TAC THENL - [MATCH_MP_TAC TRANSITIVE_STEPWISE_LT THEN ASM_REWRITE_TAC[LT_TRANS]; - DISCH_THEN(MP_TAC o SPEC `n:num`) THEN DISCH_TAC] THEN - FIRST_X_ASSUM(MP_TAC o ISPECL - [`j + 2`; `m2 DIV (2 EXP (n - r(j + 2)))`; `n:num`]) THEN - REWRITE_TAC[RIGHT_FORALL_IMP_THM; IMP_CONJ] THEN ANTS_TAC THENL - [TRANS_TAC LE_TRANS `r(j + 2):num` THEN ASM_SIMP_TAC[LT_IMP_LE] THEN - SPEC_TAC(`j + 2`,`i:num`) THEN MATCH_MP_TAC MONOTONE_BIGGER THEN - MATCH_MP_TAC TRANSITIVE_STEPWISE_LT THEN ASM_REWRITE_TAC[LT_TRANS]; - ALL_TAC] THEN - ANTS_TAC THENL - [SIMP_TAC[LE_LDIV_EQ; EXP_EQ_0; ARITH_EQ] THEN MATCH_MP_TAC - (ARITH_RULE `~(b = 0) /\ a <= b * c ==> a < b * (c + 1)`) THEN - REWRITE_TAC[EXP_EQ_0; ARITH_EQ] THEN - ASM_SIMP_TAC[GSYM EXP_ADD; LT_IMP_LE; SUB_ADD]; - ALL_TAC] THEN - DISCH_THEN(fun th -> - MP_TAC(SPEC `2 EXP (r n - n) * m1` th) THEN - MP_TAC(SPEC `2 EXP (r n - n) * m2` th)) THEN - REWRITE_TAC[GSYM REAL_OF_NUM_LE; GSYM REAL_OF_NUM_MUL] THEN - REWRITE_TAC[GSYM REAL_OF_NUM_POW] THEN - ASM_SIMP_TAC[REAL_POW_SUB; REAL_OF_NUM_EQ; ARITH_EQ] THEN - REWRITE_TAC[REAL_ARITH `a / b * c <= a <=> a * c / b <= a * &1`] THEN - SIMP_TAC[REAL_LE_LMUL_EQ; REAL_LT_POW2; REAL_LE_LDIV_EQ] THEN - SIMP_TAC[REAL_LT_POW2; REAL_FIELD - `&0 < n1 /\ &0 < n2 ==> (n2 / n1 * m) / n2 = m / n1`] THEN - ASM_REWRITE_TAC[REAL_MUL_LID; REAL_OF_NUM_POW; REAL_OF_NUM_LE] THEN - REWRITE_TAC[GSYM REAL_OF_NUM_POW] THEN MATCH_MP_TAC(TAUT - `(q1 /\ q2 ==> r) /\ (p1 /\ p2) - ==> (p1 ==> q1) ==> (p2 ==> q2) ==> r`) THEN - CONJ_TAC THENL - [DISCH_THEN(CONJUNCTS_THEN (MP_TAC o MATCH_MP (SET_RULE - `(?c. P c /\ c SUBSET s /\ c SUBSET b /\ x IN c /\ y IN c) - ==> y IN b`))) THEN - REWRITE_TAC[IN_BALL; IMP_IMP] THEN MATCH_MP_TAC(NORM_ARITH - `inv(&2) * j = i - ==> dist(x:real^N,a) < i /\ dist(x,b) < i ==> dist(a,b) < j`) THEN - REWRITE_TAC[REAL_POW_ADD; real_div; REAL_INV_MUL] THEN - REAL_ARITH_TAC; - MATCH_MP_TAC(REAL_ARITH - `a < b /\ x <= b /\ b - i < x /\ abs(a - b) < i - ==> abs(x - b) < i /\ abs(x - a) < i`) THEN - ASM_SIMP_TAC[REAL_LT_DIV2_EQ; REAL_LT_POW2; REAL_OF_NUM_LT] THEN - SIMP_TAC[REAL_LE_LDIV_EQ; REAL_LT_RDIV_EQ; REAL_LT_POW2] THEN - SIMP_TAC[REAL_LT_POW2; REAL_FIELD - `&0 < n /\ &0 < j ==> (m / n - inv j) * j = m / (n / j) - &1`] THEN - SIMP_TAC[REAL_LT_POW2; REAL_LT_SUB_RADD; REAL_FIELD - `&0 < n /\ &0 < j ==> m / n * j = m / (n / j)`] THEN - ASM_SIMP_TAC[GSYM REAL_POW_SUB; LT_IMP_LE; REAL_OF_NUM_EQ; ARITH] THEN - SIMP_TAC[REAL_LE_RDIV_EQ; REAL_LT_LDIV_EQ; REAL_LT_POW2] THEN - REWRITE_TAC[REAL_OF_NUM_POW; REAL_OF_NUM_MUL; REAL_OF_NUM_ADD] THEN - REWRITE_TAC[REAL_OF_NUM_LE; REAL_OF_NUM_LT] THEN - ONCE_REWRITE_TAC[MULT_SYM] THEN REWRITE_TAC[DIV_MUL_LE] THEN - W(MP_TAC o PART_MATCH (lhand o lhand o rand o lhand o rand) DIVISION o - lhand o rand o rand o snd) THEN - REWRITE_TAC[EXP_EQ_0; ARITH_EQ] THEN - ARITH_TAC]]] THEN - SUBGOAL_THEN - `?p f. (!n. p n < p(SUC n)) /\ - f(&0):real^N = a /\ f(&1) = b /\ - (!n m k. m <= 2 EXP (p n) /\ k <= 2 EXP (p(SUC n)) /\ - abs(&m / &2 pow (p n) - &k / &2 pow (p(SUC n))) - < inv(&2 pow (p n)) - ==> ?c. connected c /\ c SUBSET s /\ - c SUBSET ball(f(&m / &2 pow (p n)),inv(&2 pow n)) /\ - f(&m / &2 pow (p n)) IN c /\ - f(&k / &2 pow (p(SUC n))) IN c)` - MP_TAC THENL - [ALL_TAC; - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `r:num->num` THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `f:real->real^N` THEN - STRIP_TAC THEN ASM_REWRITE_TAC[] THEN - GEN_REWRITE_TAC BINDER_CONV [SWAP_FORALL_THM] THEN - ONCE_REWRITE_TAC[IMP_CONJ] THEN REWRITE_TAC[RIGHT_FORALL_IMP_THM] THEN - ONCE_REWRITE_TAC[MESON[LE_EXISTS] - `(!m n:num. m <= n ==> P m n) <=> !n d. P n (n + d)`] THEN - GEN_REWRITE_TAC I [SWAP_FORALL_THM] THEN - MATCH_MP_TAC num_INDUCTION THEN CONJ_TAC THENL - [MAP_EVERY X_GEN_TAC [`n:num`; `m1:num`; `m2:num`] THEN - REWRITE_TAC[ADD_CLAUSES; real_div; GSYM REAL_SUB_RDISTRIB] THEN - REWRITE_TAC[REAL_ABS_MUL; REAL_ABS_INV; REAL_ABS_POW; REAL_ABS_NUM] THEN - SIMP_TAC[GSYM real_div; REAL_LT_LDIV_EQ; REAL_LT_POW2; - REAL_MUL_LINV; REAL_LT_IMP_NZ] THEN - SIMP_TAC[GSYM REAL_EQ_INTEGERS; INTEGER_CLOSED] THEN - REWRITE_TAC[REAL_OF_NUM_EQ] THEN STRIP_TAC THEN - EXISTS_TAC `{f(&m2 / &2 pow r(n:num)):real^N}` THEN - ASM_REWRITE_TAC[SING_SUBSET; IN_SING; CENTRE_IN_BALL] THEN - REWRITE_TAC[CONNECTED_SING] THEN - SIMP_TAC[REAL_LT_DIV; REAL_POW_LT; REAL_OF_NUM_LT; ARITH] THEN - FIRST_X_ASSUM(MP_TAC o SPECL - [`n:num`; `m2:num`; `2 EXP (r(SUC n) - r n) * m2`]) THEN - ASM_REWRITE_TAC[] THEN ANTS_TAC THENL [ALL_TAC; SET_TAC[]] THEN - REWRITE_TAC[GSYM REAL_OF_NUM_LE; GSYM REAL_OF_NUM_MUL] THEN - REWRITE_TAC[GSYM REAL_OF_NUM_POW] THEN - ASM_SIMP_TAC[REAL_POW_SUB; LT_IMP_LE; REAL_OF_NUM_EQ; ARITH_EQ] THEN - SIMP_TAC[REAL_LT_POW2; REAL_FIELD - `&0 < r /\ &0 < s ==> (r / s * m) / r = m / s`] THEN - REWRITE_TAC[REAL_SUB_REFL; REAL_ABS_NUM; REAL_LT_INV_EQ] THEN - REWRITE_TAC[REAL_LT_POW2] THEN - ONCE_REWRITE_TAC[REAL_ARITH - `a / b * c <= a <=> a * c / b <= a * &1`] THEN - SIMP_TAC[REAL_LE_LMUL_EQ; REAL_LT_POW2; REAL_LE_LDIV_EQ] THEN - REWRITE_TAC[REAL_MUL_LID] THEN - ASM_REWRITE_TAC[REAL_OF_NUM_POW; REAL_OF_NUM_LE]; - ALL_TAC] THEN - X_GEN_TAC `d:num` THEN DISCH_THEN(LABEL_TAC "*") THEN - MAP_EVERY X_GEN_TAC [`n:num`; `m1:num`; `m2:num`] THEN - REWRITE_TAC[ADD_CLAUSES] THEN STRIP_TAC THEN - SUBGOAL_THEN - `?k. k <= 2 EXP r(SUC n) /\ - abs(&m1 / &2 pow (r n) - &k / &2 pow r(SUC n)) < inv(&2 pow r n) /\ - abs(&k / &2 pow r(SUC n) - &m2 / &2 pow r(SUC(n + d))) < - inv (&2 pow r (SUC n))` - STRIP_ASSUME_TAC THENL - [ALL_TAC; - REMOVE_THEN "*" (MP_TAC o SPECL [`SUC n`; `k:num`; `m2:num`]) THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`n:num`; `m1:num`; `k:num`]) THEN - ASM_REWRITE_TAC[ADD_CLAUSES; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `c1:real^N->bool` THEN STRIP_TAC THEN - X_GEN_TAC `c2:real^N->bool` THEN STRIP_TAC THEN - EXISTS_TAC `c1 UNION c2:real^N->bool` THEN - ASM_REWRITE_TAC[UNION_SUBSET; IN_UNION] THEN CONJ_TAC THENL - [MATCH_MP_TAC CONNECTED_UNION THEN ASM SET_TAC[]; ALL_TAC] THEN - CONJ_TAC THEN FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP - (REWRITE_RULE[IMP_CONJ] SUBSET_TRANS)) THEN - REWRITE_TAC[SUBSET_BALLS; DIST_REFL; - REAL_ARITH `&0 + inv x <= &2 / x <=> &0 <= inv x`] THEN - SIMP_TAC[REAL_LE_INV_EQ; REAL_LT_IMP_LE; REAL_LT_POW2] THEN - DISJ1_TAC THEN REWRITE_TAC[real_pow; real_div; REAL_INV_MUL] THEN - MATCH_MP_TAC(REAL_ARITH `x < y ==> x + &2 * inv(&2) * y <= &2 * y`) THEN - ONCE_REWRITE_TAC[DIST_SYM] THEN REWRITE_TAC[GSYM IN_BALL] THEN - REWRITE_TAC[GSYM real_div] THEN ASM SET_TAC[]] THEN - SUBGOAL_THEN `!m n. m <= n ==> (r:num->num) m <= r n` ASSUME_TAC THENL - [MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN - ASM_SIMP_TAC[LT_IMP_LE] THEN ARITH_TAC; - ALL_TAC] THEN - MATCH_MP_TAC(MESON[] `(?k. P k \/ P(k + 1)) ==> ?k. P k`) THEN - EXISTS_TAC `m2 DIV 2 EXP (r(SUC(n + d)) - r(SUC n))` THEN - REWRITE_TAC[GSYM REAL_OF_NUM_LE; GSYM REAL_OF_NUM_ADD] THEN - REWRITE_TAC[GSYM REAL_OF_NUM_POW] THEN - ONCE_REWRITE_TAC[REAL_ARITH `x <= y <=> x <= &1 * y`] THEN - SIMP_TAC[GSYM REAL_LE_LDIV_EQ; REAL_LT_POW2] THEN - REWRITE_TAC[REAL_ARITH `(x + &1) / y = x / y + inv(y)`] THEN - MATCH_MP_TAC(REAL_ARITH - `x <= b /\ b < x + e /\ abs(a - b) < d /\ e <= d /\ a <= c /\ b <= c - ==> x <= c /\ abs(a - x) < d /\ abs(x - b) < e \/ - x + e <= c /\ abs(a - (x + e)) < d /\ abs((x + e) - b) < e`) THEN - ASM_SIMP_TAC[REAL_LE_INV2; REAL_POW_MONO; REAL_OF_NUM_LE; ARITH; LT_IMP_LE; - REAL_LT_POW2] THEN - SIMP_TAC[REAL_LE_LDIV_EQ; REAL_LT_POW2; REAL_MUL_LID] THEN - ASM_REWRITE_TAC[REAL_OF_NUM_POW; REAL_OF_NUM_LE] THEN - REWRITE_TAC[REAL_ARITH `x / y + inv y = (x + &1) / y`] THEN - SIMP_TAC[REAL_LT_RDIV_EQ; REAL_LT_POW2; GSYM REAL_OF_NUM_POW] THEN - SIMP_TAC[REAL_LT_POW2; REAL_FIELD - `&0 < m /\ &0 < n ==> x / m * n = x / (m / n)`] THEN - ASM_SIMP_TAC[GSYM REAL_POW_SUB; REAL_OF_NUM_EQ; ARITH_EQ; - ARITH_RULE `SUC n <= SUC(n + d)`] THEN - SIMP_TAC[REAL_LE_RDIV_EQ; REAL_LT_LDIV_EQ; REAL_LT_POW2] THEN - REWRITE_TAC[REAL_OF_NUM_POW; REAL_OF_NUM_MUL; REAL_OF_NUM_ADD] THEN - REWRITE_TAC[REAL_OF_NUM_LT; REAL_OF_NUM_LE] THEN - W(MP_TAC o PART_MATCH (lhand o lhand o rand o lhand o rand) DIVISION o - lhand o lhand o lhand o snd) THEN - REWRITE_TAC[EXP_EQ_0; ARITH_EQ] THEN ARITH_TAC] THEN - SUBGOAL_THEN - `?p f. (!n. p n < p(SUC n)) /\ - (!n. f n 0 = (a:real^N)) /\ (!n. f n (2 EXP (p n)) = b) /\ - (!n k. k <= 2 EXP (p n) - ==> f (SUC n) (2 EXP (p(SUC n) - p n) * k) = f n k) /\ - (!n m k. m <= 2 EXP (p n) /\ k <= 2 EXP (p(SUC n)) /\ - abs(&m / &2 pow (p n) - &k / &2 pow (p(SUC n))) - < inv(&2 pow (p n)) - ==> ?c. connected c /\ c SUBSET s /\ - c SUBSET ball(f n m,inv(&2 pow n)) /\ - f n m IN c /\ f (SUC n) k IN c)` - MP_TAC THENL - [ALL_TAC; - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `r:num->num` THEN - DISCH_THEN(X_CHOOSE_THEN `f:num->num->real^N` STRIP_ASSUME_TAC) THEN - EXISTS_TAC `\x. let t = @t. &(SND t) / &2 pow (r(FST t)) = x in - (f:num->num->real^N) (FST t) (SND t)` THEN - ASM_REWRITE_TAC[] THEN REPEAT CONJ_TAC THENL - [LET_TAC THEN - SUBGOAL_THEN `&(SND t) / &2 pow r(FST t:num) = &0` MP_TAC THENL - [EXPAND_TAC "t" THEN CONV_TAC SELECT_CONV THEN - EXISTS_TAC `0,0` THEN REWRITE_TAC[real_div; REAL_MUL_LZERO]; - REWRITE_TAC[REAL_DIV_EQ_0; REAL_POW_EQ_0] THEN - CONV_TAC REAL_RAT_REDUCE_CONV THEN - ASM_SIMP_TAC[REAL_OF_NUM_EQ]]; - LET_TAC THEN - SUBGOAL_THEN `&(SND t) / &2 pow r(FST t:num) = &1` MP_TAC THENL - [EXPAND_TAC "t" THEN CONV_TAC SELECT_CONV THEN - EXISTS_TAC `0,2 EXP r 0` THEN - SIMP_TAC[GSYM REAL_OF_NUM_POW; REAL_DIV_REFL; REAL_POW_EQ_0; - REAL_OF_NUM_EQ; ARITH_EQ]; - SIMP_TAC[REAL_EQ_LDIV_EQ; REAL_LT_POW2; REAL_MUL_LID] THEN - ASM_SIMP_TAC[REAL_OF_NUM_POW; REAL_OF_NUM_EQ]]; - MAP_EVERY X_GEN_TAC [`n:num`; `m:num`; `k:num`] THEN STRIP_TAC THEN - ABBREV_TAC - `t = @t. &(SND t) / &2 pow r (FST t:num) = &m / &2 pow r n` THEN - ABBREV_TAC - `u = @t. &(SND t) / &2 pow r (FST t) = &k / &2 pow r(SUC n)` THEN - CONV_TAC(TOP_DEPTH_CONV let_CONV) THEN - SUBGOAL_THEN - `(f:num->num->real^N) (FST t) (SND t) = f n m /\ - (f:num->num->real^N) (FST u) (SND u) = f (SUC n) k` - (fun th -> ASM_SIMP_TAC[th]) THEN - SUBGOAL_THEN - `!n n' m m'. &m / &2 pow (r n) = &m' / &2 pow (r n') /\ - m' <= 2 EXP (r n') - ==> (f:num->num->real^N) n m = f n' m'` - (fun th -> CONJ_TAC THEN MATCH_MP_TAC th THEN ASM_REWRITE_TAC[] THEN - MAP_EVERY EXPAND_TAC ["t"; "u"] THEN - CONV_TAC SELECT_CONV THEN - REWRITE_TAC[EXISTS_PAIR_THM] THEN MESON_TAC[]) THEN - REWRITE_TAC[GSYM REAL_OF_NUM_LE; GSYM REAL_OF_NUM_POW] THEN - ONCE_REWRITE_TAC[REAL_ARITH `x <= y <=> x <= &1 * y`] THEN - SIMP_TAC[GSYM REAL_LE_LDIV_EQ; REAL_LT_POW2] THEN - MATCH_MP_TAC WLOG_LE THEN CONJ_TAC THENL [MESON_TAC[]; ALL_TAC] THEN - REPEAT(FIRST_X_ASSUM(K ALL_TAC o check (fun t -> not(is_forall t)) o - concl)) THEN - X_GEN_TAC `n:num` THEN MATCH_MP_TAC num_INDUCTION THEN CONJ_TAC THENL - [SIMP_TAC[LE] THEN DISCH_THEN SUBST1_TAC THEN - SIMP_TAC[REAL_OF_NUM_EQ; REAL_LT_POW2; REAL_FIELD - `&0 < z ==> (x / z = y / z <=> x = y)`]; - ALL_TAC] THEN - X_GEN_TAC `p:num` THEN ASM_CASES_TAC `SUC p = n` THEN - ASM_SIMP_TAC[REAL_OF_NUM_EQ; REAL_LT_POW2; REAL_FIELD - `&0 < z ==> (x / z = y / z <=> x = y)`] THEN - ASM_CASES_TAC `n <= SUC p` THEN ASM_REWRITE_TAC[] THEN - ASM_CASES_TAC `n:num <= p` THENL [ALL_TAC; ASM_ARITH_TAC] THEN - ASM_REWRITE_TAC[] THEN DISCH_THEN(LABEL_TAC "*") THEN - MAP_EVERY X_GEN_TAC [`m1:num`; `m2:num`] THEN - SIMP_TAC[REAL_LE_LDIV_EQ; REAL_LT_POW2; REAL_MUL_LID] THEN - SUBGOAL_THEN `!m n. m <= n ==> (r:num->num) m <= r n` ASSUME_TAC THENL - [MATCH_MP_TAC TRANSITIVE_STEPWISE_LE THEN - ASM_SIMP_TAC[LT_IMP_LE] THEN ARITH_TAC; - ALL_TAC] THEN - SIMP_TAC[REAL_LT_POW2; REAL_FIELD - `&0 < m /\ &0 < n ==> (x / m = y / n <=> y = (n / m) * x)`] THEN - ASM_SIMP_TAC[GSYM REAL_POW_SUB; REAL_OF_NUM_EQ; ARITH_EQ; LT_IMP_LE] THEN - REWRITE_TAC[REAL_OF_NUM_POW; REAL_OF_NUM_MUL; REAL_OF_NUM_EQ] THEN - ASM_SIMP_TAC[REAL_OF_NUM_LE] THEN STRIP_TAC THEN - SUBGOAL_THEN `r(SUC p) - r n:num = (r(SUC p) - r p) + (r p - r n)` - SUBST1_TAC THENL - [MATCH_MP_TAC(ARITH_RULE - `x <= y /\ y <= z ==> z - x:num = (z - y) + (y - x)`) THEN - CONJ_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC; - REWRITE_TAC[EXP_ADD; GSYM MULT_ASSOC]] THEN - CONV_TAC SYM_CONV THEN - TRANS_TAC EQ_TRANS - `(f:num->num->real^N) p (2 EXP (r p - r(n:num)) * m1)` THEN - CONJ_TAC THENL - [FIRST_X_ASSUM MATCH_MP_TAC; - CONV_TAC SYM_CONV THEN FIRST_X_ASSUM MATCH_MP_TAC THEN - SIMP_TAC[REAL_EQ_RDIV_EQ; REAL_LE_LDIV_EQ; REAL_LT_POW2] THEN - ONCE_REWRITE_TAC[REAL_ARITH `m / x * y:real = (y / x) * m`] THEN - ASM_SIMP_TAC[GSYM REAL_POW_SUB; REAL_OF_NUM_EQ; ARITH_EQ] THEN - REWRITE_TAC[REAL_OF_NUM_MUL; REAL_OF_NUM_POW; MULT_CLAUSES]] THEN - UNDISCH_TAC `m2 <= 2 EXP r (SUC p)` THEN - ASM_REWRITE_TAC[] THEN - REWRITE_TAC[GSYM REAL_OF_NUM_LE; GSYM REAL_OF_NUM_MUL] THEN - REWRITE_TAC[GSYM REAL_OF_NUM_POW] THEN - ASM_SIMP_TAC[REAL_POW_SUB; REAL_OF_NUM_EQ; ARITH_EQ] THEN - REWRITE_TAC[REAL_ARITH `x / y * z <= x <=> x * (z / y) <= x * &1`] THEN - SIMP_TAC[REAL_LE_LMUL_EQ; REAL_LT_POW2]]] THEN - SUBGOAL_THEN - `?t. (!n. SND(t n) 0 = (a:real^N) /\ - (!i. 2 EXP (FST(t n)) <= i ==> SND(t n) i = b) /\ - !m. m <= 2 EXP (FST(t n)) - ==> ?c. connected c /\ c SUBSET s /\ - c SUBSET ball(SND(t n) m,inv(&2 pow n)) /\ - c SUBSET ball(SND(t n) (SUC m),inv(&2 pow n)) /\ - SND(t n) m IN c /\ SND(t n) (SUC m) IN c) /\ - (!n. - FST(t n) < FST(t(SUC n)) /\ - (!k. k <= 2 EXP (FST(t n)) - ==> SND(t(SUC n)) (2 EXP (FST(t(SUC n)) - FST(t n)) * k) = - SND(t n) k) /\ - (!m k. m <= 2 EXP (FST(t n)) /\ k <= 2 EXP (FST(t(SUC n))) /\ - abs(&m / &2 pow (FST(t n)) - &k / &2 pow (FST(t(SUC n)))) - < inv(&2 pow (FST(t n))) - ==> ?c. connected c /\ c SUBSET s /\ - c SUBSET ball(SND(t n) m,inv(&2 pow n)) /\ - SND(t n) m IN c /\ SND(t(SUC n)) k IN c))` - MP_TAC THENL - [MATCH_MP_TAC DEPENDENT_CHOICE THEN - REWRITE_TAC[EXISTS_PAIR_THM; FORALL_PAIR_THM]; - DISCH_THEN(X_CHOOSE_THEN `t:num->num#(num->real^N)` - STRIP_ASSUME_TAC) THEN - EXISTS_TAC `FST o (t:num->num#(num->real^N))` THEN - EXISTS_TAC `SND o (t:num->num#(num->real^N))` THEN - ASM_REWRITE_TAC[o_THM] THEN ASM_SIMP_TAC[LE_REFL]] THEN - CONJ_TAC THENL - [MP_TAC(ISPEC `s:real^N->bool` COMPACT_LOCALLY_CONNECTED_IMP_ULC_ALT) THEN - ASM_REWRITE_TAC[] THEN CONV_TAC REAL_RAT_REDUCE_CONV THEN - DISCH_THEN(MP_TAC o SPEC `&1`) THEN REWRITE_TAC[REAL_LT_01] THEN - DISCH_THEN(X_CHOOSE_THEN `d:real` STRIP_ASSUME_TAC) THEN - MP_TAC(ISPECL [`s:real^N->bool`; - `d:real`; `a:real^N`; `b:real^N`] - CONNECTED_IMP_WELLCHAINED) THEN - ASM_REWRITE_TAC[] THEN - DISCH_THEN(X_CHOOSE_THEN `g:num->real^N` MP_TAC) THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `l:num` THEN STRIP_TAC THEN - EXISTS_TAC `\i. if i <= l then (g:num->real^N) i else b:real^N` THEN - ASM_REWRITE_TAC[LE_0] THEN CONJ_TAC THENL - [X_GEN_TAC `i:num` THEN COND_CASES_TAC THEN ASM_REWRITE_TAC[] THEN - MP_TAC(ISPEC `l:num` LT_POW2_REFL) THEN ASM_ARITH_TAC; - ALL_TAC] THEN - X_GEN_TAC `i:num` THEN DISCH_TAC THEN ASM_CASES_TAC `l:num <= i` THENL - [ASM_SIMP_TAC[ARITH_RULE `l <= i ==> ~(SUC i <= l)`] THEN - ASM_SIMP_TAC[ARITH_RULE `l:num <= i ==> (i <= l <=> i = l)`] THEN - EXISTS_TAC `{b:real^N}` THEN - REWRITE_TAC[COND_ID; CONNECTED_SING; IN_SING; SING_SUBSET] THEN - REWRITE_TAC[CENTRE_IN_BALL; REAL_LT_01] THEN ASM SET_TAC[]; - RULE_ASSUM_TAC(REWRITE_RULE[NOT_LE])] THEN - ASM_SIMP_TAC[LE_SUC_LT; LT_IMP_LE] THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`(g:num->real^N) i`; `g(SUC i):real^N`]) THEN - ANTS_TAC THENL - [ASM_SIMP_TAC[LE_SUC_LT; LT_IMP_LE]; - MATCH_MP_TAC MONO_EXISTS THEN - SIMP_TAC[SUBSET_INTER; CONJ_ACI]]; - ALL_TAC] THEN - MAP_EVERY X_GEN_TAC [`n:num`; `m:num`; `f:num->real^N`] THEN - STRIP_TAC THEN - SUBGOAL_THEN - `!r. r <= 2 EXP m - ==> ?l g:num->real^N. - g 0 = f r /\ (!i. l <= i ==> g i = f (SUC r)) /\ - (?c. connected c /\ f r IN c /\ f(SUC r) IN c /\ - c SUBSET s /\ - c SUBSET ball(f r,inv (&2 pow n)) /\ - c SUBSET ball(f(SUC r),inv (&2 pow n)) /\ - !i. g i IN c) /\ - (!i. ?c. connected c /\ c SUBSET s /\ - c SUBSET ball(g i,inv(&2 pow (SUC n))) /\ - c SUBSET ball(g(SUC i),inv(&2 pow (SUC n))) /\ - g i IN c /\ g(SUC i) IN c)` - MP_TAC THENL - [X_GEN_TAC `r:num` THEN DISCH_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPEC `r:num`) THEN ASM_REWRITE_TAC[] THEN - DISCH_THEN(X_CHOOSE_THEN `c:real^N->bool` STRIP_ASSUME_TAC) THEN - MP_TAC(ISPEC `s:real^N->bool` COMPACT_LOCALLY_CONNECTED_IMP_ULC_ALT) THEN - ASM_REWRITE_TAC[] THEN - DISCH_THEN(MP_TAC o SPEC `inv(&2 pow (SUC n))`) THEN - REWRITE_TAC[REAL_LT_INV_EQ; REAL_LT_POW2] THEN - DISCH_THEN(X_CHOOSE_THEN `d:real` STRIP_ASSUME_TAC) THEN - MP_TAC(ISPECL [`c:real^N->bool`; - `d:real`; `(f:num->real^N) r`; `(f:num->real^N) (SUC r)`] - CONNECTED_IMP_WELLCHAINED) THEN - ASM_REWRITE_TAC[] THEN - DISCH_THEN(X_CHOOSE_THEN `g:num->real^N` MP_TAC) THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `l:num` THEN STRIP_TAC THEN - EXISTS_TAC `\i. if i <= l then (g:num->real^N) i else f(SUC r)` THEN - ASM_REWRITE_TAC[LE_0] THEN - CONJ_TAC THENL [ASM_MESON_TAC[LE_ANTISYM]; ALL_TAC] THEN CONJ_TAC THENL - [EXISTS_TAC `c:real^N->bool` THEN ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; - ALL_TAC] THEN - X_GEN_TAC `i:num` THEN ASM_CASES_TAC `l:num <= i` THENL - [ASM_SIMP_TAC[ARITH_RULE `l <= i ==> ~(SUC i <= l)`] THEN - ASM_SIMP_TAC[ARITH_RULE `l:num <= i ==> (i <= l <=> i = l)`] THEN - EXISTS_TAC `{f(SUC r):real^N}` THEN - REWRITE_TAC[COND_ID; CONNECTED_SING; IN_SING; SING_SUBSET] THEN - REWRITE_TAC[CENTRE_IN_BALL; REAL_LT_INV_EQ; REAL_LT_POW2] THEN - ASM SET_TAC[]; - RULE_ASSUM_TAC(REWRITE_RULE[NOT_LE])] THEN - ASM_SIMP_TAC[LE_SUC_LT; LT_IMP_LE] THEN - FIRST_X_ASSUM(MP_TAC o SPECL [`(g:num->real^N) i`; `g(SUC i):real^N`]) THEN - ANTS_TAC THENL [ALL_TAC; REWRITE_TAC[SUBSET_INTER; CONJ_ACI]] THEN - REPEAT(FIRST_X_ASSUM(fun th -> - MP_TAC(SPEC `i:num` th) THEN MP_TAC(SPEC `SUC i` th))) THEN - ASM_SIMP_TAC[LE_SUC_LT; LT_IMP_LE] THEN ASM SET_TAC[]; - GEN_REWRITE_TAC (LAND_CONV o TOP_DEPTH_CONV) [RIGHT_IMP_EXISTS_THM]] THEN - REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`l:num->num`; `g:num->num->real^N`] THEN - DISCH_THEN(LABEL_TAC "*") THEN - MP_TAC(ISPECL [`\n:num. n`; - `2 EXP 1 INSERT IMAGE (l:num->num) {r | r <= 2 EXP m}`] - UPPER_BOUND_FINITE_SET) THEN - SIMP_TAC[FINITE_INSERT; FINITE_IMAGE; FINITE_NUMSEG_LE] THEN - DISCH_THEN(X_CHOOSE_THEN `p:num` (MP_TAC o MATCH_MP (MESON[LE_TRANS; LT_LE] - `(!x. x IN s ==> x <= p) - ==> p < 2 EXP p ==> (!x. x IN s ==> x <= 2 EXP p)`))) THEN - ANTS_TAC THEN REWRITE_TAC[LT_POW2_REFL] THEN - REWRITE_TAC[FORALL_IN_INSERT; LE_EXP] THEN - CONV_TAC NUM_REDUCE_CONV THEN - REWRITE_TAC[FORALL_IN_IMAGE; FORALL_IN_GSPEC] THEN STRIP_TAC THEN - EXISTS_TAC `m + p:num` THEN - EXISTS_TAC - `\i. if i <= 2 EXP (m + p) - then (g:num->num->real^N) (i DIV (2 EXP p)) (i MOD (2 EXP p)) - else b` THEN - ASM_REWRITE_TAC[ARITH_RULE `m < m + p <=> 1 <= p`] THEN - REWRITE_TAC[ADD_SUB2] THEN SIMP_TAC[] THEN - SIMP_TAC[DIV_MULT; EXP_EQ_0; ARITH_EQ; EXP_ADD; MOD_MULT; - ONCE_REWRITE_RULE[MULT_SYM] DIV_MULT; - ONCE_REWRITE_RULE[MULT_SYM] MOD_MULT] THEN - REPEAT CONJ_TAC THENL - [SIMP_TAC[LE_0; DIV_0; MOD_0; EXP_EQ_0; ARITH_EQ] THEN - ASM_SIMP_TAC[LE_0]; - SIMP_TAC[ARITH_RULE `m:num <= n ==> (n <= m <=> n = m)`] THEN - SIMP_TAC[ONCE_REWRITE_RULE[MULT_SYM] DIV_MULT; - ONCE_REWRITE_RULE[MULT_SYM] MOD_MULT; - EXP_EQ_0; ARITH_EQ] THEN - ASM_SIMP_TAC[LE_REFL; COND_ID]; - ALL_TAC; - ASM_SIMP_TAC[] THEN - ONCE_REWRITE_TAC[ARITH_RULE `p * k:num <= m * p <=> p * k <= p * m`] THEN - SIMP_TAC[LE_MULT_LCANCEL]; - MAP_EVERY X_GEN_TAC [`r:num`; `k:num`] THEN - MP_TAC(ISPECL [`k:num`; `2 EXP p`] DIVISION) THEN - MAP_EVERY ABBREV_TAC [`k1 = k DIV 2 EXP p`; `k2 = k MOD 2 EXP p`] THEN - REWRITE_TAC[EXP_EQ_0; ARITH_EQ] THEN - DISCH_THEN(CONJUNCTS_THEN2 SUBST1_TAC ASSUME_TAC) THEN - STRIP_TAC THEN FIRST_ASSUM(MP_TAC o MATCH_MP (ARITH_RULE - `k * p + k':num <= m ==> k * p <= m`)) THEN - REWRITE_TAC[LE_MULT_RCANCEL; EXP_EQ_0; ARITH_EQ] THEN DISCH_TAC THEN - REMOVE_THEN "*" (MP_TAC o SPEC `k1:num`) THEN - ASM_REWRITE_TAC[] THEN - REPLICATE_TAC 2 (DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) THEN - DISCH_THEN(MP_TAC o CONJUNCT1) THEN MATCH_MP_TAC MONO_EXISTS THEN - SUBGOAL_THEN `r = k1 \/ r = SUC k1` MP_TAC THENL - [ALL_TAC; ASM_MESON_TAC[]] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE LAND_CONV [REAL_ABS_SUB]) THEN - GEN_REWRITE_TAC (LAND_CONV o RAND_CONV) [GSYM REAL_MUL_LID] THEN - REWRITE_TAC[GSYM real_div; GSYM REAL_OF_NUM_ADD; GSYM REAL_OF_NUM_MUL] THEN - SIMP_TAC[REAL_LT_RDIV_EQ; REAL_LT_POW2; GSYM REAL_OF_NUM_POW] THEN - SIMP_TAC[REAL_POW_ADD; REAL_LT_POW2; REAL_FIELD - `&0 < m /\ &0 < p - ==> (k1 * p + k2) / (m * p) - r / m = ((k1 - r) * p + k2) / p / m`] THEN - REWRITE_TAC[REAL_ABS_DIV; REAL_ABS_POW; REAL_ABS_NUM] THEN - SIMP_TAC[REAL_DIV_RMUL; REAL_LT_IMP_NZ; REAL_LT_POW2] THEN - SIMP_TAC[REAL_LT_LDIV_EQ; REAL_MUL_LID; REAL_LT_POW2] THEN - DISCH_THEN(MP_TAC o MATCH_MP (REAL_ARITH - `abs(r + k2) < p - ==> &0 <= k2 /\ k2 < p ==> -- &2 * p < r /\ r < &1 * p`)) THEN - SIMP_TAC[REAL_LT_RMUL_EQ; REAL_LT_POW2] THEN - ASM_REWRITE_TAC[REAL_POS; REAL_OF_NUM_POW; REAL_OF_NUM_LT] THEN - SIMP_TAC[REAL_LT_INTEGERS; INTEGER_CLOSED; REAL_POS] THEN - REWRITE_TAC[REAL_ARITH `-- &2 + &1:real <= k - r <=> r <= k + &1`; - REAL_ARITH `k - r + &1:real <= &1 <=> k <= r`] THEN - REWRITE_TAC[REAL_OF_NUM_LE; REAL_OF_NUM_ADD] THEN ARITH_TAC] THEN - X_GEN_TAC `k:num` THEN COND_CASES_TAC THEN ASM_REWRITE_TAC[] THENL - [UNDISCH_TAC `SUC k <= 2 EXP m * 2 EXP p`; - DISCH_THEN(MP_TAC o MATCH_MP (ARITH_RULE - `k <= n ==> ~(SUC k <= n) ==> k = n`)) THEN - ASM_REWRITE_TAC[] THEN DISCH_THEN SUBST1_TAC THEN - SIMP_TAC[ONCE_REWRITE_RULE[MULT_SYM] DIV_MULT; - ONCE_REWRITE_RULE[MULT_SYM] MOD_MULT; - EXP_EQ_0; ARITH_EQ] THEN - ASM_SIMP_TAC[LE_REFL] THEN EXISTS_TAC `{b:real^N}` THEN - ASM_REWRITE_TAC[CONNECTED_SING; IN_SING; SING_SUBSET] THEN - REWRITE_TAC[CENTRE_IN_BALL; REAL_LT_INV_EQ; REAL_LT_POW2]] THEN - MP_TAC(ISPECL [`k:num`; `2 EXP p`] DIVISION) THEN - MAP_EVERY ABBREV_TAC [`k1 = k DIV 2 EXP p`; `k2 = k MOD 2 EXP p`] THEN - REWRITE_TAC[EXP_EQ_0; ARITH_EQ] THEN - DISCH_THEN(CONJUNCTS_THEN2 SUBST1_TAC ASSUME_TAC) THEN - REWRITE_TAC[LE_SUC_LT] THEN REPEAT DISCH_TAC THEN - REWRITE_TAC[ARITH_RULE `SUC(a * b + c) = a * b + SUC c`] THEN - SIMP_TAC[DIV_MULT_ADD; MOD_MULT_ADD; EXP_EQ_0; ARITH_EQ] THEN - FIRST_ASSUM(MP_TAC o MATCH_MP (ARITH_RULE - `a + b:num < c ==> a < c`)) THEN - REWRITE_TAC[LT_MULT_RCANCEL; EXP_EQ_0; ARITH_EQ] THEN DISCH_TAC THEN - SUBGOAL_THEN `SUC k2 <= 2 EXP p` MP_TAC THENL - [ASM_REWRITE_TAC[LE_SUC_LT]; REWRITE_TAC[LE_LT]] THEN - STRIP_TAC THEN ASM_REWRITE_TAC[] THENL - [ASM_SIMP_TAC[DIV_LT; MOD_LT; ADD_CLAUSES] THEN - REMOVE_THEN "*" (MP_TAC o SPEC `k1:num`) THEN - ASM_SIMP_TAC[LT_IMP_LE] THEN MESON_TAC[]; - ASM_SIMP_TAC[DIV_REFL; MOD_REFL; EXP_EQ_0; ARITH_EQ] THEN - ASM_SIMP_TAC[ARITH_RULE `a < b ==> a + 1 <= b`] THEN - REMOVE_THEN "*" (MP_TAC o SPEC `k1:num`) THEN - ASM_SIMP_TAC[LT_IMP_LE] THEN - REPLICATE_TAC 2 (DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) THEN - DISCH_THEN(MP_TAC o CONJUNCT2) THEN REWRITE_TAC[GSYM SKOLEM_THM] THEN - DISCH_THEN(MP_TAC o SPEC `k2:num`) THEN REWRITE_TAC[GSYM ADD1] THEN - SUBGOAL_THEN `(g:num->num->real^N) k1 (SUC k2) = f(SUC k1)` - (fun th -> REWRITE_TAC[th]) THEN - FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[] THEN - FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_SIMP_TAC[LT_IMP_LE]]);; + GEN_TAC THEN STRIP_TAC THEN + MP_TAC(ISPECL [`euclidean_metric:(real^N)metric`; + `s:real^N->bool`] + LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_SPACE) THEN + REWRITE_TAC[MTOPOLOGY_EUCLIDEAN_METRIC; + LOCALLY_COMPACT_SPACE_SUBTOPOLOGY_EUCLIDEAN; + CONNECTED_IN_EUCLIDEAN; + LOCALLY_CONNECTED_SPACE_SUBTOPOLOGY_EUCLIDEAN; + PATH_CONNECTED_SPACE_EUCLIDEAN_SUBTOPOLOGY] THEN + DISCH_THEN MATCH_MP_TAC THEN ASM_REWRITE_TAC[]);; let LOCALLY_COMPACT_PATH_CONNECTED_EQ_CONNECTED = prove (`!s:real^N->bool. @@ -25687,8 +24631,11 @@ let COVERING_SPACE_LIFT_HOMOTOPY = prove (ANTS_TAC THENL [ASM SET_TAC[]; SIMP_TAC[IN_INTER]]); ALL_TAC] THEN MP_TAC(ISPECL - [`interval[vec 0:real^1,vec 1]`; `IMAGE (kk:real^1->real^1->bool) tk`] + [`euclidean_metric:(real^1)metric`; + `interval[vec 0:real^1,vec 1]`; `IMAGE (kk:real^1->real^1->bool) tk`] LEBESGUE_COVERING_LEMMA) THEN + REWRITE_TAC[MDIAMETER_EUCLIDEAN; MTOPOLOGY_EUCLIDEAN_METRIC] THEN + REWRITE_TAC[COMPACT_IN_EUCLIDEAN; GSYM OPEN_IN] THEN REWRITE_TAC[COMPACT_INTERVAL; FORALL_IN_IMAGE; IMAGE_EQ_EMPTY] THEN MATCH_MP_TAC(TAUT `q /\ (p ==> ~q) /\ (q ==> (r ==> s) ==> t) diff --git a/Multivariate/realanalysis.ml b/Multivariate/realanalysis.ml index af8e5665..8991ed71 100644 --- a/Multivariate/realanalysis.ml +++ b/Multivariate/realanalysis.ml @@ -86,8 +86,9 @@ let real_compact = prove parse_as_infix("--->",(12,"right"));; -let tendsto_real = new_definition - `(f ---> l) net <=> !e. &0 < e ==> eventually (\x. abs(f(x) - l) < e) net`;; +let tendsto_real = prove + (`(f ---> l) net <=> !e. &0 < e ==> eventually (\x. abs(f(x) - l) < e) net`, + REWRITE_TAC[tendsto_real_def; LIM_EQ_LIFT; tendsto; o_THM; DIST_LIFT]);; let reallim = new_definition `reallim net f = @l. (f ---> l) net`;; diff --git a/Multivariate/topology.ml b/Multivariate/topology.ml index fbb203ce..058757a8 100644 --- a/Multivariate/topology.ml +++ b/Multivariate/topology.ml @@ -12882,24 +12882,17 @@ let diameter = new_definition if s = {} then &0 else sup {norm(x - y) | x IN s /\ y IN s}`;; +let MDIAMETER_EUCLIDEAN = prove + (`mdiameter euclidean_metric:(real^N->bool)->real = diameter`, + REWRITE_TAC[mdiameter; diameter; FUN_EQ_THM; EUCLIDEAN_METRIC; dist]);; + let DIAMETER_BOUNDED = prove (`!s. bounded s ==> (!x:real^N y. x IN s /\ y IN s ==> norm(x - y) <= diameter s) /\ (!d. &0 <= d /\ d < diameter s ==> ?x y. x IN s /\ y IN s /\ norm(x - y) > d)`, - GEN_TAC THEN DISCH_TAC THEN - ASM_CASES_TAC `s:real^N->bool = {}` THEN - ASM_REWRITE_TAC[diameter; NOT_IN_EMPTY; REAL_LET_ANTISYM] THEN - MP_TAC(SPEC `{norm(x - y:real^N) | x IN s /\ y IN s}` SUP) THEN - ABBREV_TAC `b = sup {norm(x - y:real^N) | x IN s /\ y IN s}` THEN - REWRITE_TAC[EXTENSION; IN_ELIM_THM] THEN - REWRITE_TAC[NOT_IN_EMPTY; real_gt] THEN ANTS_TAC THENL - [CONJ_TAC THENL [ASM_MESON_TAC[MEMBER_NOT_EMPTY]; ALL_TAC]; - MESON_TAC[REAL_NOT_LE]] THEN - SIMP_TAC[VECTOR_SUB; LEFT_IMP_EXISTS_THM] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [bounded]) THEN - MESON_TAC[REAL_ARITH `x <= y + z /\ y <= b /\ z<= b ==> x <= b + b`; - NORM_TRIANGLE; NORM_NEG]);; + REWRITE_TAC[GSYM MBOUNDED_EUCLIDEAN; GSYM MDIAMETER_EUCLIDEAN] THEN + REWRITE_TAC[GSYM dist; GSYM EUCLIDEAN_METRIC; MDIAMETER_BOUNDED]);; let DIAMETER_BOUNDED_BOUND = prove (`!s x y. bounded s /\ x IN s /\ y IN s ==> norm(x - y) <= diameter s`, @@ -12909,15 +12902,9 @@ let DIAMETER_COMPACT_ATTAINED = prove (`!s:real^N->bool. compact s /\ ~(s = {}) ==> ?x y. x IN s /\ y IN s /\ (norm(x - y) = diameter s)`, - GEN_TAC THEN DISCH_TAC THEN - FIRST_ASSUM(MP_TAC o MATCH_MP COMPACT_SUP_MAXDISTANCE) THEN - REPEAT(MATCH_MP_TAC MONO_EXISTS THEN GEN_TAC) THEN - STRIP_TAC THEN ASM_REWRITE_TAC[] THEN - MP_TAC(SPEC `s:real^N->bool` DIAMETER_BOUNDED) THEN - RULE_ASSUM_TAC(REWRITE_RULE[COMPACT_EQ_BOUNDED_CLOSED]) THEN - ASM_REWRITE_TAC[real_gt] THEN STRIP_TAC THEN - REWRITE_TAC[GSYM REAL_LE_ANTISYM] THEN - ASM_MESON_TAC[NORM_POS_LE; REAL_NOT_LT]);; + REWRITE_TAC[GSYM COMPACT_IN_EUCLIDEAN; GSYM MDIAMETER_EUCLIDEAN] THEN + REWRITE_TAC[GSYM dist; GSYM EUCLIDEAN_METRIC] THEN + REWRITE_TAC[GSYM MTOPOLOGY_EUCLIDEAN_METRIC; MDIAMETER_COMPACT_ATTAINED]);; let DIAMETER_TRANSLATION = prove (`!a s. diameter (IMAGE (\x. a + x) s) = diameter s`, @@ -12943,65 +12930,27 @@ let DIAMETER_EMPTY = prove REWRITE_TAC[diameter]);; let DIAMETER_SING = prove - (`!a. diameter {a} = &0`, - REWRITE_TAC[diameter; NOT_INSERT_EMPTY; IN_SING] THEN - REWRITE_TAC[SET_RULE `{f x y | x = a /\ y = a} = {f a a }`] THEN - REWRITE_TAC[SUP_SING; VECTOR_SUB_REFL; NORM_0]);; + (`!a:real^N. diameter {a} = &0`, + SIMP_TAC[GSYM MDIAMETER_EUCLIDEAN; MDIAMETER_SING; + EUCLIDEAN_METRIC; IN_UNIV]);; let DIAMETER_POS_LE = prove (`!s:real^N->bool. bounded s ==> &0 <= diameter s`, - REPEAT STRIP_TAC THEN REWRITE_TAC[diameter] THEN - COND_CASES_TAC THEN ASM_REWRITE_TAC[REAL_LE_REFL] THEN - MP_TAC(SPEC `{norm(x - y:real^N) | x IN s /\ y IN s}` SUP) THEN - REWRITE_TAC[FORALL_IN_GSPEC] THEN ANTS_TAC THENL - [CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - FIRST_X_ASSUM(X_CHOOSE_TAC `B:real` o GEN_REWRITE_RULE I [BOUNDED_POS]) THEN - EXISTS_TAC `&2 * B` THEN - ASM_SIMP_TAC[NORM_ARITH - `norm x <= B /\ norm y <= B ==> norm(x - y) <= &2 * B`]; - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN - DISCH_THEN(X_CHOOSE_TAC `a:real^N`) THEN - DISCH_THEN(MP_TAC o SPECL [`a:real^N`; `a:real^N`] o CONJUNCT1) THEN - ASM_REWRITE_TAC[VECTOR_SUB_REFL; NORM_0]]);; + REWRITE_TAC[GSYM MBOUNDED_EUCLIDEAN; GSYM MDIAMETER_EUCLIDEAN] THEN + REWRITE_TAC[MDIAMETER_POS_LE]);; let DIAMETER_SUBSET = prove (`!s t:real^N->bool. s SUBSET t /\ bounded t ==> diameter s <= diameter t`, - REPEAT STRIP_TAC THEN - ASM_CASES_TAC `s:real^N->bool = {}` THEN - ASM_SIMP_TAC[DIAMETER_EMPTY; DIAMETER_POS_LE] THEN - ASM_REWRITE_TAC[diameter] THEN - COND_CASES_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - MATCH_MP_TAC REAL_SUP_LE_SUBSET THEN - REPEAT(CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC]) THEN - REWRITE_TAC[FORALL_IN_GSPEC] THEN - FIRST_X_ASSUM(X_CHOOSE_TAC `B:real` o GEN_REWRITE_RULE I [BOUNDED_POS]) THEN - EXISTS_TAC `&2 * B` THEN - ASM_SIMP_TAC[NORM_ARITH - `norm x <= B /\ norm y <= B ==> norm(x - y) <= &2 * B`]);; + REWRITE_TAC[GSYM MBOUNDED_EUCLIDEAN; GSYM MDIAMETER_EUCLIDEAN] THEN + REWRITE_TAC[MDIAMETER_SUBSET]);; let DIAMETER_CLOSURE = prove (`!s:real^N->bool. diameter(closure s) = diameter s`, GEN_TAC THEN ASM_CASES_TAC `bounded(s:real^N->bool)` THENL - [REWRITE_TAC[GSYM REAL_LE_ANTISYM] THEN REPEAT STRIP_TAC THEN - ASM_SIMP_TAC[DIAMETER_SUBSET; BOUNDED_CLOSURE; CLOSURE_SUBSET] THEN - REWRITE_TAC[GSYM REAL_NOT_LT] THEN ONCE_REWRITE_TAC[GSYM REAL_SUB_LT] THEN - DISCH_TAC THEN MP_TAC(ISPEC `closure s:real^N->bool` DIAMETER_BOUNDED) THEN - ABBREV_TAC `d = diameter(closure s) - diameter(s:real^N->bool)` THEN - ASM_SIMP_TAC[BOUNDED_CLOSURE] THEN DISCH_THEN(MP_TAC o - SPEC `diameter(closure(s:real^N->bool)) - d / &2` o CONJUNCT2) THEN - REWRITE_TAC[NOT_IMP; GSYM CONJ_ASSOC; NOT_EXISTS_THM] THEN - FIRST_ASSUM(ASSUME_TAC o MATCH_MP DIAMETER_POS_LE) THEN - REPEAT(CONJ_TAC THENL [ASM_REAL_ARITH_TAC; ALL_TAC]) THEN - MAP_EVERY X_GEN_TAC [`x:real^N`; `y:real^N`] THEN - REWRITE_TAC[CLOSURE_APPROACHABLE; CONJ_ASSOC; AND_FORALL_THM] THEN - DISCH_THEN(CONJUNCTS_THEN2 (MP_TAC o SPEC `d / &4`) ASSUME_TAC) THEN - ASM_REWRITE_TAC[REAL_ARITH `&0 < d / &4 <=> &0 < d`] THEN - DISCH_THEN(CONJUNCTS_THEN2 - (X_CHOOSE_THEN `u:real^N` (CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) - (X_CHOOSE_THEN `v:real^N` (CONJUNCTS_THEN2 ASSUME_TAC MP_TAC))) THEN - FIRST_ASSUM(MP_TAC o MATCH_MP DIAMETER_BOUNDED) THEN - DISCH_THEN(MP_TAC o SPECL [`u:real^N`; `v:real^N`] o CONJUNCT1) THEN - ASM_REWRITE_TAC[] THEN REPEAT(POP_ASSUM MP_TAC) THEN NORM_ARITH_TAC; + [POP_ASSUM MP_TAC THEN + REWRITE_TAC[GSYM MBOUNDED_EUCLIDEAN; GSYM MDIAMETER_EUCLIDEAN] THEN + REWRITE_TAC[GSYM EUCLIDEAN_CLOSURE_OF; GSYM MTOPOLOGY_EUCLIDEAN_METRIC; + MDIAMETER_CLOSURE]; REWRITE_TAC[diameter; CLOSURE_EQ_EMPTY] THEN COND_CASES_TAC THEN ASM_REWRITE_TAC[] THEN MATCH_MP_TAC SUP_EQ THEN REWRITE_TAC[FORALL_IN_GSPEC] THEN @@ -13021,12 +12970,8 @@ let DIAMETER_CLOSURE = prove let DIAMETER_SUBSET_CBALL_NONEMPTY = prove (`!s:real^N->bool. bounded s /\ ~(s = {}) ==> ?z. z IN s /\ s SUBSET cball(z,diameter s)`, - REPEAT STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `a:real^N` THEN - DISCH_TAC THEN ASM_REWRITE_TAC[SUBSET] THEN X_GEN_TAC `b:real^N` THEN - DISCH_TAC THEN REWRITE_TAC[IN_CBALL; dist] THEN - ASM_MESON_TAC[DIAMETER_BOUNDED]);; + REWRITE_TAC[GSYM MBOUNDED_EUCLIDEAN; GSYM MDIAMETER_EUCLIDEAN] THEN + REWRITE_TAC[GSYM MCBALL_EUCLIDEAN; MDIAMETER_SUBSET_MCBALL_NONEMPTY]);; let DIAMETER_SUBSET_CBALL = prove (`!s:real^N->bool. bounded s ==> ?z. s SUBSET cball(z,diameter s)`, @@ -13036,39 +12981,25 @@ let DIAMETER_SUBSET_CBALL = prove let DIAMETER_EQ_0 = prove (`!s:real^N->bool. bounded s ==> (diameter s = &0 <=> s = {} \/ ?a. s = {a})`, - REPEAT STRIP_TAC THEN EQ_TAC THEN STRIP_TAC THEN - ASM_REWRITE_TAC[DIAMETER_EMPTY; DIAMETER_SING] THEN - REWRITE_TAC[SET_RULE - `s = {} \/ (?a. s = {a}) <=> !a b. a IN s /\ b IN s ==> a = b`] THEN - MAP_EVERY X_GEN_TAC [`a:real^N`; `b:real^N`] THEN STRIP_TAC THEN - MP_TAC(ISPECL [`s:real^N->bool`; `a:real^N`; `b:real^N`] - DIAMETER_BOUNDED_BOUND) THEN - ASM_REWRITE_TAC[] THEN NORM_ARITH_TAC);; + REWRITE_TAC[GSYM MBOUNDED_EUCLIDEAN; GSYM MDIAMETER_EUCLIDEAN] THEN + REWRITE_TAC[MDIAMETER_EQ_0]);; let DIAMETER_LE = prove (`!s:real^N->bool. (~(s = {}) \/ &0 <= d) /\ (!x y. x IN s /\ y IN s ==> norm(x - y) <= d) ==> diameter s <= d`, - GEN_TAC THEN REWRITE_TAC[diameter] THEN - COND_CASES_TAC THEN ASM_SIMP_TAC[] THEN - STRIP_TAC THEN MATCH_MP_TAC REAL_SUP_LE THEN - CONJ_TAC THENL [ASM SET_TAC[]; ASM_SIMP_TAC[FORALL_IN_GSPEC]]);; + REWRITE_TAC[GSYM dist; GSYM MDIAMETER_EUCLIDEAN] THEN + MESON_TAC[EUCLIDEAN_METRIC; MDIAMETER_LE; SUBSET_UNIV]);; let BOUNDED_AND_DIAMETER_LE = prove (`!s:real^N->bool r. bounded s /\ diameter s <= r <=> &0 <= r /\ !x y. x IN s /\ y IN s ==> dist(x,y) <= r`, - REPEAT GEN_TAC THEN ASM_CASES_TAC `&0 <= r` THENL - [ASM_REWRITE_TAC[]; ASM_MESON_TAC[DIAMETER_POS_LE; REAL_LE_TRANS]] THEN - EQ_TAC THENL - [MESON_TAC[DIAMETER_BOUNDED_BOUND; dist; REAL_LE_TRANS]; ALL_TAC] THEN - REPEAT STRIP_TAC THENL - [ALL_TAC; MATCH_MP_TAC DIAMETER_LE THEN ASM_REWRITE_TAC[GSYM dist]] THEN - ASM_CASES_TAC `s:real^N->bool = {}` THEN ASM_REWRITE_TAC[BOUNDED_EMPTY] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN - DISCH_THEN(X_CHOOSE_TAC `a:real^N`) THEN - MATCH_MP_TAC BOUNDED_SUBSET THEN EXISTS_TAC `cball(a:real^N,r)` THEN - ASM_SIMP_TAC[BOUNDED_CBALL; SUBSET; IN_CBALL; dist]);; + REPEAT GEN_TAC THEN + REWRITE_TAC[GSYM MBOUNDED_EUCLIDEAN; GSYM MDIAMETER_EUCLIDEAN] THEN + REWRITE_TAC[GSYM EUCLIDEAN_METRIC] THEN + MATCH_MP_TAC MBOUNDED_AND_MDIAMETER_LE THEN + REWRITE_TAC[EUCLIDEAN_METRIC; SUBSET_UNIV]);; let DIST_LE_DIAMETER = prove (`!s a b:real^N. bounded s /\ a IN s /\ b IN s ==> dist(a,b) <= diameter s`, @@ -13183,75 +13114,8 @@ let DIAMETER_UNION_LE = prove (`!s t:real^N->bool. bounded s /\ bounded t /\ ~(s INTER t = {}) ==> diameter(s UNION t) <= diameter s + diameter t`, - REPEAT STRIP_TAC THEN MATCH_MP_TAC DIAMETER_LE THEN - ASM_SIMP_TAC[REAL_LE_ADD; DIAMETER_POS_LE; IN_UNION] THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [GSYM MEMBER_NOT_EMPTY]) THEN - REWRITE_TAC[IN_INTER; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `z:real^N` THEN STRIP_TAC THEN - MAP_EVERY X_GEN_TAC [`x:real^N`; `y:real^N`] THEN STRIP_TAC THENL - [MATCH_MP_TAC(REAL_ARITH `x <= a /\ &0 <= b ==> x <= a + b`) THEN - ASM_SIMP_TAC[DIAMETER_POS_LE]; - MATCH_MP_TAC(NORM_ARITH - `norm(x - z:real^N) <= s /\ norm(y - z) <= t - ==> norm(x - y) <= s + t`) THEN CONJ_TAC; - MATCH_MP_TAC(NORM_ARITH - `norm(x - z:real^N) <= t /\ norm(y - z) <= s - ==> norm(x - y) <= s + t`) THEN CONJ_TAC; - MATCH_MP_TAC(REAL_ARITH `x <= b /\ &0 <= a ==> x <= a + b`) THEN - ASM_SIMP_TAC[DIAMETER_POS_LE]] THEN - MATCH_MP_TAC DIAMETER_BOUNDED_BOUND THEN ASM_REWRITE_TAC[]);; - -let LEBESGUE_COVERING_LEMMA = prove - (`!s:real^N->bool c. - compact s /\ ~(c = {}) /\ s SUBSET UNIONS c /\ (!b. b IN c ==> open b) - ==> ?d. &0 < d /\ - !t. t SUBSET s /\ diameter t <= d - ==> ?b. b IN c /\ t SUBSET b`, - REPEAT STRIP_TAC THEN - FIRST_ASSUM(MP_TAC o MATCH_MP HEINE_BOREL_LEMMA) THEN - DISCH_THEN(MP_TAC o SPEC `c:(real^N->bool)->bool`) THEN ASM_SIMP_TAC[] THEN - ASM_REWRITE_TAC[LEFT_IMP_EXISTS_THM] THEN X_GEN_TAC `e:real` THEN - STRIP_TAC THEN EXISTS_TAC `e / &2` THEN ASM_REWRITE_TAC[REAL_HALF] THEN - X_GEN_TAC `t:real^N->bool` THEN STRIP_TAC THEN - ASM_CASES_TAC `t:real^N->bool = {}` THENL [ASM SET_TAC[]; ALL_TAC] THEN - MP_TAC(ISPEC `t:real^N->bool` DIAMETER_SUBSET_CBALL_NONEMPTY) THEN - ANTS_TAC THENL - [ASM_MESON_TAC[BOUNDED_SUBSET; COMPACT_IMP_BOUNDED]; ALL_TAC] THEN - DISCH_THEN(X_CHOOSE_THEN `x:real^N` STRIP_ASSUME_TAC) THEN - FIRST_X_ASSUM(MP_TAC o SPEC `x:real^N`) THEN - ANTS_TAC THENL [ASM SET_TAC[]; MATCH_MP_TAC MONO_EXISTS] THEN - X_GEN_TAC `b:real^N->bool` THEN STRIP_TAC THEN ASM_REWRITE_TAC[] THEN - MATCH_MP_TAC SUBSET_TRANS THEN - EXISTS_TAC `cball(x:real^N,diameter(t:real^N->bool))` THEN - ASM_REWRITE_TAC[] THEN MATCH_MP_TAC SUBSET_TRANS THEN - EXISTS_TAC `ball(x:real^N,e)` THEN ASM_REWRITE_TAC[] THEN - REWRITE_TAC[SUBSET; IN_CBALL; IN_BALL] THEN - MAP_EVERY UNDISCH_TAC [`&0 < e`; `diameter(t:real^N->bool) <= e / &2`] THEN - NORM_ARITH_TAC);; - -let LEBESGUE_COVERING_LEMMA_GEN = prove - (`!u s c:(real^N->bool)->bool. - compact s /\ - ~(c = {}) /\ - s SUBSET UNIONS c /\ - (!b. b IN c ==> open_in (subtopology euclidean u) b) - ==> ?d. &0 < d /\ - !t. t SUBSET s /\ diameter t <= d - ==> ?b. b IN c /\ t SUBSET b`, - REPEAT STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE (BINDER_CONV o RAND_CONV) - [OPEN_IN_OPEN]) THEN - GEN_REWRITE_TAC (LAND_CONV o ONCE_DEPTH_CONV) [RIGHT_IMP_EXISTS_THM] THEN - REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `t:(real^N->bool)->(real^N->bool)` THEN - DISCH_THEN(STRIP_ASSUME_TAC o GSYM) THEN - MP_TAC(ISPECL[`s:real^N->bool`; `IMAGE (t:(real^N->bool)->(real^N->bool)) c`] - LEBESGUE_COVERING_LEMMA) THEN - ASM_SIMP_TAC[IMAGE_EQ_EMPTY; FORALL_IN_IMAGE; EXISTS_IN_IMAGE] THEN - REWRITE_TAC[UNIONS_IMAGE] THEN - ANTS_TAC THENL [ASM SET_TAC[]; MATCH_MP_TAC MONO_EXISTS] THEN - GEN_TAC THEN MATCH_MP_TAC MONO_AND THEN REWRITE_TAC[] THEN - MATCH_MP_TAC MONO_FORALL THEN ASM SET_TAC[]);; + REWRITE_TAC[GSYM MBOUNDED_EUCLIDEAN; GSYM MDIAMETER_EUCLIDEAN] THEN + REWRITE_TAC[MDIAMETER_UNION_LE]);; (* ------------------------------------------------------------------------- *) (* Related results with closure as the conclusion. *) @@ -25388,139 +25252,41 @@ let CONNECTED_CHAIN = prove (!s. s IN f ==> compact s /\ connected s) /\ (!s t. s IN f /\ t IN f ==> s SUBSET t \/ t SUBSET s) ==> connected(INTERS f)`, - REPEAT STRIP_TAC THEN - ASM_CASES_TAC `f:(real^N->bool)->bool = {}` THEN - ASM_REWRITE_TAC[INTERS_0; CONNECTED_UNIV] THEN - ABBREV_TAC `c:real^N->bool = INTERS f` THEN - SUBGOAL_THEN `compact(c:real^N->bool)` ASSUME_TAC THENL - [EXPAND_TAC "c" THEN MATCH_MP_TAC COMPACT_INTERS THEN ASM SET_TAC[]; - ALL_TAC] THEN - ASM_SIMP_TAC[CONNECTED_CLOSED_SET; COMPACT_IMP_CLOSED; NOT_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`a:real^N->bool`; `b:real^N->bool`] THEN STRIP_TAC THEN - MP_TAC(ISPECL [`a:real^N->bool`; `b:real^N->bool`] SEPARATION_NORMAL) THEN - ASM_REWRITE_TAC[NOT_EXISTS_THM] THEN - MAP_EVERY X_GEN_TAC [`u:real^N->bool`; `v:real^N->bool`] THEN - STRIP_TAC THEN - SUBGOAL_THEN `?k:real^N->bool. k IN f` STRIP_ASSUME_TAC THENL - [ASM SET_TAC[]; ALL_TAC] THEN - SUBGOAL_THEN `?n:real^N->bool. open n /\ k SUBSET n` MP_TAC THENL - [ASM_MESON_TAC[BOUNDED_SUBSET_BALL; COMPACT_IMP_BOUNDED; OPEN_BALL]; - REWRITE_TAC[UNIONS_SUBSET] THEN STRIP_TAC] THEN - MP_TAC(ISPEC `k:real^N->bool` COMPACT_IMP_HEINE_BOREL) THEN - ASM_SIMP_TAC[] THEN DISCH_THEN(MP_TAC o SPEC - `(u UNION v:real^N->bool) INSERT {n DIFF s | s IN f}`) THEN - REWRITE_TAC[SIMPLE_IMAGE; FORALL_IN_INSERT; FORALL_IN_IMAGE] THEN - ASM_SIMP_TAC[OPEN_UNION; OPEN_DIFF; COMPACT_IMP_CLOSED; NOT_IMP] THEN - CONJ_TAC THENL - [REWRITE_TAC[UNIONS_INSERT] THEN REWRITE_TAC[SUBSET] THEN - X_GEN_TAC `x:real^N` THEN DISCH_TAC THEN ONCE_REWRITE_TAC[IN_UNION] THEN - ASM_CASES_TAC `(x:real^N) IN c` THENL [ASM SET_TAC[]; DISJ2_TAC] THEN - REWRITE_TAC[UNIONS_IMAGE; IN_ELIM_THM] THEN - UNDISCH_TAC `~((x:real^N) IN c)` THEN - SUBST1_TAC(SYM(ASSUME `INTERS f:real^N->bool = c`)) THEN - REWRITE_TAC[IN_INTERS; NOT_FORALL_THM] THEN - MATCH_MP_TAC MONO_EXISTS THEN ASM SET_TAC[]; - ALL_TAC] THEN - DISCH_THEN(X_CHOOSE_THEN `g:(real^N->bool)->bool` MP_TAC) THEN - DISCH_THEN(CONJUNCTS_THEN2 MP_TAC STRIP_ASSUME_TAC) THEN - REWRITE_TAC[SUBSET_INSERT_DELETE] THEN - SUBGOAL_THEN `FINITE(g DELETE (u UNION v:real^N->bool))` MP_TAC THENL - [ASM_REWRITE_TAC[FINITE_DELETE]; - REWRITE_TAC[TAUT `p ==> ~q <=> ~(p /\ q)`]] THEN - REWRITE_TAC[FINITE_SUBSET_IMAGE] THEN - DISCH_THEN(X_CHOOSE_THEN `f':(real^N->bool)->bool` STRIP_ASSUME_TAC) THEN - SUBGOAL_THEN - `?j:real^N->bool. j IN f /\ - UNIONS(IMAGE (\s. n DIFF s) f') SUBSET (n DIFF j)` - STRIP_ASSUME_TAC THENL - [ASM_CASES_TAC `f':(real^N->bool)->bool = {}` THEN - ASM_REWRITE_TAC[IMAGE_CLAUSES; UNIONS_0; EMPTY_SUBSET] THENL - [ASM SET_TAC[]; ALL_TAC] THEN - SUBGOAL_THEN - `?j:real^N->bool. j IN f' /\ - UNIONS(IMAGE (\s. n DIFF s) f') SUBSET (n DIFF j)` - MP_TAC THENL [ALL_TAC; ASM_MESON_TAC[SUBSET]] THEN - SUBGOAL_THEN - `!s t:real^N->bool. s IN f' /\ t IN f' ==> s SUBSET t \/ t SUBSET s` - MP_TAC THENL [ASM_MESON_TAC[SUBSET]; ALL_TAC] THEN - UNDISCH_TAC `~(f':(real^N->bool)->bool = {})` THEN - UNDISCH_TAC `FINITE(f':(real^N->bool)->bool)` THEN - SPEC_TAC(`f':(real^N->bool)->bool`,`f':(real^N->bool)->bool`) THEN - MATCH_MP_TAC FINITE_INDUCT_STRONG THEN REWRITE_TAC[] THEN - REWRITE_TAC[EXISTS_IN_INSERT; IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN - REWRITE_TAC[FORALL_IN_INSERT] THEN POP_ASSUM_LIST(K ALL_TAC) THEN - MAP_EVERY X_GEN_TAC [`i:real^N->bool`; `f:(real^N->bool)->bool`] THEN - ASM_CASES_TAC `f:(real^N->bool)->bool = {}` THEN - ASM_REWRITE_TAC[IMAGE_CLAUSES; UNIONS_INSERT; NOT_IN_EMPTY; - UNIONS_0; UNION_EMPTY; SUBSET_REFL] THEN - DISCH_THEN(fun th -> REPEAT DISCH_TAC THEN MP_TAC th) THEN - ANTS_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN - DISCH_THEN(X_CHOOSE_THEN `j:real^N->bool` STRIP_ASSUME_TAC) THEN - SUBGOAL_THEN `(n DIFF j) SUBSET (n DIFF i) \/ - (n DIFF i:real^N->bool) SUBSET (n DIFF j)` - STRIP_ASSUME_TAC THENL - [FIRST_X_ASSUM(MP_TAC o SPEC `j:real^N->bool` o CONJUNCT2) THEN - ASM SET_TAC[]; - DISJ1_TAC THEN ASM SET_TAC[]; - DISJ2_TAC THEN EXISTS_TAC `j:real^N->bool` THEN ASM SET_TAC[]]; - ALL_TAC] THEN - SUBGOAL_THEN `(j INTER k:real^N->bool) SUBSET (u UNION v)` ASSUME_TAC THENL - [MATCH_MP_TAC(SET_RULE - `k SUBSET (u UNION v) UNION (n DIFF j) - ==> (j INTER k) SUBSET (u UNION v)`) THEN - MATCH_MP_TAC SUBSET_TRANS THEN - EXISTS_TAC `UNIONS g :real^N->bool` THEN ASM_REWRITE_TAC[] THEN - MATCH_MP_TAC SUBSET_TRANS THEN EXISTS_TAC - `UNIONS((u UNION v:real^N->bool) INSERT (g DELETE (u UNION v)))` THEN - CONJ_TAC THENL [MATCH_MP_TAC SUBSET_UNIONS THEN SET_TAC[]; ALL_TAC] THEN - ASM_REWRITE_TAC[] THEN ONCE_REWRITE_TAC[UNIONS_INSERT] THEN - ASM SET_TAC[]; - ALL_TAC] THEN - SUBGOAL_THEN `connected(j INTER k:real^N->bool)` MP_TAC THENL - [ASM_MESON_TAC[SET_RULE `s SUBSET t ==> s INTER t = s`; INTER_COMM]; - REWRITE_TAC[connected] THEN - MAP_EVERY EXISTS_TAC [`u:real^N->bool`; `v:real^N->bool`] THEN - ASM_REWRITE_TAC[] THEN ASM SET_TAC[]]);; + GEN_TAC THEN ASM_CASES_TAC `f:(real^N->bool)->bool = {}` THENL + [ASM_REWRITE_TAC[INTERS_0; CONNECTED_UNIV]; ALL_TAC] THEN + STRIP_TAC THEN REWRITE_TAC[GSYM CONNECTED_IN_EUCLIDEAN] THEN + MATCH_MP_TAC CONNECTED_IN_CHAIN THEN + ASM_REWRITE_TAC[HAUSDORFF_SPACE_EUCLIDEAN; COMPACT_IN_EUCLIDEAN; + CONNECTED_IN_EUCLIDEAN]);; let CONNECTED_CHAIN_GEN = prove (`!f:(real^N->bool)->bool. - (!s. s IN f ==> closed s /\ connected s) /\ - (?s. s IN f /\ compact s) /\ - (!s t. s IN f /\ t IN f ==> s SUBSET t \/ t SUBSET s) - ==> connected(INTERS f)`, - GEN_TAC THEN DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC) THEN - FIRST_X_ASSUM(X_CHOOSE_THEN `s:real^N->bool` STRIP_ASSUME_TAC) THEN - SUBGOAL_THEN - `INTERS f = INTERS(IMAGE (\t:real^N->bool. s INTER t) f)` - SUBST1_TAC THENL - [REWRITE_TAC[EXTENSION; INTERS_IMAGE] THEN ASM SET_TAC[]; - MATCH_MP_TAC CONNECTED_CHAIN THEN - REWRITE_TAC[IMP_CONJ; RIGHT_FORALL_IMP_THM; FORALL_IN_IMAGE] THEN - ASM_SIMP_TAC[COMPACT_INTER_CLOSED] THEN - CONJ_TAC THENL [X_GEN_TAC `t:real^N->bool`; ASM SET_TAC[]] THEN - DISCH_TAC THEN - SUBGOAL_THEN `s INTER t:real^N->bool = s \/ s INTER t = t` - (DISJ_CASES_THEN SUBST1_TAC) THEN - ASM SET_TAC[]]);; + (!s. s IN f ==> closed s /\ connected s) /\ + (?s. s IN f /\ compact s) /\ + (!s t. s IN f /\ t IN f ==> s SUBSET t \/ t SUBSET s) + ==> connected(INTERS f)`, + GEN_TAC THEN DISCH_TAC THEN REWRITE_TAC[GSYM CONNECTED_IN_EUCLIDEAN] THEN + MATCH_MP_TAC CONNECTED_IN_CHAIN_GEN THEN + ASM_REWRITE_TAC[HAUSDORFF_SPACE_EUCLIDEAN; COMPACT_IN_EUCLIDEAN; + CONNECTED_IN_EUCLIDEAN; CLOSED_IN_EUCLIDEAN]);; let CONNECTED_NEST = prove (`!s. (!n. compact(s n) /\ connected(s n)) /\ (!m n. m <= n ==> s n SUBSET s m) - ==> connected(INTERS {s n | n IN (:num)})`, - GEN_TAC THEN STRIP_TAC THEN MATCH_MP_TAC CONNECTED_CHAIN THEN - ASM_SIMP_TAC[FORALL_IN_GSPEC; IN_UNIV; IMP_CONJ; RIGHT_FORALL_IMP_THM] THEN - MATCH_MP_TAC WLOG_LE THEN ASM_MESON_TAC[]);; + ==> connected(INTERS {(s:num->real^N->bool) n | n IN (:num)})`, + GEN_TAC THEN STRIP_TAC THEN REWRITE_TAC[GSYM CONNECTED_IN_EUCLIDEAN] THEN + MATCH_MP_TAC CONNECTED_IN_NEST THEN + ASM_REWRITE_TAC[HAUSDORFF_SPACE_EUCLIDEAN; COMPACT_IN_EUCLIDEAN; + CONNECTED_IN_EUCLIDEAN]);; let CONNECTED_NEST_GEN = prove (`!s. (!n. closed(s n) /\ connected(s n)) /\ (?n. compact(s n)) /\ (!m n. m <= n ==> s n SUBSET s m) - ==> connected(INTERS {s n | n IN (:num)})`, - GEN_TAC THEN - DISCH_THEN(REPEAT_TCL DISJ_CASES_THEN ASSUME_TAC) THEN - MATCH_MP_TAC CONNECTED_CHAIN_GEN THEN - ASM_SIMP_TAC[FORALL_IN_GSPEC; IN_UNIV; IMP_CONJ; RIGHT_FORALL_IMP_THM; - EXISTS_IN_GSPEC] THEN - MATCH_MP_TAC WLOG_LE THEN ASM_MESON_TAC[]);; + ==> connected(INTERS {(s:num->real^N->bool) n | n IN (:num)})`, + GEN_TAC THEN DISCH_TAC THEN REWRITE_TAC[GSYM CONNECTED_IN_EUCLIDEAN] THEN + MATCH_MP_TAC CONNECTED_IN_NEST_GEN THEN + ASM_REWRITE_TAC[HAUSDORFF_SPACE_EUCLIDEAN; COMPACT_IN_EUCLIDEAN; + CONNECTED_IN_EUCLIDEAN; CLOSED_IN_EUCLIDEAN]);; (* ------------------------------------------------------------------------- *) (* Hausdorff distance between sets. *) @@ -36375,9 +36141,19 @@ let BOREL_DOMAIN_OF_INJECTIVITY_CONTINUOUS = prove ASM SET_TAC[]);; (* ------------------------------------------------------------------------- *) -(* Several variants of paracompactness. *) +(* Partitions of unity subordinate to open coverings. Since subsets of *) +(* Euclidean space are paracompact, there's a locally finite refinement. *) (* ------------------------------------------------------------------------- *) +let PARACOMPACT_SPACE_EUCLIDEAN = prove + (`paracompact_space(euclidean:(real^N)topology)`, + REWRITE_TAC[GSYM MTOPOLOGY_EUCLIDEAN_METRIC; PARACOMPACT_SPACE_MTOPOLOGY]);; + +let PARACOMPACT_SPACE_EUCLIDEAN_SUBTOPOLOGY = prove + (`!s:real^N->bool. paracompact_space(subtopology euclidean s)`, + REWRITE_TAC[GSYM MTOPOLOGY_EUCLIDEAN_METRIC; PARACOMPACT_SPACE_MTOPOLOGY; + GSYM MTOPOLOGY_SUBMETRIC]);; + let PARACOMPACT = prove (`!s c. (!t:real^N->bool. t IN c ==> open t) /\ s SUBSET UNIONS c ==> ?c'. s SUBSET UNIONS c' /\ @@ -36386,265 +36162,88 @@ let PARACOMPACT = prove (!x. x IN s ==> ?v. open v /\ x IN v /\ FINITE {u | u IN c' /\ ~(u INTER v = {})})`, + REPEAT STRIP_TAC THEN MP_TAC(ISPEC + `UNIONS c:real^N->bool` PARACOMPACT_SPACE_EUCLIDEAN_SUBTOPOLOGY) THEN + REWRITE_TAC[paracompact_space] THEN + ASM_SIMP_TAC[OPEN_IN_OPEN_EQ; OPEN_UNIONS; locally_finite_in] THEN + DISCH_THEN(MP_TAC o SPEC `c:(real^N->bool)->bool`) THEN + ASM_REWRITE_TAC[TOPSPACE_EUCLIDEAN_SUBTOPOLOGY] THEN ANTS_TAC THENL + [ASM SET_TAC[]; MATCH_MP_TAC MONO_EXISTS THEN ASM SET_TAC[]]);; + +let SUBORDINATE_PARTITION_OF_UNITY = prove + (`!c s:real^N->bool. + s SUBSET UNIONS c /\ (!u. u IN c ==> open u) + ==> ?f:(real^N->bool)->real^N->real. + (!u. u IN c + ==> (lift o f u) continuous_on s /\ + !x. x IN s ==> &0 <= f u x) /\ + (!x u. u IN c /\ x IN s /\ ~(x IN u) + ==> f u x = &0) /\ + (!x. x IN s ==> sum c (\u. f u x) = &1) /\ + (!x. x IN s + ==> ?n. open n /\ x IN n /\ + FINITE {u | u IN c /\ + ~(!x. x IN n + ==> f u x = &0)})`, REPEAT STRIP_TAC THEN - ASM_CASES_TAC `s:real^N->bool = {}` THENL - [EXISTS_TAC `{}:(real^N->bool)->bool` THEN - ASM_REWRITE_TAC[EMPTY_SUBSET; NOT_IN_EMPTY]; - ALL_TAC] THEN - SUBGOAL_THEN - `!x:real^N. x IN s - ==> ?t u. x IN u /\ open u /\ closure u SUBSET t /\ t IN c` - MP_TAC THENL - [X_GEN_TAC `x:real^N` THEN DISCH_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPEC `x:real^N` o GEN_REWRITE_RULE I [SUBSET]) THEN - ASM_REWRITE_TAC[IN_UNIONS] THEN MATCH_MP_TAC MONO_EXISTS THEN - X_GEN_TAC `t:real^N->bool` THEN STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPEC `t:real^N->bool`) THEN - ASM_REWRITE_TAC[] THEN - GEN_REWRITE_TAC LAND_CONV [OPEN_CONTAINS_CBALL] THEN - DISCH_THEN(MP_TAC o SPEC `x:real^N`) THEN ASM_REWRITE_TAC[] THEN - DISCH_THEN(X_CHOOSE_THEN `e:real` STRIP_ASSUME_TAC) THEN - EXISTS_TAC `ball(x:real^N,e)` THEN - ASM_SIMP_TAC[OPEN_BALL; CENTRE_IN_BALL; CLOSURE_BALL]; - GEN_REWRITE_TAC (LAND_CONV o TOP_DEPTH_CONV) [RIGHT_IMP_EXISTS_THM] THEN - REWRITE_TAC[LEFT_IMP_EXISTS_THM; SKOLEM_THM] THEN - MAP_EVERY X_GEN_TAC - [`f:real^N->real^N->bool`; `e:real^N->real^N->bool`] THEN - STRIP_TAC] THEN - MP_TAC(ISPEC `IMAGE (e:real^N->real^N->bool) s` LINDELOF) THEN - ASM_SIMP_TAC[FORALL_IN_IMAGE] THEN - ONCE_REWRITE_TAC[TAUT `p /\ q /\ r <=> q /\ p /\ r`] THEN - REWRITE_TAC[EXISTS_COUNTABLE_SUBSET_IMAGE] THEN - DISCH_THEN(X_CHOOSE_THEN `k:real^N->bool` - (CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) THEN - ASM_CASES_TAC `k:real^N->bool = {}` THENL - [ASM_REWRITE_TAC[] THEN ASM SET_TAC[]; ALL_TAC] THEN - MP_TAC(ISPEC `k:real^N->bool` COUNTABLE_AS_IMAGE) THEN - ASM_REWRITE_TAC[] THEN - DISCH_THEN(X_CHOOSE_THEN `a:num->real^N` SUBST_ALL_TAC) THEN - STRIP_TAC THEN EXISTS_TAC - `{ f(a n:real^N) DIFF UNIONS {closure(e(a m)):real^N->bool | m < n} | - n IN (:num)}` THEN - REWRITE_TAC[FORALL_IN_GSPEC; IN_UNIV] THEN REPEAT CONJ_TAC THENL - [X_GEN_TAC `n:num` THEN CONJ_TAC THENL - [MATCH_MP_TAC OPEN_DIFF THEN - CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - MATCH_MP_TAC CLOSED_UNIONS THEN - REWRITE_TAC[FORALL_IN_GSPEC; CLOSED_CLOSURE] THEN - ONCE_REWRITE_TAC[SIMPLE_IMAGE_GEN] THEN - SIMP_TAC[FINITE_IMAGE; FINITE_NUMSEG_LT]; - EXISTS_TAC `f((a:num->real^N) n):real^N->bool` THEN ASM SET_TAC[]]; - REWRITE_TAC[SUBSET; UNIONS_GSPEC; IN_ELIM_THM; IN_DIFF] THEN - X_GEN_TAC `x:real^N` THEN DISCH_TAC THEN - SUBGOAL_THEN `?n. x IN (f((a:num->real^N) n):real^N->bool)` MP_TAC THENL - [RULE_ASSUM_TAC(REWRITE_RULE[UNIONS_IMAGE; EXISTS_IN_IMAGE]) THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [EXTENSION]) THEN - DISCH_THEN(MP_TAC o SPEC `x:real^N`) THEN - ASM_REWRITE_TAC[IN_ELIM_THM; IN_UNIV] THEN - DISCH_THEN(MP_TAC o snd o EQ_IMP_RULE) THEN - ANTS_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `n:num` THEN - STRIP_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPEC `(a:num->real^N) n`) THEN - ANTS_TAC THENL [ASM SET_TAC[]; ASM_MESON_TAC[CLOSURE_SUBSET; SUBSET]]; - GEN_REWRITE_TAC LAND_CONV [num_WOP] THEN - MATCH_MP_TAC MONO_EXISTS THEN ASM SET_TAC[]]; - X_GEN_TAC `x:real^N` THEN DISCH_TAC THEN - RULE_ASSUM_TAC(REWRITE_RULE[UNIONS_IMAGE; EXISTS_IN_IMAGE]) THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [EXTENSION]) THEN - DISCH_THEN(MP_TAC o SPEC `x:real^N`) THEN - ASM_REWRITE_TAC[IN_ELIM_THM; IN_UNIV] THEN - DISCH_THEN(MP_TAC o snd o EQ_IMP_RULE) THEN - ANTS_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - DISCH_THEN(X_CHOOSE_TAC `n:num`) THEN - EXISTS_TAC `e((a:num->real^N) n):real^N->bool` THEN - ASM_REWRITE_TAC[] THEN CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - REWRITE_TAC[SET_RULE - `{u | (?n. u = f n) /\ P u} = IMAGE f {n |n| P(f n) /\ n IN (:num)}`] THEN - MATCH_MP_TAC FINITE_IMAGE THEN MATCH_MP_TAC FINITE_SUBSET THEN - EXISTS_TAC `{m:num | m <= n}` THEN REWRITE_TAC[FINITE_NUMSEG_LE] THEN - REWRITE_TAC[SUBSET; IN_ELIM_THM; IN_UNIV] THEN - X_GEN_TAC `m:num` THEN ONCE_REWRITE_TAC[GSYM CONTRAPOS_THM] THEN - REWRITE_TAC[NOT_LE] THEN DISCH_TAC THEN - MATCH_MP_TAC(SET_RULE `u SUBSET t ==> (s DIFF t) INTER u = {}`) THEN - REWRITE_TAC[SUBSET; IN_UNIONS; EXISTS_IN_GSPEC] THEN - ASM_MESON_TAC[CLOSURE_SUBSET; SUBSET]]);; - -let PARACOMPACT_CLOSED_IN = prove - (`!u:real^N->bool s c. - closed_in (subtopology euclidean u) s /\ - (!t:real^N->bool. t IN c ==> open_in (subtopology euclidean u) t) /\ - s SUBSET UNIONS c - ==> ?c'. s SUBSET UNIONS c' /\ - (!v. v IN c' - ==> open_in (subtopology euclidean u) v /\ - ?t. t IN c /\ v SUBSET t) /\ - (!x. x IN u - ==> ?v. open_in (subtopology euclidean u) v /\ x IN v /\ - FINITE {n | n IN c' /\ ~(n INTER v = {})})`, - REPEAT GEN_TAC THEN DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC - (CONJUNCTS_THEN2 MP_TAC ASSUME_TAC)) THEN - REWRITE_TAC[OPEN_IN_OPEN] THEN - GEN_REWRITE_TAC (LAND_CONV o ONCE_DEPTH_CONV) [RIGHT_IMP_EXISTS_THM] THEN - REWRITE_TAC[SKOLEM_THM; LEFT_IMP_EXISTS_THM] THEN - X_GEN_TAC `uu:(real^N->bool)->(real^N->bool)` THEN - DISCH_THEN(ASSUME_TAC o GSYM) THEN - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [CLOSED_IN_CLOSED]) THEN - DISCH_THEN(X_CHOOSE_THEN `k:real^N->bool` - (CONJUNCTS_THEN2 ASSUME_TAC SUBST_ALL_TAC)) THEN MP_TAC(ISPECL - [`u:real^N->bool`; - `((:real^N) DIFF k) INSERT IMAGE (uu:(real^N->bool)->(real^N->bool)) c`] - PARACOMPACT) THEN - ASM_SIMP_TAC[FORALL_IN_IMAGE; UNIONS_IMAGE; UNIONS_INSERT; FORALL_IN_INSERT; - EXISTS_IN_IMAGE; EXISTS_IN_INSERT; GSYM closed] THEN - ANTS_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - DISCH_THEN(X_CHOOSE_THEN `d:(real^N->bool)->bool` STRIP_ASSUME_TAC) THEN - EXISTS_TAC `{u INTER v:real^N->bool | v IN d /\ ~(v INTER k = {})}` THEN + [`subtopology euclidean (UNIONS c):(real^N)topology`; + `c:(real^N->bool)->bool`] + PARACOMPACT_PARTITION_OF_UNITY) THEN + REWRITE_TAC[TOPSPACE_EUCLIDEAN_SUBTOPOLOGY; + CONTINUOUS_MAP_EQ_LIFT; CONTINUOUS_MAP_EUCLIDEAN] THEN + ANTS_TAC THENL + [REPEAT CONJ_TAC THENL + [MATCH_MP_TAC METRIZABLE_IMP_PARACOMPACT_SPACE THEN + MATCH_MP_TAC METRIZABLE_SPACE_SUBTOPOLOGY THEN + REWRITE_TAC[METRIZABLE_SPACE_EUCLIDEAN]; + MATCH_MP_TAC HAUSDORFF_SPACE_SUBTOPOLOGY THEN + REWRITE_TAC[HAUSDORFF_SPACE_EUCLIDEAN]; + X_GEN_TAC `u:real^N->bool` THEN DISCH_TAC THEN + REWRITE_TAC[OPEN_IN_OPEN] THEN + EXISTS_TAC `u:real^N->bool` THEN + ASM_SIMP_TAC[] THEN ASM SET_TAC[]]; + ALL_TAC] THEN + DISCH_THEN(X_CHOOSE_THEN `ph:(real^N->bool)->real^N->real` + STRIP_ASSUME_TAC) THEN + EXISTS_TAC `ph:(real^N->bool)->real^N->real` THEN + SUBGOAL_THEN `open(UNIONS c:real^N->bool)` ASSUME_TAC THENL + [MATCH_MP_TAC OPEN_UNIONS THEN ASM_REWRITE_TAC[]; ALL_TAC] THEN REPEAT CONJ_TAC THENL - [REWRITE_TAC[UNIONS_GSPEC] THEN ASM SET_TAC[]; - REWRITE_TAC[FORALL_IN_GSPEC] THEN ASM SET_TAC[]; - X_GEN_TAC `x:real^N` THEN DISCH_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPEC `x:real^N`) THEN ASM_REWRITE_TAC[] THEN - DISCH_THEN(X_CHOOSE_THEN `v:real^N->bool` STRIP_ASSUME_TAC) THEN - EXISTS_TAC `u INTER v:real^N->bool` THEN ASM_REWRITE_TAC[IN_INTER] THEN - CONJ_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN - ONCE_REWRITE_TAC[SET_RULE - `{y | y IN {f x | P x} /\ Q y} = IMAGE f {x | P x /\ Q(f x)}`] THEN - MATCH_MP_TAC FINITE_IMAGE THEN - FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP - (REWRITE_RULE[IMP_CONJ] FINITE_SUBSET)) THEN SET_TAC[]]);; - -let PARACOMPACT_CLOSED = prove - (`!s:real^N->bool c. - closed s /\ (!t:real^N->bool. t IN c ==> open t) /\ s SUBSET UNIONS c - ==> ?c'. s SUBSET UNIONS c' /\ - (!u. u IN c' ==> open u /\ ?t. t IN c /\ u SUBSET t) /\ - (!x. ?v. open v /\ x IN v /\ - FINITE {u | u IN c' /\ ~(u INTER v = {})})`, - REPEAT STRIP_TAC THEN - MP_TAC(ISPECL [`(:real^N)`; `s:real^N->bool`; `c:(real^N->bool)->bool`] - PARACOMPACT_CLOSED_IN) THEN - ASM_REWRITE_TAC[SUBTOPOLOGY_UNIV; GSYM OPEN_IN; GSYM CLOSED_IN; IN_UNIV]);; - -(* ------------------------------------------------------------------------- *) -(* Partitions of unity subordinate to locally finite open coverings. *) -(* ------------------------------------------------------------------------- *) - -let SUBORDINATE_PARTITION_OF_UNITY = prove - (`!c s. s SUBSET UNIONS c /\ (!u. u IN c ==> open u) /\ - (!x. x IN s - ==> ?v. open v /\ x IN v /\ - FINITE {u | u IN c /\ ~(u INTER v = {})}) - ==> ?f:(real^N->bool)->real^N->real. - (!u. u IN c - ==> (lift o f u) continuous_on s /\ - !x. x IN s ==> &0 <= f u x) /\ - (!x u. u IN c /\ x IN s /\ ~(x IN u) ==> f u x = &0) /\ - (!x. x IN s ==> sum c (\u. f u x) = &1) /\ - (!x. x IN s - ==> ?n. open n /\ x IN n /\ - FINITE {u | u IN c /\ - ~(!x. x IN n ==> f u x = &0)})`, - REPEAT STRIP_TAC THEN - ASM_CASES_TAC `?u:real^N->bool. u IN c /\ s SUBSET u` THENL - [FIRST_X_ASSUM(CHOOSE_THEN STRIP_ASSUME_TAC) THEN - EXISTS_TAC `\v:real^N->bool x:real^N. if v = u then &1 else &0` THEN - REWRITE_TAC[COND_RAND; COND_RATOR; o_DEF; REAL_POS; - REAL_OF_NUM_EQ; ARITH_EQ; - MESON[] `(if p then q else T) <=> p ==> q`] THEN - ASM_SIMP_TAC[CONTINUOUS_ON_CONST; COND_ID; SUM_DELTA] THEN - CONJ_TAC THENL [ASM SET_TAC[]; ALL_TAC] THEN - X_GEN_TAC `x:real^N` THEN DISCH_TAC THEN - EXISTS_TAC `ball(x:real^N,&1)` THEN - REWRITE_TAC[OPEN_BALL; CENTRE_IN_BALL; REAL_LT_01] THEN - MATCH_MP_TAC FINITE_SUBSET THEN EXISTS_TAC `{u:real^N->bool}` THEN - REWRITE_TAC[FINITE_SING; SUBSET; IN_ELIM_THM; IN_SING] THEN - X_GEN_TAC `v:real^N->bool` THEN - ASM_CASES_TAC `v:real^N->bool = u` THEN ASM_REWRITE_TAC[]; - ALL_TAC] THEN - EXISTS_TAC `\u:real^N->bool x:real^N. - if x IN s - then setdist({x},s DIFF u) / sum c (\v. setdist({x},s DIFF v)) - else &0` THEN - REWRITE_TAC[SUBSET; FORALL_IN_IMAGE] THEN - SIMP_TAC[SUM_POS_LE; SETDIST_POS_LE; REAL_LE_DIV] THEN - SIMP_TAC[SETDIST_SING_IN_SET; IN_DIFF; real_div; REAL_MUL_LZERO] THEN - REWRITE_TAC[SUM_RMUL] THEN REWRITE_TAC[GSYM real_div] THEN - MATCH_MP_TAC(TAUT `r /\ p /\ q ==> p /\ q /\ r`) THEN CONJ_TAC THENL - [X_GEN_TAC `x:real^N` THEN DISCH_TAC THEN - FIRST_X_ASSUM(MP_TAC o SPEC `x:real^N`) THEN ASM_REWRITE_TAC[] THEN - MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `n:real^N->bool` THEN - REPEAT(DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) THEN - ASM_REWRITE_TAC[] THEN - MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ_ALT] FINITE_SUBSET) THEN - REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN X_GEN_TAC `u:real^N->bool` THEN - ASM_CASES_TAC `(u:real^N->bool) IN c` THEN - ASM_REWRITE_TAC[CONTRAPOS_THM] THEN DISCH_TAC THEN - X_GEN_TAC `y:real^N` THEN DISCH_TAC THEN - REWRITE_TAC[real_div; REAL_ENTIRE] THEN - COND_CASES_TAC THEN ASM_REWRITE_TAC[] THEN - ASM_CASES_TAC `(y:real^N) IN u` THEN - ASM_SIMP_TAC[SETDIST_SING_IN_SET; IN_DIFF; REAL_MUL_LZERO] THEN - ASM SET_TAC[]; - ALL_TAC] THEN - SUBGOAL_THEN - `!v x:real^N. v IN c /\ x IN s /\ x IN v ==> &0 < setdist({x},s DIFF v)` - ASSUME_TAC THENL - [REPEAT STRIP_TAC THEN - SIMP_TAC[SETDIST_POS_LE; REAL_ARITH `&0 < x <=> &0 <= x /\ ~(x = &0)`] THEN - MP_TAC(ISPECL [`s:real^N->bool`; `s DIFF v:real^N->bool`; `x:real^N`] - SETDIST_EQ_0_CLOSED_IN) THEN - ONCE_REWRITE_TAC[SET_RULE `s DIFF t = s INTER (UNIV DIFF t)`] THEN - ASM_SIMP_TAC[CLOSED_IN_CLOSED_INTER; GSYM OPEN_CLOSED] THEN - DISCH_THEN SUBST1_TAC THEN ASM_REWRITE_TAC[] THEN - ASM_REWRITE_TAC[IN_INTER; IN_DIFF; IN_UNION] THEN ASM SET_TAC[]; - ALL_TAC] THEN - SUBGOAL_THEN - `!x:real^N. x IN s ==> &0 < sum c (\v. setdist ({x},s DIFF v))` - ASSUME_TAC THENL - [X_GEN_TAC `x:real^N` THEN DISCH_TAC THEN - ONCE_REWRITE_TAC[GSYM SUM_SUPPORT] THEN - REWRITE_TAC[support; NEUTRAL_REAL_ADD] THEN - MATCH_MP_TAC SUM_POS_LT THEN REWRITE_TAC[SETDIST_POS_LE] THEN - CONJ_TAC THENL - [FIRST_X_ASSUM(MP_TAC o SPEC `x:real^N`) THEN ASM_REWRITE_TAC[] THEN - DISCH_THEN(CHOOSE_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC)) THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN - MATCH_MP_TAC(REWRITE_RULE[IMP_CONJ_ALT] FINITE_SUBSET) THEN - REWRITE_TAC[SUBSET; IN_ELIM_THM] THEN X_GEN_TAC `u:real^N->bool` THEN - ASM_CASES_TAC `(x:real^N) IN u` THEN - ASM_SIMP_TAC[SETDIST_SING_IN_SET; IN_DIFF] THEN ASM SET_TAC[]; - FIRST_X_ASSUM(MP_TAC o GEN_REWRITE_RULE I [SUBSET]) THEN - DISCH_THEN(MP_TAC o SPEC `x:real^N`) THEN REWRITE_TAC[IN_UNIONS] THEN - ASM_REWRITE_TAC[IN_ELIM_THM] THEN MATCH_MP_TAC MONO_EXISTS THEN - ASM_MESON_TAC[REAL_LT_IMP_NZ]]; + [(* Continuity and nonnegativity *) + X_GEN_TAC `u:real^N->bool` THEN DISCH_TAC THEN CONJ_TAC THENL + [MATCH_MP_TAC CONTINUOUS_ON_SUBSET THEN + EXISTS_TAC `UNIONS c:real^N->bool` THEN + ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[]; + ASM_MESON_TAC[SUBSET]]; + (* Support condition *) + REPEAT GEN_TAC THEN STRIP_TAC THEN + RULE_ASSUM_TAC(REWRITE_RULE[SUBSET; IN_ELIM_THM]) THEN + ASM_MESON_TAC[]; + (* Sum equals 1 *) + RULE_ASSUM_TAC(REWRITE_RULE[SUBSET]) THEN ASM_MESON_TAC[]; + (* Local finiteness of supports *) + X_GEN_TAC `x:real^N` THEN DISCH_TAC THEN + SUBGOAL_THEN `(x:real^N) IN UNIONS c` ASSUME_TAC THENL + [ASM SET_TAC[]; ALL_TAC] THEN + FIRST_X_ASSUM(K ALL_TAC o SPEC `x:real^N`) THEN + FIRST_X_ASSUM(MP_TAC o SPEC `x:real^N`) THEN + ASM_REWRITE_TAC[] THEN + MATCH_MP_TAC MONO_EXISTS THEN X_GEN_TAC `N:real^N->bool` THEN + STRIP_TAC THEN ASM_REWRITE_TAC[] THEN + SUBGOAL_THEN `(N:real^N->bool) SUBSET UNIONS c` ASSUME_TAC THENL + [ASM_MESON_TAC[OPEN_IN_IMP_SUBSET; + TOPSPACE_EUCLIDEAN_SUBTOPOLOGY]; ALL_TAC] THEN - ASM_SIMP_TAC[REAL_LT_IMP_NZ; REAL_DIV_REFL; o_DEF] THEN - X_GEN_TAC `u:real^N->bool` THEN DISCH_TAC THEN - MATCH_MP_TAC CONTINUOUS_ON_EQ THEN - EXISTS_TAC `\x:real^N. - lift(setdist({x},s DIFF u) / sum c (\v. setdist({x},s DIFF v)))` THEN - SIMP_TAC[] THEN REWRITE_TAC[real_div; LIFT_CMUL] THEN - MATCH_MP_TAC CONTINUOUS_ON_MUL THEN - SIMP_TAC[CONTINUOUS_ON_LIFT_SETDIST; o_DEF] THEN - MATCH_MP_TAC(REWRITE_RULE[o_DEF] CONTINUOUS_ON_INV) THEN - ASM_SIMP_TAC[REAL_LT_IMP_NZ; CONTINUOUS_ON_EQ_CONTINUOUS_WITHIN] THEN - X_GEN_TAC `x:real^N` THEN DISCH_TAC THEN - FIRST_X_ASSUM(fun th -> - MP_TAC(SPEC `x:real^N` th) THEN ASM_REWRITE_TAC[] THEN - DISCH_THEN(X_CHOOSE_THEN `n:real^N->bool` STRIP_ASSUME_TAC)) THEN - MATCH_MP_TAC CONTINUOUS_TRANSFORM_WITHIN_OPEN_IN THEN - MAP_EVERY EXISTS_TAC - [`\x:real^N. lift(sum {v | v IN c /\ ~(v INTER n = {})} - (\v. setdist({x},s DIFF v)))`; - `s INTER n:real^N->bool`] THEN - ASM_SIMP_TAC[IN_INTER; OPEN_IN_OPEN_INTER] THEN CONJ_TAC THENL - [X_GEN_TAC `y:real^N` THEN DISCH_TAC THEN AP_TERM_TAC THEN - CONV_TAC SYM_CONV THEN MATCH_MP_TAC SUM_EQ_SUPERSET THEN - ASM_REWRITE_TAC[SUBSET_RESTRICT] THEN X_GEN_TAC `v:real^N->bool` THEN - DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN - ASM_REWRITE_TAC[IN_ELIM_THM] THEN DISCH_TAC THEN - MATCH_MP_TAC SETDIST_SING_IN_SET THEN ASM SET_TAC[]; - ASM_SIMP_TAC[LIFT_SUM; o_DEF] THEN MATCH_MP_TAC CONTINUOUS_VSUM THEN - ASM_SIMP_TAC[CONTINUOUS_AT_LIFT_SETDIST; CONTINUOUS_AT_WITHIN]]);; + CONJ_TAC THENL + [FIRST_X_ASSUM(MP_TAC o + GEN_REWRITE_RULE I [OPEN_IN_OPEN]) THEN + DISCH_THEN(X_CHOOSE_THEN `t:real^N->bool` + STRIP_ASSUME_TAC) THEN + ASM_REWRITE_TAC[] THEN MATCH_MP_TAC OPEN_INTER THEN + ASM_SIMP_TAC[OPEN_UNIONS]; + FIRST_X_ASSUM(MATCH_MP_TAC o MATCH_MP + (REWRITE_RULE[IMP_CONJ] FINITE_SUBSET)) THEN + REWRITE_TAC[SUBSET; IN_ELIM_THM; NOT_FORALL_THM; + NOT_IMP; GSYM MEMBER_NOT_EMPTY; IN_INTER] THEN + ASM SET_TAC[]]]);; diff --git a/arith.ml b/arith.ml index c425140e..03af8f56 100644 --- a/arith.ml +++ b/arith.ml @@ -1608,7 +1608,7 @@ let MOD_MULT_MOD = prove ASM_REWRITE_TAC[MULT_CLAUSES; MOD_ZERO; ADD_CLAUSES] THEN ASM_CASES_TAC `p = 0` THENL [ASM_REWRITE_TAC[MULT_CLAUSES; MOD_ZERO] THEN - ASM_MESON_TAC[DIVISION; MULT_SYM]; (* OA: Metis *) + ASM_METIS_TAC[DIVISION; MULT_SYM]; ALL_TAC] THEN MATCH_MP_TAC(MESON[EQ_ADD_LCANCEL] `(?a. a + x = a + y) ==> x = y`) THEN EXISTS_TAC `m DIV n DIV p * n * p` THEN @@ -1711,7 +1711,7 @@ let DIVMOD_ELIM_THM' = prove (* ------------------------------------------------------------------------- *) let MOD_DOWN_CONV = - let MOD_SUC_MOD = MESON[ADD1; MOD_ADD_MOD; MOD_MOD_REFL] (* OA: Metis *) + let MOD_SUC_MOD = METIS[ADD1; MOD_ADD_MOD; MOD_MOD_REFL] `(SUC(m MOD n)) MOD n = SUC m MOD n` in let addmul_conv = GEN_REWRITE_CONV I [GSYM MOD_SUC_MOD; GSYM MOD_ADD_MOD; GSYM MOD_MULT_MOD2; GSYM MOD_EXP_MOD] @@ -1744,8 +1744,8 @@ let NUM_CANCEL_CONV = let AC_RULE = AC ADD_AC in fun tm -> let l,r = dest_eq tm in - let lats = sort Term.(<) (binops `(+)` l) - and rats = sort Term.(<) (binops `(+)` r) in + let lats = sort Term.(<=) (binops `(+)` l) + and rats = sort Term.(<=) (binops `(+)` r) in let i,lats',rats' = minter [] [] [] lats rats in let l' = list_mk_binop add_tm (i @ lats') and r' = list_mk_binop add_tm (i @ rats') in @@ -1874,7 +1874,7 @@ let DEPENDENT_CHOICE = prove (* `BIT1`, `_0` that is not part of a well-formed numeral. *) (* ------------------------------------------------------------------------- *) -let (BITS_ELIM_CONV : conv) = +let BITS_ELIM_CONV : conv = let NUMERAL_pth = prove(`m = n <=> NUMERAL m = n`,REWRITE_TAC[NUMERAL]) and ZERO_pth = GSYM (REWRITE_CONV[NUMERAL] `0`) and BIT0_pth,BIT1_pth = CONJ_PAIR diff --git a/basics.ml b/basics.ml index 0d6444c2..3647636f 100755 --- a/basics.ml +++ b/basics.ml @@ -114,7 +114,7 @@ let subst = try fst (find ((aconv tm) o snd) ilist) with Failure _ -> match tm with Comb(f,x) -> let f' = ssubst ilist f and x' = ssubst ilist x in - if f' == f && x' == x then tm else mk_comb(f',x') + (* if f' == f && x' == x then tm else *) mk_comb(f',x') | Abs(v,bod) -> let ilist' = filter (not o (vfree_in v) o snd) ilist in mk_abs(v,ssubst ilist' bod) @@ -126,7 +126,7 @@ let subst = fun tm -> let gs = variants (variables tm) (map (genvar o type_of) xs) in let tm' = ssubst (zip gs xs) tm in - if tm' == tm then tm else vsubst (zip ts gs) tm';; + (* if tm' == tm then tm else *) vsubst (zip ts gs) tm';; (* ------------------------------------------------------------------------- *) (* Alpha conversion term operation. *) @@ -451,6 +451,7 @@ let follow_path = (* Considering a term as a propositional formula and returning atoms. *) (* ------------------------------------------------------------------------- *) +(* let atoms = let rec atoms acc tm = match tm with @@ -461,6 +462,6 @@ let atoms = atoms (atoms acc l) r | Comb(Const("~",_),l) -> atoms acc l | _ -> (tm |-> ()) acc in - let f = fun x y -> Equal in (* HACK(daniel): Not sure whether this is ok. *) fun tm -> if type_of tm <> bool_ty then failwith "atoms: not Boolean" - else foldl (fun a x y -> x::a) [] (atoms (undefined f) tm);; + else foldl (fun a x y -> x::a) [] (atoms undefined tm);; +*) diff --git a/build-instructions.sh b/build-instructions.sh index b7418cc2..0ca1b038 100755 --- a/build-instructions.sh +++ b/build-instructions.sh @@ -1,7 +1,8 @@ -#!/bin/sh +#!/bin/bash +set -euo pipefail # Get the 64-bit CakeML compiler from here: -curl -OL https://cakeml.org/regression/artefacts/3149/cake-x64-64.tar.gz +#curl -OL https://cakeml.org/regression/artefacts/3149/cake-x64-64.tar.gz tar xvzf cake-x64-64.tar.gz # By default, the CakeML compiler reserves a few kilobytes for constants and @@ -15,6 +16,12 @@ cd cake-x64-64 && make && cd .. # Copy the compiler binary and the exported compiler state into this directory: cp cake-x64-64/cake cake-x64-64/config_enc_str.txt . +# Create the types.txt file necessary for candle_insulate.py +./cake --types < /dev/null + +# Generate candle_insulate.ml +python candle_insulate.py types.txt candle_insulate.ml + # You can now run Candle by writing: # $ ./cake --candle # or: diff --git a/calc_num.ml b/calc_num.ml index 8d07e6b2..b7880e02 100644 --- a/calc_num.ml +++ b/calc_num.ml @@ -274,9 +274,11 @@ let NUM_SUC_CONV,NUM_ADD_CONV,NUM_MULT_CONV,NUM_EXP_CONV, | Comb(Const("BIT0",_),t)|Comb(Const("BIT1",_),t) -> wellformed t | _ -> false in let rec orderrelation mtm ntm = +(* if mtm == ntm then if wellformed mtm then 0 else failwith "orderrelation" else +*) match (mtm,ntm) with Const("_0",_),Const("_0",_) -> 0 | Const("_0",_),_ -> @@ -380,18 +382,18 @@ let NUM_SUC_CONV,NUM_ADD_CONV,NUM_MULT_CONV,NUM_EXP_CONV, (if free_in suc_tm tm1 then 3 else 2) in let add_clauses,add_flags = let l1,l2 = unzip(map (mkclauses false) starts) in - Array.fromList(map STANDARDIZE l1),Array.fromList l2 in + Array.of_list(map STANDARDIZE l1),Array.of_list l2 in let adc_clauses,adc_flags = let l1,l2 = unzip(map (mkclauses true) starts) in - Array.fromList(map STANDARDIZE l1),Array.fromList l2 in + Array.of_list(map STANDARDIZE l1),Array.of_list l2 in let rec NUM_ADD_RULE mtm ntm = let m_lo,m_hi = topsplit mtm and n_lo,n_hi = topsplit ntm in let m_ind = if m_hi = zero_tm then m_lo else m_lo + 16 and n_ind = if n_hi = zero_tm then n_lo else n_lo + 16 in let ind = 32 * m_ind + n_ind in - let th1 = Array.sub add_clauses ind - and fl = Array.sub add_flags ind in + let th1 = Array.get add_clauses ind + and fl = Array.get add_flags ind in match fl with 0 -> INST [m_hi,m_tm] th1 | 1 -> INST [n_hi,n_tm] th1 @@ -409,8 +411,8 @@ let NUM_SUC_CONV,NUM_ADD_CONV,NUM_MULT_CONV,NUM_EXP_CONV, let m_ind = if m_hi = zero_tm then m_lo else m_lo + 16 and n_ind = if n_hi = zero_tm then n_lo else n_lo + 16 in let ind = 32 * m_ind + n_ind in - let th1 = Array.sub adc_clauses ind - and fl = Array.sub adc_flags ind in + let th1 = Array.get adc_clauses ind + and fl = Array.get adc_flags ind in match fl with 0 -> INST [m_hi,m_tm] th1 | 1 -> INST [n_hi,n_tm] th1 @@ -449,7 +451,7 @@ let NUM_SUC_CONV,NUM_ADD_CONV,NUM_MULT_CONV,NUM_EXP_CONV, CONV_TAC(BINOP_CONV SYM_CONV) THEN SUBST1_TAC(SYM(SPEC `_0` NUMERAL)) THEN REWRITE_TAC[ADD_EQ_0; MULT_EQ_0; BIT0]) - and pths_1 = (Array.fromList o CONJUNCTS o STANDARDIZE o prove) + and pths_1 = (Array.of_list o CONJUNCTS o STANDARDIZE o prove) (`(n = a + p * b <=> BIT0(BIT0(BIT0(BIT0 n))) = BIT0(BIT0(BIT0(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ @@ -506,7 +508,7 @@ let NUM_SUC_CONV,NUM_ADD_CONV,NUM_MULT_CONV,NUM_EXP_CONV, FIRST_X_ASSUM(SUBST1_TAC o SYM) THEN REWRITE_TAC[ADD_CLAUSES; SUC_INJ; EQ_MULT_LCANCEL; ARITH_EQ; GSYM LEFT_ADD_DISTRIB; GSYM MULT_ASSOC]) - and pths_0 = (Array.fromList o CONJUNCTS o STANDARDIZE o prove) + and pths_0 = (Array.of_list o CONJUNCTS o STANDARDIZE o prove) (`(n = _0 + p * b <=> BIT0(BIT0(BIT0(BIT0 n))) = _0 + BIT0(BIT0(BIT0(BIT0 p))) * b) /\ @@ -572,11 +574,11 @@ let NUM_SUC_CONV,NUM_ADD_CONV,NUM_MULT_CONV,NUM_EXP_CONV, let th1 = NUM_SHIFT_CONV (k - 4) ntm in (match concl th1 with Comb(_,Comb(Comb(_,Const("_0",_)),Comb(Comb(_,ptm),btm))) -> - let th2 = Array.sub pths_0 i in + let th2 = Array.get pths_0 i in let th3 = INST [ntm,n_tm; btm,b_tm; ptm,p_tm] th2 in EQ_MP th3 th1 | Comb(_,Comb(Comb(_,atm),Comb(Comb(_,ptm),btm))) -> - let th2 = Array.sub pths_1 i in + let th2 = Array.get pths_1 i in let th3 = INST[ntm,n_tm; atm,a_tm; btm,b_tm; ptm,p_tm] th2 in EQ_MP th3 th1) | Comb(Const("BIT0",_),ntm) -> @@ -625,7 +627,7 @@ let NUM_SUC_CONV,NUM_ADD_CONV,NUM_MULT_CONV,NUM_EXP_CONV, SUBST1_TAC(SYM(SPEC `_0` NUMERAL)) THEN REWRITE_TAC[BIT1; BIT0] THEN REWRITE_TAC[ADD_CLAUSES] THEN REWRITE_TAC[RIGHT_ADD_DISTRIB]) - and puths_1 = (Array.fromList o CONJUNCTS o STANDARDIZE o prove) + and puths_1 = (Array.of_list o CONJUNCTS o STANDARDIZE o prove) (`(a + p * b = n <=> BIT0(BIT0(BIT0(BIT0 a))) + BIT0(BIT0(BIT0(BIT0 p))) * b = BIT0(BIT0(BIT0(BIT0 n)))) /\ @@ -683,9 +685,9 @@ let NUM_SUC_CONV,NUM_ADD_CONV,NUM_MULT_CONV,NUM_EXP_CONV, FIRST_X_ASSUM(SUBST1_TAC o SYM) THEN REWRITE_TAC[ADD_CLAUSES; SUC_INJ; EQ_MULT_LCANCEL; ARITH_EQ; GSYM LEFT_ADD_DISTRIB; GSYM MULT_ASSOC]) in - let puths_2 = Array.fromList - (map (fun i -> let th1 = Array.sub puths_1 (i mod 16) - and th2 = Array.sub puths_1 (i / 16) in + let puths_2 = Array.of_list + (map (fun i -> let th1 = Array.get puths_1 (i mod 16) + and th2 = Array.get puths_1 (i / 16) in let th3 = GEN_REWRITE_RULE RAND_CONV [th1] th2 in STANDARDIZE th3) (0--255)) in let rec NUM_UNSHIFT_CONV tm = @@ -710,7 +712,7 @@ let NUM_SUC_CONV,NUM_ADD_CONV,NUM_MULT_CONV,NUM_EXP_CONV, let th1 = NUM_UNSHIFT_CONV tm' in let th2 = INST [atm'',a_tm; ptm'',p_tm; btm,b_tm; rand(concl th1),n_tm] - (Array.sub puths_2 (16 * j + i)) in + (Array.get puths_2 (16 * j + i)) in EQ_MP th2 th1 | _ -> let tm' = mk_comb(mk_comb(add_tm,atm'), @@ -718,7 +720,7 @@ let NUM_SUC_CONV,NUM_ADD_CONV,NUM_MULT_CONV,NUM_EXP_CONV, let th1 = NUM_UNSHIFT_CONV tm' in let th2 = INST [atm',a_tm; ptm',p_tm; btm,b_tm; rand(concl th1),n_tm] - (Array.sub puths_1 i) in + (Array.get puths_1 i) in EQ_MP th2 th1) | (Const("_0",_),Comb(Const("BIT0",_),qtm),_) -> let th1 = INST [btm,b_tm; qtm,p_tm] pth_z in @@ -1127,7 +1129,7 @@ let NUM_SUC_CONV,NUM_ADD_CONV,NUM_MULT_CONV,NUM_EXP_CONV, fun tm -> match tm with Comb(Comb(Const("*",_),mtm),ntm) -> - if mtm = ntm then + if Term.compare mtm ntm = 0 then let th1 = NUM_SQUARE_RULE mtm in let ptm = rand(concl th1) in EQ_MP (INST [mtm,m_tm;ptm,p_tm] pth_refl) th1 @@ -1169,7 +1171,7 @@ let NUM_SUC_CONV,NUM_ADD_CONV,NUM_MULT_CONV,NUM_EXP_CONV, match tm with Comb(Comb(Const("*",_),Comb(Const("NUMERAL",_),mtm)), Comb(Const("NUMERAL",_),ntm)) -> - if mtm = ntm then + if Term.compare mtm ntm = 0 then let th1 = NUM_SQUARE_RULE mtm in let ptm = rand(concl th1) in EQ_MP (INST [mtm,m_tm;ptm,p_tm] pth_refl) th1 @@ -1522,3 +1524,39 @@ let EXPAND_CASES_CONV = let rec conv tm = (base_CONV ORELSEC (step_CONV THENC LAND_CONV conv)) tm in conv THENC (REWRITE_CONV[GSYM CONJ_ASSOC]);; + +(* ------------------------------------------------------------------------- *) +(* Computation of (a EXP k) MOD n keeping intermediates reduced *) +(* ------------------------------------------------------------------------- *) + +let EXP_MOD_CONV = + let [pth_0; pth_even; pth_odd] = (CONJUNCTS o prove) + (`(a EXP 0) MOD n = 1 MOD n /\ + (a EXP (NUMERAL(BIT0 k))) MOD n = + ((a EXP (NUMERAL k) MOD n) EXP 2) MOD n /\ + (a EXP (NUMERAL(BIT1 k))) MOD n = + (a * ((a EXP (NUMERAL k) MOD n) EXP 2) MOD n) MOD n`, + REWRITE_TAC[EXP; EXP_2] THEN REWRITE_TAC[BIT0; BIT1; NUMERAL] THEN + REWRITE_TAC[EXP; EXP_ADD] THEN CONV_TAC MOD_DOWN_CONV THEN + REWRITE_TAC[]) in + let conv_zero = GEN_REWRITE_CONV I [MOD_ZERO] + and conv_0 = GEN_REWRITE_CONV I [pth_0] + and conv_even = GEN_REWRITE_CONV I [pth_even] + and conv_odd = GEN_REWRITE_CONV I [pth_odd] in + let rec conv tm = + ((conv_0 THENC NUM_MOD_CONV) ORELSEC + (conv_even THENC + LAND_CONV(LAND_CONV conv THENC NUM_EXP_CONV) THENC + NUM_MOD_CONV) ORELSEC + (conv_odd THENC + LAND_CONV(RAND_CONV(LAND_CONV(LAND_CONV conv THENC NUM_EXP_CONV) THENC + NUM_MOD_CONV) THENC + NUM_MULT_CONV) THENC + NUM_MOD_CONV)) tm in + let fullconv = (conv_zero THENC NUM_EXP_CONV) ORELSEC conv in + fun tm -> + match tm with + Comb(Comb(Const("MOD",_), + Comb(Comb(Const("EXP",_),m),k)),n) + when is_numeral m && is_numeral k && is_numeral n -> fullconv tm + | _ -> failwith "EXP_MOD_CONV";; diff --git a/candle-regression.py b/candle-regression.py new file mode 100644 index 00000000..8a7a3ea7 --- /dev/null +++ b/candle-regression.py @@ -0,0 +1,445 @@ +import sys +import pexpect +import time +import subprocess +import os +import argparse +from dataclasses import dataclass +from enum import Enum + +# --------------------------------------------------------------------------- +# Exceptions +# --------------------------------------------------------------------------- + +class StartFailure(Exception): + """Starting Candle failed (pre-boot).""" + + +class BootFailure(Exception): + """Booting Candle failed (pre-boot).""" + + +class LoadFailure(Exception): + """Loading a file failed.""" + + + +# --------------------------------------------------------------------------- +# Test status and result +# --------------------------------------------------------------------------- + +class TestStatus(Enum): + PASS = "PASS" + FAIL = "FAIL" + TIMEOUT = "TIMEOUT" + +@dataclass +class TestResult: + name: str + status: TestStatus + elapsed: float = 0.0 + error_message: str = "" + + +TESTS = [ + "100/arithmetic", + "100/cantor", + "100/konigsberg", + "100/gcd", + "100/wilson", + "100/combinations", + "100/ratcountable", + "100/euler", + "100/lhopital", + "100/stirling", + "100/liouville", +] + + +# --------------------------------------------------------------------------- +# CandleREPL +# --------------------------------------------------------------------------- + +class CandleREPL: + def __init__(self, base, restore=False): + # Easier to assume that we are in the candle directory for now. + os.chdir(base) + + # Indicates whether we are a restored instance. In that case, I suspect + # that the pid of self.process might be of sudo criu restore instead of + # Candle. + self._cake_pid = None + + self._logfile = sys.stdout + self._base = base + self._checkpoint_dir = "checkpoint" + self._pidfile_name = "cake.pid" + + self.load_stack = [] + self.last_val = None + + if restore: + self.restore() + else: + try: + self.process = pexpect.spawn("./candle", encoding='utf-8', logfile=self._logfile) + except Exception as e: + raise StartFailure from e + try: + self._check_boot() + except BootFailure: + self.kill() + raise + + def _pidfile(self): + return os.path.join(self._checkpoint_dir, self._pidfile_name) + + def _check_boot(self): + try: + index = self.process.expect([ + r'\n# ', + r'\n(ERROR: .+)', + pexpect.TIMEOUT, + pexpect.EOF, + ]) + except Exception as e: + raise BootFailure from e + + if index != 0: + reasons = { + 1: str(self._get_match(1)), + 2: "Timeout", + 3: "Process exited unexpectedly" + } + raise BootFailure(reasons[index]) + + def _get_match(self, idx): + return self.process.match.group(idx) + + def load_stack_str(self): + f"[while loading: {' > '.join(self.load_stack)}]" + + def _check_output(self, timeout=600): + try: + index = self.process.expect([ + r'\n\- Loading (\S+)', + r'\nval (\w+) =', + r'\n(ERROR: .+)', + r'\n(Parsing failed)', + r'\n(EXCEPTION: .+)', + r'\n\- Finished loading (\S+)', + pexpect.TIMEOUT, + pexpect.EOF, + ], timeout=timeout) + except Exception as e: + raise LoadFailure from e + + match index: + case 0: + dependency = self._get_match(1) + self.load_stack.append(dependency) + case 1: + self.last_val = self._get_match(1) + case 2 | 3 | 4: + raise LoadFailure(f"{self._get_match(1)} {self.load_stack_str()}") + case 5: + finished = self._get_match(1) + expected = self.load_stack.pop() + assert finished == expected, f'Expected to finish loading {expected}. Actual: {finished}' + case 6: + raise LoadFailure(f"Timeout waiting for output {self.load_stack_str()}") + case 7: + raise LoadFailure(f"Process exited unexpectedly {self.load_stack_str()}") + case _: + assert False, "Unreachable: Did you add a new case in _check_output?" + + def load(self, file, timeout=600): + self.process.sendline(f'#use "{file}";;') + self._check_output(timeout=timeout) + + while self.load_stack: + self._check_output(timeout=timeout) + + def kill(self): + self.process.close(force=True) + + # We need to make sure that the Candle process is killed and reaped, + # as criu tries to restore into the same pid (I think), + # which will fail if the pid is occupied. + # My understanding is that after restoring at least Candle is a process + # group that is not the child of this process. The former motivates the + # g (group), and the latter is why we have the loop with killpg. + if self._cake_pid: + subprocess.run(["pkill", "-9", "-g", str(self._cake_pid)]) + while True: + try: + os.killpg(self._cake_pid, 0) + except ProcessLookupError: + return + time.sleep(0.1) + + def dump(self): + os.makedirs(self._checkpoint_dir, exist_ok=True) + + # We are not in the situation where Candle has been restored, so the + # pid of process is correct. We also save it for future restoring. + if not self._cake_pid: + pid = self.process.pid + with open(self._pidfile(), "w") as f: + f.write(str(pid)) + else: + pid = self._cake_pid + + subprocess.run( + ["sudo", "criu", "dump", "-D", self._checkpoint_dir, "-t", str(pid), "--shell-job"], + check=True, + ) + + # If I remember correctly, this is for making sure the dumped process + # gets reaped. I think. + self.process.wait() + + def restore(self): + self.process = pexpect.spawn( + "sudo", ["criu", "restore", "-D", self._checkpoint_dir, "--shell-job"], + encoding='utf-8', + logfile=self._logfile, + ) + # Assumption: CRIU restores processes with their original PIDs. + # Read the cake PID (saved during dump) so kill() can target it. + self._cake_pid = int(open(self._pidfile()).read().strip()) + + +# --------------------------------------------------------------------------- +# Reporter +# --------------------------------------------------------------------------- + +class Reporter: + STATUS_SYMBOLS = { + TestStatus.PASS: "PASS", + TestStatus.FAIL: "FAIL", + TestStatus.TIMEOUT: "TIME", + } + + @staticmethod + def print_summary(results): + # Header + print() + print(f"{'Test':<40} {'Status':>6} {'Time':>8}") + print("-" * 58) + + for r in results: + elapsed_str = f"{r.elapsed:.1f}s" + sym = Reporter.STATUS_SYMBOLS[r.status] + print(f"{r.name:<40} {sym:>6} {elapsed_str:>8}") + + # Footer + counts = {} + for s in TestStatus: + c = sum(1 for r in results if r.status == s) + if c: + counts[s] = c + + print("-" * 58) + parts = [f"{s.value}: {c}" for s, c in counts.items()] + print(f"Total: {len(results)} | " + " ".join(parts)) + + # Highlight problems + failures = [r for r in results if r.status in (TestStatus.FAIL, TestStatus.TIMEOUT)] + + if failures: + print() + print("FAILURES:") + for r in failures: + msg = f" {r.name}: {r.status.value}" + if r.error_message: + msg += f" — {r.error_message}" + print(msg) + + +# --------------------------------------------------------------------------- +# TestRunner +# --------------------------------------------------------------------------- + +class TestRunner: + def __init__(self, base_dir, timeout=600, fail_fast=False): + self.base_dir = base_dir + self.timeout = timeout + self.fail_fast = fail_fast + + def setup(self, reuse_checkpoint=False): + """Start candle, load hol.ml, and dump a checkpoint.""" + checkpoint_path = os.path.join(self.base_dir, "checkpoint") + if reuse_checkpoint and os.path.isdir(checkpoint_path): + print("Reusing existing checkpoint.") + return + + print("Starting candle and loading hol.ml...") + repl = CandleREPL(self.base_dir) + try: + repl.load("hol.ml", timeout=3600) + print("hol.ml loaded. Dumping checkpoint...") + repl.dump() + print("Checkpoint created.") + except Exception: + repl.kill() + raise + + def run_test(self, name): + """Restore from checkpoint, run a single test, return TestResult.""" + start = time.perf_counter() + + try: + repl = CandleREPL(self.base_dir, restore=True) + except Exception as e: + elapsed = time.perf_counter() - start + return TestResult( + name=name, status=TestStatus.FAIL, + elapsed=elapsed, error_message=f"Restore failed: {e}", + ) + + try: + repl.load(f"{name}.ml", timeout=self.timeout) + elapsed = time.perf_counter() - start + + return TestResult(name=name, status=TestStatus.PASS, elapsed=elapsed) + + except LoadFailure as e: + elapsed = time.perf_counter() - start + err = str(e) + if repl.load_stack: + err += f" {repl.load_stack_str()}" + if repl.last_val: + err += f" (last val: {repl.last_val})" + if "Timeout" in str(e): + status = TestStatus.TIMEOUT + + else: + status = TestStatus.FAIL + return TestResult(name=name, status=status, elapsed=elapsed, error_message=err) + + except pexpect.TIMEOUT: + elapsed = time.perf_counter() - start + err = "Timeout" + if repl.load_stack: + err += f" {repl.load_stack_str()}" + if repl.last_val: + err += f" (last val: {repl.last_val})" + else: + status = TestStatus.TIMEOUT + return TestResult( + name=name, status=status, + elapsed=elapsed, error_message=err, + ) + + except Exception as e: + elapsed = time.perf_counter() - start + err = str(e) + if repl.load_stack: + err += f" {repl.load_stack_str()}" + if repl.last_val: + err += f" (last val: {repl.last_val})" + else: + status = TestStatus.FAIL + return TestResult( + name=name, status=status, + elapsed=elapsed, error_message=err, + ) + + finally: + repl.kill() + + + def run_all(self, tests): + """Run all tests, printing progress inline.""" + results = [] + total = len(tests) + + try: + for i, name in enumerate(tests, 1): + print(f"[{i}/{total}] {name} ... ", end="", flush=True) + result = self.run_test(name) + sym = Reporter.STATUS_SYMBOLS[result.status] + print(f"{sym} ({result.elapsed:.1f}s)") + if result.error_message and result.status in (TestStatus.FAIL, TestStatus.TIMEOUT): + print(f" {result.error_message}") + results.append(result) + if self.fail_fast and result.status in (TestStatus.FAIL, TestStatus.TIMEOUT): + print("Stopping early due to --fail-fast.") + break + except KeyboardInterrupt: + print("\nInterrupted — showing results so far.") + + return results + + +# --------------------------------------------------------------------------- +# CLI +# --------------------------------------------------------------------------- + +def main(): + parser = argparse.ArgumentParser( + description="Candle regression test suite", + ) + parser.add_argument( + "--reuse-checkpoint", action="store_true", + help="Skip hol.ml loading if a checkpoint already exists", + ) + parser.add_argument( + "--test", nargs="+", + help="Run specific test(s) by name", + ) + parser.add_argument( + "--list", action="store_true", + help="List available tests and exit", + ) + parser.add_argument( + "--fail-fast", action="store_true", + help="Stop after the first unexpected failure", + ) + parser.add_argument( + "--timeout", type=int, default=600, + help="Per-test timeout in seconds (default: 600)", + ) + parser.add_argument( + "--base-dir", default=os.path.dirname(os.path.abspath(__file__)), + help="Candle base directory (default: script directory)", + ) + + args = parser.parse_args() + + available = TESTS + if args.list: + for name in available: + print(f" {name}") + print(f"\n{len(available)} tests") + return + + # Determine which tests to run + if args.test: + tests = args.test + else: + tests = list(TESTS) + + runner = TestRunner( + base_dir=args.base_dir, + timeout=args.timeout, + fail_fast=args.fail_fast, + ) + + # Setup checkpoint + runner.setup(reuse_checkpoint=args.reuse_checkpoint) + + # Run tests + results = runner.run_all(tests) + + # Report + Reporter.print_summary(results) + + # Exit code: 0 if no unexpected failures + unexpected = [r for r in results if r.status in (TestStatus.FAIL, TestStatus.TIMEOUT)] + sys.exit(1 if unexpected else 0) + + +if __name__ == "__main__": + main() diff --git a/candle_boot.ml b/candle_boot.ml deleted file mode 100644 index ac96b84d..00000000 --- a/candle_boot.ml +++ /dev/null @@ -1,713 +0,0 @@ -(* ------------------------------------------------------------------------- * - * Prelude - * ------------------------------------------------------------------------- *) - -(* This is pointer equality, which is missing from CakeML. - || x = y is just to get the type variables right: - *) -let (==) x y = false || x = y;; - -let ref x = Ref x;; - -let (/) = div;; -let (-.) = Double.(-);; -let (+.) = Double.(+);; -let ( *.) = Double.( * );; -let (/.) = Double.(/);; - -let failwith msg = raise (Failure msg);; - -(* This is the pretty printer for exceptions, and you need to update it - each time you add an exception definition if you want it to print something - informative (see e.g. exception Unchanged in lib.ml). - *) - -let pp_exn e = - match e with - | Chr -> Pretty_printer.token "Chr" - | Div -> Pretty_printer.token "Div" - | Bind -> Pretty_printer.token "Bind" - | Subscript -> Pretty_printer.token "Subscript" - | Interrupt -> Pretty_printer.token "Interrupt" - | Failure s -> Pretty_printer.app_block "Failure" [Pretty_printer.pp_string s] - | _ -> Pretty_printer.token "";; - -(*CML -(* OCaml parser doesn't like the tilde *) -val rat_minus = Rat.~; -*) - -(* Some conversions in OCaml style: *) - -let string_of_int n = - if n < 0 then "-" ^ Int.toString (-n) - else Int.toString n -;; - -let pp_int n = Pretty_printer.token (string_of_int n);; - -let pp_rat r = - let n = Rat.numerator r in - let d = Rat.denominator r in - Pretty_printer.token (string_of_int n ^ "/" ^ string_of_int d) -;; - -let string_of_float = Double.toString;; - -let int_of_string = Option.valOf o Int.fromString;; - -(* Left shifting integers. HOL Light expects these to not be bigints, so I - suppose we can just map in and out of word64. *) -let (lsl) x y = - Word64.toInt (Word64.(<<) (Word64.fromInt x) y);; -let (lsr) x y = - Word64.toInt (Word64.(>>) (Word64.fromInt x) y);; - -let (land) x y = - Word64.toInt (Word64.andb (Word64.fromInt x) (Word64.fromInt y));; - -(* TODO Need a better string escaping thing. *) -let string_escaped = - let rec escape cs = - match cs with - | [] -> [] - | '\\'::l -> '\\'::'\\'::escape l - | '\b'::l -> '\\'::'b'::escape l - | '\t'::l -> '\\'::'t'::escape l - | '\n'::l -> '\\'::'n'::escape l - | '"'::l -> '\\'::'"'::escape l - | c::l -> c::escape l in - fun s -> String.implode (escape (String.explode s));; - -(* Add printers for things we deal with differently, e.g. bool, app_list, etc *) - -let pp_bool b = Pretty_printer.token (if b then "true" else "false");; - -let pp_char c = - Pretty_printer.token ("'" ^ string_escaped (String.str c) ^ "'");; - -let rec pp_app_list f xs = - match xs with - | Nil -> Pretty_printer.token "Nil" - | List xs -> - Pretty_printer.app_block "List" [Pretty_printer.pp_list f xs] - | Append (l, r) -> - Pretty_printer.app_block "Append" [ - Pretty_printer.tuple [pp_app_list f l; pp_app_list f r]] -;; - -let abs x = if x < 0 then -x else x;; - -let ignore x = x; ();; - -let rec rev_append xs acc = - match xs with - | [] -> acc - | x::xs -> rev_append xs (x::acc);; - -let concat_map f = - let rec concat acc xs = - match acc with - | [] -> map xs - | a::acc -> a::concat acc xs - and map xs = - match xs with - | [] -> [] - | x::xs -> concat (f x) xs in - map;; - -(* ------------------------------------------------------------------------- * - * Helpful banner - * ------------------------------------------------------------------------- *) - -let _ = List.app print [ - "\n"; - "---------------------------------------\n"; - " Candle \n"; - "---------------------------------------\n"; - "\n"; - "\n"; - ];; - -(* ------------------------------------------------------------------------- * - * Operations on filenames - * ------------------------------------------------------------------------- *) - -module Filename = struct - let currentDir = ".";; - let parentDir = "..";; - let dirSep = "/";; - let isRelative fname = - try String.sub fname 0 <> '/' - with Subscript -> true;; - let concat dname fname = - if dname = currentDir then fname - else String.concat [dname; dirSep; fname];; - let (basename, dirname) = - let trimSep s = (* trim trailing separators *) - let len = String.size s in - let dsl = String.size dirSep in - let rec search i = - if i < dsl then s - else if String.substring s i dsl = dirSep then - search (i - dsl) - else - String.substring s 0 i in - search (len - 1) in - let splitPath s = - let len = String.size s in - let dsl = String.size dirSep in - let s = trimSep s in - let rec search i = - if i <= dsl then - (currentDir, s) - else if String.substring s i dsl = dirSep then - (String.substring s 0 (i - 1), - String.extract s (i + dsl) None) - else - search (i - dsl) in - search (len - 1) in - ((fun s -> let (_, b) = splitPath s in b), - (fun s -> let (d, _) = splitPath s in d)) -end;; (* struct *) - -(* ------------------------------------------------------------------------- * - * Double-ended functional queue - * ------------------------------------------------------------------------- *) - -module Queue = struct - type 'a queue = 'a list * 'a list;; - let push_back (xs, ys) y = (xs, y::ys);; - let push_front (xs, ys) x = (x::xs, ys);; - let rec dequeue (xs, ys) = - match xs with - | x::xs -> Some (x, (xs, ys)) - | [] -> - match ys with - | [] -> None - | _ -> dequeue (List.rev ys, []);; - let empty = ([], []);; - let flush (xs, ys) = xs @ List.rev ys;; -end;; (* struct *) - -(* ------------------------------------------------------------------------- * - * Imperative wrapper around Queue - * ------------------------------------------------------------------------- *) - -module Buffer = struct - type 'a buffer = 'a Queue.queue ref;; - let push_back q x = q := Queue.push_back (!q) x;; - let push_front q x = q := Queue.push_front (!q) x;; - let dequeue q = - match Queue.dequeue (!q) with - | None -> None - | Some (x, q') -> - q := q'; - Some x;; - let empty () = ref Queue.empty;; - let flush q = - let els = Queue.flush (!q) in - q := Queue.empty; - els -end;; (* struct *) - -(* ------------------------------------------------------------------------- * - * Operations on strings - * ------------------------------------------------------------------------- *) - -let trimLeft str = - let rec nom n = - if n >= String.size str then str - else if Char.isSpace (String.sub str n) then nom (n + 1) - else String.extract str n None in - nom 0 - ;; - -let trimRight str = - let rec nom n = - if n < 1 then str - else if Char.isSpace (String.sub str n) then nom (n - 1) - else String.substring str 0 (n + 1) in - nom (String.size str - 1) -;; - -(* ------------------------------------------------------------------------- * - * Operations on files - * ------------------------------------------------------------------------- *) - -let isFile fname = - try let ins = Text_io.openIn fname in - Text_io.closeIn ins; - true - with Text_io.Bad_file_name -> false -;; - -(* ------------------------------------------------------------------------- * - * Lexer for enough parts of the language to keep track on whether semi-colons - * appear on the top-level or not. - * ------------------------------------------------------------------------- *) - -module Lexer = struct - -type directive = - | D_load - | D_need - | D_use -;; - -let string_of_directive d = - match d with - | D_load -> "load" - | D_need -> "need" - | D_use -> "use" -;; - -type token = - | T_begin | T_end | T_struct | T_sig | T_semis | T_newline - | T_use | T_needs | T_loads (* converted into directives *) - | T_other of string - | T_symb of string - | T_comment of string - | T_string of string - | T_quote of string - | T_char of string - | T_number of string - | T_spaces of string - | T_done (* pseudo-token at switch from loading to user input *) -;; - -let string_of_token unquote tok = - match tok with - | T_begin -> "begin" - | T_end -> "end" - | T_struct -> "struct" - | T_sig -> "sig" - | T_semis -> ";;" - | T_newline -> "\n" - | T_string s -> "\"" ^ s ^ "\"" - | T_quote s -> - begin - match unquote with - | None -> "`" ^ s ^ "`" - | Some f -> "(" ^ f s ^ ")" - end - | T_char s -> "'" ^ s ^ "'" - | T_comment s | T_other s | T_symb s | T_number s | T_spaces s -> s - | T_use -> "#use" - | T_loads -> "loads" - | T_needs -> "needs" - | T_done -> "(* shouldn't happen *)" -;; - -let directive_of_token t = - match t with - | T_needs -> Some D_need - | T_loads -> Some D_load - | T_use -> Some D_use - | _ -> None -;; - -let scan nextChar peekChar = - let quoteSym c = c = '`' in - let tok_from_keyword = - let keywords = [ - "begin", T_begin; - "end", T_end; - "struct", T_struct; - "sig", T_sig; - (* top-level directives *) - "#use", T_use; - "needs", T_needs; - "loads", T_loads; - ] in - fun s -> match Alist.lookup keywords s with - | None -> T_other s - | Some tok -> tok in - let is_symbol = - let symchars = String.explode "#$&*+-/=>@^|~!?%<:.()[]{}," in - fun c -> List.exists (fun x -> x = c) symchars in - let is_alpha c = - Char.(<=) 'a' c && Char.(<=) c 'z' || - Char.(<=) 'A' c && Char.(<=) c 'Z' in - let is_digit c = - Char.(<=) '0' c && Char.(<=) c '9' in - let is_name_char c = - is_alpha c || is_digit c || c = '_' || c = '\'' in - let is_int_char c = - is_digit c || c = '_' || c = 'l' || c = 'L' || c = 'n' in - let scan_while acc pred = - let rec nom acc = - Interrupt.check (); - match peekChar () with - | None -> None - | Some c when pred c -> - nextChar (); - nom (c::acc) - | _ -> Some (String.implode (List.rev acc)) in - nom acc in - let scan_comment () = - let rec nom acc level = - Interrupt.check (); - if level = 0 then - Some (String.implode ('('::'*'::List.rev acc)) - else - match nextChar () with - | Some '(' -> - begin - match peekChar () with - | Some '*' -> - nextChar (); - nom ('*'::'('::acc) (level + 1) - | _ -> nom ('('::acc) level - end - | Some '*' -> - begin - match peekChar () with - | Some ')' -> - nextChar (); - nom (')'::'*'::acc) (level - 1) - | _ -> nom ('*'::acc) level - end - | Some c -> nom (c::acc) level - | None -> None in - nom [] 1 in - let scan_name c = - match scan_while [c] is_name_char with - | None -> None - | Some s -> Some (tok_from_keyword s) in - let scan_symb c = - Option.map (fun s -> T_symb s) - (scan_while [c] is_symbol) in - let scan_int c = - Option.map (fun s -> T_number s) - (scan_while [c] is_int_char) in - let scan_quote () = - match scan_while [] (not o quoteSym) with - | None -> None - | Some str -> - nextChar (); - Some (T_quote str) in - let skip_line () = - scan_while [] (fun x -> x <> '\n'); - nextChar () in - let scan_spaces c = - Option.map (fun s -> T_spaces s) - (scan_while [c] (fun c -> c <> '\n' && Char.isSpace c)) in - let scan_escaped ch = - let rec nom acc = - Interrupt.check (); - match nextChar () with - | None -> None - | Some '\\' -> - begin - match nextChar () with - | None -> nom ('\\'::acc) - | Some c -> nom (c::'\\'::acc) - end - | Some c when c = ch -> Some (String.implode (List.rev acc)) - | Some c -> nom (c::acc) in - nom [] in - let scan_strlit () = - Option.map (fun s -> T_string s) - (scan_escaped '"') in - (* This code will intentionally let through some bad tokens (it doesn't check - whether escape sequences are well formed), but those will get stuck in the - real lexer. *) - let scan_charlit_or_tyvar () = - match peekChar () with - (* Escaped character literal *) - | Some '\\' -> - begin - nextChar (); - Option.map (fun s -> T_char ("\\" ^ s)) - (scan_escaped '\'') - end - (* A single tick, start of a type variable, but followed by space *) - | Some ' ' | Some '\n' | Some '\t' | Some '\r' -> Some (T_other "'") - (* Regular character literal, or a type variable *) - | Some c -> - begin - nextChar (); - match peekChar () with - (* Regular character literal *) - | Some '\'' -> - begin - nextChar (); - Some (T_char (String.str c)) - end - (* Type variable *) - | Some _ -> Option.map (fun s -> T_other s) - (scan_while [c; '\''] is_name_char) - | None -> Some (T_other (String.implode ['\''; c])) - end - (* Two ticks following each other: '' *) - | Some '\'' -> Some (T_symb "''") - | None -> Some (T_symb "'") in - let rec nextToken () = - match nextChar () with - | None -> None - (* Attempt to scan semis *) - | Some ';' -> - begin - match peekChar () with - | Some ';' -> - nextChar (); - Some T_semis - | _ -> scan_symb ';' - end - (* Attempt to scan comment *) - | Some '(' -> - begin - match peekChar () with - | Some '*' -> - nextChar (); - begin - match scan_comment () with - | None -> Some (T_symb "(*") - | Some str -> Some (T_comment str) - end - | _ -> Some (T_symb "(") - end - (* Attempt to scan char literal or type variable *) - | Some '\'' -> scan_charlit_or_tyvar () - (* Attempt to scan string literal *) - | Some '"' -> scan_strlit () - (* A #use directive, maybe: *) - | Some '#' -> scan_name '#' - (* Newlines *) - | Some '\n' -> Some T_newline - (* Anything else *) - | Some c -> - if quoteSym c then - scan_quote () - else if is_digit c then - scan_int c - else if is_symbol c then - scan_symb c - else if is_alpha c || c = '_' then - scan_name c - else if Char.isSpace c then - scan_spaces c - else - Some (T_other (String.str c)) in - fun () -> Interrupt.check (); nextToken () -;; - -end;; (* struct *) - -(* ------------------------------------------------------------------------- * - * CakeML struct: setting up REPL, reading/loading. - * ------------------------------------------------------------------------- *) - -module Cakeml = struct - -let loadPath = ref [Filename.currentDir];; -let stdIn = Text_io.openStdIn ();; -let (input1 : (unit -> char option) ref) = - ref (fun () -> Text_io.input1 stdIn);; - -let prompt1 = ref "# ";; -let prompt2 = ref " ";; -let userInput = ref true;; - -let unquote = ref (fun (s: string) -> s);; - -exception Repl_error;; - -let () = - let prompt = ref (!prompt2) in - let peekChar, nextChar = - let lookahead = ref (None: char option) in - let peek () = - match !lookahead with - | Some c -> Some c - | None -> - match (!input1) () with - | None -> None - | Some c -> - lookahead := Some c; - Some c in - let next () = - match !lookahead with - | None -> (!input1) () - | Some c -> - lookahead := None; - Some c in - peek, next in - (* Load files from disk and keep track on what has been loaded. - *) - let load = - let loadedFiles = (ref [] : string list ref) in - let loadMsg s = print ("- Loading " ^ s ^ "\n") in - let load_use fname = - loadMsg fname; - Text_io.inputLinesFile '\n' fname in - let load fname = - loadMsg fname; - match Text_io.inputLinesFile '\n' fname with - | None -> None - | Some lns -> - begin - if not (List.exists (fun x -> x = fname) (!loadedFiles)) then - loadedFiles := fname :: !loadedFiles - end; - Some lns in - let load1 fname = - if List.exists (fun x -> x = fname) (!loadedFiles) then - begin - print ("- Already loaded: " ^ fname ^ "\n"); - None - end - else - load fname in - let loadOnPath pragma fname = - let paths = List.map (fun p -> Filename.concat p fname) (!loadPath) in - match List.find isFile paths with - | None -> - print ("- No such file: " ^ fname ^ "\n"); - Repl.nextString := ""; - failwith ("No such file : " ^ fname) - | Some fname -> - let loader = match pragma with - | Lexer.D_load -> load - | Lexer.D_need -> load1 - | Lexer.D_use -> load_use in - (match loader fname with - | None -> [] - | Some ls -> ls) in - loadOnPath in - (* Instantiate lexer *) - let scan1 = Lexer.scan nextChar peekChar in - (* Enqueue input here *) - let input_buffer = (Buffer.empty () : Lexer.token Buffer.buffer) in - (* Set up a nextChar/peekChar pair on the list of lines, lex all of it, - * and then stuff it all into input_buffer. - *) - let scan_lines lines = - let inp = ref lines in - let idx = ref 0 in - let rec peekChar () = - match !inp with - | [] -> None - | s::ss -> - try Some (String.sub s (!idx)) - with Subscript -> - (* Look into next string. It should not be empty. *) - match ss with - | [] -> None - | s::ss -> try Some (String.sub s 0) - with Subscript -> None in - let rec nextChar () = - match !inp with - | [] -> None - | s::ss -> - try let res = String.sub s (!idx) in - idx := (!idx) + 1; - Some res - with Subscript -> - idx := 0; - inp := ss; - nextChar () in - let scan = Lexer.scan nextChar peekChar in - let rec nom acc = - match scan () with - | None -> List.app (Buffer.push_front input_buffer) acc - | Some tok -> nom (tok::acc) in - nom []; - Buffer.push_back input_buffer Lexer.T_done in - let next () = - match Buffer.dequeue input_buffer with - | Some tok -> Some tok - | None -> scan1 () in - let output_buffer = (Buffer.empty () : Lexer.token Buffer.buffer) in - let rec next_nonspace () = - match next () with - | Some (Lexer.T_spaces _) -> next_nonspace () - | res -> res in - let rec scan level = - try match next () with - | None -> None - (* Use token as a loading directive. *) - | Some (Lexer.T_use | Lexer.T_needs | Lexer.T_loads as tok) -> - begin - let dir = Option.valOf (Lexer.directive_of_token tok) in - match next_nonspace () with - (* Attempt to convert into directive: *) - | Some (Lexer.T_string fname as tok') -> - begin - match next_nonspace () with - (* OK directive, perform load: *) - | Some (Lexer.T_semis) -> - let lines = load dir fname in - if List.null lines then scan level else - begin - userInput := false; - scan_lines lines; - scan level - end - (* Malformed *) - | _ -> - failwith - (String.concat [ - "\nREPL error: "; - Lexer.string_of_directive dir; - " \"string\" should be followed by a double"; - " semicolon [;;].\n"]) - end - (* Malformed *) - | _ -> - failwith - (String.concat [ - "\nREPL error: "; - Lexer.string_of_directive dir; - " should be followed by a \"string literal\" and then a"; - " double semicolon [;;].\n"]) - end - | Some (Lexer.T_done) -> - userInput := true; - scan level - | Some tok -> - Buffer.push_back output_buffer tok; - match tok with - | Lexer.T_begin | Lexer.T_struct | Lexer.T_sig -> - scan (level + 1) - | Lexer.T_end -> scan (level - 1) - | Lexer.T_semis when level = 0 -> - prompt := !prompt1; - Some (Buffer.flush output_buffer) - | Lexer.T_newline when !userInput -> - print (!prompt); - prompt := !prompt2; - scan level - | _ -> scan level - with Interrupt -> - print "Compilation interrupted\n"; - raise Repl_error in - let checkError () = - let err = !Repl.errorMessage in - Repl.errorMessage := ""; - if err <> "" then raise Repl_error in - let next () = - try checkError (); - match scan 0 with - | None -> - Repl.isEOF := true; - Repl.nextString := "" - | Some ts -> - Repl.isEOF := false; - Repl.nextString := - String.concat - (List.map (Lexer.string_of_token (Some (!unquote))) ts) - with Repl_error -> - if not (!userInput) then print (!prompt1); - Buffer.flush input_buffer; - Buffer.flush output_buffer; - Repl.nextString := ""; - userInput := true in - Repl.readNextString := (fun () -> - print (!prompt1); - next (); - Repl.readNextString := next) -;; - -end;; (* struct *) diff --git a/candle_insulate.py b/candle_insulate.py new file mode 100644 index 00000000..301365dc --- /dev/null +++ b/candle_insulate.py @@ -0,0 +1,236 @@ +#!/usr/bin/env python3 +""" +Generate OCaml bindings for CakeML API insulation. + +This script reads a types.txt file from CakeML and generates OCaml code that: +1. Creates a Cake module with all CakeML functions properly namespaced +2. Binds original module names to empty modules to force usage through Cake +""" + +import sys +from collections import defaultdict +from pathlib import Path + +# Compatibility layer +MODULE_RENAMES = { + 'TextIO': 'Text_io', + 'Word8Array': 'Word8_array', + 'CommandLine': 'Command_line', + 'PrettyPrinter': 'Pretty_printer' +} + +# Ignore any bindings that contain any of the following strings +IGNORED_BINDINGS = { + 'TextIO', # shadowing this will break the REPL in strange ways + 'PrettyPrinter', # shadowing this might break the REPL in strange ways + 'assert', # parser issue + '~', # parser issue +} + +# Identifiers that are not symbols but still need to be parenthesized +INFIX_NAMES = { + "mod" +} + +# types.txt does not contain types, but we need to rebind them so the +# pretty-printers get generated. +# Note that if the module does not exist in types.txt this part gets ignored. +# +# Entries are of the form (type_var list, type_name). +MODULE_TYPES = { + 'Rat': [([], 'rat')], + 'Double': [([], 'double')], + 'Hashtable': [(['a', 'b'], 'hashtable')] +} + + +def format_type_entry(entry): + """ + Parse a MODULE_TYPES entry and return (type_params_str, type_name). + + type_params_str is the OCaml type parameter prefix (e.g. "'a " or "('a, 'b) " + or "" for no parameters). + """ + type_vars, type_name = entry + + if not type_vars: + return '', type_name + + quoted = [f"'{v}" for v in type_vars] + if len(quoted) == 1: + return f"{quoted[0]} ", type_name + else: + return f"({', '.join(quoted)}) ", type_name + + +def handle_func_name(name): + """ + Parenthesizes + renames OCaml identifiers as necessary. + + Examples: + 'delete' -> 'delete' + '*' -> '( * )' + '+' -> '(+)' + """ + if all(c.isalnum() or c in '_\'' for c in name) and not name in INFIX_NAMES: + return name + elif name.startswith("*"): # Special case to avoid (* comment syntax + return f'( {name} )' + else: + return f'({name})' + + +def count_parameters(type_sig): + """ + Count the number of parameters in a function type signature. + Only counts top-level arrows, not arrows inside parentheses. + + Examples: + 'unit -> unit' : 1 + 'a -> b -> c' : 2 + '(a -> b) -> c' : 1 (arrow inside parens doesn't count) + """ + depth = 0 + arrow_count = 0 + i = 0 + + while i < len(type_sig): + char = type_sig[i] + + if char == '(': + depth += 1 + elif char == ')': + depth -= 1 + elif char == '-' and depth == 0: + # Check if this is part of '->' + if i + 1 < len(type_sig) and type_sig[i + 1] == '>': + arrow_count += 1 + i += 1 # Skip the '>' + + i += 1 + + return arrow_count + + +def parse_types_file(content): + """Parse types.txt and extract module.function mappings.""" + bindings = defaultdict(list) + + for line in content.splitlines(): + # Skip empty lines + if not line.strip(): + continue + + parts = line.split(': ', 1) + name_part, type_part = parts[0].strip(), parts[1].strip() + + # Skip ignored bindings + if any(ignore in name_part for ignore in IGNORED_BINDINGS): + continue + + parts = name_part.split('.') + if len(parts) != 2: # Skip top-level and nested modules + continue + module_name, func_name = parts + + bindings[MODULE_RENAMES.get(module_name, module_name)].append({ + 'func_name': handle_func_name(func_name), + 'param_count': count_parameters(type_part), + }) + + return bindings + + +def generate_ocaml_bindings(bindings): + """Generate OCaml code for the Cake module and empty module stubs.""" + lines = [] + + # Generate the Cake module + lines.append("(* Generated by candle_insulate.py based on CakeML's types.txt *)") + lines.append("(* This file insulates the codebase from direct CakeML API usage *)") + lines.append("") + lines.append("module Cake = struct") + + # Get all module names (sorted for consistent output) + module_names = sorted([m for m in bindings.keys() if m]) + + # Generate submodules within Cake + for module_name in module_names: + lines.append(f" module {module_name} = struct") + + # Add type rebindings if specified for this module + if module_name in MODULE_TYPES: + for entry in MODULE_TYPES[module_name]: + params_str, type_name = format_type_entry(entry) + lines.append(f" type {params_str}{type_name} = {params_str}{module_name}.{type_name}") + lines.append("") + + # Add all functions for this module with eta expansion and symbol escaping + for binding_info in sorted(bindings[module_name], key=lambda x: x['func_name']): + func_name = binding_info['func_name'] + param_count = binding_info['param_count'] + + # Try to do as much eta-expansion as possible for performance reasons (2026-02-06) + if param_count == 0: + lines.append(f" let {func_name} = {module_name}.{func_name}") + else: + params = ' '.join(f'x{i}' for i in range(param_count)) + lines.append(f" let {func_name} {params} = {module_name}.{func_name} {params}") + + lines.append(" end;;") + lines.append("") + + lines.append("end;;") + lines.append("") + + # Generate module stubs that re-export pretty printers + lines.append("(* Module stubs to prevent direct CakeML API usage *)") + lines.append("(* Users must access these through the Cake module *)") + lines.append("(* Types are re-exported so that pretty printers still work *)") + lines.append("") + + for ocaml_module_name in module_names: + if ocaml_module_name in MODULE_TYPES: + lines.append(f"module {ocaml_module_name} = struct") + for entry in MODULE_TYPES[ocaml_module_name]: + params_str, type_name = format_type_entry(entry) + lines.append(f" type {params_str}{type_name} = {params_str}Cake.{ocaml_module_name}.{type_name}") + lines.append("end;;") + else: + lines.append(f"module {ocaml_module_name} = struct end;;") + + lines.append("") + lines.append("(* End of generated section *)") + + + return '\n'.join(lines) + + +def main(): + if len(sys.argv) < 2: + print("Usage: python generate_cake_bindings.py [output.ml]") + print(" If output file is not specified, prints to stdout") + sys.exit(1) + + input_file = Path(sys.argv[1]) + output_file = Path(sys.argv[2]) if len(sys.argv) > 2 else None + + if not input_file.exists(): + print(f"Error: Input file '{input_file}' not found") + sys.exit(1) + + # Read and parse the types file + content = input_file.read_text() + bindings = parse_types_file(content) + ocaml_code = generate_ocaml_bindings(bindings) + + # Output + if output_file: + output_file.write_text(ocaml_code) + print(f"Generated bindings written to {output_file}") + else: + print(ocaml_code) + + +if __name__ == '__main__': + main() diff --git a/candle_kernel.ml b/candle_kernel.ml index 64f13398..87703cb9 100644 --- a/candle_kernel.ml +++ b/candle_kernel.ml @@ -90,14 +90,14 @@ module Type = struct let rec compare ty1 ty2 = match ty1, ty2 with | Tyvar x1, Tyvar x2 -> String.compare x1 x2 - | Tyvar _, Tyapp _ -> Less + | Tyvar _, Tyapp _ -> -1 | Tyapp (x1,a1), Tyapp (x2,a2) -> Pair.compare String.compare (List.compare compare) (x1,a1) (x2,a2) - | Tyapp _, Tyvar _ -> Greater + | Tyapp _, Tyvar _ -> 1 ;; - let (<) ty1 ty2 = compare ty1 ty2 = Less + let (<) ty1 ty2 = compare ty1 ty2 < 0 ;; - let (<=) ty1 ty2 = compare ty1 ty2 <> Greater + let (<=) ty1 ty2 = compare ty1 ty2 <> 1 ;; end;; @@ -106,23 +106,25 @@ module Term = struct match t1, t2 with | Var (x1,ty1), Var (x2,ty2) -> Pair.compare String.compare Type.compare (x1,ty1) (x2,ty2) - | Var _, _ -> Less + | Var _, _ -> -1 | Const (x1,ty1), Const (x2,ty2) -> Pair.compare String.compare Type.compare (x1,ty1) (x2,ty2) - | Const _, Var _ -> Greater - | Const _, _ -> Less + | Const _, Var _ -> 1 + | Const _, _ -> -1 | Comb (s1,s2), Comb (t1,t2) -> Pair.compare compare compare (s1,s2) (t1,t2) - | Comb _, Var _ -> Greater - | Comb _, Const _ -> Greater - | Comb _, Abs _ -> Less + | Comb _, Var _ -> 1 + | Comb _, Const _ -> 1 + | Comb _, Abs _ -> -1 | Abs (s1,s2), Abs (t1,t2) -> Pair.compare compare compare (s1,s2) (t1,t2) - | Abs _, _ -> Greater + | Abs _, _ -> 1 ;; - let (<) t1 t2 = compare t1 t2 = Less + let (<) t1 t2 = compare t1 t2 < 0 ;; - let (<=) t1 t2 = compare t1 t2 <> Greater + let (>) t1 t2 = compare t1 t2 > 0 + ;; + let (<=) t1 t2 = compare t1 t2 <> 1 ;; end;; @@ -132,9 +134,9 @@ module Thm = struct (dest_thm th1) (dest_thm th2) ;; - let (<) th1 th2 = compare th1 th2 = Less + let (<) th1 th2 = compare th1 th2 < 0 ;; - let (<=) th1 th2 = compare th1 th2 <> Greater + let (<=) th1 th2 = compare th1 th2 <> 1 ;; end;; @@ -142,34 +144,34 @@ let rec ordav env x1 x2 = match env with | [] -> Term.compare x1 x2 | (t1,t2)::env -> - if Term.compare x1 t1 = Equal then - if Term.compare x2 t2 = Equal then - Equal + if Term.compare x1 t1 = 0 then + if Term.compare x2 t2 = 0 then + 0 else - Less - else if Term.compare x2 t2 = Equal then - Greater + -1 + else if Term.compare x2 t2 = 0 then + 1 else ordav env x1 x2 ;; let rec orda env t1 t2 = - if List.null env && t1 = t2 then Equal else + if Cake.List.null env && t1 = t2 then 0 else match t1, t2 with | Var (_,_), Var (_,_) -> ordav env t1 t2 | Const (_,_), Const (_,_) -> Term.compare t1 t2 | Comb (s1, t1), Comb (s2, t2) -> let c = orda env s1 s2 in - if c <> Equal then c else orda env t1 t2 + if c <> 0 then c else orda env t1 t2 | Abs (s1, t1), Abs (s2, t2) -> let c = Type.compare (type_of s1) (type_of s2) in - if c <> Equal then c else orda ((s1,s2)::env) t1 t2 - | Var (_,_), _ -> Less - | _, Var (_,_) -> Greater - | Const (_,_), _ -> Less - | _, Const (_,_) -> Greater - | Comb (_,_), _ -> Less - | _, Comb (_,_) -> Greater + if c <> 0 then c else orda ((s1,s2)::env) t1 t2 + | Var (_,_), _ -> -1 + | _, Var (_,_) -> 1 + | Const (_,_), _ -> -1 + | _, Const (_,_) -> 1 + | Comb (_,_), _ -> -1 + | _, Comb (_,_) -> 1 ;; let alphaorder = orda [] @@ -180,7 +182,7 @@ let alphaorder = orda [] * Fixes to the Kernel interface * ------------------------------------------------------------------------- *) -let aconv s t = alphaorder s t = Equal;; +let aconv s t = alphaorder s t = 0;; let tyvars t = List.map mk_vartype (tyvars t);; let type_vars_in_term t = List.map mk_vartype (type_vars_in_term t);; @@ -191,4 +193,3 @@ let type_vars_in_term t = List.map mk_vartype (type_vars_in_term t);; (* ------------------------------------------------------------------------- *) let equals_thm th th' = dest_thm th = dest_thm th';; - diff --git a/candle_nums.ml b/candle_nums.ml index 5791084d..30258644 100644 --- a/candle_nums.ml +++ b/candle_nums.ml @@ -57,7 +57,7 @@ end;; type num = | Int of int - | Rat of rat + | Rat of Cake.Rat.rat ;; let pp_num n = @@ -73,22 +73,22 @@ type num = num;; let denominator n = match n with | Int i -> Int 1 - | Rat r -> Int (Rat.denominator r) + | Rat r -> Int (Cake.Rat.denominator r) ;; let numerator n = match n with | Int i -> n - | Rat r -> Int (Rat.numerator r) + | Rat r -> Int (Cake.Rat.numerator r) ;; let num_fix n = match n with | Int i -> n | Rat r -> - if Rat.denominator r = 1 then - Int (Rat.numerator r) - else if Rat.denominator r = 0 then + if Cake.Rat.denominator r = 1 then + Int (Cake.Rat.numerator r) + else if Cake.Rat.denominator r = 0 then failwith "num_fix: division by zero" else n ;; @@ -96,15 +96,15 @@ let num_fix n = let abs_num n = match n with | Int i -> Int (abs i) - | Rat r -> Rat (Rat.(/) (Rat.fromInt (abs (Rat.numerator r))) - (Rat.fromInt (Rat.denominator r))) + | Rat r -> Rat (Cake.Rat.(/) (Cake.Rat.fromInt (abs (Cake.Rat.numerator r))) + (Cake.Rat.fromInt (Cake.Rat.denominator r))) ;; let sign_num n = - let sign i = if i < 0 then -1 else if i > 0 then 1 else 0 in + let sign i = if i < 0 then ~-1 else if i > 0 then 1 else 0 in match n with | Int i -> sign i - | Rat r -> sign (Rat.numerator r) + | Rat r -> sign (Cake.Rat.numerator r) ;; (* The Rat type operations normalize results *) @@ -117,30 +117,30 @@ let num_of_int i = Int i let int_of_num n = match n with | Int i -> i - | Rat r -> Rat.numerator r / Rat.denominator r + | Rat r -> Cake.Rat.numerator r / Cake.Rat.denominator r ;; let string_of_num n = match n with | Int i -> string_of_int i | Rat r -> - let n = Rat.numerator r in - let d = Rat.denominator r in + let n = Cake.Rat.numerator r in + let d = Cake.Rat.denominator r in string_of_int n ^ "/" ^ string_of_int d ;; let minus_num n = match n with - | Int i -> Int (-i) + | Int i -> Int (~-i) | Rat r -> Rat (rat_minus r) ;; let (+/) x y = match x, y with | Int i, Int j -> Int (i + j) - | Int i, Rat r -> Rat (Rat.(+) (Rat.fromInt i) r) - | Rat r, Int i -> Rat (Rat.(+) r (Rat.fromInt i)) - | Rat i, Rat j -> Rat (Rat.(+) i j) + | Int i, Rat r -> Rat (Cake.Rat.(+) (Cake.Rat.fromInt i) r) + | Rat r, Int i -> Rat (Cake.Rat.(+) r (Cake.Rat.fromInt i)) + | Rat i, Rat j -> Rat (Cake.Rat.(+) i j) ;; let (+/) x y = num_fix (x +/ y);; let add_num = (+/);; @@ -148,9 +148,9 @@ let add_num = (+/);; let (-/) x y = match x, y with | Int i, Int j -> Int (i - j) - | Int i, Rat r -> Rat (Rat.(-) (Rat.fromInt i) r) - | Rat r, Int i -> Rat (Rat.(-) r (Rat.fromInt i)) - | Rat i, Rat j -> Rat (Rat.(-) i j) + | Int i, Rat r -> Rat (Cake.Rat.(-) (Cake.Rat.fromInt i) r) + | Rat r, Int i -> Rat (Cake.Rat.(-) r (Cake.Rat.fromInt i)) + | Rat i, Rat j -> Rat (Cake.Rat.(-) i j) ;; let (-/) x y = num_fix (x -/ y);; let sub_num = (-/);; @@ -158,19 +158,19 @@ let sub_num = (-/);; let ( */) x y = match x, y with | Int i, Int j -> Int (i * j) - | Int i, Rat r -> Rat (Rat.( * ) (Rat.fromInt i) r) - | Rat r, Int i -> Rat (Rat.( * ) r (Rat.fromInt i)) - | Rat i, Rat j -> Rat (Rat.( * ) i j) + | Int i, Rat r -> Rat (Cake.Rat.( * ) (Cake.Rat.fromInt i) r) + | Rat r, Int i -> Rat (Cake.Rat.( * ) r (Cake.Rat.fromInt i)) + | Rat i, Rat j -> Rat (Cake.Rat.( * ) i j) ;; let ( */) x y = num_fix (x */ y);; let mul_num = ( */);; let (//) x y = match x, y with - | Int i, Int j -> Rat (Rat.(/) (Rat.fromInt i) (Rat.fromInt j)) - | Int i, Rat r -> Rat (Rat.(/) (Rat.fromInt i) r) - | Rat r, Int i -> Rat (Rat.(/) r (Rat.fromInt i)) - | Rat i, Rat j -> Rat (Rat.(/) i j) + | Int i, Int j -> Rat (Cake.Rat.(/) (Cake.Rat.fromInt i) (Cake.Rat.fromInt j)) + | Int i, Rat r -> Rat (Cake.Rat.(/) (Cake.Rat.fromInt i) r) + | Rat r, Int i -> Rat (Cake.Rat.(/) r (Cake.Rat.fromInt i)) + | Rat i, Rat j -> Rat (Cake.Rat.(/) i j) ;; let (//) x y = num_fix (x // y);; let div_num = (//);; @@ -216,15 +216,15 @@ let ( **/) = power_num;; let floor_num n = match n with | Int i -> n - | Rat r -> Int (Rat.numerator r / Rat.denominator r) + | Rat r -> Int (Cake.Rat.numerator r / Cake.Rat.denominator r) ;; let compare x y = match x, y with - | Int i, Int j -> Int.compare i j - | Int i, Rat r -> Rat.compare (Rat.fromInt i) r - | Rat r, Int j -> Rat.compare r (Rat.fromInt j) - | Rat i, Rat j -> Rat.compare i j + | Int i, Int j -> Cake.Int.compare i j + | Int i, Rat r -> Cake.Rat.compare (Cake.Rat.fromInt i) r + | Rat r, Int j -> Cake.Rat.compare r (Cake.Rat.fromInt j) + | Rat i, Rat j -> Cake.Rat.compare i j ;; let ( =/ y then x else y;; let gcd_num x y = match x, y with - | Int i, Int j -> Int (abs (Int.gcd i j)) + | Int i, Int j -> Int (abs (Cake.Int.gcd i j)) ;; let succ_num n = Int 1 +/ n;; diff --git a/candle_ocaml.ml b/candle_ocaml.ml new file mode 100644 index 00000000..e3d4e932 --- /dev/null +++ b/candle_ocaml.ml @@ -0,0 +1,284 @@ +exception Invalid_argument of string;; +exception Sys_error of string;; +exception End_of_file;; +exception Not_found;; + +let pp_exn e = + match e with + | Invalid_argument s -> + Pretty_printer.app_block "Invalid_argument" [Pretty_printer.pp_string s] + | Sys_error s -> + Pretty_printer.app_block "Sys_error" [Pretty_printer.pp_string s] + | End_of_file -> Pretty_printer.token "End_of_file" + | Not_found -> Pretty_printer.token "Not_found" + | _ -> pp_exn e;; + +let invalid_arg s = raise (Invalid_argument s);; + +let open_in name = try Text_io.openIn name + with Text_io.Bad_file_name -> raise (Sys_error ("open_in " ^ name)) +;; + +let open_out name = Text_io.openOut name;; + +let output_string s fd = Text_io.output s fd;; + +let close_in fd = Text_io.closeIn fd;; + +let close_out fd = Text_io.closeOut fd;; + +let input_line fd = + match Text_io.inputLine fd with + | Some l -> l + | None -> raise End_of_file +;; + +(* There isn't really a maximal integer since we have bignums. *) +let max_int = 2305843009213693951 (* 2^61 - 1 *) +let float_of_int x = Cake.Double.fromInt x +let int_of_float x = Cake.Double.toInt x +let floor x = Cake.Double.floor x + +(* General helpers. May be moved. *) +module Candle = struct + let ordering_to_int cmp x y = + match cmp x y with + | Equal -> 0 + | Less -> ~-1 + | Greater -> 1 + ;; + let int_to_ordering cmp x y = + let r = cmp x y in + if r < 0 then Less + else if r > 0 then Greater + else Equal +end;; + +module Pair = struct + let compare cmpa cmpb (a1, b1) (a2, b2) = + let ar = cmpa a1 a2 in + if ar = 0 then cmpb b1 b2 else ar +end;; + +module Int = struct + let compare x y = + if x < y then -1 else if x > y then 1 else 0 + let to_string x = Cake.Int.toString x +end;; + +module Float = struct + type float = double + let zero = Cake.Double.fromInt 0 + let one = Cake.Double.fromInt 1 + let minus_one = Cake.Double.fromInt ~-1 + let sqrt x = Cake.Double.sqrt x + let abs x = Cake.Double.abs x + let compare x y = + if Cake.Double.(<) x y then -1 + else if Cake.Double.(>) x y then 1 + else 0 + let of_string s = match Cake.Double.fromString s with + | None -> failwith "Float.of_string" + | Some x -> x +end;; + +type float = Float.float;; + +module List = struct + let fold_left f init xs = Cake.List.foldl (fun x y -> f y x) init xs + let fold_right f xs init = Cake.List.foldr f init xs + let find f l = match Cake.List.find f l with + | None -> raise Not_found + | Some x -> x + let nth l i = + if i < 0 then raise (Invalid_argument "List.nth") + else if i >= Cake.List.length l then raise (Failure "List.nth") + else Cake.List.nth l i + let for_all f l = Cake.List.all f l + let iter f xs = Cake.List.app f xs + let hd = function + | [] -> failwith "List.hd" + | h :: _ -> h + let rec assoc key = function + | [] -> raise Not_found + | (k, v) :: rest -> if k = key then v else assoc key rest + let rec mem_assoc key = function + | [] -> false + | (k, _) :: rest -> k = key || mem_assoc key rest + let filter f l = Cake.List.filter f l + let partition f l = Cake.List.partition f l + let sort cmp xs = Cake.List.sort (fun x y -> cmp x y < 0) xs + let length xs = Cake.List.length xs + let map f xs = Cake.List.map f xs + let rec map2 f xs ys = + match xs, ys with + | [], [] -> [] + | x :: xs', y :: ys' -> f x y :: map2 f xs' ys' + | _ -> invalid_arg "map2: lists must have equal length" + let mem a set = Cake.List.member a set + let rev xs = Cake.List.rev xs + let concat xss = Cake.List.concat xss + let rev_append l1 l2 = + let rec aux acc l = + match l with + [] -> acc + | h::t -> aux (h::acc) t in + aux l2 l1;; + let exists f xs = Cake.List.exists f xs + let rec compare cmp xs ys = + match (xs, ys) with + | ([], []) -> 0 + | ([], l2) -> -1 + | (l1, []) -> 1 + | (x::l1, y::l2) -> + let r = cmp x y in + if r = 0 then compare cmp l1 l2 else r +end;; + +module Char = struct + let compare c1 c2 = + if Cake.Char.(<) c1 c2 then -1 + else if Cake.Char.(>) c1 c2 then 1 + else 0 + let code c = Cake.Char.ord c + let chr i = try Cake.Char.chr i + with Chr -> raise (Invalid_argument "Char.chr") +end;; + +module String = struct + let make n c = + if n < 0 then raise (Invalid_argument "String.make") + else Cake.String.implode (Cake.List.tabulate n (fun _ -> c)) + let sub s pos len = try Cake.String.substring s pos len + with Subscript -> raise (Invalid_argument "String.sub") + let get s i = try Cake.String.sub s i + with Subscript -> raise (Invalid_argument "String.get") + let length s = Cake.String.size s;; + let compare x y = Candle.ordering_to_int Cake.String.compare x y + let escaped s = Cake.String.escape_str s + let concat sep ss = Cake.String.concatWith sep ss + (* TODO Painful use of Word64s which are always boxed; prime candidate for + writing in Pancake that's embedded, once that's possible. At that point, + it should probably move to CakeML as well. *) + (* Adapted from http://www.cse.yorku.ca/~oz/hash.html (djb2) *) + let hash s = + let times_33 w = (Cake.Word64.(+) (Cake.Word64.(<<) w 5) w) in + let step char hash = + Cake.Word64.xorb (times_33 hash) (Cake.Word64.fromInt (Cake.Char.ord char)) in + Cake.Word64.toInt (Cake.List.foldl step (Cake.Word64.fromInt 5381) (Cake.String.explode s));; +end;; + +module Array = struct + let make n x = Cake.Array.array n x + let set a n x = try Cake.Array.update a n x + with Subscript -> raise (Invalid_argument "Array.set") + let get a n = try Cake.Array.sub a n + with Subscript -> raise (Invalid_argument "Array.get") + let fold_left f init a = Cake.Array.foldl (fun x y -> f y x) init a + let of_list l = Cake.Array.fromList l + let map f a = + Cake.Array.tabulate (Cake.Array.length a) (fun i -> f (Cake.Array.sub a i)) +end;; + +module Printexc = struct + let to_string (e: exn) = "TODO stub (Printexc.to_string)" +end;; + +module Format = struct + type formatter = Pretty_imp.state;; + + let set_margin n = + if n < 1 then failwith "set_margin: must be positive"; + Pretty.margin := n + ;; + + let pp_print_as = Pretty_imp.print_as;; + let pp_print_string = Pretty_imp.print_string;; + let pp_print_break = Pretty_imp.print_break;; + let pp_print_space fmt () = Pretty_imp.print_space fmt;; + let pp_print_newline fmt () = Pretty_imp.print_newline fmt;; + + let pp_open_box = Pretty_imp.open_block;; + let pp_open_hbox fmt () = Pretty_imp.open_hblock fmt;; + let pp_open_vbox = Pretty_imp.open_vblock;; + let pp_open_hvbox = Pretty_imp.open_hvblock;; + let pp_close_box fmt () = Pretty_imp.close_block fmt;; + + let pp_get_max_boxes (fmt:formatter) () = ~-1;; (* TODO stub *) + let pp_set_max_boxes (fmt:formatter) (i:int) = ();; (* TODO stub *) + let set_max_boxes (i:int) = ();; (* TODO stub *) + + (* Functions that print to stdout: *) + + let print_string = Pretty.print_stdout pp_print_string;; + let print_break l i = + Pretty.print_stdout (fun s (l,i) -> pp_print_break s l i) (l, i);; + let print_space () = Pretty.print_stdout pp_print_space ();; + let print_newline () = Pretty.print_stdout pp_print_newline ();; + let print_flush () = ();; (* TODO? stub *) + + let open_box = Pretty.print_stdout pp_open_box;; + let open_hbox () = Pretty.print_stdout pp_open_hbox ();; + let open_vbox = Pretty.print_stdout pp_open_vbox;; + let open_hvbox = Pretty.print_stdout pp_open_hvbox;; + let close_box () = Pretty.print_stdout pp_close_box ();; +end;; + +let print_string s = Format.print_string s;; +let print_newline () = Format.print_newline ();; +let print_endline s = print_string s; print_newline ();; + +(* TODO Move Random module to CakeML basis. *) +module Random = struct + (* TODO This should probably be a local in CakeML *) + let state = ref 1;; + + let init i = state := i;; + + let bits () = + (* Parameters permanently borrowed from glibc's stdlib/random_r.c *) + let a = 1103515245 in + let c = 12345 in + let m = 2147483648 (* 2^31 *) in + let next_s = (a * !state + c) mod m in + state := next_s; next_s;; + + let int bound = + if bound <= 0 || bound >= 1073741824 (* 2^30 *) + then raise (Invalid_argument "Random.int") + else bits () mod bound;; +end;; + +module Hashtbl = struct + type ('a, 'b) t = ('a, 'b) Cake.Hashtable.hashtable + (* Note that we additionally need to pass in hash and order to create *) + let create size hash order = + Cake.Hashtable.empty size hash (Candle.int_to_ordering order) + let find tbl x = + match Cake.Hashtable.lookup tbl x with + | None -> raise Not_found + | Some y -> y + let replace tbl x y = Cake.Hashtable.insert tbl x y + let remove tbl x = Cake.Hashtable.delete tbl x + let fold f tbl init = + Cake.List.foldl (fun (x,y) acc -> f x y acc) init (Cake.Hashtable.toAscList tbl) +end;; + +module Sys = struct + let remove (s: string) = print "TODO Sys.remove (noop)\n" + let command (s: string) = + print_endline "TODO Sys.command (noop, always returns 1)"; + 1 + let time () = + print_endline "TODO Sys.time (always returns 0)"; + Float.zero;; +end;; + +module Filename = struct + let get_temp_dir_name () = + print_endline "TODO Filename.get_temp_dir_name (always returns /tmp)"; + "/tmp" + let temp_file prefix suffix = + print_endline "TODO Filename.temp_file (just concats temp dir, prefix, suffix)"; + get_temp_dir_name () ^ prefix ^ suffix +end;; diff --git a/candle_pretty.ml b/candle_pretty.ml index 2db304f4..a0c90037 100644 --- a/candle_pretty.ml +++ b/candle_pretty.ml @@ -34,13 +34,13 @@ module App_list = struct let rec map f l = match l with | Nil -> Nil - | List xs -> List (List.map f xs) + | List xs -> List (Cake.List.map f xs) | Append (l, r) -> Append (map f l, map f r) ;; let rec iter f l = match l with | Nil -> () - | List xs -> List.app f xs + | List xs -> Cake.List.app f xs | Append (l, r) -> iter f l; iter f r @@ -55,10 +55,10 @@ module App_list = struct let rec concat_aux sofar l = match l with | Nil -> sofar - | List xs -> String.concat xs :: sofar + | List xs -> Cake.String.concat xs :: sofar | Append (l, r) -> concat_aux (concat_aux sofar r) l ;; - let concat l = String.concat (concat_aux [] l) ;; + let concat l = Cake.String.concat (concat_aux [] l) ;; end;; (* struct *) @@ -91,7 +91,7 @@ module Pretty_core = struct let space = ref margin in let blanks n = space := !space - n; - App_list.list (List.tabulate n (fun _ -> " ")) in + App_list.list (Cake.List.tabulate n (fun _ -> " ")) in let newline () = space := margin; App_list.list ["\n"] in @@ -149,7 +149,7 @@ module Pretty_core = struct | String (_, len) -> len | Break (len, _) -> len | Newline -> 0 in - let sum = List.foldl (fun t s -> s + length t) 0 in + let sum = Cake.List.foldl (fun t s -> s + length t) 0 in fun typ indent toks -> Block (typ, toks, indent, sum toks) ;; @@ -194,10 +194,10 @@ module Pretty_imp = struct let tq_to_block (Token_queue (ts, ind, typ)) = match typ with - | H_block -> Pretty_core.hblock (List.rev ts) - | Hv_block -> Pretty_core.hvblock ind (List.rev ts) - | V_block -> Pretty_core.vblock ind (List.rev ts) - | C_block -> Pretty_core.block ind (List.rev ts) + | H_block -> Pretty_core.hblock (Cake.List.rev ts) + | Hv_block -> Pretty_core.hvblock ind (Cake.List.rev ts) + | V_block -> Pretty_core.vblock ind (Cake.List.rev ts) + | C_block -> Pretty_core.block ind (Cake.List.rev ts) ;; type state = @@ -224,7 +224,7 @@ module Pretty_imp = struct let print_as st l str = st_insert st (Pretty_core.string str l) ;; - let print_string st str = print_as st (String.size str) str + let print_string st str = print_as st (Cake.String.size str) str ;; let print_break st l i = st_insert st (Pretty_core.break l i) @@ -312,48 +312,3 @@ module Pretty = struct App_list.concat apps;; end;; (* struct *) - -(* ------------------------------------------------------------------------- - format.ml compatibility layer - ------------------------------------------------------------------------- *) - -let set_margin n = - if n < 1 then failwith "set_margin: must be positive"; - Pretty.margin := n -;; - -type formatter = Pretty_imp.state;; - -let pp_print_as = Pretty_imp.print_as;; -let pp_print_string = Pretty_imp.print_string;; -let pp_print_break = Pretty_imp.print_break;; -let pp_print_space fmt () = Pretty_imp.print_space fmt;; -let pp_print_newline fmt () = Pretty_imp.print_newline fmt;; - -let pp_open_box = Pretty_imp.open_block;; -let pp_open_hbox fmt () = Pretty_imp.open_hblock fmt;; -let pp_open_vbox = Pretty_imp.open_vblock;; -let pp_open_hvbox = Pretty_imp.open_hvblock;; -let pp_close_box fmt () = Pretty_imp.close_block fmt;; - -let pp_get_max_boxes (fmt:formatter) () = - remark "TODO: stub called: pp_get_max_boxes"; -1;; -let pp_set_max_boxes (fmt:formatter) (i:int) = - remark "TODO: stub called: pp_set_max_boxes";; - -let print_to_string = Pretty.print_to_string;; - -(* Functions that print to stdout: *) - -let print_string = Pretty.print_stdout pp_print_string;; -let print_break l i = - Pretty.print_stdout (fun s (l,i) -> pp_print_break s l i) (l, i);; -let print_space () = Pretty.print_stdout pp_print_space ();; -let print_newline () = Pretty.print_stdout pp_print_newline ();; -let print_endline s = print_string s; print_newline ();; - -let open_box = Pretty.print_stdout pp_open_box;; -let open_hbox () = Pretty.print_stdout pp_open_hbox ();; -let open_vbox = Pretty.print_stdout pp_open_vbox;; -let open_hvbox = Pretty.print_stdout pp_open_hvbox;; -let close_box () = Pretty.print_stdout pp_close_box ();; diff --git a/candletest.mk b/candletest.mk index 22da3640..39c06ee7 100644 --- a/candletest.mk +++ b/candletest.mk @@ -16,6 +16,9 @@ # consult your preferred resources to find out how you can give those # CAP_SYS_ADMIN to it. +# To restore, we can use the following command: +# sudo criu restore -D checkpoint/ --shell-job + # Since we need to restore into a terminal, but also want to call it via make # we need to place it into a pseudoterminal. To avoid having to somehow pass # the user password into that, we assume that criu can be run with sudo without @@ -121,5 +124,5 @@ $(LOGDIR)/%.ready: @mkdir -p $(LOGDIR)/$$(dirname $*) @echo '### Loading $*.ml' @echo '### Loading $*.ml' > $(LOGDIR)/$* - @echo 'loads "$*.ml";;Runtime.exit 0;;' | (timeout 60 $(CANDLE) >> $(LOGDIR)/$* 2>&1) || echo "TIMEOUT" >> $(LOGDIR)/$* + @echo 'loads "$*.ml";;Cake.Runtime.exit 0;;' | ($(CANDLE) >> $(LOGDIR)/$* 2>&1) || echo "TIMEOUT" >> $(LOGDIR)/$* @touch $(LOGDIR)/$*.ready diff --git a/compute.ml b/compute.ml index 87e086f4..62bdbabb 100644 --- a/compute.ml +++ b/compute.ml @@ -57,87 +57,7 @@ module type Compute_sig = sig val listItems : compset -> (string * transform list) list end;; -(* TODO Restore to original position once a binary with cakeml#1316 - included is available *) - -type ('a, 'b, 'c) stack = - Ztop - | Zrator of 'a * ('a, 'b, 'c) stack - | Zrand of 'b * ('a, 'b, 'c) stack - | Zabs of 'c * ('a, 'b, 'c) stack;; - -type pattern = - Pvar of int - | Papp of term * pattern list;; - -type 'a cst_rec = Cst_rec of - (* head: *) term * - (* args: *) (term * 'a fterm) list * - (* rws: *) 'a * - (* skip: *) int option - -and 'a clos_rec = Clos_rec of - (* env: *) 'a fterm list * - (* term: *) 'a dterm - -and 'a fterm = - Fconst of 'a cst_rec - | Neutr - | Clos of 'a clos_rec - -(*--------------------------------------------------------------------------- - * An alternative representation of terms, with all information needed: - * - they are real de Bruijn terms, so that abstraction destruction is in - * constant time. - * - application is n-ary (slight optimization) - * - we forget the names of variables - * - constants are tagged with the set of rewrites that apply to it. - * It's a reference since dterm is used to represent rhs of rewrites, - * and fixpoints equations add rewrites for a constant that appear in the - * rhs. - *---------------------------------------------------------------------------*) - -and 'a dterm = - Bv of int - | Fv - | Cst of term * ('a * int option) ref - | App of 'a dterm * 'a dterm list (* order: outermost ahead *) - | Dabs of 'a dterm;; -(* Invariant: the first arg of App never is an App. *) - - -type action = - Rewrite of rewrite list - | Conv of (term -> thm * db fterm) - -and try_rec = Try_rec of - (* hcst: *) term * - (* rws: *) action * - (* tail: *) db - - -and db = - End_db - | Try of try_rec - | Need_arg of db - -and rewrite_rec = Rewrite_rec of - (* cst: *) term * (* constant which the rule applies to *) - (* lhs: *) pattern list * (* patterns = constant args in lhs of thm *) - (* npv: *) int * (* number of distinct pat vars in lhs *) - (* rhs: *) db dterm * - (* thm: *) thm (* thm we use for rewriting *) - - -and rewrite = - Rw of rewrite_rec;; - -type cbv_stack = - ((thm->thm->thm) * (thm * db fterm), - (thm->thm->thm) * bool * (thm * db fterm), - (thm->thm)) stack;; - -module Compute = struct +module Compute : Compute_sig = struct let with_flag (flag, b) f x = let fval = !flag in @@ -171,6 +91,12 @@ let rec BODY_CONJUNCTS th = (*** compute_rules.sml ***) +type ('a, 'b, 'c) stack = + Ztop + | Zrator of 'a * ('a, 'b, 'c) stack + | Zrand of 'b * ('a, 'b, 'c) stack + | Zabs of 'c * ('a, 'b, 'c) stack;; + exception Dead_code of string;; let rhs_concl = rand o concl;; @@ -243,6 +169,10 @@ let eq_intro thm = * with p1...pn either a const applied to patterns or a free variable. *---------------------------------------------------------------------------*) +type pattern = + Pvar of int + | Papp of term * pattern list;; + let check_arg_form trm = let rec chk t stk free = if is_comb t then @@ -277,6 +207,42 @@ let check_arg_form trm = * that arguments of a variable are immediatly strongly reduced. *---------------------------------------------------------------------------*) +type 'a cst_rec = Cst_rec of { + head: term; + args: (term * 'a fterm) list; + rws: 'a; + skip: int option +} +and 'a clos_rec = Clos_rec of { + env: 'a fterm list; + term: 'a dterm +} +and 'a fterm = + Fconst of 'a cst_rec + | Neutr + | Clos of 'a clos_rec + +(*--------------------------------------------------------------------------- + * An alternative representation of terms, with all information needed: + * - they are real de Bruijn terms, so that abstraction destruction is in + * constant time. + * - application is n-ary (slight optimization) + * - we forget the names of variables + * - constants are tagged with the set of rewrites that apply to it. + * It's a reference since dterm is used to represent rhs of rewrites, + * and fixpoints equations add rewrites for a constant that appear in the + * rhs. + *---------------------------------------------------------------------------*) + +and 'a dterm = + Bv of int + | Fv + | Cst of term * ('a * int option) ref + | App of 'a dterm * 'a dterm list (* order: outermost ahead *) + | Dabs of 'a dterm;; + +(* Invariant: the first arg of App never is an App. *) + let appl = function | App (a, l1), arg -> App (a, arg :: l1) | t, arg -> App (t, [arg]);; @@ -295,25 +261,60 @@ let inst_type_dterm = function | v -> v in tyi_dt v;; + +type action = + Rewrite of rewrite list + | Conv of (term -> thm * db fterm) + +and try_rec = Try_rec of { + hcst: term; + rws: action; + tail: db +} + +and db = + End_db + | Try of try_rec + | Need_arg of db + +and rewrite = + Rw of { + cst: term; (* constant which the rule applies to *) + lhs: pattern list; (* patterns = constant args in lhs of thm *) + npv: int; (* number of distinct pat vars in lhs *) + rhs: db dterm; + thm: thm (* thm we use for rewriting *) + };; + let rec add_in_db = function | (n, cst, act, End_db) -> - funpow n (fun a -> Need_arg a) (Try (Try_rec (cst, act, End_db))) - | (0, cst, (Rewrite nrws as act), Try (Try_rec (hcst, (Rewrite rws as rw), tail))) -> - if cst = hcst then Try (Try_rec (hcst, (Rewrite (nrws @ rws)), tail)) - else Try (Try_rec (hcst, rw, (add_in_db (0, cst, act, tail)))) - | (n, cst, act, Try (Try_rec (hcst, rws, tail))) -> - Try (Try_rec (hcst, rws, (add_in_db(n, cst, act, tail)))) + funpow n (fun a -> Need_arg a) (Try (Try_rec { hcst = cst; rws = act; tail = End_db })) + | (0, cst, (Rewrite nrws as act), Try try_rec) -> + let Try_rec { hcst; rws; tail } = try_rec in + let rw = rws in + (match rws with + | Rewrite rws -> + if cst = hcst then Try (Try_rec { hcst = hcst; rws = Rewrite (nrws @ rws); tail = tail }) + else Try (Try_rec { hcst = hcst; rws = rw; tail = add_in_db (0, cst, act, tail) }) + | _ -> Try (Try_rec { hcst = hcst; rws = rws; tail = add_in_db(0, cst, act, tail) })) + | (n, cst, act, Try try_rec) -> + let Try_rec { hcst; rws; tail } = try_rec in + Try (Try_rec { hcst = hcst; rws = rws; tail = add_in_db(n, cst, act, tail) }) | (0, cst, act, db) -> - Try (Try_rec (cst, act, db)) + Try (Try_rec { hcst = cst; rws = act; tail = db }) | (n, cst, act, Need_arg tail) -> Need_arg (add_in_db(n - 1, cst, act, tail));; -let key_of (Rw (Rewrite_rec (cst, lhs, _, _, _))) = +let key_of (Rw {cst; lhs}) = let name, _ = dest_const cst in (name, length lhs, cst);; let is_skip = function - | (_, Fconst (Cst_rec (_, args, _, Some n))) -> n <= List.length args + | (_, Fconst cst_rec) -> + let Cst_rec {skip; args} = cst_rec in + (match skip with + | Some n -> n <= List.length args + | None -> false) | _ -> false;; let partition_skip skip args = @@ -334,31 +335,30 @@ let partition_skip skip args = *---------------------------------------------------------------------------*) type compset = - Rws of ((string, (db * int option) ref) Hashtable.hashtable);; + Rws of (string, (db * int option) ref) Hashtbl.t;; -let empty_rws () = Rws (Hashtable.empty 100 string_hash String.compare);; +let empty_rws () = Rws (Hashtbl.create 100 String.hash String.compare);; let assoc_clause (Rws rws) cst = - match Hashtable.lookup rws cst with - | None -> - let mt = ref (End_db, None) in - Hashtable.insert rws cst mt; - mt - | Some r -> r;; + try Hashtbl.find rws cst + with Not_found -> + let mt = ref (End_db, None) in + Hashtbl.replace rws cst mt; + mt;; let add_in_db_upd rws (name, arity, hcst) act = let rl = assoc_clause rws name in - let db, sk = !rl in + let (db, sk) = !rl in rl := add_in_db (arity, hcst, act, db), sk;; let set_skip_name (Rws htbl as rws) p sk = let rl = assoc_clause rws p in - let db, _ = !rl in + let (db, _) = !rl in rl := db, sk;; let scrub_const (Rws htbl) c = let name, _ = dest_const c in - Hashtable.delete htbl name;; + Hashtbl.remove htbl name;; let from_term (rws, env, t) = let rec down (env, t, c) = @@ -387,13 +387,13 @@ let mk_rewrite rws eq_thm = let fv, cst, pats = check_arg_form lhs in let gen_thm = itlist GEN fv eq_thm in let rhsc = from_term (rws, rev fv, rhs) in - Rw (Rewrite_rec ( - (* cst = *) cst, - (* lhs = *) pats, - (* npv = *) length fv, - (* rhs = *) rhsc, - (* thm = *) gen_thm - ));; + Rw { + cst = cst; + lhs = pats; + rhs = rhsc; + npv = length fv; + thm = gen_thm + };; let unsuitable th = let l, r = dest_eq (concl th) in @@ -407,7 +407,7 @@ let enter_thm rws thm0 = add_in_db_upd rws (key_of rw) (Rewrite [rw]);; let add_thms lthm rws = - List.app (List.app (enter_thm rws) o BODY_CONJUNCTS) lthm;; + List.iter (List.iter (enter_thm rws) o BODY_CONJUNCTS) lthm;; let add_extern (cst, arity, fconv) rws = let name, _ = dest_const cst in @@ -426,7 +426,7 @@ let from_list lthm = let scrub_thms lthm rws = let tmlist = map (concl o hd o BODY_CONJUNCTS) lthm in let clist = map (fst o strip_comb o lhs o snd o strip_forall) tmlist in - List.app (scrub_const rws) clist;; + List.iter (scrub_const rws) clist;; (*---------------------------------------------------------------------------*) @@ -434,16 +434,16 @@ let scrub_thms lthm rws = (*---------------------------------------------------------------------------*) let rws_of (Rws htbl) = - let dblist = - List.map (fun (_, v) -> let (db, _) = !v in db) (Hashtable.toAscList htbl) in + let dblist = Hashtbl.fold (fun _ v r -> let (db, _) = !v in db :: r) htbl [] in let rec get_actions db = match db with | End_db -> [] | Need_arg db' -> get_actions db' - | Try (Try_rec (hcst, rws, tail)) -> + | Try try_rec -> + let Try_rec {hcst; rws; tail} = try_rec in (hcst, rws) :: get_actions tail in let actionlist = List.concat (List.map get_actions dblist) in - let dest (Rw (Rewrite_rec (_, _, _, _, thm))) = thm in + let dest (Rw {thm}) = thm in let dest_action = function | hcst, Rewrite rws -> (hcst, map dest rws) | hcst, Conv _ -> (hcst, []) in @@ -463,16 +463,16 @@ type transform = (*---------------------------------------------------------------------------*) let deplist (Rws htbl) = - let dblist = - List.map (fun (s, v) -> let (db, _) = !v in (s, db)) (Hashtable.toAscList htbl) in + let dblist = Hashtbl.fold (fun s v r -> let (db, _) = !v in (s, db) :: r) htbl [] in let rec get_actions db = match db with | End_db -> [] | Need_arg db' -> get_actions db' - | Try (Try_rec (hcst, rws, tail)) -> + | Try try_rec -> + let Try_rec {hcst; rws; tail} = try_rec in rws :: get_actions tail in let actionlist = List.map (fun (s, db) -> s, get_actions db) dblist in - let dest (Rw (Rewrite_rec (_, _, _, _, thm))) = thm in + let dest (Rw {thm}) = thm in let dest_action = function | Rewrite rws -> Rrules (map dest rws) | Conv ecnv -> Conversion ecnv in @@ -507,7 +507,7 @@ let match_const (bds, tbds) pc c = let match_var (bds, tbds) var arg = let _ = match bds.(var) with | Some (tm, _) -> if aconv tm (fst arg) then () else raise No_match - | None -> Array.update bds (var) (Some arg) in + | None -> Array.set bds var (Some arg) in (bds, tbds);; (*--------------------------------------------------------------------------- @@ -528,7 +528,8 @@ let rec match_list bds pats args = and match_solve bds pat arg = match (pat, arg) with | Pvar var, arg -> match_var bds var arg - | Papp (phead, pargs), (_, Fconst (Cst_rec (head, args, _, _))) -> + | Papp (phead, pargs), (_, Fconst cst_rec) -> + let Cst_rec {head; args} = cst_rec in if length pargs = length args then match_list (match_const bds phead head) pargs args else @@ -539,17 +540,18 @@ and match_solve bds pat arg = * Try a sequence of rewrite rules. No attempt to factorize patterns! *---------------------------------------------------------------------------*) -type 'a rule_inst = Rule_inst of ( - (* rule: *) rewrite * - (* inst: *) ((term * 'a fterm) option array * (hol_type * hol_type) list) -);; +type 'a rule_inst = Rule_inst of { + rule: rewrite; + inst: (term * 'a fterm) option array * (hol_type * hol_type) list +};; let try_rwn ibds lt = let rec try_rec = function | [] -> raise No_match - | (Rw (Rewrite_rec (_, lhs, npv, _, _)) as rw) :: rwn -> - let env = Array.array npv None in - try Rule_inst (rw, match_list (env, ibds) lhs lt) + | rw :: rwn -> + let Rw {lhs; npv} = rw in + let env = Array.make npv None in + try Rule_inst { rule = rw; inst = match_list (env, ibds) lhs lt } with No_match -> try_rec rwn in try_rec;; @@ -558,23 +560,23 @@ let try_rwn ibds lt = * Instantiating the rule according to the output of the matching. *---------------------------------------------------------------------------*) -let comb_ct cst arg = - match cst with - | Cst_rec (head, args, Need_arg tail, skip) -> - Fconst (Cst_rec (head, arg :: args, tail, skip)) - | Cst_rec (head, args, End_db, skip) -> - Fconst (Cst_rec (head, arg :: args, End_db, skip)) - | Cst_rec (_, _, Try _, _) -> - raise (Dead_code "comb_ct: yet rules to try");; +let comb_ct (Cst_rec {head; args; rws; skip}) arg = + match rws with + | Need_arg tail -> + Fconst (Cst_rec { head = head; args = arg :: args; rws = tail; skip = skip }) + | End_db -> + Fconst (Cst_rec { head = head; args = arg :: args; rws = End_db; skip = skip }) + | Try _ -> + raise (Dead_code "comb_ct: yet rules to try");; let mk_clos (env, t) = match t with - | Cst (hc, r) -> - let (db, b) = !r in - Fconst (Cst_rec (hc, [], db, b)) + | Cst (hc, v) -> + let (db, b) = !v in + Fconst (Cst_rec {head = hc; args = []; rws = db; skip = b}) | Bv i -> List.nth env i | Fv -> Neutr - | _ -> Clos (Clos_rec (env, t));; + | _ -> Clos (Clos_rec {env = env; term = t});; (*--------------------------------------------------------------------------- * It is probably this code that can be improved the most @@ -585,12 +587,12 @@ let inst_one_var (thm, lv) = function | None -> raise (Dead_code "inst_rw");; let inst_rw (th, monitoring, rule_inst) = - let Rule_inst (rule, inst) = rule_inst in - let (Rw (Rewrite_rec (_, _, _, rhs, thm))) = rule in + let Rule_inst {rule; inst} = rule_inst in + let Rw {thm; rhs} = rule in let (bds, tysub) = inst in let tirhs = inst_type_dterm (tysub, rhs) in let tithm = INST_TYPE tysub thm in - let spec_thm, venv = Array.foldl (flip inst_one_var) (tithm, []) bds in + let spec_thm, venv = Array.fold_left inst_one_var (tithm, []) bds in let () = if monitoring then print_term (concl spec_thm) in trans_thm th spec_thm, mk_clos (venv, tirhs);; @@ -601,8 +603,9 @@ let stoppers = ref (None: (term -> bool) option);; * Reducing a constant *---------------------------------------------------------------------------*) +(* intense record pattern matching let rec reduce_cst = function - | th, Cst_rec (head, args, Try (Try_rec (hcst, Rewrite rls, tail)), skip) -> + | th, {head = head; args = args; rws = Try {hcst = hcst; rws = Rewrite rls; tail = tail}; skip = skip} -> (try let () = match !stoppers with None -> () | Some p -> if p head then raise No_match else () in let _, _, tytheta = try term_match [] hcst head with _ -> raise No_match in @@ -611,14 +614,39 @@ let rec reduce_cst = function let insted = inst_rw (th, mon, rule_inst) in (true, insted) with No_match -> - reduce_cst (th, Cst_rec (head, args, tail, skip))) - | th, Cst_rec (head, args, Try (Try_rec (hcst, Conv fconv, tail)), skip) -> + reduce_cst (th, {head = head; args = args; rws = tail; skip = skip})) + | th, {head = head; args = args; rws = Try {hcst = hcst; rws = Conv fconv; tail = tail}; skip = skip} -> (try let thm, ft = fconv (rhs_concl th) in (true, (trans_thm th thm, ft)) with _ -> - reduce_cst (th, Cst_rec (head, args, tail, skip))) - | th, cst -> (false, (th, Fconst cst));; + reduce_cst (th, {head = head; args = args; rws = tail; skip = skip})) + | th, cst -> (false, (th, Const cst));; +*) + +let rec reduce_cst (th, cst_rec) = + (let Cst_rec {head; args; rws; skip} = cst_rec in + match rws with + | Try try_rec -> + let Try_rec {hcst; rws; tail} = try_rec in + (match rws with + | Rewrite rls -> + (try + let () = match !stoppers with None -> () | Some p -> if p head then raise No_match else () in + let (_, _, tytheta) = try term_match [] hcst head with _ -> raise No_match in + let rule_inst = try_rwn tytheta args rls in + let mon = match !monitoring with None -> false | Some f -> f head in + let insted = inst_rw (th, mon, rule_inst) in + (true, insted) + with No_match -> + reduce_cst (th, Cst_rec {head = head; args = args; rws = tail; skip = skip})) + | Conv fconv -> + (try + let thm, ft = fconv (rhs_concl th) in + (true, (trans_thm th thm, ft)) + with _ -> + reduce_cst (th, Cst_rec {head = head; args = args; rws = tail; skip = skip}))) + | _ -> (false, (th, Fconst cst_rec)));; (*** computeLib.sml ***) @@ -630,6 +658,11 @@ let auto_import_definitions = ref true;; let new_compset = from_list;; let listItems = deplist;; +type cbv_stack = + ((thm->thm->thm) * (thm * db fterm), + (thm->thm->thm) * bool * (thm * db fterm), + (thm->thm)) stack;; + let rec stack_out = function | th, Ztop -> th | th, Zrator ((mka, (thb, _)), ctx) -> stack_out (mka th thb, ctx) @@ -658,16 +691,32 @@ let initial_state rws t = * we try to rebuild the thm. *---------------------------------------------------------------------------*) +(* let rec cbv_wk = function - | (th, Clos (Clos_rec (env, App (a, args)))), stk -> + | (th, Clos {env = env; term = App (a, args)}), stk -> let tha, stka = rev_itlist (push_in_stk (curry mk_clos env)) args (th, stk) in cbv_wk ((tha, mk_clos (env, a)), stka) - | (th, Clos (Clos_rec (env, Dabs body))), Zrator ((mka, (thb, cl)), s') -> + | (th, Clos {env = env; term = Dabs body}), Zrator ((mka, (thb, cl)), s') -> cbv_wk ((beta_thm (mka th thb), mk_clos (cl :: env, body)), s') | (th, Fconst cargs), stk -> let reduced, clos = reduce_cst (th, cargs) in if reduced then cbv_wk (clos, stk) else cbv_up (clos, stk) | clos, stk -> cbv_up (clos, stk) +*) + +let rec cbv_wk = function + | (th, Clos clos_rec), stk -> + let Clos_rec {env; term} = clos_rec in + (match (term, stk) with + | (App (a, args), stk) -> + let tha, stka = rev_itlist (push_in_stk (curry mk_clos env)) args (th, stk) in + cbv_wk ((tha, mk_clos (env, a)), stka) + | (Dabs body, Zrator ((mka, (thb, cl)), s')) -> + cbv_wk ((beta_thm (mka th thb), mk_clos (cl :: env, body)), s')) + | (th, Fconst cargs), stk -> + let reduced, clos = reduce_cst (th, cargs) in + if reduced then cbv_wk (clos, stk) else cbv_up (clos, stk) + | clos, stk -> cbv_up (clos, stk) (*--------------------------------------------------------------------------- * Tries to rebuild the thm, knowing that the closure has been weakly @@ -696,13 +745,31 @@ and cbv_up = function * precondition: the closure should be the output of cbv_wk *---------------------------------------------------------------------------*) +(* let rec strong = function - | (th, Clos (Clos_rec (env, Dabs t))), stk -> + | (th, Clos {env = env; term = Dabs t}), stk -> let thb, stk' = push_lam_in_stk (th, stk) in strong (cbv_wk ((thb, mk_clos (Neutr :: env, t)), stk')) | (_, Clos _), stk -> raise (Dead_code "strong") - | (th, Fconst (Cst_rec (_, args, _, skip))), stk -> + | (th, Fconst {skip = skip; args = args}), stk -> + let argssk, argsrd = partition_skip skip args in + let th', stk' = rev_itlist (push_skip_stk snd) argssk (th, stk) in + let th'', stk'' = rev_itlist (push_in_stk snd) argsrd (th', stk') in + strong_up (th'', stk'') + | (th, Neutr), stk -> strong_up (th, stk) +*) + +let rec strong = function + | (th, Clos clos_rec), stk -> + let Clos_rec {env; term} = clos_rec in + (match term with + | Dabs t -> + let thb, stk' = push_lam_in_stk (th, stk) in + strong (cbv_wk ((thb, mk_clos (Neutr :: env, t)), stk')) + | _ -> raise (Dead_code "strong")) + | (th, Fconst cst_rec), stk -> + let Cst_rec {skip; args} = cst_rec in let argssk, argsrd = partition_skip skip args in let th', stk' = rev_itlist (push_skip_stk snd) argssk (th, stk) in let th'', stk'' = rev_itlist (push_in_stk snd) argsrd (th', stk') in @@ -785,7 +852,7 @@ let basic_compset () = let basic_rws = List.filter (fun th -> not (mem th lhs_lambda_rules)) basic_rws0 in let cs = new_compset (List.map lazyfy_thm basic_rws) in - List.app (fun (_,(pat,the_conv)) -> + List.iter (fun (_,(pat,the_conv)) -> let cst,args = strip_comb pat in add_conv (cst,length args,the_conv) cs) (basic_convs()); add_conv (`LET:(A->B)->A->B`,2,let_CONV) cs; @@ -798,9 +865,9 @@ let basic_compset () = let the_compset = bool_compset();; let add_funs = C add_thms the_compset;; -let add_convs = List.app (C add_conv the_compset);; +let add_convs = List.iter (C add_conv the_compset);; -let del_consts = List.app (scrub_const the_compset);; +let del_consts = List.iter (scrub_const the_compset);; let del_funs = C scrub_thms the_compset;; let EVAL_CONV = CBV_CONV the_compset;; diff --git a/define.ml b/define.ml index 9a59e955..b76730d3 100644 --- a/define.ml +++ b/define.ml @@ -839,7 +839,7 @@ let instantiate_casewise_recursion, W(fun (asl,w) -> MAP_EVERY (fun t -> SPEC_TAC(t,t)) (subtract (frees w) [ord])) THEN W(fun (asl,w) -> ACCEPT_TAC(ASSUME w)) in - let th2 = prove(bod,SIMP_ADMISS_TAC) in + let th2 = TAC_PROOF(([],bod),SIMP_ADMISS_TAC) in let th3 = SIMPLE_EXISTS ord th2 in let allasms = hyp th3 and wfasm = lhand(concl th2) in let th4 = ASSUME(list_mk_conj(wfasm::subtract allasms [wfasm])) in diff --git a/firstorder.ml b/firstorder.ml index f98f38cf..9aa541de 100644 --- a/firstorder.ml +++ b/firstorder.ml @@ -38,7 +38,9 @@ end module List = struct +(* include List +*) let cons x l = x :: l @@ -83,7 +85,7 @@ let rec findi p l = let concat_map f l = List.concat (List.map f l) -let fsum = List.fold_left (+.) 0. +let fsum = List.fold_left (+.) Float.zero let rec last = function [] -> failwith "last" @@ -136,8 +138,8 @@ end module Mapping = struct let reset_vars,fol_of_var,hol_of_var = - let vstore = ref [] - and gstore = ref [] + let vstore = ref ([]:(term * int) list) + and gstore = ref ([]:(term * int) list) and vcounter = ref 0 in let inc_vcounter() = let n = !vcounter in @@ -148,13 +150,14 @@ module Mapping = struct try assoc v !vstore with Failure _ -> let n = inc_vcounter() in if !copverb then - Format.printf "fol_of_var: %s (ty = %s) <- %d\n%!" - (string_of_term v) (string_of_type (type_of v)) n; - vstore := (v,n)::!vstore; n in + print_string (String.concat "" [ + "fol_of_var: "; string_of_term v; + " (ty = "; string_of_type (type_of v); ") <- "; string_of_int n; "\n"]); + vstore := (v,n)::(!vstore); n in let hol_of_var v ty = try rev_assoc v !gstore with Failure _ -> let gv = genvar ty in - gstore := (gv,v)::!gstore; gv in + gstore := (gv,v)::(!gstore); gv in reset_vars,fol_of_var,hol_of_var let reset_consts,fol_of_const,hol_of_const = @@ -214,7 +217,7 @@ module Mapping = struct without the full number of its arguments (due to partial application). Therefore obtain only as many types of arguments as present in the FO term. *) - assert (List.length args <= List.length tys); + (* assert (List.length args <= List.length tys); *) let tys' = Utils.List.take (List.length args) tys in list_mk_comb (f', List.map2 hol_of_term tys' args) @@ -248,7 +251,7 @@ module Mapping = struct else basics in fun thms -> let rawrules = itlist (union' eqt o fol_of_hol_clause) thms [] in - let prs = setify (map (fst o snd o fst) rawrules) in + let prs = setify (<=) (map (fst o snd o fst) rawrules) in let prules = map (fun t -> t,filter ((=) t o fst o snd o fst) rawrules) prs in let srules = sort (fun (p,_) (q,_) -> abs(p) <= abs(q)) prules in diff --git a/grobner.ml b/grobner.ml index dc19efed..06556132 100644 --- a/grobner.ml +++ b/grobner.ml @@ -179,9 +179,9 @@ let RING_AND_IDEAL_CONV = p,[] -> false | [],q -> true | (c1,m1)::o1,(c2,m2)::o2 -> + let m1_lt_m2 = List.compare Int.compare m1 m2 < 0in c1 basis | (l,(p1,p2))::opairs -> @@ -275,7 +275,8 @@ let RING_AND_IDEAL_CONV = let rec resolve_proof vars prf = match prf with - Start m -> if m = -1 then [] else [m,[num_1,map (K 0) vars]] + Start(-1) -> [] + | Start m -> [m,[num_1,map (K 0) vars]] | Mmul(pol,lin) -> let lis = resolve_proof vars lin in map (fun (n,p) -> n,grob_cmul pol p) lis @@ -489,8 +490,8 @@ let RING_AND_IDEAL_CONV = | (x,y)::t -> if x==a then y else assoceq a t in *) let run_proof = if is_iff(snd(strip_forall(concl RABINOWITSCH_THM))) then - (print "Generating HOL version of proof"; - print "\n"; + (Format.print_string("Generating HOL version of proof"); + Format.print_newline(); let execache = ref [] in let memoize prf x = (execache := (prf,x)::(!execache)); x in let rec run_proof vars prf = @@ -505,8 +506,8 @@ let RING_AND_IDEAL_CONV = let ans = run_proof vars prf in (execache := []; ans)) else - (print "Generating HOL version of scaled proof"; - print "\n"; + (Format.print_string("Generating HOL version of scaled proof"); + Format.print_newline(); let km = map (fun x -> 0) vars in let execache = ref [] in let memoize prf x = (execache := (prf,x)::(!execache)); x in @@ -559,8 +560,8 @@ let RING_AND_IDEAL_CONV = CONV_RULE(RAND_CONV(BINOP_CONV RING_NORMALIZE_CONV)) nth in let th2 = funpow deg (IDOM_RULE o CONJ th1) NOT_EQ_01 in vars,l,cert,th2 in - print "Translating certificate to HOL inferences"; - print "\n"; + Format.print_string("Translating certificate to HOL inferences"); + Format.print_newline(); let cert_pos = map (fun (i,p) -> i,filter (fun (c,m) -> c >/ num_0) p) cert and cert_neg = map diff --git a/hol_lib.ml b/hol_lib.ml index 8aaaf22c..2270e999 100644 --- a/hol_lib.ml +++ b/hol_lib.ml @@ -15,6 +15,16 @@ include Bignum;; open Hol_loader;; *) +(* ------------------------------------------------------------------------- *) +(* Make it harder to accidentally use CakeML-specific code and add a *) +(* compatiblity layer. *) +(* ------------------------------------------------------------------------- *) + +loads "candle_insulate.ml";; (* Auto-generated. Moves CakeML specifics. *) +loads "candle_nums.ml";; (* Load "num". *) +loads "candle_pretty.ml";; (* Pretty printer code. *) +loads "candle_ocaml.ml";; (* OCaml modules. *) + (* ------------------------------------------------------------------------- *) (* Bind these to names that are independent of OCaml versions before they *) (* are potentially overwritten by an identifier of the same name. In older *) @@ -24,24 +34,22 @@ open Hol_loader;; (* Pervasives.abs_float -> Stdlib.abs_float / Float.abs *) (* ------------------------------------------------------------------------- *) -let float_sqrt = Double.sqrt;; -let float_fabs = Double.abs;; +let float_sqrt = Float.sqrt;; +let float_fabs = Float.abs;; (* ------------------------------------------------------------------------- *) (* Various tweaks to OCaml and general library functions. *) (* ------------------------------------------------------------------------- *) -loads "system.ml";; (* Set up proper parsing *) -loads "candle_nums.ml";; (* Load "num" *) -loads "bignum_num.ml";; (* Load bignums *) -loads "lib.ml";; (* Various useful general library functions *) +loads "system.ml";; (* Set up proper parsing *) +loads "bignum_num.ml";; (* Load bignums *) +loads "lib.ml";; (* Various useful general library functions *) (* ------------------------------------------------------------------------- *) (* Candle things. *) (* ------------------------------------------------------------------------- *) loads "candle_kernel.ml";; (* Brings Candle kernel into scope. *) -loads "candle_pretty.ml";; (* Pretty printer code. *) (* ------------------------------------------------------------------------- *) (* Some extra support stuff needed outside the core. *) @@ -74,9 +82,7 @@ loads "class.ml";; (* Classical reasoning: Choice and Extensionality *) loads "trivia.ml";; (* Some very basic theories, e.g. type ":1" *) loads "canon.ml";; (* Tools for putting terms in canonical forms *) loads "meson.ml";; (* First order automation: MESON (model elimination) *) -(* loads "firstorder.ml";; (* More utilities for first-order shadow terms *) -*) loads "metis.ml";; (* More advanced first-order automation: Metis *) (* loads "thecops.ml";; (* Connection-based automation: leanCoP and nanoCoP *) @@ -119,5 +125,5 @@ let check_axioms () = let basic_axioms = [INFINITY_AX; SELECT_AX; ETA_AX] in let l = filter (fun th -> not (mem th basic_axioms)) (axioms()) in if l <> [] then - let msg = "[" ^ (String.concatWith ", " (map string_of_thm l)) ^ "]" in + let msg = "[" ^ (String.concat ", " (map string_of_thm l)) ^ "]" in failwith ("check_axioms: " ^ msg);; diff --git a/holtest.mk b/holtest.mk index 17d37757..042763f1 100644 --- a/holtest.mk +++ b/holtest.mk @@ -57,6 +57,7 @@ STANDALONE_EXAMPLES:=\ Examples/prover9 \ Examples/pseudoprime \ Library/q \ + Library/rabin_test \ Examples/rectypes \ Library/ringtheory \ Examples/safetyliveness \ @@ -110,6 +111,7 @@ EXTENDED_EXAMPLES:=\ Multivariate/homology \ Multivariate/lpspaces \ Multivariate/msum \ + Multivariate/paracompact \ Multivariate/specialtopologies \ Multivariate/tarski \ RichterHilbertAxiomGeometry/Topology \ @@ -133,6 +135,7 @@ GREAT_100_THEOREMS:= \ 100/combinations \ 100/constructible \ 100/cosine \ + 100/cubedissection \ 100/cubic \ 100/derangements \ 100/desargues \ diff --git a/impconv.ml b/impconv.ml index 7c613bc0..ea5068ce 100644 --- a/impconv.ml +++ b/impconv.ml @@ -216,7 +216,7 @@ let MP_CLOSURE ths1 ths2 = (* Set of terms. Implemented as ordered lists. *) module Tset = struct (*type t = term list*) (* TODO Makes CakeML pretty printer system dizzy *) - let lift f = List.sort Term.(<) o f + let lift f = List.sort Term.compare o f let of_list = lift I let insert ts t = let rec self xs = match xs with diff --git a/ind_defs.ml b/ind_defs.ml index 43cc6fbc..6ce5a4f3 100644 --- a/ind_defs.ml +++ b/ind_defs.ml @@ -341,7 +341,7 @@ let prove_inductive_relations_exist,new_inductive_definition = clauses in let schems = setify Term.(<) schem in if is_var(hd schem) then (clauses,[]) else - if not (length(setify (fun x y -> List.compare Term.compare x y = Less) + if not (length(setify (fun x y -> List.compare Term.compare x y < 0) (map (snd o strip_comb) schems)) = 1) then failwith "Schematic variables not used consistently" else let avoids = variables (list_mk_conj clauses) in diff --git a/ind_types.ml b/ind_types.ml index f9cc2727..8ec6b99e 100755 --- a/ind_types.ml +++ b/ind_types.ml @@ -1164,9 +1164,8 @@ let define_type_raw = and pevs1,pbod1 = strip_exists (concl sth1) in let pcjs0,qcjs0 = chop_list k (conjuncts pbod0) and pcjs1,qcjs1 = chop_list k (snd(chop_list n (conjuncts pbod1))) in - let tyal0 = - setify (fun x y -> Pair.compare Type.compare Type.compare x y = Less) - (zip (map grab_type pcjs1) (map grab_type pcjs0)) in + let pty_lt x y = Pair.compare Type.compare Type.compare x y < 0 in + let tyal0 = setify pty_lt (zip (map grab_type pcjs1) (map grab_type pcjs0)) in let tyal1 = map (fun (a,b) -> (b,a)) tyal0 in let tyins0 = map (fun f -> let domty,ranty = dest_fun_ty (type_of f) in @@ -1402,9 +1401,10 @@ let define_type s = let defspec = parse_inductive_type_specification s in let newtypes = map fst defspec and constructors = itlist ((@) o map fst) (map snd defspec) [] in + let str_lt x y = String.compare x y < 0 in if not(length(setify Type.(<) newtypes) = length newtypes) then failwith "define_type: multiple definitions of a type" - else if not(length(setify String.(<) constructors) = length constructors) + else if not(length(setify str_lt constructors) = length constructors) then failwith "define_type: multiple instances of a constructor" else if exists (can get_type_arity o dest_vartype) newtypes then let t = find (can get_type_arity) (map dest_vartype newtypes) in diff --git a/int.ml b/int.ml index 34a9461e..ba8f86dc 100755 --- a/int.ml +++ b/int.ml @@ -1893,6 +1893,38 @@ let INT_REM_DOWN_CONV = INT_POW_REM; INT_REM_REM] tm in downconv THENC upconv;; +(* ------------------------------------------------------------------------- *) +(* Reduction of (a pow k) rem n keeping intermediates reduced. *) +(* ------------------------------------------------------------------------- *) + +let INT_POW_REM_CONV = + let pth_0,pth_1 = (CONJ_PAIR o prove) + (`((&m pow k) rem &n = &(m EXP k MOD n) /\ + (&m pow k) rem (-- &n) = &(m EXP k MOD n)) /\ + ((-- &m pow k) rem &n = + if EVEN k then &(m EXP k MOD n) else (-- &(m EXP k MOD n)) rem &n) /\ + ((-- &m pow k) rem (-- &n) = + if EVEN k then &(m EXP k MOD n) else (-- &(m EXP k MOD n)) rem &n)`, + REWRITE_TAC[INT_REM_RNEG; INT_POW_NEG] THEN + COND_CASES_TAC THEN + ASM_REWRITE_TAC[GSYM INT_OF_NUM_CLAUSES; GSYM INT_OF_NUM_REM] THEN + CONV_TAC INT_REM_DOWN_CONV THEN REFL_TAC) in + let conv = + (GEN_REWRITE_CONV I [pth_0] THENC RAND_CONV EXP_MOD_CONV) ORELSEC + (GEN_REWRITE_CONV I [pth_1] THENC + RATOR_CONV(LAND_CONV NUM_EVEN_CONV) THENC + GEN_REWRITE_CONV I [COND_CLAUSES] THENC + (RAND_CONV EXP_MOD_CONV ORELSEC + (LAND_CONV + (RAND_CONV(RAND_CONV EXP_MOD_CONV THENC TRY_CONV INT_NEG_CONV)) THENC + INT_REM_CONV))) in + fun tm -> + match tm with + Comb(Comb(Const("rem",_), + Comb(Comb(Const("int_pow",_),m),k)),n) + when is_intconst m && is_numeral k && is_intconst n -> conv tm + | _ -> failwith "INT_POW_REM_CONV";; + (* ------------------------------------------------------------------------- *) (* Existence of integer gcd, and the Bezout identity. *) (* ------------------------------------------------------------------------- *) diff --git a/itab.ml b/itab.ml index c1a4a2c2..1fd03148 100644 --- a/itab.ml +++ b/itab.ml @@ -13,11 +13,44 @@ needs "tactics.ml";; (* Accept a theorem modulo unification. *) (* ------------------------------------------------------------------------- *) -let UNIFY_ACCEPT_TAC mvs th (asl,w) = - let insts = term_unify mvs (concl th) w in - ([],insts),[], - let th' = INSTANTIATE insts th in - fun i [] -> INSTANTIATE i th';; +let UNIFY_ACCEPT_TAC (mvs:term list) (th:thm):tactic = + fun (asl,w) -> + let insts = term_unify mvs (concl th) w in + ([],insts),[], + let th' = INSTANTIATE insts th in + fun i [] -> INSTANTIATE i th';; + +(* REFL version of UNIFY_ACCEPT_TAC. + The conclusion ust be `expr = x` where x is a meta variable. + It can be `expr = f x y z` where f is a meta variable as well. +*) +let UNIFY_REFL_TAC: tactic = + fun (asl,w:goal) -> + let w_lhs,w_rhs = dest_eq w in + if is_var w_rhs then + if vfree_in w_rhs w_lhs then + failwith ("UNIFY_REFL_TAC: failed: `" ^ (string_of_term w) ^ "`") + else + UNIFY_ACCEPT_TAC [w_rhs] (REFL w_lhs) (asl,w) + else + let constr,rargs = strip_comb w_rhs in + if not (is_var constr) then failwith "UNIFY_REFL_TAC: not variable" else + if vfree_in constr w_lhs then + failwith ("UNIFY_REFL_TAC: failed: `" ^ (string_of_term w) ^ "`") + else + (* replace non-variable arguments of the RHS function with temporary + variables. *) + let rargs_vars = map + (fun v -> if is_var v then v else + let _ = print_string + ("UNIFY_REFL_TAC: warning: this isn't var: " ^ + string_of_term v ^ "\n") in genvar (type_of v)) rargs in + let f = list_mk_abs (rargs_vars,w_lhs) in + let the_goal = mk_eq (w_lhs, list_mk_comb (f,rargs)) in + let th = prove(the_goal, + CONV_TAC (RAND_CONV (DEPTH_CONV BETA_CONV)) THEN + REFL_TAC) in + UNIFY_ACCEPT_TAC [constr] th (asl,w);; (* ------------------------------------------------------------------------- *) (* The actual prover, as a tactic. *) diff --git a/lib.ml b/lib.ml index 9b65335f..45f05e15 100755 --- a/lib.ml +++ b/lib.ml @@ -67,11 +67,12 @@ let rec butlast l = let rec el n l = if n = 0 then hd l else el (n - 1) (tl l);; -let rec rev acc l = - match l with - [] -> acc - | h::t -> rev (h::acc) t;; -let rev l = rev [] l;; +let rev l = + let rec rev_append acc l = + match l with + [] -> acc + | h::t -> rev_append (h::acc) t in + rev_append [] l;; let rec map2 f l1 l2 = match (l1,l2) with @@ -79,6 +80,12 @@ let rec map2 f l1 l2 = | (h1::t1),(h2::t2) -> let h = f h1 h2 in h::(map2 f t1 t2) | _ -> failwith "map2: length mismatch";; +let mapi f xs = + let rec aux i f = function + [] -> [] + | h::tl -> (f i h)::(aux (i + 1) f tl) + in aux 0 f xs + (* ------------------------------------------------------------------------- *) (* Attempting function or predicate applications. *) (* ------------------------------------------------------------------------- *) @@ -205,23 +212,24 @@ let rec exists p l = [] -> false | h::t -> p(h) || exists p t;; -let rec length k l = - if l = [] then k else length (k + 1) (tl l);; -let length l = length 0 l;; +let length l = + let rec len k l = + if l = [] then k else len (k + 1) (tl l) in + len 0 l;; let rec filter p l = match l with [] -> l | h::t -> let t' = filter p t in - if p(h) then if t'==t then l else h::t' + if p(h) then (* if t'==t then l else *) h::t' else t';; let rec partition p l = match l with [] -> [],l | h::t -> let yes,no = partition p t in - if p(h) then (if yes == t then l,[] else h::yes,no) - else (if no == t then [],l else yes,h::no);; + if p(h) then ((* if yes == t then l,[] else *) h::yes,no) + else ((* if no == t then [],l else *) yes,h::no);; let rec mapfilter f l = match l with @@ -312,11 +320,10 @@ let rec zip l1 l2 = | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2) | _ -> failwith "zip";; -let rec unzip xs = - match xs with - | [] -> [],[] - | ((a,b)::rest) -> let alist,blist = unzip rest in - (a::alist,b::blist);; +let rec unzip = + function [] -> [],[] + | ((a,b)::rest) -> let alist,blist = unzip rest in + (a::alist,b::blist);; (* ------------------------------------------------------------------------- *) (* Sharing out a list according to pattern in list-of-lists. *) @@ -355,7 +362,7 @@ let rec uniq l = match l with x::(y::_ as t) -> let t' = uniq t in if x = y then t' else - if t'==t then l else x::t' + (* if t'==t then l else *) x::t' | _ -> l;; (* ------------------------------------------------------------------------- *) @@ -368,29 +375,23 @@ let setify (<=) s = uniq (sort (fun x y -> x <= y) s);; (* String operations (surely there is a better way...) *) (* ------------------------------------------------------------------------- *) -let implode = String.concat;; - (* Woah: *) - (* itlist (^) l "";; *) +let implode l = itlist (^) l "";; let explode s = let rec exap n l = if n < 0 then l else - exap (n - 1) ((String.substring s n 1)::l) in - exap (String.size s - 1) [];; + exap (n - 1) ((String.sub s n 1)::l) in + exap (String.length s - 1) [];; (* ------------------------------------------------------------------------- *) (* Greatest common divisor. *) (* ------------------------------------------------------------------------- *) -let gcd = Int.gcd;; - -(* let gcd = let rec gxd x y = if y = 0 then x else gxd y (x mod y) in fun x y -> let x' = abs x and y' = abs y in if x' < y' then gxd y' x' else gxd x' y';; -*) (* ------------------------------------------------------------------------- *) (* Some useful functions on "num" type. *) @@ -438,7 +439,7 @@ let rec allpairs f l1 l2 = (* ------------------------------------------------------------------------- *) let report s = - print s; print "\n";; + Format.print_string s; Format.print_newline();; (* ------------------------------------------------------------------------- *) (* Convenient function for issuing a warning. *) @@ -467,16 +468,16 @@ let remark s = let time f x = if not (!report_timing) then f x else - let start_time = (* Sys.time() *) 0 in + let start_time = Sys.time() in try let result = f x in - let finish_time = (* Sys.time()*) 0 in - report("CPU time (user): "^(string_of_int(finish_time - start_time))); + let finish_time = Sys.time() in + report("CPU time (user): "^(string_of_float(finish_time -. start_time))); result with e -> - let finish_time = (* Sys.time() *) 0 in - (* let msg = Printexc.to_string e in *) + let finish_time = Sys.time() in + let msg = Printexc.to_string e in report("Failed after (user) CPU time of "^ - (string_of_int(finish_time - start_time))^": "(* ^msg *)); + (string_of_float(finish_time -. start_time))^": "^msg); raise e;; (* ------------------------------------------------------------------------- *) @@ -497,11 +498,13 @@ let rec rev_assocd a l d = (* Version of map that avoids rebuilding unchanged subterms. *) (* ------------------------------------------------------------------------- *) +(* let rec qmap f l = match l with h::t -> let h' = f h and t' = qmap f t in if h' == h && t' == t then l else h'::t' | _ -> l;; +*) (* ------------------------------------------------------------------------- *) (* Merging and bottom-up mergesort. *) @@ -528,11 +531,11 @@ let mergesort ord = (* Common measure predicates to use with "sort". *) (* ------------------------------------------------------------------------- *) -(* TODO These seem like they're not in use *) - -let increasing (<) f x y = f x < f y;; +(* +let increasing f x y = compare (f x) (f y) < 0;; -let decreasing (>) f x y = f x > f y;; +let decreasing f x y = compare (f x) (f y) > 0;; +*) (* ------------------------------------------------------------------------- *) (* Polymorphic finite partial functions via Patricia trees. *) @@ -543,6 +546,13 @@ let decreasing (>) f x y = f x > f y;; (* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). *) (* ------------------------------------------------------------------------- *) +(* +type ('a,'b)func = + Empty + | Leaf of int * ('a*'b)list + | Branch of int * int * ('a,'b)func * ('a,'b)func;; +*) + (* OA: I can't map anything I want into an integer, but I can attach a comparison function to the tree. You loose the canonicity property described above @@ -550,7 +560,7 @@ let decreasing (>) f x y = f x > f y;; types, anyway, if you need to compare functions. *) -type ('a,'b) func = Func of ('a -> 'a -> ordering) * ('a * 'b) list;; +type ('a,'b) func = Func of ('a -> 'a -> int) * ('a * 'b) list;; let pp_func pk pv (Func (cmp, f)) = Pretty_printer.app_block "func" @@ -561,12 +571,23 @@ let pp_func pk pv (Func (cmp, f)) = (* Undefined function. *) (* ------------------------------------------------------------------------- *) +(* +let undefined = Empty;; +*) + let undefined cmp = Func (cmp, []);; (* ------------------------------------------------------------------------- *) (* In case of equality comparison worries, better use this. *) (* ------------------------------------------------------------------------- *) +(* +let is_undefined f = + match f with + Empty -> true + | _ -> false;; +*) + let is_undefined (Func (_, f)) = match f with [] -> true @@ -576,12 +597,52 @@ let is_undefined (Func (_, f)) = (* Operation analagous to "map" for lists. *) (* ------------------------------------------------------------------------- *) +(* +let mapf = + let rec map_list f l = + match l with + [] -> [] + | (x,y)::t -> (x,f(y))::(map_list f t) in + let rec mapf f t = + match t with + Empty -> Empty + | Leaf(h,l) -> Leaf(h,map_list f l) + | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in + mapf;; +*) + let mapf f (Func (cmp, t)) = Func (cmp, map (I F_F f) t);; (* ------------------------------------------------------------------------- *) (* Operations analogous to "fold" for lists. *) (* ------------------------------------------------------------------------- *) +(* +let foldl = + let rec foldl_list f a l = + match l with + [] -> a + | (x,y)::t -> foldl_list f (f a x y) t in + let rec foldl f a t = + match t with + Empty -> a + | Leaf(h,l) -> foldl_list f a l + | Branch(p,b,l,r) -> foldl f (foldl f a l) r in + foldl;; + +let foldr = + let rec foldr_list f l a = + match l with + [] -> a + | (x,y)::t -> f x y (foldr_list f t a) in + let rec foldr f t a = + match t with + Empty -> a + | Leaf(h,l) -> foldr_list f l a + | Branch(p,b,l,r) -> foldr f l (foldr f r a) in + foldr;; +*) + let rec foldl f a = function [] -> a | (x,y)::xs -> foldl f (f a x y) xs;; @@ -596,28 +657,54 @@ let foldr f (Func (_, t)) a = foldr f a t;; (* Mapping to sorted-list representation of the graph, domain and range. *) (* ------------------------------------------------------------------------- *) +(* +let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);; + +let dom f = setify(foldl (fun a x y -> x::a) [] f);; + +let ran f = setify(foldl (fun a x y -> y::a) [] f);; +*) + let graph (Func (cmp, t)) vcmp = - setify (fun x y -> Pair.compare cmp vcmp x y <> Greater) t;; + setify (fun x y -> Pair.compare cmp vcmp x y <> 1) t;; let dom (Func (cmp, t)) = - setify (fun x y -> cmp x y <> Greater) (map fst t);; + setify (fun x y -> cmp x y <> 1) (map fst t);; let ran (Func (cmp, t)) vcmp = - setify (fun x y -> vcmp x y <> Greater) (map snd t);; + setify (fun x y -> vcmp x y <> 1) (map snd t);; (* ------------------------------------------------------------------------- *) (* Application. *) (* ------------------------------------------------------------------------- *) +(* +let applyd = + let rec apply_listd l d x = + match l with + (a,b)::t -> let c = compare x a in + if c = 0 then b else if c > 0 then apply_listd t d x else d x + | [] -> d x in + fun f d x -> + let k = Hashtbl.hash x in + let rec look t = + match t with + Leaf(h,l) when h = k -> apply_listd l d x + | Branch(p,b,l,r) when (k lxor p) land (b - 1) = 0 + -> look (if k land b = 0 then l else r) + | _ -> d x in + look f;; + *) + let applyd (Func (cmp, f)) d x' = let rec look t = match t with | [] -> d x' | (x,y)::xs -> - match cmp x' x with - | Less -> d x' - | Greater -> look xs - | Equal -> y in + let cmpr = cmp x' x in + if cmpr < 0 then d x' + else if cmpr > 0 then look xs + else y in look f;; let apply f = applyd f (fun x -> failwith "apply");; @@ -630,29 +717,155 @@ let defined f x = try apply f x; true with Failure _ -> false;; (* Undefinition. *) (* ------------------------------------------------------------------------- *) +(* +let undefine = + let rec undefine_list x l = + match l with + (a,b as ab)::t -> + let c = compare x a in + if c = 0 then t + else if c < 0 then l else + let t' = undefine_list x t in + if t' == t then l else ab::t' + | [] -> [] in + fun x -> + let k = Hashtbl.hash x in + let rec und t = + match t with + Leaf(h,l) when h = k -> + let l' = undefine_list x l in + if l' == l then t + else if l' = [] then Empty + else Leaf(h,l') + | Branch(p,b,l,r) when k land (b - 1) = p -> + if k land b = 0 then + let l' = und l in + if l' == l then t + else (match l' with Empty -> r | _ -> Branch(p,b,l',r)) + else + let r' = und r in + if r' == r then t + else (match r' with Empty -> l | _ -> Branch(p,b,l,r')) + | _ -> t in + und;; +*) + let rec undefine x' cmp t = match t with | [] -> t | (x,y)::xs -> - match cmp x' x with - | Equal -> xs - | Less -> t - | Greater -> (x,y)::undefine x' cmp xs;; + let cmpr = cmp x' x in + if cmpr < 0 then t + else if cmpr > 0 then (x,y)::undefine x' cmp xs + else xs;; let undefine x' (Func (cmp, t)) = Func (cmp, undefine x' cmp t);; (* ------------------------------------------------------------------------- *) (* Redefinition and combination. *) (* ------------------------------------------------------------------------- *) +(* +let (|->),combine = + let newbranch p1 t1 p2 t2 = + let zp = p1 lxor p2 in + let b = zp land (-zp) in + let p = p1 land (b - 1) in + if p1 land b = 0 then Branch(p,b,t1,t2) + else Branch(p,b,t2,t1) in + let rec define_list (x,y as xy) l = + match l with + (a,b as ab)::t -> + let c = compare x a in + if c = 0 then xy::t + else if c < 0 then xy::l + else ab::(define_list xy t) + | [] -> [xy] + and combine_list op z l1 l2 = + match (l1,l2) with + [],_ -> l2 + | _,[] -> l1 + | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) -> + let c = compare x1 x2 in + if c < 0 then xy1::(combine_list op z t1 l2) + else if c > 0 then xy2::(combine_list op z l1 t2) else + let y = op y1 y2 and l = combine_list op z t1 t2 in + if z(y) then l else (x1,y)::l in + let (|->) x y = + let k = Hashtbl.hash x in + let rec upd t = + match t with + Empty -> Leaf (k,[x,y]) + | Leaf(h,l) -> + if h = k then Leaf(h,define_list (x,y) l) + else newbranch h t k (Leaf(k,[x,y])) + | Branch(p,b,l,r) -> + if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y])) + else if k land b = 0 then Branch(p,b,upd l,r) + else Branch(p,b,l,upd r) in + upd in + let rec combine op z t1 t2 = + match (t1,t2) with + Empty,_ -> t2 + | _,Empty -> t1 + | Leaf(h1,l1),Leaf(h2,l2) -> + if h1 = h2 then + let l = combine_list op z l1 l2 in + if l = [] then Empty else Leaf(h1,l) + else newbranch h1 t1 h2 t2 + | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) -> + if k land (b - 1) = p then + if k land b = 0 then + (match combine op z lf l with + Empty -> r | l' -> Branch(p,b,l',r)) + else + (match combine op z lf r with + Empty -> l | r' -> Branch(p,b,l,r')) + else + newbranch k lf p br + | (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) -> + if k land (b - 1) = p then + if k land b = 0 then + (match combine op z l lf with + Empty -> r | l' -> Branch(p,b,l',r)) + else + (match combine op z r lf with + Empty -> l | r' -> Branch(p,b,l,r')) + else + newbranch p br k lf + | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) -> + if b1 < b2 then + if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2 + else if p2 land b1 = 0 then + (match combine op z l1 t2 with + Empty -> r1 | l -> Branch(p1,b1,l,r1)) + else + (match combine op z r1 t2 with + Empty -> l1 | r -> Branch(p1,b1,l1,r)) + else if b2 < b1 then + if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2 + else if p1 land b2 = 0 then + (match combine op z t1 l2 with + Empty -> r2 | l -> Branch(p2,b2,l,r2)) + else + (match combine op z t1 r2 with + Empty -> l2 | r -> Branch(p2,b2,l2,r)) + else if p1 = p2 then + (match (combine op z l1 l2,combine op z r1 r2) with + (Empty,r) -> r | (l,Empty) -> l | (l,r) -> Branch(p1,b1,l,r)) + else + newbranch p1 t1 p2 t2 in + (|->),combine;; +*) + let (|->) x y (Func (cmp, t)) = let rec ins x y t = match t with | [] -> [(x,y)] | (x',y')::xs -> - match cmp x x' with - | Less -> (x,y)::t - | Greater -> (x',y')::ins x y xs - | Equal -> (x,y)::xs in + let cmpr = cmp x x' in + if cmpr < 0 then (x,y)::t + else if cmpr > 0 then (x',y')::ins x y xs + else (x,y)::xs in Func (cmp, ins x y t);; let combine op z (Func (cmp, t1)) (Func (_, t2)) = @@ -661,13 +874,13 @@ let combine op z (Func (cmp, t1)) (Func (_, t2)) = | [], _ -> l2 | _, [] -> l1 | (x1,y1)::t1, (x2,y2)::t2 -> - match cmp x1 x2 with - | Less -> (x1,y1)::combine t1 l2 - | Greater -> (x2,y2)::combine l1 t2 - | Equal -> - let y = op y1 y2 in - let t = combine t1 t2 in - if z y then t else (x1,y)::t in + let cmpr = cmp x1 x2 in + if cmpr < 0 then (x1,y1)::combine t1 l2 + else if cmpr > 0 then (x2,y2)::combine l1 t2 + else + let y = op y1 y2 in + let t = combine t1 t2 in + if z y then t else (x1,y)::t in Func (cmp, combine t1 t2);; (* ------------------------------------------------------------------------- *) @@ -680,6 +893,14 @@ let (|=>) = fun x y cmp -> (x |-> y) (undefined cmp);; (* Grab an arbitrary element. *) (* ------------------------------------------------------------------------- *) +(* +let rec choose t = + match t with + Empty -> failwith "choose: completely undefined function" + | Leaf(h,l) -> hd l + | Branch(b,p,t1,t2) -> choose t1;; +*) + let choose (Func (_, t)) = try hd t with Failure _ -> @@ -689,12 +910,12 @@ let choose (Func (_, t)) = (* Install a trivial printer for the general polymorphic case. *) (* ------------------------------------------------------------------------- *) -(* Can't do it. *) (* let pp_print_fpf fmt (f:('a,'b)func) = Format.pp_print_string fmt "";; let print_fpf f = pp_print_fpf Format.std_formatter f;; *) + (* ------------------------------------------------------------------------- *) (* Set operations parametrized by equality (from Steven Obua). *) (* ------------------------------------------------------------------------- *) @@ -748,33 +969,22 @@ let num_of_string = (* ------------------------------------------------------------------------- *) let strings_of_file filename = - let fd = try Text_io.openIn filename - with Text_io.Bad_file_name -> - failwith("strings_of_file: can't open "^filename) in + let fd = + try open_in filename + with Sys_error _ -> failwith("strings_of_file: can't open "^filename) in let rec suck_lines acc = - match Text_io.inputLine '\n' fd with - | Some l -> suck_lines (l::acc) - | None -> rev acc in + let l = try [input_line fd] with End_of_file -> [] in + if l = [] then rev acc else suck_lines(hd l::acc) in let data = suck_lines [] in - Text_io.closeIn fd; data;; + (close_in fd; data);; let string_of_file filename = - let fd = try Text_io.openIn filename - with Text_io.Bad_file_name -> - failwith("string_of_file: can't open "^filename) in + let fd = + try open_in filename + with Sys_error _ -> failwith("string_of_file: can't open "^filename) in let data = Text_io.inputAll fd in - Text_io.closeIn fd; data;; + (close_in fd; data);; let file_of_string filename s = - let fd = Text_io.openOut filename in - Text_io.output fd s; Text_io.closeOut fd;; - -(* TODO Painful use of Word64s which are always boxed; prime candidate for - writing in Pancake that's embedded, once that's possible. At that point, - it should probably move to CakeML as well. *) -(* Adapted from http://www.cse.yorku.ca/~oz/hash.html (djb2) *) -let string_hash s = - let times_33 w = (Word64.(+) (Word64.(<<) w 5) w) in - let step char hash = - Word64.xorb (times_33 hash) (Word64.fromInt (Char.ord char)) in - Word64.toInt (List.foldl step (Word64.fromInt 5381) (String.explode s));; + let fd = open_out filename in + output_string fd s; close_out fd;; diff --git a/lists.ml b/lists.ml index 83d0232b..2b0cfa1b 100644 --- a/lists.ml +++ b/lists.ml @@ -524,6 +524,12 @@ let MAP_I = prove (`MAP (I:A->A) = I`, REWRITE_TAC[FUN_EQ_THM; I_DEF; MAP_ID]);; +let BUTLAST_CLAUSES = prove + (`BUTLAST([]:A list) = [] /\ + (!a:A. BUTLAST [a] = []) /\ + (!(a:A) h t. BUTLAST(CONS a (CONS h t)) = CONS a (BUTLAST(CONS h t)))`, + REWRITE_TAC[BUTLAST; NOT_CONS_NIL]);; + let BUTLAST_APPEND = prove (`!l m:A list. BUTLAST(APPEND l m) = if m = [] then BUTLAST l else APPEND l (BUTLAST m)`, @@ -895,8 +901,8 @@ let dest_char,mk_char,dest_string,mk_string,CHAR_EQ_CONV,STRING_EQ_CONV = try let tms = dest_list tm in if fst(dest_type(hd(snd(dest_type(type_of tm))))) <> "char" then fail() else - let ccs = map (String.str o char_of_term) tms in - string_escaped (implode ccs) + let ccs = map (String.make 1 o char_of_term) tms in + String.escaped (implode ccs) with Failure _ -> failwith "dest_string" in let mk_bool b = let true_tm,false_tm = `T`,`F` in @@ -906,12 +912,12 @@ let dest_char,mk_char,dest_string,mk_string,CHAR_EQ_CONV,STRING_EQ_CONV = let mk_code c = let lis = map (fun i -> mk_bool((c / (1 lsl i)) mod 2 = 1)) (0--7) in itlist (fun x y -> mk_comb(y,x)) lis ascii_tm in - let codes = Array.fromList (List.map mk_code (0--255)) in - fun c -> Array.sub codes c in - let mk_char = mk_code o Char.ord in + let codes = Array.map mk_code (Array.of_list (0--255)) in + fun c -> Array.get codes c in + let mk_char = mk_code o Char.code in let mk_string s = - let ns = map (fun i -> Char.ord(String.sub s i)) - (0--(String.size s - 1)) in + let ns = map (fun i -> Char.code(String.get s i)) + (0--(String.length s - 1)) in mk_list(map mk_code ns,`:char`) in let CHAR_DISTINCTNESS = let avars,bvars,cvars = diff --git a/meson.ml b/meson.ml index 1a4edc94..16dab215 100644 --- a/meson.ml +++ b/meson.ml @@ -82,7 +82,7 @@ module Meson = struct let qpartition p m = let rec qpartition l = - if l == m then raise Unchanged else + (* if l == m then raise Unchanged else *) match l with [] -> raise Unchanged | (h::t) -> if p h then @@ -204,12 +204,12 @@ module Meson = struct match tm with Fvar v -> rev_assocd v theta tm | Fnapp(f,args) -> - let args' = qmap (fol_subst theta) args in - if args' == args then tm else Fnapp(f,args') + let args' = map (fol_subst theta) args in + (* if args' == args then tm else *) Fnapp(f,args') let fol_inst theta ((p,args) as at:fol_atom) = - let args' = qmap (fol_subst theta) args in - if args' == args then at else p,args' + let args' = map (fol_subst theta) args in + (* if args' == args then at else *) p,args' let rec fol_subst_bump offset theta tm = match tm with @@ -219,12 +219,12 @@ module Meson = struct else rev_assocd v theta tm | Fnapp(f,args) -> - let args' = qmap (fol_subst_bump offset theta) args in - if args' == args then tm else Fnapp(f,args') + let args' = map (fol_subst_bump offset theta) args in + (* if args' == args then tm else *) Fnapp(f,args') let fol_inst_bump offset theta ((p,args) as at:fol_atom) = - let args' = qmap (fol_subst_bump offset theta) args in - if args' == args then at else p,args' + let args' = map (fol_subst_bump offset theta) args in + (* if args' == args then at else *) p,args' (* ----------------------------------------------------------------------- *) (* Main unification function, maintaining a "graph" instantiation. *) @@ -264,7 +264,7 @@ module Meson = struct (* ----------------------------------------------------------------------- *) let rec fol_eq insts tm1 tm2 = - tm1 == tm2 || + (* tm1 == tm2 || *) match tm1,tm2 with Fnapp(f,fargs),Fnapp(g,gargs) -> f = g && forall2 (fol_eq insts) fargs gargs @@ -452,24 +452,25 @@ module Meson = struct Interrupt.poll (); if n > max then failwith "solve_goal: Too deep" else (if !meson_chatty && !verbose then - (print + (Format.print_string ((string_of_int (!inferences))^" inferences so far. "^ "Searching with maximum size "^(string_of_int n)^"."); - print"\n") + Format.print_newline()) else if !verbose then - print(string_of_int (!inferences)^"..") + (Format.print_string(string_of_int (!inferences)^".."); + Format.print_flush()) else ()); try let gi = if incdepth then expand_goal rules g n 100000 (fun x -> x) else expand_goal rules g 100000 n (fun x -> x) in (if !meson_chatty && !verbose then - (print + (Format.print_string ("Goal solved with "^(string_of_int (!inferences))^ " inferences."); - print"\n") + Format.print_newline()) else if !verbose then - (print("solved at "^string_of_int (!inferences)); - print"\n") + (Format.print_string("solved at "^string_of_int (!inferences)); + Format.print_newline()) else ()); gi with Failure _ -> solve (n + incsize) g in @@ -500,7 +501,7 @@ module Meson = struct else basics in fun thms -> let rawrules = itlist (union' eqt o fol_of_hol_clause) thms [] in - let prs = setify Int.(<) (map (fst o snd o fst) rawrules) in + let prs = setify (<) (map (fst o snd o fst) rawrules) in let prules = map (fun t -> t,filter ((=) t o fst o snd o fst) rawrules) prs in let srules = sort (fun (p,_) (q,_) -> abs(p) <= abs(q)) prules in @@ -734,7 +735,7 @@ module Meson = struct match l with x::(y::_ as t) -> let t' = uniq' eq t in if eq x y then t' else - if t'==t then l else x::t' + (* if t'==t then l else *) x::t' | _ -> l in let setify' le eq s = uniq' eq (sort le s) in let rec grab_constants tm acc = @@ -756,7 +757,8 @@ module Meson = struct let tyins = mapfilter match_consts (allpairs (fun x y -> x,y) pconsts mconsts) in let ths' = - setify' Thm.(<) equals_thm (mapfilter (C INST_TYPE th) tyins) in + setify' Thm.(<=) + equals_thm (mapfilter (C INST_TYPE th) tyins) in if ths' = [] then (warn true "No useful-looking instantiations of lemma"; [th]) else ths' in @@ -846,7 +848,14 @@ let ASM_MESON_TAC = GEN_MESON_TAC 0 50 1;; let MESON_TAC ths = POP_ASSUM_LIST(K ALL_TAC) THEN ASM_MESON_TAC ths;; (* ------------------------------------------------------------------------- *) -(* Also introduce a rule. *) +(* Also introduce a rule. *) (* ------------------------------------------------------------------------- *) -let MESON ths tm = prove(tm,MESON_TAC ths);; +let MESON ths tm = + let th = TAC_PROOF(([],tm),MESON_TAC ths) in + let asl,tm' = dest_thm th in + if asl <> [] && not(subset asl (unions (map hyp ths))) + then failwith "MESON: too many assumptions in result" + else if tm' = tm then th else + try EQ_MP (ALPHA tm' tm) th + with Failure _ -> failwith "MESON: the wrong result";; diff --git a/metis.ml b/metis.ml index 923b5632..db059b71 100644 --- a/metis.ml +++ b/metis.ml @@ -9,296 +9,10225 @@ (* This is a port from SML to OCaml and proof-reconstructing integration *) (* with HOL Light, written by Michael Faerber and Cezary Kaliszyk. *) (* *) -(* The port has been further adapted for use with the Candle theorem prover *) -(* by Oskar Abrahamsson. *) -(* *) (* (c) Copyright, Joe Hurd, 2001 *) (* (c) Copyright, Joe Leslie-Hurd, 2004 *) (* (c) Copyright, Michael Faerber and Cezary Kaliszyk, 2014-2018. *) -(* (c) Copyright, Oskar Abrahamsson, 2024 *) (* *) (* Distributed under the same license as HOL Light. *) (* ========================================================================= *) -(* NOTE(oskar): was firstorder.ml *) -needs "meson.ml";; +needs "firstorder.ml";; + +let metisverb = ref false;; + +module Metis_prover = struct + +(* ------------------------------------------------------------------------- *) +(* Emulating SML Word type (which is unsigned) and other operations. *) +(* ------------------------------------------------------------------------- *) + +module Word = struct + +type word = int;; +let compare : word -> word -> int = Int.compare;; + +let shiftLeft (x, y) = x lsl y;; +let shiftRight (x, y) = x lsr y;; + +(* This is only the same as the SML version, if there is no overflow *) +let minus (x,y) = x - y;; + +let andb (x,y) = x land y;; +let orb (x,y) = x lor y;; +let xorb (x,y) = x lxor y;; +let notb x = lnot x + +let toInt x = x;; +let fromInt x = x;; + +end + +module Mlist = struct + +let foldl f a l = List.fold_left (fun acc x -> f (x, acc)) a l;; +let foldr f a l = List.fold_right (fun x acc -> f (x, acc)) l a;; +let null = function + [] -> true + | _ -> false +let tabulate (n,f) = + let rec go i = if i = n then [] else f i :: go (i+1) + in go 0 +let find p l = try Some (List.find p l) with Not_found -> None;; +let rec first f = function + [] -> None + | (x :: xs) -> (match f x with None -> first f xs | s -> s);; +let enumerate l = mapi (fun x y -> (x, y)) l +let revDivide l = + let rec revDiv acc = function + (l, 0) -> (acc,l) + | ([], _) -> invalid_arg "Metis_prover.Mlist.revDivide" + | (h :: t, n) -> revDiv (h :: acc) (t, n - 1) + in fun n -> revDiv [] (l, n);; +let updateNth (n,x) l = + let (a,b) = revDivide l n + in + match b with + [] -> invalid_arg "Metis_prover.Mlist.updateNth" + | (_ :: t) -> List.rev_append a (x :: t) +;; +let sortMap f cmp = function + [] -> [] + | ([_] as l) -> l + | xs -> + let ncmp (m,_) (n,_) = cmp m n + in let nxs = List.map (fun x -> (f x, x)) xs + in let nys = List.sort ncmp nxs + in + List.map snd nys + ;; + +end + +module Option = struct + +let is_some = function + Some _ -> true + | None -> false;; + +let bind opt f = + match opt with + | Some x -> f x + | None -> None + +let value opt default = + match opt with + | Some x -> x + | None -> default + +end + +(* ========================================================================= *) +(* ML UTILITY FUNCTIONS *) +(* ========================================================================= *) + +module Useful = struct + +(* Marking critical sections of code. *) +let critical x = x;; + +(* ------------------------------------------------------------------------- *) +(* Characters (MF). *) +(* ------------------------------------------------------------------------- *) + +let isDigit c = Char.compare '0' c <= 0 && Char.compare c '9' <= 0 + +(* ------------------------------------------------------------------------- *) +(* Exceptions. *) +(* ------------------------------------------------------------------------- *) + +exception Bug of string;; + +let total f x = try Some (f x) with Failure _ -> None;; + +let exp m = + let rec f x y z = match y with + 0 -> z + | _ -> f (m (x,x)) (y / 2) (if y mod 2 = 0 then z else m (z,x)) + in + f + ;; + +(* ------------------------------------------------------------------------- *) +(* Comparisons. *) +(* ------------------------------------------------------------------------- *) + +let revCompare cmp x y = cmp y x;; + +let prodCompare xCmp yCmp (x1,y1) (x2,y2) = + let c = xCmp x1 x2 in if c <> 0 then c else yCmp y1 y2;; + +let lexCompare cmp = + let rec lex xs ys = match (xs, ys) with + ([],[]) -> 0 + | ([], _ :: _) -> -1 + | (_ :: _, []) -> 1 + | (x :: xs, y :: ys) -> + let c = cmp x y in if c <> 0 then c else lex xs ys + in lex;; + +let boolCompare x y = match (x, y) with + (false, true) -> -1 + | (true, false) -> 1 + | _ -> 0;; + +let intCompare : int -> int -> int = Int.compare;; + +(* ------------------------------------------------------------------------- *) +(* Strings. *) +(* ------------------------------------------------------------------------- *) + +let mkPrefix p s = p ^ s + +let stripSuffix pred s = + let rec strip pos = + if pos < 0 then "" else + if pred (s.[pos]) then strip (pos - 1) + else String.sub s 0 (pos + 1) + in strip (String.length s - 1);; + +(* ------------------------------------------------------------------------- *) +(* Integers. *) +(* ------------------------------------------------------------------------- *) + +let rec interval m = function + 0 -> [] + | len -> m :: interval (m + 1) (len - 1);; + +let divides = function + (_, 0) -> true + | (0, _) -> false + | (a, b) -> b mod (abs a) = 0;; +let divides = curry divides;; + +(* ------------------------------------------------------------------------- *) +(* Useful impure features. *) +(* ------------------------------------------------------------------------- *) + +let generator = ref 0;; + + let newIntThunk () = + let n = !generator + in generator := n + 1; + n + ;; + + let newIntsThunk k () = + let + n = !generator + + in generator := n + k; + interval n k + ;; + + let newInt () = newIntThunk ();; + + let newInts k = + if k <= 0 then [] + else (newIntsThunk k) ();; + +end + +(* ========================================================================= *) +(* FINITE MAPS IMPLEMENTED WITH RANDOMLY BALANCED TREES *) +(* ========================================================================= *) + +module Pmap = struct + +(* ------------------------------------------------------------------------- *) +(* Converting a comparison function to an equality function. *) +(* ------------------------------------------------------------------------- *) + +let equalKey compareKey key1 key2 = compareKey key1 key2 = 0;; + +(* ------------------------------------------------------------------------- *) +(* Priorities. *) +(* ------------------------------------------------------------------------- *) + +type priority = Word.word;; + +let randomPriority = Random.bits;; + +let comparePriority = Word.compare;; + +(* ------------------------------------------------------------------------- *) +(* Priority search trees. *) +(* ------------------------------------------------------------------------- *) + +type ('key,'value) tree = + Empty + | Tree of ('key,'value) node + +and ('key,'value) node = Node of + {size : int; + priority : priority; + left : ('key,'value) tree; + key : 'key; + value : 'value; + right : ('key,'value) tree};; + +let lowerPriorityNode node1 node2 = + let Node {priority} = node1 in let p1 = priority in + let Node {priority} = node2 in let p2 = priority + in + comparePriority p1 p2 < 0 + ;; + +(* ------------------------------------------------------------------------- *) +(* Tree debugging functions. *) +(* ------------------------------------------------------------------------- *) + +(*BasicDebug +local + let checkSizes tree = + match tree with + Empty -> 0 + | Tree (Node {size,left,right,...}) -> + let + let l = checkSizes left + and r = checkSizes right + + let () = if l + 1 + r = size then () else raise Useful.Bug "wrong size" + in + size + end;; + + let checkSorted compareKey x tree = + match tree with + Empty -> x + | Tree (Node {left,key,right,...}) -> + let + let x = checkSorted compareKey x left + + let () = + match x with + None -> () + | Some k -> + let c = compareKey k key in + if c < 0 then () + else if c = 0 then raise Useful.Bug "duplicate keys" + else raise Useful.Bug "unsorted" + + let x = Some key + in + checkSorted compareKey x right + end;; + + let checkPriorities compareKey tree = + match tree with + Empty -> None + | Tree node -> + let + let Node {left,right,...} = node + + let () = + match checkPriorities compareKey left with + None -> () + | Some lnode -> + if not (lowerPriorityNode node lnode) then () + else raise Useful.Bug "left child has greater priority" + + let () = + match checkPriorities compareKey right with + None -> () + | Some rnode -> + if not (lowerPriorityNode node rnode) then () + else raise Useful.Bug "right child has greater priority" + in + Some node + end;; +in + let treeCheckInvariants compareKey tree = + let + let _ = checkSizes tree + + let _ = checkSorted compareKey None tree + + let _ = checkPriorities compareKey tree + in + tree + end + handle Failure err -> raise (Useful.Bug err);; +end;; +*) + +(* ------------------------------------------------------------------------- *) +(* Tree operations. *) +(* ------------------------------------------------------------------------- *) + +let treeNew () = Empty;; + +let nodeSize (Node {size}) = size;; + +let treeSize tree = + match tree with + Empty -> 0 + | Tree x -> nodeSize x;; + +let mkNode priority left key value right = + let size = treeSize left + 1 + treeSize right + in + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} + ;; + +let mkTree priority left key value right = + let node = mkNode priority left key value right + in + Tree node + ;; + +(* ------------------------------------------------------------------------- *) +(* Extracting the left and right spines of a tree. *) +(* ------------------------------------------------------------------------- *) + +let rec treeLeftSpine acc tree = + match tree with + Empty -> acc + | Tree node -> nodeLeftSpine acc node + +and nodeLeftSpine acc node = + let Node {left} = node + in + treeLeftSpine (node :: acc) left + ;; + +let rec treeRightSpine acc tree = + match tree with + Empty -> acc + | Tree node -> nodeRightSpine acc node + +and nodeRightSpine acc node = + let Node {right} = node + in + treeRightSpine (node :: acc) right + ;; + +(* ------------------------------------------------------------------------- *) +(* Singleton trees. *) +(* ------------------------------------------------------------------------- *) + +let mkNodeSingleton priority key value = + let size = 1 + and left = Empty + and right = Empty + in + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} + ;; + +let nodeSingleton (key,value) = + let priority = randomPriority () + in + mkNodeSingleton priority key value + ;; + +let treeSingleton key_value = + let node = nodeSingleton key_value + in + Tree node + ;; + +(* ------------------------------------------------------------------------- *) +(* Appending two trees, where every element of the first tree is less than *) +(* every element of the second tree. *) +(* ------------------------------------------------------------------------- *) + +let rec treeAppend tree1 tree2 = + match tree1 with + Empty -> tree2 + | Tree node1 -> + match tree2 with + Empty -> tree1 + | Tree node2 -> + if lowerPriorityNode node1 node2 then + let Node {priority;left;key;value;right} = node2 + + in let left = treeAppend tree1 left + in + mkTree priority left key value right + else + let Node {priority;left;key;value;right} = node1 + + in let right = treeAppend right tree2 + in + mkTree priority left key value right + ;; + +(* ------------------------------------------------------------------------- *) +(* Appending two trees and a node, where every element of the first tree is *) +(* less than the node, which in turn is less than every element of the *) +(* second tree. *) +(* ------------------------------------------------------------------------- *) + +let treeCombine left node right = + let left_node = treeAppend left (Tree node) + in + treeAppend left_node right + ;; + +(* ------------------------------------------------------------------------- *) +(* Searching a tree for a value. *) +(* ------------------------------------------------------------------------- *) + +let rec treePeek compareKey pkey tree = + match tree with + Empty -> None + | Tree node -> nodePeek compareKey pkey node + +and nodePeek compareKey pkey node = + let Node {left;key;value;right} = node + in + let c = compareKey pkey key in + if c < 0 then treePeek compareKey pkey left + else if c = 0 then Some value + else treePeek compareKey pkey right + ;; + +(* ------------------------------------------------------------------------- *) +(* Tree paths. *) +(* ------------------------------------------------------------------------- *) + +(* Generating a path by searching a tree for a key/value pair *) + +let rec treePeekPath compareKey pkey path tree = + match tree with + Empty -> (path,None) + | Tree node -> nodePeekPath compareKey pkey path node + +and nodePeekPath compareKey pkey path node = + let Node {left;key;right} = node + in + let c = compareKey pkey key in + if c < 0 then treePeekPath compareKey pkey ((true,node) :: path) left + else if c = 0 then (path, Some node) + else treePeekPath compareKey pkey ((false,node) :: path) right + ;; + +(* A path splits a tree into left/right components *) + +let addSidePath ((wentLeft,node),(leftTree,rightTree)) = + let Node {priority;left;key;value;right} = node + in + if wentLeft then (leftTree, mkTree priority rightTree key value right) + else (mkTree priority left key value leftTree, rightTree) + ;; + +let addSidesPath left_right = Mlist.foldl addSidePath left_right;; + +let mkSidesPath path = addSidesPath (Empty,Empty) path;; + +(* Updating the subtree at a path *) + + let updateTree ((wentLeft,node),tree) = + let Node {priority;left;key;value;right} = node + in + if wentLeft then mkTree priority tree key value right + else mkTree priority left key value tree;; + let updateTreePath tree = Mlist.foldl updateTree tree;; + +(* Inserting a new node at a path position *) + +let insertNodePath node = + let rec insert left_right path = + match path with + [] -> + let (left,right) = left_right + in + treeCombine left node right + | ((_,snode) as step) :: rest -> + if lowerPriorityNode snode node then + let left_right = addSidePath (step,left_right) + in + insert left_right rest + else + let (left,right) = left_right + + in let tree = treeCombine left node right + in + updateTreePath tree path + in + insert (Empty,Empty) + ;; + +(* ------------------------------------------------------------------------- *) +(* Using a key to split a node into three components: the keys comparing *) +(* less than the supplied key, an optional equal key, and the keys comparing *) +(* greater. *) +(* ------------------------------------------------------------------------- *) + +let nodePartition compareKey pkey node = + let (path,pnode) = nodePeekPath compareKey pkey [] node + in + match pnode with + None -> + let (left,right) = mkSidesPath path + in + (left,None,right) + | Some node -> + let Node {left;key;value;right} = node + + in let (left,right) = addSidesPath (left,right) path + in + (left, Some (key,value), right) + ;; + +(* ------------------------------------------------------------------------- *) +(* Searching a tree for a key/value pair. *) +(* ------------------------------------------------------------------------- *) + +let rec treePeekKey compareKey pkey tree = + match tree with + Empty -> None + | Tree node -> nodePeekKey compareKey pkey node + +and nodePeekKey compareKey pkey node = + let Node {left;key;value;right} = node + in + let c = compareKey pkey key in + if c < 0 then treePeekKey compareKey pkey left + else if c = 0 then Some (key,value) + else treePeekKey compareKey pkey right + ;; + +(* ------------------------------------------------------------------------- *) +(* Inserting new key/values into the tree. *) +(* ------------------------------------------------------------------------- *) + +let treeInsert compareKey key_value tree = + let (key,value) = key_value + + in let (path,inode) = treePeekPath compareKey key [] tree + in + match inode with + None -> + let node = nodeSingleton (key,value) + in + insertNodePath node path + | Some node -> + let Node {size;priority;left;right} = node + + in let node = + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} + in + updateTreePath (Tree node) path + ;; + +(* ------------------------------------------------------------------------- *) +(* Deleting key/value pairs: it raises an exception if the supplied key is *) +(* not present. *) +(* ------------------------------------------------------------------------- *) + +let rec treeDelete compareKey dkey tree = + match tree with + Empty -> raise (Useful.Bug "Map.delete: element not found") + | Tree node -> nodeDelete compareKey dkey node + +and nodeDelete compareKey dkey node = + let Node {size;priority;left;key;value;right} = node + in + let c = compareKey dkey key in + if c < 0 then + let size = size - 1 + and left = treeDelete compareKey dkey left + + in let node = + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} + in + Tree node + else if c = 0 then treeAppend left right + else + let size = size - 1 + and right = treeDelete compareKey dkey right + + in let node = + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} + in + Tree node + ;; + +(* ------------------------------------------------------------------------- *) +(* Partial map is the basic operation for preserving tree structure. *) +(* It applies its argument function to the elements *in order*. *) +(* ------------------------------------------------------------------------- *) + +let rec treeMapPartial f tree = + match tree with + Empty -> Empty + | Tree node -> nodeMapPartial f node + +and nodeMapPartial f (Node {priority;left;key;value;right}) = + let left = treeMapPartial f left + and vo = f (key,value) + and right = treeMapPartial f right + in + match vo with + None -> treeAppend left right + | Some value -> mkTree priority left key value right + ;; + +(* ------------------------------------------------------------------------- *) +(* Mapping tree values. *) +(* ------------------------------------------------------------------------- *) + +let rec treeMap f tree = + match tree with + Empty -> Empty + | Tree node -> Tree (nodeMap f node) + +and nodeMap f node = + let Node {size;priority;left;key;value;right} = node + + in let left = treeMap f left + and value = f (key,value) + and right = treeMap f right + in + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} + ;; + +(* ------------------------------------------------------------------------- *) +(* Merge is the basic operation for joining two trees. Note that the merged *) +(* key is always the one from the second map. *) +(* ------------------------------------------------------------------------- *) + +let rec treeMerge compareKey f1 f2 fb tree1 tree2 = + match tree1 with + Empty -> treeMapPartial f2 tree2 + | Tree node1 -> + match tree2 with + Empty -> treeMapPartial f1 tree1 + | Tree node2 -> nodeMerge compareKey f1 f2 fb node1 node2 + +and nodeMerge compareKey f1 f2 fb node1 node2 = + let Node {priority;left;key;value;right} = node2 + + in let (l,kvo,r) = nodePartition compareKey key node1 + + in let left = treeMerge compareKey f1 f2 fb l left + and right = treeMerge compareKey f1 f2 fb r right + + in let vo = + match kvo with + None -> f2 (key,value) + | Some kv -> fb (kv,(key,value)) + in + match vo with + None -> treeAppend left right + | Some value -> + let node = mkNodeSingleton priority key value + in + treeCombine left node right + ;; + +(* ------------------------------------------------------------------------- *) +(* A union operation on trees. *) +(* ------------------------------------------------------------------------- *) + +let rec treeUnion compareKey f f2 tree1 tree2 = + match tree1 with + Empty -> tree2 + | Tree node1 -> + match tree2 with + Empty -> tree1 + | Tree node2 -> nodeUnion compareKey f f2 node1 node2 + +and nodeUnion compareKey f f2 node1 node2 = + (* if node1 == node2 then nodeMapPartial f2 node1 else *) + let Node {priority;left;key;value;right} = node2 + + in let (l,kvo,r) = nodePartition compareKey key node1 + + in let left = treeUnion compareKey f f2 l left + and right = treeUnion compareKey f f2 r right + + in let vo = + match kvo with + None -> Some value + | Some kv -> f (kv,(key,value)) + in + match vo with + None -> treeAppend left right + | Some value -> + let node = mkNodeSingleton priority key value + in + treeCombine left node right + ;; + +(* ------------------------------------------------------------------------- *) +(* An intersect operation on trees. *) +(* ------------------------------------------------------------------------- *) + +let rec treeIntersect compareKey f t1 t2 = + match t1 with + Empty -> Empty + | Tree n1 -> + match t2 with + Empty -> Empty + | Tree n2 -> nodeIntersect compareKey f n1 n2 + +and nodeIntersect compareKey f n1 n2 = + let Node {priority;left;key;value;right} = n2 + + in let (l,kvo,r) = nodePartition compareKey key n1 + + in let left = treeIntersect compareKey f l left + and right = treeIntersect compareKey f r right + + in let vo = + match kvo with + None -> None + | Some kv -> f (kv,(key,value)) + in + match vo with + None -> treeAppend left right + | Some value -> mkTree priority left key value right + ;; + +(* ------------------------------------------------------------------------- *) +(* A union operation on trees which simply chooses the second value. *) +(* ------------------------------------------------------------------------- *) + +let rec treeUnionDomain compareKey tree1 tree2 = + match tree1 with + Empty -> tree2 + | Tree node1 -> + match tree2 with + Empty -> tree1 + | Tree node2 -> + (* if node1 == node2 then tree2 else *) + nodeUnionDomain compareKey node1 node2 + +and nodeUnionDomain compareKey node1 node2 = + let Node {priority;left;key;value;right} = node2 + + in let (l,_,r) = nodePartition compareKey key node1 + + in let left = treeUnionDomain compareKey l left + and right = treeUnionDomain compareKey r right + + in let node = mkNodeSingleton priority key value + in + treeCombine left node right + ;; + +(* ------------------------------------------------------------------------- *) +(* An intersect operation on trees which simply chooses the second value. *) +(* ------------------------------------------------------------------------- *) + +let rec treeIntersectDomain compareKey tree1 tree2 = + match tree1 with + Empty -> Empty + | Tree node1 -> + match tree2 with + Empty -> Empty + | Tree node2 -> + (* if node1 == node2 then tree2 else *) + nodeIntersectDomain compareKey node1 node2 + +and nodeIntersectDomain compareKey node1 node2 = + let Node {priority;left;key;value;right} = node2 + + in let (l,kvo,r) = nodePartition compareKey key node1 + + in let left = treeIntersectDomain compareKey l left + and right = treeIntersectDomain compareKey r right + in + if Option.is_some kvo then mkTree priority left key value right + else treeAppend left right + ;; + +(* ------------------------------------------------------------------------- *) +(* A difference operation on trees. *) +(* ------------------------------------------------------------------------- *) + +let rec treeDifferenceDomain compareKey t1 t2 = + match t1 with + Empty -> Empty + | Tree n1 -> + match t2 with + Empty -> t1 + | Tree n2 -> nodeDifferenceDomain compareKey n1 n2 + +and nodeDifferenceDomain compareKey n1 n2 = + (* if n1 == n2 then Empty else *) + let Node {priority;left;key;value;right} = n1 + + in let (l,kvo,r) = nodePartition compareKey key n2 + + in let left = treeDifferenceDomain compareKey left l + and right = treeDifferenceDomain compareKey right r + in + if Option.is_some kvo then treeAppend left right + else mkTree priority left key value right + ;; + +(* ------------------------------------------------------------------------- *) +(* A subset operation on trees. *) +(* ------------------------------------------------------------------------- *) + +let rec treeSubsetDomain compareKey tree1 tree2 = + match tree1 with + Empty -> true + | Tree node1 -> + match tree2 with + Empty -> false + | Tree node2 -> nodeSubsetDomain compareKey node1 node2 + +and nodeSubsetDomain compareKey node1 node2 = + (* node1 == node2 || *) + let Node {size;left;key;right} = node1 + in + size <= nodeSize node2 && + let (l,kvo,r) = nodePartition compareKey key node2 + in + Option.is_some kvo && + treeSubsetDomain compareKey left l && + treeSubsetDomain compareKey right r + ;; + +(* ------------------------------------------------------------------------- *) +(* Picking an arbitrary key/value pair from a tree. *) +(* ------------------------------------------------------------------------- *) + +let rec nodePick node = + let Node {key;value} = node + in + (key,value) + ;; + +let treePick tree = + match tree with + Empty -> raise (Useful.Bug "Map.treePick") + | Tree node -> nodePick node;; + +(* ------------------------------------------------------------------------- *) +(* Removing an arbitrary key/value pair from a tree. *) +(* ------------------------------------------------------------------------- *) + +let rec nodeDeletePick node = + let Node {left;key;value;right} = node + in + ((key,value), treeAppend left right) + ;; + +let treeDeletePick tree = + match tree with + Empty -> raise (Useful.Bug "Map.treeDeletePick") + | Tree node -> nodeDeletePick node;; + +(* ------------------------------------------------------------------------- *) +(* Finding the nth smallest key/value (counting from 0). *) +(* ------------------------------------------------------------------------- *) + +let rec treeNth n tree = + match tree with + Empty -> raise (Useful.Bug "Map.treeNth") + | Tree node -> nodeNth n node + +and nodeNth n node = + let Node {left;key;value;right} = node + + in let k = treeSize left + in + if n = k then (key,value) + else if n < k then treeNth n left + else treeNth (n - (k + 1)) right + ;; + +(* ------------------------------------------------------------------------- *) +(* Removing the nth smallest key/value (counting from 0). *) +(* ------------------------------------------------------------------------- *) + +let rec treeDeleteNth n tree = + match tree with + Empty -> raise (Useful.Bug "Map.treeDeleteNth") + | Tree node -> nodeDeleteNth n node + +and nodeDeleteNth n node = + let Node {size;priority;left;key;value;right} = node + + in let k = treeSize left + in + if n = k then ((key,value), treeAppend left right) + else if n < k then + let (key_value,left) = treeDeleteNth n left + + in let size = size - 1 + + in let node = + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} + in + (key_value, Tree node) + else + let n = n - (k + 1) + + in let (key_value,right) = treeDeleteNth n right + + in let size = size - 1 + + in let node = + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} + in + (key_value, Tree node) + ;; + +(* ------------------------------------------------------------------------- *) +(* Iterators. *) +(* ------------------------------------------------------------------------- *) + +type ('key,'value) iterator = + Left_to_right_iterator of + ('key * 'value) * ('key,'value) tree * ('key,'value) node list + | Right_to_left_iterator of + ('key * 'value) * ('key,'value) tree * ('key,'value) node list;; + +let fromSpineLeftToRightIterator nodes = + match nodes with + [] -> None + | node :: nodes -> let Node {key;value;right} = node in + Some (Left_to_right_iterator ((key,value),right,nodes));; + +let fromSpineRightToLeftIterator nodes = + match nodes with + [] -> None + | node :: nodes -> let Node {key;value;left} = node in + Some (Right_to_left_iterator ((key,value),left,nodes));; + +let addLeftToRightIterator nodes tree = fromSpineLeftToRightIterator (treeLeftSpine nodes tree);; + +let addRightToLeftIterator nodes tree = fromSpineRightToLeftIterator (treeRightSpine nodes tree);; + +let treeMkIterator tree = addLeftToRightIterator [] tree;; + +let treeMkRevIterator tree = addRightToLeftIterator [] tree;; + +let readIterator iter = + match iter with + Left_to_right_iterator (key_value,_,_) -> key_value + | Right_to_left_iterator (key_value,_,_) -> key_value;; + +let advanceIterator iter = + match iter with + Left_to_right_iterator (_,tree,nodes) -> addLeftToRightIterator nodes tree + | Right_to_left_iterator (_,tree,nodes) -> addRightToLeftIterator nodes tree;; + +let rec foldIterator f acc io = + match io with + None -> acc + | Some iter -> + let (key,value) = readIterator iter + in + foldIterator f (f (key,value,acc)) (advanceIterator iter) + ;; + +let rec findIterator pred io = + match io with + None -> None + | Some iter -> + let key_value = readIterator iter + in + if pred key_value then Some key_value + else findIterator pred (advanceIterator iter) + ;; + +let rec firstIterator f io = + match io with + None -> None + | Some iter -> + let key_value = readIterator iter + in + match f key_value with + None -> firstIterator f (advanceIterator iter) + | s -> s + ;; + +let rec compareIterator compareKey compareValue io1 io2 = + match (io1,io2) with + (None,None) -> 0 + | (None, Some _) -> -1 + | (Some _, None) -> 1 + | (Some i1, Some i2) -> + let (k1,v1) = readIterator i1 + and (k2,v2) = readIterator i2 + in + let c = compareKey k1 k2 in + if c <> 0 then c + else + let c = compareValue v1 v2 in + if c <> 0 then c + else + let io1 = advanceIterator i1 + and io2 = advanceIterator i2 + in + compareIterator compareKey compareValue io1 io2 + ;; + +let rec equalIterator equalKey equalValue io1 io2 = + match (io1,io2) with + (None,None) -> true + | (None, Some _) -> false + | (Some _, None) -> false + | (Some i1, Some i2) -> + let (k1,v1) = readIterator i1 + and (k2,v2) = readIterator i2 + in + equalKey k1 k2 && + equalValue v1 v2 && + let io1 = advanceIterator i1 + and io2 = advanceIterator i2 + in + equalIterator equalKey equalValue io1 io2 + ;; + +(* ------------------------------------------------------------------------- *) +(* A type of finite maps. *) +(* ------------------------------------------------------------------------- *) + +type ('key,'value) map = + Map of ('key -> 'key -> int) * ('key,'value) tree;; + +(* ------------------------------------------------------------------------- *) +(* Map debugging functions. *) +(* ------------------------------------------------------------------------- *) + +(*BasicDebug +let checkInvariants s m = + let + let Map (compareKey,tree) = m + + let _ = treeCheckInvariants compareKey tree + in + m + end + handle Useful.Bug bug -> raise (Useful.Bug (s ^ "\n" ^ "Map.checkInvariants: " ^ bug));; +*) + +(* ------------------------------------------------------------------------- *) +(* Constructors. *) +(* ------------------------------------------------------------------------- *) + +let newMap compareKey = + let tree = treeNew () + in + Map (compareKey,tree) + ;; + +let singleton compareKey key_value = + let tree = treeSingleton key_value + in + Map (compareKey,tree) + ;; + +(* ------------------------------------------------------------------------- *) +(* Map size. *) +(* ------------------------------------------------------------------------- *) + +let size (Map (_,tree)) = treeSize tree;; + +let null m = size m = 0;; + +(* ------------------------------------------------------------------------- *) +(* Querying. *) +(* ------------------------------------------------------------------------- *) + +let peekKey (Map (compareKey,tree)) key = treePeekKey compareKey key tree;; + +let peek (Map (compareKey,tree)) key = treePeek compareKey key tree;; + +let inDomain key m = Option.is_some (peek m key);; + +let get m key = + match peek m key with + None -> failwith "Map.get: element not found" + | Some value -> value;; + +let pick (Map (_,tree)) = treePick tree;; + +let nth (Map (_,tree)) n = treeNth n tree;; + +let random m = + let n = size m + in + if n = 0 then raise (Useful.Bug "Map.random: empty") + else nth m (Random.int n) + ;; + +(* ------------------------------------------------------------------------- *) +(* Adding. *) +(* ------------------------------------------------------------------------- *) + +let insert (Map (compareKey,tree)) key_value = + let tree = treeInsert compareKey key_value tree + in + Map (compareKey,tree) + ;; + +(*BasicDebug +let insert = fun m -> fun kv -> + checkInvariants "Map.insert: result" + (insert (checkInvariants "Map.insert: input" m) kv);; +*) + +let insertList m = + let ins (key_value,acc) = insert acc key_value + in + Mlist.foldl ins m + ;; + +(* ------------------------------------------------------------------------- *) +(* Removing. *) +(* ------------------------------------------------------------------------- *) + +let delete (Map (compareKey,tree)) dkey = + let tree = treeDelete compareKey dkey tree + in + Map (compareKey,tree) + ;; + +(*BasicDebug +let delete = fun m -> fun k -> + checkInvariants "Map.delete: result" + (delete (checkInvariants "Map.delete: input" m) k);; +*) + +let remove m key = if inDomain key m then delete m key else m;; + +let deletePick (Map (compareKey,tree)) = + let (key_value,tree) = treeDeletePick tree + in + (key_value, Map (compareKey,tree)) + ;; + +(*BasicDebug +let deletePick = fun m -> + let + let (kv,m) = deletePick (checkInvariants "Map.deletePick: input" m) + in + (kv, checkInvariants "Map.deletePick: result" m) + end;; +*) + +let deleteNth (Map (compareKey,tree)) n = + let (key_value,tree) = treeDeleteNth n tree + in + (key_value, Map (compareKey,tree)) + ;; + +(*BasicDebug +let deleteNth = fun m -> fun n -> + let + let (kv,m) = deleteNth (checkInvariants "Map.deleteNth: input" m) n + in + (kv, checkInvariants "Map.deleteNth: result" m) + end;; +*) + +let deleteRandom m = + let n = size m + in + if n = 0 then raise (Useful.Bug "Map.deleteRandom: empty") + else deleteNth m (Random.int n) + ;; + +(* ------------------------------------------------------------------------- *) +(* Joining (all join operations prefer keys in the second map). *) +(* ------------------------------------------------------------------------- *) + +let merge (first,second,both) (Map (compareKey,tree1)) (Map (_,tree2)) = + let tree = treeMerge compareKey first second both tree1 tree2 + in + Map (compareKey,tree) + ;; + +(*BasicDebug +let merge = fun f -> fun m1 -> fun m2 -> + checkInvariants "Map.merge: result" + (merge f + (checkInvariants "Map.merge: input 1" m1) + (checkInvariants "Map.merge: input 2" m2));; +*) + +let union f (Map (compareKey,tree1)) (Map (_,tree2)) = + let f2 kv = f (kv,kv) + + in let tree = treeUnion compareKey f f2 tree1 tree2 + in + Map (compareKey,tree) + ;; + +(*BasicDebug +let union = fun f -> fun m1 -> fun m2 -> + checkInvariants "Map.union: result" + (union f + (checkInvariants "Map.union: input 1" m1) + (checkInvariants "Map.union: input 2" m2));; +*) + +let intersect f (Map (compareKey,tree1)) (Map (_,tree2)) = + let tree = treeIntersect compareKey f tree1 tree2 + in + Map (compareKey,tree) + ;; + +(*BasicDebug +let intersect = fun f -> fun m1 -> fun m2 -> + checkInvariants "Map.intersect: result" + (intersect f + (checkInvariants "Map.intersect: input 1" m1) + (checkInvariants "Map.intersect: input 2" m2));; +*) + +(* ------------------------------------------------------------------------- *) +(* Iterators over maps. *) +(* ------------------------------------------------------------------------- *) + +let mkIterator (Map (_,tree)) = treeMkIterator tree;; + +let mkRevIterator (Map (_,tree)) = treeMkRevIterator tree;; + +(* ------------------------------------------------------------------------- *) +(* Mapping and folding. *) +(* ------------------------------------------------------------------------- *) + +let mapPartial f (Map (compareKey,tree)) = + let tree = treeMapPartial f tree + in + Map (compareKey,tree) + ;; + +(*BasicDebug +let mapPartial = fun f -> fun m -> + checkInvariants "Map.mapPartial: result" + (mapPartial f (checkInvariants "Map.mapPartial: input" m));; +*) + +let map f (Map (compareKey,tree)) = + let tree = treeMap f tree + in + Map (compareKey,tree) + ;; + +(*BasicDebug +let map = fun f -> fun m -> + checkInvariants "Map.map: result" + (map f (checkInvariants "Map.map: input" m));; +*) + +let transform f = map (fun (_,value) -> f value);; + +let filter pred = + let f ((_,value) as key_value) = + if pred key_value then Some value else None + in + mapPartial f + ;; + +let partition p = + let np x = not (p x) + in + fun m -> (filter p m, filter np m) + ;; + +let foldl f b m = foldIterator f b (mkIterator m);; + +let foldr f b m = foldIterator f b (mkRevIterator m);; + +let app f m = foldl (fun (key,value,()) -> f (key,value)) () m;; + +(* ------------------------------------------------------------------------- *) +(* Searching. *) +(* ------------------------------------------------------------------------- *) + +let findl p m = findIterator p (mkIterator m);; + +let findr p m = findIterator p (mkRevIterator m);; + +let firstl f m = firstIterator f (mkIterator m);; + +let firstr f m = firstIterator f (mkRevIterator m);; + +let exists p m = Option.is_some (findl p m);; + +let all p = + let np x = not (p x) + in + fun m -> not (exists np m) + ;; + +let count pred = + let f (k,v,acc) = if pred (k,v) then acc + 1 else acc + in + foldl f 0 + ;; + +(* ------------------------------------------------------------------------- *) +(* Comparing. *) +(* ------------------------------------------------------------------------- *) + +let compare compareValue m1 m2 = + (* if m1 == m2 then 0 else *) + let c = Useful.intCompare (size m1) (size m2) in + if c <> 0 then c + else + let Map (compareKey,_) = m1 + + in let io1 = mkIterator m1 + and io2 = mkIterator m2 + in + compareIterator compareKey compareValue io1 io2 + ;; + +let equal equalValue m1 m2 = + (* m1 == m2 || *) + (size m1 = size m2 && + let Map (compareKey,_) = m1 + + in let io1 = mkIterator m1 + and io2 = mkIterator m2 + in + equalIterator (equalKey compareKey) equalValue io1 io2 + );; + +(* ------------------------------------------------------------------------- *) +(* Set operations on the domain. *) +(* ------------------------------------------------------------------------- *) + +let unionDomain (Map (compareKey,tree1)) (Map (_,tree2)) = + let tree = treeUnionDomain compareKey tree1 tree2 + in + Map (compareKey,tree) + ;; + +(*BasicDebug +let unionDomain = fun m1 -> fun m2 -> + checkInvariants "Map.unionDomain: result" + (unionDomain + (checkInvariants "Map.unionDomain: input 1" m1) + (checkInvariants "Map.unionDomain: input 2" m2));; +*) + + let uncurriedUnionDomain (m,acc) = unionDomain acc m;; + let unionListDomain ms = + match ms with + [] -> raise (Useful.Bug "Map.unionListDomain: no sets") + | m :: ms -> Mlist.foldl uncurriedUnionDomain m ms;; + +let intersectDomain (Map (compareKey,tree1)) (Map (_,tree2)) = + let tree = treeIntersectDomain compareKey tree1 tree2 + in + Map (compareKey,tree) + ;; + +(*BasicDebug +let intersectDomain = fun m1 -> fun m2 -> + checkInvariants "Map.intersectDomain: result" + (intersectDomain + (checkInvariants "Map.intersectDomain: input 1" m1) + (checkInvariants "Map.intersectDomain: input 2" m2));; +*) + + let uncurriedIntersectDomain (m,acc) = intersectDomain acc m;; + let intersectListDomain ms = + match ms with + [] -> raise (Useful.Bug "Map.intersectListDomain: no sets") + | m :: ms -> Mlist.foldl uncurriedIntersectDomain m ms;; + +let differenceDomain (Map (compareKey,tree1)) (Map (_,tree2)) = + let tree = treeDifferenceDomain compareKey tree1 tree2 + in + Map (compareKey,tree) + ;; + +(*BasicDebug +let differenceDomain = fun m1 -> fun m2 -> + checkInvariants "Map.differenceDomain: result" + (differenceDomain + (checkInvariants "Map.differenceDomain: input 1" m1) + (checkInvariants "Map.differenceDomain: input 2" m2));; +*) + +let symmetricDifferenceDomain m1 m2 = + unionDomain (differenceDomain m1 m2) (differenceDomain m2 m1);; + +let equalDomain m1 m2 = equal (K (K true)) m1 m2;; + +let subsetDomain (Map (compareKey,tree1)) (Map (_,tree2)) = + treeSubsetDomain compareKey tree1 tree2;; + +let disjointDomain m1 m2 = null (intersectDomain m1 m2);; + +(* ------------------------------------------------------------------------- *) +(* Converting to and from lists. *) +(* ------------------------------------------------------------------------- *) + +let keys m = foldr (fun (key,_,l) -> key :: l) [] m;; + +let values m = foldr (fun (_,value,l) -> value :: l) [] m;; + +let toList m = foldr (fun (key,value,l) -> (key,value) :: l) [] m;; + +let fromList compareKey l = + let m = newMap compareKey + in + insertList m l + ;; + +(* ------------------------------------------------------------------------- *) +(* Pretty-printing. *) +(* ------------------------------------------------------------------------- *) + +let toString m = "<" ^ (if null m then "" else string_of_int (size m)) ^ ">";; + +end + +(* ------------------------------------------------------------------------- *) +(* More map and set modules to support Metis. *) +(* ------------------------------------------------------------------------- *) + +(* ========================================================================= *) +(* FINITE SETS IMPLEMENTED WITH RANDOMLY BALANCED TREES *) +(* ========================================================================= *) + +module Pset = struct + +(* ------------------------------------------------------------------------- *) +(* A type of finite sets. *) +(* ------------------------------------------------------------------------- *) + +type ('elt,'a) map = ('elt,'a) Pmap.map;; + +type 'elt set = Set of ('elt,unit) map;; + +(* ------------------------------------------------------------------------- *) +(* Converting to and from maps. *) +(* ------------------------------------------------------------------------- *) + +let dest (Set m) = m;; + +let mapPartial f = + let mf (elt,()) = f elt + in + fun (Set m) -> Pmap.mapPartial mf m + ;; + +let map f = + let mf (elt,()) = f elt + in + fun (Set m) -> Pmap.map mf m + ;; + +let domain m = Set (Pmap.transform (fun _ -> ()) m);; + +(* ------------------------------------------------------------------------- *) +(* Constructors. *) +(* ------------------------------------------------------------------------- *) + +let empty cmp = Set (Pmap.newMap cmp);; + +let singleton cmp elt = Set (Pmap.singleton cmp (elt,()));; + +(* ------------------------------------------------------------------------- *) +(* Set size. *) +(* ------------------------------------------------------------------------- *) + +let null (Set m) = Pmap.null m;; + +let size (Set m) = Pmap.size m;; + +(* ------------------------------------------------------------------------- *) +(* Querying. *) +(* ------------------------------------------------------------------------- *) + +let peek (Set m) elt = + match Pmap.peekKey m elt with + Some (elt,()) -> Some elt + | None -> None;; + +let member elt (Set m) = Pmap.inDomain elt m;; + +let pick (Set m) = + let (elt,_) = Pmap.pick m + in + elt + ;; + +let nth (Set m) n = + let (elt,_) = Pmap.nth m n + in + elt + ;; + +let random (Set m) = + let (elt,_) = Pmap.random m + in + elt + ;; + +(* ------------------------------------------------------------------------- *) +(* Adding. *) +(* ------------------------------------------------------------------------- *) + +let add (Set m) elt = + let m = Pmap.insert m (elt,()) + in + Set m + ;; + + let uncurriedAdd (elt,set) = add set elt;; + let addList set = Mlist.foldl uncurriedAdd set;; + +(* ------------------------------------------------------------------------- *) +(* Removing. *) +(* ------------------------------------------------------------------------- *) + +let delete (Set m) elt = + let m = Pmap.delete m elt + in + Set m + ;; + +let remove (Set m) elt = + let m = Pmap.remove m elt + in + Set m + ;; + +let deletePick (Set m) = + let ((elt,()),m) = Pmap.deletePick m + in + (elt, Set m) + ;; + +let deleteNth (Set m) n = + let ((elt,()),m) = Pmap.deleteNth m n + in + (elt, Set m) + ;; + +let deleteRandom (Set m) = + let ((elt,()),m) = Pmap.deleteRandom m + in + (elt, Set m) + ;; + +(* ------------------------------------------------------------------------- *) +(* Joining. *) +(* ------------------------------------------------------------------------- *) + +let union (Set m1) (Set m2) = Set (Pmap.unionDomain m1 m2);; + +let unionList sets = + let ms = List.map dest sets + in + Set (Pmap.unionListDomain ms) + ;; + +let intersect (Set m1) (Set m2) = Set (Pmap.intersectDomain m1 m2);; + +let intersectList sets = + let ms = List.map dest sets + in + Set (Pmap.intersectListDomain ms) + ;; + +let difference (Set m1) (Set m2) = + Set (Pmap.differenceDomain m1 m2);; + +let symmetricDifference (Set m1) (Set m2) = + Set (Pmap.symmetricDifferenceDomain m1 m2);; + +(* ------------------------------------------------------------------------- *) +(* Pmapping and folding. *) +(* ------------------------------------------------------------------------- *) + +let filter pred = + let mpred (elt,()) = pred elt + in + fun (Set m) -> Set (Pmap.filter mpred m) + ;; + +let partition pred = + let mpred (elt,()) = pred elt + in + fun (Set m) -> + let (m1,m2) = Pmap.partition mpred m + in + (Set m1, Set m2) + ;; + +let app f = + let mf (elt,()) = f elt + in + fun (Set m) -> Pmap.app mf m + ;; + +let foldl f = + let mf (elt,(),acc) = f (elt,acc) + in + fun acc -> fun (Set m) -> Pmap.foldl mf acc m + ;; + +let foldr f = + let mf (elt,(),acc) = f (elt,acc) + in + fun acc -> fun (Set m) -> Pmap.foldr mf acc m + ;; + +(* ------------------------------------------------------------------------- *) +(* Searching. *) +(* ------------------------------------------------------------------------- *) + +let findl p = + let mp (elt,()) = p elt + in + fun (Set m) -> + match Pmap.findl mp m with + Some (elt,()) -> Some elt + | None -> None + ;; + +let findr p = + let mp (elt,()) = p elt + in + fun (Set m) -> + match Pmap.findr mp m with + Some (elt,()) -> Some elt + | None -> None + ;; + +let firstl f = + let mf (elt,()) = f elt + in + fun (Set m) -> Pmap.firstl mf m + ;; + +let firstr f = + let mf (elt,()) = f elt + in + fun (Set m) -> Pmap.firstr mf m + ;; + +let exists p = + let mp (elt,()) = p elt + in + fun (Set m) -> Pmap.exists mp m + ;; + +let all p = + let mp (elt,()) = p elt + in + fun (Set m) -> Pmap.all mp m + ;; + +let count p = + let mp (elt,()) = p elt + in + fun (Set m) -> Pmap.count mp m + ;; + +(* ------------------------------------------------------------------------- *) +(* Comparing. *) +(* ------------------------------------------------------------------------- *) + +let compareValue () () = 0;; + +let equalValue () () = true;; + +let compare (Set m1) (Set m2) = Pmap.compare compareValue m1 m2;; + +let equal (Set m1) (Set m2) = Pmap.equal equalValue m1 m2;; + +let subset (Set m1) (Set m2) = Pmap.subsetDomain m1 m2;; + +let disjoint (Set m1) (Set m2) = Pmap.disjointDomain m1 m2;; + +(* ------------------------------------------------------------------------- *) +(* Converting to and from lists. *) +(* ------------------------------------------------------------------------- *) + +let transform f = + let inc (x,l) = f x :: l + in + foldr inc [] + ;; + +let toList (Set m) = Pmap.keys m;; + +let fromList cmp elts = addList (empty cmp) elts;; + +(* ------------------------------------------------------------------------- *) +(* Pretty-printing. *) +(* ------------------------------------------------------------------------- *) + +let toString set = + "{" ^ (if null set then "" else string_of_int (size set)) ^ "}";; + +(* ------------------------------------------------------------------------- *) +(* Iterators over sets *) +(* ------------------------------------------------------------------------- *) + +type 'elt iterator = ('elt,unit) Pmap.iterator;; + +let mkIterator (Set m) = Pmap.mkIterator m;; + +let mkRevIterator (Set m) = Pmap.mkRevIterator m;; + +let readIterator iter = + let (elt,()) = Pmap.readIterator iter + in + elt + ;; + +let advanceIterator iter = Pmap.advanceIterator iter;; + + +end + +(* ========================================================================= *) +(* More map and set types for Metis. *) +(* ========================================================================= *) + +module Intmap = struct + +type 'a map = (int, 'a) Pmap.map +let newMap () = Pmap.newMap Int.compare +let null = Pmap.null +let singleton kv = Pmap.singleton Int.compare kv +let size = Pmap.size +let get = Pmap.get +let peek = Pmap.peek +let insert = Pmap.insert +let toList = Pmap.toList +let fromList l = Pmap.fromList Int.compare l +let foldl = Pmap.foldl +let foldr = Pmap.foldr +let filter = Pmap.filter +let inDomain k m = Pmap.inDomain k m +let union = Pmap.union +let delete = Pmap.delete +let mapPartial = Pmap.mapPartial +let transform = Pmap.transform +let exists = Pmap.exists + +end + +module Stringmap = struct + +type 'a map = (string, 'a) Pmap.map +let newMap () = Pmap.newMap String.compare +let null = Pmap.null +let singleton kv = Pmap.singleton String.compare kv +let size = Pmap.size +let get = Pmap.get +let peek = Pmap.peek +let insert = Pmap.insert +let toList = Pmap.toList +let fromList l = Pmap.fromList String.compare l +let foldl = Pmap.foldl +let foldr = Pmap.foldr +let filter = Pmap.filter +let inDomain k m = Pmap.inDomain k m +let union = Pmap.union +let delete = Pmap.delete +let mapPartial = Pmap.mapPartial +let transform = Pmap.transform +let exists = Pmap.exists + +end + +module Intset = struct + +type set = int Pset.set +let compare = Pset.compare +let add = Pset.add +let foldr = Pset.foldr +let foldl = Pset.foldl +let member x s = Pset.member x s +let empty = Pset.empty Int.compare +let union = Pset.union +let difference = Pset.difference +let toList = Pset.toList +let singleton x = Pset.singleton Int.compare x +let null = Pset.null +let size = Pset.size +let pick = Pset.pick +let equal = Pset.equal +let exists p s = Pset.exists p s +let fromList l = Pset.fromList Int.compare l +let delete = Pset.delete +let subset = Pset.subset +let intersect = Pset.intersect +let intersectList = function + [] -> empty + | (s::ss) -> List.fold_right Pset.intersect ss s +let findl = Pset.findl +let firstl = Pset.firstl +let transform = Pset.transform +let all p s = Pset.all p s +let count p s = Pset.count p s + +end + + +(* ========================================================================= *) +(* A HEAP DATATYPE FOR ML *) +(* ========================================================================= *) + +module Heap = struct + +(* Leftist heaps as in Purely Functional Data Structures, by Chris Okasaki *) + +exception Empty;; + +type 'a node = Em | Tr of int * 'a * 'a node * 'a node;; + +type 'a heap = Heap of ('a -> 'a -> int) * int * 'a node;; + +let rank = function + Em -> 0 + | (Tr (r,_,_,_)) -> r;; + +let makeT (x,a,b) = + if rank a >= rank b then Tr (rank b + 1, x, a, b) else Tr (rank a + 1, x, b, a);; + +let merge cmp = + let rec mrg = function + (h,Em) -> h + | (Em,h) -> h + | (Tr (_,x,a1,b1) as h1, (Tr (_,y,a2,b2) as h2)) -> + if cmp x y > 0 then makeT (y, a2, mrg (h1,b2)) + else makeT (x, a1, mrg (b1,h2)) + in + mrg + ;; + +let newHeap cmp = Heap (cmp,0,Em);; + +let add (Heap (f,n,a)) x = Heap (f, n + 1, merge f (Tr (1,x,Em,Em), a));; + +let size (Heap (_, n, _)) = n;; + +let null h = size h = 0;; + +let top = function + (Heap (_,_,Em)) -> raise Empty + | (Heap (_, _, Tr (_,x,_,_))) -> x;; + +let remove = function + (Heap (_,_,Em)) -> raise Empty + | (Heap (f, n, Tr (_,x,a,b))) -> (x, Heap (f, n - 1, merge f (a,b)));; + +let app f = + let rec ap = function + [] -> () + | (Em :: rest) -> ap rest + | (Tr (_,d,a,b) :: rest) -> (f d; ap (a :: b :: rest)) + in + function Heap (_,_,a) -> ap [a] + ;; + +let rec toList h = + if null h then [] + else + let (x,h) = remove h + in + x :: toList h + ;; + +let toString h = + "Heap[" ^ (if null h then "" else string_of_int (size h)) ^ "]";; + +end + +(* ========================================================================= *) +(* NAMES *) +(* ========================================================================= *) + +module Name = struct + +(* ------------------------------------------------------------------------- *) +(* A type of names. *) +(* ------------------------------------------------------------------------- *) + +type name = string;; + +(* ------------------------------------------------------------------------- *) +(* A total ordering. *) +(* ------------------------------------------------------------------------- *) + +let compare : name -> name -> int = String.compare;; + +let equal n1 n2 = n1 = n2;; + +(* ------------------------------------------------------------------------- *) +(* Fresh variables. *) +(* ------------------------------------------------------------------------- *) + +let prefix = "_";; +let numName i = Useful.mkPrefix prefix (string_of_int i);; +let newName () = numName (Useful.newInt ());; +let newNames n = List.map numName (Useful.newInts n);; + +let variantPrime avoid = + let rec variant n = if avoid n then variant (n ^ "'") else n + in variant;; + +let variantNum avoid n = + let isDigitOrPrime c = c = '\'' || Useful.isDigit c + in if not (avoid n) then n + else + let n = Useful.stripSuffix isDigitOrPrime n in + let rec variant i = + let n_i = n ^ string_of_int i + in if avoid n_i then variant (i + 1) else n_i + in variant 0 +;; + +(* ------------------------------------------------------------------------- *) +(* Parsing and pretty printing. *) +(* ------------------------------------------------------------------------- *) + +let toString s : string = s;; + +let fromString s : name = s;; + +module Map = struct + type 'a map = (name, 'a) Pmap.map + let newMap () = Pmap.newMap compare + let null = Pmap.null + let singleton kv = Pmap.singleton compare kv + let size = Pmap.size + let get = Pmap.get + let peek = Pmap.peek + let insert = Pmap.insert + let toList = Pmap.toList + let fromList l = Pmap.fromList compare l + let foldl = Pmap.foldl + let foldr = Pmap.foldr + let filter = Pmap.filter + let inDomain k m = Pmap.inDomain k m + let union = Pmap.union + let delete = Pmap.delete + let mapPartial = Pmap.mapPartial + let transform = Pmap.transform + let exists = Pmap.exists +end + +module Set = struct + type set = name Pset.set + let empty = Pset.empty compare + let singleton x = Pset.singleton compare x + let fromList l = Pset.fromList compare l + let compare = Pset.compare + let add = Pset.add + let foldr = Pset.foldr + let foldl = Pset.foldl + let member x s = Pset.member x s + let union = Pset.union + let difference = Pset.difference + let toList = Pset.toList + let null = Pset.null + let size = Pset.size + let pick = Pset.pick + let equal = Pset.equal + let exists p s = Pset.exists p s + let delete = Pset.delete + let subset = Pset.subset + let intersect = Pset.intersect + let intersectList = function + [] -> empty + | (s::ss) -> List.fold_right Pset.intersect ss s + let findl = Pset.findl + let firstl = Pset.firstl + let transform = Pset.transform + let all p s = Pset.all p s + let count p s = Pset.count p s +end + +end + +(* ========================================================================= *) +(* NAME/ARITY PAIRS *) +(* ========================================================================= *) + +module Name_arity = struct + +(* ------------------------------------------------------------------------- *) +(* A type of name/arity pairs. *) +(* ------------------------------------------------------------------------- *) + +type nameArity = Name.name * int;; + +let name ((n,_) : nameArity) = n;; + +let arity ((_,i) : nameArity) = i;; + +(* ------------------------------------------------------------------------- *) +(* Testing for different arities. *) +(* ------------------------------------------------------------------------- *) + +let nary i n_i = arity n_i = i;; + +let nullary = nary 0 +and unary = nary 1 +and binary = nary 2 +and ternary = nary 3;; + +(* ------------------------------------------------------------------------- *) +(* A total ordering. *) +(* ------------------------------------------------------------------------- *) + +let compare (n1,i1) (n2,i2) = + let c = Name.compare n1 n2 in + if c <> 0 then c else Useful.intCompare i1 i2;; + +let equal (n1,i1) (n2,i2) = i1 = i2 && Name.equal n1 n2;; + + +module Ordered = +struct type t = nameArity let compare = compare end + +module Map = struct + type 'a map = (nameArity, 'a) Pmap.map + let newMap () = Pmap.newMap compare + let null = Pmap.null + let singleton kv = Pmap.singleton compare kv + let size = Pmap.size + let get = Pmap.get + let peek = Pmap.peek + let insert = Pmap.insert + let toList = Pmap.toList + let fromList l = Pmap.fromList compare l + let foldl = Pmap.foldl + let foldr = Pmap.foldr + let filter = Pmap.filter + let inDomain k m = Pmap.inDomain k m + let union = Pmap.union + let delete = Pmap.delete + let mapPartial = Pmap.mapPartial + let transform = Pmap.transform + let exists = Pmap.exists + + let compose m1 m2 = + let pk ((_,a),n) = peek m2 (n,a) + in + mapPartial pk m1 + ;; +end + +module Set = struct + type set = nameArity Pset.set + let empty = Pset.empty compare + let singleton x = Pset.singleton compare x + let fromList l = Pset.fromList compare l + let compare = Pset.compare + let add = Pset.add + let foldr = Pset.foldr + let foldl = Pset.foldl + let member x s = Pset.member x s + let union = Pset.union + let difference = Pset.difference + let toList = Pset.toList + let null = Pset.null + let size = Pset.size + let pick = Pset.pick + let equal = Pset.equal + let exists p s = Pset.exists p s + let delete = Pset.delete + let subset = Pset.subset + let intersect = Pset.intersect + let intersectList = function + [] -> empty + | (s::ss) -> List.fold_right Pset.intersect ss s + let findl = Pset.findl + let firstl = Pset.firstl + let transform = Pset.transform + let all p s = Pset.all p s + let count p s = Pset.count p s + + let allNullary = all nullary;; +end + +end + +(* ========================================================================= *) +(* FIRST ORDER LOGIC TERMS *) +(* ========================================================================= *) + +module Term = struct + +(* ------------------------------------------------------------------------- *) +(* A type of first order logic terms. *) +(* ------------------------------------------------------------------------- *) + +type var = Name.name;; + +type functionName = Name.name;; + +type function_t = functionName * int;; + +type const = functionName;; + +type term = + Tvar of Name.name + | Fn of (Name.name * term list);; + +(* ------------------------------------------------------------------------- *) +(* Constructors and destructors. *) +(* ------------------------------------------------------------------------- *) + +(* Variables *) + +let destVar = function + (Tvar v) -> v + | (Fn _) -> failwith "destVar";; + +let isVar = can destVar;; + +let equalVar v = function + (Tvar v') -> Name.equal v v' + | _ -> false;; + +(* Functions *) + +let destFn = function + (Fn f) -> f + | (Tvar _) -> failwith "destFn";; + +let isFn = can destFn;; + +let fnName tm = fst (destFn tm);; + +let fnArguments tm = snd (destFn tm);; + +let fnArity tm = List.length (fnArguments tm);; + +let fnFunction tm = (fnName tm, fnArity tm);; + +let functions tm = + let rec letc fs = function + [] -> fs + | (Tvar _ :: tms) -> letc fs tms + | (Fn (n,l) :: tms) -> letc (Name_arity.Set.add fs (n, List.length l)) (l @ tms) + + in letc Name_arity.Set.empty [tm];; + +let functionNames tm = + let rec letc fs = function + [] -> fs + | (Tvar _ :: tms) -> letc fs tms + | (Fn (n,l) :: tms) -> letc (Name.Set.add fs n) (l @ tms) + in letc Name.Set.empty [tm];; + +(* Constants *) + +let mkConst c = (Fn (c, []));; + +let destConst = function + (Fn (c, [])) -> c + | _ -> failwith "destConst";; + +let isConst = can destConst;; + +(* Binary functions *) + +let mkBinop f (a,b) = Fn (f,[a;b]);; + +let destBinop f = function + (Fn (x,[a;b])) -> + if Name.equal x f then (a,b) else failwith "Term.destBinop: wrong binop" + | _ -> failwith "Term.destBinop: not a binop";; + +let isBinop f = can (destBinop f);; + +(* ------------------------------------------------------------------------- *) +(* The size of a term in symbols. *) +(* ------------------------------------------------------------------------- *) + +let vAR_SYMBOLS = 1;; + +let fN_SYMBOLS = 1;; + +let symbols tm = + let rec sz n = function + [] -> n + | (Tvar _ :: tms) -> sz (n + vAR_SYMBOLS) tms + | (Fn (letc,args) :: tms) -> sz (n + fN_SYMBOLS) (args @ tms) + in sz 0 [tm];; + +(* ------------------------------------------------------------------------- *) +(* A total comparison function for terms. *) +(* ------------------------------------------------------------------------- *) + +let compare tm1 tm2 = + let rec cmp = function + ([], []) -> 0 + | (tm1 :: tms1, tm2 :: tms2) -> + (* if tm1 == tm2 then cmp (tms1, tms2) else *) + (match (tm1,tm2) with + (Tvar v1, Tvar v2) -> + let c = Name.compare v1 v2 in + if c <> 0 then c else cmp (tms1, tms2) + | (Tvar _, Fn _) -> -1 + | (Fn _, Tvar _) -> 1 + | (Fn (f1,a1), Fn (f2,a2)) -> + let c = Name.compare f1 f2 in + if c <> 0 then c + else + let c = Useful.intCompare (List.length a1) (List.length a2) in + if c <> 0 then c else cmp (a1 @ tms1, a2 @ tms2)) + | _ -> raise (Useful.Bug "Term.compare") + in cmp ([tm1], [tm2]);; + +let equal tm1 tm2 = compare tm1 tm2 = 0;; + +(* ------------------------------------------------------------------------- *) +(* Subterms. *) +(* ------------------------------------------------------------------------- *) + +type path = int list;; + +let rec subterm' = function + (tm, []) -> tm + | (Tvar _, _ :: _) -> failwith "Term.subterm: Var" + | (Fn (_,tms), h :: t) -> + if h >= List.length tms then failwith "Term.replace: Fn" + else subterm' (List.nth tms h, t);; +let subterm s t = subterm' (s, t);; + +let subterms tm = + let rec subtms = function + ([], acc) -> acc + | ((path,tm) :: rest, acc) -> + let f (n,arg) = (n :: path, arg) + and acc = (List.rev path, tm) :: acc + in match tm with + Tvar _ -> subtms (rest, acc) + | Fn (_,args) -> subtms ((List.map f (Mlist.enumerate args) @ rest), acc) + in subtms ([([],tm)], []);; + + +let rec replace tm = function + ([],res) -> if equal res tm then tm else res + | (h :: t, res) -> + match tm with + Tvar _ -> failwith "Term.replace: Var" + | Fn (letc,tms) -> + if h >= List.length tms then failwith "Term.replace: Fn" + else + let arg = List.nth tms h in + let arg' = replace arg (t,res) + in + (* if arg' == arg then tm else *) + Fn (letc, Mlist.updateNth (h,arg') tms) +;; + +let find pred = + let rec search = function + [] -> None + | ((path,tm) :: rest) -> + if pred tm then Some (List.rev path) + else + match tm with + Tvar _ -> search rest + | Fn (_,a) -> + let subtms = List.map (fun (i,t) -> (i :: path, t)) (Mlist.enumerate a) + in search (subtms @ rest) + in + fun tm -> search [([],tm)];; + + +(* ------------------------------------------------------------------------- *) +(* Free variables. *) +(* ------------------------------------------------------------------------- *) + +let freeIn v tm = + let rec free v = function + [] -> false + | (Tvar w :: tms) -> Name.equal v w || free v tms + | (Fn (_,args) :: tms) -> free v (args @ tms) + in free v [tm];; + +let freeVarsList = + let rec free vs = function + [] -> vs + | (Tvar v :: tms) -> free (Name.Set.add vs v) tms + | (Fn (_,args) :: tms) -> free vs (args @ tms) + in free Name.Set.empty;; + +let freeVars tm = freeVarsList [tm];; + +(* ------------------------------------------------------------------------- *) +(* Fresh variables. *) +(* ------------------------------------------------------------------------- *) + +let newVar () = Tvar (Name.newName ());; + +let newVars n = List.map (fun x -> Tvar x) (Name.newNames n);; + +let avoid av n = Name.Set.member n av;; +let variantPrime av = Name.variantPrime (avoid av);; +let variantNum av = Name.variantNum (avoid av);; + +(* ------------------------------------------------------------------------- *) +(* Special support for terms with type annotations. *) +(* ------------------------------------------------------------------------- *) + +let hasTypeFunctionName = Name.fromString ":";; + +let hasTypeFunction = (hasTypeFunctionName,2);; + +let destFnHasType ((f,a) : functionName * term list) = + if not (Name.equal f hasTypeFunctionName) then + failwith "Term.destFnHasType" + else + match a with + [tm;ty] -> (tm,ty) + | _ -> failwith "Term.destFnHasType";; + +let isFnHasType = can destFnHasType;; + +let isTypedVar tm = + match tm with + Tvar _ -> true + | Fn letc -> + match Useful.total destFnHasType letc with + Some (Tvar _, _) -> true + | _ -> false;; + +let typedSymbols tm = + let rec sz n = function + [] -> n + | (tm :: tms) -> + match tm with + Tvar _ -> sz (n + 1) tms + | Fn letc -> + match Useful.total destFnHasType letc with + Some (tm,_) -> sz n (tm :: tms) + | None -> + let (_,a) = letc + in sz (n + 1) (a @ tms) + in sz 0 [tm];; + +let nonVarTypedSubterms tm = + let rec subtms = function + ([], acc) -> acc + | ((path,tm) :: rest, acc) -> + (match tm with + Tvar _ -> subtms (rest, acc) + | Fn letc -> + (match Useful.total destFnHasType letc with + Some (t,_) -> + (match t with + Tvar _ -> subtms (rest, acc) + | Fn _ -> + let acc = (List.rev path, tm) :: acc + and rest = (0 :: path, t) :: rest + in subtms (rest, acc) + ) + | None -> + let f (n,arg) = (n :: path, arg) in + let (_,args) = letc in + let acc = (List.rev path, tm) :: acc in + let rest = List.map f (Mlist.enumerate args) @ rest + in + subtms (rest, acc))) + in subtms ([([],tm)], []);; + +(* ------------------------------------------------------------------------- *) +(* Special support for terms with an explicit function application operator. *) +(* ------------------------------------------------------------------------- *) + +let appName = Name.fromString ".";; + +let mkFnApp (fTm,aTm) = (appName, [fTm;aTm]);; + +let mkApp f_a = Fn (mkFnApp f_a);; + +let destFnApp ((f,a) : Name.name * term list) = + if not (Name.equal f appName) then failwith "Term.destFnApp" + else + match a with + [fTm;aTm] -> (fTm,aTm) + | _ -> failwith "Term.destFnApp";; + +let isFnApp = can destFnApp;; + +let destApp tm = + match tm with + Tvar _ -> failwith "Term.destApp" + | Fn letc -> destFnApp letc;; + +let isApp = can destApp;; + +let listMkApp (f,l) = List.fold_left (fun acc x -> mkApp (x, acc)) f l;; + +let stripApp tm = + let rec strip tms tm = + match Useful.total destApp tm with + Some (f,a) -> strip (a :: tms) f + | None -> (tm,tms) + in strip [] tm;; + +(* ------------------------------------------------------------------------- *) +(* Parsing and pretty printing. *) +(* ------------------------------------------------------------------------- *) + +let rec toString = function + Tvar v -> v + | Fn (n, []) -> n + | Fn (n, l) -> n ^ "(" ^ String.concat ", " (List.map toString l) ^ ")";; + +module Ordered = +struct type t = term let compare = compare end + +module Map = struct + type 'a map = (term, 'a) Pmap.map + let newMap () = Pmap.newMap compare + let null = Pmap.null + let singleton kv = Pmap.singleton compare kv + let size = Pmap.size + let get = Pmap.get + let peek = Pmap.peek + let insert = Pmap.insert + let toList = Pmap.toList + let fromList l = Pmap.fromList compare l + let foldl = Pmap.foldl + let foldr = Pmap.foldr + let filter = Pmap.filter + let inDomain k m = Pmap.inDomain k m + let union = Pmap.union + let delete = Pmap.delete + let mapPartial = Pmap.mapPartial + let transform = Pmap.transform + let exists = Pmap.exists +end + +module Set = struct + type set = term Pset.set + let empty = Pset.empty compare + let singleton x = Pset.singleton compare x + let fromList l = Pset.fromList compare l + let compare = Pset.compare + let add = Pset.add + let foldr = Pset.foldr + let foldl = Pset.foldl + let member x s = Pset.member x s + let union = Pset.union + let difference = Pset.difference + let toList = Pset.toList + let null = Pset.null + let size = Pset.size + let pick = Pset.pick + let equal = Pset.equal + let exists p s = Pset.exists p s + let delete = Pset.delete + let subset = Pset.subset + let intersect = Pset.intersect + let intersectList = function + [] -> empty + | (s::ss) -> List.fold_right Pset.intersect ss s + let findl = Pset.findl + let firstl = Pset.firstl + let transform = Pset.transform + let all p s = Pset.all p s + let count p s = Pset.count p s +end + +end + +(* ========================================================================= *) +(* FIRST ORDER LOGIC SUBSTITUTIONS *) +(* ========================================================================= *) + +module Substitute = struct + +(* ------------------------------------------------------------------------- *) +(* A type of first order logic substitutions. *) +(* ------------------------------------------------------------------------- *) + +type subst = Subst of Term.term Name.Map.map;; + +(* ------------------------------------------------------------------------- *) +(* Basic operations. *) +(* ------------------------------------------------------------------------- *) + +let empty = Subst (Name.Map.newMap ());; + +let null (Subst m) = Name.Map.null m;; + +let size (Subst m) = Name.Map.size m;; + +let peek (Subst m) v = Name.Map.peek m v;; + +let insert (Subst m) v_tm = Subst (Name.Map.insert m v_tm);; + +let singleton v_tm = insert empty v_tm;; + +let toList (Subst m) = Name.Map.toList m;; + +let fromList l = Subst (Name.Map.fromList l);; + +let foldl f b (Subst m) = Name.Map.foldl f b m;; + +let foldr f b (Subst m) = Name.Map.foldr f b m;; + + +(* ------------------------------------------------------------------------- *) +(* Normalizing removes identity substitutions. *) +(* ------------------------------------------------------------------------- *) + +let normalize (Subst m as sub) = + let isNotId (v, tm) = not (Term.equalVar v tm) in + let m' = Name.Map.filter isNotId m + in if Name.Map.size m = Name.Map.size m' then sub else Subst m' +;; + +(* ------------------------------------------------------------------------- *) +(* Applying a substitution to a first order logic term. *) +(* ------------------------------------------------------------------------- *) + +let subst sub = + let rec tmSub = function + (Term.Tvar v as tm) -> + (match peek sub v with + Some tm' -> (* if tm == tm' then tm else *) tm' + | None -> tm) + | (Term.Fn (f,args) as tm) -> + let args' = List.map tmSub args + in + (* if args == args' then tm else *) + Term.Fn (f,args') + in + fun tm -> if null sub then tm else tmSub tm + ;; + +(* ------------------------------------------------------------------------- *) +(* Restricting a substitution to a given set of variables. *) +(* ------------------------------------------------------------------------- *) + +let restrict (Subst m as sub) varSet = + let isRestrictedVar (v, _) = Name.Set.member v varSet in + let m' = Name.Map.filter isRestrictedVar m + in + if Name.Map.size m = Name.Map.size m' then sub else Subst m' + ;; + +let remove (Subst m as sub) varSet = + let isRestrictedVar (v, _) = not (Name.Set.member v varSet) in + let m' = Name.Map.filter isRestrictedVar m + in + if Name.Map.size m = Name.Map.size m' then sub else Subst m' + ;; + +(* ------------------------------------------------------------------------- *) +(* Composing two substitutions so that the following identity holds: *) +(* *) +(* subst (compose sub1 sub2) tm = subst sub2 (subst sub1 tm) *) +(* ------------------------------------------------------------------------- *) + +let compose (Subst m1 as sub1) sub2 = + let f (v,tm,s) = insert s (v, subst sub2 tm) + in + if null sub2 then sub1 else Name.Map.foldl f sub2 m1 + ;; + +(* ------------------------------------------------------------------------- *) +(* Creating the union of two compatible substitutions. *) +(* ------------------------------------------------------------------------- *) + +let union (Subst m1 as s1) (Subst m2 as s2) = + let compatible ((_,tm1),(_,tm2)) = + if Term.equal tm1 tm2 then Some tm1 + else failwith "Substitute.union: incompatible" + in + if Name.Map.null m1 then s2 + else if Name.Map.null m2 then s1 + else Subst (Name.Map.union compatible m1 m2) +;; + +(* ------------------------------------------------------------------------- *) +(* Substitutions can be inverted iff they are renaming substitutions. *) +(* ------------------------------------------------------------------------- *) + +let invert (Subst m) = + let inv = function + (v, Term.Tvar w, s) -> + if Name.Map.inDomain w s then failwith "Substitute.invert: non-injective" + else Name.Map.insert s (w, Term.Tvar v) + | (_, Term.Fn _, _) -> failwith "Substitute.invert: non-variable" + in Subst (Name.Map.foldl inv (Name.Map.newMap ()) m) +;; + +let isRenaming = can invert;; + +(* ------------------------------------------------------------------------- *) +(* Creating a substitution to freshen variables. *) +(* ------------------------------------------------------------------------- *) + +let freshVars s = + let add (v, m) = insert m (v, Term.newVar ()) + in + Name.Set.foldl add empty s + ;; + +(* ------------------------------------------------------------------------- *) +(* Free variables. *) +(* ------------------------------------------------------------------------- *) + +let redexes = + let add (v,_,s) = Name.Set.add s v + in + foldl add Name.Set.empty + ;; + +let residueFreeVars = + let add (_,t,s) = Name.Set.union s (Term.freeVars t) + in + foldl add Name.Set.empty + ;; + +let freeVars = + let add (v,t,s) = Name.Set.union (Name.Set.add s v) (Term.freeVars t) + in + foldl add Name.Set.empty + ;; + +(* ------------------------------------------------------------------------- *) +(* Functions. *) +(* ------------------------------------------------------------------------- *) + +let functions = + let add (_,t,s) = Name_arity.Set.union s (Term.functions t) + in + foldl add Name_arity.Set.empty + ;; + +(* ------------------------------------------------------------------------- *) +(* Matching for first order logic terms. *) +(* ------------------------------------------------------------------------- *) + +let matchTerms sub tm1 tm2 = + let rec matchList sub = function + [] -> sub + | ((Term.Tvar v, tm) :: rest) -> + let sub = + match peek sub v with + None -> insert sub (v,tm) + | Some tm' -> + if Term.equal tm tm' then sub + else failwith "Substitute.match: incompatible matches" + in + matchList sub rest + | ((Term.Fn (f1,args1), Term.Fn (f2,args2)) :: rest) -> + if Name.equal f1 f2 && length args1 = length args2 then + matchList sub (zip args1 args2 @ rest) + else failwith "Substitute.match: different structure" + | _ -> failwith "Substitute.match: functions can't match vars" + in matchList sub [(tm1,tm2)] +;; + +(* ------------------------------------------------------------------------- *) +(* Unification for first order logic terms. *) +(* ------------------------------------------------------------------------- *) + +let unify sub tm1 tm2 = + let rec solve sub = function + [] -> sub + | ((tm1,tm2) :: rest) -> + (* if tm1 == tm2 then solve sub rest else *) + solve' sub (subst sub tm1, subst sub tm2, rest) + + and solve' sub = function + ((Term.Tvar v), tm, rest) -> + if Term.equalVar v tm then solve sub rest + else if Term.freeIn v tm then failwith "Substitute.unify: occurs check" + else + (match peek sub v with + None -> solve (compose sub (singleton (v,tm))) rest + | Some tm' -> solve' sub (tm', tm, rest)) + | (tm1, ((Term.Tvar _) as tm2), rest) -> solve' sub (tm2, tm1, rest) + | (Term.Fn (f1,args1), Term.Fn (f2,args2), rest) -> + if Name.equal f1 f2 && length args1 = length args2 then + solve sub (zip args1 args2 @ rest) + else + failwith "Substitute.unify: different structure" + + in solve sub [(tm1,tm2)];; + +end + +(* ========================================================================= *) +(* FIRST ORDER LOGIC ATOMS *) +(* ========================================================================= *) + +module Atom = struct + +(* ------------------------------------------------------------------------- *) +(* A type for storing first order logic atoms. *) +(* ------------------------------------------------------------------------- *) + +type relationName = Name.name;; + +type relation = relationName * int;; + +type atom = relationName * Term.term list;; + +(* ------------------------------------------------------------------------- *) +(* Constructors and destructors. *) +(* ------------------------------------------------------------------------- *) + +let name ((rel,_) : atom) = rel;; + +let arguments ((_,args) : atom) = args;; + +let arity atm = length (arguments atm);; + +let relation atm = (name atm, arity atm);; + +let functions = + let f (tm,acc) = Name_arity.Set.union (Term.functions tm) acc + in + fun atm -> Mlist.foldl f Name_arity.Set.empty (arguments atm) + ;; + +let functionNames = + let f (tm,acc) = Name.Set.union (Term.functionNames tm) acc + in + fun atm -> Mlist.foldl f Name.Set.empty (arguments atm) + ;; + +(* Binary relations *) + +let mkBinop p (a,b) : atom = (p,[a;b]);; + +let destBinop p = function + (x,[a;b]) -> + if Name.equal x p then (a,b) else failwith "Atom.destBinop: wrong binop" + | _ -> failwith "Atom.destBinop: not a binop";; + +let isBinop p = can (destBinop p);; + +(* ------------------------------------------------------------------------- *) +(* The size of an atom in symbols. *) +(* ------------------------------------------------------------------------- *) + +let symbols atm = + Mlist.foldl (fun (tm,z) -> Term.symbols tm + z) 1 (arguments atm);; + +(* ------------------------------------------------------------------------- *) +(* A total comparison function for atoms. *) +(* ------------------------------------------------------------------------- *) + +let compare (p1,tms1) (p2,tms2) = + let c = Name.compare p1 p2 in + if c <> 0 then c else Useful.lexCompare Term.compare tms1 tms2;; + +let equal atm1 atm2 = compare atm1 atm2 = 0;; + +(* ------------------------------------------------------------------------- *) +(* Subterms. *) +(* ------------------------------------------------------------------------- *) + +let subterm (_, tms) = function + [] -> raise (Useful.Bug "Atom.subterm: empty path") + | (h :: t) -> + if h >= length tms then failwith "Atom.subterm: bad path" + else Term.subterm (List.nth tms h) t + +let subterms ((_,tms) : atom) = + let f ((n,tm),l) = List.map (fun (p,s) -> (n :: p, s)) (Term.subterms tm) @ l + in + Mlist.foldl f [] (Mlist.enumerate tms) + ;; + +let replace ((rel,tms) as atm) = function + ([],_) -> raise (Useful.Bug "Atom.replace: empty path") + | (h :: t, res) -> + if h >= length tms then failwith "Atom.replace: bad path" + else + let tm = List.nth tms h + in let tm' = Term.replace tm (t,res) + in + (* if tm == tm' then atm else *) + (rel, Mlist.updateNth (h,tm') tms) + ;; + +let find pred = + let f (i,tm) = + match Term.find pred tm with + Some path -> Some (i :: path) + | None -> None + in + fun (_,tms) -> Mlist.first f (Mlist.enumerate tms) + ;; + +(* ------------------------------------------------------------------------- *) +(* Free variables. *) +(* ------------------------------------------------------------------------- *) + +let freeIn v atm = List.exists (Term.freeIn v) (arguments atm);; + +let freeVars = + let f (tm,acc) = Name.Set.union (Term.freeVars tm) acc + in + fun atm -> Mlist.foldl f Name.Set.empty (arguments atm) + ;; + +(* ------------------------------------------------------------------------- *) +(* Substitutions. *) +(* ------------------------------------------------------------------------- *) + +let subst sub ((p,tms) as atm) : atom = + let tms' = List.map (Substitute.subst sub) tms + in + (* if tms' == tms then atm else *) (p,tms') + ;; + +(* ------------------------------------------------------------------------- *) +(* Matching. *) +(* ------------------------------------------------------------------------- *) + +let matchAtoms sub (p1,tms1) (p2,tms2) = + let matchArg ((tm1,tm2),sub) = Substitute.matchTerms sub tm1 tm2 in + let _ = (Name.equal p1 p2 && length tms1 = length tms2) || + failwith "Atom.match" + in + Mlist.foldl matchArg sub (zip tms1 tms2) + ;; + +(* ------------------------------------------------------------------------- *) +(* Unification. *) +(* ------------------------------------------------------------------------- *) + +let unify sub (p1,tms1) (p2,tms2) = + let unifyArg ((tm1,tm2),sub) = Substitute.unify sub tm1 tm2 in + let _ = (Name.equal p1 p2 && length tms1 = length tms2) || + failwith "Atom.unify" + in + Mlist.foldl unifyArg sub (zip tms1 tms2) + ;; + +(* ------------------------------------------------------------------------- *) +(* The equality relation. *) +(* ------------------------------------------------------------------------- *) + +let eqRelationName = Name.fromString "=";; + +let eqRelationArity = 2;; + +let eqRelation = (eqRelationName,eqRelationArity);; + +let mkEq = mkBinop eqRelationName;; + +let destEq x = destBinop eqRelationName x;; + +let isEq x = isBinop eqRelationName x;; + +let mkRefl tm = mkEq (tm,tm);; + +let destRefl atm = + let (l,r) = destEq atm + in let _ = Term.equal l r || failwith "Atom.destRefl" + in + l + ;; + +let isRefl x = can destRefl x;; + +let sym atm = + let (l,r) = destEq atm + in let _ = not (Term.equal l r) || failwith "Atom.sym: refl" + in + mkEq (r,l) + ;; + +let lhs atm = fst (destEq atm);; + +let rhs atm = snd (destEq atm);; + +(* ------------------------------------------------------------------------- *) +(* Special support for terms with type annotations. *) +(* ------------------------------------------------------------------------- *) + +let typedSymbols ((_,tms) : atom) = + Mlist.foldl (fun (tm,z) -> Term.typedSymbols tm + z) 1 tms;; + +let nonVarTypedSubterms (_,tms) = + let addArg ((n,arg),acc) = + let addTm ((path,tm),acc) = (n :: path, tm) :: acc + in + Mlist.foldl addTm acc (Term.nonVarTypedSubterms arg) + in + Mlist.foldl addArg [] (Mlist.enumerate tms) + ;; + + +module Ordered = +struct type t = atom let compare = compare end + +module Map = struct + type 'a map = (atom, 'a) Pmap.map + let newMap () = Pmap.newMap compare + let null = Pmap.null + let singleton kv = Pmap.singleton compare kv + let size = Pmap.size + let get = Pmap.get + let peek = Pmap.peek + let insert = Pmap.insert + let toList = Pmap.toList + let fromList l = Pmap.fromList compare l + let foldl = Pmap.foldl + let foldr = Pmap.foldr + let filter = Pmap.filter + let inDomain k m = Pmap.inDomain k m + let union = Pmap.union + let delete = Pmap.delete + let mapPartial = Pmap.mapPartial + let transform = Pmap.transform + let exists = Pmap.exists +end + +module Set = struct + type set = atom Pset.set + let empty = Pset.empty compare + let singleton x = Pset.singleton compare x + let fromList l = Pset.fromList compare l + let compare = Pset.compare + let add = Pset.add + let foldr = Pset.foldr + let foldl = Pset.foldl + let member x s = Pset.member x s + let union = Pset.union + let difference = Pset.difference + let toList = Pset.toList + let null = Pset.null + let size = Pset.size + let pick = Pset.pick + let equal = Pset.equal + let exists p s = Pset.exists p s + let delete = Pset.delete + let subset = Pset.subset + let intersect = Pset.intersect + let intersectList = function + [] -> empty + | (s::ss) -> List.fold_right Pset.intersect ss s + let findl = Pset.findl + let firstl = Pset.firstl + let transform = Pset.transform + let all p s = Pset.all p s + let count p s = Pset.count p s +end + +end + + +(* ========================================================================= *) +(* FIRST ORDER LOGIC FORMULAS *) +(* ========================================================================= *) + +module Formula = struct + +(* ------------------------------------------------------------------------- *) +(* A type of first order logic formulas. *) +(* ------------------------------------------------------------------------- *) + +type formula = + Ftrue + | Ffalse + | Atom of Atom.atom + | Not of formula + | And of formula * formula + | Or of formula * formula + | Imp of formula * formula + | Iff of formula * formula + | Forall of Term.var * formula + | Exists of Term.var * formula;; + +(* ------------------------------------------------------------------------- *) +(* Constructors and destructors. *) +(* ------------------------------------------------------------------------- *) + +(* Booleans *) + +let mkBoolean = function + true -> Ftrue + | false -> Ffalse;; + +let destBoolean = + function Ftrue -> true + | Ffalse -> false + | _ -> failwith "destBoolean";; + +let isBoolean = can destBoolean;; + +let isTrue fm = + match fm with + Ftrue -> true + | _ -> false;; + +let isFalse fm = + match fm with + Ffalse -> true + | _ -> false;; + +(* Functions *) + +let functions fm = + let rec funcs fs = function + [] -> fs + | (Ftrue :: fms) -> funcs fs fms + | (Ffalse :: fms) -> funcs fs fms + | (Atom atm :: fms) -> funcs (Name_arity.Set.union (Atom.functions atm) fs) fms + | (Not p :: fms) -> funcs fs (p :: fms) + | (And (p,q) :: fms) -> funcs fs (p :: q :: fms) + | (Or (p,q) :: fms) -> funcs fs (p :: q :: fms) + | (Imp (p,q) :: fms) -> funcs fs (p :: q :: fms) + | (Iff (p,q) :: fms) -> funcs fs (p :: q :: fms) + | (Forall (_,p) :: fms) -> funcs fs (p :: fms) + | (Exists (_,p) :: fms) -> funcs fs (p :: fms) + in + funcs Name_arity.Set.empty [fm];; + +let functionNames fm = + let rec funcs fs = function + [] -> fs + | (Ftrue :: fms) -> funcs fs fms + | (Ffalse :: fms) -> funcs fs fms + | (Atom atm :: fms) -> funcs (Name.Set.union (Atom.functionNames atm) fs) fms + | (Not p :: fms) -> funcs fs (p :: fms) + | (And (p,q) :: fms) -> funcs fs (p :: q :: fms) + | (Or (p,q) :: fms) -> funcs fs (p :: q :: fms) + | (Imp (p,q) :: fms) -> funcs fs (p :: q :: fms) + | (Iff (p,q) :: fms) -> funcs fs (p :: q :: fms) + | (Forall (_,p) :: fms) -> funcs fs (p :: fms) + | (Exists (_,p) :: fms) -> funcs fs (p :: fms) + in + funcs Name.Set.empty [fm];; + +(* Relations *) +let relations fm = + let rec rels fs = function + [] -> fs + | (Ftrue :: fms) -> rels fs fms + | (Ffalse :: fms) -> rels fs fms + | (Atom atm :: fms) -> + rels (Name_arity.Set.add fs (Atom.relation atm)) fms + | (Not p :: fms) -> rels fs (p :: fms) + | (And (p,q) :: fms) -> rels fs (p :: q :: fms) + | (Or (p,q) :: fms) -> rels fs (p :: q :: fms) + | (Imp (p,q) :: fms) -> rels fs (p :: q :: fms) + | (Iff (p,q) :: fms) -> rels fs (p :: q :: fms) + | (Forall (_,p) :: fms) -> rels fs (p :: fms) + | (Exists (_,p) :: fms) -> rels fs (p :: fms) + in rels Name_arity.Set.empty [fm];; + + +let relationNames fm = + let rec rels fs = function + [] -> fs + | (Ftrue :: fms) -> rels fs fms + | (Ffalse :: fms) -> rels fs fms + | (Atom atm :: fms) -> rels (Name.Set.add fs (Atom.name atm)) fms + | (Not p :: fms) -> rels fs (p :: fms) + | (And (p,q) :: fms) -> rels fs (p :: q :: fms) + | (Or (p,q) :: fms) -> rels fs (p :: q :: fms) + | (Imp (p,q) :: fms) -> rels fs (p :: q :: fms) + | (Iff (p,q) :: fms) -> rels fs (p :: q :: fms) + | (Forall (_,p) :: fms) -> rels fs (p :: fms) + | (Exists (_,p) :: fms) -> rels fs (p :: fms) + in rels Name.Set.empty [fm];; + +(* Atoms *) + +let destAtom = function + (Atom atm) -> atm + | _ -> failwith "Formula.destAtom";; + +let isAtom = can destAtom;; + +(* Negations *) + +let destNeg = function + (Not p) -> p + | _ -> failwith "Formula.destNeg";; + +let isNeg = can destNeg;; + +let stripNeg = + let rec strip n = function + (Not fm) -> strip (n + 1) fm + | fm -> (n,fm) + in + strip 0 + ;; + +(* Conjunctions *) + +let listMkConj fms = + match List.rev fms with + [] -> Ftrue + | fm :: fms -> Mlist.foldl (fun (x, y) -> And (x, y)) fm fms;; + +let stripConj = + let rec strip cs = function + (And (p,q)) -> strip (p :: cs) q + | fm -> List.rev (fm :: cs) + in function + Ftrue -> [] + | fm -> strip [] fm;; + +let flattenConj = + let rec flat acc = function + [] -> acc + | (And (p,q) :: fms) -> flat acc (q :: p :: fms) + | (Ftrue :: fms) -> flat acc fms + | (fm :: fms) -> flat (fm :: acc) fms + in + fun fm -> flat [] [fm] + ;; + +(* Disjunctions *) + +let listMkDisj fms = + match List.rev fms with + [] -> Ffalse + | fm :: fms -> Mlist.foldl (fun (x,y) -> Or (x,y)) fm fms;; + +let stripDisj = + let rec strip cs = function + (Or (p,q)) -> strip (p :: cs) q + | fm -> List.rev (fm :: cs) + in function + Ffalse -> [] + | fm -> strip [] fm;; + +let flattenDisj = + let rec flat acc = function + [] -> acc + | (Or (p,q) :: fms) -> flat acc (q :: p :: fms) + | (Ffalse :: fms) -> flat acc fms + | (fm :: fms) -> flat (fm :: acc) fms + in + fun fm -> flat [] [fm] + ;; + +(* Equivalences *) + +let listMkEquiv fms = + match List.rev fms with + [] -> Ftrue + | fm :: fms -> Mlist.foldl (fun (x,y) -> Iff (x,y)) fm fms;; + +let stripEquiv = + let rec strip cs = function + (Iff (p,q)) -> strip (p :: cs) q + | fm -> List.rev (fm :: cs) + in function + Ftrue -> [] + | fm -> strip [] fm;; + +let flattenEquiv = + let rec flat acc = function + [] -> acc + | (Iff (p,q) :: fms) -> flat acc (q :: p :: fms) + | (Ftrue :: fms) -> flat acc fms + | (fm :: fms) -> flat (fm :: acc) fms + in + fun fm -> flat [] [fm] + ;; + +(* Universal quantifiers *) + +let destForall = function + (Forall (v,f)) -> (v,f) + | _ -> failwith "destForall";; + +let isForall = can destForall;; + +let rec listMkForall = function + ([],body) -> body + | (v :: vs, body) -> Forall (v, listMkForall (vs,body));; + +let setMkForall (vs,body) = Name.Set.foldr (fun (x,y) -> Forall (x,y)) body vs;; + +let stripForall = + let rec strip vs = function + (Forall (v,b)) -> strip (v :: vs) b + | tm -> (List.rev vs, tm) + in + strip [];; + +(* Existential quantifiers *) + +let destExists = function + (Exists (v,f)) -> (v,f) + | _ -> failwith "destExists";; + +let isExists = can destExists;; + +let rec listMkExists = function + ([],body) -> body + | (v :: vs, body) -> Exists (v, listMkExists (vs,body));; + +let setMkExists (vs,body) = Name.Set.foldr (fun (x,y) -> Exists (x,y)) body vs;; + +let stripExists = + let rec strip vs = function + (Exists (v,b)) -> strip (v :: vs) b + | tm -> (List.rev vs, tm) + in + strip [];; + +(* ------------------------------------------------------------------------- *) +(* The size of a formula in symbols. *) +(* ------------------------------------------------------------------------- *) + +let symbols fm = + let rec sz n = function + [] -> n + | (Ftrue :: fms) -> sz (n + 1) fms + | (Ffalse :: fms) -> sz (n + 1) fms + | (Atom atm :: fms) -> sz (n + Atom.symbols atm) fms + | (Not p :: fms) -> sz (n + 1) (p :: fms) + | (And (p,q) :: fms) -> sz (n + 1) (p :: q :: fms) + | (Or (p,q) :: fms) -> sz (n + 1) (p :: q :: fms) + | (Imp (p,q) :: fms) -> sz (n + 1) (p :: q :: fms) + | (Iff (p,q) :: fms) -> sz (n + 1) (p :: q :: fms) + | (Forall (_,p) :: fms) -> sz (n + 1) (p :: fms) + | (Exists (_,p) :: fms) -> sz (n + 1) (p :: fms) +in + sz 0 [fm];; + +(* ------------------------------------------------------------------------- *) +(* A total comparison function for formulas. *) +(* ------------------------------------------------------------------------- *) + +let compare fm1 fm2 = + let rec cmp = function + [] -> 0 + | (((f1, f2) as f1_f2) :: fs) -> + (* if f1 == f2 then cmp fs else *) + match f1_f2 with + (Ftrue,Ftrue) -> cmp fs + | (Ftrue,_) -> -1 + | (_,Ftrue) -> 1 + | (Ffalse,Ffalse) -> cmp fs + | (Ffalse,_) -> -1 + | (_,Ffalse) -> 1 + | (Atom atm1, Atom atm2) -> + let c = Atom.compare atm1 atm2 in + if c <> 0 then c else cmp fs + | (Atom _, _) -> -1 + | (_, Atom _) -> 1 + | (Not p1, Not p2) -> cmp ((p1,p2) :: fs) + | (Not _, _) -> -1 + | (_, Not _) -> 1 + | (And (p1,q1), And (p2,q2)) -> cmp ((p1,p2) :: (q1,q2) :: fs) + | (And _, _) -> -1 + | (_, And _) -> 1 + | (Or (p1,q1), Or (p2,q2)) -> cmp ((p1,p2) :: (q1,q2) :: fs) + | (Or _, _) -> -1 + | (_, Or _) -> 1 + | (Imp (p1,q1), Imp (p2,q2)) -> cmp ((p1,p2) :: (q1,q2) :: fs) + | (Imp _, _) -> -1 + | (_, Imp _) -> 1 + | (Iff (p1,q1), Iff (p2,q2)) -> cmp ((p1,p2) :: (q1,q2) :: fs) + | (Iff _, _) -> -1 + | (_, Iff _) -> 1 + | (Forall (v1,p1), Forall (v2,p2)) -> + let c = Name.compare v1 v2 in + if c <> 0 then c else cmp ((p1,p2) :: fs) + | (Forall _, Exists _) -> -1 + | (Exists _, Forall _) -> 1 + | (Exists (v1,p1), Exists (v2,p2)) -> + let c = Name.compare v1 v2 in + if c <> 0 then c else cmp ((p1,p2) :: fs) +in + cmp [(fm1,fm2)];; + +let equal fm1 fm2 = compare fm1 fm2 = 0;; + +(* ------------------------------------------------------------------------- *) +(* Free variables. *) +(* ------------------------------------------------------------------------- *) + +let freeIn v = + let rec f = function + [] -> false + | (Ftrue :: fms) -> f fms + | (Ffalse :: fms) -> f fms + | (Atom atm :: fms) -> Atom.freeIn v atm || f fms + | (Not p :: fms) -> f (p :: fms) + | (And (p,q) :: fms) -> f (p :: q :: fms) + | (Or (p,q) :: fms) -> f (p :: q :: fms) + | (Imp (p,q) :: fms) -> f (p :: q :: fms) + | (Iff (p,q) :: fms) -> f (p :: q :: fms) + | (Forall (w,p) :: fms) -> + if Name.equal v w then f fms else f (p :: fms) + | (Exists (w,p) :: fms) -> + if Name.equal v w then f fms else f (p :: fms) + in + fun fm -> f [fm] + ;; + +let add (fm,vs) = + let rec fv vs = function + [] -> vs + | ((_,Ftrue) :: fms) -> fv vs fms + | ((_,Ffalse) :: fms) -> fv vs fms + | ((bv, Atom atm) :: fms) -> + fv (Name.Set.union vs (Name.Set.difference (Atom.freeVars atm) bv)) fms + | ((bv, Not p) :: fms) -> fv vs ((bv,p) :: fms) + | ((bv, And (p,q)) :: fms) -> fv vs ((bv,p) :: (bv,q) :: fms) + | ((bv, Or (p,q)) :: fms) -> fv vs ((bv,p) :: (bv,q) :: fms) + | ((bv, Imp (p,q)) :: fms) -> fv vs ((bv,p) :: (bv,q) :: fms) + | ((bv, Iff (p,q)) :: fms) -> fv vs ((bv,p) :: (bv,q) :: fms) + | ((bv, Forall (v,p)) :: fms) -> fv vs ((Name.Set.add bv v, p) :: fms) + | ((bv, Exists (v,p)) :: fms) -> fv vs ((Name.Set.add bv v, p) :: fms) + + in fv vs [(Name.Set.empty,fm)];; + + let freeVars fm = add (fm,Name.Set.empty);; + + let freeVarsList fms = Mlist.foldl add Name.Set.empty fms;; + +let specialize fm = snd (stripForall fm);; + +let generalize fm = listMkForall (Name.Set.toList (freeVars fm), fm);; + +(* ------------------------------------------------------------------------- *) +(* Substitutions. *) +(* ------------------------------------------------------------------------- *) + + let rec substCheck sub fm = if Substitute.null sub then fm else substFm sub fm + + and substFm sub fm = match fm with + Ftrue -> fm + | Ffalse -> fm + | Atom (p,tms) -> + let tms' = List.map (Substitute.subst sub) tms + in + (* if tms == tms' then fm else *) Atom (p,tms') + | Not p -> + let p' = substFm sub p + in + (* if p == p' then fm else *) Not p' + | And (p,q) -> substConn sub fm (fun (x,y) -> And (x,y)) p q + | Or (p,q) -> substConn sub fm (fun (x,y) -> Or (x,y)) p q + | Imp (p,q) -> substConn sub fm (fun (x,y) -> Imp (x,y)) p q + | Iff (p,q) -> substConn sub fm (fun (x,y) -> Iff (x,y)) p q + | Forall (v,p) -> substQuant sub fm (fun (x,y) -> Forall (x,y)) v p + | Exists (v,p) -> substQuant sub fm (fun (x,y) -> Exists (x,y)) v p + + and substConn sub fm conn p q = + let p' = substFm sub p + and q' = substFm sub q + in + (* if p == p' && q == q' then fm else *) + conn (p',q') + + and substQuant sub fm quant v p = + let v' = + let f (w,s) = + if Name.equal w v then s + else + match Substitute.peek sub w with + None -> Name.Set.add s w + | Some tm -> Name.Set.union s (Term.freeVars tm) + + in let vars = freeVars p + in let vars = Name.Set.foldl f Name.Set.empty vars + in + Term.variantPrime vars v + + in let sub = + if Name.equal v v' then Substitute.remove sub (Name.Set.singleton v) + else Substitute.insert sub (v, Term.Tvar v') + + in let p' = substCheck sub p + in + (* if Name.equal v v' && p == p' then fm else *) + quant (v',p');; + + let subst = substCheck;; + +(* ------------------------------------------------------------------------- *) +(* The equality relation. *) +(* ------------------------------------------------------------------------- *) + +let mkEq a_b = Atom (Atom.mkEq a_b);; + +let destEq fm = Atom.destEq (destAtom fm);; + +let isEq = can destEq;; + +let mkNeq a_b = Not (mkEq a_b);; + +let destNeq = function + (Not fm) -> destEq fm + | _ -> failwith "Formula.destNeq";; + +let isNeq = can destNeq;; + +let mkRefl tm = Atom (Atom.mkRefl tm);; + +let destRefl fm = Atom.destRefl (destAtom fm);; + +let isRefl = can destRefl;; + +let sym fm = Atom (Atom.sym (destAtom fm));; + +let lhs fm = fst (destEq fm);; + +let rhs fm = snd (destEq fm);; + +(* ------------------------------------------------------------------------- *) +(* Parsing and pretty-printing. *) +(* ------------------------------------------------------------------------- *) + +let truthName = Name.fromString "T" +and falsityName = Name.fromString "F" +and conjunctionName = Name.fromString "/\\" +and disjunctionName = Name.fromString "\\/" +and implicationName = Name.fromString "==>" +and equivalenceName = Name.fromString "<=>" +and universalName = Name.fromString "!" +and existentialName = Name.fromString "?";; + + let rec demote = function + Ftrue -> Term.Fn (truthName,[]) + | Ffalse -> Term.Fn (falsityName,[]) + | (Atom (p,tms)) -> Term.Fn (p,tms) + | (Not p) -> + let + s = "~" + in + Term.Fn (Name.fromString s, [demote p]) + | (And (p,q)) -> Term.Fn (conjunctionName, [demote p; demote q]) + | (Or (p,q)) -> Term.Fn (disjunctionName, [demote p; demote q]) + | (Imp (p,q)) -> Term.Fn (implicationName, [demote p; demote q]) + | (Iff (p,q)) -> Term.Fn (equivalenceName, [demote p; demote q]) + | (Forall (v,b)) -> Term.Fn (universalName, [Term.Tvar v; demote b]) + | (Exists (v,b)) -> + Term.Fn (existentialName, [Term.Tvar v; demote b]);; + + let toString fm = Term.toString (demote fm);; + + +(* ------------------------------------------------------------------------- *) +(* Splitting goals. *) +(* ------------------------------------------------------------------------- *) + + let add_asms asms goal = + if Mlist.null asms then goal else Imp (listMkConj (List.rev asms), goal);; + + let add_var_asms asms v goal = add_asms asms (Forall (v,goal));; + + let rec split asms pol fm = + match (pol,fm) with + (* Positive splittables *) + (true,Ftrue) -> [] + | (true, Not f) -> split asms false f + | (true, And (f1,f2)) -> split asms true f1 @ split (f1 :: asms) true f2 + | (true, Or (f1,f2)) -> split (Not f1 :: asms) true f2 + | (true, Imp (f1,f2)) -> split (f1 :: asms) true f2 + | (true, Iff (f1,f2)) -> + split (f1 :: asms) true f2 @ split (f2 :: asms) true f1 + | (true, Forall (v,f)) -> List.map (add_var_asms asms v) (split [] true f) + (* Negative splittables *) + | (false,Ffalse) -> [] + | (false, Not f) -> split asms true f + | (false, And (f1,f2)) -> split (f1 :: asms) false f2 + | (false, Or (f1,f2)) -> + split asms false f1 @ split (Not f1 :: asms) false f2 + | (false, Imp (f1,f2)) -> split asms true f1 @ split (f1 :: asms) false f2 + | (false, Iff (f1,f2)) -> + split (f1 :: asms) false f2 @ split (Not f2 :: asms) true f1 + | (false, Exists (v,f)) -> List.map (add_var_asms asms v) (split [] false f) + (* Unsplittables *) + | _ -> [add_asms asms (if pol then fm else Not fm)];; + + let splitGoal fm = split [] true fm;; + +(*MetisTrace3 +let splitGoal = fun fm => + let + let result = splitGoal fm + let () = Print.trace pp "Formula.splitGoal: fm" fm + let () = Print.trace (Print.ppList pp) "Formula.splitGoal: result" result + in + result + end;; +*) + +module Ordered = +struct type t = formula let compare = compare end + +module Map = struct + type 'a map = (formula, 'a) Pmap.map + let newMap () = Pmap.newMap compare + let null = Pmap.null + let singleton kv = Pmap.singleton compare kv + let size = Pmap.size + let get = Pmap.get + let peek = Pmap.peek + let insert = Pmap.insert + let toList = Pmap.toList + let fromList l = Pmap.fromList compare l + let foldl = Pmap.foldl + let foldr = Pmap.foldr + let filter = Pmap.filter + let inDomain k m = Pmap.inDomain k m + let union = Pmap.union + let delete = Pmap.delete + let mapPartial = Pmap.mapPartial + let transform = Pmap.transform + let exists = Pmap.exists +end + +module Set = struct + type set = formula Pset.set + let empty = Pset.empty compare + let singleton x = Pset.singleton compare x + let fromList l = Pset.fromList compare l + let compare = Pset.compare + let add = Pset.add + let foldr = Pset.foldr + let foldl = Pset.foldl + let member x s = Pset.member x s + let union = Pset.union + let difference = Pset.difference + let toList = Pset.toList + let null = Pset.null + let size = Pset.size + let pick = Pset.pick + let equal = Pset.equal + let exists p s = Pset.exists p s + let delete = Pset.delete + let subset = Pset.subset + let intersect = Pset.intersect + let intersectList = function + [] -> empty + | (s::ss) -> List.fold_right Pset.intersect ss s + let findl = Pset.findl + let firstl = Pset.firstl + let transform = Pset.transform + let all p s = Pset.all p s + let count p s = Pset.count p s +end + +end + + +(* ========================================================================= *) +(* FIRST ORDER LOGIC LITERALS *) +(* ========================================================================= *) + +module Literal = struct + +(* ------------------------------------------------------------------------- *) +(* A type for storing first order logic literals. *) +(* ------------------------------------------------------------------------- *) + +type polarity = bool;; + +type literal = polarity * Atom.atom;; + +(* ------------------------------------------------------------------------- *) +(* Constructors and destructors. *) +(* ------------------------------------------------------------------------- *) + +let polarity ((pol,_) : literal) = pol;; + +let atom ((_,atm) : literal) = atm;; + +let name lit = Atom.name (atom lit);; + +let arguments lit = Atom.arguments (atom lit);; + +let arity lit = Atom.arity (atom lit);; + +let positive lit = polarity lit;; + +let negative lit = not (polarity lit);; + +let negate (pol,atm) : literal = (not pol, atm) + +let relation lit = Atom.relation (atom lit);; + +let functions lit = Atom.functions (atom lit);; + +let functionNames lit = Atom.functionNames (atom lit);; + +(* Binary relations *) + +let mkBinop rel (pol,a,b) : literal = (pol, Atom.mkBinop rel (a,b));; + +let destBinop rel ((pol,atm) : literal) = + match Atom.destBinop rel atm with (a,b) -> (pol,a,b);; + +let isBinop rel = can (destBinop rel);; + +(* Formulas *) + +let toFormula = function + (true,atm) -> Formula.Atom atm + | (false,atm) -> Formula.Not (Formula.Atom atm);; + +let fromFormula = function + (Formula.Atom atm) -> (true,atm) + | (Formula.Not (Formula.Atom atm)) -> (false,atm) + | _ -> failwith "Literal.fromFormula";; + +(* ------------------------------------------------------------------------- *) +(* The size of a literal in symbols. *) +(* ------------------------------------------------------------------------- *) + +let symbols ((_,atm) : literal) = Atom.symbols atm;; + +(* ------------------------------------------------------------------------- *) +(* A total comparison function for literals. *) +(* ------------------------------------------------------------------------- *) + +let compare = Useful.prodCompare Useful.boolCompare Atom.compare;; + +let equal (p1,atm1) (p2,atm2) = p1 = p2 && Atom.equal atm1 atm2;; + +(* ------------------------------------------------------------------------- *) +(* Subterms. *) +(* ------------------------------------------------------------------------- *) + +let subterm lit path = Atom.subterm (atom lit) path;; + +let subterms lit = Atom.subterms (atom lit);; + +let replace ((pol,atm) as lit) path_tm = + let atm' = Atom.replace atm path_tm + in + (* if atm == atm' then lit else *) (pol,atm') + ;; + +(* ------------------------------------------------------------------------- *) +(* Free variables. *) +(* ------------------------------------------------------------------------- *) + +let freeIn v lit = Atom.freeIn v (atom lit);; + +let freeVars lit = Atom.freeVars (atom lit);; + +(* ------------------------------------------------------------------------- *) +(* Substitutions. *) +(* ------------------------------------------------------------------------- *) + +let subst sub ((pol,atm) as lit) : literal = + let atm' = Atom.subst sub atm + in + (* if atm' == atm then lit else *) (pol,atm') + ;; + +(* ------------------------------------------------------------------------- *) +(* Matching. *) +(* ------------------------------------------------------------------------- *) + +let matchLiterals sub ((pol1,atm1) : literal) (pol2,atm2) = + let _ = pol1 = pol2 || failwith "Literal.match" + in + Atom.matchAtoms sub atm1 atm2 + ;; + +(* ------------------------------------------------------------------------- *) +(* Unification. *) +(* ------------------------------------------------------------------------- *) + +let unify sub ((pol1,atm1) : literal) (pol2,atm2) = + let _ = pol1 = pol2 || failwith "Literal.unify" + in + Atom.unify sub atm1 atm2 + ;; + +(* ------------------------------------------------------------------------- *) +(* The equality relation. *) +(* ------------------------------------------------------------------------- *) + +let mkEq l_r : literal = (true, Atom.mkEq l_r);; + +let destEq = function + ((true,atm) : literal) -> Atom.destEq atm + | (false,_) -> failwith "Literal.destEq";; + +let isEq = can destEq;; + +let mkNeq l_r : literal = (false, Atom.mkEq l_r);; + +let destNeq = function + ((false,atm) : literal) -> Atom.destEq atm + | (true,_) -> failwith "Literal.destNeq";; + +let isNeq = can destNeq;; + +let mkRefl tm = (true, Atom.mkRefl tm);; + +let destRefl = function + (true,atm) -> Atom.destRefl atm + | (false,_) -> failwith "Literal.destRefl";; + +let isRefl = can destRefl;; + +let mkIrrefl tm = (false, Atom.mkRefl tm);; + +let destIrrefl = function + (true,_) -> failwith "Literal.destIrrefl" + | (false,atm) -> Atom.destRefl atm;; + +let isIrrefl = can destIrrefl;; + +let sym (pol,atm) : literal = (pol, Atom.sym atm);; + +let lhs ((_,atm) : literal) = Atom.lhs atm;; + +let rhs ((_,atm) : literal) = Atom.rhs atm;; + +(* ------------------------------------------------------------------------- *) +(* Special support for terms with type annotations. *) +(* ------------------------------------------------------------------------- *) + +let typedSymbols ((_,atm) : literal) = Atom.typedSymbols atm;; + +let nonVarTypedSubterms ((_,atm) : literal) = Atom.nonVarTypedSubterms atm;; + +(* ------------------------------------------------------------------------- *) +(* Parsing and pretty-printing. *) +(* ------------------------------------------------------------------------- *) + +let toString literal = Formula.toString (toFormula literal);; + + +module Ordered = +struct type t = literal let compare = compare end + +module Map = struct + type 'a map = (literal, 'a) Pmap.map + let newMap () = Pmap.newMap compare + let null = Pmap.null + let singleton kv = Pmap.singleton compare kv + let size = Pmap.size + let get = Pmap.get + let peek = Pmap.peek + let insert = Pmap.insert + let toList = Pmap.toList + let fromList l = Pmap.fromList compare l + let foldl = Pmap.foldl + let foldr = Pmap.foldr + let filter = Pmap.filter + let inDomain k m = Pmap.inDomain k m + let union = Pmap.union + let delete = Pmap.delete + let mapPartial = Pmap.mapPartial + let transform = Pmap.transform + let exists = Pmap.exists +end + +module Set = +struct + type set = literal Pset.set + let empty = Pset.empty compare + let singleton x = Pset.singleton compare x + let fromList l = Pset.fromList compare l + let compare = Pset.compare + let add = Pset.add + let foldr = Pset.foldr + let foldl = Pset.foldl + let member x s = Pset.member x s + let union = Pset.union + let difference = Pset.difference + let toList = Pset.toList + let null = Pset.null + let size = Pset.size + let pick = Pset.pick + let equal = Pset.equal + let exists p s = Pset.exists p s + let delete = Pset.delete + let subset = Pset.subset + let intersect = Pset.intersect + let intersectList = function + [] -> empty + | (s::ss) -> List.fold_right Pset.intersect ss s + let findl = Pset.findl + let firstl = Pset.firstl + let transform = Pset.transform + let all p s = Pset.all p s + let count p s = Pset.count p s + + let negateMember lit set = member (negate lit) set;; + + let negate = + let f (lit,set) = add set (negate lit) + in + foldl f empty + ;; + + let relations = + let f (lit,set) = Name_arity.Set.add set (relation lit) + in + foldl f Name_arity.Set.empty + ;; + + let functions = + let f (lit,set) = Name_arity.Set.union set (functions lit) + in + foldl f Name_arity.Set.empty + ;; + + let freeIn v = exists (freeIn v);; + + let freeVars = + let f (lit,set) = Name.Set.union set (freeVars lit) + in + foldl f Name.Set.empty + ;; + + let freeVarsList = + let f (lits,set) = Name.Set.union set (freeVars lits) + in + Mlist.foldl f Name.Set.empty + ;; + + let symbols = + let f (lit,z) = symbols lit + z + in + foldl f 0 + ;; + + let typedSymbols = + let f (lit,z) = typedSymbols lit + z + in + foldl f 0 + ;; + +(* complexity comes from unsupported pointer equality + let subst sub lits = + let substLit (lit,(eq,lits')) = + let lit' = subst sub lit + in let eq = eq && lit == lit' + in + (eq, add lits' lit') + + in let (eq,lits') = foldl substLit (true,empty) lits + in + if eq then lits else lits' + ;; +*) + let subst sub lits = + foldl (fun (lit,lits') -> add lits' (subst sub lit)) empty lits;; + + let conjoin set = + Formula.listMkConj (List.map toFormula (toList set));; + + let disjoin set = + Formula.listMkDisj (List.map toFormula (toList set));; + + let toString cl = + "{" ^ String.concat ", " (List.map toString (toList cl)) ^ "}" + +end + +module Set_ordered = +struct type t = Set.set let compare = Set.compare end + +module Set_map = struct + type 'a map = (Set.set, 'a) Pmap.map + let newMap () = Pmap.newMap Set.compare + let null = Pmap.null + let singleton kv = Pmap.singleton Set.compare kv + let size = Pmap.size + let get = Pmap.get + let peek = Pmap.peek + let insert = Pmap.insert + let toList = Pmap.toList + let fromList l = Pmap.fromList Set.compare l + let foldl = Pmap.foldl + let foldr = Pmap.foldr + let filter = Pmap.filter + let inDomain k m = Pmap.inDomain k m + let union = Pmap.union + let delete = Pmap.delete + let mapPartial = Pmap.mapPartial + let transform = Pmap.transform + let exists = Pmap.exists +end + +end + + +(* ========================================================================= *) +(* A LOGICAL KERNEL FOR FIRST ORDER CLAUSAL THEOREMS *) +(* ========================================================================= *) + +module Thm = struct + +(* ------------------------------------------------------------------------- *) +(* An abstract type of first order logic theorems. *) +(* ------------------------------------------------------------------------- *) + +type clause = Literal.Set.set;; + +type inferenceType = + Axiom + | Assume + | Subst + | Factor + | Resolve + | Refl + | Equality;; + +type thm = Thm of clause * (inferenceType * thm list);; + +type inference = inferenceType * thm list;; + +(* ------------------------------------------------------------------------- *) +(* Theorem destructors. *) +(* ------------------------------------------------------------------------- *) + +let clause (Thm (cl,_)) = cl;; + +let inference (Thm (_,inf)) = inf;; + +(* Tautologies *) + +let isTautology th = + let chk = function + (_,None) -> None + | ((pol,atm), Some set) -> + if (pol && Atom.isRefl atm) || Atom.Set.member atm set then None + else Some (Atom.Set.add set atm) + in + match Literal.Set.foldl chk (Some Atom.Set.empty) (clause th) with + Some _ -> false + | None -> true;; + +(* Contradictions *) + +let isContradiction th = Literal.Set.null (clause th);; + +(* Unit theorems *) + +let destUnit (Thm (cl,_)) = + if Literal.Set.size cl = 1 then Literal.Set.pick cl + else failwith "Thm.destUnit";; + +let isUnit = can destUnit;; + +(* Unit equality theorems *) + +let destUnitEq th = Literal.destEq (destUnit th);; + +let isUnitEq = can destUnitEq;; + +(* Literals *) + +let member lit (Thm (cl,_)) = Literal.Set.member lit cl;; + +let negateMember lit (Thm (cl,_)) = Literal.Set.negateMember lit cl;; + +(* ------------------------------------------------------------------------- *) +(* A total order. *) +(* ------------------------------------------------------------------------- *) + +let compare th1 th2 = Literal.Set.compare (clause th1) (clause th2);; + +let equal th1 th2 = Literal.Set.equal (clause th1) (clause th2);; + +(* ------------------------------------------------------------------------- *) +(* Free variables. *) +(* ------------------------------------------------------------------------- *) + +let freeIn v (Thm (cl,_)) = Literal.Set.freeIn v cl;; + +let freeVars (Thm (cl,_)) = Literal.Set.freeVars cl;; + + +(* ------------------------------------------------------------------------- *) +(* Pretty-printing. *) +(* ------------------------------------------------------------------------- *) + +let inferenceTypeToString = function + Axiom -> "axiom" + | Assume -> "assume" + | Subst -> "subst" + | Factor -> "factor" + | Resolve -> "resolve" + | Refl -> "refl" + | Equality -> "equality" + +let toString (Thm (cl, (infType, ths))) = + inferenceTypeToString infType ^ ": " ^ Literal.Set.toString cl + +let rec print_proof (Thm (cl, (infType, ths))) = + print_string ("Inference: " ^ inferenceTypeToString infType); + Format.print_break 0 0; + + print_string ("Clauses: " ^ Literal.Set.toString cl); + Format.print_break 0 0; + + print_string "Theorems: "; + if ths = [] + then print_string "" + else begin + Format.print_break 0 0; + Format.open_vbox 2; + Format.print_break 0 0; + List.iter (print_proof) ths; + Format.close_box () + end; + Format.print_break 0 0 + + +(* ------------------------------------------------------------------------- *) +(* Primitive rules of inference. *) +(* ------------------------------------------------------------------------- *) + +(* ------------------------------------------------------------------------- *) +(* *) +(* ----- axiom C *) +(* C *) +(* ------------------------------------------------------------------------- *) + +let axiom cl = Thm (cl,(Axiom,[]));; + +(* ------------------------------------------------------------------------- *) +(* *) +(* ----------- assume L *) +(* L \/ ~L *) +(* ------------------------------------------------------------------------- *) + +let assume lit = + Thm (Literal.Set.fromList [lit; Literal.negate lit], (Assume,[]));; + +(* ------------------------------------------------------------------------- *) +(* C *) +(* -------- subst s *) +(* C[s] *) +(* ------------------------------------------------------------------------- *) + +let subst sub (Thm (cl,inf) as th) = + let cl' = Literal.Set.subst sub cl + in + (* if cl == cl' then th else *) + match inf with + (Subst,_) -> Thm (cl',inf) + | _ -> Thm (cl',(Subst,[th])) + ;; + +(* ------------------------------------------------------------------------- *) +(* L \/ C ~L \/ D *) +(* --------------------- resolve L *) +(* C \/ D *) +(* *) +(* The literal L must occur in the first theorem, and the literal ~L must *) +(* occur in the second theorem. *) +(* ------------------------------------------------------------------------- *) + +let resolve lit (Thm (cl1,_) as th1) (Thm (cl2,_) as th2) = + let cl1' = Literal.Set.delete cl1 lit + and cl2' = Literal.Set.delete cl2 (Literal.negate lit) + in + Thm (Literal.Set.union cl1' cl2', (Resolve,[th1;th2])) + ;; + +(*MetisDebug +let resolve = fun lit -> fun pos -> fun neg -> + resolve lit pos neg + handle Failure err -> + raise Failure ("Thm.resolve:\nlit = " ^ Literal.toString lit ^ + "\npos = " ^ toString pos ^ + "\nneg = " ^ toString neg ^ "\n" ^ err);; +*) + +(* ------------------------------------------------------------------------- *) +(* *) +(* --------- refl t *) +(* t = t *) +(* ------------------------------------------------------------------------- *) + +let refl tm = Thm (Literal.Set.singleton (true, Atom.mkRefl tm), (Refl,[]));; + +(* ------------------------------------------------------------------------- *) +(* *) +(* ------------------------ equality L p t *) +(* ~(s = t) \/ ~L \/ L' *) +(* *) +(* where s is the subterm of L at path p, and L' is L with the subterm at *) +(* path p being replaced by t. *) +(* ------------------------------------------------------------------------- *) + +let equality lit path t = + let s = Literal.subterm lit path + + in let lit' = Literal.replace lit (path,t) + + in let eqLit = Literal.mkNeq (s,t) + + in let cl = Literal.Set.fromList [eqLit; Literal.negate lit; lit'] + in + Thm (cl,(Equality,[])) + ;; + +end + + +(* ========================================================================= *) +(* PROOFS IN FIRST ORDER LOGIC *) +(* ========================================================================= *) + +module Proof = struct + +(* ------------------------------------------------------------------------- *) +(* A type of first order logic proofs. *) +(* ------------------------------------------------------------------------- *) + +type inference = + Axiom of Literal.Set.set + | Assume of Atom.atom + | Subst of Substitute.subst * Thm.thm + | Resolve of Atom.atom * Thm.thm * Thm.thm + | Refl of Term.term + | Equality of Literal.literal * Term.path * Term.term;; + +type proof = (Thm.thm * inference) list;; + + +(* ------------------------------------------------------------------------- *) +(* Reconstructing single inferences. *) +(* ------------------------------------------------------------------------- *) + +let parents = function + (Axiom _) -> [] + | (Assume _) -> [] + | (Subst (_,th)) -> [th] + | (Resolve (_,th,th')) -> [th;th'] + | (Refl _) -> [] + | (Equality _) -> [];; + +let inferenceToThm = function + (Axiom cl) -> Thm.axiom cl + | (Assume atm) -> Thm.assume (true,atm) + | (Subst (sub,th)) -> Thm.subst sub th + | (Resolve (atm,th,th')) -> Thm.resolve (true,atm) th th' + | (Refl tm) -> Thm.refl tm + | (Equality (lit,path,r)) -> Thm.equality lit path r;; + + let reconstructSubst cl cl' = + let rec recon = function + [] -> +(*MetisTrace3 + let () = Print.trace Literal.Set.pp "reconstructSubst: cl" cl + let () = Print.trace Literal.Set.pp "reconstructSubst: cl'" cl' +*) + raise (Useful.Bug "can't reconstruct Subst rule") + | (([],sub) :: others) -> + if Literal.Set.equal (Literal.Set.subst sub cl) cl' then sub + else recon others + | ((lit :: lits, sub) :: others) -> + let checkLit (lit',acc) = + match Useful.total (Literal.matchLiterals sub lit) lit' with + None -> acc + | Some sub -> (lits,sub) :: acc + in + recon (Literal.Set.foldl checkLit others cl') + in + Substitute.normalize (recon [(Literal.Set.toList cl, Substitute.empty)]) + ;; +(*MetisDebug + handle Failure err -> + raise (Useful.Bug ("Proof.recontructSubst: shouldn't fail:\n" ^ err));; +*) + + let reconstructResolvant cl1 cl2 cl = + (if not (Literal.Set.subset cl1 cl) then + Literal.Set.pick (Literal.Set.difference cl1 cl) + else if not (Literal.Set.subset cl2 cl) then + Literal.negate (Literal.Set.pick (Literal.Set.difference cl2 cl)) + else + (* A useless resolution, but we must reconstruct it anyway *) + let cl1' = Literal.Set.negate cl1 + and cl2' = Literal.Set.negate cl2 + in let lits = Literal.Set.intersectList [cl1;cl1';cl2;cl2'] + in + if not (Literal.Set.null lits) then Literal.Set.pick lits + else raise (Useful.Bug "can't reconstruct Resolve rule") + );; +(*MetisDebug + handle Failure err -> + raise (Useful.Bug ("Proof.recontructResolvant: shouldn't fail:\n" ^ err));; +*) + + let reconstructEquality cl = +(*MetisTrace3 + let () = Print.trace Literal.Set.pp "Proof.reconstructEquality: cl" cl +*) + + let rec sync s t path (f,a) (f',a') = + if not (Name.equal f f' && length a = length a') then None + else + let itms = Mlist.enumerate (zip a a') + in + (match List.filter (fun x -> not (uncurry Term.equal (snd x))) itms with + [(i,(tm,tm'))] -> + let path = i :: path + in + if Term.equal tm s && Term.equal tm' t then + Some (List.rev path) + else + (match (tm,tm') with + (Term.Fn f_a, Term.Fn f_a') -> sync s t path f_a f_a' + | _ -> None) + | _ -> None) + + in let recon (neq,(pol,atm),(pol',atm')) = + if pol = pol' then None + else + let (s,t) = Literal.destNeq neq + + in let path = + if not (Term.equal s t) then sync s t [] atm atm' + else if not (Atom.equal atm atm') then None + else Atom.find (Term.equal s) atm + in + match path with + Some path -> Some ((pol',atm),path,t) + | None -> None + + in let candidates = + match List.partition Literal.isNeq (Literal.Set.toList cl) with + ([l1],[l2;l3]) -> [(l1,l2,l3);(l1,l3,l2)] + | ([l1;l2],[l3]) -> [(l1,l2,l3);(l1,l3,l2);(l2,l1,l3);(l2,l3,l1)] + | ([l1],[l2]) -> [(l1,l1,l2);(l1,l2,l1)] + | _ -> raise (Useful.Bug "reconstructEquality: malformed") + +(*MetisTrace3 + let ppCands = + Print.ppList (Print.ppTriple Literal.pp Literal.pp Literal.pp) + let () = Print.trace ppCands + "Proof.reconstructEquality: candidates" candidates +*) + in + match Mlist.first recon candidates with + Some info -> info + | None -> raise (Useful.Bug "can't reconstruct Equality rule") + ;; +(*MetisDebug + handle Failure err -> + raise (Useful.Bug ("Proof.recontructEquality: shouldn't fail:\n" ^ err));; +*) + + let reconstruct cl = function + (Thm.Axiom,[]) -> Axiom cl + | (Thm.Assume,[]) -> + (match Literal.Set.findl Literal.positive cl with + Some (_,atm) -> Assume atm + | None -> raise (Useful.Bug "malformed Assume inference")) + | (Thm.Subst,[th]) -> + Subst (reconstructSubst (Thm.clause th) cl, th) + | (Thm.Resolve,[th1;th2]) -> + let cl1 = Thm.clause th1 + and cl2 = Thm.clause th2 + in let (pol,atm) = reconstructResolvant cl1 cl2 cl + in + if pol then Resolve (atm,th1,th2) else Resolve (atm,th2,th1) + | (Thm.Refl,[]) -> + (match Literal.Set.findl (K true) cl with + Some lit -> Refl (Literal.destRefl lit) + | None -> raise (Useful.Bug "malformed Refl inference")) + | (Thm.Equality,[]) -> let (x,y,z) = (reconstructEquality cl) in Equality (x,y,z) + | _ -> raise (Useful.Bug "malformed inference");; + + let thmToInference th = +(*MetisTrace3 + let () = Print.trace Thm.pp "Proof.thmToInference: th" th +*) + + let cl = Thm.clause th + + in let thmInf = Thm.inference th + +(*MetisTrace3 + let ppThmInf = Print.ppPair Thm.ppInferenceType (Print.ppList Thm.pp) + let () = Print.trace ppThmInf "Proof.thmToInference: thmInf" thmInf +*) + + in let inf = reconstruct cl thmInf + +(*MetisTrace3 + let () = Print.trace ppInference "Proof.thmToInference: inf" inf +*) +(*MetisDebug + let () = + let + let th' = inferenceToThm inf + in + if Literal.Set.equal (Thm.clause th') cl then () + else + raise + Useful.Bug + ("Proof.thmToInference: bad inference reconstruction:" ^ + "\n th = " ^ Thm.toString th ^ + "\n inf = " ^ inferenceToString inf ^ + "\n inf th = " ^ Thm.toString th') + end +*) + in + inf +(*MetisDebug + handle Failure err -> + raise (Useful.Bug ("Proof.thmToInference: shouldn't fail:\n" ^ err));; +*) +;; + +(* ------------------------------------------------------------------------- *) +(* Reconstructing whole proofs. *) +(* ------------------------------------------------------------------------- *) + +let proof th = + let emptyThms : Thm.thm Literal.Set_map.map = Literal.Set_map.newMap () + + in let rec addThms (th,ths) = + let cl = Thm.clause th + in + if Literal.Set_map.inDomain cl ths then ths + else + let (_,pars) = Thm.inference th + in let ths = Mlist.foldl addThms ths pars + in + if Literal.Set_map.inDomain cl ths then ths + else Literal.Set_map.insert ths (cl,th) + + in let mkThms th = addThms (th,emptyThms) + + in let rec addProof (th,(ths,acc)) = + let cl = Thm.clause th + in + match Literal.Set_map.peek ths cl with + None -> (ths,acc) + | Some th -> + let (_,pars) = Thm.inference th + in let (ths,acc) = Mlist.foldl addProof (ths,acc) pars + in let ths = Literal.Set_map.delete ths cl + in let acc = (th, thmToInference th) :: acc + in + (ths,acc) + + in let mkProof ths th = + let (ths,acc) = addProof (th,(ths,[])) +(*MetisTrace4 + let () = Print.trace Print.ppInt "Proof.proof: unnecessary clauses" (Literal.Set_map.size ths) +*) + in + List.rev acc + +(*MetisTrace3 + let () = Print.trace Thm.pp "Proof.proof: th" th +*) + in let ths = mkThms th + in let infs = mkProof ths th +(*MetisTrace3 + let () = Print.trace Print.ppInt "Proof.proof: size" (length infs) +*) + in + infs + ;; + +(* ------------------------------------------------------------------------- *) +(* Free variables. *) +(* ------------------------------------------------------------------------- *) + +let freeIn v = + let free th_inf = + match th_inf with + (_, Axiom lits) -> Literal.Set.freeIn v lits + | (_, Assume atm) -> Atom.freeIn v atm + | (th, Subst _) -> Thm.freeIn v th + | (_, Resolve _) -> false + | (_, Refl tm) -> Term.freeIn v tm + | (_, Equality (lit,_,tm)) -> + Literal.freeIn v lit || Term.freeIn v tm + in + List.exists free + ;; + +let freeVars = + let inc (th_inf,set) = + Name.Set.union set + (match th_inf with + (_, Axiom lits) -> Literal.Set.freeVars lits + | (_, Assume atm) -> Atom.freeVars atm + | (th, Subst _) -> Thm.freeVars th + | (_, Resolve _) -> Name.Set.empty + | (_, Refl tm) -> Term.freeVars tm + | (_, Equality (lit,_,tm)) -> + Name.Set.union (Literal.freeVars lit) (Term.freeVars tm)) + in + Mlist.foldl inc Name.Set.empty + ;; + +end + + +(* ========================================================================= *) +(* DERIVED RULES FOR CREATING FIRST ORDER LOGIC THEOREMS *) +(* ========================================================================= *) + +module Rule = struct + +(* ------------------------------------------------------------------------- *) +(* Variable names. *) +(* ------------------------------------------------------------------------- *) + +let xVarName = Name.fromString "x";; +let xVar = Term.Tvar xVarName;; + +let yVarName = Name.fromString "y";; +let yVar = Term.Tvar yVarName;; + +let zVarName = Name.fromString "z";; +let zVar = Term.Tvar zVarName;; + +let xIVarName i = Name.fromString ("x" ^ string_of_int i);; +let xIVar i = Term.Tvar (xIVarName i);; + +let yIVarName i = Name.fromString ("y" ^ string_of_int i);; +let yIVar i = Term.Tvar (yIVarName i);; + +(* ------------------------------------------------------------------------- *) +(* *) +(* --------- reflexivity *) +(* x = x *) +(* ------------------------------------------------------------------------- *) + +let reflexivityRule x = Thm.refl x;; + +let reflexivity = reflexivityRule xVar;; + +(* ------------------------------------------------------------------------- *) +(* *) +(* --------------------- symmetry *) +(* ~(x = y) \/ y = x *) +(* ------------------------------------------------------------------------- *) + +let symmetryRule x y = + let reflTh = reflexivityRule x + in let reflLit = Thm.destUnit reflTh + in let eqTh = Thm.equality reflLit [0] y + in + Thm.resolve reflLit reflTh eqTh + ;; + +let symmetry = symmetryRule xVar yVar;; + +(* ------------------------------------------------------------------------- *) +(* *) +(* --------------------------------- transitivity *) +(* ~(x = y) \/ ~(y = z) \/ x = z *) +(* ------------------------------------------------------------------------- *) + +let transitivity = + let eqTh = Thm.equality (Literal.mkEq (yVar,zVar)) [0] xVar + in + Thm.resolve (Literal.mkEq (yVar,xVar)) symmetry eqTh + ;; + +(* ------------------------------------------------------------------------- *) +(* x = y \/ C *) +(* -------------- symEq (x = y) *) +(* y = x \/ C *) +(* ------------------------------------------------------------------------- *) + +let symEq lit th = + let (x,y) = Literal.destEq lit + in + if Term.equal x y then th + else + let sub = Substitute.fromList [(xVarName,x);(yVarName,y)] + + in let symTh = Thm.subst sub symmetry + in + Thm.resolve lit th symTh + ;; + +(* ------------------------------------------------------------------------- *) +(* An equation consists of two terms (t,u) plus a theorem (stronger than) *) +(* t = u \/ C. *) +(* ------------------------------------------------------------------------- *) + +type equation = (Term.term * Term.term) * Thm.thm;; + +let equationLiteral (t_u,th) = + let lit = Literal.mkEq t_u + in + if Literal.Set.member lit (Thm.clause th) then Some lit else None + ;; + +let reflEqn t = ((t,t), Thm.refl t);; + +let symEqn (((t,u), th) as eqn) = + if Term.equal t u then eqn + else + ((u,t), + match equationLiteral eqn with + Some t_u -> symEq t_u th + | None -> th);; + +let transEqn (((x,y), th1) as eqn1) (((_,z), th2) as eqn2) = + if Term.equal x y then eqn2 + else if Term.equal y z then eqn1 + else if Term.equal x z then reflEqn x + else + ((x,z), + match equationLiteral eqn1 with + None -> th1 + | Some x_y -> + match equationLiteral eqn2 with + None -> th2 + | Some y_z -> + let sub = Substitute.fromList [(xVarName,x);(yVarName,y);(zVarName,z)] + in let th = Thm.subst sub transitivity + in let th = Thm.resolve x_y th1 th + in let th = Thm.resolve y_z th2 th + in + th + );; + +(*MetisDebug +let transEqn = fun eqn1 -> fun eqn2 -> + transEqn eqn1 eqn2 + handle Failure err -> + raise Failure ("Rule.transEqn:\neqn1 = " ^ equationToString eqn1 ^ + "\neqn2 = " ^ equationToString eqn2 ^ "\n" ^ err);; +*) + +(* ------------------------------------------------------------------------- *) +(* A conversion takes a term t and either: *) +(* 1. Returns a term u together with a theorem (stronger than) t = u \/ C. *) +(* 2. Raises an Failure exception. *) +(* ------------------------------------------------------------------------- *) + +type conv = Term.term -> Term.term * Thm.thm;; + +let allConv tm = (tm, Thm.refl tm);; + +let noConv : conv = fun _ -> failwith "noConv";; + +(*MetisDebug +let traceConv s conv tm = + let + let res as (tm',th) = conv tm + let () = trace (s ^ ": " ^ Term.toString tm ^ " --> " ^ + Term.toString tm' ^ " " ^ Thm.toString th ^ "\n") + in + res + end + handle Failure err -> + (trace (s ^ ": " ^ Term.toString tm ^ " --> Failure: " ^ err ^ "\n");; + raise (Failure (s ^ ": " ^ err)));; +*) + +let thenConvTrans tm (tm',th1) (tm'',th2) = + let eqn1 = ((tm,tm'),th1) + and eqn2 = ((tm',tm''),th2) + in let (_,th) = transEqn eqn1 eqn2 + in + (tm'',th) + ;; + +let thenConv conv1 conv2 tm = + let (tm',_) as res1 = conv1 tm + in let res2 = conv2 tm' + in + thenConvTrans tm res1 res2 + ;; + +let orelseConv (conv1 : conv) conv2 tm = try conv1 tm with Failure _ -> conv2 tm;; + +let tryConv conv = orelseConv conv allConv;; + +let changedConv conv tm = + let (tm',_) as res = conv tm + in + if tm = tm' then failwith "changedConv" else res + ;; + +let rec repeatConv conv tm = tryConv (thenConv conv (repeatConv conv)) tm;; + +let flip f = fun x y -> f y x;; + +let rec firstConv tm = function + [] -> failwith "firstConv" + | [conv] -> conv tm + | (conv :: convs) -> orelseConv conv (flip firstConv convs) tm;; +let firstConv convs tm = firstConv tm convs;; + +let rec everyConv tm = function + [] -> allConv tm + | [conv] -> conv tm + | (conv :: convs) -> thenConv conv (flip everyConv convs) tm;; +let everyConv convs tm = everyConv tm convs;; + +let rewrConv (((x,y), eqTh) as eqn) path tm = + if Term.equal x y then allConv tm + else if Mlist.null path then (y,eqTh) + else + let reflTh = Thm.refl tm + in let reflLit = Thm.destUnit reflTh + in let th = Thm.equality reflLit (1 :: path) y + in let th = Thm.resolve reflLit reflTh th + in let th = + match equationLiteral eqn with + None -> th + | Some x_y -> Thm.resolve x_y eqTh th + in let tm' = Term.replace tm (path,y) + in + (tm',th) + ;; + +(*MetisDebug +let rewrConv = fun eqn as ((x,y),eqTh) -> fun path -> fun tm -> + rewrConv eqn path tm + handle Failure err -> + raise Failure ("Rule.rewrConv:\nx = " ^ Term.toString x ^ + "\ny = " ^ Term.toString y ^ + "\neqTh = " ^ Thm.toString eqTh ^ + "\npath = " ^ Term.pathToString path ^ + "\ntm = " ^ Term.toString tm ^ "\n" ^ err);; +*) + +let pathConv conv path tm = + let x = Term.subterm tm path + in let (y,th) = conv x + in + rewrConv ((x,y),th) path tm + ;; + +let subtermConv conv i = pathConv conv [i];; + +let subtermsConv conv = function + (Term.Tvar _ as tm) -> allConv tm + | (Term.Fn (_,a) as tm) -> + everyConv (List.map (subtermConv conv) (Useful.interval 0 (length a))) tm;; + +(* ------------------------------------------------------------------------- *) +(* Applying a conversion to every subterm, with some traversal strategy. *) +(* ------------------------------------------------------------------------- *) + +let rec bottomUpConv conv tm = + thenConv (subtermsConv (bottomUpConv conv)) (repeatConv conv) tm;; + +let rec topDownConv conv tm = + thenConv (repeatConv conv) (subtermsConv (topDownConv conv)) tm;; + +let repeatTopDownConv conv = + let rec f tm = thenConv (repeatConv conv) g tm + and g tm = thenConv (subtermsConv f) h tm + and h tm = tryConv (thenConv conv f) tm + in + f + ;; + +(*MetisDebug +let repeatTopDownConv = fun conv -> fun tm -> + repeatTopDownConv conv tm + handle Failure err -> failwith ("repeatTopDownConv: " ^ err);; +*) + +(* ------------------------------------------------------------------------- *) +(* A literule (bad pun) takes a literal L and either: *) +(* 1. Returns a literal L' with a theorem (stronger than) ~L \/ L' \/ C. *) +(* 2. Raises an Failure exception. *) +(* ------------------------------------------------------------------------- *) + +type literule = Literal.literal -> Literal.literal * Thm.thm;; + +let allLiterule lit = (lit, Thm.assume lit);; + +let noLiterule : literule = fun _ -> failwith "noLiterule";; + +let thenLiterule literule1 literule2 lit = + let (lit',th1) as res1 = literule1 lit + in let (lit'',th2) as res2 = literule2 lit' + in + if Literal.equal lit lit' then res2 + else if Literal.equal lit' lit'' then res1 + else if Literal.equal lit lit'' then allLiterule lit + else + (lit'', + (if not (Thm.member lit' th1) then th1 + else if not (Thm.negateMember lit' th2) then th2 + else Thm.resolve lit' th1 th2)) + ;; + +let orelseLiterule (literule1 : literule) literule2 lit = + try literule1 lit with Failure _ -> literule2 lit;; + +let tryLiterule literule = orelseLiterule literule allLiterule;; + +let changedLiterule literule lit = + let (lit',_) as res = literule lit + in + if lit = lit' then failwith "changedLiterule" else res + ;; + +let rec repeatLiterule literule lit = + tryLiterule (thenLiterule literule (repeatLiterule literule)) lit;; + +let rec firstLiterule lit = function + [] -> failwith "firstLiterule" + | [literule] -> literule lit + | (literule :: literules) -> + orelseLiterule literule (flip firstLiterule literules) lit;; +let firstLiterule literules lit = firstLiterule lit literules;; + +let rec everyLiterule lit = function + [] -> allLiterule lit + | [literule] -> literule lit + | (literule :: literules) -> + thenLiterule literule (flip everyLiterule literules) lit;; +let everyLiterule literules lit = everyLiterule lit literules;; + +let rewrLiterule (((x,y),eqTh) as eqn) path lit = + if Term.equal x y then allLiterule lit + else + let th = Thm.equality lit path y + in let th = + match equationLiteral eqn with + None -> th + | Some x_y -> Thm.resolve x_y eqTh th + in let lit' = Literal.replace lit (path,y) + in + (lit',th) + ;; + +(*MetisDebug +let rewrLiterule = fun eqn -> fun path -> fun lit -> + rewrLiterule eqn path lit + handle Failure err -> + raise Failure ("Rule.rewrLiterule:\neqn = " ^ equationToString eqn ^ + "\npath = " ^ Term.pathToString path ^ + "\nlit = " ^ Literal.toString lit ^ "\n" ^ err);; +*) + +let pathLiterule conv path lit = + let tm = Literal.subterm lit path + in let (tm',th) = conv tm + in + rewrLiterule ((tm,tm'),th) path lit + ;; + +let argumentLiterule conv i = pathLiterule conv [i];; + +let allArgumentsLiterule conv lit = + everyLiterule + (List.map (argumentLiterule conv) (Useful.interval 0 (Literal.arity lit))) lit;; + +(* ------------------------------------------------------------------------- *) +(* A rule takes one theorem and either deduces another or raises an Failure *) +(* exception. *) +(* ------------------------------------------------------------------------- *) + +type rule = Thm.thm -> Thm.thm;; + +let allRule : rule = fun th -> th;; + +let noRule : rule = fun _ -> failwith "noRule";; + +let thenRule (rule1 : rule) (rule2 : rule) th = rule1 (rule2 th);; + +let orelseRule (rule1 : rule) rule2 th = try rule1 th with Failure _ -> rule2 th;; + +let tryRule rule = orelseRule rule allRule;; + +let changedRule rule th = + let th' = rule th + in + if not (Literal.Set.equal (Thm.clause th) (Thm.clause th')) then th' + else failwith "changedRule" + ;; + +let rec repeatRule rule lit = tryRule (thenRule rule (repeatRule rule)) lit;; + +let rec firstRule th = function + [] -> failwith "firstRule" + | [rule] -> rule th + | (rule :: rules) -> orelseRule rule (flip firstRule rules) th;; +let firstRule rules th = firstRule th rules;; + +let rec everyRule th = function + [] -> allRule th + | [rule] -> rule th + | (rule :: rules) -> thenRule rule (flip everyRule rules) th;; +let everyRule rules th = everyRule th rules;; + +let literalRule literule lit th = + let (lit',litTh) = literule lit + in + if Literal.equal lit lit' then th + else if not (Thm.negateMember lit litTh) then litTh + else Thm.resolve lit th litTh + ;; + +(*MetisDebug +let literalRule = fun literule -> fun lit -> fun th -> + literalRule literule lit th + handle Failure err -> + raise Failure ("Rule.literalRule:\nlit = " ^ Literal.toString lit ^ + "\nth = " ^ Thm.toString th ^ "\n" ^ err);; +*) + +let rewrRule eqTh lit path = literalRule (rewrLiterule eqTh path) lit;; + +let pathRule conv lit path = literalRule (pathLiterule conv path) lit;; + +let literalsRule literule = + let f (lit,th) = + if Thm.member lit th then literalRule literule lit th else th + in + fun lits -> fun th -> Literal.Set.foldl f th lits + ;; + +let allLiteralsRule literule th = literalsRule literule (Thm.clause th) th;; + +let convRule conv = allLiteralsRule (allArgumentsLiterule conv);; + +(* ------------------------------------------------------------------------- *) +(* *) +(* ---------------------------------------------- functionCongruence (f,n) *) +(* ~(x0 = y0) \/ ... \/ ~(x{n-1} = y{n-1}) \/ *) +(* f x0 ... x{n-1} = f y0 ... y{n-1} *) +(* ------------------------------------------------------------------------- *) + +let functionCongruence (f,n) = + let xs = Mlist.tabulate (n,xIVar) + and ys = Mlist.tabulate (n,yIVar) + + in let cong ((i,yi),(th,lit)) = + let path = [1;i] + in let th = Thm.resolve lit th (Thm.equality lit path yi) + in let lit = Literal.replace lit (path,yi) + in + (th,lit) + + in let reflTh = Thm.refl (Term.Fn (f,xs)) + in let reflLit = Thm.destUnit reflTh + in + fst (Mlist.foldl cong (reflTh,reflLit) (Mlist.enumerate ys)) + ;; + +(* ------------------------------------------------------------------------- *) +(* *) +(* ---------------------------------------------- relationCongruence (R,n) *) +(* ~(x0 = y0) \/ ... \/ ~(x{n-1} = y{n-1}) \/ *) +(* ~R x0 ... x{n-1} \/ R y0 ... y{n-1} *) +(* ------------------------------------------------------------------------- *) + +let relationCongruence (r,n) = + let xs = Mlist.tabulate (n,xIVar) + and ys = Mlist.tabulate (n,yIVar) + + in let cong ((i,yi),(th,lit)) = + let path = [i] + in let th = Thm.resolve lit th (Thm.equality lit path yi) + in let lit = Literal.replace lit (path,yi) + in + (th,lit) + + in let assumeLit = (false,(r,xs)) + in let assumeTh = Thm.assume assumeLit + in + fst (Mlist.foldl cong (assumeTh,assumeLit) (Mlist.enumerate ys)) + ;; + +(* ------------------------------------------------------------------------- *) +(* ~(x = y) \/ C *) +(* ----------------- symNeq ~(x = y) *) +(* ~(y = x) \/ C *) +(* ------------------------------------------------------------------------- *) + +let symNeq lit th = + let (x,y) = Literal.destNeq lit + in + if Term.equal x y then th + else + let sub = Substitute.fromList [(xVarName,y);(yVarName,x)] + in let symTh = Thm.subst sub symmetry + in + Thm.resolve lit th symTh + ;; + +(* ------------------------------------------------------------------------- *) +(* sym (x = y) = symEq (x = y) /\ sym ~(x = y) = symNeq ~(x = y) *) +(* ------------------------------------------------------------------------- *) + +let sym ((pol,_) as lit) th = if pol then symEq lit th else symNeq lit th;; + +(* ------------------------------------------------------------------------- *) +(* ~(x = x) \/ C *) +(* ----------------- removeIrrefl *) +(* C *) +(* *) +(* where all irreflexive equalities. *) +(* ------------------------------------------------------------------------- *) + +let removeIrrefl th = + let irrefl = function + ((true,_),th) -> th + | ((false,atm) as lit, th) -> + match Useful.total Atom.destRefl atm with + Some x -> Thm.resolve lit th (Thm.refl x) + | None -> th +in + Literal.Set.foldl irrefl th (Thm.clause th);; + +(* ------------------------------------------------------------------------- *) +(* x = y \/ y = x \/ C *) +(* ----------------------- removeSym *) +(* x = y \/ C *) +(* *) +(* where all duplicate copies of equalities and disequalities are removed. *) +(* ------------------------------------------------------------------------- *) + +let removeSym th = + let rem ((pol,atm) as lit, (eqs,th)) = + match Useful.total Atom.sym atm with + None -> (eqs, th) + | Some atm' -> + if Literal.Set.member lit eqs then + (eqs, (if pol then symEq lit th else symNeq lit th)) + else + (Literal.Set.add eqs (pol,atm'), th) +in + snd (Literal.Set.foldl rem (Literal.Set.empty,th) (Thm.clause th));; + +(* ------------------------------------------------------------------------- *) +(* ~(v = t) \/ C *) +(* ----------------- expandAbbrevs *) +(* C[t/v] *) +(* *) +(* where t must not contain any occurrence of the variable v. *) +(* ------------------------------------------------------------------------- *) + +let rec expandAbbrevs th = + let expand lit = + let (x,y) = Literal.destNeq lit + in let _ = Term.isTypedVar x || Term.isTypedVar y || + failwith "Rule.expandAbbrevs: no vars" + in let _ = not (Term.equal x y) || + failwith "Rule.expandAbbrevs: equal vars" + in + Substitute.unify Substitute.empty x y +in + match Literal.Set.firstl (Useful.total expand) (Thm.clause th) with + None -> removeIrrefl th + | Some sub -> expandAbbrevs (Thm.subst sub th);; + +(* ------------------------------------------------------------------------- *) +(* simplify = isTautology + expandAbbrevs + removeSym *) +(* ------------------------------------------------------------------------- *) + +let rec simplify th = + if Thm.isTautology th then None + else + let th' = th + in let th' = expandAbbrevs th' + in let th' = removeSym th' + in + if Thm.equal th th' then Some th else simplify th' + ;; + +(* ------------------------------------------------------------------------- *) +(* C *) +(* -------- freshVars *) +(* C[s] *) +(* *) +(* where s is a renaming substitution chosen so that all of the variables in *) +(* C are replaced by fresh variables. *) +(* ------------------------------------------------------------------------- *) + +let freshVars th = Thm.subst (Substitute.freshVars (Thm.freeVars th)) th;; + +(* ------------------------------------------------------------------------- *) +(* C *) +(* ---------------------------- factor *) +(* C_s_1, C_s_2, ..., C_s_n *) +(* *) +(* where each s_i is a substitution that factors C, meaning that the theorem *) +(* *) +(* C_s_i = (removeIrrefl o removeSym o Thm.subst s_i) C *) +(* *) +(* has fewer literals than C. *) +(* *) +(* Also, if s is any substitution that factors C, then one of the s_i will *) +(* result in a theorem C_s_i that strictly subsumes the theorem C_s. *) +(* ------------------------------------------------------------------------- *) + + type edge = + Factor_edge of Atom.atom * Atom.atom + | Refl_edge of Term.term * Term.term;; + + type joinStatus = + Joined + | Joinable of Substitute.subst + | Apart;; + + let joinEdge sub edge = + let result = + match edge with + Factor_edge (atm,atm') -> Useful.total (Atom.unify sub atm) atm' + | Refl_edge (tm,tm') -> Useful.total (Substitute.unify sub tm) tm' + in + match result with + None -> Apart + | Some sub' -> + (* if sub == sub' then Joined else *) Joinable sub' + ;; + + let updateApart sub = + let rec update acc = function + [] -> Some acc + | (edge :: edges) -> + match joinEdge sub edge with + Joined -> None + | Joinable _ -> update (edge :: acc) edges + | Apart -> update acc edges + in + update [] + ;; + + let addFactorEdge (pol,atm) ((pol',atm'),acc) = + if pol <> pol' then acc + else + let edge = Factor_edge (atm,atm') + in + match joinEdge Substitute.empty edge with + Joined -> raise (Useful.Bug "addFactorEdge: joined") + | Joinable sub -> (sub,edge) :: acc + | Apart -> acc + ;; + + let addReflEdge = function + ((false,_), acc) -> acc + | ((true,atm), acc) -> + let edge = let (x,y) = (Atom.destEq atm) in Refl_edge (x,y) + in + match joinEdge Substitute.empty edge with + Joined -> raise (Useful.Bug "addRefl: joined") + | Joinable _ -> edge :: acc + | Apart -> acc + ;; + let addReflEdge = curry addReflEdge;; + + let addIrreflEdge = function + ((true,_), acc) -> acc + | ((false,atm), acc) -> + let edge = let (x,y) = (Atom.destEq atm) in Refl_edge (x,y) + in + match joinEdge Substitute.empty edge with + Joined -> raise (Useful.Bug "addRefl: joined") + | Joinable sub -> (sub,edge) :: acc + | Apart -> acc + ;; + let addIrreflEdge = curry addIrreflEdge;; + + let rec init_edges acc apart = function + [] -> + let init ((apart,sub,edge),(edges,acc)) = + (edge :: edges, (apart,sub,edges) :: acc) + in + snd (Mlist.foldl init ([],[]) acc) + | ((sub,edge) :: sub_edges) -> +(*MetisDebug + let () = if not (Substitute.null sub) then () + else raise Useful.Bug "Rule.factor.init_edges: empty subst" +*) + let (acc,apart) = + match updateApart sub apart with + Some apart' -> ((apart',sub,edge) :: acc, edge :: apart) + | None -> (acc,apart) + in + init_edges acc apart sub_edges + ;; + + let rec mk_edges apart sub_edges = function + [] -> init_edges [] apart sub_edges + | (lit :: lits) -> + let sub_edges = Mlist.foldl (addFactorEdge lit) sub_edges lits + + in let (apart,sub_edges) = + match Useful.total Literal.sym lit with + None -> (apart,sub_edges) + | Some lit' -> + let apart = addReflEdge lit apart + in let sub_edges = addIrreflEdge lit sub_edges + in let sub_edges = Mlist.foldl (addFactorEdge lit') sub_edges lits + in + (apart,sub_edges) + in + mk_edges apart sub_edges lits + ;; + + let rec fact acc = function + [] -> acc + | ((_,sub,[]) :: others) -> fact (sub :: acc) others + | ((apart, sub, edge :: edges) :: others) -> + let others = + match joinEdge sub edge with + Joinable sub' -> + let others = (edge :: apart, sub, edges) :: others + in + (match updateApart sub' apart with + None -> others + | Some apart' -> (apart',sub',edges) :: others) + | _ -> (apart,sub,edges) :: others + in + fact acc others + ;; + + let factor' cl = +(*MetisTrace6 + let () = Print.trace Literal.Set.pp "Rule.factor': cl" cl +*) + let edges = mk_edges [] [] (Literal.Set.toList cl) +(*MetisTrace6 + let ppEdgesSize = Print.ppMap length Print.ppInt + let ppEdgel = Print.ppList ppEdge + let ppEdges = Print.ppList (Print.ppTriple ppEdgel Substitute.pp ppEdgel) + let () = Print.trace ppEdgesSize "Rule.factor': |edges|" edges + let () = Print.trace ppEdges "Rule.factor': edges" edges +*) + in let result = fact [] edges +(*MetisTrace6 + let ppResult = Print.ppList Substitute.pp + let () = Print.trace ppResult "Rule.factor': result" result +*) + in + result + ;; + +let factor th = + let fact sub = removeIrrefl (removeSym (Thm.subst sub th)) + in + List.map fact (factor' (Thm.clause th)) + ;; + + +end + +(* ========================================================================= *) +(* RANDOM FINITE MODELS *) +(* ========================================================================= *) + +module Model = struct + +(* ------------------------------------------------------------------------- *) +(* Constants. *) +(* ------------------------------------------------------------------------- *) + +let maxSpace = 1000;; + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +let multInt x y = + let m = int_of_float (floor (float_sqrt (float_of_int max_int))) in + if x <= m && y <= m then Some (x * y) else None;; + + let rec iexp x y acc = + if y mod 2 = 0 then iexp' x y acc + else + match multInt acc x with + Some acc -> iexp' x y acc + | None -> None + + and iexp' x y acc = + if y = 1 then Some acc + else + let y = y / 2 + in + match multInt x x with + Some x -> iexp x y acc + | None -> None + ;; + + let expInt x y = + if y <= 1 then + if y = 0 then Some 1 + else if y = 1 then Some x + else raise (Useful.Bug "expInt: negative exponent") + else if x <= 1 then + if 0 <= x then Some x + else raise (Useful.Bug "expInt: negative exponand") + else iexp x y 1;; + +let boolToInt = function + true -> 1 + | false -> 0;; + +let intToBool = function + 1 -> true + | 0 -> false + | _ -> raise (Useful.Bug "Model.intToBool");; + +let minMaxInterval i j = Useful.interval i (1 + j - i);; + +(* ------------------------------------------------------------------------- *) +(* Model size. *) +(* ------------------------------------------------------------------------- *) + +type size = Size of {size : int};; + +(* ------------------------------------------------------------------------- *) +(* A model of size N has integer elements 0...N-1. *) +(* ------------------------------------------------------------------------- *) + +type element = int;; + +let zeroElement = 0;; + +let incrementElement sz i = let Size {size} = sz in let n = size in + let i = i + 1 + in + if i = n then None else Some i + ;; + +let elementListSpace sz arity = let Size {size} = sz in let n = size in + match expInt n arity with + None -> None + | Some m as s -> if m <= maxSpace then s else None;; + +let elementListIndex sz = let Size {size} = sz in let n = size in + let rec f acc elts = + match elts with + [] -> acc + | elt :: elts -> f (n * acc + elt) elts + in + f 0 + ;; + +(* ------------------------------------------------------------------------- *) +(* The parts of the model that are fixed. *) +(* ------------------------------------------------------------------------- *) + +type fixedFunction = size -> element list -> element option;; + +type fixedRelation = size -> element list -> bool option;; + +type fixed = Fixed of + {functions : fixedFunction Name_arity.Map.map; + relations : fixedRelation Name_arity.Map.map};; + +let uselessFixedFunction : fixedFunction = K (K None);; + +let uselessFixedRelation : fixedRelation = K (K None);; + +let emptyFunctions : fixedFunction Name_arity.Map.map = Name_arity.Map.newMap ();; + +let emptyRelations : fixedRelation Name_arity.Map.map = Name_arity.Map.newMap ();; + +let fixed0 f sz elts = + match elts with + [] -> f sz + | _ -> raise (Useful.Bug "Model.fixed0: wrong arity");; + +let fixed1 f sz elts = + match elts with + [x] -> f sz x + | _ -> raise (Useful.Bug "Model.fixed1: wrong arity");; + +let fixed2 f sz elts = + match elts with + [x;y] -> f sz x y + | _ -> raise (Useful.Bug "Model.fixed2: wrong arity");; + +let emptyFixed = + let fns = emptyFunctions + and rels = emptyRelations + in + Fixed {functions = fns; + relations = rels} + ;; + +let peekFunctionFixed fix name_arity = + let Fixed {functions} = fix in let fns = functions + in + Name_arity.Map.peek fns name_arity + ;; + +let peekRelationFixed fix name_arity = + let Fixed {relations} = fix in let rels = relations + in + Name_arity.Map.peek rels name_arity + ;; + +let getFunctionFixed fix name_arity = + match peekFunctionFixed fix name_arity with + Some f -> f + | None -> uselessFixedFunction;; + +let getRelationFixed fix name_arity = + match peekRelationFixed fix name_arity with + Some rel -> rel + | None -> uselessFixedRelation;; + +let insertFunctionFixed fix name_arity_fun = + let Fixed {functions; relations} = fix + in let fns = functions and rels = relations + + in let fns = Name_arity.Map.insert fns name_arity_fun + in + Fixed {functions = fns; + relations = rels} + ;; + +let insertRelationFixed fix name_arity_rel = + let Fixed {functions; relations} = fix + in let fns = functions and rels = relations + + in let rels = Name_arity.Map.insert rels name_arity_rel + in + Fixed {functions = fns; + relations = rels} + ;; + + let union _ = raise (Useful.Bug "Model.unionFixed: nameArity clash");; + let unionFixed fix1 fix2 = + let Fixed {functions; relations} = fix1 + in let fns1 = functions and rels1 = relations in + let Fixed {functions; relations} = fix2 + in let fns2 = functions and rels2 = relations + + in let fns = Name_arity.Map.union union fns1 fns2 + + in let rels = Name_arity.Map.union union rels1 rels2 + in + Fixed {functions = fns; + relations = rels} + ;; + +let unionListFixed = + let union (fix,acc) = unionFixed acc fix + in + Mlist.foldl union emptyFixed + ;; + + let hasTypeFn _ elts = + match elts with + [x;_] -> Some x + | _ -> raise (Useful.Bug "Model.hasTypeFn: wrong arity");; + + let eqRel _ elts = + match elts with + [x;y] -> Some (x = y) + | _ -> raise (Useful.Bug "Model.eqRel: wrong arity");; + + let basicFixed = + let fns = Name_arity.Map.singleton (Term.hasTypeFunction,hasTypeFn) + + in let rels = Name_arity.Map.singleton (Atom.eqRelation,eqRel) + in + Fixed {functions = fns; + relations = rels} + ;; + +(* ------------------------------------------------------------------------- *) +(* Renaming fixed model parts. *) +(* ------------------------------------------------------------------------- *) + +type fixedMap = Fixed_map of + {functionMap : Name.name Name_arity.Map.map; + relationMap : Name.name Name_arity.Map.map};; + +let mapFixed fixMap fix = + let Fixed_map {functionMap; relationMap} = fixMap + in let fnMap = functionMap and relMap = relationMap in + let Fixed {functions; relations} = fix + in let fns = functions and rels = relations + + in let fns = Name_arity.Map.compose fnMap fns + + in let rels = Name_arity.Map.compose relMap rels + in + Fixed {functions = fns; + relations = rels} + ;; + + +(* ------------------------------------------------------------------------- *) +(* Standard fixed model parts. *) +(* ------------------------------------------------------------------------- *) + +(* Projections *) + +let projectionMin = 1 +and projectionMax = 9;; + +let projectionList = minMaxInterval projectionMin projectionMax;; + +let projectionName i = + let _ = projectionMin <= i || + raise (Useful.Bug "Model.projectionName: less than projectionMin") + + in let _ = i <= projectionMax || + raise (Useful.Bug "Model.projectionName: greater than projectionMax") + in + Name.fromString ("project" ^ string_of_int i) + ;; + +let projectionFn i _ elts = Some (List.nth elts (i - 1));; + +let arityProjectionFixed arity = + let mkProj i = ((projectionName i, arity), projectionFn i) + + in let rec addProj i acc = + if i > arity then acc + else addProj (i + 1) (Name_arity.Map.insert acc (mkProj i)) + + in let fns = addProj projectionMin emptyFunctions + + in let rels = emptyRelations + in + Fixed {functions = fns; + relations = rels} + ;; + +let projectionFixed = + unionListFixed (List.map arityProjectionFixed projectionList);; + +(* Arithmetic *) + +let numeralMin = -100 +and numeralMax = 100;; + +let numeralList = minMaxInterval numeralMin numeralMax;; + +let numeralName i = + let _ = numeralMin <= i || + raise (Useful.Bug "Model.numeralName: less than numeralMin") + + in let _ = i <= numeralMax || + raise (Useful.Bug "Model.numeralName: greater than numeralMax") + + in let s = if i < 0 then "negative" ^ string_of_int (-i) else string_of_int i + in + Name.fromString s + ;; + +let addName = Name.fromString "+" +and divName = Name.fromString "div" +and dividesName = Name.fromString "divides" +and evenName = Name.fromString "even" +and expName = Name.fromString "exp" +and geName = Name.fromString ">=" +and gtName = Name.fromString ">" +and isZeroName = Name.fromString "isZero" +and leName = Name.fromString "<=" +and ltName = Name.fromString "<" +and modName = Name.fromString "mod" +and multName = Name.fromString "*" +and negName = Name.fromString "~" +and oddName = Name.fromString "odd" +and preName = Name.fromString "pre" +and subName = Name.fromString "-" +and sucName = Name.fromString "suc";; + + (* Support *) + + let modN sz x = let Size {size} = sz in let n = size in x mod n;; + + let oneN sz = modN sz 1;; + + let multN sz (x,y) = modN sz (x * y);; + + (* Functions *) + + let numeralFn i sz = Some (modN sz i);; + + let addFn sz x y = Some (modN sz (x + y));; + + let divFn sz x y = let Size {size} = sz in let n = size in + let y = if y = 0 then n else y + in + Some (x / y) + ;; + + let expFn sz x y = Some (Useful.exp (multN sz) x y (oneN sz));; + + let modFn sz x y = let Size {size} = sz in let n = size in + let y = if y = 0 then n else y + in + Some (x mod y) + ;; + + let multFn sz x y = Some (multN sz (x,y));; + + let negFn sz x = let Size {size} = sz in let n = size in Some (if x = 0 then 0 else n - x);; + + let preFn sz x = let Size {size} = sz in let n = size in Some (if x = 0 then n - 1 else x - 1);; + + let subFn sz x y = let Size {size} = sz in let n = size in Some (if x < y then n + x - y else x - y);; + + let sucFn sz x = let Size {size} = sz in let n = size in Some (if x = n - 1 then 0 else x + 1);; + + (* Relations *) + + let dividesRel _ x y = Some (Useful.divides x y);; + + let evenRel _ x = Some (x mod 2 = 0);; + + let geRel _ x y = Some (x >= y);; + + let gtRel _ x y = Some (x > y);; + + let isZeroRel _ x = Some (x = 0);; + + let leRel _ x y = Some (x <= y);; + + let ltRel _ x y = Some (x < y);; + + let oddRel _ x = Some (x mod 2 = 1);; + + let modularFixed = + let fns = + Name_arity.Map.fromList + (List.map (fun i -> ((numeralName i,0), fixed0 (numeralFn i))) + numeralList @ + [((addName,2), fixed2 addFn); + ((divName,2), fixed2 divFn); + ((expName,2), fixed2 expFn); + ((modName,2), fixed2 modFn); + ((multName,2), fixed2 multFn); + ((negName,1), fixed1 negFn); + ((preName,1), fixed1 preFn); + ((subName,2), fixed2 subFn); + ((sucName,1), fixed1 sucFn)]) + + in let rels = + Name_arity.Map.fromList + [((dividesName,2), fixed2 dividesRel); + ((evenName,1), fixed1 evenRel); + ((geName,2), fixed2 geRel); + ((gtName,2), fixed2 gtRel); + ((isZeroName,1), fixed1 isZeroRel); + ((leName,2), fixed2 leRel); + ((ltName,2), fixed2 ltRel); + ((oddName,1), fixed1 oddRel)] + in + Fixed {functions = fns; + relations = rels} + ;; + + (* Support *) + + let cutN sz x = let Size {size} = sz in let n = size in if x >= n then n - 1 else x;; + + let oneN sz = cutN sz 1;; + + let multN sz (x,y) = cutN sz (x * y);; + + (* Functions *) + + let numeralFn i sz = if i < 0 then None else Some (cutN sz i);; + + let addFn sz x y = Some (cutN sz (x + y));; + + let divFn _ x y = if y = 0 then None else Some (x / y);; + + let expFn sz x y = Some (Useful.exp (multN sz) x y (oneN sz));; + + let modFn sz x y = let Size {size} = sz in let n = size in + if y = 0 || x = n - 1 then None else Some (x mod y);; + + let multFn sz x y = Some (multN sz (x,y));; + + let negFn _ x = if x = 0 then Some 0 else None;; + + let preFn _ x = if x = 0 then None else Some (x - 1);; + + let subFn sz x y = let Size {size} = sz in let n = size in + if y = 0 then Some x + else if x = n - 1 || x < y then None + else Some (x - y);; + + let sucFn sz x = Some (cutN sz (x + 1));; + + (* Relations *) + + let dividesRel sz x y = let Size {size} = sz in let n = size in + if x = 1 || y = 0 then Some true + else if x = 0 then Some false + else if y = n - 1 then None + else Some (Useful.divides x y);; + + let evenRel sz x = let Size {size} = sz in let n = size in + if x = n - 1 then None else Some (x mod 2 = 0);; + + let geRel sz y x = let Size {size} = sz in let n = size in + if x = n - 1 then if y = n - 1 then None else Some false + else if y = n - 1 then Some true else Some (x <= y);; + + let gtRel sz y x = let Size {size} = sz in let n = size in + if x = n - 1 then if y = n - 1 then None else Some false + else if y = n - 1 then Some true else Some (x < y);; + + let isZeroRel _ x = Some (x = 0);; + + let leRel sz x y = let Size {size} = sz in let n = size in + if x = n - 1 then if y = n - 1 then None else Some false + else if y = n - 1 then Some true else Some (x <= y);; + + let ltRel sz x y = let Size {size} = sz in let n = size in + if x = n - 1 then if y = n - 1 then None else Some false + else if y = n - 1 then Some true else Some (x < y);; + + let oddRel sz x = let Size {size} = sz in let n = size in + if x = n - 1 then None else Some (x mod 2 = 1);; + + let overflowFixed = + let fns = + Name_arity.Map.fromList + (List.map (fun i -> ((numeralName i,0), fixed0 (numeralFn i))) + numeralList @ + [((addName,2), fixed2 addFn); + ((divName,2), fixed2 divFn); + ((expName,2), fixed2 expFn); + ((modName,2), fixed2 modFn); + ((multName,2), fixed2 multFn); + ((negName,1), fixed1 negFn); + ((preName,1), fixed1 preFn); + ((subName,2), fixed2 subFn); + ((sucName,1), fixed1 sucFn)]) + + in let rels = + Name_arity.Map.fromList + [((dividesName,2), fixed2 dividesRel); + ((evenName,1), fixed1 evenRel); + ((geName,2), fixed2 geRel); + ((gtName,2), fixed2 gtRel); + ((isZeroName,1), fixed1 isZeroRel); + ((leName,2), fixed2 leRel); + ((ltName,2), fixed2 ltRel); + ((oddName,1), fixed1 oddRel)] + in + Fixed {functions = fns; + relations = rels} + ;; + +(* Sets *) + +let cardName = Name.fromString "card" +and complementName = Name.fromString "complement" +and differenceName = Name.fromString "difference" +and emptyName = Name.fromString "empty" +and memberName = Name.fromString "member" +and insertName = Name.fromString "insert" +and intersectName = Name.fromString "intersect" +and singletonName = Name.fromString "singleton" +and subsetName = Name.fromString "subset" +and symmetricDifferenceName = Name.fromString "symmetricDifference" +and unionName = Name.fromString "union" +and universeName = Name.fromString "universe";; + + (* Support *) + + let eltN sz = let Size {size} = sz in let n = size in + let rec f acc = function + 0 -> acc + | x -> f (acc + 1) (x / 2) + in + f (-1) n + ;; + + let posN i = Word.shiftLeft (1, Word.fromInt i);; + + let univN sz = Word.minus (posN (eltN sz), 1);; + + let setN sz x = Word.andb (Word.fromInt x, univN sz);; + + (* Functions *) + + let cardFn sz x = + let rec f acc = function + 0 -> acc + | s -> + let acc = if Word.andb (s,1) = 0 then acc else acc + 1 + in + f acc (Word.shiftRight (s,1)) + in + Some (f (setN sz x) 0) + ;; + + let complementFn sz x = Some (Word.toInt (Word.xorb (univN sz, setN sz x)));; + + let differenceFn sz x y = + let x = setN sz x + and y = setN sz y + in + Some (Word.toInt (Word.andb (x, Word.notb y))) + ;; + + let emptyFn _ = Some 0;; + + let insertFn sz x y = + let x = x mod eltN sz + and y = setN sz y + in + Some (Word.toInt (Word.orb (posN x, y))) + ;; + + let intersectFn sz x y = + Some (Word.toInt (Word.andb (setN sz x, setN sz y)));; + + let singletonFn sz x = + let x = x mod eltN sz + in + Some (Word.toInt (posN x)) + ;; + + let symmetricDifferenceFn sz x y = + let x = setN sz x + and y = setN sz y + in + Some (Word.toInt (Word.xorb (x,y))) + ;; + + let unionFn sz x y = + Some (Word.toInt (Word.orb (setN sz x, setN sz y)));; + + let universeFn sz = Some (Word.toInt (univN sz));; + + (* Relations *) + + let memberRel sz x y = + let x = x mod eltN sz + and y = setN sz y + in + Some (Word.andb (posN x, y) <> 0) + ;; + + let subsetRel sz x y = + let x = setN sz x + and y = setN sz y + in + Some (Word.andb (x, Word.notb y) = 0) + ;; + + let setFixed = + let fns = + Name_arity.Map.fromList + [((cardName,1), fixed1 cardFn); + ((complementName,1), fixed1 complementFn); + ((differenceName,2), fixed2 differenceFn); + ((emptyName,0), fixed0 emptyFn); + ((insertName,2), fixed2 insertFn); + ((intersectName,2), fixed2 intersectFn); + ((singletonName,1), fixed1 singletonFn); + ((symmetricDifferenceName,2), fixed2 symmetricDifferenceFn); + ((unionName,2), fixed2 unionFn); + ((universeName,0), fixed0 universeFn)] + + in let rels = + Name_arity.Map.fromList + [((memberName,2), fixed2 memberRel); + ((subsetName,2), fixed2 subsetRel)] + in + Fixed {functions = fns; + relations = rels} + ;; + +(* Lists *) + +let appendName = Name.fromString "@" +and consName = Name.fromString "::" +and lengthName = Name.fromString "length" +and nilName = Name.fromString "nil" +and nullName = Name.fromString "null" +and tailName = Name.fromString "tail";; + + let baseFix = + let fix = unionFixed projectionFixed overflowFixed + + in let sucFn = getFunctionFixed fix (sucName,1) + + in let suc2Fn sz _ x = sucFn sz [x] + in + insertFunctionFixed fix ((sucName,2), fixed2 suc2Fn) + ;; + + let fixMap = + Fixed_map {functionMap = Name_arity.Map.fromList + [((appendName,2),addName); + ((consName,2),sucName); + ((lengthName,1), projectionName 1); + ((nilName,0), numeralName 0); + ((tailName,1),preName)]; + relationMap = Name_arity.Map.fromList + [((nullName,1),isZeroName)]};; + + let listFixed = mapFixed fixMap baseFix;; + +(* ------------------------------------------------------------------------- *) +(* Valuations. *) +(* ------------------------------------------------------------------------- *) + +type valuation = Valuation of element Name.Map.map;; + +let emptyValuation = Valuation (Name.Map.newMap ());; + +let insertValuation (Valuation m) v_i = Valuation (Name.Map.insert m v_i);; + +let peekValuation (Valuation m) v = Name.Map.peek m v;; + +let constantValuation i = + let add (v,v') = insertValuation v' (v,i) + in + Name.Set.foldl add emptyValuation + ;; + +let zeroValuation = constantValuation zeroElement;; + +let getValuation v' v = + match peekValuation v' v with + Some i -> i + | None -> failwith "Model.getValuation: incomplete valuation";; + +let randomValuation sz vs = let Size {size} = sz in let n = size in + let f (v,v') = insertValuation v' (v, Random.int n) + in + Name.Set.foldl f emptyValuation vs + ;; + +let incrementValuation n vars = + let rec inc vs v' = + match vs with + [] -> None + | v :: vs -> + let (carry,i) = + match incrementElement n (getValuation v' v) with + Some i -> (false,i) + | None -> (true,zeroElement) + + in let v' = insertValuation v' (v,i) + in + if carry then inc vs v' else Some v' + in + inc (Name.Set.toList vars) + ;; + +let foldValuation n vars f = + let inc = incrementValuation n vars + + in let rec fold v' acc = + let acc = f (v',acc) + in + match inc v' with + None -> acc + | Some v' -> fold v' acc + + in let zero = zeroValuation vars + in + fold zero + ;; + +(* ------------------------------------------------------------------------- *) +(* A type of random finite mapping Z^n -> Z. *) +(* ------------------------------------------------------------------------- *) + +let cUNKNOWN = -1;; + +type table = + Forgetful_table + | Array_table of int array;; + +let newTable n arity = + match elementListSpace (Size {size = n}) arity with + None -> Forgetful_table + | Some space -> Array_table (Array.make space cUNKNOWN);; + + + let randomResult r = Random.int r;; + let lookupTable n vR table elts = + match table with + Forgetful_table -> randomResult vR + | Array_table a -> + let i = elementListIndex (Size {size = n}) elts + + in let r = Array.get a i + in + if r <> cUNKNOWN then r + else + let r = randomResult vR + + in let () = Array.set a i r + in + r + ;; + +let updateTable n table (elts,r) = + match table with + Forgetful_table -> () + | Array_table a -> + let i = elementListIndex (Size {size = n}) elts + + in let () = Array.set a i r + in + () + ;; + +(* ------------------------------------------------------------------------- *) +(* A type of random finite mappings name * arity -> Z^arity -> Z. *) +(* ------------------------------------------------------------------------- *) + +type tables = Tables of + {domainSize : int; + rangeSize : int; + tableMap : table Name_arity.Map.map ref};; + +let newTables n vR = + Tables {domainSize = n; + rangeSize = vR; + tableMap = ref (Name_arity.Map.newMap ())};; + +let getTables tables n_a = + let Tables {domainSize; tableMap} = tables + in let n = domainSize and tm = tableMap + + in let m = !tm + in + match Name_arity.Map.peek m n_a with + Some t -> t + | None -> + let (_,a) = n_a + + in let t = newTable n a + + in let m = Name_arity.Map.insert m (n_a,t) + + in let () = tm := m + in + t + ;; + +let lookupTables tables (n,elts) = + let Tables {domainSize; rangeSize} = tables + in let vN = domainSize and vR = rangeSize + + in let a = length elts + + in let table = getTables tables (n,a) + in + lookupTable vN vR table elts + ;; + +let updateTables tables ((n,elts),r) = + let Tables {domainSize} = tables in let vN = domainSize + + in let a = length elts + + in let table = getTables tables (n,a) + in + updateTable vN table (elts,r) + ;; + +(* ------------------------------------------------------------------------- *) +(* A type of random finite models. *) +(* ------------------------------------------------------------------------- *) + +type parameters = Parameters of {sizep : int; fixed : fixed};; + +type model = Model of + {sizem : int; + fixedFunctions : (element list -> element option) Name_arity.Map.map; + fixedRelations : (element list -> bool option) Name_arity.Map.map; + randomFunctions : tables; + randomRelations : tables};; + +let newModel parm = + let Parameters {sizep; fixed} = parm in let vN = sizep in + let Fixed {functions; relations} = fixed + in let fns = functions and rels = relations + + in let fixFns = Name_arity.Map.transform (fun f -> f (Size {size = vN})) fns + and fixRels = Name_arity.Map.transform (fun r -> r (Size {size = vN})) rels + + in let rndFns = newTables vN vN + and rndRels = newTables vN 2 + in + Model {sizem = vN; + fixedFunctions = fixFns; + fixedRelations = fixRels; + randomFunctions = rndFns; + randomRelations = rndRels} + ;; + +let msize (Model {sizem}) = sizem;; +let psize (Parameters {sizep}) = sizep;; + +let peekFixedFunction vM (n,elts) = + let Model {fixedFunctions} = vM in let fixFns = fixedFunctions + in + match Name_arity.Map.peek fixFns (n, length elts) with + None -> None + | Some fixFn -> fixFn elts + ;; + +let isFixedFunction vM n_elts = Option.is_some (peekFixedFunction vM n_elts);; + +let peekFixedRelation vM (n,elts) = + let Model {fixedRelations} = vM in let fixRels = fixedRelations + in + match Name_arity.Map.peek fixRels (n, length elts) with + None -> None + | Some fixRel -> fixRel elts + ;; + +let isFixedRelation vM n_elts = Option.is_some (peekFixedRelation vM n_elts);; + +(* A default model *) + +let defaultSize = 8;; + +let defaultFixed = + unionListFixed + [basicFixed; + projectionFixed; + modularFixed; + setFixed; + listFixed];; + +let default = Parameters {sizep = defaultSize; fixed = defaultFixed};; + +(* ------------------------------------------------------------------------- *) +(* Taking apart terms to interpret them. *) +(* ------------------------------------------------------------------------- *) + +let destTerm tm = + match tm with + Term.Tvar _ -> tm + | Term.Fn f_tms -> + match Term.stripApp tm with + (_,[]) -> tm + | (Term.Tvar _ as v, tms) -> Term.Fn (Term.appName, v :: tms) + | (Term.Fn (f,tms), tms') -> Term.Fn (f, tms @ tms');; + +(* ------------------------------------------------------------------------- *) +(* Interpreting terms and formulas in the model. *) +(* ------------------------------------------------------------------------- *) + +let interpretFunction vM n_elts = + match peekFixedFunction vM n_elts with + Some r -> r + | None -> + let Model {randomFunctions} = vM in let rndFns = randomFunctions + in + lookupTables rndFns n_elts + ;; + +let interpretRelation vM n_elts = + match peekFixedRelation vM n_elts with + Some r -> r + | None -> + let Model {randomRelations} = vM in let rndRels = randomRelations + in + intToBool (lookupTables rndRels n_elts) + ;; + +let interpretTerm vM vV = + let rec interpret tm = + match destTerm tm with + Term.Tvar v -> getValuation vV v + | Term.Fn (f,tms) -> interpretFunction vM (f, List.map interpret tms) + in + interpret + ;; + +let interpretAtom vM vV (r,tms) = + interpretRelation vM (r, List.map (interpretTerm vM vV) tms);; + +let interpretFormula vM = + let vN = msize vM + + in let rec interpret vV fm = + match fm with + Formula.Ftrue -> true + | Formula.Ffalse -> false + | Formula.Atom atm -> interpretAtom vM vV atm + | Formula.Not p -> not (interpret vV p) + | Formula.Or (p,q) -> interpret vV p || interpret vV q + | Formula.And (p,q) -> interpret vV p && interpret vV q + | Formula.Imp (p,q) -> interpret vV (Formula.Or (Formula.Not p, q)) + | Formula.Iff (p,q) -> interpret vV p = interpret vV q + | Formula.Forall (v,p) -> interpret' vV p v vN + | Formula.Exists (v,p) -> + interpret vV (Formula.Not (Formula.Forall (v, Formula.Not p))) + + and interpret' vV fm v i = + i = 0 || + let i = i - 1 + in let vV' = insertValuation vV (v,i) + in + interpret vV' fm && interpret' vV fm v i + + in + interpret + ;; + +let interpretLiteral vM vV (pol,atm) = + let b = interpretAtom vM vV atm + in + if pol then b else not b + ;; + +let interpretClause vM vV cl = Literal.Set.exists (interpretLiteral vM vV) cl;; + +(* ------------------------------------------------------------------------- *) +(* Check whether random groundings of a formula are true in the model. *) +(* Note: if it's cheaper, a systematic check will be performed instead. *) +(* ------------------------------------------------------------------------- *) + +let check interpret maxChecks vM fv x = + let vN = msize vM + + in let score (vV,(vT,vF)) = + if interpret vM vV x then (vT + 1, vF) else (vT, vF + 1) + + in let randomCheck acc = score (randomValuation (Size {size = vN}) fv, acc) + + in let maxChecks = + match maxChecks with + None -> maxChecks + | Some m -> + match expInt vN (Name.Set.size fv) with + Some n -> if n <= m then None else maxChecks + | None -> maxChecks + in + match maxChecks with + Some m -> funpow m randomCheck (0, 0) + | None -> foldValuation (Size {size = vN}) fv score (0, 0) + ;; + +let checkAtom maxChecks vM atm = + check interpretAtom maxChecks vM (Atom.freeVars atm) atm;; + +let checkFormula maxChecks vM fm = + check interpretFormula maxChecks vM (Formula.freeVars fm) fm;; + +let checkLiteral maxChecks vM lit = + check interpretLiteral maxChecks vM (Literal.freeVars lit) lit;; + +let checkClause maxChecks vM cl = + check interpretClause maxChecks vM (Literal.Set.freeVars cl) cl;; + +(* ------------------------------------------------------------------------- *) +(* Updating the model. *) +(* ------------------------------------------------------------------------- *) + +let updateFunction vM func_elts_elt = + let Model {randomFunctions} = vM in let rndFns = randomFunctions + + in let () = updateTables rndFns func_elts_elt + in + () + ;; + +let updateRelation vM (rel_elts,pol) = + let Model {randomRelations} = vM in let rndRels = randomRelations + + in let () = updateTables rndRels (rel_elts, boolToInt pol) + in + () + ;; + +(* ------------------------------------------------------------------------- *) +(* A type of terms with interpretations embedded in the subterms. *) +(* ------------------------------------------------------------------------- *) + +type modelTerm = + Model_var + | Model_fn of Term.functionName * modelTerm list * int list;; + +let modelTerm vM vV = + let rec modelTm tm = + match destTerm tm with + Term.Tvar v -> (Model_var, getValuation vV v) + | Term.Fn (f,tms) -> + let (tms,xs) = unzip (List.map modelTm tms) + in + (Model_fn (f,tms,xs), interpretFunction vM (f,xs)) + in + modelTm + ;; + +(* ------------------------------------------------------------------------- *) +(* Perturbing the model. *) +(* ------------------------------------------------------------------------- *) + +type perturbation = + Function_perturbation of (Term.functionName * element list) * element + | Relation_perturbation of (Atom.relationName * element list) * bool;; + +let perturb vM pert = + match pert with + Function_perturbation ((func,elts),elt) -> updateFunction vM ((func,elts),elt) + | Relation_perturbation ((rel,elts),pol) -> updateRelation vM ((rel,elts),pol);; + + let rec pertTerm vM target tm acc = + match target with [] -> acc | _ -> + (match tm with + Model_var -> acc + | Model_fn (func,tms,xs) -> + let onTarget ys = List.mem (interpretFunction vM (func,ys)) target + + in let func_xs = (func,xs) + + in let acc = + if isFixedFunction vM func_xs then acc + else + let add (y,acc) = Function_perturbation (func_xs,y) :: acc + in + Mlist.foldl add acc target + in + pertTerms vM onTarget tms xs acc) + + and pertTerms vM onTarget = + let vN = msize vM + + in let filterElements pred = + let rec filt i acc = match i with + 0 -> acc + | _ -> + let i = i - 1 + in let acc = if pred i then i :: acc else acc + in + filt i acc + in + filt vN [] + + in let rec pert = function + (_, [], [], acc) -> acc + | (ys, (tm :: tms), (x :: xs), acc) -> + let pred y = + y <> x && onTarget (List.rev_append ys (y :: xs)) + + in let target = filterElements pred + + in let acc = pertTerm vM target tm acc + in + pert ((x :: ys), tms, xs, acc) + | (_, _, _, _) -> raise (Useful.Bug "Model.pertTerms.pert") + in + fun x y z -> pert ([],x,y,z) + ;; + + let pertAtom vM vV target (rel,tms) acc = + let onTarget ys = interpretRelation vM (rel,ys) = target + + in let (tms,xs) = unzip (List.map (modelTerm vM vV) tms) + + in let rel_xs = (rel,xs) + + in let acc = + if isFixedRelation vM rel_xs then acc + else Relation_perturbation (rel_xs,target) :: acc + in + pertTerms vM onTarget tms xs acc + ;; + + let pertLiteral vM vV ((pol,atm),acc) = pertAtom vM vV pol atm acc;; + + let pertClause vM vV cl acc = Literal.Set.foldl (pertLiteral vM vV) acc cl;; + + let pickPerturb vM perts = + if Mlist.null perts then () + else perturb vM (List.nth perts (Random.int (length perts)));; + + let perturbTerm vM vV (tm,target) = + pickPerturb vM (pertTerm vM target (fst (modelTerm vM vV tm)) []);; + + let perturbAtom vM vV (atm,target) = + pickPerturb vM (pertAtom vM vV target atm []);; + + let perturbLiteral vM vV lit = pickPerturb vM (pertLiteral vM vV (lit,[]));; + + let perturbClause vM vV cl = pickPerturb vM (pertClause vM vV cl []);; + + +end + + +(* ========================================================================= *) +(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC TERMS *) +(* ========================================================================= *) + +module Term_net = struct + +(* ------------------------------------------------------------------------- *) +(* Anonymous variables. *) +(* ------------------------------------------------------------------------- *) + +let anonymousName = Name.fromString "_";; +let anonymousVar = Term.Tvar anonymousName;; + +(* ------------------------------------------------------------------------- *) +(* Quotient terms. *) +(* ------------------------------------------------------------------------- *) + +type qterm = + Qvar + | Fn of Name_arity.nameArity * qterm list;; + + let rec cmp = function + [] -> 0 + | (((q1, q2) as q1_q2) :: qs) -> + (* if q1 == q2 then cmp qs else *) + match q1_q2 with + (Qvar,Qvar) -> cmp qs (* was 0 - bug in metis? *) + | (Qvar, Fn _) -> -1 + | (Fn _, Qvar) -> 1 + | (Fn (f1, f1'), Fn (f2, f2')) -> fnCmp (f1,f1') (f2,f2') qs + + and fnCmp (n1,q1) (n2,q2) qs = + let c = Name_arity.compare n1 n2 in + if c <> 0 then c else cmp (zip q1 q2 @ qs);; + + let compareQterm q1 q2 = cmp [(q1,q2)];; + + let compareFnQterm f1 f2 = fnCmp f1 f2 [];; + + +let equalQterm q1 q2 = compareQterm q1 q2 = 0;; + +let equalFnQterm f1 f2 = compareFnQterm f1 f2 = 0;; + +let rec termToQterm = function + (Term.Tvar _) -> Qvar + | (Term.Fn (f,l)) -> Fn ((f, length l), List.map termToQterm l);; + + let rec qm = function + [] -> true + | ((Qvar,_) :: rest) -> qm rest + | ((Fn _, Qvar) :: _) -> false + | ((Fn (f,a), Fn (g,b)) :: rest) -> + Name_arity.equal f g && qm (zip a b @ rest);; + + let matchQtermQterm qtm qtm' = qm [(qtm,qtm')];; + + let rec qm = function + [] -> true + | ((Qvar,_) :: rest) -> qm rest + | ((Fn _, Term.Tvar _) :: _) -> false + | ((Fn ((f,n),a), Term.Fn (g,b)) :: rest) -> + Name.equal f g && n = length b && qm (zip a b @ rest);; + + let matchQtermTerm qtm tm = qm [(qtm,tm)];; + + let rec qn qsub = function + [] -> Some qsub + | ((Term.Tvar v, qtm) :: rest) -> + (match Name.Map.peek qsub v with + None -> qn (Name.Map.insert qsub (v,qtm)) rest + | Some qtm' -> if equalQterm qtm qtm' then qn qsub rest else None) + | ((Term.Fn _, Qvar) :: _) -> None + | ((Term.Fn (f,a), Fn ((g,n),b)) :: rest) -> + if Name.equal f g && length a = n then qn qsub (zip a b @ rest) + else None;; + + let matchTermQterm qsub tm qtm = qn qsub [(tm,qtm)];; + + let rec qv s t = match (s,t) with + (Qvar, x) -> x + | (x, Qvar) -> x + | (Fn (f,a), Fn (g,b)) -> + let _ = Name_arity.equal f g || failwith "Term_net.qv" + in + Fn (f, map2 qv a b) + ;; + + let rec qu qsub = function + [] -> qsub + | ((Qvar, _) :: rest) -> qu qsub rest + | ((qtm, Term.Tvar v) :: rest) -> + let qtm = + match Name.Map.peek qsub v with None -> qtm | Some qtm' -> qv qtm qtm' + in + qu (Name.Map.insert qsub (v,qtm)) rest + | ((Fn ((f,n),a), Term.Fn (g,b)) :: rest) -> + if Name.equal f g && n = length b then qu qsub (zip a b @ rest) + else failwith "Term_net.qu";; + + let unifyQtermQterm qtm qtm' = Useful.total (qv qtm) qtm';; + + let unifyQtermTerm qsub qtm tm = Useful.total (qu qsub) [(qtm,tm)];; + + let rec qtermToTerm = function + Qvar -> anonymousVar + | (Fn ((f,_),l)) -> Term.Fn (f, List.map qtermToTerm l);; + + +(* ------------------------------------------------------------------------- *) +(* A type of term sets that can be efficiently matched and unified. *) +(* ------------------------------------------------------------------------- *) + +type parameters = Parameters of {fifo : bool};; + +type 'a net = + Result of 'a list + | Single of qterm * 'a net + | Multiple of 'a net option * 'a net Name_arity.Map.map;; + +type 'a termNet = Net of parameters * int * (int * (int * 'a) net) option;; + +(* ------------------------------------------------------------------------- *) +(* Basic operations. *) +(* ------------------------------------------------------------------------- *) + +let newNet parm = Net (parm,0,None);; + + let rec computeSize = function + (Result l) -> length l + | (Single (_,n)) -> computeSize n + | (Multiple (vs,fs)) -> + Name_arity.Map.foldl + (fun (_,n,acc) -> acc + computeSize n) + (match vs with Some n -> computeSize n | None -> 0) + fs;; + + let netSize = function + None -> None + | (Some n) -> Some (computeSize n, n);; + + +let size = function + (Net (_,_,None)) -> 0 + | (Net (_, _, Some (i,_))) -> i;; + +let null net = size net = 0;; + +let singles qtms a = Mlist.foldr (fun (x, y) -> Single (x, y)) a qtms;; + + let pre = function + None -> (0,None) + | (Some (i,n)) -> (i, Some n);; + + let rec add a b c = match (a, b, c) with + (Result l, [], Result l') -> Result (l @ l') + | (a, (qtm :: qtms as input1), Single (qtm',n)) -> + if equalQterm qtm qtm' then Single (qtm, add a qtms n) + else add a input1 (add n [qtm'] (Multiple (None, Name_arity.Map.newMap ()))) + | (a, Qvar :: qtms, Multiple (vs,fs)) -> + Multiple (Some (oadd a qtms vs), fs) + | (a, Fn (f,l) :: qtms, Multiple (vs,fs)) -> + let n = Name_arity.Map.peek fs f + in + Multiple (vs, Name_arity.Map.insert fs (f, oadd a (l @ qtms) n)) + | _ -> raise (Useful.Bug "Term_net.insert: Match") + + and oadd a qtms = function + None -> singles qtms a + | (Some n) -> add a qtms n;; + + let ins a qtm (i,n) = Some (i + 1, oadd (Result [a]) [qtm] n);; + + let insert (Net (p,k,n)) (tm,a) = + try Net (p, k + 1, ins (k,a) (termToQterm tm) (pre n)) + with Failure _ -> raise (Useful.Bug "Term_net.insert: should never fail");; + + +let fromList parm l = Mlist.foldl (fun (tm_a,n) -> insert n tm_a) (newNet parm) l;; + +let filter pred = + let rec filt = function + (Result l) -> + (match List.filter (fun (_,a) -> pred a) l with + [] -> None + | l -> Some (Result l)) + | (Single (qtm,n)) -> + (match filt n with + None -> None + | Some n -> Some (Single (qtm,n))) + | (Multiple (vs,fs)) -> + let vs = Option.bind vs filt + + in let fs = Name_arity.Map.mapPartial (fun (_,n) -> filt n) fs + in + if not (Option.is_some vs) && Name_arity.Map.null fs then None + else Some (Multiple (vs,fs)) + in try + function + Net (_,_,None) as net -> net + | Net (p, k, Some (_,n)) -> Net (p, k, netSize (filt n)) + with Failure _ -> raise (Useful.Bug "Term_net.filter: should never fail");; + +let toString net = "Term_net[" ^ string_of_int (size net) ^ "]";; + +(* ------------------------------------------------------------------------- *) +(* Specialized fold operations to support matching and unification. *) +(* ------------------------------------------------------------------------- *) + + let rec norm = function + (0 :: ks, ((_,n) as f) :: fs, qtms) -> + let (a,qtms) = Mlist.revDivide qtms n + in + addQterm (Fn (f,a)) (ks,fs,qtms) + | stack -> stack + + and addQterm qtm (ks,fs,qtms) = + let ks = match ks with [] -> [] | k :: ks -> (k - 1) :: ks + in + norm (ks, fs, qtm :: qtms) + + and addFn ((_,n) as f) (ks,fs,qtms) = norm (n :: ks, f :: fs, qtms);; + + let stackEmpty = ([],[],[]);; + + let stackAddQterm = addQterm;; + + let stackAddFn = addFn;; + + let stackValue = function + ([],[],[qtm]) -> qtm + | _ -> raise (Useful.Bug "Term_net.stackValue");; + + + let rec fold inc acc = function + [] -> acc + | ((0,stack,net) :: rest) -> + fold inc (inc (stackValue stack, net, acc)) rest + | ((n, stack, Single (qtm,net)) :: rest) -> + fold inc acc ((n - 1, stackAddQterm qtm stack, net) :: rest) + | ((n, stack, Multiple (v,fns)) :: rest) -> + let n = n - 1 + + in let rest = + match v with + None -> rest + | Some net -> (n, stackAddQterm Qvar stack, net) :: rest + + in let getFns ((_,k) as f, net, x) = + (k + n, stackAddFn f stack, net) :: x + in + fold inc acc (Name_arity.Map.foldr getFns rest fns) + | _ -> raise (Useful.Bug "Term_net.foldTerms.fold");; + + let foldTerms inc acc net = fold inc acc [(1,stackEmpty,net)];; + + +let foldEqualTerms pat inc acc = + let rec fold = function + ([],net) -> inc (pat,net,acc) + | (pat :: pats, Single (qtm,net)) -> + if equalQterm pat qtm then fold (pats,net) else acc + | (Qvar :: pats, Multiple (v,_)) -> + (match v with None -> acc | Some net -> fold (pats,net)) + | (Fn (f,a) :: pats, Multiple (_,fns)) -> + (match Name_arity.Map.peek fns f with + None -> acc + | Some net -> fold (a @ pats, net)) + | _ -> raise (Useful.Bug "Term_net.foldEqualTerms.fold") + in + fun net -> fold ([pat],net) + ;; + + + let rec fold inc acc = function + [] -> acc + | (([],stack,net) :: rest) -> + fold inc (inc (stackValue stack, net, acc)) rest + | ((Qvar :: pats, stack, net) :: rest) -> + let harvest (qtm,n,l) = (pats, stackAddQterm qtm stack, n) :: l + in + fold inc acc (foldTerms harvest rest net) + | ((pat :: pats, stack, Single (qtm,net)) :: rest) -> + (match unifyQtermQterm pat qtm with + None -> fold inc acc rest + | Some qtm -> + fold inc acc ((pats, stackAddQterm qtm stack, net) :: rest)) + | (((Fn (f,a) as pat) :: pats, stack, Multiple (v,fns)) :: rest) -> + let rest = + match v with + None -> rest + | Some net -> (pats, stackAddQterm pat stack, net) :: rest + + in let rest = + match Name_arity.Map.peek fns f with + None -> rest + | Some net -> (a @ pats, stackAddFn f stack, net) :: rest + in + fold inc acc rest + | _ -> raise (Useful.Bug "Term_net.foldUnifiableTerms.fold");; + + let foldUnifiableTerms pat inc acc net = + fold inc acc [([pat],stackEmpty,net)];; + +(* ------------------------------------------------------------------------- *) +(* Matching and unification queries. *) +(* *) +(* These function return OVER-APPROXIMATIONS! *) +(* Filter afterwards to get the precise set of satisfying values. *) +(* ------------------------------------------------------------------------- *) + + let idwise (m,_) (n,_) = Useful.intCompare m n;; + + let fifoize (Parameters {fifo}) l = + if fifo then List.sort idwise l else l;; + + let finally parm l = List.map snd (fifoize parm l);; + + + let rec mat acc = function + [] -> acc + | ((Result l, []) :: rest) -> mat (l @ acc) rest + | ((Single (qtm,n), tm :: tms) :: rest) -> + mat acc (if matchQtermTerm qtm tm then (n,tms) :: rest else rest) + | ((Multiple (vs,fs), tm :: tms) :: rest) -> + let rest = match vs with None -> rest | Some n -> (n,tms) :: rest + + in let rest = + match tm with + Term.Tvar _ -> rest + | Term.Fn (f,l) -> + match Name_arity.Map.peek fs (f, length l) with + None -> rest + | Some n -> (n, l @ tms) :: rest + in + mat acc rest + | _ -> raise (Useful.Bug "Term_net.match: Match");; + + let matchNet x y = match (x,y) with + (Net (_,_,None), _) -> [] + | (Net (p, _, Some (_,n)), tm) -> + try finally p (mat [] [(n,[tm])]) + with Failure _ -> raise (Useful.Bug "Term_net.match: should never fail");; + + + let unseenInc qsub v tms (qtm,net,rest) = + (Name.Map.insert qsub (v,qtm), net, tms) :: rest;; + + let seenInc qsub tms (_,net,rest) = (qsub,net,tms) :: rest;; + + let rec mat acc = function + [] -> acc + | ((_, Result l, []) :: rest) -> mat (l @ acc) rest + | ((qsub, Single (qtm,net), tm :: tms) :: rest) -> + (match matchTermQterm qsub tm qtm with + None -> mat acc rest + | Some qsub -> mat acc ((qsub,net,tms) :: rest)) + | ((qsub, (Multiple _ as net), Term.Tvar v :: tms) :: rest) -> + (match Name.Map.peek qsub v with + None -> mat acc (foldTerms (unseenInc qsub v tms) rest net) + | Some qtm -> mat acc (foldEqualTerms qtm (seenInc qsub tms) rest net)) + | ((qsub, Multiple (_,fns), Term.Fn (f,a) :: tms) :: rest) -> + let rest = + match Name_arity.Map.peek fns (f, length a) with + None -> rest + | Some net -> (qsub, net, a @ tms) :: rest + in + mat acc rest + | _ -> raise (Useful.Bug "Term_net.matched.mat");; + + let matched x tm = match x with + (Net (_,_,None)) -> [] + | (Net (parm, _, Some (_,net))) -> + try finally parm (mat [] [(Name.Map.newMap (), net, [tm])]) + with Failure _ -> raise (Useful.Bug "Term_net.matched: should never fail");; + + + let inc qsub v tms (qtm,net,rest) = + (Name.Map.insert qsub (v,qtm), net, tms) :: rest;; + + let rec mat acc = function + [] -> acc + | ((_, Result l, []) :: rest) -> mat (l @ acc) rest + | ((qsub, Single (qtm,net), tm :: tms) :: rest) -> + (match unifyQtermTerm qsub qtm tm with + None -> mat acc rest + | Some qsub -> mat acc ((qsub,net,tms) :: rest)) + | ((qsub, (Multiple _ as net), Term.Tvar v :: tms) :: rest) -> + (match Name.Map.peek qsub v with + None -> mat acc (foldTerms (inc qsub v tms) rest net) + | Some qtm -> mat acc (foldUnifiableTerms qtm (inc qsub v tms) rest net)) + | ((qsub, Multiple (v,fns), Term.Fn (f,a) :: tms) :: rest) -> + let rest = match v with None -> rest | Some net -> (qsub,net,tms) :: rest + + in let rest = + match Name_arity.Map.peek fns (f, length a) with + None -> rest + | Some net -> (qsub, net, a @ tms) :: rest + in + mat acc rest + | _ -> raise (Useful.Bug "Term_net.unify.mat");; + + let unify x tm = match x with + (Net (_,_,None)) -> [] + | (Net (parm, _, Some (_,net))) -> + try finally parm (mat [] [(Name.Map.newMap (), net, [tm])]) + with Failure _ -> raise (Useful.Bug "Term_net.unify: should never fail");; + +end + + +(* ========================================================================= *) +(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC ATOMS *) +(* ========================================================================= *) + +module Atom_net = struct + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +let atomToTerm atom = Term.Fn atom;; + +let termToAtom = function + (Term.Tvar _) -> raise (Useful.Bug "Atom_net.termToAtom") + | (Term.Fn atom) -> atom;; + +(* ------------------------------------------------------------------------- *) +(* A type of atom sets that can be efficiently matched and unified. *) +(* ------------------------------------------------------------------------- *) + +type parameters = Term_net.parameters;; + +type 'a atomNet = 'a Term_net.termNet;; + +(* ------------------------------------------------------------------------- *) +(* Basic operations. *) +(* ------------------------------------------------------------------------- *) + +let newNet = Term_net.newNet;; + +let size = Term_net.size;; + +let insert net (atm,a) = Term_net.insert net (atomToTerm atm, a);; + +let fromList parm l = Mlist.foldl (fun (atm_a,n) -> insert n atm_a) (newNet parm) l;; + +let filter = Term_net.filter;; + +let toString net = "Atom_net[" ^ string_of_int (size net) ^ "]";; + + +(* ------------------------------------------------------------------------- *) +(* Matching and unification queries. *) +(* *) +(* These function return OVER-APPROXIMATIONS! *) +(* Filter afterwards to get the precise set of satisfying values. *) +(* ------------------------------------------------------------------------- *) + +let matchNet net atm = Term_net.matchNet net (atomToTerm atm);; + +let matched net atm = Term_net.matched net (atomToTerm atm);; + +let unify net atm = Term_net.unify net (atomToTerm atm);; + + +end + + +(* ========================================================================= *) +(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC LITERALS *) +(* ========================================================================= *) + +module Literal_net = struct + +(* ------------------------------------------------------------------------- *) +(* A type of literal sets that can be efficiently matched and unified. *) +(* ------------------------------------------------------------------------- *) + +type parameters = Atom_net.parameters;; + +type 'a literalNet = Literal_net of + {positive : 'a Atom_net.atomNet; + negative : 'a Atom_net.atomNet};; + +(* ------------------------------------------------------------------------- *) +(* Basic operations. *) +(* ------------------------------------------------------------------------- *) + +let newNet parm = Literal_net {positive = Atom_net.newNet parm; negative = Atom_net.newNet parm};; + + let pos (Literal_net {positive}) = Atom_net.size positive;; + + let neg (Literal_net {negative}) = Atom_net.size negative;; + + let size net = pos net + neg net;; + + (*let profile net = {positiveN = pos net; negativeN = neg net};;*) + + +let insert (Literal_net {positive;negative}) = function + ((true,atm),a) -> + Literal_net {positive = Atom_net.insert positive (atm,a); negative = negative} + | ((false,atm),a) -> + Literal_net {positive = positive; negative = Atom_net.insert negative (atm,a)};; + +let fromList parm l = Mlist.foldl (fun (lit_a,n) -> insert n lit_a) (newNet parm) l;; + +let filter pred (Literal_net {positive;negative}) = + Literal_net {positive = Atom_net.filter pred positive; + negative = Atom_net.filter pred negative};; + +let toString net = "Literal_net[" ^ string_of_int (size net) ^ "]";; + + +(* ------------------------------------------------------------------------- *) +(* Matching and unification queries. *) +(* *) +(* These function return OVER-APPROXIMATIONS! *) +(* Filter afterwards to get the precise set of satisfying values. *) +(* ------------------------------------------------------------------------- *) + +let matchNet (Literal_net {positive;negative}) = function + (true,atm) -> + Atom_net.matchNet positive atm + | (false,atm) -> Atom_net.matchNet negative atm;; + +let matched (Literal_net {positive;negative}) = function + (true,atm) -> + Atom_net.matched positive atm + | (false,atm) -> Atom_net.matched negative atm;; + +let unify (Literal_net {positive;negative}) = function + (true,atm) -> + Atom_net.unify positive atm + | (false,atm) -> Atom_net.unify negative atm;; + +end + + +(* ========================================================================= *) +(* SUBSUMPTION CHECKING FOR FIRST ORDER LOGIC CLAUSES *) +(* ========================================================================= *) + +module Subsume = struct + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +let findRest pred = + let rec f ys = function + [] -> None + | (x :: xs) -> + if pred x then Some (x, List.rev_append ys xs) else f (x :: ys) xs + in + f [] + ;; + + let addSym (lit,acc) = + match Useful.total Literal.sym lit with + None -> acc + | Some lit -> lit :: acc + let clauseSym lits = Mlist.foldl addSym lits lits;; + + +let sortClause cl = + let lits = Literal.Set.toList cl + in + Mlist.sortMap Literal.typedSymbols (Useful.revCompare Useful.intCompare) lits + ;; + +let incompatible lit = + let lits = clauseSym [lit] + in + fun lit' -> not (List.exists (can (Literal.unify Substitute.empty lit')) lits) + ;; + +(* ------------------------------------------------------------------------- *) +(* Clause ids and lengths. *) +(* ------------------------------------------------------------------------- *) + +type clauseId = int;; + +type clauseLength = int;; + + type idSet = (clauseId * clauseLength) Pset.set;; + + let idCompare (id1,len1) (id2,len2) = + let c = Useful.intCompare len1 len2 in + if c <> 0 then c else Useful.intCompare id1 id2;; + + let idSetEmpty : idSet = Pset.empty idCompare;; + + let idSetAdd (id_len,set) : idSet = Pset.add set id_len;; + + let idSetAddMax max ((_,len) as id_len, set) : idSet = + if len <= max then Pset.add set id_len else set;; + + let idSetIntersect set1 set2 : idSet = Pset.intersect set1 set2;; + +(* ------------------------------------------------------------------------- *) +(* A type of clause sets that supports efficient subsumption checking. *) +(* ------------------------------------------------------------------------- *) + +type 'a nonunit_t = Nonunit of + {nextId : clauseId; + clauses : (Literal.literal list * Thm.clause * 'a) Intmap.map; + fstLits : (clauseId * clauseLength) Literal_net.literalNet; + sndLits : (clauseId * clauseLength) Literal_net.literalNet};; + +type 'a subsume = Subsume of + {empty : (Thm.clause * Substitute.subst * 'a) list; + unitn : (Literal.literal * Thm.clause * 'a) Literal_net.literalNet; + nonunit : 'a nonunit_t};; + +let newSubsume () = + Subsume {empty = []; + unitn = Literal_net.newNet (Term_net.Parameters {fifo = false}); + nonunit = + Nonunit {nextId = 0; + clauses = Intmap.newMap (); + fstLits = Literal_net.newNet (Term_net.Parameters {fifo = false}); + sndLits = Literal_net.newNet (Term_net.Parameters {fifo = false})}};; + +let size (Subsume {empty; unitn; nonunit}) = + let Nonunit {clauses} = nonunit in + length empty + Literal_net.size unitn + Intmap.size clauses;; + +let insert (Subsume {empty;unitn;nonunit}) (cl',a) = + match sortClause cl' with + [] -> + let empty = (cl',Substitute.empty,a) :: empty + in + Subsume {empty = empty; unitn = unitn; nonunit = nonunit} + | [lit] -> + let unitn = Literal_net.insert unitn (lit,(lit,cl',a)) + in + Subsume {empty = empty; unitn = unitn; nonunit = nonunit} + | fstLit :: (sndLit :: otherLits as nonFstLits) -> + let Nonunit {nextId;clauses;fstLits;sndLits} = nonunit + in let id_length = (nextId, Literal.Set.size cl') + in let fstLits = Literal_net.insert fstLits (fstLit,id_length) + in let (sndLit,otherLits) = + match findRest (incompatible fstLit) nonFstLits with + Some sndLit_otherLits -> sndLit_otherLits + | None -> (sndLit,otherLits) + in let sndLits = Literal_net.insert sndLits (sndLit,id_length) + in let lits' = otherLits @ [fstLit;sndLit] + in let clauses = Intmap.insert clauses (nextId,(lits',cl',a)) + in let nextId = nextId + 1 + in let nonunit = Nonunit {nextId = nextId; clauses = clauses; + fstLits = fstLits; sndLits = sndLits} + in + Subsume {empty = empty; unitn = unitn; nonunit = nonunit} + ;; + +let filter pred (Subsume {empty;unitn;nonunit}) = + let empty = List.filter (fun (_,_,x) -> pred x) empty + + in let unitn = Literal_net.filter (fun (_,_,x) -> pred x) unitn + + in let nonunit = + let Nonunit {nextId;clauses;fstLits;sndLits} = nonunit + in let clauses' = Intmap.filter (fun x -> (fun (_,_,x) -> pred x) (snd x)) clauses + in + if Intmap.size clauses = Intmap.size clauses' then nonunit + else + let predId (id,_) = Intmap.inDomain id clauses' + in let fstLits = Literal_net.filter predId fstLits + and sndLits = Literal_net.filter predId sndLits + in + Nonunit {nextId = nextId; clauses = clauses'; + fstLits = fstLits; sndLits = sndLits} + in + Subsume {empty = empty; unitn = unitn; nonunit = nonunit} + ;; + +let toString subsume = "Subsume{" ^ string_of_int (size subsume) ^ "}";; + + +(* ------------------------------------------------------------------------- *) +(* Subsumption checking. *) +(* ------------------------------------------------------------------------- *) + + let matchLit lit' (lit,acc) = + match Useful.total (Literal.matchLiterals Substitute.empty lit') lit with + Some sub -> sub :: acc + | None -> acc;; + + let genClauseSubsumes pred cl' lits' cl a = + let rec mkSubsl acc sub = function + [] -> Some (sub, Mlist.sortMap length Useful.intCompare acc) + | (lit' :: lits') -> + match Mlist.foldl (matchLit lit') [] cl with + [] -> None + | [sub'] -> + (match Useful.total (Substitute.union sub) sub' with + None -> None + | Some sub -> mkSubsl acc sub lits') + | subs -> mkSubsl (subs :: acc) sub lits' + + in let rec search = function + [] -> None + | ((sub,[]) :: others) -> + let x = (cl',sub,a) + in + if pred x then Some x else search others + | ((_, [] :: _) :: others) -> search others + | ((sub, (sub' :: subs) :: subsl) :: others) -> + let others = (sub, subs :: subsl) :: others + in + match Useful.total (Substitute.union sub) sub' with + None -> search others + | Some sub -> search ((sub,subsl) :: others) + in + match mkSubsl [] Substitute.empty lits' with + None -> None + | Some sub_subsl -> search [sub_subsl] + ;; + + + let emptySubsumes pred empty = Mlist.find pred empty;; + + let unitSubsumes pred unitn = + let subLit lit = + let subUnit (lit',cl',a) = + match Useful.total (Literal.matchLiterals Substitute.empty lit') lit with + None -> None + | Some sub -> + let x = (cl',sub,a) + in + if pred x then Some x else None + in + Mlist.first subUnit (Literal_net.matchNet unitn lit) + in + Mlist.first subLit + ;; + + let nonunitSubsumes pred nonunit max cl = + let addId = match max with None -> idSetAdd | Some n -> idSetAddMax n + + in let subLit lits (lit,acc) = + Mlist.foldl addId acc (Literal_net.matchNet lits lit) + + in let Nonunit {clauses;fstLits;sndLits} = nonunit + + in let subCl' (id,_) = + let (lits',cl',a) = Intmap.get clauses id + in + genClauseSubsumes pred cl' lits' cl a + + in let fstCands = Mlist.foldl (subLit fstLits) idSetEmpty cl + in let sndCands = Mlist.foldl (subLit sndLits) idSetEmpty cl + in let cands = idSetIntersect fstCands sndCands + in + Pset.firstl subCl' cands + ;; + + let genSubsumes pred (Subsume {empty;unitn;nonunit}) max cl = + match emptySubsumes pred empty with + (Some _) as s -> s + | None -> + if max = Some 0 then None + else + let cl = clauseSym (Literal.Set.toList cl) + in + match unitSubsumes pred unitn cl with + Some _ as s -> s + | None -> + if max = Some 1 then None + else nonunitSubsumes pred nonunit max cl + ;; + + let subsumes pred subsume cl = genSubsumes pred subsume None cl;; + + let strictlySubsumes pred subsume cl = + genSubsumes pred subsume (Some (Literal.Set.size cl)) cl;; + +(*MetisTrace4 +let subsumes = fun pred -> fun subsume -> fun cl -> + let + let ppCl = Literal.Set.pp + let ppSub = Substitute.pp + let () = Print.trace ppCl "Subsume.subsumes: cl" cl + let result = subsumes pred subsume cl + let () = + match result with + None -> trace "Subsume.subsumes: not subsumed\n" + | Some (cl,sub,_) -> + (Print.trace ppCl "Subsume.subsumes: subsuming cl" cl;; + Print.trace ppSub "Subsume.subsumes: subsuming sub" sub) + in + result + end;; + +let strictlySubsumes = fun pred -> fun subsume -> fun cl -> + let + let ppCl = Literal.Set.pp + let ppSub = Substitute.pp + let () = Print.trace ppCl "Subsume.strictlySubsumes: cl" cl + let result = strictlySubsumes pred subsume cl + let () = + match result with + None -> trace "Subsume.subsumes: not subsumed\n" + | Some (cl,sub,_) -> + (Print.trace ppCl "Subsume.subsumes: subsuming cl" cl;; + Print.trace ppSub "Subsume.subsumes: subsuming sub" sub) + in + result + end;; +*) + +let isSubsumed subs cl = Option.is_some (subsumes (K true) subs cl);; + +let isStrictlySubsumed subs cl = + Option.is_some (strictlySubsumes (K true) subs cl);; + +(* ------------------------------------------------------------------------- *) +(* Single clause versions. *) +(* ------------------------------------------------------------------------- *) + +let clauseSubsumes cl' cl = + let lits' = sortClause cl' + and lits = clauseSym (Literal.Set.toList cl) + in + match genClauseSubsumes (K true) cl' lits' lits () with + Some (_,sub,()) -> Some sub + | None -> None + ;; + +let clauseStrictlySubsumes cl' cl = + if Literal.Set.size cl' > Literal.Set.size cl then None + else clauseSubsumes cl' cl;; + +end + + +(* ========================================================================= *) +(* KNUTH-BENDIX TERM ORDERING CONSTRAINTS *) +(* ========================================================================= *) + +module Knuth_bendix_order = struct + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +let notEqualTerm (x,y) = not (Term.equal x y);; + +let firstNotEqualTerm f l = + match Mlist.find notEqualTerm l with + Some (x,y) -> f x y + | None -> raise (Useful.Bug "firstNotEqualTerm");; + +(* ------------------------------------------------------------------------- *) +(* The weight of all constants must be at least 1, and there must be at most *) +(* one unary function with weight 0. *) +(* ------------------------------------------------------------------------- *) + +type kbo = Kbo of + {weight : Term.function_t -> int; + precedence : Term.function_t -> Term.function_t -> int};; + +(* Default weight = uniform *) + +let uniformWeight : Term.function_t -> int = K 1;; + +(* Default precedence = by arity *) + +let arityPrecedence : Term.function_t -> Term.function_t -> int = + fun (f1,n1) (f2,n2) -> + let c = Useful.intCompare n1 n2 in + if c <> 0 then c else Name.compare f1 f2;; + +(* The default order *) + +let default = Kbo {weight = uniformWeight; precedence = arityPrecedence};; + +(* ------------------------------------------------------------------------- *) +(* Term weight-1 represented as a linear function of the weight-1 of the *) +(* variables in the term (plus a constant). *) +(* *) +(* Note that the conditions on weight functions ensure that all weights are *) +(* at least 1, so all weight-1s are at least 0. *) +(* ------------------------------------------------------------------------- *) + +type weight = Weight of int Name.Map.map * int;; + +let weightEmpty : int Name.Map.map = Name.Map.newMap ();; + +let weightZero = Weight (weightEmpty,0);; + +let weightIsZero (Weight (m,c)) = c = 0 && Name.Map.null m;; + +let weightNeg (Weight (m,c)) = Weight (Name.Map.transform (fun x -> -x) m, -c);; + + let add ((_,n1),(_,n2)) = + let n = n1 + n2 + in + if n = 0 then None else Some n + ;; + let weightAdd (Weight (m1,c1)) (Weight (m2,c2)) = + Weight (Name.Map.union add m1 m2, c1 + c2);; + +let weightSubtract w1 w2 = weightAdd w1 (weightNeg w2);; + +let weightTerm weight = + let rec wt m c = function + [] -> Weight (m,c) + | (Term.Tvar v :: tms) -> + let n = Option.value (Name.Map.peek m v) 0 + in + wt (Name.Map.insert m (v, n + 1)) (c + 1) tms + | (Term.Fn (f,a) :: tms) -> + wt m (c + weight (f, length a)) (a @ tms) + in + fun tm -> wt weightEmpty (-1) [tm] + ;; + +let weightLowerBound (Weight (m,c)) = + if Name.Map.exists (fun (_,n) -> n < 0) m then None else Some c;; + +(*MetisDebug +let ppWeightList = + let + let ppCoeff n = + if n < 0 then Print.sequence (Print.ppString "~") (ppCoeff (~n)) + else if n = 1 then Print.skip + else Print.ppInt n + + let pp_tm (None,n) = Print.ppInt n + | pp_tm (Some v, n) = Print.sequence (ppCoeff n) (Name.pp v) + in + fun [] -> Print.ppInt 0 + | tms -> Print.ppOpList " +" pp_tm tms + end;; + +let ppWeight (Weight (m,c)) = + let + let l = Name.Map.toList m + let l = List.map (fun (v,n) -> (Some v, n)) l + let l = if c = 0 then l else l @ [(None,c)] + in + ppWeightList l + end;; + +let weightToString = Print.toString ppWeight;; +*) + +(* ------------------------------------------------------------------------- *) +(* The Knuth-Bendix term order. *) +(* ------------------------------------------------------------------------- *) + +let compare (Kbo {weight;precedence}) = + let weightDifference tm1 tm2 = + let w1 = weightTerm weight tm1 + and w2 = weightTerm weight tm2 + in + weightSubtract w2 w1 + + in let rec weightLess tm1 tm2 = + let w = weightDifference tm1 tm2 + in + if weightIsZero w then precedenceLess tm1 tm2 + else weightDiffLess w tm1 tm2 + + and weightDiffLess w tm1 tm2 = + match weightLowerBound w with + None -> false + | Some 0 -> precedenceLess tm1 tm2 + | Some n -> n > 0 + + and precedenceLess x y = match (x,y) with + (Term.Fn (f1,a1), Term.Fn (f2,a2)) -> + let c = precedence (f1, length a1) (f2, length a2) in + if c < 0 then true + else if c = 0 then firstNotEqualTerm weightLess (zip a1 a2) + else false + | _ -> false + + in let weightDiffGreater w tm1 tm2 = weightDiffLess (weightNeg w) tm2 tm1 + + in let rec weightCmp tm1 tm2 = + let w = weightDifference tm1 tm2 + in + if weightIsZero w then precedenceCmp tm1 tm2 + else if weightDiffLess w tm1 tm2 then Some (-1) + else if weightDiffGreater w tm1 tm2 then Some 1 + else None + + and precedenceCmp x y = match (x,y) with + (Term.Fn (f1,a1), Term.Fn (f2,a2)) -> + let c = precedence (f1, length a1) (f2, length a2) in + if c < 0 then Some (-1) + else if c = 0 then firstNotEqualTerm weightCmp (zip a1 a2) + else Some 1 + | _ -> raise (Useful.Bug "kboOrder.precendenceCmp") + in + fun tm1 tm2 -> + if Term.equal tm1 tm2 then Some 0 else weightCmp tm1 tm2 + ;; + +(*MetisTrace7 +let compare = fun kbo -> fun tm1 tm2 -> + let + let () = Print.trace Term.pp "Knuth_bendix_order.compare: tm1" tm1 + let () = Print.trace Term.pp "Knuth_bendix_order.compare: tm2" tm2 + let result = compare kbo tm1 tm2 + let () = + match result with + None -> trace "Knuth_bendix_order.compare: result = Incomparable\n" + | Some x -> + Print.trace Print.ppInt "Knuth_bendix_order.compare: result" x + in + result + end;; +*) + +end + + +(* ========================================================================= *) +(* ORDERED REWRITING FOR FIRST ORDER TERMS *) +(* ========================================================================= *) + +module Rewrite = struct + +(* ------------------------------------------------------------------------- *) +(* Orientations of equations. *) +(* ------------------------------------------------------------------------- *) + +type orient = Left_to_right | Right_to_left;; + +let toStringOrient ort = + match ort with + Left_to_right -> "-->" + | Right_to_left -> "<--";; + + +let toStringOrientOption orto = + match orto with + Some ort -> toStringOrient ort + | None -> "<->";; + + +(* ------------------------------------------------------------------------- *) +(* A type of rewrite systems. *) +(* ------------------------------------------------------------------------- *) + +type reductionOrder = Term.term -> Term.term -> int option;; + +type equationId = int;; + +type equation = Rule.equation;; + +type rewrite = Rewrite of + {order : reductionOrder; + known : (equation * orient option) Intmap.map; + redexes : (equationId * orient) Term_net.termNet; + subterms : (equationId * bool * Term.path) Term_net.termNet; + waiting : Intset.set};; + +let updateWaiting rw waiting = + let Rewrite {order; known; redexes; subterms} = rw + in + Rewrite + {order = order; known = known; redexes = redexes; + subterms = subterms; waiting = waiting} + ;; + +let deleteWaiting rw id = + let Rewrite {waiting} = rw in + updateWaiting rw (Intset.delete waiting id);; + +(* ------------------------------------------------------------------------- *) +(* Basic operations *) +(* ------------------------------------------------------------------------- *) + +let newRewrite order = + Rewrite + {order = order; + known = Intmap.newMap (); + redexes = Term_net.newNet (Term_net.Parameters {fifo = false}); + subterms = Term_net.newNet (Term_net.Parameters {fifo = false}); + waiting = Intset.empty};; + +let peek (Rewrite {known}) id = Intmap.peek known id;; + +let size (Rewrite {known}) = Intmap.size known;; + +let equations (Rewrite {known}) = + Intmap.foldr (fun (_,(eqn,_),eqns) -> eqn :: eqns) [] known;; + + +(*MetisTrace1 +local + let ppEq ((x_y,_),ort) = + Print.ppOp2 (" " ^ toStringOrientOption ort) Term.pp Term.pp x_y;; + + let ppField f ppA a = + Print.inconsistentBlock 2 + [Print.ppString (f ^ " ="), + Print.break, + ppA a];; + + let ppKnown = + ppField "known" + (Print.ppMap Intmap.toList + (Print.ppList (Print.ppPair Print.ppInt ppEq)));; + + let ppRedexes = + ppField "redexes" + (Term_net.pp (Print.ppPair Print.ppInt ppOrient));; + + let ppSubterms = + ppField "subterms" + (Term_net.pp + (Print.ppMap + (fun (i,l,p) -> (i, (if l then 0 else 1) :: p)) + (Print.ppPair Print.ppInt Term.ppPath)));; + + let ppWaiting = + ppField "waiting" + (Print.ppMap (Intset.toList) (Print.ppList Print.ppInt));; +in + let pp (Rewrite {known,redexes,subterms,waiting,...}) = + Print.inconsistentBlock 2 + [Print.ppString "Rewrite", + Print.break, + Print.inconsistentBlock 1 + [Print.ppString "{", + ppKnown known, +(*MetisTrace5 + Print.ppString ",", + Print.break, + ppRedexes redexes, + Print.ppString ",", + Print.break, + ppSubterms subterms, + Print.ppString ",", + Print.break, + ppWaiting waiting, +*) + Print.skip], + Print.ppString "}"] +end;; +*) + + +(* ------------------------------------------------------------------------- *) +(* Debug functions. *) +(* ------------------------------------------------------------------------- *) + +let termReducible order known id = + let eqnRed ((l,r),_) tm = + match Useful.total (Substitute.matchTerms Substitute.empty l) tm with + None -> false + | Some sub -> + order tm (Substitute.subst (Substitute.normalize sub) r) = Some 1 + + in let knownRed tm (eqnId,(eqn,ort)) = + eqnId <> id && + ((ort <> Some Right_to_left && eqnRed eqn tm) || + (ort <> Some Left_to_right && eqnRed (Rule.symEqn eqn) tm)) + + in let rec termRed tm = Intmap.exists (knownRed tm) known || subtermRed tm + and subtermRed = function + (Term.Tvar _) -> false + | (Term.Fn (_,tms)) -> List.exists termRed tms + in + termRed + ;; + +let literalReducible order known id lit = + List.exists (termReducible order known id) (Literal.arguments lit);; + +let literalsReducible order known id lits = + Literal.Set.exists (literalReducible order known id) lits;; + +let thmReducible order known id th = + literalsReducible order known id (Thm.clause th);; + +(* ------------------------------------------------------------------------- *) +(* Add equations into the system. *) +(* ------------------------------------------------------------------------- *) + +let orderToOrient = function + Some 0 -> failwith "Rewrite.orient: reflexive" + | Some c when c > 0 -> Some Left_to_right + | Some _ -> Some Right_to_left + | None -> None;; + + let ins redexes redex id ort = Term_net.insert redexes (redex,(id,ort));; + + let addRedexes id (((l,r),_),ort) redexes = + match ort with + Some Left_to_right -> ins redexes l id Left_to_right + | Some Right_to_left -> ins redexes r id Right_to_left + | None -> ins (ins redexes l id Left_to_right) r id Right_to_left;; + + +let add rw (id,eqn) = + let Rewrite {known} = rw in + if Intmap.inDomain id known then rw + else + let Rewrite {order;redexes;subterms;waiting} = rw + + in let ort = let (l,r) = fst eqn in orderToOrient (order l r) + + in let known = Intmap.insert known (id,(eqn,ort)) + + in let redexes = addRedexes id (eqn,ort) redexes + + in let waiting = Intset.add waiting id + + in let rw = + Rewrite + {order = order; known = known; redexes = redexes; + subterms = subterms; waiting = waiting} +(*MetisTrace5 + let () = Print.trace pp "Rewrite.add: result" rw +*) + in + rw + ;; + + let uncurriedAdd (eqn,rw) = add rw eqn;; + let addList rw = Mlist.foldl uncurriedAdd rw;; + +(* ------------------------------------------------------------------------- *) +(* Rewriting (the order must be a refinement of the rewrite order). *) +(* ------------------------------------------------------------------------- *) + + let reorder (i,_) (j,_) = Useful.intCompare j i;; + let matchingRedexes redexes tm = List.sort reorder (Term_net.matchNet redexes tm);; + + +let wellOriented x y = match (x,y) with + (None, _) -> true + | (Some Left_to_right, Left_to_right) -> true + | (Some Right_to_left ,Right_to_left) -> true + | _ -> false;; + +let redexResidue x y = match (x,y) with + (Left_to_right, ((l_r,_) : equation)) -> l_r + | (Right_to_left, ((l,r),_)) -> (r,l);; + +let orientedEquation dir eqn = match dir with + Left_to_right -> eqn + | Right_to_left -> Rule.symEqn eqn;; + +let rewrIdConv' order known redexes id tm = + let rewr (id',lr) = + let _ = id <> id' || failwith "same theorem" + in let (eqn,ort) = Intmap.get known id' + in let _ = wellOriented ort lr || failwith "orientation" + in let (l,r) = redexResidue lr eqn + in let sub = Substitute.normalize (Substitute.matchTerms Substitute.empty l tm) + in let tm' = Substitute.subst sub r + in let _ = Option.is_some ort || + order tm tm' = Some 1 || + failwith "order" + in let (_,th) = orientedEquation lr eqn + in + (tm', Thm.subst sub th) + in + match Mlist.first (Useful.total rewr) (matchingRedexes redexes tm) with + None -> failwith "Rewrite.rewrIdConv: no matching rewrites" + | Some res -> res + ;; + +let rewriteIdConv' order known redexes id = + if Intmap.null known then Rule.allConv + else Rule.repeatTopDownConv (rewrIdConv' order known redexes id);; + +let mkNeqConv order lit = + let (l,r) = Literal.destNeq lit + in + match order l r with + None -> failwith "incomparable" + | Some c when c < 0 -> + let th = Rule.symmetryRule l r + in + fun tm -> + if Term.equal tm r then (l,th) else failwith "mkNeqConv: RL" + | Some 0 -> failwith "irreflexive" + | Some _ -> + let th = Thm.assume lit + in + fun tm -> + if Term.equal tm l then (r,th) else failwith "mkNeqConv: LR" + ;; + +type neqConvs = Neq_convs of Rule.conv Literal.Map.map;; + +let neqConvsEmpty = Neq_convs (Literal.Map.newMap ());; + +let neqConvsNull (Neq_convs m) = Literal.Map.null m;; + +let neqConvsAdd order (Neq_convs m) lit = + match Useful.total (mkNeqConv order) lit with + None -> None + | Some conv -> Some (Neq_convs (Literal.Map.insert m (lit,conv)));; + +let mkNeqConvs order = + let add (lit,(neq,lits)) = + match neqConvsAdd order neq lit with + Some neq -> (neq,lits) + | None -> (neq, Literal.Set.add lits lit) + in + Literal.Set.foldl add (neqConvsEmpty,Literal.Set.empty) + ;; + +let neqConvsDelete (Neq_convs m) lit = Neq_convs (Literal.Map.delete m lit);; + +let neqConvsToConv (Neq_convs m) = + Rule.firstConv (Literal.Map.foldr (fun (_,c,l) -> c :: l) [] m);; + +let neqConvsFoldl f b (Neq_convs m) = + Literal.Map.foldl (fun (l,_,z) -> f (l,z)) b m;; + +let neqConvsRewrIdLiterule order known redexes id neq = + if Intmap.null known && neqConvsNull neq then Rule.allLiterule + else + let neq_conv = neqConvsToConv neq + in let rewr_conv = rewrIdConv' order known redexes id + in let conv = Rule.orelseConv neq_conv rewr_conv + in let conv = Rule.repeatTopDownConv conv + in + Rule.allArgumentsLiterule conv + ;; + +let rewriteIdEqn' order known redexes id ((l_r,th) as eqn) = + let (neq,_) = mkNeqConvs order (Thm.clause th) + in let literule = neqConvsRewrIdLiterule order known redexes id neq + in let (strongEqn,lit) = + match Rule.equationLiteral eqn with + None -> (true, Literal.mkEq l_r) + | Some lit -> (false,lit) + in let (lit',litTh) = literule lit + in + if Literal.equal lit lit' then eqn + else + (Literal.destEq lit', + (if strongEqn then th + else if not (Thm.negateMember lit litTh) then litTh + else Thm.resolve lit th litTh));; +(*MetisDebug + handle Failure err -> failwith ("Rewrite.rewriteIdEqn':\n" ^ err);; +*) + +let rewriteIdLiteralsRule' order known redexes id lits th = + let mk_literule = neqConvsRewrIdLiterule order known redexes id + + in let rewr_neq_lit (lit, ((changed,neq,lits,th) as acc)) = + let neq = neqConvsDelete neq lit + in let (lit',litTh) = mk_literule neq lit + in + if Literal.equal lit lit' then acc + else + let th = if Thm.member lit th then Thm.resolve lit th litTh + else th + in + match neqConvsAdd order neq lit' with + Some neq -> (true,neq,lits,th) + | None -> (changed, neq, Literal.Set.add lits lit', th) + + in let rec rewr_neq_lits neq lits th = + let (changed,neq,lits,th) = + neqConvsFoldl rewr_neq_lit (false,neq,lits,th) neq + in + if changed then rewr_neq_lits neq lits th + else (neq,lits,th) + + in let (neq,lits) = mkNeqConvs order lits + + in let (neq,lits,th) = rewr_neq_lits neq lits th + + in let rewr_literule = mk_literule neq + + in let rewr_lit (lit,th) = + if Thm.member lit th then Rule.literalRule rewr_literule lit th + else th + in + Literal.Set.foldl rewr_lit th lits + ;; + +let rewriteIdRule' order known redexes id th = + rewriteIdLiteralsRule' order known redexes id (Thm.clause th) th;; + +(*MetisDebug +let rewriteIdRule' = fun order -> fun known -> fun redexes -> fun id -> fun th -> + let +(*MetisTrace6 + let () = Print.trace Thm.pp "Rewrite.rewriteIdRule': th" th +*) + let result = rewriteIdRule' order known redexes id th +(*MetisTrace6 + let () = Print.trace Thm.pp "Rewrite.rewriteIdRule': result" result +*) + let _ = not (thmReducible order known id result) || + raise Useful.Bug "rewriteIdRule: should be normalized" + in + result + end + handle Failure err -> failwith ("Rewrite.rewriteIdRule:\n" ^ err);; +*) + +let rewrIdConv (Rewrite {known;redexes}) order = + rewrIdConv' order known redexes;; + +let rewrConv rewrite order = rewrIdConv rewrite order (-1);; + +let rewriteIdConv (Rewrite {known;redexes}) order = + rewriteIdConv' order known redexes;; + +let rewriteConv rewrite order = rewriteIdConv rewrite order (-1);; + +let rewriteIdLiteralsRule (Rewrite {known;redexes}) order = + rewriteIdLiteralsRule' order known redexes;; + +let rewriteLiteralsRule rewrite order = + rewriteIdLiteralsRule rewrite order (-1);; + +let rewriteIdRule (Rewrite {known;redexes}) order = + rewriteIdRule' order known redexes;; + +let rewriteRule rewrite order = rewriteIdRule rewrite order (-1);; + +(* ------------------------------------------------------------------------- *) +(* Inter-reduce the equations in the system. *) +(* ------------------------------------------------------------------------- *) + +let addSubterms id (((l,r),_) : equation) subterms = + let addSubterm b ((path,tm),net) = Term_net.insert net (tm,(id,b,path)) + + in let subterms = Mlist.foldl (addSubterm true) subterms (Term.subterms l) + + in let subterms = Mlist.foldl (addSubterm false) subterms (Term.subterms r) + in + subterms + ;; + +let sameRedexes x y z = match (x,y,z) with + (None,_,_) -> false + | (Some Left_to_right, (l0,_),(l,_)) -> Term.equal l0 l + | (Some Right_to_left, (_,r0),(_,r)) -> Term.equal r0 r;; + +let redexResidues x (l,r) = match x with + None -> [(l,r,false);(r,l,false)] + | (Some Left_to_right) -> [(l,r,true)] + | (Some Right_to_left) -> [(r,l,true)];; + +let findReducibles order known subterms id = + let checkValidRewr (l,r,ord) id' left path = + let (((x,y),_),_) = Intmap.get known id' + in let tm = Term.subterm (if left then x else y) path + in let sub = Substitute.matchTerms Substitute.empty l tm + in + if ord then () + else + let tm' = Substitute.subst (Substitute.normalize sub) r + in + if order tm tm' = Some 1 then () + else failwith "order" + + in let addRed lr ((id',left,path),todo) = + if id <> id' && not (Intset.member id' todo) && + can (checkValidRewr lr id' left) path + then Intset.add todo id' + else todo + + in let findRed ((l,_,_) as lr, todo) = + Mlist.foldl (addRed lr) todo (Term_net.matched subterms l) + in + Mlist.foldl findRed + ;; + +let reduce1 newx id (eqn0,ort0) (rpl,spl,todo,rw,changed) = + let (eq0,_) = eqn0 + in let Rewrite {order;known;redexes;subterms;waiting} = rw + in let (eq,_) as eqn = rewriteIdEqn' order known redexes id eqn0 + in let identical = + let (l0,r0) = eq0 + and (l,r) = eq + in + Term.equal l l0 && Term.equal r r0 + in let same_redexes = identical || sameRedexes ort0 eq0 eq + in let rpl = if same_redexes then rpl else Intset.add rpl id + in let spl = if newx || identical then spl else Intset.add spl id + in let changed = + if not newx && identical then changed else Intset.add changed id + in let ort = + if same_redexes then Some ort0 else let (l,r) = eq in Useful.total orderToOrient (order l r) + in + match ort with + None -> + let known = Intmap.delete known id + in let rw = + Rewrite + {order = order; known = known; redexes = redexes; + subterms = subterms; waiting = waiting} + in + (rpl,spl,todo,rw,changed) + | Some ort -> + let todo = + if not newx && same_redexes then todo + else + findReducibles + order known subterms id todo (redexResidues ort eq) + in let known = + if identical then known else Intmap.insert known (id,(eqn,ort)) + in let redexes = + if same_redexes then redexes + else addRedexes id (eqn,ort) redexes + in let subterms = + if newx || not identical then addSubterms id eqn subterms + else subterms + in let rw = + Rewrite + {order = order; known = known; redexes = redexes; + subterms = subterms; waiting = waiting} + in + (rpl,spl,todo,rw,changed) + ;; + +let pick known set = + let oriented id = + match Intmap.peek known id with + Some ((_, Some _) as x) -> Some (id,x) + | _ -> None + + in let any id = + match Intmap.peek known id with Some x -> Some (id,x) | _ -> None + in + match Intset.firstl oriented set with + Some _ as x -> x + | None -> Intset.firstl any set + ;; + + let cleanRedexes known redexes rpl = + if Intset.null rpl then redexes + else + let filt (id,_) = not (Intset.member id rpl) + + in let addReds (id,reds) = + match Intmap.peek known id with + None -> reds + | Some eqn_ort -> addRedexes id eqn_ort reds + + in let redexes = Term_net.filter filt redexes + in let redexes = Intset.foldl addReds redexes rpl + in + redexes + ;; + + let cleanSubterms known subterms spl = + if Intset.null spl then subterms + else + let filt (id,_,_) = not (Intset.member id spl) + + in let addSubtms (id,subtms) = + match Intmap.peek known id with + None -> subtms + | Some (eqn,_) -> addSubterms id eqn subtms + + in let subterms = Term_net.filter filt subterms + in let subterms = Intset.foldl addSubtms subterms spl + in + subterms + ;; + + let rebuild rpl spl rw = +(*MetisTrace5 + let ppPl = Print.ppMap Intset.toList (Print.ppList Print.ppInt) + let () = Print.trace ppPl "Rewrite.rebuild: rpl" rpl + let () = Print.trace ppPl "Rewrite.rebuild: spl" spl +*) + let Rewrite {order;known;redexes;subterms;waiting} = rw + in let redexes = cleanRedexes known redexes rpl + in let subterms = cleanSubterms known subterms spl + in + Rewrite + {order = order; + known = known; + redexes = redexes; + subterms = subterms; + waiting = waiting} + ;; + +let rec reduceAcc (rpl, spl, todo, rw, changed) = + let Rewrite {known;waiting} = rw in + match pick known todo with + Some (id,eqn_ort) -> + let todo = Intset.delete todo id + in + reduceAcc (reduce1 false id eqn_ort (rpl,spl,todo,rw,changed)) + | None -> + match pick known waiting with + Some (id,eqn_ort) -> + let rw = deleteWaiting rw id + in + reduceAcc (reduce1 true id eqn_ort (rpl,spl,todo,rw,changed)) + | None -> (rebuild rpl spl rw, Intset.toList changed);; + +let isReduced (Rewrite {waiting}) = Intset.null waiting;; + +let reduce' rw = + if isReduced rw then (rw,[]) + else reduceAcc (Intset.empty,Intset.empty,Intset.empty,rw,Intset.empty);; + +(*MetisDebug +let reduce' = fun rw -> + let +(*MetisTrace4 + let () = Print.trace pp "Rewrite.reduce': rw" rw +*) + let Rewrite {known,order,...} = rw + let result as (Rewrite {known = known', ...}, _) = reduce' rw +(*MetisTrace4 + let ppResult = Print.ppPair pp (Print.ppList Print.ppInt) + let () = Print.trace ppResult "Rewrite.reduce': result" result +*) + let ths = List.map (fun (id,((_,th),_)) -> (id,th)) (Intmap.toList known') + let _ = + not (List.exists (uncurry (thmReducible order known')) ths) || + raise Useful.Bug "Rewrite.reduce': not fully reduced" + in + result + end + handle Failure err -> raise (Useful.Bug ("Rewrite.reduce': shouldn't fail\n" ^ err));; +*) + +let reduce rw = fst (reduce' rw);; + +(* ------------------------------------------------------------------------- *) +(* Rewriting as a derived rule. *) +(* ------------------------------------------------------------------------- *) + + let addEqn (id_eqn,rw) = add rw id_eqn;; + let orderedRewrite order ths = + let rw = Mlist.foldl addEqn (newRewrite order) (Mlist.enumerate ths) + in + rewriteRule rw order + ;; + + let order : reductionOrder = fun _ _ -> Some 1;; + let rewrite = orderedRewrite order;; + + +end + +(* ========================================================================= *) +(* A STORE FOR UNIT THEOREMS *) +(* ========================================================================= *) + +module Units = struct + +(* ------------------------------------------------------------------------- *) +(* A type of unit store. *) +(* ------------------------------------------------------------------------- *) + +type unitThm = Literal.literal * Thm.thm;; + +type units = Units of unitThm Literal_net.literalNet;; + +(* ------------------------------------------------------------------------- *) +(* Basic operations. *) +(* ------------------------------------------------------------------------- *) + +let empty = Units (Literal_net.newNet (Term_net.Parameters {fifo = false}));; + +let size (Units net) = Literal_net.size net;; + +let toString units = "U{" ^ string_of_int (size units) ^ "}";; + +(* ------------------------------------------------------------------------- *) +(* Add units into the store. *) +(* ------------------------------------------------------------------------- *) + +let add (Units net) ((lit,th) as uTh) = + let net = Literal_net.insert net (lit,uTh) + in + match Useful.total Literal.sym lit with + None -> Units net + | Some ((pol,_) as lit') -> + let th' = (if pol then Rule.symEq else Rule.symNeq) lit th + in let net = Literal_net.insert net (lit',(lit',th')) + in + Units net + ;; + +let addList = Mlist.foldl (fun (th,u) -> add u th);; + +(* ------------------------------------------------------------------------- *) +(* Matching. *) +(* ------------------------------------------------------------------------- *) + +let matchUnits (Units net) lit = + let check ((lit',_) as uTh) = + match Useful.total (Literal.matchLiterals Substitute.empty lit') lit with + None -> None + | Some sub -> Some (uTh,sub) + in + Mlist.first check (Literal_net.matchNet net lit) + ;; + +(* ------------------------------------------------------------------------- *) +(* Reducing by repeated matching and resolution. *) +(* ------------------------------------------------------------------------- *) + +let reduce units = + let red1 (lit,news_th) = + match Useful.total Literal.destIrrefl lit with + Some tm -> + let (news,th) = news_th + in let th = Thm.resolve lit th (Thm.refl tm) + in + (news,th) + | None -> + let lit' = Literal.negate lit + in + match matchUnits units lit' with + None -> news_th + | Some ((_,rth),sub) -> + let (news,th) = news_th + in let rth = Thm.subst sub rth + in let th = Thm.resolve lit th rth + in let newLits = Literal.Set.delete (Thm.clause rth) lit' + in let news = Literal.Set.union newLits news + in + (news,th) + + in let rec red (news,th) = + if Literal.Set.null news then th + else red (Literal.Set.foldl red1 (Literal.Set.empty,th) news) + in + fun th -> Rule.removeSym (red (Thm.clause th, th)) + ;; + +end + + +(* ========================================================================= *) +(* CLAUSE = ID + THEOREM *) +(* ========================================================================= *) + +module Clause = struct + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +let newId = + let r = ref 0 + + in let newI () = + let n = !r + + in let () = r := n + 1 + in + n + in + fun () -> Useful.critical newI () + ;; + +(* ------------------------------------------------------------------------- *) +(* A type of clause. *) +(* ------------------------------------------------------------------------- *) + +type literalOrder = + No_literal_order + | Unsigned_literal_order + | Positive_literal_order;; + +type parameters = Parameters of + {ordering : Knuth_bendix_order.kbo; + orderLiterals : literalOrder; + orderTerms : bool};; + +type clauseId = int;; + +type clause = Clause of {parameters : parameters; id : clauseId; thm : Thm.thm};; + + +(* ------------------------------------------------------------------------- *) +(* Pretty printing. *) +(* ------------------------------------------------------------------------- *) + +let toString (Clause {id;thm}) = Thm.toString thm;; + + +(* ------------------------------------------------------------------------- *) +(* Basic operations. *) +(* ------------------------------------------------------------------------- *) + +let default : parameters = + Parameters {ordering = Knuth_bendix_order.default; + orderLiterals = Positive_literal_order; + orderTerms = true};; + +(* mk and dest removed - use Clause {fields} directly *) + +let id (Clause {id}) = id;; + +let thm (Clause {thm}) = thm;; + +let equalThms cl cl' = Thm.equal (thm cl) (thm cl');; + +let newClause parameters thm = + Clause {parameters = parameters; id = newId (); thm = thm};; + +let literals cl = Thm.clause (thm cl);; + +let isTautology (Clause {thm}) = Thm.isTautology thm;; + +let isContradiction (Clause {thm}) = Thm.isContradiction thm;; + +(* ------------------------------------------------------------------------- *) +(* The term ordering is used to cut down inferences. *) +(* ------------------------------------------------------------------------- *) + +let strictlyLess ordering x y = + match Knuth_bendix_order.compare ordering x y with + Some c when c < 0 -> true + | _ -> false;; + +let isLargerTerm (Parameters {ordering;orderTerms}) (l,r) = + not orderTerms || not (strictlyLess ordering l r);; + + let atomToTerms atm = + match Useful.total Atom.destEq atm with + None -> [Term.Fn atm] + | Some (l,r) -> [l;r];; + + let notStrictlyLess ordering (xs,ys) = + let less x = List.exists (fun y -> strictlyLess ordering x y) ys + in + not (List.for_all less xs) + ;; + + let isLargerLiteral (Parameters {ordering;orderLiterals}) lits = + match orderLiterals with + No_literal_order -> K true + | Unsigned_literal_order -> + let addLit ((_,atm),acc) = atomToTerms atm @ acc + + in let tms = Literal.Set.foldl addLit [] lits + in + fun (_,atm') -> notStrictlyLess ordering (atomToTerms atm', tms) + | Positive_literal_order -> + match Literal.Set.findl (K true) lits with + None -> K true + | Some (pol,_) -> + let addLit ((p,atm),acc) = + if p = pol then atomToTerms atm @ acc else acc + + in let tms = Literal.Set.foldl addLit [] lits + in + fun (pol',atm') -> + if pol <> pol' then pol + else notStrictlyLess ordering (atomToTerms atm', tms) + ;; + + +let largestLiterals (Clause {parameters;thm}) = + let litSet = Thm.clause thm + in let isLarger = isLargerLiteral parameters litSet + in let addLit (lit,s) = if isLarger lit then Literal.Set.add s lit else s + in + Literal.Set.foldr addLit Literal.Set.empty litSet + ;; + +(*MetisTrace6 +let largestLiterals = fun cl -> + let + let ppResult = Literal.Set.pp + let () = Print.trace pp "Clause.largestLiterals: cl" cl + let result = largestLiterals cl + let () = Print.trace ppResult "Clause.largestLiterals: result" result + in + result + end;; +*) + +let largestEquations cl = + let Clause {parameters} = cl in + let addEq lit ort ((l,_) as l_r) acc = + if isLargerTerm parameters l_r then (lit,ort,l) :: acc else acc + + in let addLit (lit,acc) = + match Useful.total Literal.destEq lit with + None -> acc + | Some (l,r) -> + let acc = addEq lit Rewrite.Right_to_left (r,l) acc + in let acc = addEq lit Rewrite.Left_to_right (l,r) acc + in + acc + in + Literal.Set.foldr addLit [] (largestLiterals cl) + ;; + + let addLit (lit,acc) = + let addTm ((path,tm),acc) = (lit,path,tm) :: acc + in + Mlist.foldl addTm acc (Literal.nonVarTypedSubterms lit) + ;; + + let largestSubterms cl = Literal.Set.foldl addLit [] (largestLiterals cl);; + + let allSubterms cl = Literal.Set.foldl addLit [] (literals cl);; + +(* ------------------------------------------------------------------------- *) +(* Subsumption. *) +(* ------------------------------------------------------------------------- *) + +let subsumes (subs : clause Subsume.subsume) cl = + Subsume.isStrictlySubsumed subs (literals cl);; + +(* ------------------------------------------------------------------------- *) +(* Simplifying rules: these preserve the clause id. *) +(* ------------------------------------------------------------------------- *) + +let freshVars (Clause {parameters;id;thm}) = + Clause {parameters = parameters; id = id; thm = Rule.freshVars thm};; + +let simplify (Clause {parameters;id;thm}) = + match Rule.simplify thm with + None -> None + | Some thm -> Some (Clause {parameters = parameters; id = id; thm = thm});; + +let reduce units (Clause {parameters;id;thm}) = + Clause {parameters = parameters; id = id; thm = Units.reduce units thm};; + +let rewrite rewr (Clause {parameters;id;thm}) = + let simp th = + let Parameters {ordering} = parameters + in let cmp = Knuth_bendix_order.compare ordering + in + Rewrite.rewriteIdRule rewr cmp id th + +(*MetisTrace4 + let () = Print.trace Rewrite.pp "Clause.rewrite: rewr" rewr + let () = Print.trace Print.ppInt "Clause.rewrite: id" id + let () = Print.trace pp "Clause.rewrite: cl" cl +*) + + in let thm = + match Rewrite.peek rewr id with + None -> simp thm + | Some ((_,thm),_) -> if Rewrite.isReduced rewr then thm else simp thm + + in let result = Clause {parameters = parameters; id = id; thm = thm} + +(*MetisTrace4 + let () = Print.trace pp "Clause.rewrite: result" result +*) + in + result;; +(*MetisDebug + handle Failure err -> failwith "Clause.rewrite:\n" ^ err);; +*) + +(* ------------------------------------------------------------------------- *) +(* Inference rules: these generate new clause ids. *) +(* ------------------------------------------------------------------------- *) + +let factor cl = + let Clause {parameters;thm} = cl in + let lits = largestLiterals cl + + in let apply sub = newClause parameters (Thm.subst sub thm) + in + List.map apply (Rule.factor' lits) + ;; + +(*MetisTrace5 +let factor = fun cl -> + let + let () = Print.trace pp "Clause.factor: cl" cl + let result = factor cl + let () = Print.trace (Print.ppList pp) "Clause.factor: result" result + in + result + end;; +*) + +let resolve (cl1,lit1) (cl2,lit2) = +(*MetisTrace5 + let () = Print.trace pp "Clause.resolve: cl1" cl1 + let () = Print.trace Literal.pp "Clause.resolve: lit1" lit1 + let () = Print.trace pp "Clause.resolve: cl2" cl2 + let () = Print.trace Literal.pp "Clause.resolve: lit2" lit2 +*) + let Clause {parameters; thm} = cl1 in let th1 = thm in + let Clause {thm} = cl2 in let th2 = thm + in let sub = Literal.unify Substitute.empty lit1 (Literal.negate lit2) +(*MetisTrace5 + let () = Print.trace Substitute.pp "Clause.resolve: sub" sub +*) + in let lit1 = Literal.subst sub lit1 + in let lit2 = Literal.negate lit1 + in let th1 = Thm.subst sub th1 + and th2 = Thm.subst sub th2 + in let _ = isLargerLiteral parameters (Thm.clause th1) lit1 || +(*MetisTrace5 + (trace "Clause.resolve: th1 violates ordering\n";; false) || +*) + failwith "resolve: clause1: ordering constraints" + in let _ = isLargerLiteral parameters (Thm.clause th2) lit2 || +(*MetisTrace5 + (trace "Clause.resolve: th2 violates ordering\n";; false) || +*) + failwith "resolve: clause2: ordering constraints" + in let th = Thm.resolve lit1 th1 th2 +(*MetisTrace5 + let () = Print.trace Thm.pp "Clause.resolve: th" th +*) + in let cl = Clause {parameters = parameters; id = newId (); thm = th} +(*MetisTrace5 + let () = Print.trace pp "Clause.resolve: cl" cl +*) + in + cl + ;; + +let paramodulate (cl1,lit1,ort1,tm1) (cl2,lit2,path2,tm2) = +(*MetisTrace5 + let () = Print.trace pp "Clause.paramodulate: cl1" cl1 + let () = Print.trace Literal.pp "Clause.paramodulate: lit1" lit1 + let () = Print.trace Rewrite.ppOrient "Clause.paramodulate: ort1" ort1 + let () = Print.trace Term.pp "Clause.paramodulate: tm1" tm1 + let () = Print.trace pp "Clause.paramodulate: cl2" cl2 + let () = Print.trace Literal.pp "Clause.paramodulate: lit2" lit2 + let () = Print.trace Term.ppPath "Clause.paramodulate: path2" path2 + let () = Print.trace Term.pp "Clause.paramodulate: tm2" tm2 +*) + let Clause {parameters; thm} = cl1 in let th1 = thm in + let Clause {thm} = cl2 in let th2 = thm + in let sub = Substitute.unify Substitute.empty tm1 tm2 + in let lit1 = Literal.subst sub lit1 + and lit2 = Literal.subst sub lit2 + and th1 = Thm.subst sub th1 + and th2 = Thm.subst sub th2 + + in let _ = isLargerLiteral parameters (Thm.clause th1) lit1 || + failwith "Clause.paramodulate: with clause: ordering" + in let _ = isLargerLiteral parameters (Thm.clause th2) lit2 || + failwith "Clause.paramodulate: into clause: ordering" + + in let eqn = (Literal.destEq lit1, th1) + in let (l_r,_) as eqn = + match ort1 with + Rewrite.Left_to_right -> eqn + | Rewrite.Right_to_left -> Rule.symEqn eqn +(*MetisTrace6 + let () = Print.trace Rule.ppEquation "Clause.paramodulate: eqn" eqn +*) + in let _ = isLargerTerm parameters l_r || + failwith "Clause.paramodulate: equation: ordering constraints" + in let th = Rule.rewrRule eqn lit2 path2 th2 +(*MetisTrace5 + let () = Print.trace Thm.pp "Clause.paramodulate: th" th +*) + in + Clause {parameters = parameters; id = newId (); thm = th} +(*MetisTrace5 + handle Failure err -> + let + let () = trace ("Clause.paramodulate: failed: " ^ err ^ "\n") + in + raise Failure err + end;; +*) + + +end + + +module Ax_cj = struct + +type ax_cj_thm = Ax_cj_thm of {axioms_thm : Thm.thm list; conjecture_thm : Thm.thm list};; +type ax_cj_cl = Ax_cj_cl of {axioms_cl : Clause.clause list; conjecture_cl : Clause.clause list};; + +end + +(* ========================================================================= *) +(* THE ACTIVE SET OF CLAUSES *) +(* ========================================================================= *) + +module Active = struct + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +(*MetisDebug +local + let mkRewrite ordering = + let + let add (cl,rw) = + let + let Clause.Clause {id; thm} = cl in let th = thm + in + match Useful.total Thm.destUnitEq th with + Some l_r -> Rewrite.add rw (id,(l_r,th)) + | None -> rw + end + in + Mlist.foldl add (Rewrite.new (Knuth_bendix_order.compare ordering)) + end;; + + let allFactors red = + let + let allClause cl = + List.all red (cl :: Clause.factor cl) || + let + let () = Print.trace Clause.pp + "Active.isSaturated.allFactors: cl" cl + in + false + end + in + List.all allClause + end;; + + let allResolutions red = + let + let allClause2 cl_lit cl = + let + let allLiteral2 lit = + match Useful.total (Clause.resolve cl_lit) (cl,lit) with + None -> true + | Some cl -> allFactors red [cl] + in + Literal.Set.all allLiteral2 (Clause.literals cl) + end || + let + let () = Print.trace Clause.pp + "Active.isSaturated.allResolutions: cl2" cl + in + false + end + + let allClause1 allCls cl = + let + let cl = Clause.freshVars cl + + let allLiteral1 lit = List.all (allClause2 (cl,lit)) allCls + in + Literal.Set.all allLiteral1 (Clause.literals cl) + end || + let + let () = Print.trace Clause.pp + "Active.isSaturated.allResolutions: cl1" cl + in + false + end + + in + fun [] -> true + | allCls as cl :: cls -> + allClause1 allCls cl && allResolutions red cls + end;; + + let allParamodulations red cls = + let + let allClause2 cl_lit_ort_tm cl = + let + let allLiteral2 lit = + let + let para = Clause.paramodulate cl_lit_ort_tm + + let allSubterms (path,tm) = + match Useful.total para (cl,lit,path,tm) with + None -> true + | Some cl -> allFactors red [cl] + in + List.all allSubterms (Literal.nonVarTypedSubterms lit) + end || + let + let () = Print.trace Literal.pp + "Active.isSaturated.allParamodulations: lit2" lit + in + false + end + in + Literal.Set.all allLiteral2 (Clause.literals cl) + end || + let + let () = Print.trace Clause.pp + "Active.isSaturated.allParamodulations: cl2" cl + let (_,_,ort,_) = cl_lit_ort_tm + let () = Print.trace Rewrite.ppOrient + "Active.isSaturated.allParamodulations: ort1" ort + in + false + end + + let allClause1 cl = + let + let cl = Clause.freshVars cl + + let allLiteral1 lit = + let + let allCl2 x = List.all (allClause2 x) cls + in + match Useful.total Literal.destEq lit with + None -> true + | Some (l,r) -> + allCl2 (cl,lit,Rewrite.Left_to_right,l) && + allCl2 (cl,lit,Rewrite.Right_to_left,r) + end || + let + let () = Print.trace Literal.pp + "Active.isSaturated.allParamodulations: lit1" lit + in + false + end + in + Literal.Set.all allLiteral1 (Clause.literals cl) + end || + let + let () = Print.trace Clause.pp + "Active.isSaturated.allParamodulations: cl1" cl + in + false + end + in + List.all allClause1 cls + end;; + + let redundant {subsume,reduce,rewrite} = + let + let simp cl = + match Clause.simplify cl with + None -> true + | Some cl -> + Subsume.isStrictlySubsumed subsume (Clause.literals cl) || + let + let cl' = cl + let cl' = Clause.reduce reduce cl' + let cl' = Clause.rewrite rewrite cl' + in + not (Clause.equalThms cl cl') && + (simp cl' || + let + let () = Print.trace Clause.pp + "Active.isSaturated.redundant: cl'" cl' + in + false + end) + end + in + fun cl -> + simp cl || + let + let () = Print.trace Clause.pp + "Active.isSaturated.redundant: cl" cl + in + false + end + end;; +in + let isSaturated ordering subs cls = + let + let rd = Units.empty + let rw = mkRewrite ordering cls + let red = redundant {subsume = subs, reduce = rd, rewrite = rw} + in + (allFactors red cls && + allResolutions red cls && + allParamodulations red cls) || + let + let () = Print.trace Rewrite.pp "Active.isSaturated: rw" rw + let () = Print.trace (Print.ppList Clause.pp) + "Active.isSaturated: clauses" cls + in + false + end + end;; +end;; + +let checkSaturated ordering subs cls = + if isSaturated ordering subs cls then () + else raise (Useful.Bug "Active.checkSaturated");; +*) + +(* ------------------------------------------------------------------------- *) +(* A type of active clause sets. *) +(* ------------------------------------------------------------------------- *) + +type simplify = Simplify of {subsumes : bool; reduce : bool; rewrites : bool};; + +type parameters = Parameters of + {clause : Clause.parameters; + prefactor : simplify; + postfactor : simplify};; + +type active = Active of + {parameters : parameters; + clauses : Clause.clause Intmap.map; + units : Units.units; + rewrite : Rewrite.rewrite; + subsume : Clause.clause Subsume.subsume; + literals : (Clause.clause * Literal.literal) Literal_net.literalNet; + equations : + (Clause.clause * Literal.literal * Rewrite.orient * Term.term) + Term_net.termNet; + subterms : + (Clause.clause * Literal.literal * Term.path * Term.term) + Term_net.termNet; + allSubterms : (Clause.clause * Term.term) Term_net.termNet};; + +let getSubsume (Active {subsume}) = subsume;; + +let setRewrite active rewrite = + let Active + {parameters;clauses;units;subsume;literals;equations; + subterms;allSubterms} = active + in + Active + {parameters = parameters; clauses = clauses; units = units; + rewrite = rewrite; subsume = subsume; literals = literals; + equations = equations; subterms = subterms; allSubterms = allSubterms} + ;; + +(* ------------------------------------------------------------------------- *) +(* Basic operations. *) +(* ------------------------------------------------------------------------- *) + +let maxSimplify : simplify = Simplify {subsumes = true; reduce = true; rewrites = true};; + +let default : parameters = + Parameters {clause = Clause.default; + prefactor = maxSimplify; + postfactor = maxSimplify};; + +let empty parameters = + let Parameters {clause} = parameters + in let Clause.Parameters {ordering} = clause + in + Active + {parameters = parameters; + clauses = Intmap.newMap (); + units = Units.empty; + rewrite = Rewrite.newRewrite (Knuth_bendix_order.compare ordering); + subsume = Subsume.newSubsume (); + literals = Literal_net.newNet (Term_net.Parameters {fifo = false}); + equations = Term_net.newNet (Term_net.Parameters {fifo = false}); + subterms = Term_net.newNet (Term_net.Parameters {fifo = false}); + allSubterms = Term_net.newNet (Term_net.Parameters {fifo = false})} + ;; + +let size (Active {clauses}) = Intmap.size clauses;; + +let clauses (Active {clauses}) = + let cls = clauses in + let add (_,cl,acc) = cl :: acc + in + Intmap.foldr add [] cls + ;; + +let saturation active = + let remove (cl,(cls,subs)) = + let lits = Clause.literals cl + in + if Subsume.isStrictlySubsumed subs lits then (cls,subs) + else (cl :: cls, Subsume.insert subs (lits,())) + + in let cls = clauses active + in let (cls,_) = Mlist.foldl remove ([], Subsume.newSubsume ()) cls + in let (cls,subs) = Mlist.foldl remove ([], Subsume.newSubsume ()) cls + +(*MetisDebug + let Active {parameters,...} = active + let {clause,...} = parameters + let {ordering,...} = clause + let () = checkSaturated ordering subs cls +*) + in + cls + ;; + + +(* ------------------------------------------------------------------------- *) +(* Pretty printing. *) +(* ------------------------------------------------------------------------- *) + +let toString active = "Active{" ^ string_of_int (size active) ^ "}";; + + +(* ------------------------------------------------------------------------- *) +(* Simplify clauses. *) +(* ------------------------------------------------------------------------- *) + +let simplify simp units rewr subs = + let Simplify {subsumes; reduce; rewrites} = simp + in let s = subsumes and r = reduce and w = rewrites + + in let rec rewrite cl = + let cl' = Clause.rewrite rewr cl + in + if Clause.equalThms cl cl' then Some cl + else + match Clause.simplify cl' with + None -> None + | Some cl'' -> + (* *) + (* Post-rewrite simplification can enable more rewrites: *) + (* *) + (* ~(X = f(X)) \/ ~(g(Y) = f(X)) \/ ~(c = f(X)) *) + (* ---------------------------------------------- rewrite *) + (* ~(X = f(X)) \/ ~(g(Y) = X) \/ ~(c = X) *) + (* ---------------------------------------------- simplify *) + (* ~(g(Y) = f(g(Y))) \/ ~(c = g(Y)) *) + (* ---------------------------------------------- rewrite *) + (* ~(c = f(c)) \/ ~(c = g(Y)) *) + (* *) + (* This was first observed in a bug discovered by Martin *) + (* Desharnais and Jasmin Blanchett *) + (* *) + if Clause.equalThms cl' cl'' then Some cl' else rewrite cl'' + in + fun cl -> + match Clause.simplify cl with + None -> None + | Some cl -> + match (if w then rewrite cl else Some cl) with + None -> None + | Some cl -> + let cl = if r then Clause.reduce units cl else cl + in + if s && Clause.subsumes subs cl then None else Some cl + ;; + +(*MetisDebug +let simplify = fun simp -> fun units -> fun rewr -> fun subs -> fun cl -> + let + let traceCl s = Print.trace Clause.pp ("Active.simplify: " ^ s) +(*MetisTrace4 + let ppClOpt = Print.ppOption Clause.pp + let () = traceCl "cl" cl +*) + let cl' = simplify simp units rewr subs cl +(*MetisTrace4 + let () = Print.trace ppClOpt "Active.simplify: cl'" cl' +*) + let () = + match cl' with + None -> () + | Some cl' -> + case + (match simplify simp units rewr subs cl' with + None -> Some ("away", K ()) + | Some cl'' -> + if Clause.equalThms cl' cl'' then None + else Some ("further", fun () -> traceCl "cl''" cl'')) of + None -> () + | Some (e,f) -> + let + let () = traceCl "cl" cl + let () = traceCl "cl'" cl' + let () = f () + in + raise + Useful.Bug + ("Active.simplify: clause should have been simplified "^e) + end + in + cl' + end;; +*) + +let simplifyActive simp active = + let Active {units;rewrite;subsume} = active + in + simplify simp units rewrite subsume + ;; + +(* ------------------------------------------------------------------------- *) +(* Add a clause into the active set. *) +(* ------------------------------------------------------------------------- *) -(* ========================================================================= *) -(* Main Metis module. *) -(* ========================================================================= *) +let addUnit units cl = + let th = Clause.thm cl + in + match Useful.total Thm.destUnit th with + Some lit -> Units.add units (lit,th) + | None -> units + ;; -module Metis = struct +let addRewrite rewrite cl = + let th = Clause.thm cl + in + match Useful.total Thm.destUnitEq th with + Some l_r -> Rewrite.add rewrite (Clause.id cl, (l_r,th)) + | None -> rewrite + ;; + +let addSubsume subsume cl = Subsume.insert subsume (Clause.literals cl, cl);; + +let addLiterals literals cl = + let add ((_,atm) as lit, literals) = + if Atom.isEq atm then literals + else Literal_net.insert literals (lit,(cl,lit)) + in + Literal.Set.foldl add literals (Clause.largestLiterals cl) + ;; -exception Assert of string;; +let addEquations equations cl = + let add ((lit,ort,tm),equations) = + Term_net.insert equations (tm,(cl,lit,ort,tm)) + in + Mlist.foldl add equations (Clause.largestEquations cl) + ;; + +let addSubterms subterms cl = + let add ((lit,path,tm),subterms) = + Term_net.insert subterms (tm,(cl,lit,path,tm)) + in + Mlist.foldl add subterms (Clause.largestSubterms cl) + ;; + +let addAllSubterms allSubterms cl = + let add ((_,_,tm),allSubterms) = + Term_net.insert allSubterms (tm,(cl,tm)) + in + Mlist.foldl add allSubterms (Clause.allSubterms cl) + ;; + +let addClause active cl = + let Active + {parameters;clauses;units;rewrite;subsume;literals; + equations;subterms;allSubterms} = active + in let clauses = Intmap.insert clauses (Clause.id cl, cl) + and subsume = addSubsume subsume cl + and literals = addLiterals literals cl + and equations = addEquations equations cl + and subterms = addSubterms subterms cl + and allSubterms = addAllSubterms allSubterms cl + in + Active + {parameters = parameters; clauses = clauses; units = units; + rewrite = rewrite; subsume = subsume; literals = literals; + equations = equations; subterms = subterms; + allSubterms = allSubterms} + ;; + +let addFactorClause active cl = + let Active + {parameters;clauses;units;rewrite;subsume;literals; + equations;subterms;allSubterms} = active + in let units = addUnit units cl + and rewrite = addRewrite rewrite cl + in + Active + {parameters = parameters; clauses = clauses; units = units; + rewrite = rewrite; subsume = subsume; literals = literals; + equations = equations; subterms = subterms; allSubterms = allSubterms} + ;; (* ------------------------------------------------------------------------- *) -(* Metis prover. *) +(* Derive (unfactored) consequences of a clause. *) (* ------------------------------------------------------------------------- *) -let metisverb = ref false;; +let deduceResolution literals cl ((_,atm) as lit, acc) = + let resolve (cl_lit,acc) = + (*let (cl1, lit1) = cl_lit in + print_endline ("cl1 = " ^ Clause.toString cl1); + print_endline ("lit1 = " ^ Literal.toString lit1); + print_endline ("cl = " ^ Clause.toString cl); + print_endline ("lit = " ^ Literal.toString lit);*) + match Useful.total (Clause.resolve cl_lit) (cl,lit) with + Some cl' -> cl' :: acc + | None -> acc +(*MetisTrace4 + let () = Print.trace Literal.pp "Active.deduceResolution: lit" lit +*) + in + if Atom.isEq atm then acc + else + Mlist.foldl resolve acc (Literal_net.unify literals (Literal.negate lit)) + ;; + +let deduceParamodulationWith subterms cl ((lit,ort,tm),acc) = + let para (cl_lit_path_tm,acc) = + match Useful.total (Clause.paramodulate (cl,lit,ort,tm)) cl_lit_path_tm with + Some cl' -> cl' :: acc + | None -> acc + in + Mlist.foldl para acc (Term_net.unify subterms tm) + ;; + +let deduceParamodulationInto equations cl ((lit,path,tm),acc) = + let para (cl_lit_ort_tm,acc) = + match Useful.total (Clause.paramodulate cl_lit_ort_tm) (cl,lit,path,tm) with + Some cl' -> cl' :: acc + | None -> acc + in + Mlist.foldl para acc (Term_net.unify equations tm) + ;; + +let deduce active cl = + let Active {parameters;literals;equations;subterms} = active -loads "metis/random.ml";; -loads "metis/portable.ml";; -loads "metis/math.ml";; + in let lits = Clause.largestLiterals cl + in let eqns = Clause.largestEquations cl + in let subtms = + if Term_net.null equations then [] else Clause.largestSubterms cl +(*MetisTrace5 + let () = Print.trace Literal.Set.pp "Active.deduce: lits" lits + let () = Print.trace + (Print.ppList + (Print.ppMap (fun (lit,ort,_) -> (lit,ort)) + (Print.ppPair Literal.pp Rewrite.ppOrient))) + "Active.deduce: eqns" eqns + let () = Print.trace + (Print.ppList + (Print.ppTriple Literal.pp Term.ppPath Term.pp)) + "Active.deduce: subtms" subtms +*) -(* Inline the Useful module here, as it's used almost everywhere in Metis: *) + in let acc = [] + in let acc = Literal.Set.foldl (deduceResolution literals cl) acc lits + in let acc = Mlist.foldl (deduceParamodulationWith subterms cl) acc eqns + in let acc = Mlist.foldl (deduceParamodulationInto equations cl) acc subtms + in let acc = List.rev acc + +(*MetisTrace5 + let () = Print.trace (Print.ppList Clause.pp) "Active.deduce: acc" acc +*) + in + acc + ;; (* ------------------------------------------------------------------------- *) -(* Exceptions. *) +(* Extract clauses from the active set that can be simplified. *) (* ------------------------------------------------------------------------- *) -exception Error of string;; + let clause_rewritables active = + let Active {clauses;rewrite} = active -exception Bug of string;; + in let rewr (id,cl,ids) = + let cl' = Clause.rewrite rewrite cl + in + if Clause.equalThms cl cl' then ids else Intset.add ids id + in + Intmap.foldr rewr Intset.empty clauses + ;; -let total f x = try Some (f x) with Error _ -> None;; + let orderedRedexResidues (((l,r),_),ort) = + match ort with + None -> [] + | Some Rewrite.Left_to_right -> [(l,r,true)] + | Some Rewrite.Right_to_left -> [(r,l,true)];; -let isSome = function - (Some _) -> true - | None -> false -;; + let unorderedRedexResidues (((l,r),_),ort) = + match ort with + None -> [(l,r,false);(r,l,false)] + | Some _ -> [];; + + let rewrite_rewritables active rewr_ids = + let Active {parameters;rewrite;clauses;allSubterms} = active + in let Parameters {clause} = parameters + in let Clause.Parameters {ordering} = clause + in let order = Knuth_bendix_order.compare ordering + + in let addRewr (id,acc) = + if Intmap.inDomain id clauses then Intset.add acc id else acc + + in let addReduce ((l,r,ord),acc) = + let isValidRewr tm = + match Useful.total (Substitute.matchTerms Substitute.empty l) tm with + None -> false + | Some sub -> + ord || + let tm' = Substitute.subst (Substitute.normalize sub) r + in + order tm tm' = Some 1 + + in let addRed ((cl,tm),acc) = +(*MetisTrace5 + let () = Print.trace Clause.pp "Active.addRed: cl" cl + let () = Print.trace Term.pp "Active.addRed: tm" tm +*) + let id = Clause.id cl + in + if Intset.member id acc then acc + else if not (isValidRewr tm) then acc + else Intset.add acc id + +(*MetisTrace5 + let () = Print.trace Term.pp "Active.addReduce: l" l + let () = Print.trace Term.pp "Active.addReduce: r" r + let () = Print.trace Print.ppBool "Active.addReduce: ord" ord +*) + in + Mlist.foldl addRed acc (Term_net.matched allSubterms l) + + in let addEquation redexResidues (id,acc) = + match Rewrite.peek rewrite id with + None -> acc + | Some eqn_ort -> Mlist.foldl addReduce acc (redexResidues eqn_ort) + + in let addOrdered = addEquation orderedRedexResidues + + in let addUnordered = addEquation unorderedRedexResidues + + in let ids = Intset.empty + in let ids = Mlist.foldl addRewr ids rewr_ids + in let ids = Mlist.foldl addOrdered ids rewr_ids + in let ids = Mlist.foldl addUnordered ids rewr_ids + in + ids + ;; + + let choose_clause_rewritables active ids = size active <= length ids + + let rewritables active ids = + if choose_clause_rewritables active ids then clause_rewritables active + else rewrite_rewritables active ids;; + +(*MetisDebug + let rewritables = fun active -> fun ids -> + let + let clause_ids = clause_rewritables active + let rewrite_ids = rewrite_rewritables active ids -let can f x = isSome (total f x);; + let () = + if Intset.equal rewrite_ids clause_ids then () + else + let + let ppIdl = Print.ppList Print.ppInt + let ppIds = Print.ppMap Intset.toList ppIdl + let () = Print.trace pp "Active.rewritables: active" active + let () = Print.trace ppIdl "Active.rewritables: ids" ids + let () = Print.trace ppIds + "Active.rewritables: clause_ids" clause_ids + let () = Print.trace ppIds + "Active.rewritables: rewrite_ids" rewrite_ids + in + raise Useful.Bug "Active.rewritables: ~(rewrite_ids SUBSET clause_ids)" + end + in + if choose_clause_rewritables active ids then clause_ids else rewrite_ids + end;; +*) + + let delete active ids = + if Intset.null ids then active + else + let idPred id = not (Intset.member id ids) + + in let clausePred cl = idPred (Clause.id cl) + + in let Active + {parameters; + clauses; + units; + rewrite; + subsume; + literals; + equations; + subterms; + allSubterms} = active + + in let cP1 (x,_) = clausePred x + in let cP1_4 (x,_,_,_) = clausePred x + in let clauses = Intmap.filter (fun x -> idPred (fst x)) clauses + and subsume = Subsume.filter clausePred subsume + and literals = Literal_net.filter (fun (x,_) -> clausePred x) literals + and equations = Term_net.filter (fun (x,_,_,_) -> clausePred x) equations + and subterms = Term_net.filter (fun (x,_,_,_) -> clausePred x) subterms + and allSubterms = Term_net.filter (fun (x,_) -> clausePred x) allSubterms + in + Active + {parameters = parameters; + clauses = clauses; + units = units; + rewrite = rewrite; + subsume = subsume; + literals = literals; + equations = equations; + subterms = subterms; + allSubterms = allSubterms} + ;; + + let extract_rewritables active = + let Active {clauses;rewrite} = active in + if Rewrite.isReduced rewrite then (active,[]) + else +(*MetisTrace3 + let () = trace "Active.extract_rewritables: inter-reducing\n" +*) + let (rewrite,ids) = Rewrite.reduce' rewrite + in let active = setRewrite active rewrite + in let ids = rewritables active ids + in let cls = Intset.transform (Intmap.get clauses) ids +(*MetisTrace3 + let ppCls = Print.ppList Clause.pp + let () = Print.trace ppCls "Active.extract_rewritables: cls" cls +*) + in + (delete active ids, cls) +(*MetisDebug + handle Failure err -> + raise (Useful.Bug ("Active.extract_rewritables: shouldn't fail\n" ^ err));; +*) +;; (* ------------------------------------------------------------------------- *) -(* Combinators. *) +(* Factor clauses. *) (* ------------------------------------------------------------------------- *) -let cComb f x y = f y x;; + let prefactor_simplify active subsume = + let Active {parameters;units;rewrite} = active + in let Parameters {prefactor} = parameters + in + simplify prefactor units rewrite subsume + ;; -let iComb x = x;; + let postfactor_simplify active subsume = + let Active {parameters;units;rewrite} = active + in let Parameters {postfactor} = parameters + in + simplify postfactor units rewrite subsume + ;; -let kComb x y = x;; + let sort_utilitywise = + let utility cl = + match Literal.Set.size (Clause.literals cl) with + 0 -> -1 + | 1 -> if Thm.isUnitEq (Clause.thm cl) then 0 else 1 + | n -> n + in + Mlist.sortMap utility Useful.intCompare + ;; -let sComb f g x = f x (g x);; + let rec post_factor (cl, ((active,subsume,acc) as active_subsume_acc)) = + match postfactor_simplify active subsume cl with + None -> active_subsume_acc + | Some cl' -> + if Clause.equalThms cl' cl then + let active = addFactorClause active cl + and subsume = addSubsume subsume cl + and acc = cl :: acc + in (active,subsume,acc) + else + (* If the clause was changed in the post-factor simplification *) + (* step, then it may have altered the set of largest literals *) + (* in the clause. The safest thing to do is to factor again. *) + factor1 (cl', active_subsume_acc) -let wComb f x = f x x;; + and factor1 (cl, active_subsume_acc) = + let cls = sort_utilitywise (cl :: Clause.factor cl) + in Mlist.foldl post_factor active_subsume_acc cls + ;; -let rec funpow n f x = - match n with - | 0 -> x - | _ -> funpow (n - 1) f (f x);; + let pre_factor (cl, ((active,subsume,_) as active_subsume_acc)) = + match prefactor_simplify active subsume cl with + None -> active_subsume_acc + | Some cl -> factor1 (cl, active_subsume_acc) + ;; -let exp m = - let rec f x y z = - match y with - | 0 -> z - | _ -> f (m (x,x)) (Int.div y 2) (if y mod 2 = 0 then z else m (z,x)) in - f;; + let rec factor' active acc = function + [] -> (active, List.rev acc) + | cls -> + let cls = sort_utilitywise cls + in let subsume = getSubsume active + in let (active,_,acc) = Mlist.foldl pre_factor (active,subsume,acc) cls + in let (active,cls) = extract_rewritables active + in + factor' active acc cls + ;; + + let factor active cls = factor' active [] cls;; + +(*let factor active cls = + let str cl = String.concat "\n" (List.map Clause.toString cl) in + print_endline ("Active.factor: cls:\n" ^ str cls); + let (active,cls') = factor active cls in + print_endline ("Active.factor: cls':\n" ^ str cls'); + (active, cls');; +*) + +(*MetisTrace4 +let factor = fun active -> fun cls -> + let + let ppCls = Print.ppList Clause.pp + let () = Print.trace ppCls "Active.factor: cls" cls + let (active,cls') = factor active cls + let () = Print.trace ppCls "Active.factor: cls'" cls' + in + (active,cls') + end;; +*) + +(* ------------------------------------------------------------------------- *) +(* Create a new active clause set and initialize clauses. *) +(* ------------------------------------------------------------------------- *) + +let mk_clause params th = + Clause.Clause {parameters = params; id = Clause.newId (); thm = th};; + +let newActive parameters (Ax_cj.Ax_cj_thm {axioms_thm;conjecture_thm}) = + let Parameters {clause} = parameters + + in let mk_clause = mk_clause clause + in let active = empty parameters + in let (active,axioms) = factor active (List.map mk_clause axioms_thm) + in let (active,conjecture) = factor active (List.map mk_clause conjecture_thm) + in + (active, Ax_cj.Ax_cj_cl {axioms_cl = axioms; conjecture_cl = conjecture}) + ;; (* ------------------------------------------------------------------------- *) -(* Pairs. *) +(* Add a clause into the active set and deduce all consequences. *) (* ------------------------------------------------------------------------- *) -let pair x y = (x,y);; +let add active cl = + match simplifyActive maxSimplify active cl with + None -> (active,[]) + | Some cl' -> + if Clause.isContradiction cl' then (active,[cl']) + else if not (Clause.equalThms cl cl') then factor active [cl'] + else +(*MetisTrace2 + let () = Print.trace Clause.pp "Active.add: cl" cl +*) + let active = addClause active cl + in let cl = Clause.freshVars cl + in let cls = deduce active cl + in let (active,cls) = factor active cls +(*MetisTrace2 + let ppCls = Print.ppList Clause.pp + let () = Print.trace ppCls "Active.add: cls" cls +*) + in + (active,cls) + ;; -let swap (x,y) = (y,x);; +end -let curry f x y = f (x,y);; -let uncurry f (x,y) = f x y;; +(* ========================================================================= *) +(* THE WAITING SET OF CLAUSES *) +(* ========================================================================= *) + +module Waiting = struct (* ------------------------------------------------------------------------- *) -(* State transformers. *) +(* A type of waiting sets of clauses. *) (* ------------------------------------------------------------------------- *) -let return (* : 'a -> 's -> 'a * 's *) = pair;; +type weight = float;; + +type modelParameters = Model_parameters of + {model : Model.parameters; + initialPerturbations : int; + maxChecks : int option; + perturbations : int; + weight : weight} -let bind f (g (* : 'a -> 's -> 'b * 's *)) x = uncurry g (f x);; +type parameters = Parameters of + {symbolsWeight : weight; + variablesWeight : weight; + literalsWeight : weight; + modelsP : modelParameters list};; + +type distance = float;; + +type waiting = Waiting of + {parameters : parameters; + clauses : (weight * (distance * Clause.clause)) Heap.heap; + models : Model.model list};; (* ------------------------------------------------------------------------- *) -(* Comparisons. *) +(* Basic operations. *) (* ------------------------------------------------------------------------- *) -let revCompare cmp x y = - match cmp x y with Less -> Greater | Equal -> Equal | Greater -> Less;; +let defaultModels : modelParameters list = + [Model_parameters {model = Model.default; + initialPerturbations = 100; + maxChecks = Some 20; + perturbations = 0; + weight = Float.one}];; -let prodCompare xCmp yCmp (x1,y1) (x2,y2) = - match xCmp x1 x2 with - | Less -> Less - | Equal -> yCmp y1 y2 - | Greater -> Greater;; +let default : parameters = + Parameters {symbolsWeight = Float.one; + literalsWeight = Float.one; + variablesWeight = Float.one; + modelsP = defaultModels};; -let lexCompare cmp = - let rec lex x y = - match x,y with - | ([],[]) -> Equal - | ([], _ :: _) -> Less - | (_ :: _, []) -> Greater - | (x :: xs, y :: ys) -> - match cmp x y with - | Less -> Less - | Equal -> lex xs ys - | Greater -> Greater in - lex -;; +let size (Waiting {clauses}) = Heap.size clauses;; + +let toString w = "Waiting{" ^ string_of_int (size w) ^ "}";; + +(*let toString (Waiting {clauses}) = "\n" ^ + String.concat "\n" (List.map (fun (w, (d, c)) -> Clause.toString c) (Heap.toList clauses));;*) -let boolCompare x y = - match x,y with - | (false,true) -> Less - | (true,false) -> Greater - | _ -> Equal;; + +(*MetisDebug +let pp = + Print.ppMap + (fun Waiting {clauses,...} -> + List.map (fun (w,(_,cl)) -> (w, Clause.id cl, cl)) (Heap.toList clauses)) + (Print.ppList (Print.ppTriple Print.ppReal Print.ppInt Clause.pp));; +*) (* ------------------------------------------------------------------------- *) -(* Lists. *) +(* Perturbing the models. *) (* ------------------------------------------------------------------------- *) -let rec first f = function - | [] -> None - | x::xs -> match f x with None -> first f xs | s -> s;; - -let rec maps (f (* : 'a -> 's -> 'b * 's *)) = function - | [] -> return [] - | x :: xs -> - bind (f x) (fun y -> bind (maps f xs) (fun ys -> return (y :: ys)));; - -let zipWith f = - let rec z l = function - | ([], []) -> l - | (x :: xs, y :: ys) -> z (f x y :: l) (xs, ys) - | _ -> raise (Error "zipWith: lists different lengths") in - fun xs -> fun ys -> List.rev (z [] (xs, ys)) -;; +type modelClause = Name.Set.set * Thm.clause;; -let zip xs ys = zipWith pair xs ys;; +let mkModelClause cl = + let lits = Clause.literals cl + in let fvs = Literal.Set.freeVars lits + in + (fvs,lits) + ;; -let unzip ab = - let inc (x,y) (xs,ys) = (x :: xs, y :: ys) in - List.foldl inc ([],[]) (List.rev ab);; +let mkModelClauses = List.map mkModelClause;; -let enumerate l = fst (maps (fun x m -> ((m, x), m + 1)) l 0);; +let perturbModel vM cls = + if Mlist.null cls then K () + else + let vN = Model.Size {size = Model.msize vM} -let revDivide l = - let rec revDiv acc = function - | (l, 0) -> (acc,l) - | ([], _) -> raise Subscript - | (h :: t, n) -> revDiv (h :: acc) (t, n - 1) in - fun n -> revDiv [] (l, n);; + in let perturbClause (fv,cl) = + let vV = Model.randomValuation vN fv + in + if Model.interpretClause vM vV cl then () + else Model.perturbClause vM vV cl -let divide l n = let (a,b) = revDivide l n in (List.rev a, b);; + in let perturbClauses () = List.iter perturbClause cls + in + fun n -> funpow n perturbClauses () + ;; -let updateNth (n,x) l = - let (a,b) = revDivide l n in - match b with [] -> raise Subscript | (_ :: t) -> rev_append a (x :: t) -;; +let initialModel axioms conjecture parm = + let Model_parameters {model;initialPerturbations} = parm + in let m = Model.newModel model + in let () = perturbModel m conjecture initialPerturbations + in let () = perturbModel m axioms initialPerturbations + in + m + ;; -let deleteNth n l = - let (a,b) = revDivide l n in - match b with [] -> raise Subscript | (_ :: t) -> rev_append a t -;; +let checkModels parms models (fv,cl) = + let check ((parm,model),z) = + let Model_parameters {maxChecks;weight} = parm + in let n = maxChecks + in let (vT,vF) = Model.check Model.interpretClause n model fv cl + in + (Float.one +. float_of_int vT /. float_of_int (vT + vF) ** weight) *. z + in + Mlist.foldl check Float.one (zip parms models) + ;; + +let perturbModels parms models cls = + let perturb (parm,model) = + let Model_parameters {perturbations} = parm + in + perturbModel model cls perturbations + in + List.iter perturb (zip parms models) + ;; (* ------------------------------------------------------------------------- *) -(* Sets implemented with lists. *) +(* Clause weights. *) (* ------------------------------------------------------------------------- *) -let mem x l = List.exists (fun y -> x = y) l;; + let clauseSymbols cl = float_of_int (Literal.Set.typedSymbols cl);; + + let clauseVariables cl = + float_of_int (Name.Set.size (Literal.Set.freeVars cl) + 1);; + + let clauseLiterals cl = float_of_int (Literal.Set.size cl);; + + let clausePriority cl = Float.of_string "1e-12" *. float_of_int (Clause.id cl);; + + let clauseWeight (parm : parameters) mods dist mcl cl = +(*MetisTrace3 + let () = Print.trace Clause.pp "Waiting.clauseWeight: cl" cl +*) + let Parameters {symbolsWeight;variablesWeight;literalsWeight;modelsP} = parm + in let lits = Clause.literals cl + in let symbolsW = clauseSymbols lits ** symbolsWeight + in let variablesW = clauseVariables lits ** variablesWeight + in let literalsW = clauseLiterals lits ** literalsWeight + in let modelsW = checkModels modelsP mods mcl +(*MetisTrace4 + let () = trace ("Waiting.clauseWeight: dist = " ^ + string_of_float dist ^ "\n") + let () = trace ("Waiting.clauseWeight: symbolsW = " ^ + string_of_float symbolsW ^ "\n") + let () = trace ("Waiting.clauseWeight: variablesW = " ^ + string_of_float variablesW ^ "\n") + let () = trace ("Waiting.clauseWeight: literalsW = " ^ + string_of_float literalsW ^ "\n") + let () = trace ("Waiting.clauseWeight: modelsW = " ^ + string_of_float modelsW ^ "\n") +*) + in let weight = dist *. symbolsW *. variablesW *. literalsW *. modelsW + in let weight = weight +. clausePriority cl +(*MetisTrace3 + let () = trace ("Waiting.clauseWeight: weight = " ^ + string_of_float weight ^ "\n") +*) + in + weight + ;; (* ------------------------------------------------------------------------- *) -(* Strings. *) +(* Adding new clauses. *) (* ------------------------------------------------------------------------- *) -let mkPrefix p s = p ^ s +let add' waiting dist mcls cls = + let Waiting {parameters;clauses;models} = waiting + in let Parameters {modelsP} = parameters in let modelParameters = modelsP -let stripSuffix pred s = - let rec strip pos = - if pos < 0 then "" else - if pred (s.[pos]) then strip (pos - 1) - else String.substring s 0 (pos + 1) in - strip (String.size s - 1);; +(*MetisDebug + let _ = not (Mlist.null cls) || + raise Useful.Bug "Waiting.add': null" + + let _ = length mcls = length cls || + raise Useful.Bug "Waiting.add': different lengths" +*) + + in let dist = dist +. log (float_of_int (length cls)) + + in let addCl ((mcl,cl),acc) = + let weight = clauseWeight parameters models dist mcl cl + in + Heap.add acc (weight,(dist,cl)) + + in let clauses = Mlist.foldl addCl clauses (zip mcls cls) + + in let () = perturbModels modelParameters models mcls + in + Waiting {parameters = parameters; clauses = clauses; models = models} + ;; + +let add waiting (dist,cls) = + if Mlist.null cls then waiting + else +(*MetisTrace3 + let () = Print.trace pp "Waiting.add: waiting" waiting + let () = Print.trace (Print.ppList Clause.pp) "Waiting.add: cls" cls +*) + + let waiting = add' waiting dist (mkModelClauses cls) cls + +(*MetisTrace3 + let () = Print.trace pp "Waiting.add: waiting" waiting +*) + in + waiting + ;; + + let cmp ((w1 : float),_) ((w2 : float),_) = Float.compare w1 w2;; + + let empty parameters axioms conjecture = + let Parameters {modelsP} = parameters in let modelParameters = modelsP + in let clauses = Heap.newHeap cmp + and models = List.map (initialModel axioms conjecture) modelParameters + in + Waiting {parameters = parameters; clauses = clauses; models = models} + ;; + + let newWaiting parameters (Ax_cj.Ax_cj_cl {axioms_cl;conjecture_cl}) = + let mAxioms = mkModelClauses axioms_cl + and mConjecture = mkModelClauses conjecture_cl + + in let waiting = empty parameters mAxioms mConjecture + in + if Mlist.null axioms_cl && Mlist.null conjecture_cl then waiting + else add' waiting Float.zero (mAxioms @ mConjecture) (axioms_cl @ conjecture_cl) +(*MetisDebug + handle e -> + let + let () = Print.trace Print.ppException "Waiting.new: exception" e + in + raise e + end;; +*) (* ------------------------------------------------------------------------- *) -(* Sorting and searching. *) +(* Removing the lightest clause. *) (* ------------------------------------------------------------------------- *) -let sort cmp = List.sort (fun x y -> cmp x y = Less);; +let remove (Waiting {parameters;clauses;models}) = + if Heap.null clauses then None + else + let ((_,dcl),clauses) = Heap.remove clauses -let sortMap f cmp = function - | [] -> [] - | ([_] as l) -> l - | xs -> - let ncmp (m,_) (n,_) = cmp m n in - let nxs = List.map (fun x -> (f x, x)) xs in - let nys = List.sort (fun x y -> ncmp x y = Less) nxs in - List.map snd nys -;; + in let waiting = + Waiting + {parameters = parameters; + clauses = clauses; + models = models} + in + Some (dcl,waiting) + ;; + +end + + +(* ========================================================================= *) +(* THE RESOLUTION PROOF PROCEDURE *) +(* ========================================================================= *) + +module Resolution = struct (* ------------------------------------------------------------------------- *) -(* Integers. *) +(* A type of resolution proof procedures. *) (* ------------------------------------------------------------------------- *) -let rec interval m = function - | 0 -> [] - | len -> m :: interval (m + 1) (len - 1);; +type parameters = Parameters of + {activeP : Active.parameters; + waitingP : Waiting.parameters};; -let divides = function - | (_, 0) -> true - | (0, _) -> false - | (a, b) -> b mod (abs a) = 0;; -let divides = curry divides;; +type resolution = Resolution of + {parameters : parameters; + active : Active.active; + waiting : Waiting.waiting};; (* ------------------------------------------------------------------------- *) -(* Useful impure features. *) +(* Basic operations. *) (* ------------------------------------------------------------------------- *) -let generator = ref 0;; +let default : parameters = + Parameters {activeP = Active.default; + waitingP = Waiting.default};; -let newIntThunk () = - let n = !generator in - generator := n + 1; - n -;; +let newResolution parameters ths = + let Parameters {activeP; waitingP} = parameters + in let activeParm = activeP and waitingParm = waitingP + + in let (active,cls) = Active.newActive activeParm ths (* cls = factored ths *) + + in let waiting = Waiting.newWaiting waitingParm cls + in + Resolution {parameters = parameters; active = active; waiting = waiting};; +(*MetisDebug + handle e -> + let + let () = Print.trace Print.ppException "Resolution.new: exception" e + in + raise e + end;; +*) + +let active (Resolution {active}) = active;; + +let waiting (Resolution {waiting}) = waiting;; + + +(* ------------------------------------------------------------------------- *) +(* The main proof loop. *) +(* ------------------------------------------------------------------------- *) + +type decision = + Contradiction of Thm.thm + | Satisfiable of Thm.thm list;; + +type state = + Decided of decision + | Undecided of resolution;; + +let iterate res = + let Resolution {parameters;active;waiting} = res + +(*MetisTrace2 + let () = Print.trace Active.pp "Resolution.iterate: active" active + let () = Print.trace Waiting.pp "Resolution.iterate: waiting" waiting +*) + in + (* + print_endline ("Resolution.iterate:active: " ^ Active.toString active); + print_endline ("Resolution.iterate:waiting: " ^ Waiting.toString waiting); + *) + match Waiting.remove waiting with + None -> + let sat = Satisfiable (List.map Clause.thm (Active.saturation active)) + in + Decided sat + | Some ((d,cl),waiting) -> + if Clause.isContradiction cl then + Decided (Contradiction (Clause.thm cl)) + else +(*MetisTrace1 + let () = Print.trace Clause.pp "Resolution.iterate: cl" cl +*) + (* + let () = print_endline ("Resolution.iterate: cl " ^ (Clause.toString cl)) in + *) + let (active,cls) = Active.add active cl + + in let waiting = Waiting.add waiting (d,cls) + + in let res = + Resolution + {parameters = parameters; + active = active; + waiting = waiting} + in + Undecided res + ;; + +let rec loop res = + match iterate res with + Decided dec -> dec + | Undecided res -> loop res;; -let newIntsThunk k () = - let n = !generator in - generator := n + k; - interval n k -;; -let newInt () = newIntThunk ();; - -let newInts k = - if k <= 0 then [] - else (newIntsThunk k) ();; - -(* The rest of Metis follows: *) - -loads "metis/pmap.ml";; -loads "metis/pset.ml";; -loads "metis/mmap.ml";; -loads "metis/mset.ml";; -loads "metis/sharing.ml";; -loads "metis/heap.ml";; -loads "metis/name.ml";; -loads "metis/name_arity.ml";; -loads "metis/term.ml";; -loads "metis/substitute.ml";; -loads "metis/atom.ml";; -loads "metis/formula.ml";; -loads "metis/literal.ml";; -loads "metis/thm.ml";; -loads "metis/proof.ml";; -loads "metis/rule.ml";; -loads "metis/model.ml";; -loads "metis/term_net.ml";; -loads "metis/atom_net.ml";; -loads "metis/literal_net.ml";; -loads "metis/subsume.ml";; -loads "metis/knuth_bendix.ml";; -loads "metis/rewrite.ml";; -loads "metis/units.ml";; -loads "metis/clause.ml";; -loads "metis/active.ml";; -loads "metis/waiting.ml";; -loads "metis/resolution.ml";; -loads "metis/loop.ml";; -loads "metis/metis_debug.ml";; -loads "metis/preterm.ml";; -loads "metis/metis_mapping.ml";; -loads "metis/metis_path.ml";; -loads "metis/metis_unify.ml";; -loads "metis/metis_rules.ml";; -loads "metis/metis_reconstruct2.ml";; -loads "metis/metis_generate.ml";; +end + +(* ========================================================================= *) +(* The basic Metis loop. *) +(* ========================================================================= *) + +module Loop = +struct + +let rec loop res = + match Resolution.iterate res with + Resolution.Decided dec -> Some dec + | Resolution.Undecided res -> loop res + +let run rules = + let ths = Ax_cj.Ax_cj_thm {axioms_thm = rules; conjecture_thm = []} in + let res = Resolution.newResolution Resolution.default ths in + match loop res with + None -> failwith "metis: timeout" + | Some (Resolution.Contradiction thm) -> thm + | Some (Resolution.Satisfiable _) -> + failwith "metis: found satisfiable assignment" + +end + +end + + +module Metis_debug = struct + +(* Taken from: https://sourceforge.net/p/hol/mailman/message/35201767/ *) +let print_varandtype fmt tm = + let hop,args = strip_comb tm in + let s = name_of hop + and ty = type_of hop in + if is_var hop && args = [] then + (pp_print_string fmt "("; + pp_print_string fmt s; + pp_print_string fmt ":"; + pp_print_type fmt ty; + pp_print_string fmt ")") + else fail() ;; + +let show_types,hide_types = + (fun () -> install_user_printer ("Show Types",print_varandtype)), + (fun () -> try delete_user_printer "Show Types" + with Failure _ -> failwith ("hide_types: "^ + "Types are already hidden."));; + +end + + +module Preterm = struct + +let mk_negp pt = Combp (preterm_of_term `~`, pt) +let mk_eqp (ps, pt) = Combp (Combp (Constp ("=", dpty), ps), pt) +let mk_conjp (ps, pt) = Combp (Combp (preterm_of_term `/\`, ps), pt) +let mk_disjp (ps, pt) = Combp (Combp (preterm_of_term `\/`, ps), pt) + +let list_mk_combp (h, t) = rev_itlist (fun x acc -> Combp (acc, x)) t h + +(* +assert + ( + list_mk_combp (Varp ("1", dpty), [Varp ("2", dpty); Varp ("3", dpty)]) + = + Combp (Combp (Varp ("1", Ptycon ("", [])), Varp ("2", Ptycon ("", []))), + Varp ("3", Ptycon ("", []))) + );; +*) + +let list_mk_disjp = function + [] -> preterm_of_term `F` + | h::t -> itlist (curry mk_disjp) t h + +(* typechecking a preterm with constants fails, + therefore we convert constants to variables before type checking + type checking converts the variables back to the corresponding constants +*) +let rec unconst_preterm = function + Varp (s, pty) -> Varp (s, pty) + | Constp (s, pty) -> Varp (s, pty) + | Combp (l, r) -> Combp (unconst_preterm l, unconst_preterm r) + | Typing (ptm, pty) -> Typing (unconst_preterm ptm, pty) + | _ -> failwith "unconst_preterm" + +let rec env_of_preterm = function + Varp (s, pty) -> [(s, pty)] + | Constp (s, pty) -> [] + | Combp (l, r) -> env_of_preterm l @ env_of_preterm r + | Typing (ptm, pty) -> env_of_preterm ptm + | _ -> failwith "env_of_preterm" + +let env_of_th = env_of_preterm o preterm_of_term o concl +let env_of_ths = List.concat o List.map env_of_th + +end + + +module Metis_mapping = struct + + let reset_consts,fol_of_const,hol_of_const = + Meson.reset_consts,Meson.fol_of_const,Meson.hol_of_const + +let preterm_of_const = preterm_of_term o hol_of_const o int_of_string + +let prefix s = "__" ^ s + +let rec preterm_of_fol_term = function + Metis_prover.Term.Tvar x -> Varp (prefix x, dpty) + | Metis_prover.Term.Fn (f, args) -> + let pf = preterm_of_const f in + let pargs = List.map preterm_of_fol_term args in + Preterm.list_mk_combp (pf, pargs) + +let preterm_of_predicate = function + "=" -> Constp ("=", dpty) + | p -> preterm_of_const p + +let preterm_of_atom (p, args) = + let pp = preterm_of_predicate p in + let pargs = List.map preterm_of_fol_term args in + Typing (Preterm.list_mk_combp (pp, pargs), pretype_of_type bool_ty) + +let preterm_of_literal (pol, fat) = + let pat = preterm_of_atom fat in + if pol then pat else Preterm.mk_negp pat + +let preterm_of_eq (s, t) = + Preterm.mk_eqp (preterm_of_fol_term s, preterm_of_fol_term t) + + +let typecheck env = term_of_preterm o retypecheck env o Preterm.unconst_preterm +let typecheckl env = function + [] -> [] + | xs -> Preterm.list_mk_disjp xs |> typecheck env |> disjuncts + + +let hol_of_term env = typecheck env o preterm_of_fol_term + +let hol_of_atom env = typecheck env o preterm_of_atom + +let hol_of_literal env = typecheck env o preterm_of_literal + +let hol_of_clause env = typecheck env o Preterm.list_mk_disjp o map preterm_of_literal + +let hol_of_substitution env = map dest_eq o typecheckl env o map preterm_of_eq + +end + + +module Metis_path = struct + +(* The term `f 1 2 3` is encoded in HOL Light as follows: + + @ + / \ + @ 3 + / \ + @ 2 + / \ + f 1 + +*) + +let rec hol_of_term_path tm path = match tm, path with + (tm, []) -> tm, "" + | Metis_prover.Term.Fn (f, args), i :: is -> + let arity = length args in + (* assert (i < arity); *) + let (tm', path') = hol_of_term_path (List.nth args i) is in + (tm', String.make (arity - i - 1) 'l' ^ "r" ^ path') + | _ -> failwith "hol_of_term_path" + +let hol_of_atom_path (p, args) = hol_of_term_path (Metis_prover.Term.Fn (p, args)) + +let hol_of_literal_path (pol, atom) path = + let s, path = hol_of_atom_path atom path in + (s, (if pol then path else "r" ^ path)) + +end + + +module Metis_unify = struct + +let verb = ref false + +exception Unify + +let rec unify_fo_ho_term vars fat tm m = +(* + if !verb then Format.printf "unify_fo_ho_term: fat = %s, tm = %s\n%!" + (Metis_prover.Term.toString fat) (string_of_term tm); +*) + match fat with + Metis_prover.Term.Tvar v when List.mem_assoc v m -> + (* if !verb then Format.printf "var_assoc\n%!"; *) + let tm' = List.assoc v m in + if tm = tm' then m else raise Unify + | Metis_prover.Term.Tvar v -> + (* if !verb then Format.printf "var\n%!"; *) + if is_var tm && not (List.mem tm vars) then (v, tm) :: m + else ((* if !verb then Format.printf "Unify!\n%!"; *) raise Unify) + | Metis_prover.Term.Fn (f, args) -> + (* if !verb then Format.printf "fn\n%!"; *) + let hf, hargs = try strip_comb tm with Failure _ -> raise Unify in +(* + if !verb then begin + Format.printf "hf = %s\n%!" (string_of_term hf); + Format.printf "is_var: %s\n%!" (if is_var hf then "true" else "false") + end; + assert (is_const hf || is_var hf); +*) + if hf = Metis_mapping.hol_of_const (int_of_string f) + then itlist2 (unify_fo_ho_term vars) args hargs m + else raise Unify + +let unify_fo_ho_atom vars (p, args) htm m = + if p = "=" + then try let hl, hr = dest_eq htm in itlist2 (unify_fo_ho_term vars) args [hl; hr] m + with Failure _ -> raise Unify + else unify_fo_ho_term vars (Metis_prover.Term.Fn (p, args)) htm m + +let unify_fo_ho_literal vars (pol, atom) htm m = + let htm' = if pol then htm else try dest_neg htm with Failure _ -> raise Unify in + unify_fo_ho_atom vars atom htm' m + +end + + +module Metis_rules = struct + +(* move a literal in the proof of a disjunction to the first position + may not preserve the order of the other literals *) +let FRONT lit thm = + let conc = concl thm in + let disj = disjuncts (concl thm) in + let rest = match partition (fun l -> l = lit) disj with + ([], _) -> failwith "FRONT: literal not in disjunction" + | (_ , r) -> r in + let disj' = lit :: rest in + let conc' = list_mk_disj disj' in + let eq = DISJ_ACI_RULE (mk_eq (conc, conc')) in + (PURE_ONCE_REWRITE_RULE [eq] thm, rest) + +(* resolve two clauses, where atom has to appear at the first position of + both clauses: positive in the first and negative in the second clause *) +let RESOLVE_N = + let RESOLVE_1 = TAUT `!a. a ==> ~a ==> F` + and RESOLVE_2L = TAUT `!a b. a \/ b ==> ~a ==> b` + and RESOLVE_2R = TAUT `!a c. a ==> ~a \/ c ==> c` + and RESOLVE_3 = TAUT `!a b c. a \/ b ==> ~a \/ c ==> b \/ c` in + fun atom -> function + ([], []) -> SPEC atom RESOLVE_1 +| (r1, []) -> SPECL [atom; list_mk_disj r1] RESOLVE_2L +| ([], r2) -> SPECL [atom; list_mk_disj r2] RESOLVE_2R +| (r1, r2) -> SPECL [atom; list_mk_disj r1; list_mk_disj r2] RESOLVE_3 + +(* resolve two clauses th1 and th2, where atom appears somewhere + positive in th1 and negative in th2 *) +let RESOLVE atom th1 th2 = + (*print_endline ("Atom: " ^ string_of_term atom); + print_endline ("th1 : " ^ string_of_term (concl th1)); + print_endline ("th2 : " ^ string_of_term (concl th2));*) + try let (th1', r1) = FRONT atom th1 + and (th2', r2) = FRONT (mk_neg atom) th2 in + let res = RESOLVE_N atom (r1, r2) in + MP (MP res th1') th2' + with Failure _ -> failwith "resolve" + +(* given A, tm |- C, prove A |- ~tm \/ C or + given A, ~tm |- C, prove A |- tm \/ C *) +let DISCH_DISJ = + let IMPL_NOT_L = TAUT `!a b. ~a ==> b <=> a \/ b` + and IMPL_NOT_R = TAUT `!a b. a ==> b <=> ~a \/ b` in + fun tm th -> + let impl = DISCH tm th + and (tm', IMPL_NOT) = + try dest_neg tm, IMPL_NOT_L + with Failure _ -> tm, IMPL_NOT_R in + let eq = SPECL [tm'; concl th] IMPL_NOT in + PURE_ONCE_REWRITE_RULE [eq] impl + +(* given A, tm1, .., tmn |- th, prove A |- ~tm1 \/ .. \/ ~tmn \/ th *) +let DISCH_DISJS tms th = List.fold_right DISCH_DISJ tms th + +end + + +module Metis_reconstruct2 = struct + +let term_eq_mod_type t1 t2 tyinsts = + try + let _,tminsts,tyinsts = term_type_unify t1 t2 ([], [], tyinsts) in +(* + if !metisverb then + begin + Format.printf "unified with |tminsts| = %d!\n%!" (List.length tminsts); + List.iter (fun t1, t2 -> Format.printf "%s <- %s\n%!" (string_of_term t1) (string_of_term t2)) tminsts + end; +*) + if tminsts = [] then Some tyinsts else None + with Failure _ -> None + +(* pointer inequality unsupported; using != or <> sound off as well +let rec match_elems f m = function + ([], []) -> [m] + | ([], _) -> [] + | (x :: xs, ys) -> List.map (fun y -> match f x y m with + Some m' -> match_elems f m' (xs, List.filter ((!=) y) ys) + | None -> []) ys |> List.concat +*) +let rec match_elems f m = function + ([], []) -> [m] + | ([], _) -> [] + | (x :: xs, ys) -> + let rec go acc = function + [] -> [] + | y :: rest -> (match f x y m with + Some m' -> match_elems f m' (xs, List.rev_append acc rest) + | None -> []) @ go (y :: acc) rest + in go [] ys + +let match_fo_ho_clause vars = match_elems + (fun ft ht m -> try Some (Metis_unify.unify_fo_ho_literal vars ft ht m) with Metis_unify.Unify -> None) + [] + + +let string_of_tminst = String.concat ", " o + map (fun (tm, v) -> string_of_term tm ^ " <- " ^ string_of_term v) + +let string_of_tyinst = String.concat ", " o + map (fun (ty, v) -> string_of_type ty ^ " <- " ^ string_of_type v) + +let string_of_instantiation (it, tminst, tyinst) = + "([" ^ string_of_tminst tminst ^ "], [" ^ string_of_tyinst tyinst ^ "])" + +let reorient_tysubst vars sub = + let sub' = map (fun (ty, v) -> + if List.mem v vars && is_vartype ty then v, ty else ty, v) sub in + map (fun (ty, v) -> tysubst sub' ty, v) sub' + +let rec hol_of_thm axioms fth = + (* if !metisverb then Format.printf "hol_of_thm: %s\n%!" (Metis_prover.Thm.toString fth); *) + let env = Preterm.env_of_ths axioms in + let hth = match Metis_prover.Proof.thmToInference fth with + Metis_prover.Proof.Axiom clause -> + let clausel = Metis_prover.Literal.Set.toList clause in + let maxs = Utils.List.concat_map (fun ax -> + (*if !metisverb then Format.printf "ax: %s\n%!" (string_of_thm ax);*) + let disjs = concl ax |> striplist dest_disj in + (*if !metisverb then Format.printf "before matching\n%!";*) + let tmvars = freesl (hyp ax) in + let ms = match_fo_ho_clause tmvars (clausel, disjs) in + (*if !metisverb then Format.printf "after matching\n%!";*) + map (fun m -> m, ax) ms) axioms in + (* assert (List.length maxs > 0); *) + let tminst = List.map (fun (v, tm) -> mk_var (Metis_mapping.prefix v, type_of tm), tm) in +(* + if !metisverb then Format.printf "length maxs = %d\n%!" (List.length maxs); + if !metisverb then List.iter (fun (m, ax) -> Format.printf "max: %s with m = %s\n%!" (string_of_thm ax) (string_of_tminst (tminst m))) maxs; +*) + let (m, ax) = List.hd maxs in + INST (tminst m) ax + (* Caution: the substitution can contain elements such as "x -> f(x)" *) + | Metis_prover.Proof.Subst (fsub, fth1) -> + let th1 = hol_of_thm axioms fth1 in + (* if !metisverb then Format.printf "subst with th1 = %s\n%!" (string_of_thm th1); *) + + let fsubl = Metis_prover.Substitute.toList fsub in + (* if !metisverb then Format.printf "before substitution lifting\n%!"; *) + let hsub = map (fun (v, t) -> t, Metis_prover.Term.Tvar v) fsubl |> + Metis_mapping.hol_of_substitution env in + (* if !metisverb then Format.printf "subst: %s\n%!" (string_of_tminst hsub); *) + let tyinst = itlist (fun (t, v) m -> + let v' = find (fun v' -> name_of v' = name_of v) (frees (concl th1)) in + type_unify (type_of v) (type_of v') m) hsub [] in + let tminst = map (fun (t, v) -> inst tyinst t, inst tyinst v) hsub in + +(* + if !metisverb then + Format.printf "before instantiate of th1 = %s with %s\n%!" + (string_of_thm th1) (string_of_instantiation ([], tminst, tyinst)); + +*) + INSTANTIATE ([], tminst, tyinst) th1 + | Metis_prover.Proof.Resolve (atom, fth1, fth2) -> + let th1 = hol_of_thm axioms fth1 + and th2 = hol_of_thm axioms fth2 in + let env = Preterm.env_of_ths [th1; th2] @ env in +(* + if !metisverb then List.iter (fun (s, pty) -> Format.printf "%s <- %s\n%!" s (string_of_type (type_of_pretype pty))) env; + if !metisverb then Format.printf "before resolving\n%!"; + if !metisverb then Format.printf "th1 = %s\n%!" (string_of_thm th1); + if !metisverb then Format.printf "th2 = %s\n%!" (string_of_thm th2); +*) + let tm1 = striplist dest_disj (concl th1) |> List.filter (not o is_neg) + and tm2 = striplist dest_disj (concl th2) |> List.filter is_neg |> List.map dest_neg in +(* + if !metisverb then List.iter (Format.printf "tm1: %s\n%!" o string_of_term) tm1; + if !metisverb then List.iter (Format.printf "tm2: %s\n%!" o string_of_term) tm2; +*) + let hatom = Metis_mapping.hol_of_atom env atom in +(* + if !metisverb then Format.printf "hatom: %s\n%!" (string_of_term hatom); +*) + let cands = Utils.List.concat_map (fun x -> + match term_eq_mod_type hatom x [] with + None -> [] + | Some m -> Utils.List.filter_map (fun y -> term_eq_mod_type hatom y m) tm2) tm1 in +(* + if !metisverb then Format.printf "%d candidates available\n%!" (List.length cands); + assert (List.length cands > 0); + assert (let h = List.hd cands in List.for_all ((=) h) cands); +*) + let tyinsts = List.hd cands in + let tyvars = map hyp axioms |> List.concat |> + map type_vars_in_term |> List.concat in + (* if !metisverb then Format.printf "Reorienting type substitution ...\n%!"; *) + let tyinsts = reorient_tysubst tyvars tyinsts in + + (* if !metisverb then Format.printf "Resolving ...\n%!"; *) + + Metis_rules.RESOLVE (inst tyinsts hatom) + (INST_TYPE tyinsts th1) (INST_TYPE tyinsts th2) + | Metis_prover.Proof.Refl term -> REFL (Metis_mapping.hol_of_term env term) + | Metis_prover.Proof.Assume atom -> SPEC (Metis_mapping.hol_of_atom env atom) EXCLUDED_MIDDLE + | Metis_prover.Proof.Equality (flit, fpath, ft) -> + let hlit = Metis_mapping.hol_of_literal env flit in + let fs, hpath = Metis_path.hol_of_literal_path flit fpath in + let hs = follow_path hpath hlit in + let ht = Metis_mapping.hol_of_term env ft in + let m = type_unify (type_of ht) (type_of hs) [] in + let hlit, hs, ht = inst m hlit, inst m hs, inst m ht in + +(* + if !metisverb then begin + Format.printf "Trying to replace %s : %s with %s : %s\n%!" + (string_of_term hs) (string_of_type (type_of hs)) + (string_of_term ht) (string_of_type (type_of ht)); + Format.printf "In %s\n%!" (string_of_term hlit) + end; +*) + + let heq = mk_eq (hs, ht) in + let conv = PATH_CONV hpath (PURE_ONCE_REWRITE_CONV [ASSUME heq]) in + let hlit' = CONV_RULE conv (ASSUME hlit) in +(* + if !metisverb then Format.printf "hlit = %s, hlit' = %s\n%!" + (string_of_term hlit) (string_of_thm hlit'); + + if hs <> ht then assert (concl hlit' <> hlit); + *) + (try Metis_rules.DISCH_DISJS [heq; hlit] hlit' + with Failure _ -> failwith "equality") + in + (* eliminate duplicates in clause *) + let hth = CONV_RULE DISJ_CANON_CONV hth in +(* + if !metisverb then begin + Format.printf "hol_of_thm finished\n%!"; + let hth' = Metis_prover.Thm.clause fth |> Metis_prover.Literal.Set.toList |> Metis_mapping.hol_of_clause env in + Format.printf "hol_of_thm returned:\n%s\n for\n%s\n%!" + (string_of_term (concl hth)) (string_of_term hth') + end; +*) + hth + +end + +(* ========================================================================= *) +(* Conversion of HOL to Metis FOL. *) +(* ========================================================================= *) + +module Metis_generate = struct + +let metis_name = string_of_int + +let rec metis_of_term env consts tm = + if is_var tm && not (List.mem tm consts) then + (Metis_prover.Term.Tvar(metis_name (Meson.fol_of_var tm))) + else ( + let f,args = strip_comb tm in + if List.mem f env then failwith "metis_of_term: higher order" else + let ff = Meson.fol_of_const f in + Metis_prover.Term.Fn (metis_name ff, map (metis_of_term env consts) args)) + +let metis_of_atom env consts tm = + try let (l, r) = dest_eq tm in + let l' = metis_of_term env consts l + and r' = metis_of_term env consts r in + Metis_prover.Atom.mkEq (l', r') + with Failure _ -> + let f,args = strip_comb tm in + if List.mem f env then failwith "metis_of_atom: higher order" else + let ff = Meson.fol_of_const f in + (metis_name ff, map (metis_of_term env consts) args) + +let metis_of_literal env consts tm = + let (pol, tm') = try (false, dest_neg tm) + with Failure _ -> (true, tm) + in (pol, metis_of_atom env consts tm') + +let metis_of_clause th = + let lconsts = freesl (hyp th) in + let tm = concl th in + let hlits = disjuncts tm in + let flits = map (metis_of_literal [] lconsts) hlits in + let set = Metis_prover.Literal.Set.fromList flits in + Metis_prover.Thm.axiom set + +let metis_of_clauses = map metis_of_clause + +end + + +(* ========================================================================= *) +(* Main Metis module. *) +(* ========================================================================= *) + +module Metis = struct (* ------------------------------------------------------------------------- *) (* Some parameters controlling Metis behaviour. *) @@ -311,18 +10240,20 @@ let split_limit = ref 0;; (* Limit of case splits before Metis proper *) (* ----------------------------------------------------------------------- *) (* Debugging tactic. *) -let PRINT_TAC g = print_goal g; ALL_TAC g;; -let PRINT_ID_TAC s g = print_endline s; PRINT_TAC g;; +let PRINT_TAC g = print_goal g; ALL_TAC g +let PRINT_ID_TAC s g = print_endline s; PRINT_TAC g (* Slightly modified tactic from meson.ml. *) let FOL_PREPARE_TAC ths = (* We start with a single goal: P. *) + REFUTE_THEN ASSUME_TAC THEN (*PRINT_ID_TAC "refuted" THEN*) (* 0 [`~P`] `F` *) + Meson.POLY_ASSUME_TAC (map GEN_ALL ths) THEN (*PRINT_ID_TAC "poly_assumed" THEN*) (* 0 [`~P`] @@ -332,42 +10263,56 @@ let FOL_PREPARE_TAC ths = `F` *) + W(MAP_EVERY(UNDISCH_TAC o concl o snd) o fst) THEN (* `~P ==> th1 ==> ... ==> thn ==> F` *) + SELECT_ELIM_TAC THEN (* eliminate "select terms", e.g. Hilbert operators *) + W(fun (asl,w) -> MAP_EVERY (fun v -> SPEC_TAC(v,v)) (frees w)) THEN (*PRINT_ID_TAC "all-quantified" THEN*) (* MAP_EVERY is mapM for tactics I believe that this all-quantifies all free variables in the goal *) + CONV_TAC(PRESIMP_CONV THENC TOP_DEPTH_CONV BETA_CONV THENC LAMBDA_ELIM_CONV THENC CONDS_CELIM_CONV THENC Meson.QUANT_BOOL_CONV) THEN (*PRINT_ID_TAC "converted" THEN*) + REPEAT(GEN_TAC ORELSE DISCH_TAC) THEN (* remove outermost all-quantifiers (GEN_TAC) and implications (DISCH_TAC), moving them into assumptions *) + REFUTE_THEN ASSUME_TAC THEN (* move conclusion negated into assumptions, replace goal by `F`*) + RULE_ASSUM_TAC(CONV_RULE(NNF_CONV THENC SKOLEM_CONV)) THEN (* transform assumptions to NNF and skolemize *) + REPEAT (FIRST_X_ASSUM CHOOSE_TAC) THEN (* remove existentials at the front *) + ASM_FOL_TAC THEN (* fix function arities, e.g. f(x) and f(x,y) become I f x and I (I f x) y *) + Meson.SPLIT_TAC (!split_limit) THEN RULE_ASSUM_TAC(CONV_RULE(PRENEX_CONV THENC WEAK_CNF_CONV)) THEN + RULE_ASSUM_TAC(repeat (fun th -> SPEC(genvar(type_of(fst(dest_forall(concl th))))) th)) THEN (* destroy all-quantifiers and replace quantified variables by fresh ones *) + REPEAT (FIRST_X_ASSUM (Meson.CONJUNCTS_THEN' ASSUME_TAC)) THEN (* make every conjunction a separate assumption *) + RULE_ASSUM_TAC(CONV_RULE(ASSOC_CONV DISJ_ASSOC)) (* associate disjunctions to the right *) + (*THEN PRINT_ID_TAC "before Metis"*) -;; + let without_warnings f = let tiv = !type_invention_warning in @@ -375,7 +10320,7 @@ let without_warnings f = type_invention_warning := false; try let y = f () in reset (); y with e -> (reset(); raise e) -;; + let SIMPLE_METIS_REFUTE ths = Meson.clear_contrapos_cache(); @@ -383,30 +10328,33 @@ let SIMPLE_METIS_REFUTE ths = we should make that deterministic for proof reconstruction! *) Random.init 0; let rules = Metis_generate.metis_of_clauses ths in +(* if !metisverb then begin - print_string "Original ths:\n"; - List.app (print_endline o string_of_thm) ths + Format.printf "Original ths:\n%!"; + List.iter (Format.printf "%s\n%!" o string_of_thm) ths end; - let res = Loop.run rules in - if !metisverb then Thm.print_proof res; +*) + let res = Metis_prover.Loop.run rules in + (* if !metisverb then Metis_prover.Thm.print_proof res; *) let ths = map (CONV_RULE DISJ_CANON_CONV) ths in let proof = without_warnings (fun () -> Metis_reconstruct2.hol_of_thm ths res) in +(* if !metisverb then begin - print_string "ths:\n"; - List.app (fun t -> print_thm t; print_string "\n") ths; - print_string "Metis theorem:\n"; + Format.printf "ths:\n%!"; + List.iter (fun t -> print_thm t; Format.printf "\n%!") ths; + Format.printf "Metis theorem:\n%!"; print_thm proof; - print_string "Metis end.\n" + Format.printf "Metis end.\n%!"; end; +*) let allhyps = List.concat (List.map hyp ths) in - if not (forall (fun h -> mem h allhyps) (hyp proof)) then - raise (Assert "(forall (fun h -> mem h allhyps) (hyp proof))"); - if not (concl proof = `F`) then - raise (Assert "(concl proof = `F`)"); +(* + assert (forall (fun h -> List.mem h allhyps) (hyp proof)); + assert (concl proof = `F`); +*) proof -;; let PURE_METIS_TAC g = Meson.reset_vars(); Meson.reset_consts(); @@ -416,17 +10364,9 @@ let PURE_METIS_TAC g = let GEN_METIS_TAC ths = FOL_PREPARE_TAC ths THEN PURE_METIS_TAC -end (* struct Metis *) +end ;; -let pp_exn e = - match e with - | Metis.Assert m -> - Pretty_printer.token ("Metis.Assert (" ^ m ^ ")") - | Metis.Error m -> Pretty_printer.token ("Metis.Error (" ^ m ^ ")") - | Metis.Bug m -> Pretty_printer.token ("Metis.Bug (" ^ m ^ ")") - | _ -> pp_exn e;; - (* ========================================================================= *) (* Basic Metis refutation procedure and parametrized tactic. *) (* ========================================================================= *) @@ -436,4 +10376,3 @@ let ASM_METIS_TAC = Metis.GEN_METIS_TAC;; let METIS_TAC ths = POP_ASSUM_LIST(K ALL_TAC) THEN ASM_METIS_TAC ths;; let METIS ths tm = prove(tm,METIS_TAC ths);; - diff --git a/metis/active.ml b/metis/active.ml deleted file mode 100644 index 2dc6163b..00000000 --- a/metis/active.ml +++ /dev/null @@ -1,439 +0,0 @@ -(* ========================================================================= *) -(* THE ACTIVE SET OF CLAUSES *) -(* ========================================================================= *) - -module Active = struct - -(* ------------------------------------------------------------------------- *) -(* A type of active clause sets. *) -(* ------------------------------------------------------------------------- *) - -type simplify = Simplify of { - subsumes : bool; - reduce : bool; - rewrites : bool -};; - -type parameters = Parameters of { - clause : Clause.parameters; - prefactor : simplify; - postfactor : simplify -};; - -type active = Active of { - parameters : parameters; - clauses : (int, Clause.clause) Mmap.map; - units : Units.units; - rewrite : Rewrite.rewrite; - subsume : Clause.clause Subsume.subsume; - literals : (Clause.clause * Literal.literal) Literal_net.literalNet; - equations : - (Clause.clause * Literal.literal * Rewrite.orient * Term.term) - Term_net.termNet; - subterms : - (Clause.clause * Literal.literal * Term.path * Term.term) - Term_net.termNet; - allSubterms : (Clause.clause * Term.term) Term_net.termNet -};; - -let getSubsume (Active {subsume}) = subsume;; - -let setRewrite active rewrite = - Active {active with rewrite = rewrite};; - -(* ------------------------------------------------------------------------- *) -(* Basic operations. *) -(* ------------------------------------------------------------------------- *) - -let maxSimplify = Simplify { - subsumes = true; - reduce = true; - rewrites = true -};; - -let default = Parameters { - clause = Clause.default; - prefactor = maxSimplify; - postfactor = maxSimplify -};; - -let empty parameters = - let clause = parameters.Parameters.clause in - let ordering = clause.Clause.Parameters.ordering in - Active { - parameters = parameters; - clauses = Intmap.newMap (); - units = Units.empty; - rewrite = Rewrite.newRewrite (Knuth_bendix_order.compare ordering); - subsume = Subsume.newSubsume (); - literals = Literal_net.newNet false; - equations = Term_net.newNet false; - subterms = Term_net.newNet false; - allSubterms = Term_net.newNet false - };; - -let size (Active {clauses}) = Intmap.size clauses;; - -let clauses (Active {clauses}) = - let add (_,cl,acc) = cl::acc in - Intmap.foldr add [] clauses -;; - -let saturation active = - let remove cl (cls,subs) = - let lits = Clause.literals cl in - if Subsume.isStrictlySubsumed subs lits then - (cls,subs) - else - (cl::cls, Subsume.insert subs (lits, ())) in - let cls = clauses active in - let (cls,_) = List.foldl remove ([], Subsume.newSubsume ()) cls in - let (cls,subs) = List.foldl remove ([], Subsume.newSubsume ()) cls in - cls - ;; - -(* ------------------------------------------------------------------------- *) -(* Pretty printing. *) -(* ------------------------------------------------------------------------- *) - -let toString active = "Active{" ^ string_of_int (size active) ^ "}";; - -(* ------------------------------------------------------------------------- *) -(* Simplify clauses. *) -(* ------------------------------------------------------------------------- *) - -let simplify simp units rewr subs = - let Simplify {subsumes; reduce; rewrites} = simp in - let rewrite cl = - let cl' = Clause.rewrite rewr cl in - if Clause.equalThms cl cl' then - Some cl - else - Clause.simplify cl' in - fun cl -> - match Clause.simplify cl with - | None -> None - | Some cl -> - match (if rewrites then rewrite cl else Some cl) with - | None -> None - | Some cl -> - let cl = if reduce then Clause.reduce units cl else cl in - if subsumes && Clause.subsumes subs cl then None else Some cl -;; - -let simplifyActive simp (Active {units; rewrite; subsume}) = - simplify simp units rewrite subsume -;; - -(* ------------------------------------------------------------------------- *) -(* Add a clause into the active set. *) -(* ------------------------------------------------------------------------- *) - -let addUnit units cl = - let th = cl.Clause.Clause.thm in - match total Thm.destUnit th with - | Some lit -> Units.add units (lit,th) - | None -> units -;; - -let addRewrite rewrite cl = - let th = cl.Clause.Clause.thm in - match total Thm.destUnitEq th with - | Some l_r -> Rewrite.add rewrite (cl.Clause.Clause.id, (l_r,th)) - | None -> rewrite -;; - -let addSubsume subsume cl = Subsume.insert subsume (Clause.literals cl, cl);; - -let addLiterals literals cl = - let add ((_,atm) as lit, literals) = - if Atom.isEq atm then - literals - else - Literal_net.insert literals (lit,(cl,lit)) in - Literal.Set.foldl add literals (Clause.largestLiterals cl) -;; - -let addEquations equations cl = - let add (lit,ort,tm) equations = - Term_net.insert equations (tm,(cl,lit,ort,tm)) in - List.foldl add equations (Clause.largestEquations cl) -;; - -let addSubterms subterms cl = - let add (lit,path,tm) subterms = - Term_net.insert subterms (tm,(cl,lit,path,tm)) in - List.foldl add subterms (Clause.largestSubterms cl) -;; - -let addAllSubterms allSubterms cl = - let add (_,_,tm) allSubterms = Term_net.insert allSubterms (tm,(cl,tm)) in - List.foldl add allSubterms (Clause.allSubterms cl) -;; - -let addClause active cl = - let Active {clauses; subsume; literals; equations; subterms; - allSubterms} = active in - let clauses = Intmap.insert clauses (cl.Clause.Clause.id, cl) - and subsume = addSubsume subsume cl - and literals = addLiterals literals cl - and equations = addEquations equations cl - and subterms = addSubterms subterms cl - and allSubterms = addAllSubterms allSubterms cl in - Active {active with clauses = clauses; subsume = subsume; - literals = literals; equations = equations; - subterms = subterms; allSubterms = allSubterms} -;; - -let addFactorClause active cl = - let Active {units; rewrite} = active in - let units = addUnit units cl - and rewrite = addRewrite rewrite cl in - Active {active with units = units; rewrite = rewrite} -;; - -(* ------------------------------------------------------------------------- *) -(* Derive (unfactored) consequences of a clause. *) -(* ------------------------------------------------------------------------- *) - -let deduceResolution literals cl ((_,atm) as lit, acc) = - let resolve cl_lit acc = - match total (Clause.resolve cl_lit) (cl,lit) with - | Some cl' -> cl' :: acc - | None -> acc in - if Atom.isEq atm then - acc - else - List.foldl resolve acc (Literal_net.unify literals (Literal.negate lit)) -;; - -let deduceParamodulationWith subterms cl ((lit,ort,tm),acc) = - let para cl_lit_path_tm acc = - match total (Clause.paramodulate (cl,lit,ort,tm)) cl_lit_path_tm with - Some cl' -> cl' :: acc - | None -> acc in - List.foldl para acc (Term_net.unify subterms tm) -;; - -let deduceParamodulationInto equations cl ((lit,path,tm),acc) = - let para cl_lit_ort_tm acc = - match total (Clause.paramodulate cl_lit_ort_tm) (cl,lit,path,tm) with - | Some cl' -> cl' :: acc - | None -> acc in - List.foldl para acc (Term_net.unify equations tm) -;; - -let deduce active cl = - let Active {literals;equations;subterms} = active in - let lits = Clause.largestLiterals cl in - let eqns = Clause.largestEquations cl in - let subtms = - if Term_net.null equations then [] else Clause.largestSubterms cl in - let acc = [] in - let acc = Literal.Set.foldl (deduceResolution literals cl) acc lits in - let acc = - List.foldl (curry (deduceParamodulationWith subterms cl)) acc eqns in - let acc = - List.foldl (curry (deduceParamodulationInto equations cl)) acc subtms in - let acc = List.rev acc in - acc -;; - -(* ------------------------------------------------------------------------- *) -(* Extract clauses from the active set that can be simplified. *) -(* ------------------------------------------------------------------------- *) - -let clause_rewritables active = - let Active {clauses; rewrite} = active in - let rewr (id,cl,ids) = - let cl' = Clause.rewrite rewrite cl in - if Clause.equalThms cl cl' then ids else Intset.add ids id in - Intmap.foldr rewr Intset.empty clauses -;; - -let orderedRedexResidues (((l,r),_),ort) = - match ort with - None -> [] - | Some (Rewrite.Left_to_right) -> [(l,r,true)] - | Some (Rewrite.Right_to_left) -> [(r,l,true)] -;; - -let unorderedRedexResidues (((l,r),_),ort) = - match ort with - None -> [(l,r,false);(r,l,false)] - | Some _ -> [] -;; - -let rewrite_rewritables active rewr_ids = - let Active {parameters;rewrite;clauses;allSubterms} = active in - let Parameters {clause} = parameters in - let Clause.Parameters {ordering} = clause in - let order = Knuth_bendix_order.compare ordering in - let addRewr (id,acc) = - if Intmap.inDomain id clauses then Intset.add acc id else acc in - let addReduce ((l,r,ord),acc) = - let isValidRewr tm = - match total (Substitute.matchTerms Substitute.empty l) tm with - | None -> false - | Some sub -> - ord || let tm' = Substitute.subst (Substitute.normalize sub) r in - order (tm,tm') = Some Greater in - let addRed ((cl,tm),acc) = - let id = cl.Clause.Clause.id in - if Intset.member id acc then acc - else if not (isValidRewr tm) then acc - else Intset.add acc id in - List.foldl (curry addRed) acc (Term_net.matched allSubterms l) in - let addEquation redexResidues (id,acc) = - match Rewrite.peek rewrite id with - | None -> acc - | Some eqn_ort -> - List.foldl (curry addReduce) acc (redexResidues eqn_ort) in - let addOrdered = addEquation orderedRedexResidues in - let addUnordered = addEquation unorderedRedexResidues in - let ids = Intset.empty in - let ids = List.foldl (curry addRewr) ids rewr_ids in - let ids = List.foldl (curry addOrdered) ids rewr_ids in - let ids = List.foldl (curry addUnordered) ids rewr_ids in - ids -;; - -let choose_clause_rewritables active ids = size active <= length ids - let rewritables active ids = - if choose_clause_rewritables active ids then clause_rewritables active - else rewrite_rewritables active ids -;; - -let delete active ids = - if Intset.null ids then active else - let idPred id = not (Intset.member id ids) in - let clausePred cl = idPred cl.Clause.Clause.id in - let Active {clauses; subsume; literals; equations; subterms; allSubterms} = - active in - let clauses = Intmap.filter (fun x -> idPred (fst x)) clauses - and subsume = Subsume.filter clausePred subsume - and literals = Literal_net.filter (fun (x,_) -> clausePred x) literals - and equations = Term_net.filter (fun (x,_,_,_) -> clausePred x) equations - and subterms = Term_net.filter (fun (x,_,_,_) -> clausePred x) subterms - and allSubterms = Term_net.filter (fun (x,_) -> clausePred x) allSubterms in - Active {active with clauses = clauses; subsume = subsume; - literals = literals; equations = equations; - subterms = subterms; allSubterms = allSubterms} -;; - -let extract_rewritables active = - let Active {clauses; rewrite} = active in - if Rewrite.isReduced rewrite then (active,[]) else - let (rewrite,ids) = Rewrite.reduce' rewrite in - let active = setRewrite active rewrite in - let ids = rewritables active ids in - let cls = Intset.transform (Intmap.get clauses) ids in - (delete active ids, cls) -;; - -(* ------------------------------------------------------------------------- *) -(* Factor clauses. *) -(* ------------------------------------------------------------------------- *) - -let prefactor_simplify active subsume = - let Active {parameters; units; rewrite} = active in - let Parameters {prefactor} = parameters in - simplify prefactor units rewrite subsume -;; - -let postfactor_simplify active subsume = - let Active {parameters; units; rewrite} = active in - let Parameters {postfactor} = parameters in - simplify postfactor units rewrite subsume -;; - -let sort_utilitywise = - let utility cl = - match Literal.Set.size (Clause.literals cl) with - | 0 -> -1 - | 1 -> if Thm.isUnitEq cl.Clause.Clause.thm then 0 else 1 - | n -> n in - sortMap utility Int.compare -;; - -let rec post_factor (cl, ((active,subsume,acc) as active_subsume_acc)) = - match postfactor_simplify active subsume cl with - | None -> active_subsume_acc - | Some cl' -> - if Clause.equalThms cl' cl then - let active = addFactorClause active cl - and subsume = addSubsume subsume cl - and acc = cl::acc in - (active,subsume,acc) - else - (* If the clause was changed in the post-factor simplification *) - (* step, then it may have altered the set of largest literals *) - (* in the clause. The safest thing to do is to factor again. *) - factor1 (cl', active_subsume_acc) -and factor1 (cl, active_subsume_acc) = - let cls = sort_utilitywise (cl::Clause.factor cl) in - List.foldl (curry post_factor) active_subsume_acc cls -;; - -let pre_factor (cl, ((active,subsume,_) as active_subsume_acc)) = - match prefactor_simplify active subsume cl with - | None -> active_subsume_acc - | Some cl -> factor1 (cl, active_subsume_acc) -;; - -let rec factor' active acc = - function - | [] -> (active, List.rev acc) - | cls -> - let cls = sort_utilitywise cls in - let subsume = getSubsume active in - let (active,_,acc) = - List.foldl (curry pre_factor) (active,subsume,acc) cls in - let (active,cls) = extract_rewritables active in - factor' active acc cls -;; - -let factor active cls = factor' active [] cls;; - -(* ------------------------------------------------------------------------- *) -(* Create a new active clause set and initialize clauses. *) -(* ------------------------------------------------------------------------- *) - -let mk_clause params th : Clause.clause = - Clause.Clause { - parameters = params; - id = Clause.newId (); - thm = th - };; - -let newActive parameters (Ax_cj.Ax_cj_thm {axioms_thm; conjecture_thm}) = - let Parameters {clause} = parameters in - let mk_clause = mk_clause clause in - let active = empty parameters in - let (active,axioms) = factor active (List.map mk_clause axioms_thm) in - let (active,conjecture) = factor active (List.map mk_clause conjecture_thm) in - (active, Ax_cj.Ax_cj_cl {axioms_cl = axioms; conjecture_cl = conjecture}) -;; - -(* ------------------------------------------------------------------------- *) -(* Add a clause into the active set and deduce all consequences. *) -(* ------------------------------------------------------------------------- *) - -let add active cl = - match simplifyActive maxSimplify active cl with - | None -> (active,[]) - | Some cl' -> - if Clause.isContradiction cl' then - (active,[cl']) - else if not (Clause.equalThms cl cl') then - factor active [cl'] - else - let active = addClause active cl in - let cl = Clause.freshVars cl in - let cls = deduce active cl in - let (active,cls) = factor active cls in - (active,cls) -;; - -end (* struct Active *) -;; diff --git a/metis/atom.ml b/metis/atom.ml deleted file mode 100644 index a58b51a6..00000000 --- a/metis/atom.ml +++ /dev/null @@ -1,235 +0,0 @@ -(* ========================================================================= *) -(* FIRST ORDER LOGIC ATOMS *) -(* ========================================================================= *) - -module Atom = struct - -(* ------------------------------------------------------------------------- *) -(* A type for storing first order logic atoms. *) -(* ------------------------------------------------------------------------- *) - -type relationName = Name.name;; - -type relation = relationName * int;; - -type atom = relationName * Term.term list;; - -(* ------------------------------------------------------------------------- *) -(* Constructors and destructors. *) -(* ------------------------------------------------------------------------- *) - -let name ((rel,_) : atom) = rel;; - -let arguments ((_,args) : atom) = args;; - -let arity atm = length (arguments atm);; - -let relation atm = (name atm, arity atm);; - -let functions = - let f tm acc = Name_arity.Set.union (Term.functions tm) acc in - fun atm -> List.foldl f Name_arity.Set.empty (arguments atm) -;; - -let functionNames = - let f tm acc = Name.Set.union (Term.functionNames tm) acc in - fun atm -> List.foldl f Name.Set.empty (arguments atm) -;; - -(* Binary relations *) - -let mkBinop p (a,b) : atom = (p,[a;b]) -;; - -let destBinop p = - function - | (x,[a;b]) -> if Name.equal x p then (a,b) - else raise (Error "Atom.destBinop: wrong binop") - | _ -> raise (Error "Atom.destBinop: not a binop");; - -let isBinop p = can (destBinop p) -;; - -(* ------------------------------------------------------------------------- *) -(* The size of an atom in symbols. *) -(* ------------------------------------------------------------------------- *) - -let symbols atm = - List.foldl (fun tm z -> Term.symbols tm + z) 1 (arguments atm) -;; - -(* ------------------------------------------------------------------------- *) -(* A total comparison function for atoms. *) -(* ------------------------------------------------------------------------- *) - -let compare (p1,tms1) (p2,tms2) = - match Name.compare p1 p2 with - | Less -> Less - | Equal -> lexCompare Term.compare tms1 tms2 - | Greater -> Greater -;; - -let equal atm1 atm2 = compare atm1 atm2 = Equal -;; - -(* ------------------------------------------------------------------------- *) -(* Subterms. *) -(* ------------------------------------------------------------------------- *) - -let subterm x y = - match x, y with - | (_, []) -> raise (Bug "Atom.subterm: empty path") - | ((_,tms), h :: t) -> - if h >= length tms then raise (Error "Atom.subterm: bad path") - else Term.subterm (List.nth tms h) t;; - -let subterms ((_,tms) : atom) = - let f (n,tm) l = - List.map (fun (p,s) -> (n :: p, s)) (Term.subterms tm) @ l in - List.foldl f [] (enumerate tms) -;; - -let replace ((rel,tms) as atm) = - function - | ([],_) -> raise (Bug "Atom.replace: empty path") - | (h :: t, res) -> - if h >= length tms then - raise (Error "Atom.replace: bad path") - else - let tm = List.nth tms h in - let tm' = Term.replace tm (t,res) in - if Portable.pointerEqual (tm,tm') then - atm - else (rel, updateNth (h,tm') tms) -;; - -let find pred = - let f (i,tm) = - match Term.find pred tm with - | Some path -> Some (i :: path) - | None -> None in - fun (_,tms) -> first f (enumerate tms) -;; - -(* ------------------------------------------------------------------------- *) -(* Free variables. *) -(* ------------------------------------------------------------------------- *) - -let freeIn v atm = List.exists (Term.freeIn v) (arguments atm);; - -let freeVars = - let f tm acc = Name.Set.union (Term.freeVars tm) acc in - fun atm -> List.foldl f Name.Set.empty (arguments atm) -;; - -(* ------------------------------------------------------------------------- *) -(* Substitutions. *) -(* ------------------------------------------------------------------------- *) - -let subst sub ((p,tms) as atm) : atom = - let tms' = Sharing.map (Substitute.subst sub) tms in - if Portable.pointerEqual (tms',tms) then atm else (p,tms') -;; - -(* ------------------------------------------------------------------------- *) -(* Matching. *) -(* ------------------------------------------------------------------------- *) - -let matchAtoms sub (p1,tms1) (p2,tms2) = - let matchArg (tm1,tm2) sub = Substitute.matchTerms sub tm1 tm2 in - let _ = (Name.equal p1 p2 && length tms1 = length tms2) || - raise (Error "Atom.match") in - List.foldl matchArg sub (zip tms1 tms2) -;; - -(* ------------------------------------------------------------------------- *) -(* Unification. *) -(* ------------------------------------------------------------------------- *) - -let unify sub (p1,tms1) (p2,tms2) = - let unifyArg (tm1,tm2) sub = Substitute.unify sub tm1 tm2 in - let _ = (Name.equal p1 p2 && length tms1 = length tms2) || - raise (Error "Atom.unify") in - List.foldl unifyArg sub (zip tms1 tms2) -;; - -(* ------------------------------------------------------------------------- *) -(* The equality relation. *) -(* ------------------------------------------------------------------------- *) - -let eqRelationName = Name.fromString "=";; - -let eqRelationArity = 2;; - -let eqRelation = (eqRelationName,eqRelationArity);; - -let mkEq = mkBinop eqRelationName;; - -let destEq x = destBinop eqRelationName x;; - -let isEq x = isBinop eqRelationName x;; - -let mkRefl tm = mkEq (tm,tm);; - -let destRefl atm = - let (l,r) = destEq atm in - let _ = Term.equal l r || raise (Error "Atom.destRefl") in - l -;; - -let isRefl x = can destRefl x;; - -let sym atm = - let (l,r) = destEq atm in - let _ = not (Term.equal l r) || raise (Error "Atom.sym: refl") in - mkEq (r,l) -;; - -let lhs atm = fst (destEq atm);; - -let rhs atm = snd (destEq atm);; - -(* ------------------------------------------------------------------------- *) -(* Special support for terms with type annotations. *) -(* ------------------------------------------------------------------------- *) - -let typedSymbols ((_,tms) : atom) = - List.foldl (fun tm z -> Term.typedSymbols tm + z) 1 tms;; - -let nonVarTypedSubterms (_,tms) = - let addArg (n,arg) acc = - let addTm (path,tm) acc = (n :: path, tm) :: acc in - List.foldl addTm acc (Term.nonVarTypedSubterms arg) in - List.foldl addArg [] (enumerate tms) -;; - -module Map = struct -let newMap () = Mmap.newMap compare ();; -let singleton kv = Mmap.singleton compare kv;; -let fromList xs = Mmap.fromList compare xs;; -let mapPartial f m = Mmap.mapPartial compare f m;; -let null = Mmap.null and size = Mmap.size and get = Mmap.get -and peek = Mmap.peek and insert = Mmap.insert and toList = Mmap.toList -and foldl = Mmap.foldl and foldr = Mmap.foldr and filter = Mmap.filter -and inDomain = Mmap.inDomain and union = Mmap.union and delete = Mmap.delete -and transform = Mmap.transform and exists = Mmap.exists;; -end (* struct Map *) -;; - -module Set = struct -let empty : atom Mset.set = Mset.empty compare;; -let singleton k = Mset.singleton compare k;; -let intersect m1 m2 = Mset.intersect compare;; -let intersectList = Mset.intersectList compare;; -let add = Mset.add and foldr = Mset.foldr and foldl = Mset.foldl -and member = Mset.member and union = Mset.union and difference = Mset.difference -and toList = Mset.toList and null = Mset.null and size = Mset.size -and pick = Mset.pick and equal = Mset.equal and exists = Mset.exists -and fromList = Mset.fromList and delete = Mset.delete and subset = Mset.subset -and findl = Mset.findl and firstl = Mset.firstl and transform = Mset.transform -and all = Mset.all and count = Mset.count;; -end (* struct Set *) -;; - -end (* struct Atom *) -;; diff --git a/metis/atom_net.ml b/metis/atom_net.ml deleted file mode 100644 index 2e5be05f..00000000 --- a/metis/atom_net.ml +++ /dev/null @@ -1,57 +0,0 @@ -(* ========================================================================= *) -(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC ATOMS *) -(* ========================================================================= *) - -module Atom_net = struct - -(* ------------------------------------------------------------------------- *) -(* Helper functions. *) -(* ------------------------------------------------------------------------- *) - -let atomToTerm atom = Term.Fn atom;; - -let termToAtom = function - | (Term.Var_ _) -> raise (Bug "Atom_net.termToAtom") - | (Term.Fn atom) -> atom;; - -(* ------------------------------------------------------------------------- *) -(* A type of atom sets that can be efficiently matched and unified. *) -(* ------------------------------------------------------------------------- *) - -type parameters = Term_net.parameters;; - -type 'a atomNet = 'a Term_net.termNet;; - -(* ------------------------------------------------------------------------- *) -(* Basic operations. *) -(* ------------------------------------------------------------------------- *) - -let newNet = Term_net.newNet;; - -let size = Term_net.size;; - -let insert net (atm,a) = Term_net.insert net (atomToTerm atm, a);; - -let fromList parm l = - List.foldl (fun atm_a n -> insert n atm_a) (newNet parm) l;; - -let filter = Term_net.filter;; - -let toString net = "Atom_net[" ^ Int.toString (size net) ^ "]";; - - -(* ------------------------------------------------------------------------- *) -(* Matching and unification queries. *) -(* *) -(* These function return OVER-APPROXIMATIONS! *) -(* Filter afterwards to get the precise set of satisfying values. *) -(* ------------------------------------------------------------------------- *) - -let matchNet net atm = Term_net.matchNet net (atomToTerm atm);; - -let matched net atm = Term_net.matched net (atomToTerm atm);; - -let unify net atm = Term_net.unify net (atomToTerm atm);; - -end (* struct Atom_net *) -;; diff --git a/metis/clause.ml b/metis/clause.ml deleted file mode 100644 index fc12d6b4..00000000 --- a/metis/clause.ml +++ /dev/null @@ -1,247 +0,0 @@ -(* ========================================================================= *) -(* CLAUSE = ID + THEOREM *) -(* ========================================================================= *) - -module Clause = struct - -(* ------------------------------------------------------------------------- *) -(* Helper functions. *) -(* ------------------------------------------------------------------------- *) - -let newId = - let r = ref 0 in - let newI () = - let n = !r in - let () = r := n + 1 in - n in - fun () -> Portable.critical newI () -;; - -(* ------------------------------------------------------------------------- *) -(* A type of clause. *) -(* ------------------------------------------------------------------------- *) - -type literalOrder = - | No_literal_order - | Unsigned_literal_order - | Positive_literal_order;; - -type parameters = Parameters of { - ordering : Knuth_bendix_order.kbo; - orderLiterals : literalOrder; - orderTerms : bool -};; - -type clauseId = int;; - -type clause = Clause of { - parameters : parameters; - id : clauseId; - thm : Thm.thm -};; - -(* ------------------------------------------------------------------------- *) -(* Pretty printing. *) -(* ------------------------------------------------------------------------- *) - -let toString (Clause {thm}) = Thm.toString thm;; - -(* ------------------------------------------------------------------------- *) -(* Basic operations. *) -(* ------------------------------------------------------------------------- *) - -let default = Parameters { - ordering = Knuth_bendix_order.default; - orderLiterals = Positive_literal_order; - orderTerms = true -};; - -let mk p i t = Clause {parameters = p; id = i; thm = t};; - -let equalThms cl cl' = Thm.equal cl.Clause.thm cl'.Clause.thm;; - -let newClause parameters thm = - Clause {parameters = parameters; id = newId (); thm = thm};; - -let literals cl = Thm.clause cl.Clause.thm;; - -let isTautology (Clause {thm}) = Thm.isTautology thm;; - -let isContradiction (Clause {thm}) = Thm.isContradiction thm;; - -(* ------------------------------------------------------------------------- *) -(* The term ordering is used to cut down inferences. *) -(* ------------------------------------------------------------------------- *) - -let strictlyLess ordering x_y = - match Knuth_bendix_order.compare ordering x_y with - | Some (Less) -> true - | _ -> false;; - -let isLargerTerm (Parameters {ordering; orderTerms}) l_r = - not orderTerms || not (strictlyLess ordering l_r) -;; - -let atomToTerms atm = - match total Atom.destEq atm with - | None -> [Term.Fn atm] - | Some (l,r) -> [l;r] -;; - -let notStrictlyLess ordering (xs,ys) = - let less x = List.exists (fun y -> strictlyLess ordering (x,y)) ys in - not (List.all less xs) -;; - -let isLargerLiteral (Parameters {ordering; orderLiterals}) lits = - match orderLiterals with - | No_literal_order -> kComb true - | Unsigned_literal_order -> - let addLit ((_,atm),acc) = atomToTerms atm @ acc in - let tms = Literal.Set.foldl addLit [] lits in - fun (_,atm') -> notStrictlyLess ordering (atomToTerms atm', tms) - | Positive_literal_order -> - match Literal.Set.findl (kComb true) lits with - | None -> kComb true - | Some (pol,_) -> - let addLit ((p,atm),acc) = - if p = pol then atomToTerms atm @ acc else acc in - let tms = Literal.Set.foldl addLit [] lits in - fun (pol',atm') -> - if pol <> pol' then pol - else notStrictlyLess ordering (atomToTerms atm', tms) -;; - -let largestLiterals (Clause {parameters; thm}) = - let litSet = Thm.clause thm in - let isLarger = isLargerLiteral parameters litSet in - let addLit (lit,s) = if isLarger lit then Literal.Set.add s lit else s in - Literal.Set.foldr addLit Literal.Set.empty litSet -;; - -let largestEquations cl = - let Clause {parameters} = cl in - let addEq lit ort ((l,_) as l_r) acc = - if isLargerTerm parameters l_r then (lit,ort,l) :: acc else acc in - let addLit (lit,acc) = - match total Literal.destEq lit with - | None -> acc - | Some (l,r) -> - let acc = addEq lit Rewrite.Right_to_left (r,l) acc in - let acc = addEq lit Rewrite.Left_to_right (l,r) acc in - acc in - Literal.Set.foldr addLit [] (largestLiterals cl) -;; - -let addLit (lit,acc) = - let addTm (path,tm) acc = (lit,path,tm) :: acc in - List.foldl addTm acc (Literal.nonVarTypedSubterms lit) -;; - -let largestSubterms cl = Literal.Set.foldl addLit [] (largestLiterals cl);; - -let allSubterms cl = Literal.Set.foldl addLit [] (literals cl);; - -(* ------------------------------------------------------------------------- *) -(* Subsumption. *) -(* ------------------------------------------------------------------------- *) - -let subsumes (subs : clause Subsume.subsume) cl = - Subsume.isStrictlySubsumed subs (literals cl);; - -(* ------------------------------------------------------------------------- *) -(* Simplifying rules: these preserve the clause id. *) -(* ------------------------------------------------------------------------- *) - -let freshVars clause = - Clause {clause with thm = Rule.freshVars clause.Clause.thm};; - -let simplify clause = - match Rule.simplify clause.Clause.thm with - | None -> None - | Some thm -> Some (Clause {clause with thm = thm}) -;; - -let reduce units clause = - Clause {clause with thm = Units.reduce units clause.Clause.thm};; - -let rewrite rewr (Clause {parameters; id; thm}) = - let simp th = - let Parameters {ordering} = parameters in - let cmp = Knuth_bendix_order.compare ordering in - Rewrite.rewriteIdRule rewr cmp id th in - let thm = - match Rewrite.peek rewr id with - | None -> simp thm - | Some ((_,thm),_) -> if Rewrite.isReduced rewr then thm else simp thm in - let result = Clause {parameters = parameters; id = id; thm = thm} in - result;; - -(* ------------------------------------------------------------------------- *) -(* Inference rules: these generate new clause ids. *) -(* ------------------------------------------------------------------------- *) - -let factor cl = - let Clause {parameters; thm} = cl in - let lits = largestLiterals cl in - let apply sub = newClause parameters (Thm.subst sub thm) in - List.map apply (Rule.factor' lits) -;; - -let resolve (cl1,lit1) (cl2,lit2) = - let parameters = cl1.Clause.parameters - and th1 = cl1.Clause.thm - and th2 = cl2.Clause.thm in - let sub = Literal.unify Substitute.empty lit1 (Literal.negate lit2) in - let lit1 = Literal.subst sub lit1 in let lit2 = Literal.negate lit1 in - let th1 = Thm.subst sub th1 - and th2 = Thm.subst sub th2 in - let _ = isLargerLiteral parameters (Thm.clause th1) lit1 || - raise (Error "resolve: clause1: ordering constraints") in - let _ = isLargerLiteral parameters (Thm.clause th2) lit2 || - raise (Error "resolve: clause2: ordering constraints") in - let th = Thm.resolve lit1 th1 th2 in - let cl = Clause {parameters = parameters; id = newId (); thm = th} in - cl -;; - -let paramodulate (cl1,lit1,ort1,tm1) (cl2,lit2,path2,tm2) = - let parameters = cl1.Clause.parameters - and th1 = cl1.Clause.thm - and th2 = cl2.Clause.thm in - let sub = Substitute.unify Substitute.empty tm1 tm2 in - let lit1 = Literal.subst sub lit1 - and lit2 = Literal.subst sub lit2 - and th1 = Thm.subst sub th1 - and th2 = Thm.subst sub th2 in - let _ = isLargerLiteral parameters (Thm.clause th1) lit1 || - raise (Error "Clause.paramodulate: with clause: ordering") in - let _ = isLargerLiteral parameters (Thm.clause th2) lit2 || - raise (Error "Clause.paramodulate: into clause: ordering") in - let eqn = (Literal.destEq lit1, th1) in - let (l_r,_) as eqn = - match ort1 with - | Rewrite.Left_to_right -> eqn - | Rewrite.Right_to_left -> Rule.symEqn eqn in - let _ = isLargerTerm parameters l_r || - raise (Error "Clause.paramodulate: equation: ordering constraints") in - let th = Rule.rewrRule eqn lit2 path2 th2 in - Clause {parameters = parameters; id = newId (); thm = th} - -end -;; - -module Ax_cj = struct - -type ax_cj_thm = Ax_cj_thm of { - axioms_thm : Thm.thm list; - conjecture_thm : Thm.thm list -};; - -type ax_cj_cl = Ax_cj_cl of { - axioms_cl : Clause.clause list; - conjecture_cl : Clause.clause list -};; - -end -;; diff --git a/metis/formula.ml b/metis/formula.ml deleted file mode 100644 index 7a2042bb..00000000 --- a/metis/formula.ml +++ /dev/null @@ -1,550 +0,0 @@ -(* ========================================================================= *) -(* FIRST ORDER LOGIC FORMULAS *) -(* ========================================================================= *) - -module Formula = struct - -(* ------------------------------------------------------------------------- *) -(* A type of first order logic formulas. *) -(* ------------------------------------------------------------------------- *) - -type formula = - | True_ - | False_ - | Atom of Atom.atom - | Not of formula - | And of formula * formula - | Or of formula * formula - | Imp of formula * formula - | Iff of formula * formula - | Forall of Term.var * formula - | Exists of Term.var * formula;; - -(* ------------------------------------------------------------------------- *) -(* Constructors and destructors. *) -(* ------------------------------------------------------------------------- *) - -(* Booleans *) - -let mkBoolean = function - | true -> True_ - | false -> False_;; - -let destBoolean = function - | True_ -> true - | False_ -> false - | _ -> raise (Error "destBoolean");; - -let isBoolean = can destBoolean;; - -let isTrue fm = - match fm with - | True_ -> true - | _ -> false;; - -let isFalse fm = - match fm with - | False_ -> true - | _ -> false;; - -(* Functions *) - -let functions fm = - let rec funcs fs = function - | [] -> fs - | (True_ :: fms) -> funcs fs fms - | (False_ :: fms) -> funcs fs fms - | (Atom atm :: fms) -> - funcs (Name_arity.Set.union (Atom.functions atm) fs) fms - | (Not p :: fms) -> funcs fs (p :: fms) - | (And (p,q) :: fms) -> funcs fs (p :: q :: fms) - | (Or (p,q) :: fms) -> funcs fs (p :: q :: fms) - | (Imp (p,q) :: fms) -> funcs fs (p :: q :: fms) - | (Iff (p,q) :: fms) -> funcs fs (p :: q :: fms) - | (Forall (_,p) :: fms) -> funcs fs (p :: fms) - | (Exists (_,p) :: fms) -> funcs fs (p :: fms) in - funcs Name_arity.Set.empty [fm];; - -let functionNames fm = - let rec funcs fs = function - | [] -> fs - | (True_ :: fms) -> funcs fs fms - | (False_ :: fms) -> funcs fs fms - | (Atom atm :: fms) -> - funcs (Name.Set.union (Atom.functionNames atm) fs) fms - | (Not p :: fms) -> funcs fs (p :: fms) - | (And (p,q) :: fms) -> funcs fs (p :: q :: fms) - | (Or (p,q) :: fms) -> funcs fs (p :: q :: fms) - | (Imp (p,q) :: fms) -> funcs fs (p :: q :: fms) - | (Iff (p,q) :: fms) -> funcs fs (p :: q :: fms) - | (Forall (_,p) :: fms) -> funcs fs (p :: fms) - | (Exists (_,p) :: fms) -> funcs fs (p :: fms) in - funcs Name.Set.empty [fm];; - -(* Relations *) -let relations fm = - let rec rels fs = function - | [] -> fs - | (True_ :: fms) -> rels fs fms - | (False_ :: fms) -> rels fs fms - | (Atom atm :: fms) -> - rels (Name_arity.Set.add fs (Atom.relation atm)) fms - | (Not p :: fms) -> rels fs (p :: fms) - | (And (p,q) :: fms) -> rels fs (p :: q :: fms) - | (Or (p,q) :: fms) -> rels fs (p :: q :: fms) - | (Imp (p,q) :: fms) -> rels fs (p :: q :: fms) - | (Iff (p,q) :: fms) -> rels fs (p :: q :: fms) - | (Forall (_,p) :: fms) -> rels fs (p :: fms) - | (Exists (_,p) :: fms) -> rels fs (p :: fms) in - rels Name_arity.Set.empty [fm];; - -let relationNames fm = - let rec rels fs = function - | [] -> fs - | (True_ :: fms) -> rels fs fms - | (False_ :: fms) -> rels fs fms - | (Atom atm :: fms) -> rels (Name.Set.add fs (Atom.name atm)) fms - | (Not p :: fms) -> rels fs (p :: fms) - | (And (p,q) :: fms) -> rels fs (p :: q :: fms) - | (Or (p,q) :: fms) -> rels fs (p :: q :: fms) - | (Imp (p,q) :: fms) -> rels fs (p :: q :: fms) - | (Iff (p,q) :: fms) -> rels fs (p :: q :: fms) - | (Forall (_,p) :: fms) -> rels fs (p :: fms) - | (Exists (_,p) :: fms) -> rels fs (p :: fms) in - rels Name.Set.empty [fm];; - -(* Atoms *) - -let destAtom = function - | Atom atm -> atm - | _ -> raise (Error "Formula.destAtom");; - -let isAtom = can destAtom;; - -(* Negations *) - -let destNeg = function - | Not p -> p - | _ -> raise (Error "Formula.destNeg");; - -let isNeg = can destNeg;; - -let stripNeg = - let rec strip n = function - | (Not fm) -> strip (n + 1) fm - | fm -> (n,fm) in - strip 0 -;; - -(* Conjunctions *) - -let listMkConj fms = - match List.rev fms with - | [] -> True_ - | fm :: fms -> List.foldl (fun x y -> And (x, y)) fm fms;; - -let stripConj = - let rec strip cs = function - | (And (p,q)) -> strip (p :: cs) q - | fm -> List.rev (fm :: cs) in - function - | True_ -> [] - | fm -> strip [] fm;; - -let flattenConj = - let rec flat acc = function - | [] -> acc - | (And (p,q) :: fms) -> flat acc (q :: p :: fms) - | (True_ :: fms) -> flat acc fms - | (fm :: fms) -> flat (fm :: acc) fms in - fun fm -> flat [] [fm] -;; - -(* Disjunctions *) - -let listMkDisj fms = - match List.rev fms with - | [] -> False_ - | fm :: fms -> List.foldl (fun x y -> Or (x,y)) fm fms;; - -let stripDisj = - let rec strip cs = function - | (Or (p,q)) -> strip (p :: cs) q - | fm -> List.rev (fm :: cs) in - function - | False_ -> [] - | fm -> strip [] fm;; - -let flattenDisj = - let rec flat acc = function - | [] -> acc - | (Or (p,q) :: fms) -> flat acc (q :: p :: fms) - | (False_ :: fms) -> flat acc fms - | (fm :: fms) -> flat (fm :: acc) fms in - fun fm -> flat [] [fm] -;; - -(* Equivalences *) - -let listMkEquiv fms = - match List.rev fms with - | [] -> True_ - | fm :: fms -> List.foldl (fun x y -> Iff (x,y)) fm fms;; - -let stripEquiv = - let rec strip cs = function - | (Iff (p,q)) -> strip (p :: cs) q - | fm -> List.rev (fm :: cs) in - function - | True_ -> [] - | fm -> strip [] fm;; - -let flattenEquiv = - let rec flat acc = function - | [] -> acc - | (Iff (p,q) :: fms) -> flat acc (q :: p :: fms) - | (True_ :: fms) -> flat acc fms - | (fm :: fms) -> flat (fm :: acc) fms in - fun fm -> flat [] [fm] -;; - -(* Universal quantifiers *) - -let destForall = function - | (Forall (v,f)) -> (v,f) - | _ -> raise (Error "destForall");; - -let isForall = can destForall;; - -let rec listMkForall = function - | ([],body) -> body - | (v :: vs, body) -> Forall (v, listMkForall (vs,body));; - -let setMkForall (vs,body) = Name.Set.foldr (fun (x,y) -> Forall (x,y)) body vs;; - -let stripForall = - let rec strip vs = function - | (Forall (v,b)) -> strip (v :: vs) b - | tm -> (List.rev vs, tm) in - strip [];; - -(* Existential quantifiers *) - -let destExists = function - | (Exists (v,f)) -> (v,f) - | _ -> raise (Error "destExists");; - -let isExists = can destExists;; - -let rec listMkExists = function - | ([],body) -> body - | (v :: vs, body) -> Exists (v, listMkExists (vs,body));; - -let setMkExists (vs,body) = Name.Set.foldr (fun (x,y) -> Exists (x,y)) body vs;; - -let stripExists = - let rec strip vs = function - | (Exists (v,b)) -> strip (v :: vs) b - | tm -> (List.rev vs, tm) in - strip [];; - -(* ------------------------------------------------------------------------- *) -(* The size of a formula in symbols. *) -(* ------------------------------------------------------------------------- *) - -let symbols fm = - let rec sz n = function - | [] -> n - | (True_ :: fms) -> sz (n + 1) fms - | (False_ :: fms) -> sz (n + 1) fms - | (Atom atm :: fms) -> sz (n + Atom.symbols atm) fms - | (Not p :: fms) -> sz (n + 1) (p :: fms) - | (And (p,q) :: fms) -> sz (n + 1) (p :: q :: fms) - | (Or (p,q) :: fms) -> sz (n + 1) (p :: q :: fms) - | (Imp (p,q) :: fms) -> sz (n + 1) (p :: q :: fms) - | (Iff (p,q) :: fms) -> sz (n + 1) (p :: q :: fms) - | (Forall (_,p) :: fms) -> sz (n + 1) (p :: fms) - | (Exists (_,p) :: fms) -> sz (n + 1) (p :: fms) in - sz 0 [fm];; - -(* ------------------------------------------------------------------------- *) -(* A total comparison function for formulas. *) -(* ------------------------------------------------------------------------- *) - -let compare fm1 fm2 = - let rec cmp = function - | [] -> Equal - | (f1_f2 :: fs) -> - if Portable.pointerEqual f1_f2 then cmp fs - else - match f1_f2 with - | (True_,True_) -> cmp fs - | (True_,_) -> Less - | (_,True_) -> Greater - | (False_,False_) -> cmp fs - | (False_,_) -> Less - | (_,False_) -> Greater - | (Atom atm1, Atom atm2) -> - begin - match Atom.compare atm1 atm2 with - | Less -> Less - | Equal -> cmp fs - | Greater -> Greater - end - | (Atom _, _) -> Less - | (_, Atom _) -> Greater - | (Not p1, Not p2) -> cmp ((p1,p2) :: fs) - | (Not _, _) -> Less - | (_, Not _) -> Greater - | (And (p1,q1), And (p2,q2)) -> cmp ((p1,p2) :: (q1,q2) :: fs) - | (And _, _) -> Less - | (_, And _) -> Greater - | (Or (p1,q1), Or (p2,q2)) -> cmp ((p1,p2) :: (q1,q2) :: fs) - | (Or _, _) -> Less - | (_, Or _) -> Greater - | (Imp (p1,q1), Imp (p2,q2)) -> cmp ((p1,p2) :: (q1,q2) :: fs) - | (Imp _, _) -> Less - | (_, Imp _) -> Greater - | (Iff (p1,q1), Iff (p2,q2)) -> cmp ((p1,p2) :: (q1,q2) :: fs) - | (Iff _, _) -> Less - | (_, Iff _) -> Greater - | (Forall (v1,p1), Forall (v2,p2)) -> - begin - match Name.compare v1 v2 with - Less -> Less - | Equal -> cmp ((p1,p2) :: fs) - | Greater -> Greater - end - | (Forall _, Exists _) -> Less - | (Exists _, Forall _) -> Greater - | (Exists (v1,p1), Exists (v2,p2)) -> - begin - match Name.compare v1 v2 with - Less -> Less - | Equal -> cmp ((p1,p2) :: fs) - | Greater -> Greater - end in - cmp [fm1,fm2];; - -let equal fm1 fm2 = compare fm1 fm2 = Equal;; - -(* ------------------------------------------------------------------------- *) -(* Free variables. *) -(* ------------------------------------------------------------------------- *) - -let freeIn v = - let rec f = function - | [] -> false - | (True_ :: fms) -> f fms - | (False_ :: fms) -> f fms - | (Atom atm :: fms) -> Atom.freeIn v atm || f fms - | (Not p :: fms) -> f (p :: fms) - | (And (p,q) :: fms) -> f (p :: q :: fms) - | (Or (p,q) :: fms) -> f (p :: q :: fms) - | (Imp (p,q) :: fms) -> f (p :: q :: fms) - | (Iff (p,q) :: fms) -> f (p :: q :: fms) - | (Forall (w,p) :: fms) -> - if Name.equal v w then f fms else f (p :: fms) - | (Exists (w,p) :: fms) -> - if Name.equal v w then f fms else f (p :: fms) in - fun fm -> f [fm] -;; - -let add (fm,vs) = - let rec fv vs = function - | [] -> vs - | ((_,True_) :: fms) -> fv vs fms - | ((_,False_) :: fms) -> fv vs fms - | ((bv, Atom atm) :: fms) -> - fv (Name.Set.union vs (Name.Set.difference (Atom.freeVars atm) bv)) fms - | ((bv, Not p) :: fms) -> fv vs ((bv,p) :: fms) - | ((bv, And (p,q)) :: fms) -> fv vs ((bv,p) :: (bv,q) :: fms) - | ((bv, Or (p,q)) :: fms) -> fv vs ((bv,p) :: (bv,q) :: fms) - | ((bv, Imp (p,q)) :: fms) -> fv vs ((bv,p) :: (bv,q) :: fms) - | ((bv, Iff (p,q)) :: fms) -> fv vs ((bv,p) :: (bv,q) :: fms) - | ((bv, Forall (v,p)) :: fms) -> fv vs ((Name.Set.add bv v, p) :: fms) - | ((bv, Exists (v,p)) :: fms) -> fv vs ((Name.Set.add bv v, p) :: fms) in - fv vs [(Name.Set.empty,fm)];; - -let freeVars fm = add (fm,Name.Set.empty);; - -let freeVarsList fms = List.foldl (fun x y -> add (x,y)) Name.Set.empty fms;; - -let specialize fm = snd (stripForall fm);; - -let generalize fm = listMkForall (Name.Set.toList (freeVars fm), fm);; - -(* ------------------------------------------------------------------------- *) -(* Substitutions. *) -(* ------------------------------------------------------------------------- *) - -let rec substCheck sub fm = if Substitute.null sub then fm else substFm sub fm - -and substFm sub fm = match fm with - | True_ -> fm - | False_ -> fm - | Atom (p,tms) -> - let tms' = Sharing.map (Substitute.subst sub) tms in - if Portable.pointerEqual (tms,tms') then fm else Atom (p,tms') - | Not p -> - let p' = substFm sub p in - if Portable.pointerEqual (p,p') then fm else Not p' - | And (p,q) -> substConn sub fm (fun (x,y) -> And (x,y)) p q - | Or (p,q) -> substConn sub fm (fun (x,y) -> Or (x,y)) p q - | Imp (p,q) -> substConn sub fm (fun (x,y) -> Imp (x,y)) p q - | Iff (p,q) -> substConn sub fm (fun (x,y) -> Iff (x,y)) p q - | Forall (v,p) -> substQuant sub fm (fun (x,y) -> Forall (x,y)) v p - | Exists (v,p) -> substQuant sub fm (fun (x,y) -> Exists (x,y)) v p - -and substConn sub fm conn p q = - let p' = substFm sub p - and q' = substFm sub q in - if Portable.pointerEqual (p,p') && Portable.pointerEqual (q,q') then fm - else conn (p',q') - -and substQuant sub fm quant v p = - let v' = - let f (w, s) = - if Name.equal w v then s - else - match Substitute.peek sub w with - | None -> Name.Set.add s w - | Some tm -> Name.Set.union s (Term.freeVars tm) in - let vars = freeVars p in - let vars = Name.Set.foldl f Name.Set.empty vars in - Term.variantPrime vars v in - let sub = - if Name.equal v v' then Substitute.remove sub (Name.Set.singleton v) - else Substitute.insert sub (v, Term.Var_ v') in - let p' = substCheck sub p in - if Name.equal v v' && Portable.pointerEqual (p,p') then fm - else quant (v',p');; - -let subst = substCheck;; - -(* ------------------------------------------------------------------------- *) -(* The equality relation. *) -(* ------------------------------------------------------------------------- *) - -let mkEq a_b = Atom (Atom.mkEq a_b);; - -let destEq fm = Atom.destEq (destAtom fm);; - -let isEq = can destEq;; - -let mkNeq a_b = Not (mkEq a_b);; - -let destNeq = function - (Not fm) -> destEq fm - | _ -> raise (Error "Formula.destNeq");; - -let isNeq = can destNeq;; - -let mkRefl tm = Atom (Atom.mkRefl tm);; - -let destRefl fm = Atom.destRefl (destAtom fm);; - -let isRefl = can destRefl;; - -let sym fm = Atom (Atom.sym (destAtom fm));; - -let lhs fm = fst (destEq fm);; - -let rhs fm = snd (destEq fm);; - -(* ------------------------------------------------------------------------- *) -(* Parsing and pretty-printing. *) -(* ------------------------------------------------------------------------- *) - -let truthName = Name.fromString "T" -and falsityName = Name.fromString "F" -and conjunctionName = Name.fromString "/\\" -and disjunctionName = Name.fromString "\\/" -and implicationName = Name.fromString "==>" -and equivalenceName = Name.fromString "<=>" -and universalName = Name.fromString "!" -and existentialName = Name.fromString "?";; - -let rec demote = function - | True_ -> Term.Fn (truthName,[]) - | False_ -> Term.Fn (falsityName,[]) - | (Atom (p,tms)) -> Term.Fn (p,tms) - | (Not p) -> - let s = "~" in - Term.Fn (Name.fromString s, [demote p]) - | (And (p,q)) -> Term.Fn (conjunctionName, [demote p; demote q]) - | (Or (p,q)) -> Term.Fn (disjunctionName, [demote p; demote q]) - | (Imp (p,q)) -> Term.Fn (implicationName, [demote p; demote q]) - | (Iff (p,q)) -> Term.Fn (equivalenceName, [demote p; demote q]) - | (Forall (v,b)) -> Term.Fn (universalName, [Term.Var_ v; demote b]) - | (Exists (v,b)) -> - Term.Fn (existentialName, [Term.Var_ v; demote b]);; - -let toString fm = Term.toString (demote fm);; - -(* ------------------------------------------------------------------------- *) -(* Splitting goals. *) -(* ------------------------------------------------------------------------- *) - -let add_asms asms goal = - if List.null asms then goal else Imp (listMkConj (List.rev asms), goal);; - -let add_var_asms asms v goal = add_asms asms (Forall (v,goal));; - -let rec split asms pol fm = - match (pol,fm) with - (* Positive splittables *) - | (true,True_) -> [] - | (true, Not f) -> split asms false f - | (true, And (f1,f2)) -> split asms true f1 @ split (f1 :: asms) true f2 - | (true, Or (f1,f2)) -> split (Not f1 :: asms) true f2 - | (true, Imp (f1,f2)) -> split (f1 :: asms) true f2 - | (true, Iff (f1,f2)) -> - split (f1 :: asms) true f2 @ split (f2 :: asms) true f1 - | (true, Forall (v,f)) -> List.map (add_var_asms asms v) (split [] true f) - (* Negative splittables *) - | (false,False_) -> [] - | (false, Not f) -> split asms true f - | (false, And (f1,f2)) -> split (f1 :: asms) false f2 - | (false, Or (f1,f2)) -> - split asms false f1 @ split (Not f1 :: asms) false f2 - | (false, Imp (f1,f2)) -> split asms true f1 @ split (f1 :: asms) false f2 - | (false, Iff (f1,f2)) -> - split (f1 :: asms) false f2 @ split (Not f2 :: asms) true f1 - | (false, Exists (v,f)) -> List.map (add_var_asms asms v) (split [] false f) - (* Unsplittables *) - | _ -> [add_asms asms (if pol then fm else Not fm)];; - -let splitGoal fm = split [] true fm;; - -module Map = struct -let newMap () = Mmap.newMap compare ();; -let singleton kv = Mmap.singleton compare kv;; -let fromList xs = Mmap.fromList compare xs;; -let mapPartial f m = Mmap.mapPartial compare f m;; -let null = Mmap.null and size = Mmap.size and get = Mmap.get -and peek = Mmap.peek and insert = Mmap.insert and toList = Mmap.toList -and foldl = Mmap.foldl and foldr = Mmap.foldr and filter = Mmap.filter -and inDomain = Mmap.inDomain and union = Mmap.union and delete = Mmap.delete -and transform = Mmap.transform and exists = Mmap.exists;; -end (* struct Map *) -;; - -module Set = struct -let empty : formula Mset.set = Mset.empty compare;; -let singleton k = Mset.singleton compare k;; -let intersect m1 m2 = Mset.intersect compare;; -let intersectList = Mset.intersectList compare;; -let fromList = Mset.fromList compare;; -let add = Mset.add and foldr = Mset.foldr and foldl = Mset.foldl -and member = Mset.member and union = Mset.union and difference = Mset.difference -and toList = Mset.toList and null = Mset.null and size = Mset.size -and pick = Mset.pick and equal = Mset.equal and exists = Mset.exists -and delete = Mset.delete and subset = Mset.subset and findl = Mset.findl -and firstl = Mset.firstl and transform = Mset.transform and all = Mset.all -and count = Mset.count;; -end (* struct Set *) -;; - -end (* struct Formula *) -;; diff --git a/metis/heap.ml b/metis/heap.ml deleted file mode 100644 index a82a3007..00000000 --- a/metis/heap.ml +++ /dev/null @@ -1,70 +0,0 @@ -(* ========================================================================= *) -(* A HEAP DATATYPE FOR ML *) -(* ========================================================================= *) - -module Heap = struct - -(* Leftist heaps as in Purely Functional Data Structures, by Chris Okasaki *) - -exception Empty;; - -type 'a node = Em | Tr of int * 'a * 'a node * 'a node;; - -type 'a heap = Heap of ('a * 'a -> ordering) * int * 'a node;; - -let rank = function - | Em -> 0 - | (Tr (r,_,_,_)) -> r;; - -let makeT (x,a,b) = - if rank a >= rank b then - Tr (rank b + 1, x, a, b) - else - Tr (rank a + 1, x, b, a);; - -let merge cmp = - let rec mrg = function - | (h,Em) -> h - | (Em,h) -> h - | (Tr (_,x,a1,b1) as h1, (Tr (_,y,a2,b2) as h2)) -> - match cmp (x,y) with - | Greater -> makeT (y, a2, mrg (h1,b2)) - | _ -> makeT (x, a1, mrg (b1,h2)) in - mrg -;; - -let newHeap cmp = Heap ((fun (x,y) -> cmp x y),0,Em);; - -let add (Heap (f,n,a)) x = Heap (f, n + 1, merge f (Tr (1,x,Em,Em), a));; - -let size (Heap (_, n, _)) = n;; - -let null h = size h = 0;; - -let top = function - | (Heap (_,_,Em)) -> raise Empty - | (Heap (_, _, Tr (_,x,_,_))) -> x;; - -let remove = function - | (Heap (_,_,Em)) -> raise Empty - | (Heap (f, n, Tr (_,x,a,b))) -> (x, Heap (f, n - 1, merge f (a,b)));; - -let app f = - let rec ap = function - | [] -> () - | (Em :: rest) -> ap rest - | (Tr (_,d,a,b) :: rest) -> (f d; ap (a :: b :: rest)) in - function Heap (_,_,a) -> ap [a] -;; - -let rec toList h = - if null h then [] else - let (x,h) = remove h in - x :: toList h -;; - -let toString h = - "Heap[" ^ (if null h then "" else Int.toString (size h)) ^ "]";; - -end (* struct Heap *) -;; diff --git a/metis/knuth_bendix.ml b/metis/knuth_bendix.ml deleted file mode 100644 index 09491bf0..00000000 --- a/metis/knuth_bendix.ml +++ /dev/null @@ -1,137 +0,0 @@ -(* ========================================================================= *) -(* KNUTH-BENDIX TERM ORDERING CONSTRAINTS *) -(* ========================================================================= *) - -module Knuth_bendix_order = struct - -(* ------------------------------------------------------------------------- *) -(* Helper functions. *) -(* ------------------------------------------------------------------------- *) - -let notEqualTerm (x,y) = not (Term.equal x y);; - -let firstNotEqualTerm f l = - match List.find notEqualTerm l with - | Some (x,y) -> f x y - | None -> raise (Bug "firstNotEqualTerm");; - -(* ------------------------------------------------------------------------- *) -(* The weight of all constants must be at least 1, and there must be at most *) -(* one unary function with weight 0. *) -(* ------------------------------------------------------------------------- *) - -type kbo = Kbo of { - weight : Term.function_t -> int; - precedence : Term.function_t * Term.function_t -> ordering -};; - -(* Default weight = uniform *) - -let uniformWeight : Term.function_t -> int = kComb 1;; - -(* Default precedence = by arity *) - -let arityPrecedence : Term.function_t * Term.function_t -> ordering = - fun ((f1,n1),(f2,n2)) -> - match Int.compare n1 n2 with - | Less -> Less - | Equal -> Name.compare f1 f2 - | Greater -> Greater;; - -(* The default order *) - -let default = Kbo {weight = uniformWeight; precedence = arityPrecedence};; - -(* ------------------------------------------------------------------------- *) -(* Term weight-1 represented as a linear function of the weight-1 of the *) -(* variables in the term (plus a constant). *) -(* *) -(* Note that the conditions on weight functions ensure that all weights are *) -(* at least 1, so all weight-1s are at least 0. *) -(* ------------------------------------------------------------------------- *) - -type weight = Weight of (Name.name, int) Mmap.map * int;; - -let weightEmpty : (Name.name, int) Mmap.map = Name.Map.newMap ();; - -let weightZero = Weight (weightEmpty,0);; - -let weightIsZero (Weight (m,c)) = c = 0 && Name.Map.null m;; - -let weightNeg (Weight (m,c)) = Weight (Name.Map.transform (fun x -> -x) m, -c);; - -let add ((_,n1),(_,n2)) = - let n = n1 + n2 in - if n = 0 then None else Some n -;; - -let weightAdd (Weight (m1,c1)) (Weight (m2,c2)) = - Weight (Name.Map.union add m1 m2, c1 + c2);; - -let weightSubtract w1 w2 = weightAdd w1 (weightNeg w2);; - -let weightTerm weight = - let rec wt m c = function - | [] -> Weight (m,c) - | Term.Var_ v :: tms -> - let n = Option.getOpt (Name.Map.peek m v) 0 in - wt (Name.Map.insert m (v, n + 1)) (c + 1) tms - | Term.Fn (f,a) :: tms -> - wt m (c + weight (f, length a)) (a @ tms) in - fun tm -> wt weightEmpty (-1) [tm] -;; - -let weightLowerBound (Weight (m,c)) = - if Name.Map.exists (fun _ n -> n < 0) m then None else Some c;; - -(* ------------------------------------------------------------------------- *) -(* The Knuth-Bendix term order. *) -(* ------------------------------------------------------------------------- *) - -let compare (Kbo {weight; precedence}) = - let weightDifference tm1 tm2 = - let w1 = weightTerm weight tm1 - and w2 = weightTerm weight tm2 in - weightSubtract w2 w1 in - let rec weightLess tm1 tm2 = - let w = weightDifference tm1 tm2 in - if weightIsZero w then precedenceLess tm1 tm2 - else weightDiffLess w tm1 tm2 - and weightDiffLess w tm1 tm2 = - match weightLowerBound w with - | None -> false - | Some 0 -> precedenceLess tm1 tm2 - | Some n -> n > 0 - and precedenceLess x y = - match (x,y) with - | (Term.Fn (f1,a1), Term.Fn (f2,a2)) -> - begin - match precedence ((f1, length a1), (f2, length a2)) with - | Less -> true - | Equal -> firstNotEqualTerm weightLess (zip a1 a2) - | Greater -> false - end - | _ -> false in - let weightDiffGreater w tm1 tm2 = weightDiffLess (weightNeg w) tm2 tm1 in - let rec weightCmp tm1 tm2 = - let w = weightDifference tm1 tm2 in - if weightIsZero w then precedenceCmp tm1 tm2 - else if weightDiffLess w tm1 tm2 then Some Less - else if weightDiffGreater w tm1 tm2 then Some Greater - else None - and precedenceCmp x y = - match (x,y) with - | (Term.Fn (f1,a1), Term.Fn (f2,a2)) -> - begin - match precedence ((f1, length a1), (f2, length a2)) with - | Less -> Some Less - | Equal -> firstNotEqualTerm weightCmp (zip a1 a2) - | Greater -> Some Greater - end - | _ -> raise (Bug "kboOrder.precendenceCmp") in - fun (tm1,tm2) -> - if Term.equal tm1 tm2 then Some Equal else weightCmp tm1 tm2 -;; - -end (* struct Knuth_bendix *) -;; diff --git a/metis/literal.ml b/metis/literal.ml deleted file mode 100644 index 24677c55..00000000 --- a/metis/literal.ml +++ /dev/null @@ -1,284 +0,0 @@ -(* ========================================================================= *) -(* FIRST ORDER LOGIC LITERALS *) -(* ========================================================================= *) - -module Literal = struct - -(* ------------------------------------------------------------------------- *) -(* A type for storing first order logic literals. *) -(* ------------------------------------------------------------------------- *) - -type polarity = bool;; - -type literal = polarity * Atom.atom;; - -(* ------------------------------------------------------------------------- *) -(* Constructors and destructors. *) -(* ------------------------------------------------------------------------- *) - -let polarity ((pol,_) : literal) = pol;; - -let atom ((_,atm) : literal) = atm;; - -let name lit = Atom.name (atom lit);; - -let arguments lit = Atom.arguments (atom lit);; - -let arity lit = Atom.arity (atom lit);; - -let positive lit = polarity lit;; - -let negative lit = not (polarity lit);; - -let negate (pol,atm) : literal = (not pol, atm) - -let relation lit = Atom.relation (atom lit);; - -let functions lit = Atom.functions (atom lit);; - -let functionNames lit = Atom.functionNames (atom lit);; - -(* Binary relations *) - -let mkBinop rel (pol,a,b) : literal = (pol, Atom.mkBinop rel (a,b));; - -let destBinop rel ((pol,atm) : literal) = - let (a,b) = Atom.destBinop rel atm in - (pol,a,b);; - -let isBinop rel = can (destBinop rel);; - -(* Formulas *) - -let toFormula = function - | (true,atm) -> Formula.Atom atm - | (false,atm) -> Formula.Not (Formula.Atom atm);; - -let fromFormula = function - | (Formula.Atom atm) -> (true,atm) - | (Formula.Not (Formula.Atom atm)) -> (false,atm) - | _ -> raise (Error "Literal.fromFormula");; - -(* ------------------------------------------------------------------------- *) -(* The size of a literal in symbols. *) -(* ------------------------------------------------------------------------- *) - -let symbols ((_,atm) : literal) = Atom.symbols atm;; - -(* ------------------------------------------------------------------------- *) -(* A total comparison function for literals. *) -(* ------------------------------------------------------------------------- *) - -let compare = prodCompare boolCompare Atom.compare;; - -let equal (p1,atm1) (p2,atm2) = p1 = p2 && Atom.equal atm1 atm2;; - -(* ------------------------------------------------------------------------- *) -(* Subterms. *) -(* ------------------------------------------------------------------------- *) - -let subterm lit path = Atom.subterm (atom lit) path;; - -let subterms lit = Atom.subterms (atom lit);; - -let replace ((pol,atm) as lit) path_tm = - let atm' = Atom.replace atm path_tm in - if Portable.pointerEqual (atm,atm') then lit else (pol,atm') -;; - -(* ------------------------------------------------------------------------- *) -(* Free variables. *) -(* ------------------------------------------------------------------------- *) - -let freeIn v lit = Atom.freeIn v (atom lit);; - -let freeVars lit = Atom.freeVars (atom lit);; - -(* ------------------------------------------------------------------------- *) -(* Substitutions. *) -(* ------------------------------------------------------------------------- *) - -let subst sub ((pol,atm) as lit) : literal = - let atm' = Atom.subst sub atm in - if Portable.pointerEqual (atm',atm) then lit else (pol,atm') -;; - -(* ------------------------------------------------------------------------- *) -(* Matching. *) -(* ------------------------------------------------------------------------- *) - -let matchLiterals sub ((pol1,atm1) : literal) (pol2,atm2) = - let _ = pol1 = pol2 || raise (Error "Literal.match") in - Atom.matchAtoms sub atm1 atm2 -;; - -(* ------------------------------------------------------------------------- *) -(* Unification. *) -(* ------------------------------------------------------------------------- *) - -let unify sub ((pol1,atm1) : literal) (pol2,atm2) = - let _ = pol1 = pol2 || raise (Error "Literal.unify") in - Atom.unify sub atm1 atm2 -;; - -(* ------------------------------------------------------------------------- *) -(* The equality relation. *) -(* ------------------------------------------------------------------------- *) - -let mkEq l_r : literal = (true, Atom.mkEq l_r);; - -let destEq = function - | ((true,atm) : literal) -> Atom.destEq atm - | (false,_) -> raise (Error "Literal.destEq");; - -let isEq = can destEq;; - -let mkNeq l_r : literal = (false, Atom.mkEq l_r);; - -let destNeq = function - | ((false,atm) : literal) -> Atom.destEq atm - | (true,_) -> raise (Error "Literal.destNeq");; - -let isNeq = can destNeq;; - -let mkRefl tm = (true, Atom.mkRefl tm);; - -let destRefl = function - | (true,atm) -> Atom.destRefl atm - | (false,_) -> raise (Error "Literal.destRefl");; - -let isRefl = can destRefl;; - -let mkIrrefl tm = (false, Atom.mkRefl tm);; - -let destIrrefl = function - | (true,_) -> raise (Error "Literal.destIrrefl") - | (false,atm) -> Atom.destRefl atm;; - -let isIrrefl = can destIrrefl;; - -let sym (pol,atm) : literal = (pol, Atom.sym atm);; - -let lhs ((_,atm) : literal) = Atom.lhs atm;; - -let rhs ((_,atm) : literal) = Atom.rhs atm;; - -(* ------------------------------------------------------------------------- *) -(* Special support for terms with type annotations. *) -(* ------------------------------------------------------------------------- *) - -let typedSymbols ((_,atm) : literal) = Atom.typedSymbols atm;; - -let nonVarTypedSubterms ((_,atm) : literal) = Atom.nonVarTypedSubterms atm;; - -(* ------------------------------------------------------------------------- *) -(* Parsing and pretty-printing. *) -(* ------------------------------------------------------------------------- *) - -let toString literal = Formula.toString (toFormula literal);; - -module Map = struct -let newMap () = Mmap.newMap compare ();; -let singleton kv = Mmap.singleton compare kv;; -let fromList xs = Mmap.fromList compare xs;; -let mapPartial f m = Mmap.mapPartial compare f m;; -let null = Mmap.null and size = Mmap.size and get = Mmap.get -and peek = Mmap.peek and insert = Mmap.insert and toList = Mmap.toList -and foldl = Mmap.foldl and foldr = Mmap.foldr and filter = Mmap.filter -and inDomain = Mmap.inDomain and union = Mmap.union and delete = Mmap.delete -and transform = Mmap.transform and exists = Mmap.exists;; -end (* struct Map *) -;; - -module Set = struct -let empty : literal Mset.set = Mset.empty compare;; -let singleton k = Mset.singleton compare k;; -let intersect m1 m2 = Mset.intersect compare;; -let intersectList = Mset.intersectList compare;; -let fromList = Mset.fromList compare;; -let add = Mset.add and foldr = Mset.foldr and foldl = Mset.foldl -and member = Mset.member and union = Mset.union and difference = Mset.difference -and toList = Mset.toList and null = Mset.null and size = Mset.size -and pick = Mset.pick and equal = Mset.equal and exists = Mset.exists -and delete = Mset.delete and subset = Mset.subset and findl = Mset.findl -and firstl = Mset.firstl and transform = Mset.transform and all = Mset.all -and count = Mset.count;; -let negateMember lit set = member (negate lit) set;; -let negate = - let f (lit,set) = add set (negate lit) in - foldl f empty;; -let relations = - let f (lit,set) = Name_arity.Set.add set (relation lit) in - foldl f Name_arity.Set.empty;; -let functions = - let f (lit,set) = Name_arity.Set.union set (functions lit) in - foldl f Name_arity.Set.empty;; -let freeIn v = exists (freeIn v);; -let freeVars = - let f (lit,set) = Name.Set.union set (freeVars lit) in - foldl f Name.Set.empty;; -let freeVarsList = - let f lits set = Name.Set.union set (freeVars lits) in - List.foldl f Name.Set.empty;; -let symbols = - let f (lit,z) = symbols lit + z in - foldl f 0;; -let typedSymbols = - let f (lit,z) = typedSymbols lit + z in - foldl f 0;; -let subst sub lits = - let substLit (lit,(eq,lits')) = - let lit' = subst sub lit in - let eq = eq && Portable.pointerEqual (lit,lit') in - (eq, add lits' lit') in - let (eq,lits') = foldl substLit (true,empty) lits in - if eq then lits else lits';; -let conjoin set = - Formula.listMkConj (List.map toFormula (toList set));; -let disjoin set = - Formula.listMkDisj (List.map toFormula (toList set));; -let toString cl = - "{" ^ String.concatWith ", " (List.map toString (toList cl)) ^ "}";; -(* TODO(oskar): Urk *) -let compare (s1: literal Mset.set) (s2: literal Mset.set) = - List.compare compare (toList s1) (toList s2);; -end (* struct Set *) -;; - -module Set_map = struct -let compare = Set.compare;; -let newMap () = Mmap.newMap compare ();; -let singleton kv = Mmap.singleton compare kv;; -let fromList xs = Mmap.fromList compare xs;; -let mapPartial f m = Mmap.mapPartial compare f m;; -let null = Mmap.null and size = Mmap.size and get = Mmap.get -and peek = Mmap.peek and insert = Mmap.insert and toList = Mmap.toList -and foldl = Mmap.foldl and foldr = Mmap.foldr and filter = Mmap.filter -and inDomain = Mmap.inDomain and union = Mmap.union and delete = Mmap.delete -and transform = Mmap.transform and exists = Mmap.exists;; -end (* struct Map *) -;; - -module Set_set = struct -let compare = Set.compare;; -let empty : literal Mset.set Mset.set = Mset.empty compare;; -let singleton k = Mset.singleton compare k;; -let intersect m1 m2 = Mset.intersect compare;; -let intersectList = Mset.intersectList compare;; -let fromList = Mset.fromList compare;; -let add = Mset.add and foldr = Mset.foldr and foldl = Mset.foldl -and member = Mset.member and union = Mset.union and difference = Mset.difference -and toList = Mset.toList and null = Mset.null and size = Mset.size -and pick = Mset.pick and equal = Mset.equal and exists = Mset.exists -and delete = Mset.delete and subset = Mset.subset and findl = Mset.findl -and firstl = Mset.firstl and transform = Mset.transform and all = Mset.all -and count = Mset.count;; -(* TODO(oskar): Urk *) -let compare (s1: literal Mset.set Mset.set) - (s2: literal Mset.set Mset.set) = - List.compare compare (toList s1) (toList s2);; -end (* struct Set *) -;; - -end (* struct Literal *) -;; diff --git a/metis/literal_net.ml b/metis/literal_net.ml deleted file mode 100644 index a733c1aa..00000000 --- a/metis/literal_net.ml +++ /dev/null @@ -1,73 +0,0 @@ -(* ========================================================================= *) -(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC LITERALS *) -(* ========================================================================= *) - -module Literal_net = struct - -(* ------------------------------------------------------------------------- *) -(* A type of literal sets that can be efficiently matched and unified. *) -(* ------------------------------------------------------------------------- *) - -type parameters = Atom_net.parameters;; - -type 'a literalNet = Literal_net of { - positive : 'a Atom_net.atomNet; - negative : 'a Atom_net.atomNet -};; - -(* ------------------------------------------------------------------------- *) -(* Basic operations. *) -(* ------------------------------------------------------------------------- *) - -let newNet parm = - Literal_net { - positive = Atom_net.newNet parm; - negative = Atom_net.newNet parm -};; - -let pos (Literal_net {positive}) = Atom_net.size positive;; - -let neg (Literal_net {negative}) = Atom_net.size negative;; - -let size net = pos net + neg net;; - -let insert (Literal_net {positive; negative}) = function - | ((true,atm),a) -> - Literal_net {positive = Atom_net.insert positive (atm,a); - negative = negative} - | ((false,atm),a) -> - Literal_net {positive = positive; - negative = Atom_net.insert negative (atm,a)};; - -let fromList parm l = - List.foldl (fun lit_a n -> insert n lit_a) (newNet parm) l;; - -let filter pred (Literal_net {positive; negative}) = - Literal_net { - positive = Atom_net.filter pred positive; - negative = Atom_net.filter pred negative - };; - -let toString net = "Literal_net[" ^ Int.toString (size net) ^ "]";; - -(* ------------------------------------------------------------------------- *) -(* Matching and unification queries. *) -(* *) -(* These function return OVER-APPROXIMATIONS! *) -(* Filter afterwards to get the precise set of satisfying values. *) -(* ------------------------------------------------------------------------- *) - -let matchNet (Literal_net {positive; negative}) = function - | (true,atm) -> Atom_net.matchNet positive atm - | (false,atm) -> Atom_net.matchNet negative atm;; - -let matched (Literal_net {positive; negative}) = function - | (true,atm) -> Atom_net.matched positive atm - | (false,atm) -> Atom_net.matched negative atm;; - -let unify (Literal_net {positive; negative}) = function - | (true,atm) -> Atom_net.unify positive atm - | (false,atm) -> Atom_net.unify negative atm;; - -end (* struct Literal_net *) -;; diff --git a/metis/loop.ml b/metis/loop.ml deleted file mode 100644 index 3bd4f3a6..00000000 --- a/metis/loop.ml +++ /dev/null @@ -1,25 +0,0 @@ -(* ========================================================================= *) -(* The basic Metis loop. *) -(* ========================================================================= *) - -module Loop = -struct - -let rec loop res = - Interrupt.poll (); - match Resolution.iterate res with - | Resolution.Decided dec -> Some dec - | Resolution.Undecided res -> loop res -;; - -let run rules = - let ths = Ax_cj.Ax_cj_thm {axioms_thm = rules; conjecture_thm = []} in - let res = Resolution.newResolution Resolution.default ths in - match loop res with - | None -> failwith "metis: timeout" - | Some (Resolution.Contradiction thm) -> thm - | Some (Resolution.Satisfiable _) -> - failwith "metis: found satisfiable assignment" - -end (* struct Loop *) -;; diff --git a/metis/math.ml b/metis/math.ml deleted file mode 100644 index afdf2e09..00000000 --- a/metis/math.ml +++ /dev/null @@ -1,6 +0,0 @@ -module Math = struct - -let sqrt = Double.sqrt;; - -end (* struct Math *) -;; diff --git a/metis/metis_debug.ml b/metis/metis_debug.ml deleted file mode 100644 index 820c77e6..00000000 --- a/metis/metis_debug.ml +++ /dev/null @@ -1,27 +0,0 @@ -module Metis_debug = struct - -(* Taken from: https://sourceforge.net/p/hol/mailman/message/35201767/ *) -let print_varandtype fmt tm = - let hop,args = strip_comb tm in - let s = name_of hop - and ty = type_of hop in - if is_var hop && args = [] then - begin - pp_print_string fmt "("; - pp_print_string fmt s; - pp_print_string fmt ":"; - pp_print_type fmt ty; - pp_print_string fmt ")" - end - else fail() -;; - -let show_types,hide_types = - (fun () -> install_user_printer ("Show Types", print_varandtype)), - fun () -> - try delete_user_printer "Show Types" - with Failure _ -> - failwith ("hide_types: Types are already hidden.");; - -end (* struct Metis_debug *) -;; diff --git a/metis/metis_generate.ml b/metis/metis_generate.ml deleted file mode 100644 index b5ab74ad..00000000 --- a/metis/metis_generate.ml +++ /dev/null @@ -1,50 +0,0 @@ -(* ========================================================================= *) -(* Conversion of HOL to Metis FOL. *) -(* ========================================================================= *) - -module Metis_generate = struct - -let metis_name = string_of_int;; - -let rec metis_of_term env consts tm = - if is_var tm && not (mem tm consts) then - Term.Var_ (metis_name (Meson.fol_of_var tm)) - else ( - let f,args = strip_comb tm in - if mem f env then failwith "metis_of_term: higher order" else - let ff = Meson.fol_of_const f in - Term.Fn (metis_name ff, map (metis_of_term env consts) args)) -;; - -let metis_of_atom env consts tm = - try let (l, r) = dest_eq tm in - let l' = metis_of_term env consts l - and r' = metis_of_term env consts r in - Atom.mkEq (l', r') - with Failure _ -> - let f,args = strip_comb tm in - if mem f env then failwith "metis_of_atom: higher order" else - let ff = Meson.fol_of_const f in - (metis_name ff, map (metis_of_term env consts) args) -;; - -let metis_of_literal env consts tm = - let (pol, tm') = - try (false, dest_neg tm) - with Failure _ -> (true, tm) in - (pol, metis_of_atom env consts tm') -;; - -let metis_of_clause th = - let lconsts = freesl (hyp th) in - let tm = concl th in - let hlits = disjuncts tm in - let flits = map (metis_of_literal [] lconsts) hlits in - let set = Literal.Set.fromList flits in - Thm.axiom set -;; - -let metis_of_clauses = map metis_of_clause;; - -end (* struct Metis_generate *) -;; diff --git a/metis/metis_mapping.ml b/metis/metis_mapping.ml deleted file mode 100644 index 811dcede..00000000 --- a/metis/metis_mapping.ml +++ /dev/null @@ -1,57 +0,0 @@ -module Metis_mapping = struct - -let reset_consts,fol_of_const,hol_of_const = - Meson.reset_consts,Meson.fol_of_const,Meson.hol_of_const -;; - -let preterm_of_const = preterm_of_term o hol_of_const o int_of_string;; - -let prefix s = "__" ^ s;; - -let rec preterm_of_fol_term = function - | Term.Var_ x -> Varp (prefix x, dpty) - | Term.Fn (f, args) -> - let pf = preterm_of_const f in - let pargs = List.map preterm_of_fol_term args in - Preterm.list_mk_combp (pf, pargs);; - -let preterm_of_predicate = function - | "=" -> Constp ("=", dpty) - | p -> preterm_of_const p -;; - -let preterm_of_atom (p, args) = - let pp = preterm_of_predicate p in - let pargs = List.map preterm_of_fol_term args in - Typing (Preterm.list_mk_combp (pp, pargs), pretype_of_type bool_ty) -;; - -let preterm_of_literal (pol, fat) = - let pat = preterm_of_atom fat in - if pol then pat else Preterm.mk_negp pat -;; - -let preterm_of_eq (s, t) = - Preterm.mk_eqp (preterm_of_fol_term s, preterm_of_fol_term t) -;; - -let typecheck env = - term_of_preterm o retypecheck env o Preterm.unconst_preterm;; -let typecheckl env = function - | [] -> [] - | xs -> Preterm.list_mk_disjp xs |> typecheck env |> disjuncts -;; - -let hol_of_term env = typecheck env o preterm_of_fol_term;; - -let hol_of_atom env = typecheck env o preterm_of_atom;; - -let hol_of_literal env = typecheck env o preterm_of_literal;; - -let hol_of_clause env = - typecheck env o Preterm.list_mk_disjp o map preterm_of_literal;; - -let hol_of_substitution env = map dest_eq o typecheckl env o map preterm_of_eq;; - -end (* struct Metis_mapping *) -;; diff --git a/metis/metis_path.ml b/metis/metis_path.ml deleted file mode 100644 index 06e8db15..00000000 --- a/metis/metis_path.ml +++ /dev/null @@ -1,36 +0,0 @@ -module Metis_path = struct - -(* The term `f 1 2 3` is encoded in HOL Light as follows: - - @ - / \ - @ 3 - / \ - @ 2 - / \ - f 1 - -*) - -let rec hol_of_term_path tm path = match tm, path with - | (tm, []) -> tm, "" - | Term.Fn (f, args), i :: is -> - let arity = length args in - if not (i < arity) then - raise (Assert "i < arity"); - let (tm', path') = hol_of_term_path (List.nth args i) is in - let make n c = String.implode (List.tabulate n (fun _ -> c)) in - (tm', make (arity - i - 1) 'l' ^ "r" ^ path') - | _ -> failwith "hol_of_term_path" -;; - -let hol_of_atom_path (p, args) = hol_of_term_path (Term.Fn (p, args)) -;; - -let hol_of_literal_path (pol, atom) path = - let s, path = hol_of_atom_path atom path in - s, (if pol then path else "r" ^ path) -;; - -end (* struct metis_path *) -;; diff --git a/metis/metis_reconstruct2.ml b/metis/metis_reconstruct2.ml deleted file mode 100644 index 8d463ae6..00000000 --- a/metis/metis_reconstruct2.ml +++ /dev/null @@ -1,260 +0,0 @@ -module Metis_reconstruct2 = struct - -let term_eq_mod_type t1 t2 tyinsts = - try - let _,tminsts,tyinsts = term_type_unify t1 t2 ([], [], tyinsts) in - if !metisverb then - begin - print_string "unified with |tminsts| = "; - print_string (Int.toString (List.length tminsts)); - print_string "!\n"; - List.app (fun (t1,t2) -> - begin - print_string (string_of_term t1); - print_string " <- "; - print_string (string_of_term t2); - print_newline () - end) tminsts - end; - if not (List.null tminsts) then - raise (Assert "tminsts = []"); - Some tyinsts - with _ -> None -;; - -let rec match_elems f m = function - | ([], []) -> [m] - | ([], _) -> [] - | (x :: xs, ys) -> - List.map (fun y -> - match f x y m with - | Some m' -> match_elems f m' (xs, List.filter (((<>) y)) ys) - | None -> []) ys |> List.concat -;; - -let match_fo_ho_clause vars = - match_elems (fun ft ht m -> - try Some (Metis_unify.unify_fo_ho_literal vars ft ht m) - with Metis_unify.Unify -> None) - [] -;; - -let string_of_tminst = String.concatWith ", " o - map (fun (tm, v) -> string_of_term tm ^ " <- " ^ string_of_term v) -;; - -let string_of_tyinst = String.concatWith ", " o - map (fun (ty, v) -> string_of_type ty ^ " <- " ^ string_of_type v) -;; - -let string_of_instantiation (it, tminst, tyinst) = - "([" ^ string_of_tminst tminst ^ "], [" ^ string_of_tyinst tyinst ^ "])" -;; - -let reorient_tysubst vars sub = - let sub' = map (fun (ty, v) -> - if mem v vars && is_vartype ty then v, ty else ty, v) sub in - map (fun (ty, v) -> tysubst sub' ty, v) sub' -;; - -let rec hol_of_thm axioms fth = - if !metisverb then - begin - print_string "hol_of_thm: "; - print_string (Thm.toString fth); - print_string "\n" - end; - let env = Preterm.env_of_ths axioms in - let hth = - match Proof.thmToInference fth with - | Proof.Axiom clause -> - let clausel = Literal.Set.toList clause in - let maxs = concat_map (fun ax -> - let disjs = concl ax |> striplist dest_disj in - let tmvars = freesl (hyp ax) in - let ms = match_fo_ho_clause tmvars (clausel, disjs) in - map (fun m -> m, ax) ms) axioms in - if not (List.length maxs > 0) then - raise (Assert "List.length maxs > 0"); - let tminst = - List.map (fun (v, tm) -> - mk_var (Metis_mapping.prefix v, type_of tm), tm) in - if !metisverb then - begin - print_string "length maxs = "; - print_string (Int.toString (List.length maxs)); - print_string "\n" - end; - if !metisverb then - List.app (fun (m, ax) -> - begin - print_string "max: "; - print_string (string_of_thm ax); - print_string " with m = "; - print_string (string_of_tminst (tminst m)); - print_string "\n" - end) maxs; - let (m, ax) = List.hd maxs in - INST (tminst m) ax - (* Caution: the substitution can contain elements such as "x -> f(x)" *) - | Proof.Subst (fsub, fth1) -> - let th1 = hol_of_thm axioms fth1 in - if !metisverb then - begin - print_string "subst with th1 = "; - print_string (string_of_thm th1); - print_string "\n" - end; - let fsubl = Substitute.toList fsub in - if !metisverb then print_string "before substitution lifting\n"; - let hsub = map (fun (v, t) -> t, Term.Var_ v) fsubl |> - Metis_mapping.hol_of_substitution env in - if !metisverb then - begin - print_string "subst: "; - print_string (string_of_tminst hsub); - print_string "\n" - end; - let tyinst = itlist (fun (t, v) m -> - let v' = find (fun v' -> name_of v' = name_of v) (frees (concl th1)) in - type_unify (type_of v) (type_of v') m) hsub [] in - let tminst = map (fun (t, v) -> inst tyinst t, inst tyinst v) hsub in - if !metisverb then - begin - print_string "before instantiate of th1 = "; - print_string (string_of_thm th1); - print_string " with "; - print_string (string_of_instantiation ([], tminst, tyinst)); - print_string "\n" - end; - INSTANTIATE ([], tminst, tyinst) th1 - | Proof.Resolve (atom, fth1, fth2) -> - let th1 = hol_of_thm axioms fth1 - and th2 = hol_of_thm axioms fth2 in - let env = Preterm.env_of_ths [th1; th2] @ env in - if !metisverb then - List.app (fun (s, pty) -> - begin - print_string s; - print_string " <- "; - print_string (string_of_type (type_of_pretype pty)); - print_string "\n" - end) env; - if !metisverb then print_string "before resolving\n"; - if !metisverb then - begin - print_string "th1 = "; - print_string (string_of_thm th1); - print_string "\n" - end; - if !metisverb then - begin - print_string "th2 = "; - print_string (string_of_thm th2); - print_string "\n" - end; - let tm1 = striplist dest_disj (concl th1) |> List.filter (not o is_neg) - and tm2 = striplist dest_disj (concl th2) - |> List.filter is_neg |> List.map dest_neg in - if !metisverb then - List.app (fun s -> - begin - print_string "tm1: "; - print_string (string_of_term s); - print_string "\n" - end) tm1; - if !metisverb then - List.app (fun s -> - begin - print_string "tm2: "; - print_string (string_of_term s); - print_string "\n" - end) tm2; - let hatom = Metis_mapping.hol_of_atom env atom in - if !metisverb then - begin - print_string "hatom: "; - print_string (string_of_term hatom); - print_string "\n" - end; - let cands = List.concat (List.map (fun x -> - match term_eq_mod_type hatom x [] with - None -> [] - | Some m -> - List.mapPartial (fun y -> term_eq_mod_type hatom y m) tm2) tm1) in - if !metisverb then - begin - print_string (Int.toString (List.length cands)); - print_string " candidates available\n" - end; - if not (List.length cands > 0) then - raise (Assert "List.length cands > 0"); - if not (let h = List.hd cands in List.all ((=) h) cands) then - raise (Assert "(let h = List.hd cands in List.all ((=) h) cands)"); - let tyinsts = List.hd cands in - let tyvars = map hyp axioms |> List.concat |> - map type_vars_in_term |> List.concat in - if !metisverb then print_string "Reorienting type substitution ...\n"; - let tyinsts = reorient_tysubst tyvars tyinsts in - if !metisverb then print_string "Resolving ...\n"; - Metis_rules.RESOLVE (inst tyinsts hatom) - (INST_TYPE tyinsts th1) (INST_TYPE tyinsts th2) - | Proof.Refl term -> REFL (Metis_mapping.hol_of_term env term) - | Proof.Assume atom -> - SPEC (Metis_mapping.hol_of_atom env atom) EXCLUDED_MIDDLE - | Proof.Equality (flit, fpath, ft) -> - let hlit = Metis_mapping.hol_of_literal env flit in - let fs, hpath = Metis_path.hol_of_literal_path flit fpath in - let hs = follow_path hpath hlit in - let ht = Metis_mapping.hol_of_term env ft in - let m = type_unify (type_of ht) (type_of hs) [] in - let hlit, hs, ht = inst m hlit, inst m hs, inst m ht in - if !metisverb then - begin - print_string "Trying to replace "; - print_string (string_of_term hs); - print_string " : "; - print_string (string_of_type (type_of hs)); - print_string " with "; - print_string (string_of_term ht); - print_string " : "; - print_string (string_of_type (type_of ht)); - print_string "\nIn "; - print_string (string_of_term hlit); - print_string "\n" - end; - let heq = mk_eq (hs, ht) in - let conv = PATH_CONV hpath (PURE_ONCE_REWRITE_CONV [ASSUME heq]) in - let hlit' = CONV_RULE conv (ASSUME hlit) in - if !metisverb then - begin - print_string "hlit = "; - print_string (string_of_term hlit); - print_string ", hlit' = "; - print_string (string_of_thm hlit'); - print_string "\n" - end; - if hs <> ht then - (if not (concl hlit' <> hlit) then - raise (Assert "(concl hlit' <> hlit)") - else ()); - (try Metis_rules.DISCH_DISJS [heq; hlit] hlit' - with _ -> failwith "equality") in - (* eliminate duplicates in clause *) - let hth = CONV_RULE DISJ_CANON_CONV hth in - if !metisverb then - begin - print_string "hol_of_thm finished\n"; - let hth' = Thm.clause fth |> Literal.Set.toList - |> Metis_mapping.hol_of_clause env in - print_string "hol_of_thm returned:\n"; - print_string (string_of_term (concl hth)); - print_string " for\n"; - print_string (string_of_term hth'); - print_string "\n" - end; - hth -;; - -end (* struct Metis_reconstruct2 *) -;; diff --git a/metis/metis_rules.ml b/metis/metis_rules.ml deleted file mode 100644 index 5ebc2c99..00000000 --- a/metis/metis_rules.ml +++ /dev/null @@ -1,63 +0,0 @@ -module Metis_rules = struct - -(* move a literal in the proof of a disjunction to the first position - may not preserve the order of the other literals *) -let FRONT lit thm = - let conc = concl thm in - let disj = disjuncts (concl thm) in - let rest = match partition (fun l -> l = lit) disj with - | ([], _) -> failwith "FRONT: literal not in disjunction" - | (_ , r) -> r in - let disj' = lit :: rest in - let conc' = list_mk_disj disj' in - let eq = DISJ_ACI_RULE (mk_eq (conc, conc')) in - (PURE_ONCE_REWRITE_RULE [eq] thm, rest) -;; - -(* resolve two clauses, where atom has to appear at the first position of - both clauses: positive in the first and negative in the second clause *) -let RESOLVE_N = - let RESOLVE_1 = TAUT `!a. a ==> ~a ==> F` - and RESOLVE_2L = TAUT `!a b. a \/ b ==> ~a ==> b` - and RESOLVE_2R = TAUT `!a c. a ==> ~a \/ c ==> c` - and RESOLVE_3 = TAUT `!a b c. a \/ b ==> ~a \/ c ==> b \/ c` in - fun atom -> function - | ([], []) -> SPEC atom RESOLVE_1 - | (r1, []) -> SPECL [atom; list_mk_disj r1] RESOLVE_2L - | ([], r2) -> SPECL [atom; list_mk_disj r2] RESOLVE_2R - | (r1, r2) -> SPECL [atom; list_mk_disj r1; list_mk_disj r2] RESOLVE_3 -;; - -(* resolve two clauses th1 and th2, where atom appears somewhere - positive in th1 and negative in th2 *) -let RESOLVE atom th1 th2 = - (*print_endline ("Atom: " ^ string_of_term atom); - print_endline ("th1 : " ^ string_of_term (concl th1)); - print_endline ("th2 : " ^ string_of_term (concl th2));*) - try let (th1', r1) = FRONT atom th1 - and (th2', r2) = FRONT (mk_neg atom) th2 in - let res = RESOLVE_N atom (r1, r2) in - MP (MP res th1') th2' - with _ -> failwith "resolve" -;; - -(* given A, tm |- C, prove A |- ~tm \/ C or - given A, ~tm |- C, prove A |- tm \/ C *) -let DISCH_DISJ = - let IMPL_NOT_L = TAUT `!a b. ~a ==> b <=> a \/ b` - and IMPL_NOT_R = TAUT `!a b. a ==> b <=> ~a \/ b` in - fun tm th -> - let impl = DISCH tm th - and (tm', IMPL_NOT) = - try dest_neg tm, IMPL_NOT_L - with _ -> tm, IMPL_NOT_R in - let eq = SPECL [tm'; concl th] IMPL_NOT in - PURE_ONCE_REWRITE_RULE [eq] impl -;; - -(* given A, tm1, .., tmn |- th, prove A |- ~tm1 \/ .. \/ ~tmn \/ th *) -let DISCH_DISJS tms th = List.foldr DISCH_DISJ th tms -;; - -end (* struct Metis_rules *) -;; diff --git a/metis/metis_unify.ml b/metis/metis_unify.ml deleted file mode 100644 index a63e990c..00000000 --- a/metis/metis_unify.ml +++ /dev/null @@ -1,54 +0,0 @@ -module Metis_unify = struct - -let verb = ref false;; - -exception Unify;; - -let rec unify_fo_ho_term vars fat tm m = - if !verb then - begin - print_string "unify_fo_ho_term: fat = "; - print_string (Term.toString fat); - print_string ", tm = "; - print_string (string_of_term tm); - print_newline () - end; - match fat with - | Term.Var_ v when List.exists (fun (w,_) -> w = v) m -> - if !verb then print_string "var_assoc\n"; - let tm' = assoc v m in - if tm = tm' then m else raise Unify - | Term.Var_ v -> - if !verb then print_string "var\n"; - if is_var tm && not (mem tm vars) then (v, tm) :: m - else (if !verb then print_string "Unify!\n"; raise Unify) - | Term.Fn (f, args) -> - if !verb then print_string "fn\n"; - let hf, hargs = try strip_comb tm with _ -> raise Unify in - if !verb then begin - print_string "hf = "; print_string (string_of_term hf); - print_string "\n"; - print_string "is_var: "; - print_string (if is_var hf then "true" else "false"); - print_string "\n" - end; - if not (is_const hf || is_var hf) then - raise (Assert "is_const hf || is_var hf"); - if hf = Metis_mapping.hol_of_const (int_of_string f) - then itlist2 (unify_fo_ho_term vars) args hargs m - else raise Unify;; - -let unify_fo_ho_atom vars (p, args) htm m = - if p = "=" then - try let hl, hr = dest_eq htm in - itlist2 (unify_fo_ho_term vars) args [hl; hr] m - with _ -> raise Unify - else unify_fo_ho_term vars (Term.Fn (p, args)) htm m;; - -let unify_fo_ho_literal vars (pol, atom) htm m = - let htm' = if pol then htm else - try dest_neg htm with _ -> raise Unify in - unify_fo_ho_atom vars atom htm' m;; - -end (* struct Metis_unify *) -;; diff --git a/metis/mmap.ml b/metis/mmap.ml deleted file mode 100644 index e8abdc8b..00000000 --- a/metis/mmap.ml +++ /dev/null @@ -1,68 +0,0 @@ -module Mmap = struct -type ('k, 'v) map = Mmap of ('k, 'v) Map.map;; -let newMap cmp () = Mmap (Map.empty cmp);; -let null (Mmap m) = Map.null m;; -let singleton cmp (k, x) = Mmap (Map.insert (Map.empty cmp) k x);; -let size (Mmap m) = Map.size m;; -let get (Mmap m) k = - match Map.lookup m k with - | None -> raise (Error "Mmap.get: element not found") - | Some v -> v;; -let peek (Mmap m) k = Map.lookup m k;; -let insert (Mmap m) (k, v) = Mmap (Map.insert m k v);; -let toList (Mmap m) = Map.toAscList m;; -let fromList cmp l = Mmap (Map.fromList cmp l);; -let foldr f b (Mmap m) = - Map.foldrWithKey (fun k v s -> f (k, v, s)) b m;; -let foldl = foldr;; -let filter f (Mmap m) = Mmap (Map.filterWithKey (fun k v -> f (k, v)) m);; -let inDomain k (Mmap m) = Option.isSome (Map.lookup m k);; -let union f (Mmap m1) (Mmap m2) = - let m1 = Map.map (fun x -> Some x) m1 - and m2 = Map.map (fun x -> Some x) m2 in - let f' k = function - | Some x, Some y -> f ((k, x), (k, y)) - | Some x, _ -> Some x - | _, Some y -> Some y - | _ -> None in - let m = Map.unionWithKey (fun k x y -> f' k (x, y)) m1 m2 in - let m = Map.filter Option.isSome m in - Mmap (Map.map Option.valOf m);; -let delete (Mmap m) k = Mmap (Map.delete m k);; -let mapPartial cmp f (Mmap m) = - Mmap (Map.foldrWithKey (fun k x acc -> - match f (k, x) with - | Some y -> Map.insert acc k y - | None -> acc) (Map.empty cmp) m);; -let transform f (Mmap m) = Mmap (Map.map f m);; -let exists f (Mmap m) = Map.exists f m;; -end (* struct Mmap *) -;; - -module Intmap = struct -let cmp = Int.compare -let newMap () = Mmap.newMap cmp ();; -let singleton kv = Mmap.singleton cmp kv;; -let fromList xs = Mmap.fromList cmp xs;; -let mapPartial f m = Mmap.mapPartial cmp f m;; -let null = Mmap.null and size = Mmap.size and get = Mmap.get -and peek = Mmap.peek and insert = Mmap.insert and toList = Mmap.toList -and foldl = Mmap.foldl and foldr = Mmap.foldr and filter = Mmap.filter -and inDomain = Mmap.inDomain and union = Mmap.union and delete = Mmap.delete -and transform = Mmap.transform and exists = Mmap.exists;; -end (* struct IntMap *) -;; - -module Stringmap = struct -let cmp = String.compare -let newMap () = Mmap.newMap cmp ();; -let singleton kv = Mmap.singleton cmp kv;; -let fromList xs = Mmap.fromList cmp xs;; -let mapPartial f m = Mmap.mapPartial cmp f m;; -let null = Mmap.null and size = Mmap.size and get = Mmap.get -and peek = Mmap.peek and insert = Mmap.insert and toList = Mmap.toList -and foldl = Mmap.foldl and foldr = Mmap.foldr and filter = Mmap.filter -and inDomain = Mmap.inDomain and union = Mmap.union and delete = Mmap.delete -and transform = Mmap.transform and exists = Mmap.exists;; -end (* struct Stringmap *) -;; diff --git a/metis/model.ml b/metis/model.ml deleted file mode 100644 index bba36534..00000000 --- a/metis/model.ml +++ /dev/null @@ -1,1011 +0,0 @@ -(* ========================================================================= *) -(* RANDOM FINITE MODELS *) -(* ========================================================================= *) - -module Model = struct - -(* ------------------------------------------------------------------------- *) -(* Constants. *) -(* ------------------------------------------------------------------------- *) - -let maxSpace = 1000;; - -(* ------------------------------------------------------------------------- *) -(* Helper functions. *) -(* ------------------------------------------------------------------------- *) - -let multInt = fun x -> fun y -> Some (x * y);; - -let rec iexp x y acc = - if y mod 2 = 0 then iexp' x y acc - else - match multInt acc x with - | Some acc -> iexp' x y acc - | None -> None - -and iexp' x y acc = - if y = 1 then Some acc - else - let y = Int.div y 2 in - match multInt x x with - | Some x -> iexp x y acc - | None -> None -;; - -let expInt x y = - if y <= 1 then - if y = 0 then Some 1 - else if y = 1 then Some x - else raise (Bug "expInt: negative exponent") - else if x <= 1 then - if 0 <= x then Some x - else raise (Bug "expInt: negative exponand") - else iexp x y 1;; - -let boolToInt = function - | true -> 1 - | false -> 0;; - -let intToBool = function - | 1 -> true - | 0 -> false - | _ -> raise (Bug "Model.intToBool");; - -let minMaxInterval i j = interval i (1 + j - i);; - -(* ------------------------------------------------------------------------- *) -(* A model of size N has integer elements 0...N-1. *) -(* ------------------------------------------------------------------------- *) - -type element = int;; - -let zeroElement = 0;; - -let incrementElement n i = - let i = i + 1 in - if i = n then None else Some i -;; - -let elementListSpace n arity = - match expInt n arity with - | None -> None - | Some m as s -> if m <= maxSpace then s else None;; - -let elementListIndex n = - let rec f acc elts = - match elts with - | [] -> acc - | elt :: elts -> f (n * acc + elt) elts in - f 0 -;; - -(* ------------------------------------------------------------------------- *) -(* The parts of the model that are fixed. *) -(* ------------------------------------------------------------------------- *) - -type fixedFunction = int -> element list -> element option;; - -type fixedRelation = int -> element list -> bool option;; - -type fixed = Fixed of { - functions : (Name_arity.nameArity, fixedFunction) Mmap.map; - relations : (Name_arity.nameArity, fixedRelation) Mmap.map -};; - -let uselessFixedFunction : fixedFunction = kComb (kComb None);; - -let uselessFixedRelation : fixedRelation = kComb (kComb None);; - -let emptyFunctions : (Name_arity.nameArity, fixedFunction) Mmap.map = - Name_arity.Map.newMap ();; - -let emptyRelations : (Name_arity.nameArity, fixedRelation) Mmap.map = - Name_arity.Map.newMap ();; - -let fixed0 f sz elts = - match elts with - | [] -> f sz - | _ -> raise (Bug "Model.fixed0: wrong arity");; - -let fixed1 f sz elts = - match elts with - | [x] -> f sz x - | _ -> raise (Bug "Model.fixed1: wrong arity");; - -let fixed2 f sz elts = - match elts with - | [x;y] -> f sz x y - | _ -> raise (Bug "Model.fixed2: wrong arity");; - -let emptyFixed = - let fns = emptyFunctions - and rels = emptyRelations in - Fixed {functions = fns; relations = rels} -;; - -let peekFunctionFixed fix name_arity = - let Fixed {functions} = fix in - Name_arity.Map.peek functions name_arity -;; - -let peekRelationFixed fix name_arity = - let Fixed {relations} = fix in - Name_arity.Map.peek relations name_arity -;; - -let getFunctionFixed fix name_arity = - match peekFunctionFixed fix name_arity with - | Some f -> f - | None -> uselessFixedFunction;; - -let getRelationFixed fix name_arity = - match peekRelationFixed fix name_arity with - | Some rel -> rel - | None -> uselessFixedRelation;; - -let insertFunctionFixed fix name_arity_fun = - let Fixed {functions} = fix in - let fns = Name_arity.Map.insert functions name_arity_fun in - Fixed {fix with functions = fns} -;; - -let insertRelationFixed fix name_arity_rel = - let Fixed {relations} = fix in - let rels = Name_arity.Map.insert relations name_arity_rel in - Fixed {fix with relations = rels} -;; - -let union _ = raise (Bug "Model.unionFixed: nameArity clash");; -let unionFixed fix1 fix2 = - let fns1 = fix1.Fixed.functions and rels1 = fix1.Fixed.relations in - let fns2 = fix2.Fixed.functions and rels2 = fix2.Fixed.relations in - let fns = Name_arity.Map.union union fns1 fns2 in - let rels = Name_arity.Map.union union rels1 rels2 in - Fixed {functions = fns; relations = rels} -;; - -let unionListFixed = - let union fix acc = unionFixed acc fix in - List.foldl union emptyFixed -;; - -let hasTypeFn _ elts = - match elts with - | [x;_] -> Some x - | _ -> raise (Bug "Model.hasTypeFn: wrong arity");; - -let eqRel _ elts = - match elts with - | [x;y] -> Some (x = y) - | _ -> raise (Bug "Model.eqRel: wrong arity");; - -let basicFixed = - let fns = Name_arity.Map.singleton (Term.hasTypeFunction,hasTypeFn) in - let rels = Name_arity.Map.singleton (Atom.eqRelation,eqRel) in - Fixed {functions = fns; relations = rels} -;; - -(* ------------------------------------------------------------------------- *) -(* Renaming fixed model parts. *) -(* ------------------------------------------------------------------------- *) - -type fixedMap = Fixed_map of { - functionMap : (Name_arity.nameArity, Name.name) Mmap.map; - relationMap : (Name_arity.nameArity, Name.name) Mmap.map -};; - -let mapFixed fixMap fix = - let Fixed_map {functionMap; relationMap} = fixMap - and Fixed {functions; relations} = fix in - let fns = Name_arity.Map.compose functionMap functions in - let rels = Name_arity.Map.compose relationMap relations in - Fixed {functions = fns; relations = rels} -;; - - -(* ------------------------------------------------------------------------- *) -(* Standard fixed model parts. *) -(* ------------------------------------------------------------------------- *) - -(* Projections *) - -let projectionMin = 1 -and projectionMax = 9;; - -let projectionList = minMaxInterval projectionMin projectionMax;; - -let projectionName i = - let _ = projectionMin <= i || - raise (Bug "Model.projectionName: less than projectionMin") in - let _ = i <= projectionMax || - raise (Bug "Model.projectionName: greater than projectionMax") in - Name.fromString ("project" ^ Int.toString i) -;; - -let projectionFn i _ elts = Some (List.nth elts (i - 1));; - -let arityProjectionFixed arity = - let mkProj i = ((projectionName i, arity), projectionFn i) in - let rec addProj i acc = - if i > arity then acc - else addProj (i + 1) (Name_arity.Map.insert acc (mkProj i)) in - let fns = addProj projectionMin emptyFunctions in - let rels = emptyRelations in - Fixed {functions = fns; relations = rels} -;; - -let projectionFixed = - unionListFixed (List.map arityProjectionFixed projectionList);; - -(* Arithmetic *) - -let numeralMin = -100 -and numeralMax = 100;; - -let numeralList = minMaxInterval numeralMin numeralMax;; - -let numeralName i = - let _ = numeralMin <= i || - raise (Bug "Model.numeralName: less than numeralMin") in - let _ = i <= numeralMax || - raise (Bug "Model.numeralName: greater than numeralMax") in - let s = if i < 0 then "negative" ^ Int.toString (-i) else Int.toString i in - Name.fromString s -;; - -let addName = Name.fromString "+" -and divName = Name.fromString "div" -and dividesName = Name.fromString "divides" -and evenName = Name.fromString "even" -and expName = Name.fromString "exp" -and geName = Name.fromString ">=" -and gtName = Name.fromString ">" -and isZeroName = Name.fromString "isZero" -and leName = Name.fromString "<=" -and ltName = Name.fromString "<" -and modName = Name.fromString "mod" -and multName = Name.fromString "*" -and negName = Name.fromString "~" -and oddName = Name.fromString "odd" -and preName = Name.fromString "pre" -and subName = Name.fromString "-" -and sucName = Name.fromString "suc";; - -(* Support *) - -let modN n x = x mod n;; - -let oneN sz = modN sz 1;; - -let multN sz (x,y) = modN sz (x * y);; - -(* Functions *) - -let numeralFn i sz = Some (modN sz i);; - -let addFn sz x y = Some (modN sz (x + y));; - -let divFn n x y = - let y = if y = 0 then n else y in - Some (Int.div x y) -;; - -let expFn sz x y = Some (exp (multN sz) x y (oneN sz));; - -let modFn n x y = - let y = if y = 0 then n else y in - Some (x mod y) -;; - -let multFn sz x y = Some (multN sz (x,y));; - -let negFn n x = Some (if x = 0 then 0 else n - x);; - -let preFn n x = Some (if x = 0 then n - 1 else x - 1);; - -let subFn n x y = Some (if x < y then n + x - y else x - y);; - -let sucFn n x = Some (if x = n - 1 then 0 else x + 1);; - -(* Relations *) - -let dividesRel _ x y = Some (divides x y);; - -let evenRel _ x = Some (x mod 2 = 0);; - -let geRel _ x y = Some (x >= y);; - -let gtRel _ x y = Some (x > y);; - -let isZeroRel _ x = Some (x = 0);; - -let leRel _ x y = Some (x <= y);; - -let ltRel _ x y = Some (x < y);; - -let oddRel _ x = Some (x mod 2 = 1);; - -let modularFixed = - let fns = - Name_arity.Map.fromList - (List.map (fun i -> ((numeralName i,0), fixed0 (numeralFn i))) - numeralList @ - [((addName,2), fixed2 addFn); - ((divName,2), fixed2 divFn); - ((expName,2), fixed2 expFn); - ((modName,2), fixed2 modFn); - ((multName,2), fixed2 multFn); - ((negName,1), fixed1 negFn); - ((preName,1), fixed1 preFn); - ((subName,2), fixed2 subFn); - ((sucName,1), fixed1 sucFn)]) in - let rels = - Name_arity.Map.fromList - [((dividesName,2), fixed2 dividesRel); - ((evenName,1), fixed1 evenRel); - ((geName,2), fixed2 geRel); - ((gtName,2), fixed2 gtRel); - ((isZeroName,1), fixed1 isZeroRel); - ((leName,2), fixed2 leRel); - ((ltName,2), fixed2 ltRel); - ((oddName,1), fixed1 oddRel)] in - Fixed {functions = fns; relations = rels} -;; - -(* Support *) - -let cutN n x = if x >= n then n - 1 else x;; - -let oneN sz = cutN sz 1;; - -let multN sz (x,y) = cutN sz (x * y);; - -(* Functions *) - -let numeralFn i sz = if i < 0 then None else Some (cutN sz i);; - -let addFn sz x y = Some (cutN sz (x + y));; - -let divFn _ x y = if y = 0 then None else Some (Int.div x y);; - -let expFn sz x y = Some (exp (multN sz) x y (oneN sz));; - -let modFn n x y = - if y = 0 || x = n - 1 then None else Some (x mod y);; - -let multFn sz x y = Some (multN sz (x,y));; - -let negFn _ x = if x = 0 then Some 0 else None;; - -let preFn _ x = if x = 0 then None else Some (x - 1);; - -let subFn n x y = - if y = 0 then Some x - else if x = n - 1 || x < y then None - else Some (x - y);; - -let sucFn sz x = Some (cutN sz (x + 1));; - -(* Relations *) - -let dividesRel n x y = - if x = 1 || y = 0 then Some true - else if x = 0 then Some false - else if y = n - 1 then None - else Some (divides x y);; - -let evenRel n x = - if x = n - 1 then None else Some (x mod 2 = 0);; - -let geRel n y x = - if x = n - 1 then if y = n - 1 then None else Some false - else if y = n - 1 then Some true else Some (x <= y);; - -let gtRel n y x = - if x = n - 1 then if y = n - 1 then None else Some false - else if y = n - 1 then Some true else Some (x < y);; - -let isZeroRel _ x = Some (x = 0);; - -let leRel n x y = - if x = n - 1 then if y = n - 1 then None else Some false - else if y = n - 1 then Some true else Some (x <= y);; - -let ltRel n x y = - if x = n - 1 then if y = n - 1 then None else Some false - else if y = n - 1 then Some true else Some (x < y);; - -let oddRel n x = - if x = n - 1 then None else Some (x mod 2 = 1);; - -let overflowFixed = - let fns = - Name_arity.Map.fromList - (List.map (fun i -> ((numeralName i,0), fixed0 (numeralFn i))) - numeralList @ - [((addName,2), fixed2 addFn); - ((divName,2), fixed2 divFn); - ((expName,2), fixed2 expFn); - ((modName,2), fixed2 modFn); - ((multName,2), fixed2 multFn); - ((negName,1), fixed1 negFn); - ((preName,1), fixed1 preFn); - ((subName,2), fixed2 subFn); - ((sucName,1), fixed1 sucFn)]) in - let rels = - Name_arity.Map.fromList - [((dividesName,2), fixed2 dividesRel); - ((evenName,1), fixed1 evenRel); - ((geName,2), fixed2 geRel); - ((gtName,2), fixed2 gtRel); - ((isZeroName,1), fixed1 isZeroRel); - ((leName,2), fixed2 leRel); - ((ltName,2), fixed2 ltRel); - ((oddName,1), fixed1 oddRel)] in - Fixed {functions = fns; relations = rels} -;; - -(* Sets *) - -let cardName = Name.fromString "card" -and complementName = Name.fromString "complement" -and differenceName = Name.fromString "difference" -and emptyName = Name.fromString "empty" -and memberName = Name.fromString "member" -and insertName = Name.fromString "insert" -and intersectName = Name.fromString "intersect" -and singletonName = Name.fromString "singleton" -and subsetName = Name.fromString "subset" -and symmetricDifferenceName = Name.fromString "symmetricDifference" -and unionName = Name.fromString "union" -and universeName = Name.fromString "universe";; - -(* Support *) - -let eltN n = - let rec f acc = function - | 0 -> acc - | x -> f (acc + 1) (Int.div x 2) in - f (-1) n -;; - -let posN i = Word64.(<<) (Word64.fromInt 1) i;; - -let univN sz = Word64.(-) (posN (eltN sz)) (Word64.fromInt 1);; - -let setN sz x = Word64.andb (Word64.fromInt x) (univN sz);; - -(* Functions *) - -let cardFn sz x = - let rec f acc s = - if s = Word64.fromInt 0 then acc else - let acc = if Word64.andb s (Word64.fromInt 1) = Word64.fromInt 0 then acc - else Word64.(+) acc (Word64.fromInt 1) in - f acc (Word64.(>>) s 1) in - Some (Word64.toInt (f (setN sz x) (Word64.fromInt 0))) -;; - -let complementFn sz x = - Some (Word64.toInt (Word64.xorb (univN sz) (setN sz x)));; - -let differenceFn sz x y = - let x = setN sz x - and y = setN sz y in - Some (Word64.toInt (Word64.andb x (Word64.notb y))) -;; - -let emptyFn _ = Some 0;; - -let insertFn sz x y = - let x = x mod eltN sz - and y = setN sz y in - Some (Word64.toInt (Word64.orb (posN x) y)) -;; - -let intersectFn sz x y = - Some (Word64.toInt (Word64.andb (setN sz x) (setN sz y)));; - -let singletonFn sz x = - let x = x mod eltN sz in - Some (Word64.toInt (posN x)) -;; - -let symmetricDifferenceFn sz x y = - let x = setN sz x - and y = setN sz y in - Some (Word64.toInt (Word64.xorb x y)) -;; - -let unionFn sz x y = - Some (Word64.toInt (Word64.orb (setN sz x) (setN sz y)));; - -let universeFn sz = Some (Word64.toInt (univN sz));; - -(* Relations *) - -let memberRel sz x y = - let x = x mod eltN sz - and y = setN sz y in - Some (Word64.andb (posN x) y <> Word64.fromInt 0) -;; - -let subsetRel sz x y = - let x = setN sz x - and y = setN sz y in - Some (Word64.andb x (Word64.notb y) = Word64.fromInt 0) -;; - -let setFixed = - let fns = - Name_arity.Map.fromList - [((cardName,1), fixed1 cardFn); - ((complementName,1), fixed1 complementFn); - ((differenceName,2), fixed2 differenceFn); - ((emptyName,0), fixed0 emptyFn); - ((insertName,2), fixed2 insertFn); - ((intersectName,2), fixed2 intersectFn); - ((singletonName,1), fixed1 singletonFn); - ((symmetricDifferenceName,2), fixed2 symmetricDifferenceFn); - ((unionName,2), fixed2 unionFn); - ((universeName,0), fixed0 universeFn)] in - let rels = - Name_arity.Map.fromList - [((memberName,2), fixed2 memberRel); - ((subsetName,2), fixed2 subsetRel)] in - Fixed {functions = fns; relations = rels} -;; - -(* Lists *) - -let appendName = Name.fromString "@" -and consName = Name.fromString "::" -and lengthName = Name.fromString "length" -and nilName = Name.fromString "nil" -and nullName = Name.fromString "null" -and tailName = Name.fromString "tail";; - -let baseFix = - let fix = unionFixed projectionFixed overflowFixed in - let sucFn = getFunctionFixed fix (sucName,1) in - let suc2Fn sz _ x = sucFn sz [x] in - insertFunctionFixed fix ((sucName,2), fixed2 suc2Fn) -;; - -let fixMap = - Fixed_map {functionMap = Name_arity.Map.fromList - [((appendName,2),addName); - ((consName,2),sucName); - ((lengthName,1), projectionName 1); - ((nilName,0), numeralName 0); - ((tailName,1),preName)]; - relationMap = Name_arity.Map.fromList - [((nullName,1),isZeroName)] -};; - -let listFixed = mapFixed fixMap baseFix;; - -(* ------------------------------------------------------------------------- *) -(* Valuations. *) -(* ------------------------------------------------------------------------- *) - -type valuation = Valuation of (Name.name, element) Mmap.map;; - -let emptyValuation = Valuation (Name.Map.newMap ());; - -let insertValuation (Valuation m) v_i = Valuation (Name.Map.insert m v_i);; - -let peekValuation (Valuation m) v = Name.Map.peek m v;; - -let constantValuation i = - let add (v,v') = insertValuation v' (v,i) in - Name.Set.foldl add emptyValuation -;; - -let zeroValuation = constantValuation zeroElement;; - -let getValuation v' v = - match peekValuation v' v with - | Some i -> i - | None -> raise (Error "Model.getValuation: incomplete valuation");; - -let randomValuation n vs = - let f (v,v') = insertValuation v' (v, Portable.randomInt n) in - Name.Set.foldl f emptyValuation vs -;; - -let incrementValuation n vars = - let rec inc vs v' = - match vs with - | [] -> None - | v :: vs -> - let (carry,i) = - match incrementElement n (getValuation v' v) with - | Some i -> (false,i) - | None -> (true,zeroElement) in - let v' = insertValuation v' (v,i) in - if carry then inc vs v' else Some v' in - inc (Name.Set.toList vars) -;; - -let foldValuation n vars f = - let inc = incrementValuation n vars in - let rec fold v' acc = - let acc = f (v',acc) in - match inc v' with - | None -> acc - | Some v' -> fold v' acc in - let zero = zeroValuation vars in - fold zero -;; - -(* ------------------------------------------------------------------------- *) -(* A type of random finite mapping Z^n -> Z. *) -(* ------------------------------------------------------------------------- *) - -let cUNKNOWN = -1;; - -type table = - | Forgetful_table - | Array_table of int array;; - -let newTable n arity = - match elementListSpace n arity with - | None -> Forgetful_table - | Some space -> Array_table (Array.array space cUNKNOWN) -;; - -let randomResult r = Portable.randomInt r;; -let lookupTable n vR table elts = - match table with - | Forgetful_table -> randomResult vR - | Array_table a -> - let i = elementListIndex n elts in - let r = Array.sub a i in - if r <> cUNKNOWN then r - else - let r = randomResult vR in - Array.update a i r; - r -;; - -let updateTable n table (elts,r) = - match table with - | Forgetful_table -> () - | Array_table a -> - let i = elementListIndex n elts in - Array.update a i r -;; - -(* ------------------------------------------------------------------------- *) -(* A type of random finite mappings name * arity -> Z^arity -> Z. *) -(* ------------------------------------------------------------------------- *) - -type tables = Tables of { - domainSize : int; - rangeSize : int; - tableMap : (Name_arity.nameArity, table) Mmap.map ref -};; - -let newTables n vR = Tables { - domainSize = n; - rangeSize = vR; - tableMap = ref (Name_arity.Map.newMap ()) -};; - -let getTables tables n_a = - let n = tables.Tables.domainSize and tm = tables.Tables.tableMap in - let m = !tm in - match Name_arity.Map.peek m n_a with - | Some t -> t - | None -> - let (_,a) = n_a in - let t = newTable n a in - let m = Name_arity.Map.insert m (n_a,t) in - tm := m; - t -;; - -let lookupTables tables (n,elts) = - let Tables {domainSize; rangeSize} = tables in - let a = length elts in - let table = getTables tables (n,a) in - lookupTable domainSize rangeSize table elts -;; - -let updateTables tables ((n,elts),r) = - let Tables {domainSize} = tables in - let a = length elts in - let table = getTables tables (n,a) in - updateTable domainSize table (elts,r) -;; - -(* ------------------------------------------------------------------------- *) -(* A type of random finite models. *) -(* ------------------------------------------------------------------------- *) - -type parameters = Parameters of { - sizep : int; - fixed : fixed -};; - -type model = Model of { - sizem : int; - fixedFunctions : (Name_arity.nameArity, element list -> element option) - Mmap.map; - fixedRelations : (Name_arity.nameArity, element list -> bool option) - Mmap.map; - randomFunctions : tables; - randomRelations : tables -};; - -let newModel (Parameters {sizep; fixed}) = - let Fixed {functions; relations} = fixed in - let fixFns = Name_arity.Map.transform (fun f -> f sizep) functions - and fixRels = Name_arity.Map.transform (fun r -> r sizep) relations in - let rndFns = newTables sizep sizep - and rndRels = newTables sizep 2 in - Model {sizem = sizep; fixedFunctions = fixFns; fixedRelations = fixRels; - randomFunctions = rndFns; randomRelations = rndRels} -;; - -let msize (Model {sizem}) = sizem;; -let psize (Parameters {sizep}) = sizep;; - -let peekFixedFunction vM (n,elts) = - let Model {fixedFunctions} = vM in - match Name_arity.Map.peek fixedFunctions (n, length elts) with - | None -> None - | Some fixFn -> fixFn elts -;; - -let isFixedFunction vM n_elts = Option.isSome (peekFixedFunction vM n_elts);; - -let peekFixedRelation vM (n,elts) = - let Model {fixedRelations} = vM in - match Name_arity.Map.peek fixedRelations (n, length elts) with - | None -> None - | Some fixRel -> fixRel elts -;; - -let isFixedRelation vM n_elts = Option.isSome (peekFixedRelation vM n_elts);; - -(* A default model *) - -let defaultSize = 8;; - -let defaultFixed = - unionListFixed - [basicFixed; - projectionFixed; - modularFixed; - setFixed; - listFixed];; - -let default = Parameters {sizep = defaultSize; fixed = defaultFixed};; - -(* ------------------------------------------------------------------------- *) -(* Taking apart terms to interpret them. *) -(* ------------------------------------------------------------------------- *) - -let destTerm tm = - match tm with - | Term.Var_ _ -> tm - | Term.Fn f_tms -> - match Term.stripApp tm with - | (_,[]) -> tm - | (Term.Var_ _ as v, tms) -> Term.Fn (Term.appName, v :: tms) - | (Term.Fn (f,tms), tms') -> Term.Fn (f, tms @ tms');; - -(* ------------------------------------------------------------------------- *) -(* Interpreting terms and formulas in the model. *) -(* ------------------------------------------------------------------------- *) - -let interpretFunction vM n_elts = - match peekFixedFunction vM n_elts with - | Some r -> r - | None -> - let Model {randomFunctions} = vM in - lookupTables randomFunctions n_elts -;; - -let interpretRelation vM n_elts = - match peekFixedRelation vM n_elts with - | Some r -> r - | None -> - let Model {randomRelations} = vM in - intToBool (lookupTables randomRelations n_elts) -;; - -let interpretTerm vM vV = - let rec interpret tm = - match destTerm tm with - | Term.Var_ v -> getValuation vV v - | Term.Fn (f,tms) -> interpretFunction vM (f, List.map interpret tms) in - interpret -;; - -let interpretAtom vM vV (r,tms) = - interpretRelation vM (r, List.map (interpretTerm vM vV) tms);; - -let interpretFormula vM = - let vN = msize vM in - let rec interpret vV fm = - match fm with - | Formula.True_ -> true - | Formula.False_ -> false - | Formula.Atom atm -> interpretAtom vM vV atm - | Formula.Not p -> not (interpret vV p) - | Formula.Or (p,q) -> interpret vV p || interpret vV q - | Formula.And (p,q) -> interpret vV p && interpret vV q - | Formula.Imp (p,q) -> interpret vV (Formula.Or (Formula.Not p, q)) - | Formula.Iff (p,q) -> interpret vV p = interpret vV q - | Formula.Forall (v,p) -> interpret' vV p v vN - | Formula.Exists (v,p) -> - interpret vV (Formula.Not (Formula.Forall (v, Formula.Not p))) - -and interpret' vV fm v i = - i = 0 || - let i = i - 1 in - let vV' = insertValuation vV (v,i) in - interpret vV' fm && interpret' vV fm v i in - interpret -;; - -let interpretLiteral vM vV (pol,atm) = - let b = interpretAtom vM vV atm in - if pol then b else not b -;; - -let interpretClause vM vV cl = Literal.Set.exists (interpretLiteral vM vV) cl;; - -(* ------------------------------------------------------------------------- *) -(* Check whether random groundings of a formula are true in the model. *) -(* Note: if it's cheaper, a systematic check will be performed instead. *) -(* ------------------------------------------------------------------------- *) - -let check interpret maxChecks vM fv x = - let vN = msize vM in - let score (vV,(vT,vF)) = - if interpret vM vV x then (vT + 1, vF) else (vT, vF + 1) in - let randomCheck acc = score (randomValuation vN fv, acc) in - let maxChecks = - match maxChecks with - | None -> maxChecks - | Some m -> - match expInt vN (Name.Set.size fv) with - | Some n -> if n <= m then None else maxChecks - | None -> maxChecks in - match maxChecks with - | Some m -> funpow m randomCheck (0, 0) - | None -> foldValuation vN fv score (0, 0) -;; - -let checkAtom maxChecks vM atm = - check interpretAtom maxChecks vM (Atom.freeVars atm) atm;; - -let checkFormula maxChecks vM fm = - check interpretFormula maxChecks vM (Formula.freeVars fm) fm;; - -let checkLiteral maxChecks vM lit = - check interpretLiteral maxChecks vM (Literal.freeVars lit) lit;; - -let checkClause maxChecks vM cl = - check interpretClause maxChecks vM (Literal.Set.freeVars cl) cl;; - -(* ------------------------------------------------------------------------- *) -(* Updating the model. *) -(* ------------------------------------------------------------------------- *) - -let updateFunction vM func_elts_elt = - let Model {randomFunctions} = vM in - updateTables randomFunctions func_elts_elt -;; - -let updateRelation vM (rel_elts,pol) = - let Model {randomRelations} = vM in - updateTables randomRelations (rel_elts, boolToInt pol) -;; - -(* ------------------------------------------------------------------------- *) -(* A type of terms with interpretations embedded in the subterms. *) -(* ------------------------------------------------------------------------- *) - -type modelTerm = - | Model_var - | Model_fn of Term.functionName * modelTerm list * int list;; - -let modelTerm vM vV = - let rec modelTm tm = - match destTerm tm with - | Term.Var_ v -> (Model_var, getValuation vV v) - | Term.Fn (f,tms) -> - let (tms,xs) = unzip (List.map modelTm tms) in - (Model_fn (f,tms,xs), interpretFunction vM (f,xs)) in - modelTm -;; - -(* ------------------------------------------------------------------------- *) -(* Perturbing the model. *) -(* ------------------------------------------------------------------------- *) - -type perturbation = - | Function_perturbation of (Term.functionName * element list) * element - | Relation_perturbation of (Atom.relationName * element list) * bool;; - -let perturb vM pert = - match pert with - | Function_perturbation ((func,elts),elt) -> - updateFunction vM ((func,elts),elt) - | Relation_perturbation ((rel,elts),pol) -> - updateRelation vM ((rel,elts),pol);; - -let rec pertTerm vM target tm acc = - match target with - | [] -> acc - | _ -> - match tm with - | Model_var -> acc - | Model_fn (func,tms,xs) -> - let onTarget ys = mem (interpretFunction vM (func,ys)) target in - let func_xs = (func,xs) in - let acc = - if isFixedFunction vM func_xs then acc - else - let add y acc = Function_perturbation (func_xs,y) :: acc in - List.foldl add acc target in - pertTerms vM onTarget tms xs acc - -and pertTerms vM onTarget = - let vN = msize vM in - let filterElements pred = - let rec filt i acc = - match i with - | 0 -> acc - | _ -> - let i = i - 1 in - let acc = if pred i then i :: acc else acc in - filt i acc in - filt vN [] in - let rec pert = function - | (_, [], [], acc) -> acc - | (ys, (tm :: tms), (x :: xs), acc) -> - let pred y = - y <> x && onTarget (rev_append ys (y :: xs)) in - let target = filterElements pred in - let acc = pertTerm vM target tm acc in - pert ((x :: ys), tms, xs, acc) - | (_, _, _, _) -> raise (Bug "Model.pertTerms.pert") in - fun x y z -> pert ([],x,y,z) -;; - -let pertAtom vM vV target (rel,tms) acc = - let onTarget ys = interpretRelation vM (rel,ys) = target in - let (tms,xs) = unzip (List.map (modelTerm vM vV) tms) in - let rel_xs = (rel,xs) in - let acc = - if isFixedRelation vM rel_xs then acc - else Relation_perturbation (rel_xs,target) :: acc in - pertTerms vM onTarget tms xs acc -;; - -let pertLiteral vM vV ((pol,atm),acc) = pertAtom vM vV pol atm acc;; - -let pertClause vM vV cl acc = Literal.Set.foldl (pertLiteral vM vV) acc cl;; - -let pickPerturb vM perts = - if List.null perts then () - else perturb vM (List.nth perts (Portable.randomInt (length perts)));; - -let perturbTerm vM vV (tm,target) = - pickPerturb vM (pertTerm vM target (fst (modelTerm vM vV tm)) []);; - -let perturbAtom vM vV (atm,target) = - pickPerturb vM (pertAtom vM vV target atm []);; - -let perturbLiteral vM vV lit = pickPerturb vM (pertLiteral vM vV (lit,[]));; - -let perturbClause vM vV cl = pickPerturb vM (pertClause vM vV cl []);; - -end (* struct Model *) -;; diff --git a/metis/mset.ml b/metis/mset.ml deleted file mode 100644 index 3c1605a0..00000000 --- a/metis/mset.ml +++ /dev/null @@ -1,68 +0,0 @@ -module Mset = struct -type 'k set = Mset of 'k Set.set;; -let add (Mset s) x = Mset (Set.insert x s);; -let foldr f a (Mset s) = Set.fold (curry f) a s;; -let foldl = foldr;; -let member x (Mset s) = Set.member x s;; -let empty cmp = Mset (Set.empty cmp);; -let union (Mset s1) (Mset s2) = Mset (Set.union s1 s2);; -let difference (Mset s1) (Mset s2) = - Mset (Set.fold (fun k acc -> - if Set.member k s1 then Set.delete k acc else acc) s1 s2);; -let toList (Mset s) = Set.toList s;; -let singleton cmp k = Mset (Set.singleton cmp k);; -let null (Mset s) = Set.null s;; -let size (Mset s) = Set.size s;; -let pick (Mset s) = - (* Hack: *) - let x = ref [] in - try Set.map (fun k -> x := [k]; failwith "") s; List.hd (!x) - with Failure _ -> List.hd (!x) -;; -let equal (Mset s1) (Mset s2) = - Set.isSubset s1 s2 && - Set.isSubset s2 s1;; -let exists f (Mset s) = Set.exists f s;; -let fromList cmp l = Mset (Set.fromList cmp l);; -let delete (Mset s) k = Mset (Set.delete k s);; -let subset (Mset s1) (Mset s2) = Set.isSubset s1 s2;; -let intersect cmp (Mset s1) (Mset s2) = - Mset (Set.fold (fun k acc -> - if Set.member k s2 then Set.insert k acc else acc) (Set.empty cmp) s1);; -let intersectList cmp = function - | [] -> Mset (Set.empty cmp) - | s::ss -> List.foldr (intersect cmp) s ss;; -let findl p (Mset s) = - Set.fold (fun k acc -> - match acc with - | Some _ -> acc - | None -> if p k then Some k else None) None s;; -let firstl f (Mset s) = - Set.fold (fun k acc -> - match acc with - | Some _ -> acc - | None -> f k) None s;; -let transform f (Mset s) = - Set.fold (fun x acc -> f x :: acc) [] s;; -let all p (Mset s) = Set.all p s;; -let count p (Mset s) = - Set.fold (fun x c -> if p x then c+1 else c) 0 s;; -end (* struct Mset *) -;; - -module Intset = struct -let cmp = Int.compare;; -let empty : int Mset.set = Mset.empty cmp;; -let singleton k = Mset.singleton cmp k;; -let intersect m1 m2 = Mset.intersect cmp;; -let intersectList = Mset.intersectList cmp;; -let fromList = Mset.fromList cmp;; -let add = Mset.add and foldr = Mset.foldr and foldl = Mset.foldl -and member = Mset.member and union = Mset.union and difference = Mset.difference -and toList = Mset.toList and null = Mset.null and size = Mset.size -and pick = Mset.pick and equal = Mset.equal and exists = Mset.exists -and delete = Mset.delete and subset = Mset.subset and findl = Mset.findl -and firstl = Mset.firstl and transform = Mset.transform and all = Mset.all -and count = Mset.count;; -end -;; diff --git a/metis/name.ml b/metis/name.ml deleted file mode 100644 index f3481cdf..00000000 --- a/metis/name.ml +++ /dev/null @@ -1,87 +0,0 @@ -(* ========================================================================= *) -(* NAMES *) -(* ========================================================================= *) - -module Name = struct - -(* ------------------------------------------------------------------------- *) -(* A type of names. *) -(* ------------------------------------------------------------------------- *) - -type name = string;; -let pp_name s = pp_string s;; - -(* ------------------------------------------------------------------------- *) -(* A total ordering. *) -(* ------------------------------------------------------------------------- *) - -let compare = String.compare;; - -let equal n1 n2 = n1 = n2;; - -(* ------------------------------------------------------------------------- *) -(* Fresh variables. *) -(* ------------------------------------------------------------------------- *) - -let prefix = "_";; -let numName i = mkPrefix prefix (Int.toString i);; -let newName () = numName (newInt ());; -let newNames n = List.map numName (newInts n);; - -let variantPrime avoid = - let rec variant n = if avoid n then variant (n ^ "'") else n in - variant;; - -let isDigit c = - Char.(<=) '0' c && Char.(<=) c '9';; - -let variantNum avoid n = - let isDigitOrPrime c = c = '\'' || isDigit c in - if not (avoid n) then n - else - let n = stripSuffix isDigitOrPrime n in - let rec variant i = - let n_i = n ^ Int.toString i in - if avoid n_i then variant (i + 1) else n_i in - variant 0 -;; - -(* ------------------------------------------------------------------------- *) -(* Parsing and pretty printing. *) -(* ------------------------------------------------------------------------- *) - -let toString s : string = s;; - -let fromString s : name = s;; - -module Map = struct -let newMap () = Mmap.newMap compare ();; -let singleton kv = Mmap.singleton compare kv;; -let fromList xs = Mmap.fromList compare xs;; -let mapPartial f m = Mmap.mapPartial compare f m;; -let null = Mmap.null and size = Mmap.size and get = Mmap.get -and peek = Mmap.peek and insert = Mmap.insert and toList = Mmap.toList -and foldl = Mmap.foldl and foldr = Mmap.foldr and filter = Mmap.filter -and inDomain = Mmap.inDomain and union = Mmap.union and delete = Mmap.delete -and transform = Mmap.transform and exists = Mmap.exists;; -end (* struct Map *) -;; - -module Set = struct -let empty : name Mset.set = Mset.empty compare;; -let singleton k = Mset.singleton compare k;; -let intersect m1 m2 = Mset.intersect compare;; -let intersectList = Mset.intersectList compare;; -let fromList = Mset.fromList compare;; -let add = Mset.add and foldr = Mset.foldr and foldl = Mset.foldl -and member = Mset.member and union = Mset.union and difference = Mset.difference -and toList = Mset.toList and null = Mset.null and size = Mset.size -and pick = Mset.pick and equal = Mset.equal and exists = Mset.exists -and delete = Mset.delete and subset = Mset.subset and findl = Mset.findl -and firstl = Mset.firstl and transform = Mset.transform and all = Mset.all -and count = Mset.count;; -end (* struct Set *) -;; - -end (* struct Name *) -;; diff --git a/metis/name_arity.ml b/metis/name_arity.ml deleted file mode 100644 index 32c883e6..00000000 --- a/metis/name_arity.ml +++ /dev/null @@ -1,75 +0,0 @@ -(* ========================================================================= *) -(* NAME/ARITY PAIRS *) -(* ========================================================================= *) - -module Name_arity = struct - -(* ------------------------------------------------------------------------- *) -(* A type of name/arity pairs. *) -(* ------------------------------------------------------------------------- *) - -type nameArity = Name.name * int;; - -let name ((n,_) : nameArity) = n;; - -let arity ((_,i) : nameArity) = i;; - -(* ------------------------------------------------------------------------- *) -(* Testing for different arities. *) -(* ------------------------------------------------------------------------- *) - -let nary i n_i = arity n_i = i;; - -let nullary = nary 0 -and unary = nary 1 -and binary = nary 2 -and ternary = nary 3;; - -(* ------------------------------------------------------------------------- *) -(* A total ordering. *) -(* ------------------------------------------------------------------------- *) - -let compare (n1,i1) (n2,i2) = - match Name.compare n1 n2 with - | Less -> Less - | Equal -> Int.compare i1 i2 - | Greater -> Greater;; - -let equal (n1,i1) (n2,i2) = i1 = i2 && Name.equal n1 n2;; - -module Map = struct -let newMap () = Mmap.newMap compare ();; -let singleton kv = Mmap.singleton compare kv;; -let fromList xs = Mmap.fromList compare xs;; -let mapPartial f m = Mmap.mapPartial compare f m;; -let null = Mmap.null and size = Mmap.size and get = Mmap.get -and peek = Mmap.peek and insert = Mmap.insert and toList = Mmap.toList -and foldl = Mmap.foldl and foldr = Mmap.foldr and filter = Mmap.filter -and inDomain = Mmap.inDomain and union = Mmap.union and delete = Mmap.delete -and transform = Mmap.transform and exists = Mmap.exists;; -let compose m1 m2 = - let pk ((_,a), n) = peek m2 (n, a) in - mapPartial pk m1 -;; -end (* struct Map *) -;; - -module Set = struct -let empty : nameArity Mset.set = Mset.empty compare;; -let singleton k = Mset.singleton compare k;; -let intersect m1 m2 = Mset.intersect compare;; -let intersectList = Mset.intersectList compare;; -let fromList = Mset.fromList compare;; -let add = Mset.add and foldr = Mset.foldr and foldl = Mset.foldl -and member = Mset.member and union = Mset.union and difference = Mset.difference -and toList = Mset.toList and null = Mset.null and size = Mset.size -and pick = Mset.pick and equal = Mset.equal and exists = Mset.exists -and delete = Mset.delete and subset = Mset.subset and findl = Mset.findl -and firstl = Mset.firstl and transform = Mset.transform and all = Mset.all -and count = Mset.count;; -let allNullary = all nullary -;; -end (* struct Set *) -;; -end (* struct Name_arity *) -;; diff --git a/metis/pmap.ml b/metis/pmap.ml deleted file mode 100644 index 5205479a..00000000 --- a/metis/pmap.ml +++ /dev/null @@ -1,999 +0,0 @@ -(* ========================================================================= *) -(* FINITE MAPS IMPLEMENTED WITH RANDOMLY BALANCED TREES *) -(* ========================================================================= *) - -module Pmap = struct - -(* ------------------------------------------------------------------------- *) -(* Importing useful functionality. *) -(* ------------------------------------------------------------------------- *) - -let pointerEqual = Portable.pointerEqual;; - -let randomInt = Portable.randomInt;; - -let randomWord = Portable.randomWord;; - -(* ------------------------------------------------------------------------- *) -(* Converting a comparison function to an equality function. *) -(* ------------------------------------------------------------------------- *) - -let equalKey compareKey key1 key2 = compareKey key1 key2 = Equal;; - -(* ------------------------------------------------------------------------- *) -(* Priorities. *) -(* ------------------------------------------------------------------------- *) - -type priority = Word64.word;; - -let randomPriority = randomWord;; - -let comparePriority = fun x y -> - Int.compare (Word64.toInt x) (Word64.toInt y);; - -(* ------------------------------------------------------------------------- *) -(* Priority search trees. *) -(* ------------------------------------------------------------------------- *) - -type ('key,'value) tree = - | Empty - | Tree of ('key,'value) node -and ('key,'value) node = Node of { - size : int; - priority : priority; - left : ('key,'value) tree; - key : 'key; - value : 'value; - right : ('key,'value) tree -};; - -let lowerPriorityNode node1 node2 = - let p1 = node1.Node.priority - and p2 = node2.Node.priority in - comparePriority p1 p2 = Less -;; - -(* ------------------------------------------------------------------------- *) -(* Tree operations. *) -(* ------------------------------------------------------------------------- *) - -let treeNew () = Empty;; - -let nodeSize (Node {size}) = size;; - -let treeSize tree = - match tree with - | Empty -> 0 - | Tree x -> nodeSize x;; - -let mkNode priority left key value right = - let size = treeSize left + 1 + treeSize right in - Node { - size = size; - priority = priority; - left = left; - key = key; - value = value; - right = right} -;; - -let mkTree priority left key value right = - let node = mkNode priority left key value right in - Tree node -;; - -(* ------------------------------------------------------------------------- *) -(* Extracting the left and right spines of a tree. *) -(* ------------------------------------------------------------------------- *) - -let rec treeLeftSpine acc tree = - match tree with - | Empty -> acc - | Tree node -> nodeLeftSpine acc node - -and nodeLeftSpine acc node = - let Node {left} = node in - treeLeftSpine (node :: acc) left -;; - -let rec treeRightSpine acc tree = - match tree with - | Empty -> acc - | Tree node -> nodeRightSpine acc node - -and nodeRightSpine acc node = - let Node {right} = node in - treeRightSpine (node :: acc) right -;; - -(* ------------------------------------------------------------------------- *) -(* Singleton trees. *) -(* ------------------------------------------------------------------------- *) - -let mkNodeSingleton priority key value = - let size = 1 - and left = Empty - and right = Empty in - Node { - size = size; - priority = priority; - left = left; - key = key; - value = value; - right = right} -;; - -let nodeSingleton (key,value) = - let priority = randomPriority () in - mkNodeSingleton priority key value -;; - -let treeSingleton key_value = - let node = nodeSingleton key_value in - Tree node -;; - -(* ------------------------------------------------------------------------- *) -(* Appending two trees, where every element of the first tree is less than *) -(* every element of the second tree. *) -(* ------------------------------------------------------------------------- *) - -let rec treeAppend tree1 tree2 = - match tree1 with - | Empty -> tree2 - | Tree node1 -> - match tree2 with - | Empty -> tree1 - | Tree node2 -> - if lowerPriorityNode node1 node2 then - let Node {priority; left; key; value; right} = node2 in - let left = treeAppend tree1 left in - mkTree priority left key value right - else - let Node {priority; left; key; value; right} = node1 in - let right = treeAppend right tree2 in - mkTree priority left key value right -;; - -(* ------------------------------------------------------------------------- *) -(* Appending two trees and a node, where every element of the first tree is *) -(* less than the node, which in turn is less than every element of the *) -(* second tree. *) -(* ------------------------------------------------------------------------- *) - -let treeCombine left node right = - let left_node = treeAppend left (Tree node) in - treeAppend left_node right -;; - -(* ------------------------------------------------------------------------- *) -(* Searching a tree for a value. *) -(* ------------------------------------------------------------------------- *) - -let rec treePeek compareKey pkey tree = - match tree with - | Empty -> None - | Tree node -> nodePeek compareKey pkey node - -and nodePeek compareKey pkey node = - let Node {left; key; value; right} = node in - match compareKey pkey key with - | Less -> treePeek compareKey pkey left - | Equal -> Some value - | Greater -> treePeek compareKey pkey right -;; - -(* ------------------------------------------------------------------------- *) -(* Tree paths. *) -(* ------------------------------------------------------------------------- *) - -(* Generating a path by searching a tree for a key/value pair *) - -let rec treePeekPath compareKey pkey path tree = - match tree with - | Empty -> (path,None) - | Tree node -> nodePeekPath compareKey pkey path node - -and nodePeekPath compareKey pkey path node = - let Node {left; key; right} = node in - match compareKey pkey key with - | Less -> treePeekPath compareKey pkey ((true,node) :: path) left - | Equal -> (path, Some node) - | Greater -> treePeekPath compareKey pkey ((false,node) :: path) right -;; - -(* A path splits a tree into left/right components *) - -let addSidePath (wentLeft,node) (leftTree,rightTree) = - let Node {priority; left; key; value; right} = node in - if wentLeft then (leftTree, mkTree priority rightTree key value right) - else (mkTree priority left key value leftTree, rightTree) -;; - -let addSidesPath left_right = List.foldl addSidePath left_right;; - -let mkSidesPath path = addSidesPath (Empty,Empty) path;; - -(* Updating the subtree at a path *) - -let updateTree (wentLeft,node) tree = - let Node {priority; left; key; value; right} = node in - if wentLeft then mkTree priority tree key value right - else mkTree priority left key value tree;; - -let updateTreePath tree = List.foldl updateTree tree;; - -(* Inserting a new node at a path position *) - -let insertNodePath node = - let rec insert left_right path = - match path with - | [] -> - let (left,right) = left_right in - treeCombine left node right - | ((_,snode) as step) :: rest -> - if lowerPriorityNode snode node then - let left_right = addSidePath step left_right in - insert left_right rest - else - let (left,right) = left_right in - let tree = treeCombine left node right in - updateTreePath tree path in - insert (Empty,Empty) -;; - -(* ------------------------------------------------------------------------- *) -(* Using a key to split a node into three components: the keys comparing *) -(* less than the supplied key, an optional equal key, and the keys comparing *) -(* greater. *) -(* ------------------------------------------------------------------------- *) - -let nodePartition compareKey pkey node = - let (path,pnode) = nodePeekPath compareKey pkey [] node in - match pnode with - | None -> - let (left,right) = mkSidesPath path in - (left,None,right) - | Some node -> - let Node {left; key; value; right} = node in - let (left,right) = addSidesPath (left,right) path in - (left, Some (key,value), right) -;; - -(* ------------------------------------------------------------------------- *) -(* Searching a tree for a key/value pair. *) -(* ------------------------------------------------------------------------- *) - -let rec treePeekKey compareKey pkey tree = - match tree with - | Empty -> None - | Tree node -> nodePeekKey compareKey pkey node - -and nodePeekKey compareKey pkey node = - let Node {left; key; value; right} = node in - match compareKey pkey key with - | Less -> treePeekKey compareKey pkey left - | Equal -> Some (key,value) - | Greater -> treePeekKey compareKey pkey right -;; - -(* ------------------------------------------------------------------------- *) -(* Inserting new key/values into the tree. *) -(* ------------------------------------------------------------------------- *) - -let treeInsert compareKey key_value tree = - let (key,value) = key_value in - let (path,inode) = treePeekPath compareKey key [] tree in - match inode with - | None -> - let node = nodeSingleton (key,value) in - insertNodePath node path - | Some node -> - let Node {size; priority; left; right} = node in - let node = Node { - size = size; - priority = priority; - left = left; - key = key; - value = value; - right = right} in - updateTreePath (Tree node) path -;; - -(* ------------------------------------------------------------------------- *) -(* Deleting key/value pairs: it raises an exception if the supplied key is *) -(* not present. *) -(* ------------------------------------------------------------------------- *) - -let rec treeDelete compareKey dkey tree = - match tree with - | Empty -> raise (Bug "Map.delete: element not found") - | Tree node -> nodeDelete compareKey dkey node - -and nodeDelete compareKey dkey node = - let Node {size; priority; left; key; value; right} = node in - match compareKey dkey key with - | Less -> - let size = size - 1 - and left = treeDelete compareKey dkey left in - let node = Node {size = size; priority = priority; left = left; key = key; - value = value; right = right} in - Tree node - | Equal -> treeAppend left right - | Greater -> - let size = size - 1 - and right = treeDelete compareKey dkey right in - let node = Node {size = size; priority = priority; left = left; key = key; - value = value; right = right} in - Tree node -;; - -(* ------------------------------------------------------------------------- *) -(* Partial map is the basic operation for preserving tree structure. *) -(* It applies its argument function to the elements *in order*. *) -(* ------------------------------------------------------------------------- *) - -let rec treeMapPartial f tree = - match tree with - | Empty -> Empty - | Tree node -> nodeMapPartial f node - -and nodeMapPartial f (Node {priority; left; key; value; right}) = - let left = treeMapPartial f left - and vo = f key value - and right = treeMapPartial f right in - match vo with - | None -> treeAppend left right - | Some value -> mkTree priority left key value right -;; - -(* ------------------------------------------------------------------------- *) -(* Mapping tree values. *) -(* ------------------------------------------------------------------------- *) - -let rec treeMap f tree = - match tree with - | Empty -> Empty - | Tree node -> Tree (nodeMap f node) - -and nodeMap f node = - let Node {size; priority; left; key; value; right} = node in - let left = treeMap f left - and value = f key value - and right = treeMap f right in - Node {size = size; priority = priority; left = left; key = key; value = value; - right = right} -;; - -(* ------------------------------------------------------------------------- *) -(* Merge is the basic operation for joining two trees. Note that the merged *) -(* key is always the one from the second map. *) -(* ------------------------------------------------------------------------- *) - -let rec treeMerge compareKey f1 f2 fb tree1 tree2 = - match tree1 with - | Empty -> treeMapPartial f2 tree2 - | Tree node1 -> - match tree2 with - | Empty -> treeMapPartial f1 tree1 - | Tree node2 -> nodeMerge compareKey f1 f2 fb node1 node2 - -and nodeMerge compareKey f1 f2 fb node1 node2 = - let Node {priority; left; key; value; right} = node2 in - let (l,kvo,r) = nodePartition compareKey key node1 in - let left = treeMerge compareKey f1 f2 fb l left - and right = treeMerge compareKey f1 f2 fb r right in - let vo = match kvo with - | None -> f2 key value - | Some kv -> fb kv (key,value) in - match vo with - | None -> treeAppend left right - | Some value -> - let node = mkNodeSingleton priority key value in - treeCombine left node right -;; - -(* ------------------------------------------------------------------------- *) -(* A union operation on trees. *) -(* ------------------------------------------------------------------------- *) - -let rec treeUnion compareKey f f2 tree1 tree2 = - match tree1 with - | Empty -> tree2 - | Tree node1 -> - match tree2 with - | Empty -> tree1 - | Tree node2 -> nodeUnion compareKey f f2 node1 node2 - -and nodeUnion compareKey f f2 node1 node2 = - if pointerEqual (node1,node2) then - nodeMapPartial f2 node1 - else - let Node {priority; left; key; value; right} = node2 in - let (l,kvo,r) = nodePartition compareKey key node1 in - let left = treeUnion compareKey f f2 l left - and right = treeUnion compareKey f f2 r right in - let vo = match kvo with - | None -> Some value - | Some kv -> f kv (key,value) in - match vo with - | None -> treeAppend left right - | Some value -> - let node = mkNodeSingleton priority key value in - treeCombine left node right -;; - -(* ------------------------------------------------------------------------- *) -(* An intersect operation on trees. *) -(* ------------------------------------------------------------------------- *) - -let rec treeIntersect compareKey f t1 t2 = - match t1 with - | Empty -> Empty - | Tree n1 -> - match t2 with - | Empty -> Empty - | Tree n2 -> nodeIntersect compareKey f n1 n2 - -and nodeIntersect compareKey f n1 n2 = - let Node {priority; left; key; value; right} = n2 in - let (l,kvo,r) = nodePartition compareKey key n1 in - let left = treeIntersect compareKey f l left - and right = treeIntersect compareKey f r right in - let vo = - match kvo with - | None -> None - | Some kv -> f (kv,(key,value)) in - match vo with - | None -> treeAppend left right - | Some value -> mkTree priority left key value right -;; - -(* ------------------------------------------------------------------------- *) -(* A union operation on trees which simply chooses the second value. *) -(* ------------------------------------------------------------------------- *) - -let rec treeUnionDomain compareKey tree1 tree2 = - match tree1 with - | Empty -> tree2 - | Tree node1 -> - match tree2 with - | Empty -> tree1 - | Tree node2 -> - if pointerEqual (node1,node2) then tree2 - else nodeUnionDomain compareKey node1 node2 - -and nodeUnionDomain compareKey node1 node2 = - let Node {priority; left; key; value; right} = node2 in - let (l,_,r) = nodePartition compareKey key node1 in - let left = treeUnionDomain compareKey l left - and right = treeUnionDomain compareKey r right in - let node = mkNodeSingleton priority key value in - treeCombine left node right -;; - -(* ------------------------------------------------------------------------- *) -(* An intersect operation on trees which simply chooses the second value. *) -(* ------------------------------------------------------------------------- *) - -let rec treeIntersectDomain compareKey tree1 tree2 = - match tree1 with - | Empty -> Empty - | Tree node1 -> - match tree2 with - | Empty -> Empty - | Tree node2 -> - if pointerEqual (node1,node2) then tree2 - else nodeIntersectDomain compareKey node1 node2 - -and nodeIntersectDomain compareKey node1 node2 = - let Node {priority; left; key; value; right} = node2 in - let (l,kvo,r) = nodePartition compareKey key node1 in - let left = treeIntersectDomain compareKey l left - and right = treeIntersectDomain compareKey r right in - if Option.isSome kvo then mkTree priority left key value right - else treeAppend left right -;; - -(* ------------------------------------------------------------------------- *) -(* A difference operation on trees. *) -(* ------------------------------------------------------------------------- *) - -let rec treeDifferenceDomain compareKey t1 t2 = - match t1 with - | Empty -> Empty - | Tree n1 -> - match t2 with - | Empty -> t1 - | Tree n2 -> nodeDifferenceDomain compareKey n1 n2 - -and nodeDifferenceDomain compareKey n1 n2 = - if pointerEqual (n1,n2) then Empty - else - let Node {priority; left; key; value; right} = n1 in - let (l,kvo,r) = nodePartition compareKey key n2 in - let left = treeDifferenceDomain compareKey left l - and right = treeDifferenceDomain compareKey right r in - if Option.isSome kvo then treeAppend left right - else mkTree priority left key value right -;; - -(* ------------------------------------------------------------------------- *) -(* A subset operation on trees. *) -(* ------------------------------------------------------------------------- *) - -let rec treeSubsetDomain compareKey tree1 tree2 = - match tree1 with - | Empty -> true - | Tree node1 -> - match tree2 with - | Empty -> false - | Tree node2 -> nodeSubsetDomain compareKey node1 node2 - -and nodeSubsetDomain compareKey node1 node2 = - pointerEqual (node1,node2) || - let Node {size; left; key; right} = node1 in - size <= nodeSize node2 && - let (l,kvo,r) = nodePartition compareKey key node2 in - Option.isSome kvo && - treeSubsetDomain compareKey left l && - treeSubsetDomain compareKey right r -;; - -(* ------------------------------------------------------------------------- *) -(* Picking an arbitrary key/value pair from a tree. *) -(* ------------------------------------------------------------------------- *) - -let rec nodePick node = - let Node {key; value} = node in - (key,value) -;; - -let treePick tree = - match tree with - | Empty -> raise (Bug "Map.treePick") - | Tree node -> nodePick node -;; - -(* ------------------------------------------------------------------------- *) -(* Removing an arbitrary key/value pair from a tree. *) -(* ------------------------------------------------------------------------- *) - -let rec nodeDeletePick node = - let Node {left; key; value; right} = node in - ((key,value), treeAppend left right) -;; - -let treeDeletePick tree = - match tree with - | Empty -> raise (Bug "Map.treeDeletePick") - | Tree node -> nodeDeletePick node -;; - -(* ------------------------------------------------------------------------- *) -(* Finding the nth smallest key/value (counting from 0). *) -(* ------------------------------------------------------------------------- *) - -let rec treeNth n tree = - match tree with - | Empty -> raise (Bug "Map.treeNth") - | Tree node -> nodeNth n node - -and nodeNth n node = - let Node {left; key; value; right} = node in - let k = treeSize left in - if n = k then (key,value) - else if n < k then treeNth n left - else treeNth (n - (k + 1)) right -;; - -(* ------------------------------------------------------------------------- *) -(* Removing the nth smallest key/value (counting from 0). *) -(* ------------------------------------------------------------------------- *) - -let rec treeDeleteNth n tree = - match tree with - | Empty -> raise (Bug "Map.treeDeleteNth") - | Tree node -> nodeDeleteNth n node - -and nodeDeleteNth n node = - let Node {size; priority; left; key; value; right} = node in - let k = treeSize left in - if n = k then ((key,value), treeAppend left right) - else if n < k then - let (key_value,left) = treeDeleteNth n left in - let size = size - 1 in - let node = Node {size = size; priority = priority; left = left; key = key; - value = value; right = right} in - (key_value, Tree node) - else - let n = n - (k + 1) in - let (key_value,right) = treeDeleteNth n right in - let size = size - 1 in - let node = Node {size = size; priority = priority; left = left; key = key; - value = value; right = right} in - (key_value, Tree node) -;; - -(* ------------------------------------------------------------------------- *) -(* Iterators. *) -(* ------------------------------------------------------------------------- *) - -type ('key,'value) iterator = - | Left_to_right_iterator of - ('key * 'value) * ('key,'value) tree * ('key,'value) node list - | Right_to_left_iterator of - ('key * 'value) * ('key,'value) tree * ('key,'value) node list;; - -let fromSpineLeftToRightIterator nodes = - match nodes with - | [] -> None - | node :: nodes -> - let Node {key; value; right} = node in - Some (Left_to_right_iterator ((key,value),right,nodes));; - -let fromSpineRightToLeftIterator nodes = - match nodes with - | [] -> None - | node :: nodes -> - let Node {key; value; left} = node in - Some (Right_to_left_iterator ((key,value),left,nodes));; - -let addLeftToRightIterator nodes tree = - fromSpineLeftToRightIterator (treeLeftSpine nodes tree);; - -let addRightToLeftIterator nodes tree = - fromSpineRightToLeftIterator (treeRightSpine nodes tree);; - -let treeMkIterator tree = addLeftToRightIterator [] tree;; - -let treeMkRevIterator tree = addRightToLeftIterator [] tree;; - -let readIterator iter = - match iter with - | Left_to_right_iterator (key_value,_,_) -> key_value - | Right_to_left_iterator (key_value,_,_) -> key_value -;; - -let advanceIterator iter = - match iter with - | Left_to_right_iterator (_,tree,nodes) -> addLeftToRightIterator nodes tree - | Right_to_left_iterator (_,tree,nodes) -> addRightToLeftIterator nodes tree -;; - -let rec foldIterator f acc io = - match io with - | None -> acc - | Some iter -> - let (key,value) = readIterator iter in - foldIterator f (f (key,value,acc)) (advanceIterator iter) -;; - -let rec findIterator pred io = - match io with - | None -> None - | Some iter -> - let key_value = readIterator iter in - if pred key_value then Some key_value - else findIterator pred (advanceIterator iter) -;; - -let rec firstIterator f io = - match io with - | None -> None - | Some iter -> - let key_value = readIterator iter in - match f key_value with - | None -> firstIterator f (advanceIterator iter) - | s -> s -;; - -let rec compareIterator compareKey compareValue io1 io2 = - match (io1,io2) with - | (None,None) -> Equal - | (None, Some _) -> Less - | (Some _, None) -> Greater - | (Some i1, Some i2) -> - let (k1,v1) = readIterator i1 - and (k2,v2) = readIterator i2 in - match compareKey k1 k2 with - | Less -> Less - | Equal -> - begin - match compareValue v1 v2 with - | Less -> Less - | Equal -> - let io1 = advanceIterator i1 - and io2 = advanceIterator i2 in - compareIterator compareKey compareValue io1 io2 - | Greater -> Greater - end - | Greater -> Greater -;; - -let rec equalIterator equalKey equalValue io1 io2 = - match (io1,io2) with - | (None,None) -> true - | (None, Some _) -> false - | (Some _, None) -> false - | (Some i1, Some i2) -> - let (k1,v1) = readIterator i1 - and (k2,v2) = readIterator i2 in - equalKey k1 k2 && - equalValue v1 v2 && - let io1 = advanceIterator i1 - and io2 = advanceIterator i2 in - equalIterator equalKey equalValue io1 io2 -;; - -(* ------------------------------------------------------------------------- *) -(* A type of finite maps. *) -(* ------------------------------------------------------------------------- *) - -type ('key,'value) map = - Map of ('key -> 'key -> ordering) * ('key,'value) tree;; - -(* ------------------------------------------------------------------------- *) -(* Constructors. *) -(* ------------------------------------------------------------------------- *) - -let newMap compareKey = - let tree = treeNew () in - Map (compareKey,tree) -;; - -let singleton compareKey key_value = - let tree = treeSingleton key_value in - Map (compareKey,tree) -;; - -(* ------------------------------------------------------------------------- *) -(* Map size. *) -(* ------------------------------------------------------------------------- *) - -let size (Map (_,tree)) = treeSize tree;; - -let null m = size m = 0;; - -(* ------------------------------------------------------------------------- *) -(* Querying. *) -(* ------------------------------------------------------------------------- *) - -let peekKey (Map (compareKey,tree)) key = treePeekKey compareKey key tree;; - -let peek (Map (compareKey,tree)) key = treePeek compareKey key tree;; - -let inDomain key m = Option.isSome (peek m key);; - -let get m key = - match peek m key with - | None -> raise (Error "Map.get: element not found") - | Some value -> value;; - -let pick (Map (_,tree)) = treePick tree;; - -let nth (Map (_,tree)) n = treeNth n tree;; - -let random m = - let n = size m in - if n = 0 then raise (Bug "Map.random: empty") - else nth m (randomInt n) -;; - -(* ------------------------------------------------------------------------- *) -(* Adding. *) -(* ------------------------------------------------------------------------- *) - -let insert (Map (compareKey,tree)) key_value = - let tree = treeInsert compareKey key_value tree in - Map (compareKey,tree) -;; - -let insertList m = - let ins key_value acc = insert acc key_value in - List.foldl ins m -;; - -(* ------------------------------------------------------------------------- *) -(* Removing. *) -(* ------------------------------------------------------------------------- *) - -let delete (Map (compareKey,tree)) dkey = - let tree = treeDelete compareKey dkey tree in - Map (compareKey,tree) -;; - -let remove m key = if inDomain key m then delete m key else m;; - -let deletePick (Map (compareKey,tree)) = - let (key_value,tree) = treeDeletePick tree in - (key_value, Map (compareKey,tree)) -;; - -let deleteNth (Map (compareKey,tree)) n = - let (key_value,tree) = treeDeleteNth n tree in - (key_value, Map (compareKey,tree)) -;; - -let deleteRandom m = - let n = size m in - if n = 0 then raise (Bug "Map.deleteRandom: empty") - else deleteNth m (randomInt n) -;; - -(* ------------------------------------------------------------------------- *) -(* Joining (all join operations prefer keys in the second map). *) -(* ------------------------------------------------------------------------- *) - -let merge (first,second,both) (Map (compareKey,tree1)) (Map (_,tree2)) = - let tree = treeMerge compareKey first second both tree1 tree2 in - Map (compareKey,tree) -;; - -let union f (Map (compareKey,tree1)) (Map (_,tree2)) = - let f2 k v = f (k,v) (k,v) in - let tree = treeUnion compareKey f f2 tree1 tree2 in - Map (compareKey,tree) -;; - -let intersect f (Map (compareKey,tree1)) (Map (_,tree2)) = - let tree = treeIntersect compareKey f tree1 tree2 in - Map (compareKey,tree) -;; - -(* ------------------------------------------------------------------------- *) -(* Iterators over maps. *) -(* ------------------------------------------------------------------------- *) - -let mkIterator (Map (_,tree)) = treeMkIterator tree;; - -let mkRevIterator (Map (_,tree)) = treeMkRevIterator tree;; - -(* ------------------------------------------------------------------------- *) -(* Mapping and folding. *) -(* ------------------------------------------------------------------------- *) - -let mapPartial f (Map (compareKey,tree)) = - let tree = treeMapPartial f tree in - Map (compareKey,tree) -;; - -let map f (Map (compareKey,tree)) = - let tree = treeMap f tree in - Map (compareKey,tree) -;; - -let transform f = map (fun (_,value) -> f value);; - -let filter pred = - let f key value = - if pred key value then Some value else None in - mapPartial f -;; - -let partition p = - let np x y = not (p x y) in - fun m -> (filter p m, filter np m) -;; - -let foldl f b m = foldIterator f b (mkIterator m);; - -let foldr f b m = foldIterator f b (mkRevIterator m);; - -let app f m = foldl (fun (key,value,()) -> f (key,value)) () m;; - -(* ------------------------------------------------------------------------- *) -(* Searching. *) -(* ------------------------------------------------------------------------- *) - -let findl p m = findIterator p (mkIterator m);; - -let findr p m = findIterator p (mkRevIterator m);; - -let firstl f m = firstIterator f (mkIterator m);; - -let firstr f m = firstIterator f (mkRevIterator m);; - -let exists p m = Option.isSome (findl p m);; - -let all p = - let np x = not (p x) in - fun m -> not (exists np m) -;; - -let count pred = - let f (k,v,acc) = if pred (k,v) then acc + 1 else acc in - foldl f 0 -;; - -(* ------------------------------------------------------------------------- *) -(* Comparing. *) -(* ------------------------------------------------------------------------- *) - -let compare compareValue m1 m2 = - if pointerEqual (m1,m2) then Equal - else - match Int.compare (size m1) (size m2) with - | Less -> Less - | Equal -> - let Map (compareKey,_) = m1 in - let io1 = mkIterator m1 - and io2 = mkIterator m2 in - compareIterator compareKey compareValue io1 io2 - | Greater -> Greater -;; - -let equal equalValue m1 m2 = - pointerEqual (m1,m2) || - (size m1 = size m2 && - let Map (compareKey,_) = m1 in - let io1 = mkIterator m1 - and io2 = mkIterator m2 in - equalIterator (equalKey compareKey) equalValue io1 io2) -;; - -(* ------------------------------------------------------------------------- *) -(* Set operations on the domain. *) -(* ------------------------------------------------------------------------- *) - -let unionDomain (Map (compareKey,tree1)) (Map (_,tree2)) = - let tree = treeUnionDomain compareKey tree1 tree2 in - Map (compareKey,tree) -;; - -let uncurriedUnionDomain m acc = unionDomain acc m;; -let unionListDomain ms = - match ms with - | [] -> raise (Bug "Map.unionListDomain: no sets") - | m :: ms -> List.foldl uncurriedUnionDomain m ms -;; - -let intersectDomain (Map (compareKey,tree1)) (Map (_,tree2)) = - let tree = treeIntersectDomain compareKey tree1 tree2 in - Map (compareKey,tree) -;; - -let uncurriedIntersectDomain m acc = intersectDomain acc m;; -let intersectListDomain ms = - match ms with - | [] -> raise (Bug "Map.intersectListDomain: no sets") - | m :: ms -> List.foldl uncurriedIntersectDomain m ms;; - -let differenceDomain (Map (compareKey,tree1)) (Map (_,tree2)) = - let tree = treeDifferenceDomain compareKey tree1 tree2 in - Map (compareKey,tree) -;; - -let symmetricDifferenceDomain m1 m2 = - unionDomain (differenceDomain m1 m2) (differenceDomain m2 m1);; - -let equalDomain m1 m2 = equal (kComb (kComb true)) m1 m2;; - -let subsetDomain (Map (compareKey,tree1)) (Map (_,tree2)) = - treeSubsetDomain compareKey tree1 tree2;; - -let disjointDomain m1 m2 = null (intersectDomain m1 m2);; - -(* ------------------------------------------------------------------------- *) -(* Converting to and from lists. *) -(* ------------------------------------------------------------------------- *) - -let keys m = foldr (fun (key,_,l) -> key :: l) [] m;; - -let values m = foldr (fun (_,value,l) -> value :: l) [] m;; - -let toList m = foldr (fun (key,value,l) -> (key,value) :: l) [] m;; - -let fromList compareKey l = - let m = newMap compareKey in - insertList m l -;; - -(* ------------------------------------------------------------------------- *) -(* Pretty-printing. *) -(* ------------------------------------------------------------------------- *) - -let toString m = "<" ^ (if null m then "" else Int.toString (size m)) ^ ">";; - -end (* struct Pmap *) -;; diff --git a/metis/portable.ml b/metis/portable.ml deleted file mode 100644 index 8ab7fbae..00000000 --- a/metis/portable.ml +++ /dev/null @@ -1,13 +0,0 @@ -module Portable = struct - -let pointerEqual (p1, p2) = p1 == p2;; - -let randomInt x = Random.rand () mod x;; - -let randomWord (): Word64.word = - Word64.fromInt (Random.rand ());; - -let critical x = x;; - -end -;; diff --git a/metis/preterm.ml b/metis/preterm.ml deleted file mode 100644 index 9911c91d..00000000 --- a/metis/preterm.ml +++ /dev/null @@ -1,36 +0,0 @@ -module Preterm = struct - -let mk_negp pt = Combp (preterm_of_term `~`, pt);; -let mk_eqp (ps, pt) = Combp (Combp (Constp ("=", dpty), ps), pt);; -let mk_conjp (ps, pt) = Combp (Combp (preterm_of_term `/\`, ps), pt);; -let mk_disjp (ps, pt) = Combp (Combp (preterm_of_term `\/`, ps), pt);; - -let list_mk_combp (h, t) = rev_itlist (fun x acc -> Combp (acc, x)) t h;; - -let list_mk_disjp = function - | [] -> preterm_of_term `F` - | h::t -> itlist (curry mk_disjp) t h;; - -(* typechecking a preterm with constants fails, - therefore we convert constants to variables before type checking - type checking converts the variables back to the corresponding constants -*) -let rec unconst_preterm = function - | Varp (s, pty) -> Varp (s, pty) - | Constp (s, pty) -> Varp (s, pty) - | Combp (l, r) -> Combp (unconst_preterm l, unconst_preterm r) - | Typing (ptm, pty) -> Typing (unconst_preterm ptm, pty) - | _ -> failwith "unconst_preterm";; - -let rec env_of_preterm = function - | Varp (s, pty) -> [(s, pty)] - | Constp (s, pty) -> [] - | Combp (l, r) -> env_of_preterm l @ env_of_preterm r - | Typing (ptm, pty) -> env_of_preterm ptm - | _ -> failwith "env_of_preterm";; - -let env_of_th = env_of_preterm o preterm_of_term o concl;; -let env_of_ths = List.concat o List.map env_of_th;; - -end (* struct Preterm *) -;; diff --git a/metis/proof.ml b/metis/proof.ml deleted file mode 100644 index 7047724d..00000000 --- a/metis/proof.ml +++ /dev/null @@ -1,213 +0,0 @@ -(* ========================================================================= *) -(* PROOFS IN FIRST ORDER LOGIC *) -(* ========================================================================= *) - -module Proof = struct - -(* -open Useful;; -*) - -(* ------------------------------------------------------------------------- *) -(* A type of first order logic proofs. *) -(* ------------------------------------------------------------------------- *) - -type inference = - | Axiom of Literal.literal Mset.set - | Assume of Atom.atom - | Subst of Substitute.subst * Thm.thm - | Resolve of Atom.atom * Thm.thm * Thm.thm - | Refl of Term.term - | Equality of Literal.literal * Term.path * Term.term;; - -type proof = (Thm.thm * inference) list;; - -(* ------------------------------------------------------------------------- *) -(* Reconstructing single inferences. *) -(* ------------------------------------------------------------------------- *) - -let parents = function - | (Axiom _) -> [] - | (Assume _) -> [] - | (Subst (_,th)) -> [th] - | (Resolve (_,th,th')) -> [th;th'] - | (Refl _) -> [] - | (Equality _) -> [];; - -let inferenceToThm = function - | (Axiom cl) -> Thm.axiom cl - | (Assume atm) -> Thm.assume (true,atm) - | (Subst (sub,th)) -> Thm.subst sub th - | (Resolve (atm,th,th')) -> Thm.resolve (true,atm) th th' - | (Refl tm) -> Thm.refl tm - | (Equality (lit,path,r)) -> Thm.equality lit path r;; - -let reconstructSubst cl cl' = - let rec recon = function - | [] -> - raise (Bug "can't reconstruct Subst rule") - | (([],sub) :: others) -> - if Literal.Set.equal (Literal.Set.subst sub cl) cl' then sub - else recon others - | (lit :: lits, sub) :: others -> - let checkLit (lit',acc) = - match total (Literal.matchLiterals sub lit) lit' with - | None -> acc - | Some sub -> (lits,sub) :: acc in - recon (Literal.Set.foldl checkLit others cl') in - Substitute.normalize (recon [(Literal.Set.toList cl, Substitute.empty)]) -;; - -let reconstructResolvant cl1 cl2 cl = - if not (Literal.Set.subset cl1 cl) then - Literal.Set.pick (Literal.Set.difference cl1 cl) - else if not (Literal.Set.subset cl2 cl) then - Literal.negate (Literal.Set.pick (Literal.Set.difference cl2 cl)) - else - (* A useless resolution, but we must reconstruct it anyway *) - let cl1' = Literal.Set.negate cl1 - and cl2' = Literal.Set.negate cl2 in - let lits = Literal.Set.intersectList [cl1;cl1';cl2;cl2'] in - if not (Literal.Set.null lits) then Literal.Set.pick lits - else raise (Bug "can't reconstruct Resolve rule") -;; - -let reconstructEquality cl = - let rec sync s t path (f,a) (f',a') = - if not (Name.equal f f' && length a = length a') then None - else - let itms = enumerate (zip a a') in - match List.filter (fun x -> not (uncurry Term.equal (snd x))) itms with - | [(i,(tm,tm'))] -> - let path = i :: path in - if Term.equal tm s && Term.equal tm' t then - Some (List.rev path) - else - begin - match (tm,tm') with - | (Term.Fn f_a, Term.Fn f_a') -> sync s t path f_a f_a' - | _ -> None - end - | _ -> None in - let recon (neq,(pol,atm),(pol',atm')) = - if pol = pol' then None - else - let (s,t) = Literal.destNeq neq in - let path = - if not (Term.equal s t) then sync s t [] atm atm' - else if not (Atom.equal atm atm') then None - else Atom.find (Term.equal s) atm in - match path with - | Some path -> Some ((pol',atm),path,t) - | None -> None in - let candidates = - match List.partition Literal.isNeq (Literal.Set.toList cl) with - | ([l1],[l2;l3]) -> [(l1,l2,l3);(l1,l3,l2)] - | ([l1;l2],[l3]) -> [(l1,l2,l3);(l1,l3,l2);(l2,l1,l3);(l2,l3,l1)] - | ([l1],[l2]) -> [(l1,l1,l2);(l1,l2,l1)] - | _ -> raise (Bug "reconstructEquality: malformed") in - match first recon candidates with - | Some info -> info - | None -> raise (Bug "can't reconstruct Equality rule") -;; - -let reconstruct cl = function - | (Thm.Axiom,[]) -> Axiom cl - | (Thm.Assume,[]) -> - begin - match Literal.Set.findl Literal.positive cl with - | Some (_,atm) -> Assume atm - | None -> raise (Bug "malformed Assume inference") - end - | (Thm.Subst,[th]) -> - Subst (reconstructSubst (Thm.clause th) cl, th) - | (Thm.Resolve,[th1;th2]) -> - let cl1 = Thm.clause th1 - and cl2 = Thm.clause th2 in - let (pol,atm) = reconstructResolvant cl1 cl2 cl in - if pol then Resolve (atm,th1,th2) else Resolve (atm,th2,th1) - | (Thm.Refl,[]) -> - begin - match Literal.Set.findl (kComb true) cl with - | Some lit -> Refl (Literal.destRefl lit) - | None -> raise (Bug "malformed Refl inference") - end - | (Thm.Equality,[]) -> - let (x,y,z) = (reconstructEquality cl) in - Equality (x,y,z) - | _ -> raise (Bug "malformed inference");; - -let thmToInference th = - let cl = Thm.clause th in - let thmInf = Thm.inference th in - let inf = reconstruct cl thmInf in - inf -;; - -(* ------------------------------------------------------------------------- *) -(* Reconstructing whole proofs. *) -(* ------------------------------------------------------------------------- *) - -let proof th = - let emptyThms : (Literal.literal Mset.set, Thm.thm) Mmap.map = - Literal.Set_map.newMap () in - let rec addThms (th,ths) = - let cl = Thm.clause th in - if Literal.Set_map.inDomain cl ths then ths - else - let (_,pars) = Thm.inference th in - let ths = List.foldl (curry addThms) ths pars in - if Literal.Set_map.inDomain cl ths then ths - else Literal.Set_map.insert ths (cl,th) in - let mkThms th = addThms (th,emptyThms) in - let rec addProof (th,(ths,acc)) = - let cl = Thm.clause th in - match Literal.Set_map.peek ths cl with - | None -> (ths,acc) - | Some th -> - let (_,pars) = Thm.inference th in - let (ths,acc) = List.foldl (curry addProof) (ths,acc) pars in - let ths = Literal.Set_map.delete ths cl in - let acc = (th, thmToInference th) :: acc in - (ths,acc) in - let mkProof ths th = - let (ths,acc) = addProof (th,(ths,[])) in - List.rev acc in - let ths = mkThms th in - let infs = mkProof ths th in - infs -;; - -(* ------------------------------------------------------------------------- *) -(* Free variables. *) -(* ------------------------------------------------------------------------- *) - -let freeIn v = - let free th_inf = - match th_inf with - | (_, Axiom lits) -> Literal.Set.freeIn v lits - | (_, Assume atm) -> Atom.freeIn v atm - | (th, Subst _) -> Thm.freeIn v th - | (_, Resolve _) -> false - | (_, Refl tm) -> Term.freeIn v tm - | (_, Equality (lit,_,tm)) -> - Literal.freeIn v lit || Term.freeIn v tm in - List.exists free -;; - -let freeVars = - let inc (th_inf,set) = - Name.Set.union set - (match th_inf with - | (_, Axiom lits) -> Literal.Set.freeVars lits - | (_, Assume atm) -> Atom.freeVars atm - | (th, Subst _) -> Thm.freeVars th - | (_, Resolve _) -> Name.Set.empty - | (_, Refl tm) -> Term.freeVars tm - | (_, Equality (lit,_,tm)) -> - Name.Set.union (Literal.freeVars lit) (Term.freeVars tm)) in - List.foldl (curry inc) Name.Set.empty -;; - -end (* struct Proof *) -;; diff --git a/metis/pset.ml b/metis/pset.ml deleted file mode 100644 index f91f72ed..00000000 --- a/metis/pset.ml +++ /dev/null @@ -1,270 +0,0 @@ -(* ========================================================================= *) -(* FINITE SETS IMPLEMENTED WITH RANDOMLY BALANCED TREES *) -(* ========================================================================= *) - -module Pset = struct - -(* ------------------------------------------------------------------------- *) -(* A type of finite sets. *) -(* ------------------------------------------------------------------------- *) - -type ('elt,'a) map = ('elt,'a) Pmap.map;; - -type 'elt set = Set of ('elt,unit) map;; - -(* ------------------------------------------------------------------------- *) -(* Converting to and from maps. *) -(* ------------------------------------------------------------------------- *) - -let dest (Set m) = m;; - -let mapPartial f = - let mf elt () = f elt in - fun (Set m) -> Pmap.mapPartial mf m -;; - -let map f = - let mf elt () = f elt in - fun (Set m) -> Pmap.map mf m -;; - -let domain m = Set (Pmap.transform (fun _ _ -> ()) m);; - -(* ------------------------------------------------------------------------- *) -(* Constructors. *) -(* ------------------------------------------------------------------------- *) - -let empty cmp = Set (Pmap.newMap cmp);; - -let singleton cmp elt = Set (Pmap.singleton cmp (elt,()));; - -(* ------------------------------------------------------------------------- *) -(* Set size. *) -(* ------------------------------------------------------------------------- *) - -let null (Set m) = Pmap.null m;; - -let size (Set m) = Pmap.size m;; - -(* ------------------------------------------------------------------------- *) -(* Querying. *) -(* ------------------------------------------------------------------------- *) - -let peek (Set m) elt = - match Pmap.peekKey m elt with - | Some (elt,()) -> Some elt - | None -> None;; - -let member elt (Set m) = Pmap.inDomain elt m;; - -let pick (Set m) = - let (elt,_) = Pmap.pick m in - elt -;; - -let nth (Set m) n = - let (elt,_) = Pmap.nth m n in - elt -;; - -let random (Set m) = - let (elt,_) = Pmap.random m in - elt -;; - -(* ------------------------------------------------------------------------- *) -(* Adding. *) -(* ------------------------------------------------------------------------- *) - -let add (Set m) elt = - let m = Pmap.insert m (elt,()) in - Set m -;; - -let uncurriedAdd elt set = add set elt;; -let addList set = List.foldl uncurriedAdd set;; - -(* ------------------------------------------------------------------------- *) -(* Removing. *) -(* ------------------------------------------------------------------------- *) - -let delete (Set m) elt = - let m = Pmap.delete m elt in - Set m -;; - -let remove (Set m) elt = - let m = Pmap.remove m elt in - Set m -;; - -let deletePick (Set m) = - let ((elt,()),m) = Pmap.deletePick m in - (elt, Set m) -;; - -let deleteNth (Set m) n = - let ((elt,()),m) = Pmap.deleteNth m n in - (elt, Set m) -;; - -let deleteRandom (Set m) = - let ((elt,()),m) = Pmap.deleteRandom m in - (elt, Set m) -;; - -(* ------------------------------------------------------------------------- *) -(* Joining. *) -(* ------------------------------------------------------------------------- *) - -let union (Set m1) (Set m2) = Set (Pmap.unionDomain m1 m2);; - -let unionList sets = - let ms = List.map dest sets in - Set (Pmap.unionListDomain ms) -;; - -let intersect (Set m1) (Set m2) = Set (Pmap.intersectDomain m1 m2);; - -let intersectList sets = - let ms = List.map dest sets in - Set (Pmap.intersectListDomain ms) -;; - -let difference (Set m1) (Set m2) = - Set (Pmap.differenceDomain m1 m2);; - -let symmetricDifference (Set m1) (Set m2) = - Set (Pmap.symmetricDifferenceDomain m1 m2);; - -(* ------------------------------------------------------------------------- *) -(* Pmapping and folding. *) -(* ------------------------------------------------------------------------- *) - -let filter pred = - let mpred (elt,()) = pred elt in - fun (Set m) -> Set (Pmap.filter mpred m) -;; - -let partition pred = - let mpred (elt,()) = pred elt in - fun (Set m) -> - let (m1,m2) = Pmap.partition mpred m in - (Set m1, Set m2) -;; - -let app f = - let mf (elt,()) = f elt in - fun (Set m) -> Pmap.app mf m -;; - -let foldl f = - let mf (elt,(),acc) = f (elt,acc) in - fun acc (Set m) -> Pmap.foldl mf acc m -;; - -let foldr f = - let mf (elt,(),acc) = f (elt,acc) in - fun acc (Set m) -> Pmap.foldr mf acc m -;; - -(* ------------------------------------------------------------------------- *) -(* Searching. *) -(* ------------------------------------------------------------------------- *) - -let findl p = - let mp (elt,()) = p elt in - fun (Set m) -> - match Pmap.findl mp m with - | Some (elt,()) -> Some elt - | None -> None -;; - -let findr p = - let mp (elt,()) = p elt in - fun (Set m) -> - match Pmap.findr mp m with - | Some (elt,()) -> Some elt - | None -> None -;; - -let firstl f = - let mf (elt,()) = f elt in - fun (Set m) -> Pmap.firstl mf m -;; - -let firstr f = - let mf (elt,()) = f elt in - fun (Set m) -> Pmap.firstr mf m -;; - -let exists p = - let mp (elt,()) = p elt in - fun (Set m) -> Pmap.exists mp m -;; - -let all p = - let mp (elt,()) = p elt in - fun (Set m) -> Pmap.all mp m -;; - -let count p = - let mp (elt,()) = p elt in - fun (Set m) -> Pmap.count mp m -;; - -(* ------------------------------------------------------------------------- *) -(* Comparing. *) -(* ------------------------------------------------------------------------- *) - -let compareValue () () = Equal;; - -let equalValue () () = true;; - -let compare (Set m1) (Set m2) = Pmap.compare compareValue m1 m2;; - -let equal (Set m1) (Set m2) = Pmap.equal equalValue m1 m2;; - -let subset (Set m1) (Set m2) = Pmap.subsetDomain m1 m2;; - -let disjoint (Set m1) (Set m2) = Pmap.disjointDomain m1 m2;; - -(* ------------------------------------------------------------------------- *) -(* Converting to and from lists. *) -(* ------------------------------------------------------------------------- *) - -let transform f = - let inc (x,l) = f x :: l in - foldr inc [] -;; - -let toList (Set m) = Pmap.keys m;; - -let fromList cmp elts = addList (empty cmp) elts;; - -(* ------------------------------------------------------------------------- *) -(* Pretty-printing. *) -(* ------------------------------------------------------------------------- *) - -let toString set = - "{" ^ (if null set then "" else Int.toString (size set)) ^ "}";; - -(* ------------------------------------------------------------------------- *) -(* Iterators over sets *) -(* ------------------------------------------------------------------------- *) - -type 'elt iterator = ('elt,unit) Pmap.iterator;; - -let mkIterator (Set m) = Pmap.mkIterator m;; - -let mkRevIterator (Set m) = Pmap.mkRevIterator m;; - -let readIterator iter = - let (elt,()) = Pmap.readIterator iter in - elt -;; - -let advanceIterator iter = Pmap.advanceIterator iter;; - -end (* struct Pset *) -;; diff --git a/metis/random.ml b/metis/random.ml deleted file mode 100644 index 397b21c5..00000000 --- a/metis/random.ml +++ /dev/null @@ -1,21 +0,0 @@ -(* 32-bit RNG from ML for the Working Programmer, converted to using integers. - *) -module Random = struct - -let init, rand, upto = - let a = 16807 in - let m = 2147483647 in - let nextRand seed = - let t = a * seed in - t - m * (t / m) in - let r = ref 1 in - let init n = r := n in - let rand () = - let x = nextRand (!r) in - r := x; - x in - let upto n = rand () mod n in - init, rand, upto;; - -end (* struct Random *) -;; diff --git a/metis/resolution.ml b/metis/resolution.ml deleted file mode 100644 index f49c9795..00000000 --- a/metis/resolution.ml +++ /dev/null @@ -1,81 +0,0 @@ -(* ========================================================================= *) -(* THE RESOLUTION PROOF PROCEDURE *) -(* ========================================================================= *) - -module Resolution = struct - -(* ------------------------------------------------------------------------- *) -(* A type of resolution proof procedures. *) -(* ------------------------------------------------------------------------- *) - -type parameters = Parameters of { - activeP : Active.parameters; - waitingP : Waiting.parameters -};; - -type resolution = Resolution of { - parameters : parameters; - active : Active.active; - waiting : Waiting.waiting -};; - -(* ------------------------------------------------------------------------- *) -(* Basic operations. *) -(* ------------------------------------------------------------------------- *) - -let default = Parameters { - activeP = Active.default; - waitingP = Waiting.default -};; - -let newResolution parameters ths = - let Parameters {activeP; waitingP} = parameters in - let (active,cls) = Active.newActive activeP ths (* cls = factored ths *) in - let waiting = Waiting.newWaiting waitingP cls in - Resolution {parameters = parameters; active = active; waiting = waiting};; - -let active (Resolution {active}) = active;; - -let waiting (Resolution {waiting}) = waiting;; - -(* ------------------------------------------------------------------------- *) -(* The main proof loop. *) -(* ------------------------------------------------------------------------- *) - -type decision = - | Contradiction of Thm.thm - | Satisfiable of Thm.thm list;; - -type state = - | Decided of decision - | Undecided of resolution;; - -let iterate res = - let Resolution {parameters; active; waiting} = res in - match Waiting.remove waiting with - | None -> - let sat = Satisfiable (List.map (fun cl -> cl.Clause.Clause.thm) - (Active.saturation active)) in - Decided sat - | Some ((d,cl),waiting) -> - if Clause.isContradiction cl then - Decided (Contradiction cl.Clause.Clause.thm) - else - let (active,cls) = Active.add active cl in - let waiting = Waiting.add waiting (d,cls) in - let res = - Resolution { - parameters = parameters; - active = active; - waiting = waiting} in - Undecided res -;; - -let rec loop res = - Interrupt.poll (); - match iterate res with - | Decided dec -> dec - | Undecided res -> loop res;; - -end (* struct Resolution *) -;; diff --git a/metis/rewrite.ml b/metis/rewrite.ml deleted file mode 100644 index 62d4fd33..00000000 --- a/metis/rewrite.ml +++ /dev/null @@ -1,441 +0,0 @@ -(* ========================================================================= *) -(* ORDERED REWRITING FOR FIRST ORDER TERMS *) -(* ========================================================================= *) - -module Rewrite = struct - -(* ------------------------------------------------------------------------- *) -(* Orientations of equations. *) -(* ------------------------------------------------------------------------- *) - -type orient = Left_to_right | Right_to_left;; - -let toStringOrient ort = - match ort with - | Left_to_right -> "-->" - | Right_to_left -> "<--";; - - -let toStringOrientOption orto = - match orto with - | Some ort -> toStringOrient ort - | None -> "<->";; - - -(* ------------------------------------------------------------------------- *) -(* A type of rewrite systems. *) -(* ------------------------------------------------------------------------- *) - -type reductionOrder = Term.term * Term.term -> ordering option;; - -type equationId = int;; - -type equation = Rule.equation;; - -type rewrite = Rewrite of { - order : reductionOrder; - known : (int, equation * orient option) Mmap.map; - redexes : (equationId * orient) Term_net.termNet; - subterms : (equationId * bool * Term.path) Term_net.termNet; - waiting : int Mset.set -};; - -let updateWaiting rw waiting = - Rewrite {rw with waiting = waiting};; - -let deleteWaiting rw id = - Rewrite {rw with waiting = Intset.delete rw.Rewrite.waiting id};; - -(* ------------------------------------------------------------------------- *) -(* Basic operations *) -(* ------------------------------------------------------------------------- *) - -let newRewrite order = - Rewrite { - order = order; - known = Intmap.newMap (); - redexes = Term_net.newNet false; - subterms = Term_net.newNet false; - waiting = Intset.empty -};; - -let peek (Rewrite {known}) id = Intmap.peek known id;; - -let size (Rewrite {known}) = Intmap.size known;; - -let equations (Rewrite {known}) = - Intmap.foldr (fun (_,(eqn,_),eqns) -> eqn :: eqns) [] known;; - -(* ------------------------------------------------------------------------- *) -(* Add equations into the system. *) -(* ------------------------------------------------------------------------- *) - -let orderToOrient = function - | None -> None - | Some ord -> - match ord with - | Equal -> raise (Error "Rewrite.orient: reflexive") - | Greater -> Some Left_to_right - | Less -> Some Right_to_left;; - -let ins redexes redex id ort = Term_net.insert redexes (redex,(id,ort));; - -let addRedexes id (((l,r),_),ort) redexes = - match ort with - | None -> ins (ins redexes l id Left_to_right) r id Right_to_left - | Some ort -> - match ort with - | Left_to_right -> ins redexes l id Left_to_right - | Right_to_left -> ins redexes r id Right_to_left -;; - -let add rw (id,eqn) = - let Rewrite {known} = rw in - if Intmap.inDomain id known then rw else - let Rewrite {order; redexes; subterms; waiting} = rw in - let ort = orderToOrient (order (fst eqn)) in - let known = Intmap.insert known (id,(eqn,ort)) in - let redexes = addRedexes id (eqn,ort) redexes in - let waiting = Intset.add waiting id in - Rewrite { - order = order; known = known; redexes = redexes; - subterms = subterms; waiting = waiting} -;; - -let uncurriedAdd (eqn,rw) = add rw eqn;; -let addList rw = List.foldl (curry uncurriedAdd) rw;; - -(* ------------------------------------------------------------------------- *) -(* Rewriting (the order must be a refinement of the rewrite order). *) -(* ------------------------------------------------------------------------- *) - -let reorder (i,_) (j,_) = Int.compare j i;; -let matchingRedexes redexes tm = sort reorder (Term_net.matchNet redexes tm);; - -let wellOriented x y = match (x,y) with - | (None, _) -> true - (* FIXME Something is wrong with nested pattern parsing: - * This used to be | Some Left_to_right, Left_to_right -> ... - * | Some Right_to_left, Right_to_left -> ... - *) - | (Some z, w) -> z = w - | _ -> false;; - -let redexResidue x y = match (x,y) with - | (Left_to_right, ((l_r,_) : equation)) -> l_r - | (Right_to_left, ((l,r),_)) -> (r,l);; - -let orientedEquation dir eqn = match dir with - | Left_to_right -> eqn - | Right_to_left -> Rule.symEqn eqn;; - -let rewrIdConv' order known redexes id tm = - let rewr (id',lr) = - let _ = id <> id' || raise (Error "same theorem") in - let (eqn,ort) = Intmap.get known id' in - let _ = wellOriented ort lr || raise (Error "orientation") in - let (l,r) = redexResidue lr eqn in - let sub = - Substitute.normalize (Substitute.matchTerms Substitute.empty l tm) in - let tm' = Substitute.subst sub r in - let _ = Option.isSome ort || - order (tm,tm') = Some Greater || - raise (Error "order") in - let (_,th) = orientedEquation lr eqn in - (tm', Thm.subst sub th) in - match first (total rewr) (matchingRedexes redexes tm) with - | None -> raise (Error "Rewrite.rewrIdConv: no matching rewrites") - | Some res -> res -;; - -let rewriteIdConv' order known redexes id = - if Intmap.null known then Rule.allConv - else Rule.repeatTopDownConv (rewrIdConv' order known redexes id);; - -let mkNeqConv order lit = - let (l,r) = Literal.destNeq lit in - match order (l,r) with - | None -> raise (Error "incomparable") - | Some ord -> - match ord with - | Less -> - let th = Rule.symmetryRule l r in - fun tm -> - if Term.equal tm r then (l,th) else raise (Error "mkNeqConv: RL") - | Equal -> raise (Error "irreflexive") - | Greater -> - let th = Thm.assume lit in - fun tm -> - if Term.equal tm l then (r,th) else raise (Error "mkNeqConv: LR") -;; - -type neqConvs = Neq_convs of (Literal.literal, Rule.conv) Mmap.map;; - -let neqConvsEmpty = Neq_convs (Literal.Map.newMap ());; - -let neqConvsNull (Neq_convs m) = Literal.Map.null m;; - -let neqConvsAdd order (Neq_convs m) lit = - match total (mkNeqConv order) lit with - | None -> None - | Some conv -> Some (Neq_convs (Literal.Map.insert m (lit,conv)));; - -let mkNeqConvs order = - let add (lit,(neq,lits)) = - match neqConvsAdd order neq lit with - | Some neq -> (neq,lits) - | None -> (neq, Literal.Set.add lits lit) in - Literal.Set.foldl add (neqConvsEmpty,Literal.Set.empty) -;; - -let neqConvsDelete (Neq_convs m) lit = Neq_convs (Literal.Map.delete m lit);; - -let neqConvsToConv (Neq_convs m) = - Rule.firstConv (Literal.Map.foldr (fun (_,c,l) -> c :: l) [] m);; - -let neqConvsFoldl f b (Neq_convs m) = - Literal.Map.foldl (fun (l,_,z) -> f (l,z)) b m;; - -let neqConvsRewrIdLiterule order known redexes id neq = - if Intmap.null known && neqConvsNull neq then Rule.allLiterule - else - let neq_conv = neqConvsToConv neq in - let rewr_conv = rewrIdConv' order known redexes id in - let conv = Rule.orelseConv neq_conv rewr_conv in - let conv = Rule.repeatTopDownConv conv in - Rule.allArgumentsLiterule conv -;; - -let rewriteIdEqn' order known redexes id ((l_r,th) as eqn) = - let (neq,_) = mkNeqConvs order (Thm.clause th) in - let literule = neqConvsRewrIdLiterule order known redexes id neq in - let (strongEqn,lit) = - match Rule.equationLiteral eqn with - | None -> (true, Literal.mkEq l_r) - | Some lit -> (false,lit) in - let (lit',litTh) = literule lit in - if Literal.equal lit lit' then eqn - else - (Literal.destEq lit', - (if strongEqn then th - else if not (Thm.negateMember lit litTh) then litTh - else Thm.resolve lit th litTh));; - -let rewriteIdLiteralsRule' order known redexes id lits th = - let mk_literule = neqConvsRewrIdLiterule order known redexes id in - let rewr_neq_lit (lit, ((changed,neq,lits,th) as acc)) = - let neq = neqConvsDelete neq lit in - let (lit',litTh) = mk_literule neq lit in - if Literal.equal lit lit' then acc - else - let th = Thm.resolve lit th litTh in - match neqConvsAdd order neq lit' with - | Some neq -> (true,neq,lits,th) - | None -> (changed, neq, Literal.Set.add lits lit', th) in - let rec rewr_neq_lits neq lits th = - let (changed,neq,lits,th) = - neqConvsFoldl rewr_neq_lit (false,neq,lits,th) neq in - if changed then rewr_neq_lits neq lits th - else (neq,lits,th) in - let (neq,lits) = mkNeqConvs order lits in - let (neq,lits,th) = rewr_neq_lits neq lits th in - let rewr_literule = mk_literule neq in - let rewr_lit (lit,th) = - if Thm.member lit th then Rule.literalRule rewr_literule lit th else th in - Literal.Set.foldl rewr_lit th lits -;; - -let rewriteIdRule' order known redexes id th = - rewriteIdLiteralsRule' order known redexes id (Thm.clause th) th;; - -let rewrIdConv (Rewrite {known; redexes}) order = - rewrIdConv' order known redexes;; - -let rewrConv rewrite order = rewrIdConv rewrite order (-1);; - -let rewriteIdConv (Rewrite {known; redexes}) order = - rewriteIdConv' order known redexes;; - -let rewriteConv rewrite order = rewriteIdConv rewrite order (-1);; - -let rewriteIdLiteralsRule (Rewrite {known; redexes}) order = - rewriteIdLiteralsRule' order known redexes;; - -let rewriteLiteralsRule rewrite order = - rewriteIdLiteralsRule rewrite order (-1);; - -let rewriteIdRule (Rewrite {known; redexes}) order = - rewriteIdRule' order known redexes;; - -let rewriteRule rewrite order = rewriteIdRule rewrite order (-1);; - -(* ------------------------------------------------------------------------- *) -(* Inter-reduce the equations in the system. *) -(* ------------------------------------------------------------------------- *) - -let addSubterms id (((l,r),_) : equation) subterms = - let addSubterm b ((path,tm),net) = Term_net.insert net (tm,(id,b,path)) in - let subterms = - List.foldl (curry (addSubterm true)) subterms (Term.subterms l) in - let subterms = - List.foldl (curry (addSubterm false)) subterms (Term.subterms r) in - subterms -;; - -let sameRedexes x y z = match (x,y,z) with - | (None,_,_) -> false - | (Some ort, (l0,r0),(l,r)) -> - match ort with - | Left_to_right -> Term.equal l0 l - | Right_to_left -> Term.equal r0 r;; - -let redexResidues x (l,r) = match x with - | None -> [(l,r,false);(r,l,false)] - | Some ort -> - match ort with - | Left_to_right -> [(l,r,true)] - | Right_to_left -> [(r,l,true)];; - -let findReducibles order known subterms id = - let checkValidRewr (l,r,ord) id' left path = - let (((x,y),_),_) = Intmap.get known id' in - let tm = Term.subterm (if left then x else y) path in - let sub = Substitute.matchTerms Substitute.empty l tm in - if ord then () - else - let tm' = Substitute.subst (Substitute.normalize sub) r in - if order (tm,tm') = Some Greater then () - else raise (Error "order") in - let addRed lr ((id',left,path),todo) = - if id <> id' && not (Intset.member id' todo) && - can (checkValidRewr lr id' left) path - then Intset.add todo id' - else todo in - let findRed ((l,_,_) as lr, todo) = - List.foldl (curry (addRed lr)) todo (Term_net.matched subterms l) in - List.foldl (curry findRed) -;; - -let reduce1 newx id (eqn0,ort0) (rpl,spl,todo,rw,changed) = - let (eq0,_) = eqn0 in - let Rewrite {order; known; redexes; subterms; waiting} = rw in - let (eq,_) as eqn = rewriteIdEqn' order known redexes id eqn0 in - let identical = - let (l0,r0) = eq0 - and (l,r) = eq in - Term.equal l l0 && Term.equal r r0 in - let same_redexes = identical || sameRedexes ort0 eq0 eq in - let rpl = if same_redexes then rpl else Intset.add rpl id in - let spl = if newx || identical then spl else Intset.add spl id in - let changed = - if not newx && identical then changed else Intset.add changed id in - let ort = - if same_redexes then Some ort0 else total orderToOrient (order eq) in - match ort with - | None -> - let known = Intmap.delete known id in - let rw = Rewrite { - order = order; known = known; redexes = redexes; - subterms = subterms; waiting = waiting} in - (rpl,spl,todo,rw,changed) - | Some ort -> - let todo = - if not newx && same_redexes then todo - else - findReducibles order known subterms id todo (redexResidues ort eq) in - let known = - if identical then known else Intmap.insert known (id,(eqn,ort)) in - let redexes = if same_redexes then redexes - else addRedexes id (eqn,ort) redexes in - let subterms = - if newx || not identical then addSubterms id eqn subterms - else subterms in - let rw = - Rewrite {order = order; known = known; redexes = redexes; - subterms = subterms; waiting = waiting} in - (rpl,spl,todo,rw,changed) -;; - -let pick known set = - let oriented id = - match Intmap.peek known id with - | Some ((_, Some _) as x) -> Some (id,x) - | _ -> None in - let any id = - match Intmap.peek known id with Some x -> Some (id,x) | _ -> None in - match Intset.firstl oriented set with - | Some _ as x -> x - | None -> Intset.firstl any set -;; - -let cleanRedexes known redexes rpl = - if Intset.null rpl then redexes - else - let filt (id,_) = not (Intset.member id rpl) in - let addReds (id,reds) = - match Intmap.peek known id with - | None -> reds - | Some eqn_ort -> addRedexes id eqn_ort reds in - let redexes = Term_net.filter filt redexes in - let redexes = Intset.foldl addReds redexes rpl in - redexes -;; - -let cleanSubterms known subterms spl = - if Intset.null spl then subterms - else - let filt (id,_,_) = not (Intset.member id spl) in - let addSubtms (id,subtms) = - match Intmap.peek known id with - | None -> subtms - | Some (eqn,_) -> addSubterms id eqn subtms in - let subterms = Term_net.filter filt subterms in - let subterms = Intset.foldl addSubtms subterms spl in - subterms -;; - -let rebuild rpl spl rw = - let Rewrite {order; known; redexes; subterms; waiting} = rw in - let redexes = cleanRedexes known redexes rpl in - let subterms = cleanSubterms known subterms spl in - Rewrite { - order = order; known = known; redexes = redexes; subterms = subterms; - waiting = waiting} -;; - -let rec reduceAcc (rpl, spl, todo, rw, changed) = - let Rewrite {known; waiting} = rw in - match pick known todo with - | Some (id,eqn_ort) -> - let todo = Intset.delete todo id in - reduceAcc (reduce1 false id eqn_ort (rpl,spl,todo,rw,changed)) - | None -> - match pick known waiting with - | Some (id,eqn_ort) -> - let rw = deleteWaiting rw id in - reduceAcc (reduce1 true id eqn_ort (rpl,spl,todo,rw,changed)) - | None -> (rebuild rpl spl rw, Intset.toList changed);; - -let isReduced (Rewrite {waiting}) = Intset.null waiting;; - -let reduce' rw = - if isReduced rw then (rw,[]) - else reduceAcc (Intset.empty,Intset.empty,Intset.empty,rw,Intset.empty);; - -let reduce rw = fst (reduce' rw);; - -(* ------------------------------------------------------------------------- *) -(* Rewriting as a derived rule. *) -(* ------------------------------------------------------------------------- *) - -let addEqn id_eqn rw = add rw id_eqn;; -let orderedRewrite order ths = - let rw = List.foldl addEqn (newRewrite order) (enumerate ths) in - rewriteRule rw order -;; - -let order : reductionOrder = kComb (Some Greater);; -let rewrite = orderedRewrite order;; - -end (* struct Rewrite *) -;; diff --git a/metis/rule.ml b/metis/rule.ml deleted file mode 100644 index 36262297..00000000 --- a/metis/rule.ml +++ /dev/null @@ -1,621 +0,0 @@ -(* ========================================================================= *) -(* DERIVED RULES FOR CREATING FIRST ORDER LOGIC THEOREMS *) -(* ========================================================================= *) - -module Rule = struct - -(* ------------------------------------------------------------------------- *) -(* Variable names. *) -(* ------------------------------------------------------------------------- *) - -let xVarName = Name.fromString "x";; -let xVar = Term.Var_ xVarName;; - -let yVarName = Name.fromString "y";; -let yVar = Term.Var_ yVarName;; - -let zVarName = Name.fromString "z";; -let zVar = Term.Var_ zVarName;; - -let xIVarName i = Name.fromString ("x" ^ Int.toString i);; -let xIVar i = Term.Var_ (xIVarName i);; - -let yIVarName i = Name.fromString ("y" ^ Int.toString i);; -let yIVar i = Term.Var_ (yIVarName i);; - -(* ------------------------------------------------------------------------- *) -(* *) -(* --------- reflexivity *) -(* x = x *) -(* ------------------------------------------------------------------------- *) - -let reflexivityRule x = Thm.refl x;; - -let reflexivity = reflexivityRule xVar;; - -(* ------------------------------------------------------------------------- *) -(* *) -(* --------------------- symmetry *) -(* ~(x = y) \/ y = x *) -(* ------------------------------------------------------------------------- *) - -let symmetryRule x y = - let reflTh = reflexivityRule x in - let reflLit = Thm.destUnit reflTh in - let eqTh = Thm.equality reflLit [0] y in - Thm.resolve reflLit reflTh eqTh -;; - -let symmetry = symmetryRule xVar yVar;; - -(* ------------------------------------------------------------------------- *) -(* *) -(* --------------------------------- transitivity *) -(* ~(x = y) \/ ~(y = z) \/ x = z *) -(* ------------------------------------------------------------------------- *) - -let transitivity = - let eqTh = Thm.equality (Literal.mkEq (yVar,zVar)) [0] xVar in - Thm.resolve (Literal.mkEq (yVar,xVar)) symmetry eqTh -;; - -(* ------------------------------------------------------------------------- *) -(* x = y \/ C *) -(* -------------- symEq (x = y) *) -(* y = x \/ C *) -(* ------------------------------------------------------------------------- *) - -let symEq lit th = - let (x,y) = Literal.destEq lit in - if Term.equal x y then th - else - let sub = Substitute.fromList [(xVarName,x);(yVarName,y)] in - let symTh = Thm.subst sub symmetry in - Thm.resolve lit th symTh -;; - -(* ------------------------------------------------------------------------- *) -(* An equation consists of two terms (t,u) plus a theorem (stronger than) *) -(* t = u \/ C. *) -(* ------------------------------------------------------------------------- *) - -type equation = (Term.term * Term.term) * Thm.thm;; - -let equationLiteral (t_u,th) = - let lit = Literal.mkEq t_u in - if Literal.Set.member lit (Thm.clause th) then Some lit else None -;; - -let reflEqn t = ((t,t), Thm.refl t);; - -let symEqn (((t,u), th) as eqn) = - if Term.equal t u then eqn - else - ((u,t), match equationLiteral eqn with - | Some t_u -> symEq t_u th - | None -> th);; - -let transEqn (((x,y), th1) as eqn1) (((_,z), th2) as eqn2) = - if Term.equal x y then eqn2 - else if Term.equal y z then eqn1 - else if Term.equal x z then reflEqn x - else - ((x,z), match equationLiteral eqn1 with - | None -> th1 - | Some x_y -> - match equationLiteral eqn2 with - | None -> th2 - | Some y_z -> - let sub = - Substitute.fromList [(xVarName,x); (yVarName,y); - (zVarName,z)] in - let th = Thm.subst sub transitivity in - let th = Thm.resolve x_y th1 th in - let th = Thm.resolve y_z th2 th in - th);; - -(* ------------------------------------------------------------------------- *) -(* A conversion takes a term t and either: *) -(* 1. Returns a term u together with a theorem (stronger than) t = u \/ C. *) -(* 2. Raises an Error exception. *) -(* ------------------------------------------------------------------------- *) - -type conv = Term.term -> Term.term * Thm.thm;; - -let allConv tm = (tm, Thm.refl tm);; - -let noConv : conv = fun _ -> raise (Error "noConv");; - -let thenConvTrans tm (tm',th1) (tm'',th2) = - let eqn1 = ((tm,tm'),th1) - and eqn2 = ((tm',tm''),th2) in - let (_,th) = transEqn eqn1 eqn2 in - (tm'',th) -;; - -let thenConv conv1 conv2 tm = - let (tm',_) as res1 = conv1 tm in - let res2 = conv2 tm' in - thenConvTrans tm res1 res2 -;; - -let orelseConv (conv1 : conv) conv2 tm = try conv1 tm with Error _ -> conv2 tm;; - -let tryConv conv = orelseConv conv allConv;; - -let changedConv conv tm = - let (tm',_) as res = conv tm in - if tm = tm' then raise (Error "changedConv") else res -;; - -let rec repeatConv conv tm = tryConv (thenConv conv (repeatConv conv)) tm;; - -let flip f = fun x y -> f y x;; - -let rec firstConv tm = function - | [] -> raise (Error "firstConv") - | [conv] -> conv tm - | (conv :: convs) -> orelseConv conv (flip firstConv convs) tm;; -let firstConv convs tm = firstConv tm convs;; - -let rec everyConv tm = function - | [] -> allConv tm - | [conv] -> conv tm - | (conv :: convs) -> thenConv conv (flip everyConv convs) tm;; -let everyConv convs tm = everyConv tm convs;; - -let rewrConv (((x,y), eqTh) as eqn) path tm = - if Term.equal x y then allConv tm - else if List.null path then (y,eqTh) - else - let reflTh = Thm.refl tm in - let reflLit = Thm.destUnit reflTh in - let th = Thm.equality reflLit (1 :: path) y in - let th = Thm.resolve reflLit reflTh th in - let th = - match equationLiteral eqn with - | None -> th - | Some x_y -> Thm.resolve x_y eqTh th in - let tm' = Term.replace tm (path,y) in - (tm',th) -;; - -let pathConv conv path tm = - let x = Term.subterm tm path in - let (y,th) = conv x in - rewrConv ((x,y),th) path tm -;; - -let subtermConv conv i = pathConv conv [i];; - -let subtermsConv conv = function - | (Term.Var_ _ as tm) -> allConv tm - | (Term.Fn (_,a) as tm) -> - everyConv (List.map (subtermConv conv) (interval 0 (length a))) tm;; - -(* ------------------------------------------------------------------------- *) -(* Applying a conversion to every subterm, with some traversal strategy. *) -(* ------------------------------------------------------------------------- *) - -let rec bottomUpConv conv tm = - thenConv (subtermsConv (bottomUpConv conv)) (repeatConv conv) tm;; - -let rec topDownConv conv tm = - thenConv (repeatConv conv) (subtermsConv (topDownConv conv)) tm;; - -let repeatTopDownConv conv = - let rec f tm = thenConv (repeatConv conv) g tm - and g tm = thenConv (subtermsConv f) h tm - and h tm = tryConv (thenConv conv f) tm in - f -;; - -(* ------------------------------------------------------------------------- *) -(* A literule (bad pun) takes a literal L and either: *) -(* 1. Returns a literal L' with a theorem (stronger than) ~L \/ L' \/ C. *) -(* 2. Raises an Error exception. *) -(* ------------------------------------------------------------------------- *) - -type literule = Literal.literal -> Literal.literal * Thm.thm;; - -let allLiterule lit = (lit, Thm.assume lit);; - -let noLiterule : literule = fun _ -> raise (Error "noLiterule");; - -let thenLiterule literule1 literule2 lit = - let (lit',th1) as res1 = literule1 lit in - let (lit'',th2) as res2 = literule2 lit' in - if Literal.equal lit lit' then res2 - else if Literal.equal lit' lit'' then res1 - else if Literal.equal lit lit'' then allLiterule lit - else - (lit'', - (if not (Thm.member lit' th1) then th1 - else if not (Thm.negateMember lit' th2) then th2 - else Thm.resolve lit' th1 th2)) -;; - -let orelseLiterule (literule1 : literule) literule2 lit = - try literule1 lit with Error _ -> literule2 lit;; - -let tryLiterule literule = orelseLiterule literule allLiterule;; - -let changedLiterule literule lit = - let (lit',_) as res = literule lit in - if lit = lit' then raise (Error "changedLiterule") else res -;; - -let rec repeatLiterule literule lit = - tryLiterule (thenLiterule literule (repeatLiterule literule)) lit;; - -let rec firstLiterule lit = function - | [] -> raise (Error "firstLiterule") - | [literule] -> literule lit - | (literule :: literules) -> - orelseLiterule literule (flip firstLiterule literules) lit;; -let firstLiterule literules lit = firstLiterule lit literules;; - -let rec everyLiterule lit = function - | [] -> allLiterule lit - | [literule] -> literule lit - | (literule :: literules) -> - thenLiterule literule (flip everyLiterule literules) lit;; -let everyLiterule literules lit = everyLiterule lit literules;; - -let rewrLiterule (((x,y),eqTh) as eqn) path lit = - if Term.equal x y then allLiterule lit - else - let th = Thm.equality lit path y in - let th = match equationLiteral eqn with - | None -> th - | Some x_y -> Thm.resolve x_y eqTh th in - let lit' = Literal.replace lit (path,y) in - (lit',th) -;; - -let pathLiterule conv path lit = - let tm = Literal.subterm lit path in - let (tm',th) = conv tm in - rewrLiterule ((tm,tm'),th) path lit -;; - -let argumentLiterule conv i = pathLiterule conv [i];; - -let allArgumentsLiterule conv lit = - everyLiterule - (List.map (argumentLiterule conv) (interval 0 (Literal.arity lit))) lit;; - -(* ------------------------------------------------------------------------- *) -(* A rule takes one theorem and either deduces another or raises an Error *) -(* exception. *) -(* ------------------------------------------------------------------------- *) - -type rule = Thm.thm -> Thm.thm;; - -let allRule : rule = fun th -> th;; - -let noRule : rule = fun _ -> raise (Error "noRule");; - -let thenRule (rule1 : rule) (rule2 : rule) th = rule1 (rule2 th);; - -let orelseRule (rule1 : rule) rule2 th = try rule1 th with Error _ -> rule2 th;; - -let tryRule rule = orelseRule rule allRule;; - -let changedRule rule th = - let th' = rule th in - if not (Literal.Set.equal (Thm.clause th) (Thm.clause th')) then th' - else raise (Error "changedRule") -;; - -let rec repeatRule rule lit = tryRule (thenRule rule (repeatRule rule)) lit;; - -let rec firstRule th = function - | [] -> raise (Error "firstRule") - | [rule] -> rule th - | (rule :: rules) -> orelseRule rule (flip firstRule rules) th;; -let firstRule rules th = firstRule th rules;; - -let rec everyRule th = function - | [] -> allRule th - | [rule] -> rule th - | (rule :: rules) -> thenRule rule (flip everyRule rules) th;; -let everyRule rules th = everyRule th rules;; - -let literalRule literule lit th = - let (lit',litTh) = literule lit in - if Literal.equal lit lit' then th - else if not (Thm.negateMember lit litTh) then litTh - else Thm.resolve lit th litTh -;; - -let rewrRule eqTh lit path = literalRule (rewrLiterule eqTh path) lit;; - -let pathRule conv lit path = literalRule (pathLiterule conv path) lit;; - -let literalsRule literule = - let f (lit,th) = - if Thm.member lit th then literalRule literule lit th else th in - fun lits -> fun th -> Literal.Set.foldl f th lits -;; - -let allLiteralsRule literule th = literalsRule literule (Thm.clause th) th;; - -let convRule conv = allLiteralsRule (allArgumentsLiterule conv);; - -(* ------------------------------------------------------------------------- *) -(* *) -(* ---------------------------------------------- functionCongruence (f,n) *) -(* ~(x0 = y0) \/ ... \/ ~(x{n-1} = y{n-1}) \/ *) -(* f x0 ... x{n-1} = f y0 ... y{n-1} *) -(* ------------------------------------------------------------------------- *) - -let functionCongruence (f,n) = - let xs = List.tabulate n xIVar - and ys = List.tabulate n yIVar in - let cong ((i,yi),(th,lit)) = - let path = [1;i] in - let th = Thm.resolve lit th (Thm.equality lit path yi) in - let lit = Literal.replace lit (path,yi) in - (th,lit) in - let reflTh = Thm.refl (Term.Fn (f,xs)) in - let reflLit = Thm.destUnit reflTh in - fst (List.foldl (curry cong) (reflTh,reflLit) (enumerate ys)) -;; - -(* ------------------------------------------------------------------------- *) -(* *) -(* ---------------------------------------------- relationCongruence (R,n) *) -(* ~(x0 = y0) \/ ... \/ ~(x{n-1} = y{n-1}) \/ *) -(* ~R x0 ... x{n-1} \/ R y0 ... y{n-1} *) -(* ------------------------------------------------------------------------- *) - -let relationCongruence (r,n) = - let xs = List.tabulate n xIVar - and ys = List.tabulate n yIVar in - let cong ((i,yi),(th,lit)) = - let path = [i] in - let th = Thm.resolve lit th (Thm.equality lit path yi) in - let lit = Literal.replace lit (path,yi) in - (th,lit) in - let assumeLit = (false,(r,xs)) in - let assumeTh = Thm.assume assumeLit in - fst (List.foldl (curry cong) (assumeTh,assumeLit) (enumerate ys)) -;; - -(* ------------------------------------------------------------------------- *) -(* ~(x = y) \/ C *) -(* ----------------- symNeq ~(x = y) *) -(* ~(y = x) \/ C *) -(* ------------------------------------------------------------------------- *) - -let symNeq lit th = - let (x,y) = Literal.destNeq lit in - if Term.equal x y then th - else - let sub = Substitute.fromList [(xVarName,y);(yVarName,x)] in - let symTh = Thm.subst sub symmetry in - Thm.resolve lit th symTh -;; - -(* ------------------------------------------------------------------------- *) -(* sym (x = y) = symEq (x = y) /\ sym ~(x = y) = symNeq ~(x = y) *) -(* ------------------------------------------------------------------------- *) - -let sym ((pol,_) as lit) th = if pol then symEq lit th else symNeq lit th;; - -(* ------------------------------------------------------------------------- *) -(* ~(x = x) \/ C *) -(* ----------------- removeIrrefl *) -(* C *) -(* *) -(* where all irreflexive equalities. *) -(* ------------------------------------------------------------------------- *) - -let removeIrrefl th = - let irrefl = function - | ((true,_),th) -> th - | ((false,atm) as lit, th) -> - match total Atom.destRefl atm with - | Some x -> Thm.resolve lit th (Thm.refl x) - | None -> th in - Literal.Set.foldl irrefl th (Thm.clause th);; - -(* ------------------------------------------------------------------------- *) -(* x = y \/ y = x \/ C *) -(* ----------------------- removeSym *) -(* x = y \/ C *) -(* *) -(* where all duplicate copies of equalities and disequalities are removed. *) -(* ------------------------------------------------------------------------- *) - -let removeSym th = - let rem ((pol,atm) as lit, (eqs,th)) = - match total Atom.sym atm with - | None -> (eqs, th) - | Some atm' -> - if Literal.Set.member lit eqs then - (eqs, (if pol then symEq lit th else symNeq lit th)) - else - (Literal.Set.add eqs (pol,atm'), th) in - snd (Literal.Set.foldl rem (Literal.Set.empty,th) (Thm.clause th));; - -(* ------------------------------------------------------------------------- *) -(* ~(v = t) \/ C *) -(* ----------------- expandAbbrevs *) -(* C[t/v] *) -(* *) -(* where t must not contain any occurrence of the variable v. *) -(* ------------------------------------------------------------------------- *) - -let rec expandAbbrevs th = - let expand lit = - let (x,y) = Literal.destNeq lit in - let _ = Term.isTypedVar x || Term.isTypedVar y || - raise (Error "Rule.expandAbbrevs: no vars") in - let _ = not (Term.equal x y) || - raise (Error "Rule.expandAbbrevs: equal vars") in - Substitute.unify Substitute.empty x y in - match Literal.Set.firstl (total expand) (Thm.clause th) with - | None -> removeIrrefl th - | Some sub -> expandAbbrevs (Thm.subst sub th);; - -(* ------------------------------------------------------------------------- *) -(* simplify = isTautology + expandAbbrevs + removeSym *) -(* ------------------------------------------------------------------------- *) - -let rec simplify th = - if Thm.isTautology th then None - else - let th' = th in - let th' = expandAbbrevs th' in - let th' = removeSym th' in - if Thm.equal th th' then Some th else simplify th' -;; - -(* ------------------------------------------------------------------------- *) -(* C *) -(* -------- freshVars *) -(* C[s] *) -(* *) -(* where s is a renaming substitution chosen so that all of the variables in *) -(* C are replaced by fresh variables. *) -(* ------------------------------------------------------------------------- *) - -let freshVars th = Thm.subst (Substitute.freshVars (Thm.freeVars th)) th;; - -(* ------------------------------------------------------------------------- *) -(* C *) -(* ---------------------------- factor *) -(* C_s_1, C_s_2, ..., C_s_n *) -(* *) -(* where each s_i is a substitution that factors C, meaning that the theorem *) -(* *) -(* C_s_i = (removeIrrefl o removeSym o Thm.subst s_i) C *) -(* *) -(* has fewer literals than C. *) -(* *) -(* Also, if s is any substitution that factors C, then one of the s_i will *) -(* result in a theorem C_s_i that strictly subsumes the theorem C_s. *) -(* ------------------------------------------------------------------------- *) - -type edge = - | Factor_edge of Atom.atom * Atom.atom - | Refl_edge of Term.term * Term.term;; - -type joinStatus = - | Joined - | Joinable of Substitute.subst - | Apart;; - -let joinEdge sub edge = - let result = - match edge with - | Factor_edge (atm,atm') -> total (Atom.unify sub atm) atm' - | Refl_edge (tm,tm') -> total (Substitute.unify sub tm) tm' in - match result with - | None -> Apart - | Some sub' -> - if Portable.pointerEqual (sub,sub') then Joined else Joinable sub' -;; - -let updateApart sub = - let rec update acc = function - | [] -> Some acc - | edge :: edges -> - match joinEdge sub edge with - | Joined -> None - | Joinable _ -> update (edge :: acc) edges - | Apart -> update acc edges in - update [] -;; - -let addFactorEdge (pol,atm) ((pol',atm'),acc) = - if pol <> pol' then acc else - let edge = Factor_edge (atm,atm') in - match joinEdge Substitute.empty edge with - | Joined -> raise (Bug "addFactorEdge: joined") - | Joinable sub -> (sub,edge) :: acc - | Apart -> acc -;; - -let addReflEdge = function - | ((false,_), acc) -> acc - | ((true,atm), acc) -> - let edge = let (x,y) = (Atom.destEq atm) in Refl_edge (x,y) in - match joinEdge Substitute.empty edge with - | Joined -> raise (Bug "addRefl: joined") - | Joinable _ -> edge :: acc - | Apart -> acc -;; -let addReflEdge = curry addReflEdge;; - -let addIrreflEdge = function - | ((true,_), acc) -> acc - | ((false,atm), acc) -> - let edge = let (x,y) = (Atom.destEq atm) in Refl_edge (x,y) in - match joinEdge Substitute.empty edge with - | Joined -> raise (Bug "addRefl: joined") - | Joinable sub -> (sub,edge) :: acc - | Apart -> acc -;; -let addIrreflEdge = curry addIrreflEdge;; - -let rec init_edges acc apart = function - | [] -> - let init ((apart,sub,edge),(edges,acc)) = - (edge :: edges, (apart,sub,edges) :: acc) in - snd (List.foldl (curry init) ([],[]) acc) - | ((sub,edge) :: sub_edges) -> - let (acc,apart) = - match updateApart sub apart with - | Some apart' -> ((apart',sub,edge) :: acc, edge :: apart) - | None -> (acc,apart) in - init_edges acc apart sub_edges -;; - -let rec mk_edges apart sub_edges = function - | [] -> init_edges [] apart sub_edges - | lit :: lits -> - let sub_edges = List.foldl (curry (addFactorEdge lit)) sub_edges lits in - let (apart,sub_edges) = - match total Literal.sym lit with - | None -> (apart,sub_edges) - | Some lit' -> - let apart = addReflEdge lit apart in - let sub_edges = addIrreflEdge lit sub_edges in - let sub_edges = List.foldl (curry (addFactorEdge lit')) sub_edges lits in - (apart,sub_edges) in - mk_edges apart sub_edges lits -;; - -let rec fact acc = function - | [] -> acc - | ((_,sub,[]) :: others) -> fact (sub :: acc) others - | ((apart, sub, edge :: edges) :: others) -> - let others = - match joinEdge sub edge with - | Joinable sub' -> - let others = (edge :: apart, sub, edges) :: others in - begin - match updateApart sub' apart with - | None -> others - | Some apart' -> (apart',sub',edges) :: others - end - | _ -> (apart,sub,edges) :: others in - fact acc others -;; - -let factor' cl = - let edges = mk_edges [] [] (Literal.Set.toList cl) in - let result = fact [] edges in - result -;; - -let factor th = - let fact sub = removeIrrefl (removeSym (Thm.subst sub th)) in - List.map fact (factor' (Thm.clause th)) -;; - -end (* struct Rule *) -;; diff --git a/metis/sharing.ml b/metis/sharing.ml deleted file mode 100644 index b3c541e8..00000000 --- a/metis/sharing.ml +++ /dev/null @@ -1,4 +0,0 @@ -module Sharing = struct -let map = List.map;; -end (* struct Sharing *) -;; diff --git a/metis/substitute.ml b/metis/substitute.ml deleted file mode 100644 index 86558aca..00000000 --- a/metis/substitute.ml +++ /dev/null @@ -1,213 +0,0 @@ -(* ========================================================================= *) -(* FIRST ORDER LOGIC SUBSTITUTIONS *) -(* ========================================================================= *) - -module Substitute = struct - -(* ------------------------------------------------------------------------- *) -(* A type of first order logic substitutions. *) -(* ------------------------------------------------------------------------- *) - -type subst = Subst of (Name.name, Term.term) Mmap.map;; - -(* ------------------------------------------------------------------------- *) -(* Basic operations. *) -(* ------------------------------------------------------------------------- *) - -let empty = Subst (Name.Map.newMap ());; - -let null (Subst m) = Name.Map.null m;; - -let size (Subst m) = Name.Map.size m;; - -let peek (Subst m) v = Name.Map.peek m v;; - -let insert (Subst m) v_tm = Subst (Name.Map.insert m v_tm);; - -let singleton v_tm = insert empty v_tm;; - -let toList (Subst m) = Name.Map.toList m;; - -let fromList l = Subst (Name.Map.fromList l);; - -let foldl f b (Subst m) = Name.Map.foldl f b m;; - -let foldr f b (Subst m) = Name.Map.foldr f b m;; - - -(* ------------------------------------------------------------------------- *) -(* Normalizing removes identity substitutions. *) -(* ------------------------------------------------------------------------- *) - -let normalize (Subst m as sub) = - let isNotId (v, tm) = not (Term.equalVar v tm) in - let m' = Name.Map.filter isNotId m in - if Name.Map.size m = Name.Map.size m' then sub else Subst m' -;; - -(* ------------------------------------------------------------------------- *) -(* Applying a substitution to a first order logic term. *) -(* ------------------------------------------------------------------------- *) - -let subst sub = - let rec tmSub = function - | Term.Var_ v as tm -> - begin - match peek sub v with - | Some tm' -> if Portable.pointerEqual (tm,tm') then tm else tm' - | None -> tm - end - | Term.Fn (f,args) as tm -> - let args' = Sharing.map tmSub args in - if Portable.pointerEqual (args,args') then tm - else Term.Fn (f,args') in - fun tm -> if null sub then tm else tmSub tm -;; - -(* ------------------------------------------------------------------------- *) -(* Restricting a substitution to a given set of variables. *) -(* ------------------------------------------------------------------------- *) - -let restrict (Subst m as sub) varSet = - let isRestrictedVar (v, _) = Name.Set.member v varSet in - let m' = Name.Map.filter isRestrictedVar m in - if Name.Map.size m = Name.Map.size m' then sub else Subst m' -;; - -let remove (Subst m as sub) varSet = - let isRestrictedVar (v, _) = not (Name.Set.member v varSet) in - let m' = Name.Map.filter isRestrictedVar m in - if Name.Map.size m = Name.Map.size m' then sub else Subst m' -;; - -(* ------------------------------------------------------------------------- *) -(* Composing two substitutions so that the following identity holds: *) -(* *) -(* subst (compose sub1 sub2) tm = subst sub2 (subst sub1 tm) *) -(* ------------------------------------------------------------------------- *) - -let compose (Subst m1 as sub1) sub2 = - let f (v,tm,s) = insert s (v, subst sub2 tm) in - if null sub2 then sub1 else Name.Map.foldl f sub2 m1 -;; - -(* ------------------------------------------------------------------------- *) -(* Creating the union of two compatible substitutions. *) -(* ------------------------------------------------------------------------- *) - -let union (Subst m1 as s1) (Subst m2 as s2) = - let compatible ((_,tm1),(_,tm2)) = - if Term.equal tm1 tm2 then Some tm1 - else raise (Error "Substitute.union: incompatible") in - if Name.Map.null m1 then s2 - else if Name.Map.null m2 then s1 - else Subst (Name.Map.union compatible m1 m2) -;; - -(* ------------------------------------------------------------------------- *) -(* Substitutions can be inverted iff they are renaming substitutions. *) -(* ------------------------------------------------------------------------- *) - -let invert (Subst m) = - let inv = function - | (v, Term.Var_ w, s) -> - if Name.Map.inDomain w s then - raise (Error "Substitute.invert: non-injective") - else - Name.Map.insert s (w, Term.Var_ v) - | (_, Term.Fn _, _) -> raise (Error "Substitute.invert: non-variable") in - Subst (Name.Map.foldl inv (Name.Map.newMap ()) m) -;; - -let isRenaming = can invert;; - -(* ------------------------------------------------------------------------- *) -(* Creating a substitution to freshen variables. *) -(* ------------------------------------------------------------------------- *) - -let freshVars s = - let add (v, m) = insert m (v, Term.newVar ()) in - Name.Set.foldl add empty s -;; - -(* ------------------------------------------------------------------------- *) -(* Free variables. *) -(* ------------------------------------------------------------------------- *) - -let redexes = - let add (v,_,s) = Name.Set.add s v in - foldl add Name.Set.empty -;; - -let residueFreeVars = - let add (_,t,s) = Name.Set.union s (Term.freeVars t) in - foldl add Name.Set.empty -;; - -let freeVars = - let add (v,t,s) = Name.Set.union (Name.Set.add s v) (Term.freeVars t) in - foldl add Name.Set.empty -;; - -(* ------------------------------------------------------------------------- *) -(* Functions. *) -(* ------------------------------------------------------------------------- *) - -let functions = - let add (_,t,s) = Name_arity.Set.union s (Term.functions t) in - foldl add Name_arity.Set.empty -;; - -(* ------------------------------------------------------------------------- *) -(* Matching for first order logic terms. *) -(* ------------------------------------------------------------------------- *) - -let matchTerms sub tm1 tm2 = - let rec matchList sub = function - | [] -> sub - | (Term.Var_ v, tm) :: rest -> - let sub = - match peek sub v with - | None -> insert sub (v,tm) - | Some tm' -> - if Term.equal tm tm' then sub - else raise (Error "Substitute.match: incompatible matches") in - matchList sub rest - | ((Term.Fn (f1,args1), Term.Fn (f2,args2)) :: rest) -> - if Name.equal f1 f2 && length args1 = length args2 then - matchList sub (zip args1 args2 @ rest) - else raise (Error "Substitute.match: different structure") - | _ -> raise (Error "Substitute.match: functions can't match vars") in - matchList sub [(tm1,tm2)] -;; - -(* ------------------------------------------------------------------------- *) -(* Unification for first order logic terms. *) -(* ------------------------------------------------------------------------- *) - -let unify sub tm1 tm2 = - let rec solve sub = function - | [] -> sub - | (((tm1,tm2) as tm1_tm2) :: rest) -> - if Portable.pointerEqual tm1_tm2 then solve sub rest - else solve' sub (subst sub tm1, subst sub tm2, rest) - and solve' sub = function - | ((Term.Var_ v), tm, rest) -> - if Term.equalVar v tm then solve sub rest - else if Term.freeIn v tm then raise (Error "Substitute.unify: occurs check") - else - begin - match peek sub v with - | None -> solve (compose sub (singleton (v,tm))) rest - | Some tm' -> solve' sub (tm', tm, rest) - end - | (tm1, ((Term.Var_ _) as tm2), rest) -> solve' sub (tm2, tm1, rest) - | (Term.Fn (f1,args1), Term.Fn (f2,args2), rest) -> - if Name.equal f1 f2 && length args1 = length args2 then - solve sub (zip args1 args2 @ rest) - else - raise (Error "Substitute.unify: different structure") in - solve sub [(tm1,tm2)];; - -end (* struct Substitute *) -;; diff --git a/metis/subsume.ml b/metis/subsume.ml deleted file mode 100644 index 715fa132..00000000 --- a/metis/subsume.ml +++ /dev/null @@ -1,243 +0,0 @@ -(* ========================================================================= *) -(* SUBSUMPTION CHECKING FOR FIRST ORDER LOGIC CLAUSES *) -(* ========================================================================= *) - -module Subsume = struct - -(* ------------------------------------------------------------------------- *) -(* Helper functions. *) -(* ------------------------------------------------------------------------- *) - -let findRest pred = - let rec f ys = function - | [] -> None - | (x :: xs) -> - if pred x then Some (x, rev_append ys xs) else f (x :: ys) xs in - f [] -;; - -let addSym (lit,acc) = - match total Literal.sym lit with - | None -> acc - | Some lit -> lit :: acc -let clauseSym lits = List.foldl (curry addSym) lits lits;; - - -let sortClause cl = - let lits = Literal.Set.toList cl in - sortMap Literal.typedSymbols (revCompare Int.compare) lits -;; - -let incompatible lit = - let lits = clauseSym [lit] in - fun lit' -> not (List.exists (can (Literal.unify Substitute.empty lit')) lits) -;; - -(* ------------------------------------------------------------------------- *) -(* Clause ids and lengths. *) -(* ------------------------------------------------------------------------- *) - -type clauseId = int;; - -type clauseLength = int;; - -type idSet = (clauseId * clauseLength) Pset.set;; - -let idCompare (id1,len1) (id2,len2) = - match Int.compare len1 len2 with - | Less -> Less - | Equal -> Int.compare id1 id2 - | Greater -> Greater;; - -let idSetEmpty : idSet = Pset.empty idCompare;; - -let idSetAdd (id_len,set) : idSet = Pset.add set id_len;; - -let idSetAddMax max ((_,len) as id_len, set) : idSet = - if len <= max then Pset.add set id_len else set;; - -let idSetIntersect set1 set2 : idSet = Pset.intersect set1 set2;; - -(* ------------------------------------------------------------------------- *) -(* A type of clause sets that supports efficient subsumption checking. *) -(* ------------------------------------------------------------------------- *) - -type 'a nonunit_t = Non_unit of { - nextId : clauseId; - clauses : (int, Literal.literal list * Thm.clause * 'a) Mmap.map; - fstLits : (clauseId * clauseLength) Literal_net.literalNet; - sndLits : (clauseId * clauseLength) Literal_net.literalNet -};; - -type 'a subsume = Subsume of { - empty : (Thm.clause * Substitute.subst * 'a) list; - unitn : (Literal.literal * Thm.clause * 'a) Literal_net.literalNet; - nonunit : 'a nonunit_t -};; - -let newSubsume () = Subsume { - empty = []; - unitn = Literal_net.newNet false; - nonunit = Non_unit { - nextId = 0; - clauses = Intmap.newMap (); - fstLits = Literal_net.newNet false; - sndLits = Literal_net.newNet false} -};; - -let size (Subsume {empty; unitn; nonunit}) = - let Non_unit {clauses} = nonunit in - length empty + Literal_net.size unitn + Intmap.size clauses;; - -let insert (Subsume {empty; unitn; nonunit}) (cl',a) = - match sortClause cl' with - | [] -> - let empty = (cl',Substitute.empty,a) :: empty in - Subsume {empty = empty; unitn = unitn; nonunit = nonunit} - | [lit] -> - let unitn = Literal_net.insert unitn (lit,(lit,cl',a)) in - Subsume {empty = empty; unitn = unitn; nonunit = nonunit} - | fstLit :: (sndLit :: otherLits as nonFstLits) -> - let Non_unit {nextId;clauses;fstLits;sndLits} = nonunit in - let id_length = (nextId, Literal.Set.size cl') in - let fstLits = Literal_net.insert fstLits (fstLit,id_length) in - let (sndLit,otherLits) = - match findRest (incompatible fstLit) nonFstLits with - | Some sndLit_otherLits -> sndLit_otherLits - | None -> (sndLit,otherLits) in - let sndLits = Literal_net.insert sndLits (sndLit,id_length) in - let lits' = otherLits @ [fstLit;sndLit] in - let clauses = Intmap.insert clauses (nextId,(lits',cl',a)) in - let nextId = nextId + 1 in - let nonunit = Non_unit {nextId = nextId; clauses = clauses; - fstLits = fstLits; sndLits = sndLits} in - Subsume {empty = empty; unitn = unitn; nonunit = nonunit} -;; - -let filter pred (Subsume {empty; unitn; nonunit}) = - let pred3 (_,_,x) = pred x in - let empty = List.filter (fun (_,_,x) -> pred x) empty in - let unitn = Literal_net.filter (fun (_,_,x) -> pred x) unitn in - let nonunit = - let Non_unit {nextId; clauses; fstLits; sndLits} = nonunit in - let clauses' = Intmap.filter (fun x -> pred3 (snd x)) clauses in - if Intmap.size clauses = Intmap.size clauses' then nonunit else - let predId (id,_) = Intmap.inDomain id clauses' in - let fstLits = Literal_net.filter predId fstLits - and sndLits = Literal_net.filter predId sndLits in - Non_unit {nextId = nextId; clauses = clauses'; fstLits = fstLits; - sndLits = sndLits} in - Subsume {empty = empty; unitn = unitn; nonunit = nonunit} -;; - -let toString subsume = "Subsume{" ^ Int.toString (size subsume) ^ "}";; - -(* ------------------------------------------------------------------------- *) -(* Subsumption checking. *) -(* ------------------------------------------------------------------------- *) - -let matchLit lit' (lit,acc) = - match total (Literal.matchLiterals Substitute.empty lit') lit with - | Some sub -> sub :: acc - | None -> acc;; - -let genClauseSubsumes pred cl' lits' cl a = - let rec mkSubsl acc sub = function - | [] -> Some (sub, sortMap length Int.compare acc) - | (lit' :: lits') -> - match List.foldl (curry (matchLit lit')) [] cl with - | [] -> None - | [sub'] -> - begin - match total (Substitute.union sub) sub' with - | None -> None - | Some sub -> mkSubsl acc sub lits' - end - | subs -> mkSubsl (subs :: acc) sub lits' in - let rec search = function - | [] -> None - | ((sub,[]) :: others) -> - let x = (cl',sub,a) in - if pred x then Some x else search others - | ((_, [] :: _) :: others) -> search others - | ((sub, (sub' :: subs) :: subsl) :: others) -> - let others = (sub, subs :: subsl) :: others in - match total (Substitute.union sub) sub' with - | None -> search others - | Some sub -> search ((sub,subsl) :: others) in - match mkSubsl [] Substitute.empty lits' with - | None -> None - | Some sub_subsl -> search [sub_subsl] -;; - -let emptySubsumes pred empty = List.find pred empty;; - -let unitSubsumes pred unitn = - let subLit lit = - let subUnit (lit',cl',a) = - match total (Literal.matchLiterals Substitute.empty lit') lit with - | None -> None - | Some sub -> - let x = (cl',sub,a) in - if pred x then Some x else None in - first subUnit (Literal_net.matchNet unitn lit) in - first subLit -;; - -let nonunitSubsumes pred nonunit max cl = - let addId = match max with - | None -> idSetAdd - | Some n -> idSetAddMax n in - let subLit lits (lit,acc) = - List.foldl (curry addId) acc (Literal_net.matchNet lits lit) in - let Non_unit {clauses; fstLits; sndLits} = nonunit in - let subCl' (id,_) = - let (lits',cl',a) = Intmap.get clauses id in - genClauseSubsumes pred cl' lits' cl a in - let fstCands = List.foldl (curry (subLit fstLits)) idSetEmpty cl in - let sndCands = List.foldl (curry (subLit sndLits)) idSetEmpty cl in - let cands = idSetIntersect fstCands sndCands in - Pset.firstl subCl' cands -;; - -let genSubsumes pred (Subsume {empty; unitn; nonunit}) max cl = - match emptySubsumes pred empty with - | Some _ as s -> s - | None -> - if max = Some 0 then None else - let cl = clauseSym (Literal.Set.toList cl) in - match unitSubsumes pred unitn cl with - | Some _ as s -> s - | None -> - if max = Some 1 then None - else nonunitSubsumes pred nonunit max cl -;; - -let subsumes pred subsume cl = genSubsumes pred subsume None cl;; - -let strictlySubsumes pred subsume cl = - genSubsumes pred subsume (Some (Literal.Set.size cl)) cl;; - -let isSubsumed subs cl = Option.isSome (subsumes (kComb true) subs cl);; - -let isStrictlySubsumed subs cl = - Option.isSome (strictlySubsumes (kComb true) subs cl);; - -(* ------------------------------------------------------------------------- *) -(* Single clause versions. *) -(* ------------------------------------------------------------------------- *) - -let clauseSubsumes cl' cl = - let lits' = sortClause cl' - and lits = clauseSym (Literal.Set.toList cl) in - match genClauseSubsumes (kComb true) cl' lits' lits () with - | Some (_,sub,()) -> Some sub - | None -> None -;; - -let clauseStrictlySubsumes cl' cl = - if Literal.Set.size cl' > Literal.Set.size cl then None - else clauseSubsumes cl' cl;; - -end (* struct Subsume *) -;; diff --git a/metis/term.ml b/metis/term.ml deleted file mode 100644 index b07371d6..00000000 --- a/metis/term.ml +++ /dev/null @@ -1,371 +0,0 @@ -(* ========================================================================= *) -(* FIRST ORDER LOGIC TERMS *) -(* ========================================================================= *) - -module Term = struct - -(* ------------------------------------------------------------------------- *) -(* A type of first order logic terms. *) -(* ------------------------------------------------------------------------- *) - -type var = Name.name;; - -type functionName = Name.name;; - -type function_t = functionName * int;; - -type const = functionName;; - -type term = - | Var_ of Name.name - | Fn of (Name.name * term list);; - -(* ------------------------------------------------------------------------- *) -(* Constructors and destructors. *) -(* ------------------------------------------------------------------------- *) - -(* Variables *) - -let destVar = function - | Var_ v -> v - | Fn _ -> raise (Error "destVar");; - -let isVar = can destVar;; - -let equalVar v = function - | Var_ v' -> Name.equal v v' - | _ -> false;; - -(* Functions *) - -let destFn = function - | Fn f -> f - | Var_ _ -> raise (Error "destFn");; - -let isFn = can destFn;; - -let fnName tm = fst (destFn tm);; - -let fnArguments tm = snd (destFn tm);; - -let fnArity tm = List.length (fnArguments tm);; - -let fnFunction tm = (fnName tm, fnArity tm);; - -let functions tm = - let rec letc fs = function - | [] -> fs - | Var_ _ :: tms -> letc fs tms - | Fn (n,l) :: tms -> - letc (Name_arity.Set.add fs (n, List.length l)) (l @ tms) in - letc Name_arity.Set.empty [tm];; - -let functionNames tm = - let rec letc fs = function - | [] -> fs - | Var_ _ :: tms -> letc fs tms - | Fn (n,l) :: tms -> letc (Name.Set.add fs n) (l @ tms) in - letc Name.Set.empty [tm];; - -(* Constants *) - -let mkConst c = Fn (c, []);; - -let destConst = function - | Fn (c, []) -> c - | _ -> raise (Error "destConst");; - -let isConst = can destConst;; - -(* Binary functions *) - -let mkBinop f (a,b) = Fn (f,[a;b]);; - -let destBinop f = function - | Fn (x,[a;b]) -> - if Name.equal x f then (a,b) - else raise (Error "Term.destBinop: wrong binop") - | _ -> raise (Error "Term.destBinop: not a binop");; - -let isBinop f = can (destBinop f);; - -(* ------------------------------------------------------------------------- *) -(* The size of a term in symbols. *) -(* ------------------------------------------------------------------------- *) - -let vAR_SYMBOLS = 1;; - -let fN_SYMBOLS = 1;; - -let symbols tm = - let rec sz n = function - | [] -> n - | Var_ _ :: tms -> sz (n + vAR_SYMBOLS) tms - | Fn (letc,args) :: tms -> sz (n + fN_SYMBOLS) (args @ tms) in - sz 0 [tm];; - -(* ------------------------------------------------------------------------- *) -(* A total comparison function for terms. *) -(* ------------------------------------------------------------------------- *) - -let compare tm1 tm2 = - let rec cmp tm1 tm2 = - match tm1, tm2 with - | ([], []) -> Equal - | (tm1 :: tms1, tm2 :: tms2) -> - let tm1_tm2 = (tm1,tm2) in - if Portable.pointerEqual tm1_tm2 then cmp tms1 tms2 else - begin - match tm1_tm2 with - | (Var_ v1, Var_ v2) -> - begin - match Name.compare v1 v2 with - | Less -> Less - | Equal -> cmp tms1 tms2 - | Greater -> Greater - end - | (Var_ _, Fn _) -> Less - | (Fn _, Var_ _) -> Greater - | (Fn (f1,a1), Fn (f2,a2)) -> - begin - match Name.compare f1 f2 with - | Less -> Less - | Equal -> - begin - match Int.compare (List.length a1) (List.length a2) with - | Less -> Less - | Equal -> cmp (a1 @ tms1) (a2 @ tms2) - | Greater -> Greater - end - | Greater -> Greater - end - end - | _ -> raise (Bug "Term.compare") in - cmp [tm1] [tm2];; - -let equal tm1 tm2 = compare tm1 tm2 = Equal;; - -(* ------------------------------------------------------------------------- *) -(* Subterms. *) -(* ------------------------------------------------------------------------- *) - -type path = int list;; - -let rec subterm' = function - | (tm, []) -> tm - | (Var_ _, _ :: _) -> raise (Error "Term.subterm: Var_") - | (Fn (_,tms), h :: t) -> - if h >= List.length tms then raise (Error "Term.replace: Fn") - else subterm' (List.nth tms h, t);; -let subterm s t = subterm' (s, t);; - -let subterms tm = - let rec subtms = function - | ([], acc) -> acc - | ((path,tm) :: rest, acc) -> - let f (n,arg) = (n :: path, arg) - and acc = (List.rev path, tm) :: acc in - match tm with - | Var_ _ -> subtms (rest, acc) - | Fn (_,args) -> subtms ((List.map f (enumerate args) @ rest), acc) in - subtms ([([],tm)], []);; - -let rec replace tm = function - | ([],res) -> if equal res tm then tm else res - | (h :: t, res) -> - match tm with - | Var_ _ -> raise (Error "Term.replace: Var_") - | Fn (letc,tms) -> - if h >= List.length tms then raise (Error "Term.replace: Fn") else - let arg = List.nth tms h in - let arg' = replace arg (t,res) in - if Portable.pointerEqual (arg',arg) then tm - else Fn (letc, updateNth (h,arg') tms) -;; - -let find pred = - let rec search = function - | [] -> None - | ((path,tm) :: rest) -> - if pred tm then Some (List.rev path) else - match tm with - | Var_ _ -> search rest - | Fn (_,a) -> - let subtms = List.map (fun (i,t) -> (i :: path, t)) (enumerate a) in - search (subtms @ rest) in - fun tm -> search [([],tm)];; - -(* ------------------------------------------------------------------------- *) -(* Free variables. *) -(* ------------------------------------------------------------------------- *) - -let freeIn v tm = - let rec free v = function - | [] -> false - | (Var_ w :: tms) -> Name.equal v w || free v tms - | (Fn (_,args) :: tms) -> free v (args @ tms) in - free v [tm];; - -let freeVarsList = - let rec free vs = function - [] -> vs - | (Var_ v :: tms) -> free (Name.Set.add vs v) tms - | (Fn (_,args) :: tms) -> free vs (args @ tms) in - free Name.Set.empty;; - -let freeVars tm = freeVarsList [tm];; - -(* ------------------------------------------------------------------------- *) -(* Fresh variables. *) -(* ------------------------------------------------------------------------- *) - -let newVar () = Var_ (Name.newName ());; - -let newVars n = List.map (fun x -> Var_ x) (Name.newNames n);; - -let avoid av n = Name.Set.member n av;; -let variantPrime av = Name.variantPrime (avoid av);; -let variantNum av = Name.variantNum (avoid av);; - -(* ------------------------------------------------------------------------- *) -(* Special support for terms with type annotations. *) -(* ------------------------------------------------------------------------- *) - -let hasTypeFunctionName = Name.fromString ":";; - -let hasTypeFunction = (hasTypeFunctionName,2);; - -let destFnHasType ((f,a) : functionName * term list) = - if not (Name.equal f hasTypeFunctionName) then - raise (Error "Term.destFnHasType") - else - match a with - | [tm;ty] -> (tm,ty) - | _ -> raise (Error "Term.destFnHasType");; - -let isFnHasType = can destFnHasType;; - -let isTypedVar tm = - match tm with - | Var_ _ -> true - | Fn letc -> - match total destFnHasType letc with - | Some (Var_ _, _) -> true - | _ -> false;; - -let typedSymbols tm = - let rec sz n = function - | [] -> n - | (tm :: tms) -> - match tm with - | Var_ _ -> sz (n + 1) tms - | Fn letc -> - match total destFnHasType letc with - | Some (tm,_) -> sz n (tm :: tms) - | None -> - let (_,a) = letc in - sz (n + 1) (a @ tms) in - sz 0 [tm];; - -let nonVarTypedSubterms tm = - let rec subtms = function - | ([], acc) -> acc - | ((path,tm) :: rest, acc) -> - begin - match tm with - | Var_ _ -> subtms (rest, acc) - | Fn letc -> - begin - match total destFnHasType letc with - | Some (t,_) -> - begin - match t with - | Var_ _ -> subtms (rest, acc) - | Fn _ -> - let acc = (List.rev path, tm) :: acc - and rest = (0 :: path, t) :: rest in - subtms (rest, acc) - end - | None -> - let f (n,arg) = (n :: path, arg) in - let (_,args) = letc in - let acc = (List.rev path, tm) :: acc in - let rest = List.map f (enumerate args) @ rest in - subtms (rest, acc) - end - end in - subtms ([([],tm)], []);; - -(* ------------------------------------------------------------------------- *) -(* Special support for terms with an explicit function application operator. *) -(* ------------------------------------------------------------------------- *) - -let appName = Name.fromString ".";; - -let mkFnApp (fTm,aTm) = (appName, [fTm;aTm]);; - -let mkApp f_a = Fn (mkFnApp f_a);; - -let destFnApp ((f,a) : Name.name * term list) = - if not (Name.equal f appName) then raise (Error "Term.destFnApp") else - match a with - | [fTm;aTm] -> (fTm,aTm) - | _ -> raise (Error "Term.destFnApp");; - -let isFnApp = can destFnApp;; - -let destApp tm = - match tm with - | Var_ _ -> raise (Error "Term.destApp") - | Fn letc -> destFnApp letc;; - -let isApp = can destApp;; - -let listMkApp (f,l) = List.foldl (fun acc x -> mkApp (x, acc)) f l;; - -let stripApp tm = - let rec strip tms tm = - match total destApp tm with - | Some (f,a) -> strip (a :: tms) f - | None -> (tm,tms) in - strip [] tm;; - -(* ------------------------------------------------------------------------- *) -(* Parsing and pretty printing. *) -(* ------------------------------------------------------------------------- *) - -let rec toString = function - | Var_ v -> v - | Fn (n, []) -> n - | Fn (n, l) -> n ^ "(" ^ String.concatWith ", " (List.map toString l) ^ ")";; - -module Map = struct -let newMap () = Mmap.newMap compare ();; -let singleton kv = Mmap.singleton compare kv;; -let fromList xs = Mmap.fromList compare xs;; -let mapPartial f m = Mmap.mapPartial compare f m;; -let null = Mmap.null and size = Mmap.size and get = Mmap.get -and peek = Mmap.peek and insert = Mmap.insert and toList = Mmap.toList -and foldl = Mmap.foldl and foldr = Mmap.foldr and filter = Mmap.filter -and inDomain = Mmap.inDomain and union = Mmap.union and delete = Mmap.delete -and transform = Mmap.transform and exists = Mmap.exists;; -end (* struct Map *) -;; - -module Set = struct -let empty : term Mset.set = Mset.empty compare;; -let singleton k = Mset.singleton compare k;; -let intersect m1 m2 = Mset.intersect compare;; -let intersectList = Mset.intersectList compare;; -let fromList = Mset.fromList compare;; -let add = Mset.add and foldr = Mset.foldr and foldl = Mset.foldl -and member = Mset.member and union = Mset.union and difference = Mset.difference -and toList = Mset.toList and null = Mset.null and size = Mset.size -and pick = Mset.pick and equal = Mset.equal and exists = Mset.exists -and delete = Mset.delete and subset = Mset.subset and findl = Mset.findl -and firstl = Mset.firstl and transform = Mset.transform and all = Mset.all -and count = Mset.count;; -end (* struct Set *) -;; -end (* struct Term *) -;; diff --git a/metis/term_net.ml b/metis/term_net.ml deleted file mode 100644 index e1472dd6..00000000 --- a/metis/term_net.ml +++ /dev/null @@ -1,404 +0,0 @@ -(* ========================================================================= *) -(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC TERMS *) -(* ========================================================================= *) - -module Term_net = struct - -(* ------------------------------------------------------------------------- *) -(* Anonymous variables. *) -(* ------------------------------------------------------------------------- *) - -let anonymousName = Name.fromString "_";; -let anonymousVar = Term.Var_ anonymousName;; - -(* ------------------------------------------------------------------------- *) -(* Quotient terms. *) -(* ------------------------------------------------------------------------- *) - -type qterm = - | Var_ - | Fn of Name_arity.nameArity * qterm list;; - -let rec cmp = function - | [] -> Equal - | (q1_q2 :: qs) -> - if Portable.pointerEqual q1_q2 then cmp qs else - match q1_q2 with - | (Var_, Var_) -> Equal - | (Var_, Fn _) -> Less - | (Fn _, Var_) -> Greater - | (Fn (f1, f1'), Fn (f2, f2')) -> fnCmp (f1,f1') (f2,f2') qs -and fnCmp (n1,q1) (n2,q2) qs = - match Name_arity.compare n1 n2 with - | Less -> Less - | Equal -> cmp (zip q1 q2 @ qs) - | Greater -> Greater;; - -let compareQterm q1_q2 = cmp [q1_q2];; - -let compareFnQterm (f1,f2) = fnCmp f1 f2 [];; - -let equalQterm q1 q2 = compareQterm (q1,q2) = Equal;; - -let equalFnQterm f1 f2 = compareFnQterm (f1,f2) = Equal;; - -let rec termToQterm = function - | (Term.Var_ _) -> Var_ - | (Term.Fn (f,l)) -> Fn ((f, length l), List.map termToQterm l);; - -let rec qm = function - | [] -> true - | (Var_, _) :: rest -> qm rest - | (Fn _, Var_) :: _ -> false - | (Fn (f,a), Fn (g,b)) :: rest -> - Name_arity.equal f g && qm (zip a b @ rest);; - -let matchQtermQterm qtm qtm' = qm [(qtm,qtm')];; - -let rec qm = function - | [] -> true - | ((Var_,_) :: rest) -> qm rest - | ((Fn _, Term.Var_ _) :: _) -> false - | ((Fn ((f,n),a), Term.Fn (g,b)) :: rest) -> - Name.equal f g && n = length b && qm (zip a b @ rest);; - -let matchQtermTerm qtm tm = qm [(qtm,tm)];; - -let rec qn qsub = function - | [] -> Some qsub - | ((Term.Var_ v, qtm) :: rest) -> - begin - match Name.Map.peek qsub v with - | None -> qn (Name.Map.insert qsub (v,qtm)) rest - | Some qtm' -> if equalQterm qtm qtm' then qn qsub rest else None - end - | ((Term.Fn _, Var_) :: _) -> None - | ((Term.Fn (f,a), Fn ((g,n),b)) :: rest) -> - if Name.equal f g && length a = n then qn qsub (zip a b @ rest) - else None;; - -let matchTermQterm qsub tm qtm = qn qsub [(tm,qtm)];; - -let rec qv s t = match (s,t) with - | (Var_, x) -> x - | (x, Var_) -> x - | (Fn (f,a), Fn (g,b)) -> - let _ = Name_arity.equal f g || raise (Error "Term_net.qv") in - Fn (f, zipWith qv a b) -;; - -let rec qu qsub = function - | [] -> qsub - | (Var_, _) :: rest -> qu qsub rest - | (qtm, Term.Var_ v) :: rest -> - let qtm = match Name.Map.peek qsub v with - | None -> qtm - | Some qtm' -> qv qtm qtm' in - qu (Name.Map.insert qsub (v,qtm)) rest - | (Fn ((f,n),a), Term.Fn (g,b)) :: rest -> - if Name.equal f g && n = length b then qu qsub (zip a b @ rest) - else raise (Error "Term_net.qu") -;; - -let unifyQtermQterm qtm qtm' = total (qv qtm) qtm';; - -let unifyQtermTerm qsub qtm tm = total (qu qsub) [(qtm,tm)];; - -let rec qtermToTerm = function - | Var_ -> anonymousVar - | (Fn ((f,_),l)) -> Term.Fn (f, List.map qtermToTerm l);; - -(* ------------------------------------------------------------------------- *) -(* A type of term sets that can be efficiently matched and unified. *) -(* ------------------------------------------------------------------------- *) - -type parameters = bool;; - -type 'a net = - | Result of 'a list - | Single of qterm * 'a net - | Multiple of 'a net option * (Name_arity.nameArity, 'a net) Mmap.map;; - -type 'a termNet = Net of parameters * int * (int * (int * 'a) net) option;; - -(* ------------------------------------------------------------------------- *) -(* Basic operations. *) -(* ------------------------------------------------------------------------- *) - -let newNet parm = Net (parm,0,None);; - -let rec computeSize = function - | (Result l) -> length l - | (Single (_,n)) -> computeSize n - | (Multiple (vs,fs)) -> - Name_arity.Map.foldl - (fun (_,n,acc) -> acc + computeSize n) - (match vs with Some n -> computeSize n | None -> 0) - fs;; - -let netSize = function - | None -> None - | (Some n) -> Some (computeSize n, n);; - - -let size = function - | (Net (_,_,None)) -> 0 - | (Net (_, _, Some (i,_))) -> i;; - -let null net = size net = 0;; - -let singles qtms a = List.foldr (fun x y -> Single (x, y)) a qtms;; - -let pre = function - | None -> (0,None) - | (Some (i,n)) -> (i, Some n);; - -let rec add a b c = match (a, b, c) with - | (Result l, [], Result l') -> Result (l @ l') - | (a, (qtm :: qtms as input1), Single (qtm',n)) -> - if equalQterm qtm qtm' then Single (qtm, add a qtms n) - else add a input1 (add n [qtm'] (Multiple (None, Name_arity.Map.newMap ()))) - | (a, Var_ :: qtms, Multiple (vs,fs)) -> - Multiple (Some (oadd a qtms vs), fs) - | (a, Fn (f,l) :: qtms, Multiple (vs,fs)) -> - let n = Name_arity.Map.peek fs f in - Multiple (vs, Name_arity.Map.insert fs (f, oadd a (l @ qtms) n)) - | _ -> raise (Bug "Term_net.insert: Match") - -and oadd a qtms = function - | None -> singles qtms a - | (Some n) -> add a qtms n;; - -let ins a qtm (i,n) = Some (i + 1, oadd (Result [a]) [qtm] n);; - -let insert (Net (p,k,n)) (tm,a) = - try Net (p, k + 1, ins (k,a) (termToQterm tm) (pre n)) - with Error _ -> raise (Bug "Term_net.insert: should never fail");; - -let fromList parm l = List.foldl (fun tm_a n -> insert n tm_a) (newNet parm) l;; - -let filter pred = - let rec filt = function - | Result l -> - begin - match List.filter (fun (_,a) -> pred a) l with - | [] -> None - | l -> Some (Result l) - end - | Single (qtm,n) -> - begin - match filt n with - | None -> None - | Some n -> Some (Single (qtm,n)) - end - | Multiple (vs,fs) -> - let vs = Option.mapPartial filt vs in - let fs = Name_arity.Map.mapPartial (fun (_,n) -> filt n) fs in - if not (Option.isSome vs) && Name_arity.Map.null fs then None - else Some (Multiple (vs,fs)) in - try - function - | Net (_,_,None) as net -> net - | Net (p, k, Some (_,n)) -> Net (p, k, netSize (filt n)) - with Error _ -> raise (Bug "Term_net.filter: should never fail");; - -let toString net = "Term_net[" ^ Int.toString (size net) ^ "]";; - -(* ------------------------------------------------------------------------- *) -(* Specialized fold operations to support matching and unification. *) -(* ------------------------------------------------------------------------- *) - -let rec norm = function - | (0 :: ks, ((_,n) as f) :: fs, qtms) -> - let (a,qtms) = revDivide qtms n in - addQterm (Fn (f,a)) (ks,fs,qtms) - | stack -> stack - -and addQterm qtm (ks,fs,qtms) = - let ks = match ks with [] -> [] | k :: ks -> (k - 1) :: ks in - norm (ks, fs, qtm :: qtms) - -and addFn ((_,n) as f) (ks,fs,qtms) = norm (n :: ks, f :: fs, qtms);; - -let stackEmpty = ([],[],[]);; - -let stackAddQterm = addQterm;; - -let stackAddFn = addFn;; - -let stackValue = function - | ([],[],[qtm]) -> qtm - | _ -> raise (Bug "Term_net.stackValue");; - - -let rec fold inc acc = function - | [] -> acc - | ((0,stack,net) :: rest) -> - fold inc (inc (stackValue stack, net, acc)) rest - | ((n, stack, Single (qtm,net)) :: rest) -> - fold inc acc ((n - 1, stackAddQterm qtm stack, net) :: rest) - | ((n, stack, Multiple (v,fns)) :: rest) -> - let n = n - 1 in - let rest = match v with - | None -> rest - | Some net -> (n, stackAddQterm Var_ stack, net) :: rest in - let getFns ((_,k) as f, net, x) = - (k + n, stackAddFn f stack, net) :: x in - fold inc acc (Name_arity.Map.foldr getFns rest fns) - | _ -> raise (Bug "Term_net.foldTerms.fold");; - -let foldTerms inc acc net = fold inc acc [(1,stackEmpty,net)];; - -let foldEqualTerms pat inc acc = - let rec fold = function - | ([],net) -> inc (pat,net,acc) - | (pat :: pats, Single (qtm,net)) -> - if equalQterm pat qtm then fold (pats,net) else acc - | (Var_ :: pats, Multiple (v,_)) -> - begin - match v with - | None -> acc - | Some net -> fold (pats,net) - end - | (Fn (f,a) :: pats, Multiple (_,fns)) -> - begin - match Name_arity.Map.peek fns f with - | None -> acc - | Some net -> fold (a @ pats, net) - end - | _ -> raise (Bug "Term_net.foldEqualTerms.fold") in - fun net -> fold ([pat],net) -;; - -let rec fold inc acc = function - | [] -> acc - | ([],stack,net) :: rest -> - fold inc (inc (stackValue stack, net, acc)) rest - | (Var_ :: pats, stack, net) :: rest -> - let harvest (qtm,n,l) = (pats, stackAddQterm qtm stack, n) :: l in - fold inc acc (foldTerms harvest rest net) - | (pat :: pats, stack, Single (qtm,net)) :: rest -> - begin - match unifyQtermQterm pat qtm with - | None -> fold inc acc rest - | Some qtm -> - fold inc acc ((pats, stackAddQterm qtm stack, net) :: rest) - end - | ((Fn (f,a) as pat) :: pats, stack, Multiple (v,fns)) :: rest -> - let rest = match v with - | None -> rest - | Some net -> (pats, stackAddQterm pat stack, net) :: rest in - let rest = match Name_arity.Map.peek fns f with - | None -> rest - | Some net -> (a @ pats, stackAddFn f stack, net) :: rest in - fold inc acc rest - | _ -> raise (Bug "Term_net.foldUnifiableTerms.fold");; - -let foldUnifiableTerms pat inc acc net = - fold inc acc [([pat],stackEmpty,net)];; - -(* ------------------------------------------------------------------------- *) -(* Matching and unification queries. *) -(* *) -(* These function return OVER-APPROXIMATIONS! *) -(* Filter afterwards to get the precise set of satisfying values. *) -(* ------------------------------------------------------------------------- *) - -let idwise (m,_) (n,_) = Int.compare m n;; - -let fifoize (fifo : parameters) l = if fifo then sort idwise l else l;; - -let finally parm l = List.map snd (fifoize parm l);; - -let rec mat acc = function - | [] -> acc - | ((Result l, []) :: rest) -> mat (l @ acc) rest - | ((Single (qtm,n), tm :: tms) :: rest) -> - mat acc (if matchQtermTerm qtm tm then (n,tms) :: rest else rest) - | ((Multiple (vs,fs), tm :: tms) :: rest) -> - let rest = match vs with None -> rest | Some n -> (n,tms) :: rest in - let rest = match tm with - | Term.Var_ _ -> rest - | Term.Fn (f,l) -> - match Name_arity.Map.peek fs (f, length l) with - | None -> rest - | Some n -> (n, l @ tms) :: rest in - mat acc rest - | _ -> raise (Bug "Term_net.match: Match");; - -let matchNet x y = match (x,y) with - | (Net (_,_,None), _) -> [] - | (Net (p, _, Some (_,n)), tm) -> - try finally p (mat [] [(n,[tm])]) - with Error _ -> raise (Bug "Term_net.match: should never fail");; - -let unseenInc qsub v tms (qtm,net,rest) = - (Name.Map.insert qsub (v,qtm), net, tms) :: rest;; - -let seenInc qsub tms (_,net,rest) = (qsub,net,tms) :: rest;; - -let rec mat acc = function - | [] -> acc - | (_, Result l, []) :: rest -> mat (l @ acc) rest - | (qsub, Single (qtm,net), tm :: tms) :: rest -> - begin - match matchTermQterm qsub tm qtm with - | None -> mat acc rest - | Some qsub -> mat acc ((qsub,net,tms) :: rest) - end - | (qsub, (Multiple _ as net), Term.Var_ v :: tms) :: rest -> - begin - match Name.Map.peek qsub v with - | None -> mat acc (foldTerms (unseenInc qsub v tms) rest net) - | Some qtm -> mat acc (foldEqualTerms qtm (seenInc qsub tms) rest net) - end - | (qsub, Multiple (_,fns), Term.Fn (f,a) :: tms) :: rest -> - let rest = match Name_arity.Map.peek fns (f, length a) with - | None -> rest - | Some net -> (qsub, net, a @ tms) :: rest in - mat acc rest - | _ -> raise (Bug "Term_net.matched.mat");; - -let matched x tm = match x with - | (Net (_,_,None)) -> [] - | (Net (parm, _, Some (_,net))) -> - try finally parm (mat [] [(Name.Map.newMap (), net, [tm])]) - with Error _ -> raise (Bug "Term_net.matched: should never fail");; - - -let inc qsub v tms (qtm,net,rest) = - (Name.Map.insert qsub (v,qtm), net, tms) :: rest;; - -let rec mat acc = function - | [] -> acc - | (_, Result l, []) :: rest -> mat (l @ acc) rest - | (qsub, Single (qtm,net), tm :: tms) :: rest -> - begin - match unifyQtermTerm qsub qtm tm with - | None -> mat acc rest - | Some qsub -> mat acc ((qsub,net,tms) :: rest) - end - | (qsub, (Multiple _ as net), Term.Var_ v :: tms) :: rest -> - begin - match Name.Map.peek qsub v with - | None -> mat acc (foldTerms (inc qsub v tms) rest net) - | Some qtm -> mat acc (foldUnifiableTerms qtm (inc qsub v tms) rest net) - end - | (qsub, Multiple (v,fns), Term.Fn (f,a) :: tms) :: rest -> - let rest = match v with - | None -> rest - | Some net -> (qsub,net,tms) :: rest in - let rest = match Name_arity.Map.peek fns (f, length a) with - | None -> rest - | Some net -> (qsub, net, a @ tms) :: rest in - mat acc rest - | _ -> raise (Bug "Term_net.unify.mat");; - -let unify x tm = match x with - | (Net (_,_,None)) -> [] - | (Net (parm, _, Some (_,net))) -> - try finally parm (mat [] [(Name.Map.newMap (), net, [tm])]) - with Error _ -> raise (Bug "Term_net.unify: should never fail");; - -end (* struct Term_net *) -;; diff --git a/metis/thm.ml b/metis/thm.ml deleted file mode 100644 index 4be5c33e..00000000 --- a/metis/thm.ml +++ /dev/null @@ -1,197 +0,0 @@ -(* ========================================================================= *) -(* A LOGICAL KERNEL FOR FIRST ORDER CLAUSAL THEOREMS *) -(* ========================================================================= *) - -module Thm = struct - -(* ------------------------------------------------------------------------- *) -(* An abstract type of first order logic theorems. *) -(* ------------------------------------------------------------------------- *) - -type clause = Literal.literal Mset.set;; - -type inferenceType = - Axiom - | Assume - | Subst - | Factor - | Resolve - | Refl - | Equality;; - -type thm = Thm of clause * (inferenceType * thm list);; - -type inference = inferenceType * thm list;; - -(* ------------------------------------------------------------------------- *) -(* Theorem destructors. *) -(* ------------------------------------------------------------------------- *) - -let clause (Thm (cl,_)) = cl;; - -let inference (Thm (_,inf)) = inf;; - -(* Tautologies *) - -let isTautology th = - let chk = function - | (_,None) -> None - | ((pol,atm), Some set) -> - if (pol && Atom.isRefl atm) || Atom.Set.member atm set then None - else Some (Atom.Set.add set atm) in - match Literal.Set.foldl chk (Some Atom.Set.empty) (clause th) with - | Some _ -> false - | None -> true;; - -(* Contradictions *) - -let isContradiction th = Literal.Set.null (clause th);; - -(* Unit theorems *) - -let destUnit (Thm (cl,_)) = - if Literal.Set.size cl = 1 then Literal.Set.pick cl - else raise (Error "Thm.destUnit");; - -let isUnit = can destUnit;; - -(* Unit equality theorems *) - -let destUnitEq th = Literal.destEq (destUnit th);; - -let isUnitEq = can destUnitEq;; - -(* Literals *) - -let member lit (Thm (cl,_)) = Literal.Set.member lit cl;; - -let negateMember lit (Thm (cl,_)) = Literal.Set.negateMember lit cl;; - -(* ------------------------------------------------------------------------- *) -(* A total order. *) -(* ------------------------------------------------------------------------- *) - -let compare th1 th2 = Literal.Set.compare (clause th1) (clause th2);; - -let equal th1 th2 = Literal.Set.equal (clause th1) (clause th2);; - -(* ------------------------------------------------------------------------- *) -(* Free variables. *) -(* ------------------------------------------------------------------------- *) - -let freeIn v (Thm (cl,_)) = Literal.Set.freeIn v cl;; - -let freeVars (Thm (cl,_)) = Literal.Set.freeVars cl;; - -(* ------------------------------------------------------------------------- *) -(* Pretty-printing. *) -(* ------------------------------------------------------------------------- *) - -let inferenceTypeToString = function - | Axiom -> "axiom" - | Assume -> "assume" - | Subst -> "subst" - | Factor -> "factor" - | Resolve -> "resolve" - | Refl -> "refl" - | Equality -> "equality" -;; - -let toString (Thm (cl, (infType, ths))) = - inferenceTypeToString infType ^ ": " ^ Literal.Set.toString cl - -let rec print_proof (Thm (cl, (infType, ths))) = - print_string ("Inference: " ^ inferenceTypeToString infType); - print_newline (); - print_string ("Clauses: " ^ Literal.Set.toString cl); - print_newline (); - print_string "Theorems: "; - if ths = [] - then print_string "" - else begin - print_break 0 0; - open_vbox 2; - print_break 0 0; - List.app (print_proof) ths; - close_box () - end; - print_newline () -;; - -(* ------------------------------------------------------------------------- *) -(* Primitive rules of inference. *) -(* ------------------------------------------------------------------------- *) - -(* ------------------------------------------------------------------------- *) -(* *) -(* ----- axiom C *) -(* C *) -(* ------------------------------------------------------------------------- *) - -let axiom cl = Thm (cl,(Axiom,[]));; - -(* ------------------------------------------------------------------------- *) -(* *) -(* ----------- assume L *) -(* L \/ ~L *) -(* ------------------------------------------------------------------------- *) - -let assume lit = - Thm (Literal.Set.fromList [lit; Literal.negate lit], (Assume,[]));; - -(* ------------------------------------------------------------------------- *) -(* C *) -(* -------- subst s *) -(* C[s] *) -(* ------------------------------------------------------------------------- *) - -let subst sub (Thm (cl,inf) as th) = - let cl' = Literal.Set.subst sub cl in - if Portable.pointerEqual (cl,cl') then th else - match inf with - | (Subst,_) -> Thm (cl',inf) - | _ -> Thm (cl',(Subst,[th])) -;; - -(* ------------------------------------------------------------------------- *) -(* L \/ C ~L \/ D *) -(* --------------------- resolve L *) -(* C \/ D *) -(* *) -(* The literal L must occur in the first theorem, and the literal ~L must *) -(* occur in the second theorem. *) -(* ------------------------------------------------------------------------- *) - -let resolve lit (Thm (cl1,_) as th1) (Thm (cl2,_) as th2) = - let cl1' = Literal.Set.delete cl1 lit - and cl2' = Literal.Set.delete cl2 (Literal.negate lit) in - Thm (Literal.Set.union cl1' cl2', (Resolve,[th1;th2])) -;; - -(* ------------------------------------------------------------------------- *) -(* *) -(* --------- refl t *) -(* t = t *) -(* ------------------------------------------------------------------------- *) - -let refl tm = Thm (Literal.Set.singleton (true, Atom.mkRefl tm), (Refl,[]));; - -(* ------------------------------------------------------------------------- *) -(* *) -(* ------------------------ equality L p t *) -(* ~(s = t) \/ ~L \/ L' *) -(* *) -(* where s is the subterm of L at path p, and L' is L with the subterm at *) -(* path p being replaced by t. *) -(* ------------------------------------------------------------------------- *) - -let equality lit path t = - let s = Literal.subterm lit path in - let lit' = Literal.replace lit (path,t) in - let eqLit = Literal.mkNeq (s,t) in - let cl = Literal.Set.fromList [eqLit; Literal.negate lit; lit'] in - Thm (cl,(Equality,[])) -;; - -end (* struct Thm *) -;; diff --git a/metis/units.ml b/metis/units.ml deleted file mode 100644 index da1eefb0..00000000 --- a/metis/units.ml +++ /dev/null @@ -1,86 +0,0 @@ -(* ========================================================================= *) -(* A STORE FOR UNIT THEOREMS *) -(* ========================================================================= *) - -module Units = struct - -(* ------------------------------------------------------------------------- *) -(* A type of unit store. *) -(* ------------------------------------------------------------------------- *) - -type unitThm = Literal.literal * Thm.thm;; - -type units = Units of unitThm Literal_net.literalNet;; - -(* ------------------------------------------------------------------------- *) -(* Basic operations. *) -(* ------------------------------------------------------------------------- *) - -(* -open Term_net -*) - -let empty = Units (Literal_net.newNet false);; - -let size (Units net) = Literal_net.size net;; - -let toString units = "U{" ^ Int.toString (size units) ^ "}";; - -(* ------------------------------------------------------------------------- *) -(* Add units into the store. *) -(* ------------------------------------------------------------------------- *) - -let add (Units net) ((lit,th) as uTh) = - let net = Literal_net.insert net (lit,uTh) in - match total Literal.sym lit with - | None -> Units net - | Some ((pol,_) as lit') -> - let th' = (if pol then Rule.symEq else Rule.symNeq) lit th in - let net = Literal_net.insert net (lit',(lit',th')) in - Units net -;; - -let addList = List.foldl (fun th u -> add u th);; - -(* ------------------------------------------------------------------------- *) -(* Matching. *) -(* ------------------------------------------------------------------------- *) - -let matchUnits (Units net) lit = - let check ((lit',_) as uTh) = - match total (Literal.matchLiterals Substitute.empty lit') lit with - | None -> None - | Some sub -> Some (uTh,sub) in - first check (Literal_net.matchNet net lit) -;; - -(* ------------------------------------------------------------------------- *) -(* Reducing by repeated matching and resolution. *) -(* ------------------------------------------------------------------------- *) - -let reduce units = - let red1 (lit,news_th) = - match total Literal.destIrrefl lit with - | Some tm -> - let (news,th) = news_th in - let th = Thm.resolve lit th (Thm.refl tm) in - (news,th) - | None -> - let lit' = Literal.negate lit in - match matchUnits units lit' with - | None -> news_th - | Some ((_,rth),sub) -> - let (news,th) = news_th in - let rth = Thm.subst sub rth in - let th = Thm.resolve lit th rth in - let newLits = Literal.Set.delete (Thm.clause rth) lit' in - let news = Literal.Set.union newLits news in - (news,th) in - let rec red (news,th) = - if Literal.Set.null news then th - else red (Literal.Set.foldl red1 (Literal.Set.empty,th) news) in - fun th -> Rule.removeSym (red (Thm.clause th, th)) -;; - -end (* struct Units *) -;; diff --git a/metis/waiting.ml b/metis/waiting.ml deleted file mode 100644 index 9ed801d6..00000000 --- a/metis/waiting.ml +++ /dev/null @@ -1,208 +0,0 @@ -(* ========================================================================= *) -(* THE WAITING SET OF CLAUSES *) -(* ========================================================================= *) - -module Waiting = struct - -(* ------------------------------------------------------------------------- *) -(* A type of waiting sets of clauses. *) -(* ------------------------------------------------------------------------- *) - -type weight = Double.double;; - -type modelParameters = Model_parameters of { - model : Model.parameters; - initialPerturbations : int; - maxChecks : int option; - perturbations : int; - weight : weight -};; - -type parameters = Parameters of { - symbolsWeight : weight; - variablesWeight : weight; - literalsWeight : weight; - modelsP : modelParameters list -};; - -type distance = Double.double - -type waiting = Waiting of { - parameters : parameters; - clauses : (weight * (distance * Clause.clause)) Heap.heap; - models : Model.model list -};; - -(* ------------------------------------------------------------------------- *) -(* Basic operations. *) -(* ------------------------------------------------------------------------- *) - -let defaultModels : modelParameters list = [ - Model_parameters { - model = Model.default; - initialPerturbations = 100; - maxChecks = Some 20; - perturbations = 0; - weight = Double.fromInt 1 - }];; - -let default : parameters = - Parameters { - symbolsWeight = Double.fromInt 1; - literalsWeight = Double.fromInt 1; - variablesWeight = Double.fromInt 1; - modelsP = defaultModels -};; - -let size (Waiting {clauses}) = Heap.size clauses;; - -let toString w = "Waiting{" ^ Int.toString (size w) ^ "}";; - -(* ------------------------------------------------------------------------- *) -(* Perturbing the models. *) -(* ------------------------------------------------------------------------- *) - -type modelClause = Name.name Mset.set * Thm.clause;; - -let mkModelClause cl = - let lits = Clause.literals cl in - let fvs = Literal.Set.freeVars lits in - (fvs,lits) -;; - -let mkModelClauses = List.map mkModelClause;; - -let perturbModel vM cls = - if List.null cls then - kComb () - else - let vN = Model.msize vM in - let perturbClause (fv,cl) = - let vV = Model.randomValuation vN fv in - if not (Model.interpretClause vM vV cl) then () - else Model.perturbClause vM vV cl in - let perturbClauses () = List.app perturbClause cls in - fun n -> funpow n perturbClauses () -;; - -let initialModel axioms conjecture parm = - let Model_parameters {model; initialPerturbations} = parm in - let m = Model.newModel model in - let () = perturbModel m conjecture initialPerturbations in - let () = perturbModel m axioms initialPerturbations in - m -;; - -let checkModels = - let one = Double.fromInt 1 in - fun parms models (fv,cl) -> - let check (parm,model) z = - let Model_parameters {maxChecks; weight} = parm in - let (vT,vF) = Model.check Model.interpretClause maxChecks model fv cl in - z *. (Double.pow (one +. Double.fromInt vT /. Double.fromInt (vT + vF)) - weight) in - List.foldl check one (zip parms models) - ;; - -let perturbModels parms models cls = - let perturb (parm,model) = - let Model_parameters {perturbations} = parm in - perturbModel model cls perturbations in - List.app perturb (zip parms models) -;; - -(* ------------------------------------------------------------------------- *) -(* Clause weights. *) -(* ------------------------------------------------------------------------- *) - -let clauseSymbols cl = Double.fromInt (Literal.Set.typedSymbols cl);; - -let clauseVariables cl = - Double.fromInt (Name.Set.size (Literal.Set.freeVars cl) + 1);; - -let clauseLiterals cl = Double.fromInt (Literal.Set.size cl);; - -let clausePriority = - let Some factor = Double.fromString "1e-12" in - fun cl -> - Double.fromInt cl.Clause.Clause.id *. factor;; - -let clauseWeight parm mods dist mcl cl = - let Parameters {symbolsWeight; variablesWeight; literalsWeight; - modelsP} = parm in - let lits = Clause.literals cl in - let symbolsW = Double.pow (clauseSymbols lits) symbolsWeight in - let variablesW = Double.pow (clauseVariables lits) variablesWeight in - let literalsW = Double.pow (clauseLiterals lits) literalsWeight in - let modelsW = checkModels modelsP mods mcl in - let weight = dist *. symbolsW *. variablesW *. literalsW *. modelsW in - let weight = weight +. clausePriority cl in - weight -;; - -(* ------------------------------------------------------------------------- *) -(* Adding new clauses. *) -(* ------------------------------------------------------------------------- *) - -let add' waiting dist mcls cls = - let Waiting {parameters; clauses; models} = waiting in - let Parameters {modelsP} = parameters in - let dist = dist +. Double.ln (Double.fromInt (length cls)) in - let addCl (mcl,cl) acc = - let weight = clauseWeight parameters models dist mcl cl in - Heap.add acc (weight,(dist,cl)) in - let clauses = List.foldl addCl clauses (zip mcls cls) in - perturbModels modelsP models mcls; - Waiting {parameters = parameters; clauses = clauses; models = models} -;; - -let add waiting (dist,cls) = - if List.null cls then - waiting - else - let waiting = add' waiting dist (mkModelClauses cls) cls in - waiting -;; - -let cmp (w1,_) (w2,_) = - if Double.(<) w1 w2 then Less - else if Double.(>) w1 w2 then Greater - else Equal;; - -let empty parameters axioms conjecture = - let Parameters {modelsP} = parameters in - let clauses = Heap.newHeap cmp - and models = List.map (initialModel axioms conjecture) modelsP in - Waiting {parameters = parameters; clauses = clauses; models = models} -;; - -let newWaiting = - let zero = Double.fromInt 0 in - fun parameters (Ax_cj.Ax_cj_cl {axioms_cl; conjecture_cl}) -> - let mAxioms = mkModelClauses axioms_cl - and mConjecture = mkModelClauses conjecture_cl in - let waiting = empty parameters mAxioms mConjecture in - if List.null axioms_cl && List.null conjecture_cl then - waiting - else - add' waiting zero (mAxioms @ mConjecture) (axioms_cl @ conjecture_cl) -;; - -(* ------------------------------------------------------------------------- *) -(* Removing the lightest clause. *) -(* ------------------------------------------------------------------------- *) - -let remove (Waiting {parameters; clauses; models}) = - if Heap.null clauses then - None - else - let ((_,dcl),clauses) = Heap.remove clauses in - let waiting = Waiting { - parameters = parameters; - clauses = clauses; - models = models} in - Some (dcl,waiting) -;; - -end (* struct Waiting *) -;; diff --git a/nums.ml b/nums.ml index 2b9daf19..58237da6 100644 --- a/nums.ml +++ b/nums.ml @@ -7,7 +7,7 @@ (* (c) Copyright, John Harrison 1998-2007 *) (* ========================================================================= *) -needs "pair.ml";; +needs "compute.ml";; (* ------------------------------------------------------------------------- *) (* Declare a new type "ind" of individuals. *) @@ -254,7 +254,7 @@ let is_numeral = can dest_numeral;; let the_specifications = ref ([]: ((string list * thm) * thm) list);; let new_specification = - let code c = mk_small_numeral (Char.ord (String.sub c 0)) in + let code c = mk_small_numeral (Char.code (c.[0])) in let mk_code name = end_itlist (curry mk_pair) (map code (explode name)) in let check_distinct l = @@ -283,7 +283,7 @@ let new_specification = failwith "new_specification: Assumptions not allowed in theorem" else if not (frees c = []) then failwith ("new_specification: Free variables in predicate: " ^ - (String.concatWith ", " (map (fun (Var (name,_)) -> name) (frees c)))) else + (String.concat ", " (map (fun (Var (name,_)) -> name) (frees c)))) else let avs = fst(strip_exists c) in if length names = 0 || length names > length avs then failwith "new_specification: Unsuitable number of constant names" else diff --git a/parser.ml b/parser.ml index 19836613..a605b454 100644 --- a/parser.ml +++ b/parser.ml @@ -127,9 +127,9 @@ let lex = | "b"::rst -> "\b",rst | " "::rst -> " ",rst | "x"::h::l::rst -> - String.str (Char.chr(int_of_string("0x"^h^l))),rst + String.make 1 (Char.chr(int_of_string("0x"^h^l))),rst | a::b::c::rst when forall isnum [a;b;c] -> - String.str (Char.chr(int_of_string(a^b^c))),rst + String.make 1 (Char.chr(int_of_string(a^b^c))),rst | _ -> failwith "lex:unrecognized OCaml-style escape in string" in let stringchar = some (fun i -> i <> "\\" && i <> "\"") @@ -184,7 +184,7 @@ let lex = (* ------------------------------------------------------------------------- *) let parse_pretype = - let (mk_prefinty:num->pretype) = + let mk_prefinty:num->pretype = let rec prefinty n = if n =/ num_1 then Ptycon("1",[]) else let c = if Num.mod_num n num_2 =/ num_0 then "tybit0" else "tybit1" in @@ -290,9 +290,7 @@ let parse_preterm = | Combp(p1,p2) -> union (pfrees p1) (pfrees p2) | Absp(p1,p2) -> subtract (pfrees p2) (pfrees p1) | Typing(p,_) -> pfrees p in - let pdest_eq t = - match t with - | Combp(Combp(Varp(("="|"<=>"),_),l),r) -> l,r in + let pdest_eq = function (Combp(Combp(Varp(("="|"<=>"),_),l),r)) -> l,r in let pmk_let (letbindings,body) = let vars,tms = unzip (map pdest_eq letbindings) in let _ = warn(not @@ -326,8 +324,8 @@ let parse_preterm = let lis = map (fun i -> pmk_bool((c / (1 lsl i)) mod 2 = 1)) (0--7) in itlist (fun x y -> Combp(y,x)) lis (Varp("ASCII",dpty)) in let pmk_string s = - let ns = map (fun i -> Char.ord (String.sub s i)) - (0--(String.size s - 1)) in + let ns = map (fun i -> Char.code(String.get s i)) + (0--(String.length s - 1)) in pmk_list(map pmk_char ns) in let pmk_setcompr (fabs,bvs,babs) = let v = pgenvar() in @@ -368,10 +366,10 @@ let parse_preterm = let pretype = parse_pretype and string inp = match inp with - Ident s::rst when String.size s >= 2 && - String.sub s 0 = '"' && - String.sub s (String.size s - 1) = '"' - -> String.substring s 1 (String.size s - 2),rst + Ident s::rst when String.length s >= 2 && + String.sub s 0 1 = "\"" && + String.sub s (String.length s - 1) 1 = "\"" + -> String.sub s 1 (String.length s - 2),rst | _ -> raise Noparse and singleton1 x = [x] and lmk_ite (((((_,b),_),l),_),r) = @@ -389,7 +387,7 @@ let parse_preterm = let r0 = hd ropt in let n_l = num_of_string l0 and n_r = num_of_string r0 in - let n_d = power_num (num 10) (num (String.size r0)) in + let n_d = power_num (num 10) (num (String.length r0)) in let n_n = n_l */ n_d +/ n_r in string_of_num n_n,string_of_num n_d in Combp(Combp(Varp("DECIMAL",dpty),Varp(l,dpty)),Varp(r,dpty)) @@ -519,9 +517,9 @@ let parse_preterm = (fun inp -> match inp with [Ident s] when - not(String.size s >= 2 && - String.sub s 0 = '"' && - String.sub s (String.size s - 1) = '"') + not(String.length s >= 2 && + String.sub s 0 1 = "\"" && + String.sub s (String.length s - 1) 1 = "\"") -> Varp(s,dpty),[] | _ -> preterm inp);; diff --git a/preterm.ml b/preterm.ml index cdc2ddd2..c53f8137 100644 --- a/preterm.ml +++ b/preterm.ml @@ -83,11 +83,10 @@ let new_type_abbrev,remove_type_abbrev,type_abbrevs = let remove_type_abbrev s = the_type_abbreviations := filter (fun (s',_) -> s' <> s) (!the_type_abbreviations) in + let (<) x y = Pair.compare String.compare Type.compare x y < 0 in let new_type_abbrev(s,ty) = (remove_type_abbrev s; - the_type_abbreviations := - merge (fun x y -> Pair.compare String.compare Type.compare x y = Less) - [s,ty] (!the_type_abbreviations)) in + the_type_abbreviations := merge(<) [s,ty] (!the_type_abbreviations)) in let type_abbrevs() = !the_type_abbreviations in new_type_abbrev,remove_type_abbrev,type_abbrevs;; @@ -157,7 +156,6 @@ let rec preterm_of_term tm = (* ------------------------------------------------------------------------- *) let type_of_pretype,term_of_preterm,retypecheck = - let tyv_num = ref 0 in let new_type_var() = let n = !tyv_num in (tyv_num := n + 1; Stv(n)) in @@ -213,7 +211,7 @@ let type_of_pretype,term_of_preterm,retypecheck = (* ----------------------------------------------------------------------- *) let get_var_type vname = - assoc vname (!the_implicit_types) in + assoc vname !the_implicit_types in (* ----------------------------------------------------------------------- *) (* Unravel unifications and apply them to a type. *) @@ -231,12 +229,12 @@ let type_of_pretype,term_of_preterm,retypecheck = (* ----------------------------------------------------------------------- *) let free_stvs = - let rec free_stvs stv = match stv with + let rec free_stvs = function |Stv n -> [n] |Utv _ -> [] |Ptycon(_,args) -> flat (map free_stvs args) in - setify Int.(<=) o free_stvs + setify (<=) o free_stvs in let string_of_pretype stvs = @@ -249,7 +247,7 @@ let type_of_pretype,term_of_preterm,retypecheck = in let string_of_preterm = - let rec untyped_t_of_pt pt = match pt with + let rec untyped_t_of_pt = function |Varp(s,pty) -> mk_var(s,aty) |Constp(s,pty) -> mk_mconst(s,get_const_type s) |Combp(l,r) -> mk_comb(untyped_t_of_pt l,untyped_t_of_pt r) @@ -305,7 +303,7 @@ let type_of_pretype,term_of_preterm,retypecheck = |(t,Stv x,ptm)::oth -> unify env ((Stv x,t,ptm)::oth) |(_,_,ptm)::oth -> failwith (string_of_ty_error env ptm) in - unify env [ty1,ty2,(match ptm with None -> None | Some t -> Some(t,ty1,ty2))] + unify env [ty1,ty2,match ptm with None -> None | Some t -> Some(t,ty1,ty2)] in (* ----------------------------------------------------------------------- *) @@ -407,7 +405,7 @@ let type_of_pretype,term_of_preterm,retypecheck = | Utv(v) -> (mk_vartype(v), false) | Ptycon(con,args) -> let args',translated = unzip (map type_of_pretype_base args) in - let translated = List.foldl (fun x y -> if x then x else y) false translated in + let translated = List.fold_left (||) false translated in (mk_type(con,args'), translated) in let type_of_pretype (ty:pretype): hol_type = @@ -426,7 +424,7 @@ let type_of_pretype,term_of_preterm,retypecheck = let v = mk_var(s,ty) in let _ = if translated && not (exists (fun s' -> s = s') - (!stvs_translated_terms)) + !stvs_translated_terms) then stvs_translated_terms := s::(!stvs_translated_terms) else () in v | Constp(s,pty) -> @@ -434,19 +432,19 @@ let type_of_pretype,term_of_preterm,retypecheck = let c = mk_mconst(s,ty) in let _ = if translated && not (exists (fun s' -> s = s') - (!stvs_translated_terms)) + !stvs_translated_terms) then stvs_translated_terms := s::(!stvs_translated_terms) else () in c | Combp(l,r) -> mk_comb(term_of_preterm l,term_of_preterm r) | Absp(v,bod) -> mk_gabs(term_of_preterm v,term_of_preterm bod) | Typing(ptm,pty) -> term_of_preterm ptm in let report_type_invention () = - if (!stvs_translated_terms) <> [] then - if (!type_invention_error) + if !stvs_translated_terms <> [] then + if !type_invention_error then failwith ("typechecking error (cannot infer type of variables): " ^ - String.concatWith ", " (!stvs_translated_terms)) - else warn (!type_invention_warning) "inventing type variables" in + String.concat ", " !stvs_translated_terms) + else warn !type_invention_warning "inventing type variables" in fun ptm -> stvs_translated_terms := []; let tm = term_of_preterm ptm in report_type_invention (); tm in @@ -465,7 +463,6 @@ let type_of_pretype,term_of_preterm,retypecheck = try resolve_interface ptm' (fun e -> e) env with Failure _ -> failwith "typechecking error (overload resolution)" in let ptm'' = solve_preterm env' ptm' in - ptm'' - in + ptm'' in type_of_pretype,term_of_preterm,retypecheck;; diff --git a/printer.ml b/printer.ml index 9781fa24..32a236fa 100755 --- a/printer.ml +++ b/printer.ml @@ -16,7 +16,7 @@ needs "nets.ml";; (* ------------------------------------------------------------------------- *) let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = - let charcode s = Char.ord (String.sub s 0) in + let charcode s = Char.code(String.get s 0) in let spaces = " \t\n\r" and separators = ",;" and brackets = "()[]{}" @@ -25,20 +25,20 @@ let isspace,issep,isbra,issymb,isalpha,isnum,isalnum = and nums = "0123456789" in let allchars = spaces^separators^brackets^symbs^alphas^nums in let csetsize = itlist (max o charcode) (explode allchars) 256 in - let ctable = Array.array csetsize 0 in - do_list (fun c -> Array.update ctable (charcode c) 1) (explode spaces); - do_list (fun c -> Array.update ctable (charcode c) 2) (explode separators); - do_list (fun c -> Array.update ctable (charcode c) 4) (explode brackets); - do_list (fun c -> Array.update ctable (charcode c) 8) (explode symbs); - do_list (fun c -> Array.update ctable (charcode c) 16) (explode alphas); - do_list (fun c -> Array.update ctable (charcode c) 32) (explode nums); - let isspace c = Array.sub ctable (charcode c) = 1 - and issep c = Array.sub ctable (charcode c) = 2 - and isbra c = Array.sub ctable (charcode c) = 4 - and issymb c = Array.sub ctable (charcode c) = 8 - and isalpha c = Array.sub ctable (charcode c) = 16 - and isnum c = Array.sub ctable (charcode c) = 32 - and isalnum c = Array.sub ctable (charcode c) >= 16 in + let ctable = Array.make csetsize 0 in + do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces); + do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators); + do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets); + do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs); + do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas); + do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums); + let isspace c = Array.get ctable (charcode c) = 1 + and issep c = Array.get ctable (charcode c) = 2 + and isbra c = Array.get ctable (charcode c) = 4 + and issymb c = Array.get ctable (charcode c) = 8 + and isalpha c = Array.get ctable (charcode c) = 16 + and isnum c = Array.get ctable (charcode c) = 32 + and isalnum c = Array.get ctable (charcode c) >= 16 in isspace,issep,isbra,issymb,isalpha,isnum,isalnum;; (* ------------------------------------------------------------------------- *) @@ -84,7 +84,7 @@ let unparse_as_prefix,parse_as_prefix,is_prefix,prefixes = let unparse_as_infix,parse_as_infix,get_infix_status,infixes = let cmp (s,(x,a)) (t,(y,b)) = - x < y || x = y && String.(>) a b || x = y && a = b && String.(<) s t in + x < y || x = y && Cake.String.(>) a b || x = y && a = b && Cake.String.(<) s t in let infix_list = ref ([]:(string * (int * string)) list) in (fun n -> infix_list := filter (((<>) n) o fst) (!infix_list)), (fun (n,d) -> infix_list := sort cmp @@ -104,6 +104,38 @@ let the_overload_skeletons = ref ([] : (string * hol_type) list);; (* Now the printer. *) (* ------------------------------------------------------------------------- *) +(* +include Format;; +*) +type formatter = Format.formatter;; +let set_margin n = Format.set_margin n;; +let pp_print_as = Format.pp_print_as;; +let pp_print_string = Format.pp_print_string;; +let pp_print_break = Format.pp_print_break;; +let pp_print_space fmt () = Format.pp_print_space fmt ();; +let pp_print_newline fmt () = Format.pp_print_newline fmt ();; + +let pp_open_box = Format.pp_open_box;; +let pp_open_hbox fmt () = Format.pp_open_hbox fmt ();; +let pp_open_vbox = Format.pp_open_vbox;; +let pp_open_hvbox = Format.pp_open_hvbox;; +let pp_close_box fmt () = Format.pp_close_box fmt ();; + +let pp_get_max_boxes fmt () = Format.pp_get_max_boxes fmt ();; +let pp_set_max_boxes fmt i = Format.pp_set_max_boxes fmt i;; +let set_max_boxes i = Format.set_max_boxes i;; + +let print_break l i = Format.print_break l i;; +let print_space () = Format.print_space ();; + +let open_box = Format.open_box;; +let open_hbox () = Format.open_hbox ();; +let open_vbox = Format.open_vbox;; +let open_hvbox = Format.open_hvbox;; +let close_box () = Format.close_box ();; + +set_max_boxes 100;; + (* ------------------------------------------------------------------------- *) (* Flag determining whether interface/overloading is reversed on printing. *) (* ------------------------------------------------------------------------- *) @@ -347,8 +379,8 @@ let pp_print_term,pp_print_colored_term = try (let tms = dest_list tm in try if fst(dest_type(hd(snd(dest_type(type_of tm))))) <> "char" then fail() else - let ccs = map (String.str o Char.chr o code_of_term) tms in - let s = "\"" ^ string_escaped (implode ccs) ^ "\"" in + let ccs = map (String.make 1 o Char.chr o code_of_term) tms in + let s = "\"" ^ String.escaped (implode ccs) ^ "\"" in pp_print_string fmt s with Failure _ -> pp_open_box fmt 0; pp_print_string fmt "["; @@ -450,7 +482,7 @@ let pp_print_term,pp_print_colored_term = with Failure _ -> if s = "COND" && length args = 3 then ((if prec = 0 then () else pp_print_string fmt "("); - pp_open_hvbox fmt (-1); + pp_open_hvbox fmt (~-1); (let ccls,ecl = splitlist pdest_cond tm in if length ccls <= 4 then (color_switch pp_print_colored_resword fmt "if "; @@ -523,7 +555,7 @@ let pp_print_term,pp_print_colored_term = let s' = if parses_as_binder s || can get_infix_status s || is_prefix s then "("^s^")" else s in let rec has_invented_typevar (ty:hol_type): bool = - if is_vartype ty then (dest_vartype ty).[0] = '?' + if is_vartype ty then String.get (dest_vartype ty) 0 = '?' else List.exists has_invented_typevar (snd (dest_type ty)) in if !print_types_of_subterms = 2 || (!print_types_of_subterms = 1 && has_invented_typevar (type_of hop)) @@ -676,9 +708,25 @@ let print_thm = Pretty.print_stdout pp_print_thm;; (* Conversions to string. *) (* ------------------------------------------------------------------------- *) -let string_of_type = print_to_string pp_print_type;; -let string_of_term = print_to_string pp_print_term;; -let string_of_thm = print_to_string pp_print_thm;; +(* +let print_to_string printer = + let buf = Buffer.create 16 in + let fmt = formatter_of_buffer buf in + let () = pp_set_max_boxes fmt 100 in + let print = printer fmt in + let flush = pp_print_flush fmt in + fun x -> + let () = pp_set_margin fmt (get_margin ()) in + let () = print x in + let () = flush () in + let s = Buffer.contents buf in + let () = Buffer.reset buf in + s;; +*) + +let string_of_type = Pretty.print_to_string pp_print_type;; +let string_of_term = Pretty.print_to_string pp_print_term;; +let string_of_thm = Pretty.print_to_string pp_print_thm;; (* ------------------------------------------------------------------------- *) (* Install printers for term, type and thm. *) diff --git a/quot.ml b/quot.ml index 6d95b565..70be61e3 100644 --- a/quot.ml +++ b/quot.ml @@ -7,7 +7,7 @@ (* (c) Copyright, John Harrison 1998-2007 *) (* ========================================================================= *) -needs "meson.ml";; +needs "metis.ml";; (* ------------------------------------------------------------------------- *) (* Given a type name "ty" and a curried binary relation R, this defines *) diff --git a/recursion.ml b/recursion.ml index 4e52abfc..1fe79296 100644 --- a/recursion.ml +++ b/recursion.ml @@ -30,7 +30,7 @@ let prove_recursive_functions_exist = let raxs = map (findax o fst o dest_const o repeat rator o hd o snd) lpats in let axfns = map (repeat rator o lhand o snd o strip_forall) raxs in - let (<=) x y = Pair.compare Term.compare Term.compare x y <> Greater in + let (<=) x y = Pair.compare Term.compare Term.compare x y <= 0 in let urfns = map (fun v -> assocd v (setify (<=) (zip axfns (map fst lpats))) v) exvs in diff --git a/simp.ml b/simp.ml index c0b121dd..5e5753f2 100644 --- a/simp.ml +++ b/simp.ml @@ -76,7 +76,7 @@ let term_order = else if f2 = top then false else if f1 = top then true - else Term.(<) f2 f1 in + else Term.(>) f1 f2 in dyn_order `T`;; (* ------------------------------------------------------------------------- *) @@ -214,12 +214,14 @@ let apply_prover(Prover(conv,_)) tm = conv tm;; (* We also have a type of (traversal) strategy, following Konrad. *) (* ------------------------------------------------------------------------- *) +(* Candle: datatypes and type abbreviations can't be made mutually recursive *) type 'a strat = 'a -> int -> term -> thm;; type simpset = - Simpset of gconv net (* Rewrites & congruences *) - * (simpset strat -> simpset strat) (* Prover for conditions *) - * prover list (* Subprovers for prover *) - * (thm -> thm list -> thm list) (* Rewrite maker *) + Simpset of gconv net (* Rewrites & congruences *) + * (simpset strat -> simpset strat) (* Prover for conditions *) + * prover list (* Subprovers for prover *) + * (thm -> thm list -> thm list) (* Rewrite maker *) +;; type strategy = simpset strat;; (* ------------------------------------------------------------------------- *) diff --git a/system.ml b/system.ml index dce8a8ae..9df94c60 100644 --- a/system.ml +++ b/system.ml @@ -10,14 +10,14 @@ let quotexpander s = if s = "" then failwith "Empty quotation" else - let c = String.sub s 0 in + let c = Cake.String.sub s 0 in if c = ':' then "parse_type \"" ^ - string_escaped (String.substring s 1 (String.size s - 1)) ^ "\"" + string_escaped (Cake.String.substring s 1 (Cake.String.size s - 1)) ^ "\"" else if c = ';' then "parse_qproof \"" ^ string_escaped s ^ "\"" else - let n = String.size s - 1 in - if String.substring s n 1 = ":" - then "\"" ^ string_escaped (String.substring s 0 n) ^ "\"" + let n = Cake.String.size s - 1 in + if Cake.String.substring s n 1 = ":" + then "\"" ^ string_escaped (Cake.String.substring s 0 n) ^ "\"" else "parse_term \"" ^ string_escaped s ^ "\"";; let _ = Cakeml.unquote := quotexpander;; diff --git a/tactics.ml b/tactics.ml index 5db2c7c4..3fb0df58 100644 --- a/tactics.ml +++ b/tactics.ml @@ -130,7 +130,7 @@ let (VALID:tactic->tactic) = (* Various simple combinators for tactics, identity tactic etc. *) (* ------------------------------------------------------------------------- *) -let (THEN),(THENL),then1_,then_ = +let (THEN),(THENL),then_,then1_ = let propagate_empty i [] = [] and propagate_thm th i [] = INSTANTIATE_ALL i th in let compose_justs n just1 just2 insts2 i ths = @@ -161,7 +161,7 @@ let (THEN),(THENL),then1_,then_ = let _,gls,_ as gstate = tac1 g in if gls = [] then tacsequence gstate [] else tacsequence gstate tac2l in - then_,thenl_,(fun tac1 tac2 -> thenl_ tac1 [tac2]),then_;; + then_,thenl_,then_,(fun tac1 tac2 -> thenl_ tac1 [tac2]);; let ((ORELSE): tactic -> tactic -> tactic) = fun tac1 tac2 g -> @@ -765,8 +765,8 @@ let ANTS_TAC = (* Set to None if the formatter's default max boxes value is to be used. *) let print_goal_hyp_max_boxes = ref (None:int option);; -let (pp_print_goal:formatter->goal->unit), - (pp_print_colored_goal:formatter->goal->unit) = +let (pp_print_goal:Format.formatter->goal->unit), + (pp_print_colored_goal:Format.formatter->goal->unit) = let with_color (color_flag:bool) = let string_of_int3 n = if n < 10 then " "^string_of_int n @@ -774,8 +774,8 @@ let (pp_print_goal:formatter->goal->unit), else string_of_int n in let print_hyp fmt n (s,th) = pp_open_hbox fmt (); - pp_print_string fmt (string_of_int3 n); - pp_print_string fmt " ["; + Format.pp_print_string fmt (string_of_int3 n); + Format.pp_print_string fmt " ["; pp_open_hvbox fmt 0; let old_max_boxes = pp_get_max_boxes fmt () in (match !print_goal_hyp_max_boxes with @@ -785,39 +785,39 @@ let (pp_print_goal:formatter->goal->unit), fmt (concl th); pp_set_max_boxes fmt old_max_boxes; pp_close_box fmt (); - pp_print_string fmt "]"; - (if not (s = "") then (pp_print_string fmt (" ("^s^")")) else ()); + Format.pp_print_string fmt "]"; + (if not (s = "") then (Format.pp_print_string fmt (" ("^s^")")) else ()); pp_close_box fmt (); - pp_print_newline fmt () in + Format.pp_print_newline fmt () in let rec print_hyps fmt n asl = if asl = [] then () else (print_hyp fmt n (hd asl); print_hyps fmt (n + 1) (tl asl)) in fun fmt (asl,w) -> - pp_print_newline fmt (); + Format.pp_print_newline fmt (); if asl <> [] - then (print_hyps fmt 0 (rev asl); pp_print_newline fmt ()) + then (print_hyps fmt 0 (rev asl); Format.pp_print_newline fmt ()) else (); (if color_flag then pp_print_colored_qterm else pp_print_qterm) fmt w; - pp_print_newline fmt () in + Format.pp_print_newline fmt () in with_color false, with_color true;; -let (pp_print_goalstack:formatter->goalstack->unit), - (pp_print_colored_goalstack:formatter->goalstack->unit) = +let (pp_print_goalstack:Format.formatter->goalstack->unit), + (pp_print_colored_goalstack:Format.formatter->goalstack->unit) = let print_goalstate color_flag fmt k gs = let (_,gl,_) = gs in let n = length gl in let s = if n = 0 then "No subgoals" else (string_of_int k)^" subgoal"^(if k > 1 then "s" else "") ^" ("^(string_of_int n)^" total)" in - pp_print_string fmt s; pp_print_newline fmt (); + Format.pp_print_string fmt s; Format.pp_print_newline fmt (); if gl = [] then () else do_list ((if color_flag then pp_print_colored_goal else pp_print_goal) fmt o C el gl) (rev(0--(k-1))) in let fn color_flag fmt l = - if l = [] then pp_print_string fmt "Empty goalstack" + if l = [] then Format.pp_print_string fmt "Empty goalstack" else if tl l = [] then let (_,gl,_ as gs) = hd l in print_goalstate color_flag fmt 1 gs @@ -910,8 +910,9 @@ let (TAC_PROOF : goal * tactic -> thm) = let prove(t,tac) = let th = TAC_PROOF(([],t),tac) in - let t' = concl th in - if t' = t then th else + let asl,t' = dest_thm th in + if asl <> [] then failwith "prove: additional assumptions in result" + else if t' = t then th else try EQ_MP (ALPHA t' t) th with Failure _ -> failwith "prove: justification generated wrong theorem";; @@ -921,14 +922,14 @@ let prove(t,tac) = let current_goalstack = ref ([] :goalstack);; -let (refine:refinement->unit) = +let (refine:refinement->goalstack) = fun r -> let l = !current_goalstack in if l = [] then failwith "No current goal" else let h = hd l in let res = r h :: l in current_goalstack := res; - print_goalstack (!current_goalstack);; + !current_goalstack;; let flush_goalstack() = let l = !current_goalstack in @@ -959,10 +960,10 @@ let er tac = e_result end else begin (if !verbose then print_goalstack !current_goalstack); - remark (String.concat [ + remark (String.concat "" [ "\n(Rotating "; - Int.toString n_subgoals_to_rotate; - "subgoal"; + Int.to_string n_subgoals_to_rotate; + " subgoal"; (if n_subgoals_to_rotate = 1 then "" else "s"); "...)\n\n"]); let new_g = r n_subgoals_to_rotate in @@ -975,10 +976,10 @@ let er tac = let set_goal(asl,w) = current_goalstack := [mk_goalstate(map (fun t -> "",ASSUME t) asl,w)]; - print_goalstack (!current_goalstack);; + !current_goalstack;; let g t = - let fvs = sort String.(<) (map (fst o dest_var) (frees t)) in + let fvs = sort (fun x y -> String.compare x y < 0) (map (fst o dest_var) (frees t)) in (if fvs <> [] then let errmsg = end_itlist (fun s t -> s^", "^t) fvs in warn true ("Free variables in goal: "^errmsg) @@ -989,10 +990,10 @@ let b() = let l = !current_goalstack in if length l = 1 then failwith "Can't back up any more" else current_goalstack := tl l; - print_goalstack (!current_goalstack);; + !current_goalstack;; let p() = - print_goalstack (!current_goalstack);; + !current_goalstack;; let top_realgoal() = let (_,((asl,w)::_),_)::_ = !current_goalstack in diff --git a/test.sh b/test.sh new file mode 100755 index 00000000..dd3d64a8 --- /dev/null +++ b/test.sh @@ -0,0 +1,8 @@ +#!/bin/bash +set -euo pipefail + +# Set up Candle +./build-instructions.sh + +# Run regression suite +python candle-regression.py \ No newline at end of file diff --git a/unit_tests.ml b/unit_tests.ml index 64850f3d..a3601771 100644 --- a/unit_tests.ml +++ b/unit_tests.ml @@ -200,6 +200,16 @@ assert (pow (num 1 // num 2) (-3) = num 8);; assert (pow (num 1 // num 2) (-4) = num 16);; assert (pow (num 1 // num 2) 0 = num 1);; +(* ------------------------------------------------------------------------- *) +(* Test UNIFY_REFL_TAC. *) +(* ------------------------------------------------------------------------- *) + +let UNIFY_REFL_TAC_TEST = prove(`?x. 1 = x`, META_EXISTS_TAC THEN UNIFY_REFL_TAC);; +let UNIFY_REFL_TAC_TEST2 = prove(`?f. y + z = f y z`, + META_EXISTS_TAC THEN UNIFY_REFL_TAC);; +let UNIFY_REFL_TAC_TEST3 = prove(`?f. y + 1 = f y 0`, + META_EXISTS_TAC THEN UNIFY_REFL_TAC);; + (* ------------------------------------------------------------------------- *) (* Test pa_j preprocessor. *)