From 4343a44dfece4757cd20037c6995922e4f59fe47 Mon Sep 17 00:00:00 2001 From: Juneyoung Lee Date: Thu, 29 Jan 2026 08:37:34 -0600 Subject: [PATCH 01/79] Add UNIFY_REFL_TAC to unify metavariables in equality This patch adds `UNIFY_REFL_TAC`, which is a simple extension of `UNIFY_ACCEPT_TAC` for the case when the goal is an equality `t = x` and `x` is a metavariable. If the goal is `e = f x y z` and `f` is a metavariable, it instantiates `f` with `\x y z. e` (the number of arguments does not have to be 3 and can vary). This is adopted from `UNIFY_REFL_TAC` in s2n-bignum. --- Help/UNIFY_ACCEPT_TAC.hlp | 4 +-- Help/UNIFY_REFL_TAC.hlp | 57 +++++++++++++++++++++++++++++++++++++++ itab.ml | 43 +++++++++++++++++++++++++---- unit_tests.ml | 10 +++++++ 4 files changed, 107 insertions(+), 7 deletions(-) create mode 100644 Help/UNIFY_REFL_TAC.hlp 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/itab.ml b/itab.ml index 573bba31..04bee87f 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 _ = Printf.printf + "UNIFY_REFL_TAC: warning: this isn't var: %s\n" + (string_of_term v) 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/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. *) From c845dd3bcc09a816b009d2b373958c3cdd3893fc Mon Sep 17 00:00:00 2001 From: John Harrison Date: Fri, 30 Jan 2026 06:15:24 +0000 Subject: [PATCH 02/79] 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. --- CHANGES | 72 +++ Multivariate/complex_database.ml | 23 + Multivariate/metric.ml | 793 ++++++++++++++++++++++++++ Multivariate/multivariate_database.ml | 23 + Multivariate/paths.ml | 5 +- Multivariate/topology.ml | 202 ++----- 6 files changed, 948 insertions(+), 170 deletions(-) diff --git a/CHANGES b/CHANGES index 0a27dfa1..954b8abd 100644 --- a/CHANGES +++ b/CHANGES @@ -8,6 +8,78 @@ * page: https://github.com/jrh13/hol-light/commits/master * * ***************************************************************** +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/Multivariate/complex_database.ml b/Multivariate/complex_database.ml index cf8ae137..ef61a7de 100644 --- a/Multivariate/complex_database.ml +++ b/Multivariate/complex_database.ml @@ -5686,6 +5686,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; @@ -12553,12 +12554,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; @@ -12607,6 +12610,20 @@ 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_SUBSET",MDIAMETER_SUBSET; +"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; @@ -12961,6 +12978,7 @@ theorems := "METRIZABLE_IMP_NORMAL_SPACE",METRIZABLE_IMP_NORMAL_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_COMPLETION",METRIZABLE_SPACE_COMPLETION; "METRIZABLE_SPACE_DISCRETE_TOPOLOGY",METRIZABLE_SPACE_DISCRETE_TOPOLOGY; "METRIZABLE_SPACE_EUCLIDEAN",METRIZABLE_SPACE_EUCLIDEAN; @@ -17024,6 +17042,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; @@ -17561,6 +17580,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; @@ -19392,6 +19412,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; @@ -20291,6 +20313,7 @@ theorems := "mbounded",mbounded; "mcball",mcball; "mcomplete",mcomplete; +"mdiameter",mdiameter; "mdist",mdist; "measurable",measurable; "measurable_on",measurable_on; diff --git a/Multivariate/metric.ml b/Multivariate/metric.ml index 2cca33f8..0b0994c0 100644 --- a/Multivariate/metric.ml +++ b/Multivariate/metric.ml @@ -23418,6 +23418,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. *) (* ------------------------------------------------------------------------- *) @@ -31248,6 +31255,398 @@ let LAVRENTIEV_EXTENSION = prove REWRITE_TAC[SET_RULE `c INTER u = u <=> u SUBSET c`] THEN ASM_MESON_TAC[SUBSET_TRANS; GDELTA_IN_SUBSET]]);; +(* ------------------------------------------------------------------------- *) +(* Diameter of a set in a metric space. *) +(* ------------------------------------------------------------------------- *) + +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 MDIAMETER_EMPTY = prove + (`!m:A metric. mdiameter m {} = &0`, + REWRITE_TAC[mdiameter]);; + +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 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 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 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 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 + `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 + 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 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]);; + +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[]);; + (* ------------------------------------------------------------------------- *) (* "Capped" equivalent bounded metrics and general product metrics. *) (* ------------------------------------------------------------------------- *) @@ -31751,6 +32150,400 @@ let (METRIZABLE_SPACE_PRODUCT_TOPOLOGY, 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. *) (* ------------------------------------------------------------------------- *) diff --git a/Multivariate/multivariate_database.ml b/Multivariate/multivariate_database.ml index f4d6767e..79705413 100644 --- a/Multivariate/multivariate_database.ml +++ b/Multivariate/multivariate_database.ml @@ -4708,6 +4708,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; @@ -10790,12 +10791,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; @@ -10844,6 +10847,20 @@ 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_SUBSET",MDIAMETER_SUBSET; +"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; @@ -11191,6 +11208,7 @@ theorems := "METRIZABLE_IMP_NORMAL_SPACE",METRIZABLE_IMP_NORMAL_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_COMPLETION",METRIZABLE_SPACE_COMPLETION; "METRIZABLE_SPACE_DISCRETE_TOPOLOGY",METRIZABLE_SPACE_DISCRETE_TOPOLOGY; "METRIZABLE_SPACE_EUCLIDEAN",METRIZABLE_SPACE_EUCLIDEAN; @@ -14133,6 +14151,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; @@ -14550,6 +14569,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; @@ -16164,6 +16184,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; @@ -16905,6 +16927,7 @@ theorems := "mbounded",mbounded; "mcball",mcball; "mcomplete",mcomplete; +"mdiameter",mdiameter; "mdist",mdist; "measurable",measurable; "measurable_on",measurable_on; diff --git a/Multivariate/paths.ml b/Multivariate/paths.ml index ba8fac96..e505c994 100644 --- a/Multivariate/paths.ml +++ b/Multivariate/paths.ml @@ -25687,8 +25687,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/topology.ml b/Multivariate/topology.ml index fbb203ce..e8bec2bf 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. *) From 93df5c12500e6bafe6c197628edaa7eb15dfdc81 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 6 Feb 2026 20:01:16 +0800 Subject: [PATCH 03/79] Up until lib.ml --- candle_boot.ml | 1 + candle_insulate.ml | 439 +++++++++++++++++++++++++++++++++++++++++++++ candle_insulate.py | 204 +++++++++++++++++++++ candle_kernel.ml | 21 ++- candle_nums.ml | 66 +++---- candle_ocaml.ml | 104 +++++++++++ candle_pretty.ml | 67 ++----- hol_lib.ml | 22 ++- lib.ml | 371 +++++++++++++++++++++++--------------- system.ml | 10 +- 10 files changed, 1053 insertions(+), 252 deletions(-) create mode 100644 candle_insulate.ml create mode 100644 candle_insulate.py create mode 100644 candle_ocaml.ml diff --git a/candle_boot.ml b/candle_boot.ml index ac96b84d..9df3ee8d 100644 --- a/candle_boot.ml +++ b/candle_boot.ml @@ -14,6 +14,7 @@ let (-.) = Double.(-);; let (+.) = Double.(+);; let ( *.) = Double.( * );; let (/.) = Double.(/);; +let (~-) x = -x;; let failwith msg = raise (Failure msg);; diff --git a/candle_insulate.ml b/candle_insulate.ml new file mode 100644 index 00000000..957e3e93 --- /dev/null +++ b/candle_insulate.ml @@ -0,0 +1,439 @@ +(* Generated by candle_insulate.py based on CakeML's types.txt *) +(* This file insulates the codebase from direct CakeML API usage *) + +module Cake = struct + module Alist = struct + let delete x0 x1 = Alist.delete x0 x1 + let every x0 x1 = Alist.every x0 x1 + let lookup x0 x1 = Alist.lookup x0 x1 + let map x0 x1 = Alist.map x0 x1 + let update x0 x1 = Alist.update x0 x1 + end;; + + module Array = struct + let all x0 x1 = Array.all x0 x1 + let app x0 x1 = Array.app x0 x1 + let appi x0 x1 = Array.appi x0 x1 + let array x0 x1 = Array.array x0 x1 + let arrayEmpty x0 = Array.arrayEmpty x0 + let collate x0 x1 x2 = Array.collate x0 x1 x2 + let copy x0 x1 x2 = Array.copy x0 x1 x2 + let copyVec x0 x1 x2 = Array.copyVec x0 x1 x2 + let exists x0 x1 = Array.exists x0 x1 + let find x0 x1 = Array.find x0 x1 + let findi x0 x1 = Array.findi x0 x1 + let foldl x0 x1 x2 = Array.foldl x0 x1 x2 + let foldli x0 x1 x2 = Array.foldli x0 x1 x2 + let foldr x0 x1 x2 = Array.foldr x0 x1 x2 + let foldri x0 x1 x2 = Array.foldri x0 x1 x2 + let fromList x0 = Array.fromList x0 + let length x0 = Array.length x0 + let lookup x0 x1 x2 = Array.lookup x0 x1 x2 + let modify x0 x1 = Array.modify x0 x1 + let modifyi x0 x1 = Array.modifyi x0 x1 + let sub x0 x1 = Array.sub x0 x1 + let tabulate x0 x1 = Array.tabulate x0 x1 + let update x0 x1 x2 = Array.update x0 x1 x2 + let updateResize x0 x1 x2 x3 = Array.updateResize x0 x1 x2 x3 + end;; + + module Bool = struct + let (=) x0 x1 = Bool.(=) x0 x1 + let compare x0 x1 = Bool.compare x0 x1 + let fromString x0 = Bool.fromString x0 + let not x0 = Bool.not x0 + let toString x0 = Bool.toString x0 + end;; + + module Char = struct + let (<) x0 x1 = Char.(<) x0 x1 + let (<=) x0 x1 = Char.(<=) x0 x1 + let (=) x0 x1 = Char.(=) x0 x1 + let (>) x0 x1 = Char.(>) x0 x1 + let (>=) x0 x1 = Char.(>=) x0 x1 + let chr x0 = Char.chr x0 + let fromByte x0 = Char.fromByte x0 + let isSpace x0 = Char.isSpace x0 + let ord x0 = Char.ord x0 + let some x0 = Char.some x0 + end;; + + module Command_line = struct + let arguments x0 = Command_line.arguments x0 + let cline x0 = Command_line.cline x0 + let name x0 = Command_line.name x0 + end;; + + module Double = struct + type double = Double.double + + let ( * ) x0 x1 = Double.( * ) x0 x1 + let (+) x0 x1 = Double.(+) x0 x1 + let (-) x0 x1 = Double.(-) x0 x1 + let (/) x0 x1 = Double.(/) x0 x1 + let (<) x0 x1 = Double.(<) x0 x1 + let (<=) x0 x1 = Double.(<=) x0 x1 + let (=) x0 x1 = Double.(=) x0 x1 + let (>) x0 x1 = Double.(>) x0 x1 + let (>=) x0 x1 = Double.(>=) x0 x1 + let abs x0 = Double.abs x0 + let construct x0 x1 x2 = Double.construct x0 x1 x2 + let exp x0 = Double.exp x0 + let exponent x0 = Double.exponent x0 + let ffloat_ulp x0 = Double.ffloat_ulp x0 + let float_is_finite x0 = Double.float_is_finite x0 + let float_is_zero x0 = Double.float_is_zero x0 + let floor x0 = Double.floor x0 + let flt_max = Double.flt_max + let fma x0 x1 x2 = Double.fma x0 x1 x2 + let fnext_hi x0 = Double.fnext_hi x0 + let fnext_lo x0 = Double.fnext_lo x0 + let fromInt x0 = Double.fromInt x0 + let fromString x0 = Double.fromString x0 + let fromWord x0 = Double.fromWord x0 + let ln x0 = Double.ln x0 + let maxulp = Double.maxulp + let neginf64 = Double.neginf64 + let posinf64 = Double.posinf64 + let posmin64 = Double.posmin64 + let poszero64 = Double.poszero64 + let pow x0 x1 = Double.pow x0 x1 + let pp_double x0 = Double.pp_double x0 + let sign x0 = Double.sign x0 + let significand x0 = Double.significand x0 + let sqrt x0 = Double.sqrt x0 + let toInt x0 = Double.toInt x0 + let toString x0 = Double.toString x0 + let toWord x0 = Double.toWord x0 + let twicemaxulp = Double.twicemaxulp + end;; + + module Hashtable = struct + let clear x0 = Hashtable.clear x0 + let delete x0 x1 = Hashtable.delete x0 x1 + let empty x0 x1 x2 = Hashtable.empty x0 x1 x2 + let insert x0 x1 x2 = Hashtable.insert x0 x1 x2 + let lookup x0 x1 = Hashtable.lookup x0 x1 + let size x0 = Hashtable.size x0 + let toAscList x0 = Hashtable.toAscList x0 + end;; + + module Int = struct + let ( * ) x0 x1 = Int.( * ) x0 x1 + let (+) x0 x1 = Int.(+) x0 x1 + let (-) x0 x1 = Int.(-) x0 x1 + let (<) x0 x1 = Int.(<) x0 x1 + let (<=) x0 x1 = Int.(<=) x0 x1 + let (>) x0 x1 = Int.(>) x0 x1 + let (>=) x0 x1 = Int.(>=) x0 x1 + let (mod) x0 x1 = Int.(mod) x0 x1 + let compare x0 x1 = Int.compare x0 x1 + let div x0 x1 = Int.div x0 x1 + let fromNatString x0 = Int.fromNatString x0 + let fromString x0 = Int.fromString x0 + let gcd x0 x1 = Int.gcd x0 x1 + let int_to_string x0 x1 = Int.int_to_string x0 x1 + let toString x0 = Int.toString x0 + end;; + + module List = struct + let (@) x0 x1 = List.(@) x0 x1 + let all x0 x1 = List.all x0 x1 + let all_distinct x0 = List.all_distinct x0 + let app x0 x1 = List.app x0 x1 + let cmp x0 x1 x2 = List.cmp x0 x1 x2 + let collate x0 x1 x2 = List.collate x0 x1 x2 + let compare x0 x1 x2 = List.compare x0 x1 x2 + let concat x0 = List.concat x0 + let drop x0 x1 = List.drop x0 x1 + let dropUntil x0 x1 = List.dropUntil x0 x1 + let exists x0 x1 = List.exists x0 x1 + let filter x0 x1 = List.filter x0 x1 + let filterRev x0 x1 = List.filterRev x0 x1 + let find x0 x1 = List.find x0 x1 + let flatRev x0 = List.flatRev x0 + let foldl x0 x1 x2 = List.foldl x0 x1 x2 + let foldli x0 x1 x2 = List.foldli x0 x1 x2 + let foldr x0 x1 x2 = List.foldr x0 x1 x2 + let foldri x0 x1 x2 = List.foldri x0 x1 x2 + let front x0 = List.front x0 + let genlist x0 x1 = List.genlist x0 x1 + let getItem x0 = List.getItem x0 + let hd x0 = List.hd x0 + let isPrefix x0 x1 = List.isPrefix x0 x1 + let last x0 = List.last x0 + let length x0 = List.length x0 + let map x0 x1 = List.map x0 x1 + let mapPartial x0 x1 = List.mapPartial x0 x1 + let mapRev x0 x1 = List.mapRev x0 x1 + let mapi x0 x1 = List.mapi x0 x1 + let member x0 x1 = List.member x0 x1 + let nth x0 x1 = List.nth x0 x1 + let null x0 = List.null x0 + let pad_left x0 x1 x2 = List.pad_left x0 x1 x2 + let pad_right x0 x1 x2 = List.pad_right x0 x1 x2 + let partition x0 x1 = List.partition x0 x1 + let rev x0 = List.rev x0 + let snoc x0 x1 = List.snoc x0 x1 + let sort x0 x1 = List.sort x0 x1 + let split x0 x1 = List.split x0 x1 + let splitAtPki x0 x1 x2 = List.splitAtPki x0 x1 x2 + let sum x0 = List.sum x0 + let tabulate x0 x1 = List.tabulate x0 x1 + let take x0 x1 = List.take x0 x1 + let takeUntil x0 x1 = List.takeUntil x0 x1 + let tl x0 = List.tl x0 + let unzip x0 = List.unzip x0 + let update x0 x1 x2 = List.update x0 x1 x2 + let zip x0 = List.zip x0 + end;; + + module Map = struct + let all x0 x1 = Map.all x0 x1 + let compare x0 x1 x2 = Map.compare x0 x1 x2 + let delete x0 x1 = Map.delete x0 x1 + let empty x0 = Map.empty x0 + let exists x0 x1 = Map.exists x0 x1 + let filter x0 x1 = Map.filter x0 x1 + let filterWithKey x0 x1 = Map.filterWithKey x0 x1 + let foldrWithKey x0 x1 x2 = Map.foldrWithKey x0 x1 x2 + let fromList x0 x1 = Map.fromList x0 x1 + let insert x0 x1 x2 = Map.insert x0 x1 x2 + let isSubmap x0 x1 = Map.isSubmap x0 x1 + let isSubmapBy x0 x1 x2 = Map.isSubmapBy x0 x1 x2 + let lookup x0 x1 = Map.lookup x0 x1 + let map x0 x1 = Map.map x0 x1 + let mapWithKey x0 x1 = Map.mapWithKey x0 x1 + let member x0 x1 = Map.member x0 x1 + let null x0 = Map.null x0 + let singleton x0 x1 x2 = Map.singleton x0 x1 x2 + let size x0 = Map.size x0 + let toAscList x0 = Map.toAscList x0 + let union x0 x1 = Map.union x0 x1 + let unionWith x0 x1 x2 = Map.unionWith x0 x1 x2 + let unionWithKey x0 x1 x2 = Map.unionWithKey x0 x1 x2 + end;; + + module Marshalling = struct + let n2w2 x0 x1 x2 = Marshalling.n2w2 x0 x1 x2 + let w22n x0 x1 = Marshalling.w22n x0 x1 + end;; + + module Option = struct + let compare x0 x1 x2 = Option.compare x0 x1 x2 + let compose x0 x1 x2 = Option.compose x0 x1 x2 + let composePartial x0 x1 x2 = Option.composePartial x0 x1 x2 + let getOpt x0 x1 = Option.getOpt x0 x1 + let isNone x0 = Option.isNone x0 + let isSome x0 = Option.isSome x0 + let join x0 = Option.join x0 + let map x0 x1 = Option.map x0 x1 + let map2 x0 x1 x2 = Option.map2 x0 x1 x2 + let mapPartial x0 x1 = Option.mapPartial x0 x1 + let valOf x0 = Option.valOf x0 + end;; + + module Pair = struct + let compare x0 x1 x2 x3 = Pair.compare x0 x1 x2 x3 + let map x0 x1 x2 = Pair.map x0 x1 x2 + let toString x0 x1 x2 = Pair.toString x0 x1 x2 + end;; + + module Rat = struct + type rat = Rat.rat + + let ( * ) x0 x1 = Rat.( * ) x0 x1 + let (+) x0 x1 = Rat.(+) x0 x1 + let (-) x0 x1 = Rat.(-) x0 x1 + let (/) x0 x1 = Rat.(/) x0 x1 + let (<) x0 x1 = Rat.(<) x0 x1 + let (<=) x0 x1 = Rat.(<=) x0 x1 + let (>) x0 x1 = Rat.(>) x0 x1 + let (>=) x0 x1 = Rat.(>=) x0 x1 + let ceiling x0 = Rat.ceiling x0 + let compare x0 x1 = Rat.compare x0 x1 + let denominator x0 = Rat.denominator x0 + let floor x0 = Rat.floor x0 + let fromInt x0 = Rat.fromInt x0 + let inv x0 = Rat.inv x0 + let is_int x0 = Rat.is_int x0 + let max x0 x1 = Rat.max x0 x1 + let min x0 x1 = Rat.min x0 x1 + let numerator x0 = Rat.numerator x0 + let pp_rat x0 = Rat.pp_rat x0 + let toString x0 = Rat.toString x0 + end;; + + module Runtime = struct + let abort x0 = Runtime.abort x0 + let debugMsg x0 = Runtime.debugMsg x0 + let exit x0 = Runtime.exit x0 + let fail x0 = Runtime.fail x0 + let fullGC x0 = Runtime.fullGC x0 + end;; + + module Set = struct + let all x0 x1 = Set.all x0 x1 + let compare x0 x1 = Set.compare x0 x1 + let delete x0 x1 = Set.delete x0 x1 + let empty x0 = Set.empty x0 + let exists x0 x1 = Set.exists x0 x1 + let filter x0 x1 = Set.filter x0 x1 + let fold x0 x1 x2 = Set.fold x0 x1 x2 + let fromList x0 x1 = Set.fromList x0 x1 + let insert x0 x1 = Set.insert x0 x1 + let isSubset x0 x1 = Set.isSubset x0 x1 + let map x0 x1 = Set.map x0 x1 + let member x0 x1 = Set.member x0 x1 + let null x0 = Set.null x0 + let singleton x0 x1 = Set.singleton x0 x1 + let size x0 = Set.size x0 + let toList x0 = Set.toList x0 + let translate x0 x1 x2 = Set.translate x0 x1 x2 + let union x0 x1 = Set.union x0 x1 + end;; + + module Sexp = struct + let fromString x0 = Sexp.fromString x0 + let inputSexp x0 = Sexp.inputSexp x0 + let pp_sexp x0 = Sexp.pp_sexp x0 + let pp_str_tree x0 = Sexp.pp_str_tree x0 + let str_tree_to_strings x0 x1 = Sexp.str_tree_to_strings x0 x1 + let toPrettyString x0 = Sexp.toPrettyString x0 + let toString x0 = Sexp.toString x0 + end;; + + module String = struct + let (<) x0 x1 = String.(<) x0 x1 + let (<=) x0 x1 = String.(<=) x0 x1 + let (=) x0 x1 = String.(=) x0 x1 + let (>) x0 x1 = String.(>) x0 x1 + let (>=) x0 x1 = String.(>=) x0 x1 + let (^) x0 x1 = String.(^) x0 x1 + let char_escape_seq x0 = String.char_escape_seq x0 + let collate x0 x1 x2 = String.collate x0 x1 x2 + let compare x0 x1 = String.compare x0 x1 + let concat x0 = String.concat x0 + let concatWith x0 x1 = String.concatWith x0 x1 + let escape_char x0 = String.escape_char x0 + let escape_str x0 = String.escape_str x0 + let explode x0 = String.explode x0 + let extract x0 x1 x2 = String.extract x0 x1 x2 + let fields x0 x1 = String.fields x0 x1 + let findi x0 x1 x2 = String.findi x0 x1 x2 + let implode x0 = String.implode x0 + let isPrefix x0 x1 = String.isPrefix x0 x1 + let isSubstring x0 x1 = String.isSubstring x0 x1 + let isSuffix x0 x1 = String.isSuffix x0 x1 + let size x0 = String.size x0 + let split x0 x1 = String.split x0 x1 + let str x0 = String.str x0 + let strcat x0 x1 = String.strcat x0 x1 + let sub x0 x1 = String.sub x0 x1 + let substring x0 x1 x2 = String.substring x0 x1 x2 + let tokens x0 x1 = String.tokens x0 x1 + let translate x0 x1 = String.translate x0 x1 + end;; + + module Vector = struct + let all x0 x1 = Vector.all x0 x1 + let collate x0 x1 x2 = Vector.collate x0 x1 x2 + let concat x0 = Vector.concat x0 + let exists x0 x1 = Vector.exists x0 x1 + let find x0 x1 = Vector.find x0 x1 + let findi x0 x1 = Vector.findi x0 x1 + let foldl x0 x1 x2 = Vector.foldl x0 x1 x2 + let foldli x0 x1 x2 = Vector.foldli x0 x1 x2 + let foldr x0 x1 x2 = Vector.foldr x0 x1 x2 + let foldri x0 x1 x2 = Vector.foldri x0 x1 x2 + let fromList x0 = Vector.fromList x0 + let length x0 = Vector.length x0 + let map x0 x1 = Vector.map x0 x1 + let mapi x0 x1 = Vector.mapi x0 x1 + let sub x0 x1 = Vector.sub x0 x1 + let tabulate x0 x1 = Vector.tabulate x0 x1 + let toList x0 = Vector.toList x0 + let update x0 x1 x2 = Vector.update x0 x1 x2 + end;; + + module Word64 = struct + let (+) x0 x1 = Word64.(+) x0 x1 + let (-) x0 x1 = Word64.(-) x0 x1 + let (<) x0 x1 = Word64.(<) x0 x1 + let (<<) x0 x1 = Word64.(<<) x0 x1 + let (<=) x0 x1 = Word64.(<=) x0 x1 + let (=) x0 x1 = Word64.(=) x0 x1 + let (>) x0 x1 = Word64.(>) x0 x1 + let (>=) x0 x1 = Word64.(>=) x0 x1 + let (>>) x0 x1 = Word64.(>>) x0 x1 + let andb x0 x1 = Word64.andb x0 x1 + let concatAll x0 x1 x2 x3 x4 x5 x6 x7 = Word64.concatAll x0 x1 x2 x3 x4 x5 x6 x7 + let fromInt x0 = Word64.fromInt x0 + let notb x0 = Word64.notb x0 + let orb x0 x1 = Word64.orb x0 x1 + let ror x0 x1 = Word64.ror x0 x1 + let toInt x0 = Word64.toInt x0 + let toIntSigned x0 = Word64.toIntSigned x0 + let xorb x0 x1 = Word64.xorb x0 x1 + end;; + + module Word8 = struct + let (+) x0 x1 = Word8.(+) x0 x1 + let (-) x0 x1 = Word8.(-) x0 x1 + let (<) x0 x1 = Word8.(<) x0 x1 + let (<<) x0 x1 = Word8.(<<) x0 x1 + let (<=) x0 x1 = Word8.(<=) x0 x1 + let (=) x0 x1 = Word8.(=) x0 x1 + let (>) x0 x1 = Word8.(>) x0 x1 + let (>=) x0 x1 = Word8.(>=) x0 x1 + let (>>) x0 x1 = Word8.(>>) x0 x1 + let andb x0 x1 = Word8.andb x0 x1 + let fromInt x0 = Word8.fromInt x0 + let notb x0 = Word8.notb x0 + let orb x0 x1 = Word8.orb x0 x1 + let ror x0 x1 = Word8.ror x0 x1 + let toInt x0 = Word8.toInt x0 + let toIntSigned x0 = Word8.toIntSigned x0 + let xorb x0 x1 = Word8.xorb x0 x1 + end;; + + module Word8_array = struct + let array x0 x1 = Word8_array.array x0 x1 + let copy x0 x1 x2 x3 x4 = Word8_array.copy x0 x1 x2 x3 x4 + let copyVec x0 x1 x2 x3 x4 = Word8_array.copyVec x0 x1 x2 x3 x4 + let findi x0 x1 = Word8_array.findi x0 x1 + let length x0 = Word8_array.length x0 + let sub x0 x1 = Word8_array.sub x0 x1 + let substring x0 x1 x2 = Word8_array.substring x0 x1 x2 + let update x0 x1 x2 = Word8_array.update x0 x1 x2 + end;; + +end;; + +(* Empty module stubs to prevent direct CakeML API usage *) +(* Users must access these through the Cake module *) + +module Alist = struct end;; +module Array = struct end;; +module Bool = struct end;; +module Char = struct end;; +module Command_line = struct end;; +module Double = struct end;; +module Hashtable = struct end;; +module Int = struct end;; +module List = struct end;; +module Map = struct end;; +module Marshalling = struct end;; +module Option = struct end;; +module Pair = struct end;; +module Rat = struct end;; +module Runtime = struct end;; +module Set = struct end;; +module Sexp = struct end;; +module String = struct end;; +module Vector = struct end;; +module Word64 = struct end;; +module Word8 = struct end;; +module Word8_array = struct end;; + +(* End of generated section *) \ No newline at end of file diff --git a/candle_insulate.py b/candle_insulate.py new file mode 100644 index 00000000..431e3a46 --- /dev/null +++ b/candle_insulate.py @@ -0,0 +1,204 @@ +#!/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 (see below) +} + +# 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. +MODULE_TYPES = { + 'Rat': ['rat'], + 'Double': ['double'] +} + +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 type_name in MODULE_TYPES[module_name]: + lines.append(f" type {type_name} = {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 empty module stubs to prevent direct access + lines.append("(* Empty module stubs to prevent direct CakeML API usage *)") + lines.append("(* Users must access these through the Cake module *)") + lines.append("") + + for ocaml_module_name in module_names: + 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..55584e8c 100644 --- a/candle_kernel.ml +++ b/candle_kernel.ml @@ -89,10 +89,10 @@ let mk_eq = module Type = struct let rec compare ty1 ty2 = match ty1, ty2 with - | Tyvar x1, Tyvar x2 -> String.compare x1 x2 + | Tyvar x1, Tyvar x2 -> Cake.String.compare x1 x2 | Tyvar _, Tyapp _ -> Less | Tyapp (x1,a1), Tyapp (x2,a2) -> - Pair.compare String.compare (List.compare compare) (x1,a1) (x2,a2) + Cake.Pair.compare Cake.String.compare (Cake.List.compare compare) (x1,a1) (x2,a2) | Tyapp _, Tyvar _ -> Greater ;; let (<) ty1 ty2 = compare ty1 ty2 = Less @@ -105,19 +105,19 @@ module Term = struct let rec compare t1 t2 = match t1, t2 with | Var (x1,ty1), Var (x2,ty2) -> - Pair.compare String.compare Type.compare (x1,ty1) (x2,ty2) + Cake.Pair.compare Cake.String.compare Type.compare (x1,ty1) (x2,ty2) | Var _, _ -> Less | Const (x1,ty1), Const (x2,ty2) -> - Pair.compare String.compare Type.compare (x1,ty1) (x2,ty2) + Cake.Pair.compare Cake.String.compare Type.compare (x1,ty1) (x2,ty2) | Const _, Var _ -> Greater | Const _, _ -> Less | Comb (s1,s2), Comb (t1,t2) -> - Pair.compare compare compare (s1,s2) (t1,t2) + Cake.Pair.compare compare compare (s1,s2) (t1,t2) | Comb _, Var _ -> Greater | Comb _, Const _ -> Greater | Comb _, Abs _ -> Less | Abs (s1,s2), Abs (t1,t2) -> - Pair.compare compare compare (s1,s2) (t1,t2) + Cake.Pair.compare compare compare (s1,s2) (t1,t2) | Abs _, _ -> Greater ;; let (<) t1 t2 = compare t1 t2 = Less @@ -128,7 +128,7 @@ end;; module Thm = struct let compare th1 th2 = - Pair.compare (List.compare Term.compare) Term.compare + Cake.Pair.compare (Cake.List.compare Term.compare) Term.compare (dest_thm th1) (dest_thm th2) ;; @@ -154,7 +154,7 @@ let rec 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 Equal else match t1, t2 with | Var (_,_), Var (_,_) -> ordav env t1 t2 | Const (_,_), Const (_,_) -> Term.compare t1 t2 @@ -182,8 +182,8 @@ let alphaorder = orda [] let aconv s t = alphaorder s t = Equal;; -let tyvars t = List.map mk_vartype (tyvars t);; -let type_vars_in_term t = List.map mk_vartype (type_vars_in_term t);; +let tyvars t = Cake.List.map mk_vartype (tyvars t);; +let type_vars_in_term t = Cake.List.map mk_vartype (type_vars_in_term t);; (* ------------------------------------------------------------------------- *) (* Comparison function on theorems. Currently the same as equality, but *) @@ -191,4 +191,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..e13e1329 --- /dev/null +++ b/candle_ocaml.ml @@ -0,0 +1,104 @@ +exception Invalid_argument of string;; +exception Sys_error of string;; +exception End_of_file;; + +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" + | _ -> pp_exn e;; + +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 '\n' fd with + | Some l -> l + | None -> raise End_of_file +;; + +(* 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 + ;; +end;; + +module Float = struct + 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 +end;; + +module String = struct + let sub s pos len = try Cake.String.substring s pos len + with Subscript -> raise (Invalid_argument "String.sub") + let length s = Cake.String.size s;; + let compare x y = Candle.ordering_to_int Cake.String.compare x y +end;; + +module Printexc = struct + let to_string (e: exn) = "TODO stub (Printexc.to_string)" +end;; + +module Sys = struct + let time () = Float.zero;; (* TODO stub *) +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 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 ();; +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/hol_lib.ml b/hol_lib.ml index 8aaaf22c..1f1b91a7 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";; (* Move most of CakeML to Cake module. *) +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. *) diff --git a/lib.ml b/lib.ml index 9b65335f..74005fc4 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 @@ -205,9 +206,10 @@ 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 @@ -312,11 +314,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. *) @@ -362,35 +363,31 @@ let rec uniq l = (* Convert list into set by eliminating duplicates. *) (* ------------------------------------------------------------------------- *) -let setify (<=) s = uniq (sort (fun x y -> x <= y) s);; +(* +let setify s = uniq (sort (fun x y -> compare x y <= 0) 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 +435,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 +464,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;; (* ------------------------------------------------------------------------- *) @@ -528,11 +525,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. *) @@ -542,83 +539,100 @@ let decreasing (>) f x y = f x > f y;; (* *) (* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10). *) (* ------------------------------------------------------------------------- *) - -(* 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 - but you'll probably always use the same comparison functions for the same - types, anyway, if you need to compare functions. - *) - -type ('a,'b) func = Func of ('a -> 'a -> ordering) * ('a * 'b) list;; - -let pp_func pk pv (Func (cmp, f)) = - Pretty_printer.app_block "func" - [Pretty_printer.pp_list (fun (k, v) -> - Pretty_printer.tuple [pk k; pv v]) f];; +(* +type ('a,'b)func = + Empty + | Leaf of int * ('a*'b)list + | Branch of int * int * ('a,'b)func * ('a,'b)func;; (* ------------------------------------------------------------------------- *) (* Undefined function. *) (* ------------------------------------------------------------------------- *) -let undefined cmp = Func (cmp, []);; +let undefined = Empty;; (* ------------------------------------------------------------------------- *) (* In case of equality comparison worries, better use this. *) (* ------------------------------------------------------------------------- *) -let is_undefined (Func (_, f)) = +let is_undefined f = match f with - [] -> true + Empty -> true | _ -> false;; (* ------------------------------------------------------------------------- *) (* Operation analagous to "map" for lists. *) (* ------------------------------------------------------------------------- *) -let mapf f (Func (cmp, t)) = Func (cmp, map (I F_F f) t);; +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;; (* ------------------------------------------------------------------------- *) (* Operations analogous to "fold" for lists. *) (* ------------------------------------------------------------------------- *) -let rec foldl f a = - function [] -> a - | (x,y)::xs -> foldl f (f a x y) xs;; -let foldl f a (Func (_, t)) = foldl f a t;; +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 rec foldr f a = - function [] -> a - | (x,y)::xs -> f x y (foldr f a xs);; -let foldr f (Func (_, t)) a = foldr f a t;; +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;; (* ------------------------------------------------------------------------- *) (* Mapping to sorted-list representation of the graph, domain and range. *) (* ------------------------------------------------------------------------- *) -let graph (Func (cmp, t)) vcmp = - setify (fun x y -> Pair.compare cmp vcmp x y <> Greater) t;; +let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);; -let dom (Func (cmp, t)) = - setify (fun x y -> cmp x y <> Greater) (map fst t);; +let dom f = setify(foldl (fun a x y -> x::a) [] f);; -let ran (Func (cmp, t)) vcmp = - setify (fun x y -> vcmp x y <> Greater) (map snd t);; +let ran f = setify(foldl (fun a x y -> y::a) [] f);; (* ------------------------------------------------------------------------- *) (* Application. *) (* ------------------------------------------------------------------------- *) -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 - look f;; +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 apply f = applyd f (fun x -> failwith "apply");; @@ -630,71 +644,159 @@ let defined f x = try apply f x; true with Failure _ -> false;; (* Undefinition. *) (* ------------------------------------------------------------------------- *) -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 undefine x' (Func (cmp, t)) = Func (cmp, undefine x' cmp t);; +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;; (* ------------------------------------------------------------------------- *) (* Redefinition and combination. *) (* ------------------------------------------------------------------------- *) -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 - Func (cmp, ins x y t);; - -let combine op z (Func (cmp, t1)) (Func (_, t2)) = - let rec combine l1 l2 = - match l1, l2 with - | [], _ -> 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 - Func (cmp, combine t1 t2);; +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;; (* ------------------------------------------------------------------------- *) (* Special case of point function. *) (* ------------------------------------------------------------------------- *) -let (|=>) = fun x y cmp -> (x |-> y) (undefined cmp);; +let (|=>) = fun x y -> (x |-> y) undefined;; (* ------------------------------------------------------------------------- *) (* Grab an arbitrary element. *) (* ------------------------------------------------------------------------- *) -let choose (Func (_, t)) = - try hd t - with Failure _ -> - failwith "choose: completely undefined function";; +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;; +*) (* ------------------------------------------------------------------------- *) (* 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 +850,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 data = Text_io.inputAll fd in - Text_io.closeIn fd; data;; + let fd = open_in_bin filename in + let data = really_input_string fd (in_channel_length fd) in + (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/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;; From 8fb49ac8ba5288c2efbe33878fa6960045ae6782 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 6 Feb 2026 21:11:22 +0800 Subject: [PATCH 04/79] Up until printer.ml Might be broken because depend on OCaml parser change --- basics.ml | 5 ++- candle_ocaml.ml | 34 +++++++++++++--- printer.ml | 101 +++++++++++++++++++++++++++++++++++++----------- 3 files changed, 109 insertions(+), 31 deletions(-) diff --git a/basics.ml b/basics.ml index 0d6444c2..ebb396f5 100755 --- a/basics.ml +++ b/basics.ml @@ -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/candle_ocaml.ml b/candle_ocaml.ml index e13e1329..5d971de6 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -40,18 +40,42 @@ module Candle = struct end;; module Float = struct - let zero = Cake.Double.fromInt 0;; - let one = Cake.Double.fromInt 1;; - let minus_one = Cake.Double.fromInt ~-1;; + 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 end;; +module List = struct + let exists f xs = Cake.List.exists f xs +end;; + +module Char = struct + 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 +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") end;; module Printexc = struct @@ -84,8 +108,7 @@ module Format = struct let pp_get_max_boxes (fmt:formatter) () = ~-1;; (* TODO stub *) let pp_set_max_boxes (fmt:formatter) (i:int) = ();; (* TODO stub *) - - let print_to_string = Pretty.print_to_string;; + let set_max_boxes (i:int) = ();; (* TODO stub *) (* Functions that print to stdout: *) @@ -94,7 +117,6 @@ module Format = struct 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 ();; diff --git a/printer.ml b/printer.ml index 9781fa24..2bb262d8 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,45 @@ 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_to_string = Format.print_to_string;; + +(* Functions that print to stdout: *) + +let print_string = Format.print_string;; +let print_break l i = Format.print_break l i;; +let print_space () = Format.print_space ();; +let print_newline () = Format.print_newline ();; +let print_endline s = Format.print_endline s;; + +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 +386,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 +489,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 +562,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 +715,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. *) From 6ddc41f2d229e5d6577b28e347d5b10509ea3fbf Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Sat, 7 Feb 2026 00:04:54 +0800 Subject: [PATCH 05/79] Fix comment in candle_insulate.py --- candle_insulate.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/candle_insulate.py b/candle_insulate.py index 431e3a46..b880682b 100644 --- a/candle_insulate.py +++ b/candle_insulate.py @@ -24,7 +24,7 @@ '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 (see below) + '~', # parser issue } # Identifiers that are not symbols but still need to be parenthesized From 2c068cdb15f6ed237c5af6a432f1fbd46b52b137 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 10 Feb 2026 16:41:00 +0800 Subject: [PATCH 06/79] Adjust (~-) and (~-.) --- candle_boot.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/candle_boot.ml b/candle_boot.ml index 9df3ee8d..42632933 100644 --- a/candle_boot.ml +++ b/candle_boot.ml @@ -14,7 +14,14 @@ let (-.) = Double.(-);; let (+.) = Double.(+);; let ( *.) = Double.( * );; let (/.) = Double.(/);; -let (~-) x = -x;; + +(* OCaml parser doesn't like ~, and the CakeML parser doesn't like ~- nor ~-. *) +(*CML +val negint = Int.~; +val negfloat = Double.~; +*) +let (~-) x = negint x;; +let (~-.) x = negfloat x;; let failwith msg = raise (Failure msg);; From 4e70827156ed3f968fc0d9781163af5a3f687571 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 10 Feb 2026 16:41:36 +0800 Subject: [PATCH 07/79] Fix pointer equality (?) --- basics.ml | 4 ++-- candle_boot.ml | 9 +++++++-- lib.ml | 10 ++++++---- printer.ml | 4 ++-- 4 files changed, 17 insertions(+), 10 deletions(-) diff --git a/basics.ml b/basics.ml index ebb396f5..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. *) diff --git a/candle_boot.ml b/candle_boot.ml index 42632933..40fa23c8 100644 --- a/candle_boot.ml +++ b/candle_boot.ml @@ -3,9 +3,14 @@ * ------------------------------------------------------------------------- *) (* This is pointer equality, which is missing from CakeML. - || x = y is just to get the type variables right: + The way we want to implement this is by using (=) for mutable types such as + references, and false otherwise. + By defining (==) as follows, we get the correct behavior for reference types, + and type errors everywhere else. Those need to be manually fixed, using (=) + for mutable types, and false otherwise. The hope is that the type error + messages make this decision easier. *) -let (==) x y = false || x = y;; +let (==) x y = !x; !y; x = y let ref x = Ref x;; diff --git a/lib.ml b/lib.ml index 74005fc4..738736cb 100755 --- a/lib.ml +++ b/lib.ml @@ -215,15 +215,15 @@ 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 @@ -356,7 +356,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;; (* ------------------------------------------------------------------------- *) @@ -494,11 +494,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. *) diff --git a/printer.ml b/printer.ml index 2bb262d8..494ceafb 100755 --- a/printer.ml +++ b/printer.ml @@ -125,7 +125,7 @@ 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_to_string = Format.print_to_string;; +let print_to_string = Pretty.print_to_string;; (* Functions that print to stdout: *) @@ -133,7 +133,7 @@ let print_string = Format.print_string;; let print_break l i = Format.print_break l i;; let print_space () = Format.print_space ();; let print_newline () = Format.print_newline ();; -let print_endline s = Format.print_endline s;; +let print_endline s = print_string s; print_newline ();; let open_box = Format.open_box;; let open_hbox () = Format.open_hbox ();; From 76632888eb5cdd19223c448452bfc791c1fbd1b4 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 10 Feb 2026 18:24:39 +0800 Subject: [PATCH 08/79] Up to preterm.ml --- candle_boot.ml | 11 +++-- candle_kernel.ml | 80 +++++++++++++++---------------- candle_ocaml.ml | 22 +++++++++ lib.ml | 119 +++++++++++++++++++++++++++++++++++++++++++++-- preterm.ml | 33 ++++++------- 5 files changed, 198 insertions(+), 67 deletions(-) diff --git a/candle_boot.ml b/candle_boot.ml index 40fa23c8..eeb0ea60 100644 --- a/candle_boot.ml +++ b/candle_boot.ml @@ -14,11 +14,12 @@ let (==) x y = !x; !y; x = y let ref x = Ref x;; -let (/) = div;; -let (-.) = Double.(-);; -let (+.) = Double.(+);; -let ( *.) = Double.( * );; -let (/.) = Double.(/);; +let (/) x y = div x y;; +let (-.) x y = Double.(-) x y;; +let (+.) x y = Double.(+) x y;; +let ( *.) x y = Double.( * ) x y;; +let (/.) x y = Double.(/) x y;; +let (||) x y = x || y;; (* OCaml parser doesn't like ~, and the CakeML parser doesn't like ~- nor ~-. *) (*CML diff --git a/candle_kernel.ml b/candle_kernel.ml index 55584e8c..f3c66484 100644 --- a/candle_kernel.ml +++ b/candle_kernel.ml @@ -89,15 +89,15 @@ let mk_eq = module Type = struct let rec compare ty1 ty2 = match ty1, ty2 with - | Tyvar x1, Tyvar x2 -> Cake.String.compare x1 x2 - | Tyvar _, Tyapp _ -> Less + | Tyvar x1, Tyvar x2 -> String.compare x1 x2 + | Tyvar _, Tyapp _ -> -1 | Tyapp (x1,a1), Tyapp (x2,a2) -> - Cake.Pair.compare Cake.String.compare (Cake.List.compare compare) (x1,a1) (x2,a2) - | Tyapp _, Tyvar _ -> Greater + Pair.compare String.compare (List.compare compare) (x1,a1) (x2,a2) + | Tyapp _, Tyvar _ -> 1 ;; - let (<) ty1 ty2 = compare ty1 ty2 = Less + let (<) ty1 ty2 = compare ty1 ty2 = -1 ;; - let (<=) ty1 ty2 = compare ty1 ty2 <> Greater + let (<=) ty1 ty2 = compare ty1 ty2 <> 1 ;; end;; @@ -105,36 +105,36 @@ module Term = struct let rec compare t1 t2 = match t1, t2 with | Var (x1,ty1), Var (x2,ty2) -> - Cake.Pair.compare Cake.String.compare Type.compare (x1,ty1) (x2,ty2) - | Var _, _ -> Less + Pair.compare String.compare Type.compare (x1,ty1) (x2,ty2) + | Var _, _ -> -1 | Const (x1,ty1), Const (x2,ty2) -> - Cake.Pair.compare Cake.String.compare Type.compare (x1,ty1) (x2,ty2) - | Const _, Var _ -> Greater - | Const _, _ -> Less + Pair.compare String.compare Type.compare (x1,ty1) (x2,ty2) + | Const _, Var _ -> 1 + | Const _, _ -> -1 | Comb (s1,s2), Comb (t1,t2) -> - Cake.Pair.compare compare compare (s1,s2) (t1,t2) - | Comb _, Var _ -> Greater - | Comb _, Const _ -> Greater - | Comb _, Abs _ -> Less + Pair.compare compare compare (s1,s2) (t1,t2) + | Comb _, Var _ -> 1 + | Comb _, Const _ -> 1 + | Comb _, Abs _ -> -1 | Abs (s1,s2), Abs (t1,t2) -> - Cake.Pair.compare compare compare (s1,s2) (t1,t2) - | Abs _, _ -> Greater + Pair.compare compare compare (s1,s2) (t1,t2) + | Abs _, _ -> 1 ;; - let (<) t1 t2 = compare t1 t2 = Less + let (<) t1 t2 = compare t1 t2 = -1 ;; - let (<=) t1 t2 = compare t1 t2 <> Greater + let (<=) t1 t2 = compare t1 t2 <> 1 ;; end;; module Thm = struct let compare th1 th2 = - Cake.Pair.compare (Cake.List.compare Term.compare) Term.compare + Pair.compare (List.compare Term.compare) Term.compare (dest_thm th1) (dest_thm th2) ;; - let (<) th1 th2 = compare th1 th2 = Less + let (<) th1 th2 = compare th1 th2 = -1 ;; - let (<=) th1 th2 = compare th1 th2 <> Greater + let (<=) th1 th2 = compare th1 th2 <> 1 ;; end;; @@ -142,34 +142,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 Cake.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,10 +180,10 @@ 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 = Cake.List.map mk_vartype (tyvars t);; -let type_vars_in_term t = Cake.List.map mk_vartype (type_vars_in_term t);; +let tyvars t = List.map mk_vartype (tyvars t);; +let type_vars_in_term t = List.map mk_vartype (type_vars_in_term t);; (* ------------------------------------------------------------------------- *) (* Comparison function on theorems. Currently the same as equality, but *) diff --git a/candle_ocaml.ml b/candle_ocaml.ml index 5d971de6..3db38fe1 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -39,6 +39,17 @@ module Candle = struct ;; 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 +end;; + module Float = struct let zero = Cake.Double.fromInt 0 let one = Cake.Double.fromInt 1 @@ -48,7 +59,17 @@ module Float = struct end;; module List = struct + let fold_left f init xs = Cake.List.foldl (fun x y -> f y x) init xs + let map f xs = Cake.List.map f xs 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 @@ -68,6 +89,7 @@ module String = struct 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 end;; module Array = struct diff --git a/lib.ml b/lib.ml index 738736cb..9fc3bd6c 100755 --- a/lib.ml +++ b/lib.ml @@ -363,9 +363,7 @@ let rec uniq l = (* Convert list into set by eliminating duplicates. *) (* ------------------------------------------------------------------------- *) -(* -let setify s = uniq (sort (fun x y -> compare x y <= 0) s);; -*) +let setify (<=) s = uniq (sort (fun x y -> x <= y) s);; (* ------------------------------------------------------------------------- *) (* String operations (surely there is a better way...) *) @@ -541,31 +539,59 @@ let decreasing f x y = compare (f x) (f y) > 0;; (* *) (* 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 + but you'll probably always use the same comparison functions for the same + types, anyway, if you need to compare functions. + *) + +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" + [Pretty_printer.pp_list (fun (k, v) -> + Pretty_printer.tuple [pk k; pv v]) 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 + | _ -> false;; (* ------------------------------------------------------------------------- *) (* Operation analagous to "map" for lists. *) (* ------------------------------------------------------------------------- *) +(* let mapf = let rec map_list f l = match l with @@ -577,11 +603,15 @@ let mapf = | 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 @@ -605,21 +635,44 @@ let foldr = | 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;; +let foldl f a (Func (_, t)) = foldl f a t;; + +let rec foldr f a = + function [] -> a + | (x,y)::xs -> f x y (foldr f a xs);; +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 <> 1) t;; + +let dom (Func (cmp, 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 <> 1) (map snd t);; (* ------------------------------------------------------------------------- *) (* Application. *) (* ------------------------------------------------------------------------- *) +(* let applyd = let rec apply_listd l d x = match l with @@ -635,6 +688,18 @@ let applyd = -> 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 -> + 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");; @@ -646,6 +711,7 @@ let defined f x = try apply f x; true with Failure _ -> false;; (* Undefinition. *) (* ------------------------------------------------------------------------- *) +(* let undefine = let rec undefine_list x l = match l with @@ -676,11 +742,23 @@ let undefine = 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 -> + 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 @@ -771,17 +849,45 @@ let (|->),combine = 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 -> + 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)) = + let rec combine l1 l2 = + match l1, l2 with + | [], _ -> l2 + | _, [] -> l1 + | (x1,y1)::t1, (x2,y2)::t2 -> + 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);; (* ------------------------------------------------------------------------- *) (* Special case of point function. *) (* ------------------------------------------------------------------------- *) -let (|=>) = fun x y -> (x |-> y) undefined;; +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" @@ -789,6 +895,11 @@ let rec choose t = | Branch(b,p,t1,t2) -> choose t1;; *) +let choose (Func (_, t)) = + try hd t + with Failure _ -> + failwith "choose: completely undefined function";; + (* ------------------------------------------------------------------------- *) (* Install a trivial printer for the general polymorphic case. *) (* ------------------------------------------------------------------------- *) 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;; From 6ffb56a1479cd6ad1f0f1e7868a4fee7f9c67590 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 13 Feb 2026 16:00:25 +0800 Subject: [PATCH 09/79] Up to parser.ml --- parser.ml | 30 ++++++++++++++---------------- 1 file changed, 14 insertions(+), 16 deletions(-) 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);; From e2a6f22c0b617075bd5f89296099ecb45415aa4b Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 13 Feb 2026 16:15:52 +0800 Subject: [PATCH 10/79] Up to canon.ml --- candle_ocaml.ml | 1 + ind_defs.ml | 2 +- tactics.ml | 55 +++++++++++++++++++++++++------------------------ 3 files changed, 30 insertions(+), 28 deletions(-) diff --git a/candle_ocaml.ml b/candle_ocaml.ml index 3db38fe1..154f38bc 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -48,6 +48,7 @@ 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 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/tactics.ml b/tactics.ml index 5db2c7c4..6ca3b1fd 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),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_,(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 From cdd455b8f93b6841172d472920ebd5441b15f2dd Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 13 Feb 2026 16:35:31 +0800 Subject: [PATCH 11/79] Up to meson.ml --- candle_ocaml.ml | 1 + meson.ml | 53 +++++++++++++++++++++++++++++-------------------- 2 files changed, 32 insertions(+), 22 deletions(-) diff --git a/candle_ocaml.ml b/candle_ocaml.ml index 154f38bc..386a22b6 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -140,6 +140,7 @@ module Format = struct 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 ();; 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";; From 5bc8909c57d44908be3ff100dcd2a00ff51c33c0 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 13 Feb 2026 18:01:29 +0800 Subject: [PATCH 12/79] Up to firstorder.ml --- candle_ocaml.ml | 20 ++++++++++++++++++++ firstorder.ml | 21 ++++++++++++--------- hol_lib.ml | 2 -- 3 files changed, 32 insertions(+), 11 deletions(-) diff --git a/candle_ocaml.ml b/candle_ocaml.ml index 386a22b6..af873b43 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -1,6 +1,7 @@ exception Invalid_argument of string;; exception Sys_error of string;; exception End_of_file;; +exception Not_found;; let pp_exn e = match e with @@ -9,8 +10,11 @@ let pp_exn e = | 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)) ;; @@ -61,7 +65,23 @@ end;; 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 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 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/hol_lib.ml b/hol_lib.ml index 1f1b91a7..2f7ac1bd 100644 --- a/hol_lib.ml +++ b/hol_lib.ml @@ -82,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 *) From 91017d0158053ddc46517872bd3b9885cacefa10 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 13 Feb 2026 22:09:50 +0800 Subject: [PATCH 13/79] Original metis.ml --- metis.ml | 10396 +++++++++++++++++++++++++++++++++- metis/active.ml | 439 -- metis/atom.ml | 235 - metis/atom_net.ml | 57 - metis/clause.ml | 247 - metis/formula.ml | 550 -- metis/heap.ml | 70 - metis/knuth_bendix.ml | 137 - metis/literal.ml | 284 - metis/literal_net.ml | 73 - metis/loop.ml | 25 - metis/math.ml | 6 - metis/metis_debug.ml | 27 - metis/metis_generate.ml | 50 - metis/metis_mapping.ml | 57 - metis/metis_path.ml | 36 - metis/metis_reconstruct2.ml | 260 - metis/metis_rules.ml | 63 - metis/metis_unify.ml | 54 - metis/mmap.ml | 68 - metis/model.ml | 1011 ---- metis/mset.ml | 68 - metis/name.ml | 87 - metis/name_arity.ml | 75 - metis/pmap.ml | 999 ---- metis/portable.ml | 13 - metis/preterm.ml | 36 - metis/proof.ml | 213 - metis/pset.ml | 270 - metis/random.ml | 21 - metis/resolution.ml | 81 - metis/rewrite.ml | 441 -- metis/rule.ml | 621 -- metis/sharing.ml | 4 - metis/substitute.ml | 213 - metis/subsume.ml | 243 - metis/term.ml | 371 -- metis/term_net.ml | 404 -- metis/thm.ml | 197 - metis/units.ml | 86 - metis/waiting.ml | 208 - 41 files changed, 10170 insertions(+), 8626 deletions(-) delete mode 100644 metis/active.ml delete mode 100644 metis/atom.ml delete mode 100644 metis/atom_net.ml delete mode 100644 metis/clause.ml delete mode 100644 metis/formula.ml delete mode 100644 metis/heap.ml delete mode 100644 metis/knuth_bendix.ml delete mode 100644 metis/literal.ml delete mode 100644 metis/literal_net.ml delete mode 100644 metis/loop.ml delete mode 100644 metis/math.ml delete mode 100644 metis/metis_debug.ml delete mode 100644 metis/metis_generate.ml delete mode 100644 metis/metis_mapping.ml delete mode 100644 metis/metis_path.ml delete mode 100644 metis/metis_reconstruct2.ml delete mode 100644 metis/metis_rules.ml delete mode 100644 metis/metis_unify.ml delete mode 100644 metis/mmap.ml delete mode 100644 metis/model.ml delete mode 100644 metis/mset.ml delete mode 100644 metis/name.ml delete mode 100644 metis/name_arity.ml delete mode 100644 metis/pmap.ml delete mode 100644 metis/portable.ml delete mode 100644 metis/preterm.ml delete mode 100644 metis/proof.ml delete mode 100644 metis/pset.ml delete mode 100644 metis/random.ml delete mode 100644 metis/resolution.ml delete mode 100644 metis/rewrite.ml delete mode 100644 metis/rule.ml delete mode 100644 metis/sharing.ml delete mode 100644 metis/substitute.ml delete mode 100644 metis/subsume.ml delete mode 100644 metis/term.ml delete mode 100644 metis/term_net.ml delete mode 100644 metis/thm.ml delete mode 100644 metis/units.ml delete mode 100644 metis/waiting.ml diff --git a/metis.ml b/metis.ml index 923b5632..e9d38fa9 100644 --- a/metis.ml +++ b/metis.ml @@ -9,296 +9,10236 @@ (* 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 + +(* ------------------------------------------------------------------------- *) +(* Convenient utility modules. *) +(* ------------------------------------------------------------------------- *) + +module Portable = struct + +let pointerEqual (p1, p2) = p1 == p2;; + +let randomInt x = Random.int x;; +let randomWord () = Random.bits ();; + +let critical x = x;; + +end + +module Option = struct + +let getOpt = function + (Some s, _) -> s + | (None, x) -> x;; + +let isSome = function + Some _ -> true + | None -> false;; + +let mapPartial f = function + None -> None + | Some x -> f x;; + +end + +module Order = struct + +type order = Less | Equal | Greater;; + +let orderOfInt = function + -1 -> Less + | 0 -> Equal + | 1 -> Greater + | _ -> failwith "orderOfInt" +;; + +let intOfOrder = function + Less -> -1 + | Equal -> 0 + | Greater -> 1 +;; + +let toCompare f = fun (x, y) -> orderOfInt (f x y);; +let fromCompare f = fun x y -> intOfOrder (f (x, y));; + +end + +module Int = struct + +let toString = string_of_int;; + +let compare = Order.toCompare (compare : int -> int -> int);; + +let maxInt = Some max_int;; + +let div x y = x / y;; + +end + +module Real = struct + +open Order + +type real = float;; + +let compare = toCompare (compare : float -> float -> int);; + +let fromInt = float_of_int;; +let floor x = int_of_float (floor x);; + +end + +(* ------------------------------------------------------------------------- *) +(* Emulating SML Word type (which is unsigned) and other operations. *) +(* ------------------------------------------------------------------------- *) + +module Word = struct + +open Order + +type word = int;; +let compare = toCompare (compare: word -> word -> int);; + +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 Math = struct + +let ln = log;; +let pow (x,y) = x ** y;; + +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 nth (l, i) = List.nth l i;; +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 revAppend (l1, l2) = List.rev_append l1 l2;; +let find p l = try Some (List.find p l) with Not_found -> None;; +let all = List.for_all;; + +end + +(* ========================================================================= *) +(* ML UTILITY FUNCTIONS *) +(* ========================================================================= *) + +module Useful = struct + +open Order + +(* ------------------------------------------------------------------------- *) +(* OCaml lists (MF). *) +(* ------------------------------------------------------------------------- *) + +let length = List.length;; +let app = List.iter;; + +(* ------------------------------------------------------------------------- *) +(* Characters (MF). *) +(* ------------------------------------------------------------------------- *) + +let isDigit c = '0' <= c && c <= '9' + +(* ------------------------------------------------------------------------- *) +(* Exceptions. *) +(* ------------------------------------------------------------------------- *) + +exception Error of string;; + +exception Bug of string;; + +exception Subscript;; + +let total f x = try Some (f x) with Error _ -> None;; + +let isSome = function + (Some _) -> true + | None -> false +;; + +let can f x = isSome (total f x);; + +(* ------------------------------------------------------------------------- *) +(* Combinators. *) +(* ------------------------------------------------------------------------- *) + +let cComb f x y = f y x;; + +let iComb x = x;; + +let kComb x y = x;; + +let sComb f g x = f x (g x);; + +let wComb f x = f x x;; + +let rec funpow n f x = match n with + 0 -> x + | _ -> funpow (n - 1) f (f x);; + +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 + ;; + +(* ------------------------------------------------------------------------- *) +(* Pairs. *) +(* ------------------------------------------------------------------------- *) + +let pair x y = (x,y);; + +let swap (x,y) = (y,x);; + +let curry f x y = f (x,y);; + +let uncurry f (x,y) = f x y;; + +(* ------------------------------------------------------------------------- *) +(* State transformers. *) +(* ------------------------------------------------------------------------- *) + +let return : 'a -> 's -> 'a * 's = pair;; + +let bind f (g : 'a -> 's -> 'b * 's) x = uncurry g (f x);; + +(*fun mmap f (m : 's -> 'a * 's) = bind m (unit o f); + +fun mjoin (f : 's -> ('s -> 'a * 's) * 's) = bind f I; + +fun mwhile c b = let fun f a = if c a then bind (b a) f else unit a in f end;*) + +(* ------------------------------------------------------------------------- *) +(* Comparisons. *) +(* ------------------------------------------------------------------------- *) + +let revCompare cmp x_y = + match cmp x_y with Less -> Greater | Equal -> Equal | Greater -> Less;; + +let prodCompare xCmp yCmp ((x1,y1),(x2,y2)) = + match xCmp (x1,x2) with + Less -> Less + | Equal -> yCmp (y1,y2) + | Greater -> Greater;; + +let lexCompare cmp = + let rec lex = function + ([],[]) -> Equal + | ([], _ :: _) -> Less + | (_ :: _, []) -> Greater + | (x :: xs, y :: ys) -> + (match cmp (x,y) with + Less -> Less + | Equal -> lex (xs,ys) + | Greater -> Greater) + in + lex + ;; + +let boolCompare = function + (false,true) -> Less + | (true,false) -> Greater + | _ -> Equal;; + +(* ------------------------------------------------------------------------- *) +(* Lists. *) +(* ------------------------------------------------------------------------- *) + +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)) + ;; + +let zip xs ys = zipWith pair xs ys;; + +let unzip ab = + let inc ((x,y),(xs,ys)) = (x :: xs, y :: ys) + in Mlist.foldl inc ([],[]) (List.rev ab);; + +let enumerate l = fst (maps (fun x m -> ((m, x), m + 1)) l 0);; + +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);; + +let divide l n = let (a,b) = revDivide l n in (List.rev a, b);; + +let updateNth (n,x) l = + let (a,b) = revDivide l n + in + match b with [] -> raise Subscript | (_ :: t) -> List.rev_append a (x :: t) +;; + +let deleteNth n l = + let (a,b) = revDivide l n + in + match b with [] -> raise Subscript | (_ :: t) -> List.rev_append a t +;; + +(* ------------------------------------------------------------------------- *) +(* Sets implemented with lists. *) +(* ------------------------------------------------------------------------- *) + +let mem x l = List.mem x l;; + +(* ------------------------------------------------------------------------- *) +(* 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);; + +(* ------------------------------------------------------------------------- *) +(* Sorting and searching. *) +(* ------------------------------------------------------------------------- *) + +let sort cmp = List.sort (fromCompare cmp);; + +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 (fromCompare ncmp) nxs + in + List.map snd nys + ;; + +(* ------------------------------------------------------------------------- *) +(* 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 + +open Order + +(* ------------------------------------------------------------------------- *) +(* Importing useful functionality. *) +(* ------------------------------------------------------------------------- *) + +exception Bug = Useful.Bug;; + +exception Error = Useful.Error;; + +let pointerEqual = Portable.pointerEqual;; + +let kComb = Useful.kComb;; + +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 = Word.word;; + +let randomPriority = randomWord;; + +let comparePriority = Word.compare;; + +(* ------------------------------------------------------------------------- *) +(* Priority search trees. *) +(* ------------------------------------------------------------------------- *) + +type ('key,'value) tree = + Empty + | Tree of ('key,'value) node + +and ('key,'value) node = + {size : int; + priority : priority; + left : ('key,'value) tree; + key : 'key; + value : 'value; + right : ('key,'value) tree};; + +let lowerPriorityNode node1 node2 = + let {priority = p1} = node1 + and {priority = p2} = node2 + in + comparePriority (p1,p2) = Less + ;; + +(* ------------------------------------------------------------------------- *) +(* 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 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 -> + match compareKey (k,key) with + Less -> () + | Equal -> raise Bug "duplicate keys" + | Greater -> raise 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 Bug "left child has greater priority" + + let () = + match checkPriorities compareKey right with + None -> () + | Some rnode -> + if not (lowerPriorityNode node rnode) then () + else raise 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 Error err -> raise (Bug err);; +end;; +*) + +(* ------------------------------------------------------------------------- *) +(* Tree operations. *) +(* ------------------------------------------------------------------------- *) + +let treeNew () = Empty;; + +let nodeSize ({size = x}) = x;; + +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 + {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 {left=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 {right=right} = node + in + treeRightSpine (node :: acc) right + ;; + +(* ------------------------------------------------------------------------- *) +(* Singleton trees. *) +(* ------------------------------------------------------------------------- *) + +let mkNodeSingleton priority key value = + let size = 1 + and left = Empty + and right = Empty + in + {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 {priority=priority;left=left;key=key;value=value;right=right} = node2 + + in let left = treeAppend tree1 left + in + mkTree priority left key value right + else + let {priority=priority;left=left;key=key;value=value;right=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 {left=left;key=key;value=value;right=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 {left=left;key=key;right=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 {priority=priority;left=left;key=key;value=value;right=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 {priority=priority;left=left;key=key;value=value;right=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 {left=left;key=key;value=value;right=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 {left=left;key=key;value=value;right=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 {size=size;priority=priority;left=left;right=right} = node + + in let 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 {size=size;priority=priority;left=left;key=key;value=value;right=right} = node + in + match compareKey (dkey,key) with + Less -> + let size = size - 1 + and left = treeDelete compareKey dkey left + + in let 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 = + {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 ({priority=priority;left=left;key=key;value=value;right=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 {size=size;priority=priority;left=left;key=key;value=value;right=right} = node + + in let left = treeMap f left + and value = f (key,value) + and right = treeMap f right + in + {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 {priority=priority;left=left;key=key;value=value;right=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 {priority=priority;left=left;key=key;value=value;right=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 {priority=priority;left=left;key=key;value=value;right=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 {priority=priority;left=left;key=key;value=value;right=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 {priority=priority;left=left;key=key;value=value;right=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 {priority=priority;left=left;key=key;value=value;right=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 {size=size;left=left;key=key;right=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 {key=key;value=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 {left=left;key=key;value=value;right=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 {left=left;key=key;value=value;right=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 {size=size;priority=priority;left=left;key=key;value=value;right=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 = + {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 = + {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 + | {key=key;value=value;right=right} :: nodes -> + Some (Left_to_right_iterator ((key,value),right,nodes));; + +let fromSpineRightToLeftIterator nodes = + match nodes with + [] -> None + | {key=key;value=value;left=left} :: nodes -> + 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 -> + (match compareValue (v1,v2) with + Less -> Less + | Equal -> + let io1 = advanceIterator i1 + and io2 = advanceIterator i2 + in + compareIterator compareKey compareValue io1 io2 + | Greater -> Greater) + | 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 -> order) * ('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 Bug bug -> raise (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.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) + ;; + +(*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 (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) + ;; + +(*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.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) + ;; + +(*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 (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 (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 (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 + +(* ------------------------------------------------------------------------- *) +(* More map and set modules to support Metis. *) +(* ------------------------------------------------------------------------- *) + +(* ========================================================================= *) +(* FINITE SETS IMPLEMENTED WITH RANDOMLY BALANCED TREES *) +(* ========================================================================= *) + +module Pset = struct + +open Order + +(* ------------------------------------------------------------------------- *) +(* 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 ((),()) = 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 + +(* ========================================================================= *) +(* More map and set types for Metis. *) +(* ========================================================================= *) + +module Mmap = struct + +exception Error = Useful.Error;; + +module type Ordered = +sig + type t + val compare : t -> t -> int +end + +module Make (Ord : Ordered) = +struct + module Ma = Map.Make (Ord) + + type +'a map = 'a Ma.t + + let newMap () = Ma.empty;; + let null = Ma.is_empty;; + let singleton (k, x) = Ma.singleton k x;; + let size = Ma.cardinal;; + let get m k = try Ma.find k m with Not_found -> raise (Error "Mmap.get: element not found");; + let peek m k = try Some (Ma.find k m) with Not_found -> None;; + let insert m (k, v) = Ma.add k v m;; + let toList = Ma.bindings;; + let fromList l = List.fold_right (fun (v,tm) -> Ma.add v tm) l Ma.empty;; + let foldl f b m = List.fold_left (fun s (v, tm) -> f (v, tm, s)) b (Ma.bindings m);; + let foldr = foldl;; + let filter f = Ma.filter (fun x y -> f (x, y));; + let inDomain = Ma.mem;; + let union f m1 m2 = + let f' k = function + (Some x, Some y) -> f ((k, x), (k, y)) + | (Some x, None) -> Some x + | (None, Some y) -> Some y + | (None, None) -> None + in Ma.merge (fun k x y -> f' k (x, y)) m1 m2 + let delete m k = Ma.remove k m + let mapPartial f m = Ma.fold (fun k x acc -> match f (k, x) with Some y -> Ma.add k y acc | None -> acc) m Ma.empty;; + let transform = Ma.map;; + let exists f = Ma.exists (fun k m -> f (k,m));; +end +end + + +module Intmap = struct + +open Order + +module Ordered = struct type t = int let compare = compare end + +include Mmap.Make (Ordered);; + +end + +module Stringmap = struct + +open Order + +module Ordered = struct type t = string let compare = compare end + +include Mmap.Make (Ordered);; + +end + +module Mset = struct + +module type Ordered = +sig + type t + val compare : t -> t -> int +end + +module Make (Ord : Ordered) = +struct + module Se = Set.Make (Ord) + + type set = Se.t;; + let compare = Order.toCompare Se.compare;; + + let add s x = Se.add x s;; + let foldr f a s = Se.fold (fun x acc -> f (x,acc)) s a;; + let foldl = foldr;; + let member = Se.mem;; + let empty = Se.empty;; + let union = Se.union;; + let difference = Se.diff;; + let toList = Se.elements;; + let singleton = Se.singleton;; + let null = Se.is_empty;; + let size = Se.cardinal;; + let pick = Se.choose;; + let equal = Se.equal;; + let exists = Se.exists;; + let fromList l = List.fold_right Se.add l Se.empty;; + let delete s x = Se.remove x s;; + let subset = Se.subset;; + let intersect = Se.inter;; + let intersectList = function + [] -> Se.empty + | (s::ss) -> List.fold_right Se.inter ss s + let findl p s = + let go x = function + (Some _) as s -> s + | None -> if p x then Some x else None + in Se.fold go s None;; + let firstl f s = + let go x = function + (Some _) as s -> s + | None -> f x + in Se.fold go s None;; + let transform f s = Se.fold (fun x acc -> f x :: acc) s [] + let all = Se.for_all;; + let count p s = Se.fold (fun x c -> if p x then c+1 else c) s 0 +end + +end + + +module Intset = struct + +open Order + +module Ordered = struct type t = int let compare = compare end + +include Mset.Make (Ordered);; + +end + + +module Sharing = struct + +let map = List.map;; +end + +(* ========================================================================= *) +(* A HEAP DATATYPE FOR ML *) +(* ========================================================================= *) + +module Heap = struct + +(* Leftist heaps as in Purely Functional Data Structures, by Chris Okasaki *) + +open Order + +exception Empty;; + +type 'a node = Em | Tr of int * 'a * 'a node * 'a node;; + +type 'a heap = Heap of ('a * 'a -> order) * 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 (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 Int.toString (size h)) ^ "]";; + +end + +(* ========================================================================= *) +(* NAMES *) +(* ========================================================================= *) + +module Name = struct + +open Useful;; + +(* ------------------------------------------------------------------------- *) +(* A type of names. *) +(* ------------------------------------------------------------------------- *) + +type name = string;; + +(* ------------------------------------------------------------------------- *) +(* A total ordering. *) +(* ------------------------------------------------------------------------- *) + +let compare = Order.toCompare (compare : name -> name -> int);; + +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 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 Ordered = +struct type t = name let compare = Order.fromCompare compare end + +module Map = Mmap.Make (Ordered);; +module Set = Mset.Make (Ordered);; + +end + +(* ========================================================================= *) +(* NAME/ARITY PAIRS *) +(* ========================================================================= *) + +module Name_arity = struct + +open Useful;; +open Order + +(* ------------------------------------------------------------------------- *) +(* 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 Ordered = +struct type t = nameArity let compare = fromCompare compare end + +module Map = struct + include Mmap.Make (Ordered) + + let compose m1 m2 = + let pk ((_,a),n) = peek m2 (n,a) + in + mapPartial pk m1 + ;; +end + +module Set = struct + include Mset.Make (Ordered) + + let allNullary = all nullary; +end + +end + +(* ========================================================================= *) +(* FIRST ORDER LOGIC TERMS *) +(* ========================================================================= *) + +module Term = struct + +open Useful +open Order + +(* ------------------------------------------------------------------------- *) +(* 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 = function + ([], []) -> Equal + | (tm1 :: tms1, tm2 :: tms2) -> + let tm1_tm2 = (tm1,tm2) + in + if Portable.pointerEqual tm1_tm2 then cmp (tms1, tms2) + else + (match tm1_tm2 with + (Var v1, Var v2) -> + (match Name.compare (v1,v2) with + Less -> Less + | Equal -> cmp (tms1, tms2) + | Greater -> Greater) + | (Var _, Fn _) -> Less + | (Fn _, Var _) -> Greater + | (Fn (f1,a1), Fn (f2,a2)) -> + (match Name.compare (f1,f2) with + Less -> Less + | Equal -> + (match Int.compare (List.length a1, List.length a2) with + Less -> Less + | Equal -> cmp (a1 @ tms1, a2 @ tms2) + | Greater -> Greater) + | Greater -> Greater)) + | _ -> 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) -> + (match tm with + Var _ -> subtms (rest, acc) + | Fn letc -> + (match total destFnHasType letc with + Some (t,_) -> + (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) + ) + | 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))) + 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.fold_left (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.concat ", " (List.map toString l) ^ ")";; + +module Ordered = +struct type t = term let compare = fromCompare compare end + +module Map = Map.Make (Ordered);; + +module Set = Set.Make (Ordered);; + +end + +(* ========================================================================= *) +(* FIRST ORDER LOGIC SUBSTITUTIONS *) +(* ========================================================================= *) + +module Substitute = struct + +open Useful + +(* ------------------------------------------------------------------------- *) +(* 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.Var v as tm) -> + (match peek sub v with + Some tm' -> if Portable.pointerEqual (tm,tm') then tm else tm' + | None -> tm) + | (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 + (match peek sub v with + None -> solve (compose sub (singleton (v,tm))) rest + | Some tm' -> solve' sub (tm', tm, rest)) + | (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 + +(* ========================================================================= *) +(* FIRST ORDER LOGIC ATOMS *) +(* ========================================================================= *) + +module Atom = struct + +open Useful +open Order + +(* ------------------------------------------------------------------------- *) +(* 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 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 = + Mlist.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 = + let subterm' = function + (_, []) -> raise (Bug "Atom.subterm: empty path") + | ((_,tms), h :: t) -> + if h >= length tms then raise (Error "Atom.subterm: bad path") + else Term.subterm (Mlist.nth (tms,h)) t + in fun x y -> subterm' (x, y) + +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 [] (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 = Mlist.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 -> Mlist.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 + 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) || + raise (Error "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 || 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) = + 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 [] (enumerate tms) + ;; + + +module Ordered = +struct type t = atom let compare = fromCompare compare end + +module Map = Mmap.Make (Ordered);; + +module Set = Mset.Make (Ordered);; + +end + + +(* ========================================================================= *) +(* FIRST ORDER LOGIC FORMULAS *) +(* ========================================================================= *) + +module Formula = struct + +open Useful +open Order + +(* ------------------------------------------------------------------------- *) +(* 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 -> 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 + 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 -> 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 + 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 -> 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 + 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) -> + (match Atom.compare (atm1,atm2) with + Less -> Less + | Equal -> cmp fs + | Greater -> Greater) + | (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)) -> + (match Name.compare (v1,v2) with + Less -> Less + | Equal -> cmp ((p1,p2) :: fs) + | Greater -> Greater) + | (Forall _, Exists _) -> Less + | (Exists _, Forall _) -> Greater + | (Exists (v1,p1), Exists (v2,p2)) -> + (match Name.compare (v1,v2) with + Less -> Less + | Equal -> cmp ((p1,p2) :: fs) + | Greater -> Greater) +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 = 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 + 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 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,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;; + +(*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 = fromCompare compare end + +module Map = Mmap.Make (Ordered);; + +module Set = Mset.Make (Ordered);; + +end + + +(* ========================================================================= *) +(* FIRST ORDER LOGIC LITERALS *) +(* ========================================================================= *) + +module Literal = struct + +open Useful;; +open Order + +(* ------------------------------------------------------------------------- *) +(* 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) + | _ -> 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 Ordered = +struct type t = literal let compare = fromCompare compare end + +module Map = Mmap.Make (Ordered);; + +module Set = +struct + include Mset.Make (Ordered);; + + 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 + ;; + + 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.concat ", " (List.map toString (toList cl)) ^ "}" + +end + +module Set_ordered = +struct type t = Set.set let compare = fromCompare Set.compare end + +module Set_map = Mmap.Make (Set_ordered);; + +module Set_set = Mset.Make (Set_ordered);; + +end + + +(* ========================================================================= *) +(* A LOGICAL KERNEL FOR FIRST ORDER CLAUSAL THEOREMS *) +(* ========================================================================= *) + +module Thm = struct + +open Useful;; +open Order + +(* ------------------------------------------------------------------------- *) +(* 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 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. *) +(* ------------------------------------------------------------------------- *) + +open Format + +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_break 0 0; + + print_string ("Clauses: " ^ Literal.Set.toString cl); + print_break 0 0; + + print_string "Theorems: "; + if ths = [] + then print_string "" + else begin + print_break 0 0; + open_vbox 2; + print_break 0 0; + List.iter (print_proof) ths; + close_box () + end; + 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 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])) + ;; + +(*MetisDebug +let resolve = fun lit -> fun pos -> fun neg -> + resolve lit pos neg + handle Error err -> + raise Error ("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 + +open Useful;; + +(* ------------------------------------------------------------------------- *) +(* 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 (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)]) + ;; +(*MetisDebug + handle Error err -> + raise (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 (Bug "can't reconstruct Resolve rule") + );; +(*MetisDebug + handle Error err -> + raise (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 = 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 (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 first recon candidates with + Some info -> info + | None -> raise (Bug "can't reconstruct Equality rule") + ;; +(*MetisDebug + handle Error err -> + raise (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 (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 (kComb true) cl with + Some lit -> Refl (Literal.destRefl lit) + | None -> raise (Bug "malformed Refl inference")) + | (Thm.Equality,[]) -> let (x,y,z) = (reconstructEquality cl) in Equality (x,y,z) + | _ -> raise (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 + 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 Error err -> + raise (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 + +open Useful;; + +(* ------------------------------------------------------------------------- *) +(* 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 + );; + +(*MetisDebug +let transEqn = fun eqn1 -> fun eqn2 -> + transEqn eqn1 eqn2 + handle Error err -> + raise Error ("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 Error exception. *) +(* ------------------------------------------------------------------------- *) + +type conv = Term.term -> Term.term * Thm.thm;; + +let allConv tm = (tm, Thm.refl tm);; + +let noConv : conv = fun _ -> raise (Error "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 Error err -> + (trace (s ^ ": " ^ Term.toString tm ^ " --> Error: " ^ err ^ "\n");; + raise (Error (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 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 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 Error err -> + raise Error ("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.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 + ;; + +(*MetisDebug +let repeatTopDownConv = fun conv -> fun tm -> + repeatTopDownConv conv tm + handle Error err -> raise (Error ("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 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) + ;; + +(*MetisDebug +let rewrLiterule = fun eqn -> fun path -> fun lit -> + rewrLiterule eqn path lit + handle Error err -> + raise Error ("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) (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 + ;; + +(*MetisDebug +let literalRule = fun literule -> fun lit -> fun th -> + literalRule literule lit th + handle Error err -> + raise Error ("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) (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) (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 (Mlist.foldl init ([],[]) acc) + | ((sub,edge) :: sub_edges) -> +(*MetisDebug + let () = if not (Substitute.null sub) then () + else raise 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 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 + +open Useful;; + +(* ------------------------------------------------------------------------- *) +(* Constants. *) +(* ------------------------------------------------------------------------- *) + +let maxSpace = 1000;; + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +let multInt = + match Int.maxInt with + None -> (fun x -> fun y -> Some (x * y)) + | Some m -> + let m = Real.floor (float_sqrt (Real.fromInt m)) + in + fun x -> fun y -> 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 = 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);; + +(* ------------------------------------------------------------------------- *) +(* Model size. *) +(* ------------------------------------------------------------------------- *) + +type size = {size : int};; + +(* ------------------------------------------------------------------------- *) +(* A model of size N has integer elements 0...N-1. *) +(* ------------------------------------------------------------------------- *) + +type element = int;; + +let zeroElement = 0;; + +let incrementElement {size = n} i = + let i = i + 1 + in + if i = n then None else Some i + ;; + +let elementListSpace {size = n} arity = + match expInt n arity with + None -> None + | Some m as s -> if m <= maxSpace then s else None;; + +let elementListIndex {size = 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 = size -> element list -> element option;; + +type fixedRelation = size -> element list -> bool option;; + +type fixed = + {functions : fixedFunction Name_arity.Map.map; + relations : fixedRelation Name_arity.Map.map};; + +let uselessFixedFunction : fixedFunction = kComb (kComb None);; + +let uselessFixedRelation : fixedRelation = kComb (kComb 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 (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 + {functions = fns; + relations = rels} + ;; + +let peekFunctionFixed fix name_arity = + let {functions = fns} = fix + in + Name_arity.Map.peek fns name_arity + ;; + +let peekRelationFixed fix name_arity = + let {relations = rels} = fix + 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 {functions = fns; relations = rels} = fix + + in let fns = Name_arity.Map.insert fns name_arity_fun + in + {functions = fns; + relations = rels} + ;; + +let insertRelationFixed fix name_arity_rel = + let {functions = fns; relations = rels} = fix + + in let rels = Name_arity.Map.insert rels name_arity_rel + in + {functions = fns; + relations = rels} + ;; + + let union _ = raise (Bug "Model.unionFixed: nameArity clash");; + let unionFixed fix1 fix2 = + let {functions = fns1; relations = rels1} = fix1 + and {functions = fns2; relations = rels2} = fix2 + + in let fns = Name_arity.Map.union union fns1 fns2 + + in let rels = Name_arity.Map.union union rels1 rels2 + in + {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 (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 + {functions = fns; + relations = rels} + ;; + +(* ------------------------------------------------------------------------- *) +(* Renaming fixed model parts. *) +(* ------------------------------------------------------------------------- *) + +type fixedMap = + {functionMap : Name.name Name_arity.Map.map; + relationMap : Name.name Name_arity.Map.map};; + +let mapFixed fixMap fix = + let {functionMap = fnMap; relationMap = relMap} = fixMap + and {functions = fns; relations = rels} = fix + + in let fns = Name_arity.Map.compose fnMap fns + + in let rels = Name_arity.Map.compose relMap rels + in + {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 (Mlist.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 + {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 {size = 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 {size = 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 {size = 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 {size = n} x = Some (if x = 0 then 0 else n - x);; + + let preFn {size = n} x = Some (if x = 0 then n - 1 else x - 1);; + + let subFn {size = n} x y = Some (if x < y then n + x - y else x - y);; + + let sucFn {size = 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 + {functions = fns; + relations = rels} + ;; + + (* Support *) + + let cutN {size = 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 {size = 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 {size = 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 {size = 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 {size = n} x = + if x = n - 1 then None else Some (x mod 2 = 0);; + + let geRel {size = 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 {size = 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 {size = 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 {size = 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 {size = 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 + {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 {size = n} = + let rec f acc = function + 0 -> acc + | x -> f (acc + 1) (Int.div 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 + {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 = + {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 -> raise (Error "Model.getValuation: incomplete valuation");; + +let randomValuation {size = 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 {size = n} arity with + None -> Forgetful_table + | Some space -> Array_table (Array.make 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 {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 = n} elts + + in let () = Array.set a i r + in + () + ;; + +(* ------------------------------------------------------------------------- *) +(* A type of random finite mappings name * arity -> Z^arity -> Z. *) +(* ------------------------------------------------------------------------- *) + +type tables = + {domainSize : int; + rangeSize : int; + tableMap : table Name_arity.Map.map ref};; + +let newTables n vR = + {domainSize = n; + rangeSize = vR; + tableMap = ref (Name_arity.Map.newMap ())};; + +let getTables tables n_a = + let {domainSize = n; rangeSize = _; tableMap = tm} = tables + + 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 {domainSize = vN; rangeSize = vR} = tables + + 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 {domainSize = vN} = tables + + 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 = {sizep : int; fixed : fixed};; + +type model = + {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 {sizep = vN; fixed = fixed} = + let {functions = fns; relations = rels} = fixed + + in let fixFns = Name_arity.Map.transform (fun f -> f {size = vN}) fns + and fixRels = Name_arity.Map.transform (fun r -> r {size = vN}) rels + + in let rndFns = newTables vN vN + and rndRels = newTables vN 2 + in + {sizem = vN; + fixedFunctions = fixFns; + fixedRelations = fixRels; + randomFunctions = rndFns; + randomRelations = rndRels} + ;; + +let msize ({sizem = vN}) = vN;; +let psize ({sizep = vN}) = vN;; + +let peekFixedFunction vM (n,elts) = + let {fixedFunctions = fixFns} = vM + in + match Name_arity.Map.peek fixFns (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 {fixedRelations = fixRels} = vM + in + match Name_arity.Map.peek fixRels (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 = {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 {randomFunctions = rndFns} = vM + in + lookupTables rndFns n_elts + ;; + +let interpretRelation vM n_elts = + match peekFixedRelation vM n_elts with + Some r -> r + | None -> + let {randomRelations = rndRels} = vM + in + intToBool (lookupTables rndRels 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 {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 = 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 {randomFunctions = rndFns} = vM + + in let () = updateTables rndFns func_elts_elt + in + () + ;; + +let updateRelation vM (rel_elts,pol) = + let {randomRelations = rndRels} = vM + + 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.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 + 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 (Mlist.revAppend (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 Mlist.null perts then () + else perturb vM (Mlist.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 + + +(* ========================================================================= *) +(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC TERMS *) +(* ========================================================================= *) + +module Term_net = struct + +open Useful;; +open Order;; + +(* ------------------------------------------------------------------------- *) +(* 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) -> + (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 _, 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 = {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, 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 = 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.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,_)) -> + (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 (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) -> + (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 (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=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) -> + (match matchTermQterm qsub tm qtm with + None -> mat acc rest + | Some qsub -> mat acc ((qsub,net,tms) :: rest)) + | ((qsub, (Multiple _ as net), Term.Var 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 (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) -> + (match unifyQtermTerm qsub qtm tm with + None -> mat acc rest + | Some qsub -> mat acc ((qsub,net,tms) :: rest)) + | ((qsub, (Multiple _ as net), Term.Var 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 (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 + + +(* ========================================================================= *) +(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC ATOMS *) +(* ========================================================================= *) + +module Atom_net = struct + +open Useful;; + +(* ------------------------------------------------------------------------- *) +(* 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 = Mlist.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 + + +(* ========================================================================= *) +(* MATCHING AND UNIFICATION FOR SETS OF FIRST ORDER LOGIC LITERALS *) +(* ========================================================================= *) + +module Literal_net = struct + +open Useful;; + +(* ------------------------------------------------------------------------- *) +(* A type of literal sets that can be efficiently matched and unified. *) +(* ------------------------------------------------------------------------- *) + +type parameters = Atom_net.parameters;; + +type 'a literalNet = + {positive : 'a Atom_net.atomNet; + negative : 'a Atom_net.atomNet};; + +(* ------------------------------------------------------------------------- *) +(* Basic operations. *) +(* ------------------------------------------------------------------------- *) + +let newNet parm = {positive = Atom_net.newNet parm; negative = Atom_net.newNet parm};; + + let pos ({positive=positive} : 'a literalNet) = Atom_net.size positive;; + + let neg ({negative=negative} : 'a literalNet) = Atom_net.size negative;; + + let size net = pos net + neg net;; + + (*let profile net = {positiveN = pos net; negativeN = neg net};;*) + + +let insert {positive=positive;negative=negative} = function + ((true,atm),a) -> + {positive = Atom_net.insert positive (atm,a); negative = negative} + | ((false,atm),a) -> + {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 {positive=positive;negative=negative} = + {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 ({positive=positive;negative=negative} : 'a literalNet) = function + (true,atm) -> + Atom_net.matchNet positive atm + | (false,atm) -> Atom_net.matchNet negative atm;; + +let matched ({positive=positive;negative=negative} : 'a literalNet) = function + (true,atm) -> + Atom_net.matched positive atm + | (false,atm) -> Atom_net.matched negative atm;; + +let unify ({positive=positive;negative=negative} : 'a literalNet) = 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 + +open Useful;; +open Order;; + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +let findRest pred = + let rec f ys = function + [] -> None + | (x :: xs) -> + if pred x then Some (x, Mlist.revAppend (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 = Mlist.foldl 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 = + {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 = + {empty : (Thm.clause * Substitute.subst * 'a) list; + unitn : (Literal.literal * Thm.clause * 'a) Literal_net.literalNet; + nonunit : 'a nonunit_t};; + +open Term_net +let newSubsume () = + {empty = []; + unitn = Literal_net.newNet {fifo = false}; + nonunit = + {nextId = 0; + clauses = Intmap.newMap (); + fstLits = Literal_net.newNet {fifo = false}; + sndLits = Literal_net.newNet {fifo = false}}};; + +let size ({empty=empty; unitn=unitn; nonunit = {clauses=clauses}}) = + length empty + Literal_net.size unitn + Intmap.size clauses;; + +let insert ({empty=empty;unitn=unitn;nonunit=nonunit}) (cl',a) = + match sortClause cl' with + [] -> + let empty = (cl',Substitute.empty,a) :: empty + in + {empty = empty; unitn = unitn; nonunit = nonunit} + | [lit] -> + let unitn = Literal_net.insert unitn (lit,(lit,cl',a)) + in + {empty = empty; unitn = unitn; nonunit = nonunit} + | fstLit :: (sndLit :: otherLits as nonFstLits) -> + let {nextId=nextId;clauses=clauses;fstLits=fstLits;sndLits=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 = {nextId = nextId; clauses = clauses; + fstLits = fstLits; sndLits = sndLits} + in + {empty = empty; unitn = unitn; nonunit = nonunit} + ;; + +let filter pred ({empty=empty;unitn=unitn;nonunit=nonunit}) = + let pred3 (_,_,x) = pred x + in let empty = List.filter pred3 empty + + in let unitn = Literal_net.filter pred3 unitn + + in let nonunit = + let {nextId=nextId;clauses=clauses;fstLits=fstLits;sndLits=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 + {nextId = nextId; clauses = clauses'; + fstLits = fstLits; sndLits = sndLits} + in + {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 Mlist.foldl (matchLit lit') [] cl with + [] -> None + | [sub'] -> + (match 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 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 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) = + Mlist.foldl addId acc (Literal_net.matchNet lits lit) + + in let {nextId = _; clauses=clauses; fstLits=fstLits; sndLits=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 ({empty=empty;unitn=unitn;nonunit=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.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 + + +(* ========================================================================= *) +(* KNUTH-BENDIX TERM ORDERING CONSTRAINTS *) +(* ========================================================================= *) + +module Knuth_bendix_order = struct + +open Useful;; +open Order;; + +(* ------------------------------------------------------------------------- *) +(* 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 (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 = + {weight : Term.function_t -> int; + precedence : Term.function_t * Term.function_t -> order};; + +(* Default weight = uniform *) + +let uniformWeight : Term.function_t -> int = kComb 1;; + +(* Default precedence = by arity *) + +let arityPrecedence : Term.function_t * Term.function_t -> order = + 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 = {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.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;; + +(*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 {weight=weight;precedence=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)) -> + (match precedence ((f1, length a1), (f2, length a2)) with + Less -> true + | Equal -> firstNotEqualTerm weightLess (zip a1 a2) + | Greater -> 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 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)) -> + (match precedence ((f1, length a1), (f2, length a2)) with + Less -> Some Less + | Equal -> firstNotEqualTerm weightCmp (zip a1 a2) + | Greater -> Some Greater) + | _ -> raise (Bug "kboOrder.precendenceCmp") + in + fun (tm1,tm2) -> + if Term.equal tm1 tm2 then Some Equal 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.ppOrder "Knuth_bendix_order.compare: result" x + in + result + end;; +*) + +end + + +(* ========================================================================= *) +(* ORDERED REWRITING FOR FIRST ORDER TERMS *) +(* ========================================================================= *) + +module Rewrite = struct + +open Useful;; +open Order;; + +(* ------------------------------------------------------------------------- *) +(* 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 -> order option;; + +type equationId = int;; + +type equation = Rule.equation;; + +type rewrite_t = + {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};; + +type rewrite = + Rewrite of rewrite_t;; + +let updateWaiting rw waiting = + let Rewrite {order=order; known=known; redexes=redexes; subterms=subterms; waiting = _} = rw + in + Rewrite + {order = order; known = known; redexes = redexes; + subterms = subterms; waiting = waiting} + ;; + +let deleteWaiting (Rewrite {waiting=waiting} as rw) id = + updateWaiting rw (Intset.delete waiting id);; + +(* ------------------------------------------------------------------------- *) +(* Basic operations *) +(* ------------------------------------------------------------------------- *) + +open Term_net +let newRewrite order = + Rewrite + {order = order; + known = Intmap.newMap (); + redexes = Term_net.newNet {fifo = false}; + subterms = Term_net.newNet {fifo = false}; + waiting = Intset.empty};; + +let peek (Rewrite {known=known}) id = Intmap.peek known id;; + +let size (Rewrite {known=known}) = Intmap.size known;; + +let equations (Rewrite {known=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 total (Substitute.matchTerms Substitute.empty l) tm with + None -> false + | Some sub -> + order (tm, Substitute.subst (Substitute.normalize sub) r) = Some Greater + + 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.Var _) -> 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 Equal) -> raise (Error "Rewrite.orient: reflexive") + | (Some Greater) -> Some Left_to_right + | (Some Less) -> 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 (Rewrite {known=known} as rw) (id,eqn) = + if Intmap.inDomain id known then rw + else + let Rewrite {order=order;redexes=redexes;subterms=subterms;waiting=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 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,_)) = 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 + | (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' || 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 Less -> + let th = Rule.symmetryRule l r + in + fun tm -> + if Term.equal tm r then (l,th) else raise (Error "mkNeqConv: RL") + | Some Equal -> raise (Error "irreflexive") + | Some 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 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 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 Error err -> raise (Error ("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 = 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;; + +(*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 Bug "rewriteIdRule: should be normalized" + in + result + end + handle Error err -> raise (Error ("Rewrite.rewriteIdRule:\n" ^ err));; +*) + +let rewrIdConv (Rewrite {known=known;redexes=redexes}) order = + rewrIdConv' order known redexes;; + +let rewrConv rewrite order = rewrIdConv rewrite order (-1);; + +let rewriteIdConv (Rewrite {known=known;redexes=redexes}) order = + rewriteIdConv' order known redexes;; + +let rewriteConv rewrite order = rewriteIdConv rewrite order (-1);; + +let rewriteIdLiteralsRule (Rewrite {known=known;redexes=redexes}) order = + rewriteIdLiteralsRule' order known redexes;; + +let rewriteLiteralsRule rewrite order = + rewriteIdLiteralsRule rewrite order (-1);; + +let rewriteIdRule (Rewrite {known=known;redexes=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 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) = + 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=order;known=known;redexes=redexes;subterms=subterms;waiting=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 = +(*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=order;known=known;redexes=redexes;subterms=subterms;waiting=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, (Rewrite {known=known;waiting=waiting} as rw), changed) = + 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=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 Bug "Rewrite.reduce': not fully reduced" + in + result + end + handle Error err -> raise (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) (enumerate ths) + in + rewriteRule rw order + ;; + + let order : reductionOrder = kComb (Some Greater);; + let rewrite = orderedRewrite order;; + + +end + +(* ========================================================================= *) +(* A STORE FOR UNIT THEOREMS *) +(* ========================================================================= *) + +module Units = struct + +open Useful;; + +(* ------------------------------------------------------------------------- *) +(* 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 {fifo = 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 = Mlist.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 + + +(* ========================================================================= *) +(* CLAUSE = ID + THEOREM *) +(* ========================================================================= *) + +module Clause = struct + +open Useful;; +open Order;; + +(* ------------------------------------------------------------------------- *) +(* 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 = + {ordering : Knuth_bendix_order.kbo; + orderLiterals : literalOrder; + orderTerms : bool};; + +type clauseId = int;; + +type clauseInfo = {parameters : parameters; id : clauseId; thm : Thm.thm};; + +type clause = Clause of clauseInfo;; + + +(* ------------------------------------------------------------------------- *) +(* Pretty printing. *) +(* ------------------------------------------------------------------------- *) + +let toString (Clause {id=id;thm=thm}) = Thm.toString thm;; + + +(* ------------------------------------------------------------------------- *) +(* Basic operations. *) +(* ------------------------------------------------------------------------- *) + +let default : parameters = + {ordering = Knuth_bendix_order.default; + orderLiterals = Positive_literal_order; + orderTerms = true};; + +let mk info = Clause info + +let dest (Clause info) = info;; + +let id (Clause {id = i}) = i;; + +let thm (Clause {thm = th}) = th;; + +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}) = Thm.isTautology thm;; + +let isContradiction (Clause {thm=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 ({ordering=ordering;orderTerms=orderTerms} : parameters) 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 (Mlist.all less xs) + ;; + + let isLargerLiteral ({ordering=ordering;orderLiterals=orderLiterals} : parameters) 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=parameters;thm=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 (Clause {parameters=parameters} as cl) = + 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 + 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=parameters;id=id;thm=thm}) = + Clause {parameters = parameters; id = id; thm = Rule.freshVars thm};; + +let simplify (Clause {parameters=parameters;id=id;thm=thm}) = + match Rule.simplify thm with + None -> None + | Some thm -> Some (Clause {parameters = parameters; id = id; thm = thm});; + +let reduce units (Clause {parameters=parameters;id=id;thm=thm}) = + Clause {parameters = parameters; id = id; thm = Units.reduce units thm};; + +let rewrite rewr (Clause {parameters=parameters;id=id;thm=thm}) = + let simp th = + let {ordering=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 Error err -> raise (Error ("Clause.rewrite:\n" ^ err));; +*) + +(* ------------------------------------------------------------------------- *) +(* Inference rules: these generate new clause ids. *) +(* ------------------------------------------------------------------------- *) + +let factor (Clause {parameters=parameters;thm=thm} as cl) = + 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=parameters; thm = th1} = cl1 + and Clause {thm = th2} = cl2 + 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) || +*) + raise (Error "resolve: clause1: ordering constraints") + in let _ = isLargerLiteral parameters (Thm.clause th2) lit2 || +(*MetisTrace5 + (trace "Clause.resolve: th2 violates ordering\n";; false) || +*) + raise (Error "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=parameters; thm = th1} = cl1 + and Clause {thm = th2} = cl2 + 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 +(*MetisTrace6 + let () = Print.trace Rule.ppEquation "Clause.paramodulate: eqn" eqn +*) + in let _ = isLargerTerm parameters l_r || + raise (Error "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 Error err -> + let + let () = trace ("Clause.paramodulate: failed: " ^ err ^ "\n") + in + raise Error err + end;; +*) + + +end + + +module Ax_cj = struct + +type ax_cj_thm = {axioms_thm : Thm.thm list; conjecture_thm : Thm.thm list};; +type ax_cj_cl = {axioms_cl : Clause.clause list; conjecture_cl : Clause.clause list};; + +end + +(* ========================================================================= *) +(* THE ACTIVE SET OF CLAUSES *) +(* ========================================================================= *) + +module Active = struct + +open Useful;; +open Order;; +open Ax_cj + +(* ------------------------------------------------------------------------- *) +(* Helper functions. *) +(* ------------------------------------------------------------------------- *) + +(*MetisDebug +local + let mkRewrite ordering = + let + let add (cl,rw) = + let + let {id, thm = th, ...} = Clause.dest cl + in + match 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 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 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 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 (Bug "Active.checkSaturated");; +*) + +(* ------------------------------------------------------------------------- *) +(* A type of active clause sets. *) +(* ------------------------------------------------------------------------- *) + +type simplify = {subsumes : bool; reduce : bool; rewrites : bool};; + +type parameters = + {clause : Clause.parameters; + prefactor : simplify; + postfactor : simplify};; + +type active_t = + {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};; + +type active = + Active of active_t;; + +let getSubsume (Active {subsume = s}) = s;; + +let setRewrite active rewrite = + let Active + {parameters=parameters;clauses=clauses;units=units;subsume=subsume;literals=literals;equations=equations; + subterms=subterms;allSubterms=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 = {subsumes = true; reduce = true; rewrites = true};; + +let default : parameters = + {clause = Clause.default; + prefactor = maxSimplify; + postfactor = maxSimplify};; + +open Term_net +let empty parameters = + let {clause=clause} = parameters + in let {Clause.ordering=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 {fifo = false}; + equations = Term_net.newNet {fifo = false}; + subterms = Term_net.newNet {fifo = false}; + allSubterms = Term_net.newNet {fifo = false}} + ;; + +let size (Active {clauses=clauses}) = Intmap.size clauses;; + +let clauses (Active {clauses = cls}) = + 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 {subsumes = s; reduce = r; rewrites = w} = 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 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 + Bug + ("Active.simplify: clause should have been simplified "^e) + end + in + cl' + end;; +*) + +let simplifyActive simp active = + let Active {units=units;rewrite=rewrite;subsume=subsume} = active + in + simplify simp units rewrite subsume + ;; + +(* ------------------------------------------------------------------------- *) +(* Add a clause into the active set. *) +(* ------------------------------------------------------------------------- *) + +let addUnit units cl = + let th = Clause.thm cl + in + match total Thm.destUnit th with + Some lit -> Units.add units (lit,th) + | None -> units + ;; + +let addRewrite rewrite cl = + let th = Clause.thm cl + in + match 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) + ;; + +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=parameters;clauses=clauses;units=units;rewrite=rewrite;subsume=subsume;literals=literals; + equations=equations;subterms=subterms;allSubterms=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=parameters;clauses=clauses;units=units;rewrite=rewrite;subsume=subsume;literals=literals; + equations=equations;subterms=subterms;allSubterms=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} + ;; + +(* ------------------------------------------------------------------------- *) +(* Derive (unfactored) consequences of a clause. *) +(* ------------------------------------------------------------------------- *) + +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 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 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 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=parameters;literals=literals;equations=equations;subterms=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 +(*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 +*) + + 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 + ;; + +(* ------------------------------------------------------------------------- *) +(* Extract clauses from the active set that can be simplified. *) +(* ------------------------------------------------------------------------- *) + + let clause_rewritables active = + let Active {clauses=clauses;rewrite=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=parameters;rewrite=rewrite;clauses=clauses;allSubterms=allSubterms} = active + in let {clause = {Clause.ordering=ordering}} = parameters + 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) = +(*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 () = + 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 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=parameters; + clauses=clauses; + units=units; + rewrite=rewrite; + subsume=subsume; + literals=literals; + equations=equations; + subterms=subterms; + allSubterms=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 cP1 literals + and equations = Term_net.filter cP1_4 equations + and subterms = Term_net.filter cP1_4 subterms + and allSubterms = Term_net.filter cP1 allSubterms + in + Active + {parameters = parameters; + clauses = clauses; + units = units; + rewrite = rewrite; + subsume = subsume; + literals = literals; + equations = equations; + subterms = subterms; + allSubterms = allSubterms} + ;; -(* ========================================================================= *) -(* Main Metis module. *) -(* ========================================================================= *) + let extract_rewritables (Active {clauses=clauses;rewrite=rewrite} as active) = + 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 Error err -> + raise (Bug ("Active.extract_rewritables: shouldn't fail\n" ^ err));; +*) +;; -module Metis = struct +(* ------------------------------------------------------------------------- *) +(* Factor clauses. *) +(* ------------------------------------------------------------------------- *) + + let prefactor_simplify active subsume = + let Active {parameters=parameters;units=units;rewrite=rewrite} = active + in let {prefactor=prefactor} = parameters + in + simplify prefactor units rewrite subsume + ;; + + let postfactor_simplify active subsume = + let Active {parameters=parameters;units=units;rewrite=rewrite} = active + in let {postfactor=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 (Clause.thm cl) 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 Mlist.foldl 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) = 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');; +*) -exception Assert of string;; +(*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;; +*) (* ------------------------------------------------------------------------- *) -(* Metis prover. *) +(* Create a new active clause set and initialize clauses. *) (* ------------------------------------------------------------------------- *) -let metisverb = ref false;; +let mk_clause params th = + Clause.mk {Clause.parameters = params; Clause.id = Clause.newId (); Clause.thm = th};; -loads "metis/random.ml";; -loads "metis/portable.ml";; -loads "metis/math.ml";; +let newActive parameters {axioms_thm=axioms_thm;conjecture_thm=conjecture_thm} = + let {clause=clause} = parameters -(* Inline the Useful module here, as it's used almost everywhere in Metis: *) + 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, {axioms_cl = axioms; conjecture_cl = conjecture}) + ;; (* ------------------------------------------------------------------------- *) -(* Exceptions. *) +(* Add a clause into the active set and deduce all consequences. *) (* ------------------------------------------------------------------------- *) -exception Error of string;; +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) + ;; -exception Bug of string;; +end -let total f x = try Some (f x) with Error _ -> None;; -let isSome = function - (Some _) -> true - | None -> false -;; +(* ========================================================================= *) +(* THE WAITING SET OF CLAUSES *) +(* ========================================================================= *) -let can f x = isSome (total f x);; +module Waiting = struct + +open Useful;; +open Ax_cj +open Real (* ------------------------------------------------------------------------- *) -(* Combinators. *) +(* A type of waiting sets of clauses. *) (* ------------------------------------------------------------------------- *) -let cComb f x y = f y x;; - -let iComb x = x;; +type weight = real;; -let kComb x y = x;; +type modelParameters = + {model : Model.parameters; + initialPerturbations : int; + maxChecks : int option; + perturbations : int; + weight : weight} -let sComb f g x = f x (g x);; +type parameters = + {symbolsWeight : weight; + variablesWeight : weight; + literalsWeight : weight; + modelsP : modelParameters list};; -let wComb f x = f x x;; +type distance = real;; -let rec funpow n f x = - match n with - | 0 -> x - | _ -> funpow (n - 1) f (f x);; +type waiting_t = + {parameters : parameters; + clauses : (weight * (distance * Clause.clause)) Heap.heap; + models : Model.model list};; -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;; +type waiting = + Waiting of waiting_t;; (* ------------------------------------------------------------------------- *) -(* Pairs. *) +(* Basic operations. *) (* ------------------------------------------------------------------------- *) -let pair x y = (x,y);; +let defaultModels : modelParameters list = + [{model = Model.default; + initialPerturbations = 100; + maxChecks = Some 20; + perturbations = 0; + weight = 1.0}];; -let swap (x,y) = (y,x);; +let default : parameters = + {symbolsWeight = 1.0; + literalsWeight = 1.0; + variablesWeight = 1.0; + modelsP = defaultModels};; -let curry f x y = f (x,y);; +let size (Waiting {clauses=clauses}) = Heap.size clauses;; + +let toString w = "Waiting{" ^ Int.toString (size w) ^ "}";; + +(*let toString (Waiting {clauses}) = "\n" ^ + String.concat "\n" (List.map (fun (w, (d, c)) -> Clause.toString c) (Heap.toList clauses));;*) -let uncurry f (x,y) = f x y;; + +(*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));; +*) (* ------------------------------------------------------------------------- *) -(* State transformers. *) +(* Perturbing the models. *) (* ------------------------------------------------------------------------- *) -let return (* : 'a -> 's -> 'a * 's *) = pair;; +type modelClause = Name.Set.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 bind f (g (* : 'a -> 's -> 'b * 's *)) x = uncurry g (f x);; +let perturbModel vM cls = + if Mlist.null cls then kComb () + else + let vN = {Model.size = Model.msize vM} + + 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 + + in let perturbClauses () = app perturbClause cls + in + fun n -> funpow n perturbClauses () + ;; + +let initialModel axioms conjecture parm = + let {model=model;initialPerturbations=initialPerturbations} = parm + in let m = Model.newModel model + in let () = perturbModel m conjecture initialPerturbations + in let () = perturbModel m axioms initialPerturbations + in + m + ;; + +let checkModels parms models (fv,cl) = + let check ((parm,model),z) = + let {maxChecks=maxChecks;weight=weight} = parm + in let n = maxChecks + in let (vT,vF) = Model.check Model.interpretClause n model fv cl + in + Math.pow (1.0 +. Real.fromInt vT /. Real.fromInt (vT + vF), weight) *. z + in + Mlist.foldl check 1.0 (zip parms models) + ;; + +let perturbModels parms models cls = + let perturb (parm,model) = + let {perturbations=perturbations} = parm + in + perturbModel model cls perturbations + in + app perturb (zip parms models) + ;; (* ------------------------------------------------------------------------- *) -(* Comparisons. *) +(* Clause weights. *) (* ------------------------------------------------------------------------- *) -let revCompare cmp x y = - match cmp x y with Less -> Greater | Equal -> Equal | Greater -> Less;; + let clauseSymbols cl = Real.fromInt (Literal.Set.typedSymbols cl);; -let prodCompare xCmp yCmp (x1,y1) (x2,y2) = - match xCmp x1 x2 with - | Less -> Less - | Equal -> yCmp y1 y2 - | Greater -> Greater;; + let clauseVariables cl = + Real.fromInt (Name.Set.size (Literal.Set.freeVars cl) + 1);; -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 clauseLiterals cl = Real.fromInt (Literal.Set.size cl);; -let boolCompare x y = - match x,y with - | (false,true) -> Less - | (true,false) -> Greater - | _ -> Equal;; + let clausePriority cl = 1e-12 *. Real.fromInt (Clause.id cl);; + + let clauseWeight (parm : parameters) mods dist mcl cl = +(*MetisTrace3 + let () = Print.trace Clause.pp "Waiting.clauseWeight: cl" cl +*) + let {symbolsWeight=symbolsWeight;variablesWeight=variablesWeight;literalsWeight=literalsWeight;modelsP=modelsP} = parm + in let lits = Clause.literals cl + in let symbolsW = Math.pow (clauseSymbols lits, symbolsWeight) + in let variablesW = Math.pow (clauseVariables lits, variablesWeight) + in let literalsW = Math.pow (clauseLiterals lits, literalsWeight) + in let modelsW = checkModels modelsP mods mcl +(*MetisTrace4 + let () = trace ("Waiting.clauseWeight: dist = " ^ + Real.toString dist ^ "\n") + let () = trace ("Waiting.clauseWeight: symbolsW = " ^ + Real.toString symbolsW ^ "\n") + let () = trace ("Waiting.clauseWeight: variablesW = " ^ + Real.toString variablesW ^ "\n") + let () = trace ("Waiting.clauseWeight: literalsW = " ^ + Real.toString literalsW ^ "\n") + let () = trace ("Waiting.clauseWeight: modelsW = " ^ + Real.toString modelsW ^ "\n") +*) + in let weight = dist *. symbolsW *. variablesW *. literalsW *. modelsW + in let weight = weight +. clausePriority cl +(*MetisTrace3 + let () = trace ("Waiting.clauseWeight: weight = " ^ + Real.toString weight ^ "\n") +*) + in + weight + ;; (* ------------------------------------------------------------------------- *) -(* Lists. *) +(* Adding new clauses. *) (* ------------------------------------------------------------------------- *) -let rec first f = function - | [] -> None - | x::xs -> match f x with None -> first f xs | s -> s;; +let add' waiting dist mcls cls = + let Waiting {parameters=parameters;clauses=clauses;models=models} = waiting + in let {modelsP = modelParameters} = parameters -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)));; +(*MetisDebug + let _ = not (Mlist.null cls) || + raise Bug "Waiting.add': null" -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)) -;; + let _ = length mcls = length cls || + raise Bug "Waiting.add': different lengths" +*) -let zip xs ys = zipWith pair xs ys;; + in let dist = dist +. Math.ln (Real.fromInt (length cls)) -let unzip ab = - let inc (x,y) (xs,ys) = (x :: xs, y :: ys) in - List.foldl inc ([],[]) (List.rev ab);; + in let addCl ((mcl,cl),acc) = + let weight = clauseWeight parameters models dist mcl cl + in + Heap.add acc (weight,(dist,cl)) -let enumerate l = fst (maps (fun x m -> ((m, x), m + 1)) l 0);; + in let clauses = Mlist.foldl addCl clauses (zip mcls cls) -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 () = perturbModels modelParameters models mcls + in + Waiting {parameters = parameters; clauses = clauses; models = models} + ;; -let divide l n = let (a,b) = revDivide l n in (List.rev a, b);; +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 updateNth (n,x) l = - let (a,b) = revDivide l n in - match b with [] -> raise Subscript | (_ :: t) -> rev_append a (x :: t) -;; + let waiting = add' waiting dist (mkModelClauses cls) cls -let deleteNth n l = - let (a,b) = revDivide l n in - match b with [] -> raise Subscript | (_ :: t) -> rev_append a t -;; +(*MetisTrace3 + let () = Print.trace pp "Waiting.add: waiting" waiting +*) + in + waiting + ;; -(* ------------------------------------------------------------------------- *) -(* Sets implemented with lists. *) -(* ------------------------------------------------------------------------- *) + let cmp ((w1,_),(w2,_)) = Real.compare (w1,w2);; + + let empty parameters axioms conjecture = + let {modelsP = modelParameters} = parameters + 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 {axioms_cl=axioms_cl;conjecture_cl=conjecture_cl} = + let mAxioms = mkModelClauses axioms_cl + and mConjecture = mkModelClauses conjecture_cl -let mem x l = List.exists (fun y -> x = y) l;; + in let waiting = empty parameters mAxioms mConjecture + in + if Mlist.null axioms_cl && Mlist.null conjecture_cl then waiting + else add' waiting 0.0 (mAxioms @ mConjecture) (axioms_cl @ conjecture_cl) +(*MetisDebug + handle e -> + let + let () = Print.trace Print.ppException "Waiting.new: exception" e + in + raise e + end;; +*) (* ------------------------------------------------------------------------- *) -(* Strings. *) +(* Removing the lightest clause. *) (* ------------------------------------------------------------------------- *) -let mkPrefix p s = p ^ s +let remove (Waiting {parameters=parameters;clauses=clauses;models=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 -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);; + +(* ========================================================================= *) +(* THE RESOLUTION PROOF PROCEDURE *) +(* ========================================================================= *) + +module Resolution = struct + +open Useful;; (* ------------------------------------------------------------------------- *) -(* Sorting and searching. *) +(* A type of resolution proof procedures. *) (* ------------------------------------------------------------------------- *) -let sort cmp = List.sort (fun x y -> cmp x y = Less);; +type parameters = + {activeP : Active.parameters; + waitingP : Waiting.parameters};; -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 -;; +type resolution_t = + {parameters : parameters; + active : Active.active; + waiting : Waiting.waiting};; + +type resolution = + Resolution of resolution_t;; (* ------------------------------------------------------------------------- *) -(* Integers. *) +(* Basic operations. *) (* ------------------------------------------------------------------------- *) -let rec interval m = function - | 0 -> [] - | len -> m :: interval (m + 1) (len - 1);; +let default : parameters = + {activeP = Active.default; + waitingP = Waiting.default};; + +let newResolution parameters ths = + let {activeP = activeParm; waitingP = waitingParm} = parameters + + 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 = a}) = a;; + +let waiting (Resolution {waiting = w}) = w;; -let divides = function - | (_, 0) -> true - | (0, _) -> false - | (a, b) -> b mod (abs a) = 0;; -let divides = curry divides;; (* ------------------------------------------------------------------------- *) -(* Useful impure features. *) +(* The main proof loop. *) (* ------------------------------------------------------------------------- *) -let generator = ref 0;; +type decision = + Contradiction of Thm.thm + | Satisfiable of Thm.thm list;; -let newIntThunk () = - let n = !generator in - generator := n + 1; - n -;; +type state = + Decided of decision + | Undecided of resolution;; -let newIntsThunk k () = - let n = !generator in - generator := n + k; - interval n k -;; +let iterate res = + let Resolution {parameters=parameters;active=active;waiting=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;; + + +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 + +open Ax_cj -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";; +let run rules = + let ths = {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 + +open Metis_prover + + 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 + + +module Metis_path = struct + +open Metis_prover + +(* 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 + 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 (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 + +open Metis_prover + +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%!" + (Term.toString fat) (string_of_term tm); + match fat with + Term.Var 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 + | Term.Var 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) + | 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 (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 + +open Metis_prover + +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 + +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.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%!" (Thm.toString fth); + 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 = 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)" *) + | 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 = Substitute.toList fsub in + if !metisverb then Format.printf "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 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 + | 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) + | 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 + 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' = Thm.clause fth |> 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 + +open Metis_prover + +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 + + +(* ========================================================================= *) +(* Main Metis module. *) +(* ========================================================================= *) + +module Metis = struct + +open Metis_prover (* ------------------------------------------------------------------------- *) (* Some parameters controlling Metis behaviour. *) @@ -311,18 +10251,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 +10274,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 +10331,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(); @@ -385,8 +10341,8 @@ let SIMPLE_METIS_REFUTE ths = 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; @@ -394,19 +10350,16 @@ let SIMPLE_METIS_REFUTE ths = 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 -> mem h allhyps) (hyp proof)); + assert (concl proof = `F`); proof -;; let PURE_METIS_TAC g = Meson.reset_vars(); Meson.reset_consts(); @@ -416,17 +10369,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 +10381,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 *) -;; From 0a5e935c976d1ff780906c23b8f82939189844e5 Mon Sep 17 00:00:00 2001 From: John Harrison Date: Mon, 16 Feb 2026 19:05:44 +0000 Subject: [PATCH 14/79] 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). New definitions: collectionwise_normal_space countably_paracompact_space locally_metrizable_space paracompact_space realcompact_space sigma_locally_finite_in and theorems CLF_OPEN_CLOSURE_IMP_LF_CLOSED CLOSED_GDELTA_IN_SIGMA_LF_BASE CLOSED_G_DELTA_IN_SIGMA_LOCALLY_FINITE_BASE CLOSED_REFINEMENT_IMP_PARACOMPACT COLLECTIONWISE_NORMAL_IMP_NORMAL COLLECTIONWISE_NORMAL_SPACE_CLOSED_SUBSET COMPACT_IMP_PARACOMPACT_SPACE COMPACT_LF_OPEN_NEIGHBORHOOD COMPACT_TUBE_COVER CONTINUOUS_MAP_SUM_LOCALLY_FINITE COUNTABLE_IMP_SIGMA_LOCALLY_FINITE_IN COUNTABLY_PARACOMPACT_IMP_DOWKER COUNTABLY_PARACOMPACT_SPACE_CLOSED_SUBSET COUNTABLY_PARACOMPACT_SPACE_PRODUCT_COMPACT CP_IMPLIES_NORMAL_SPACE CP_INDEXED_CLOSED_COVER DOWKER_BACKWARD DOWKER_DISCRETE_EXPANSION EXPANSION_SET_CONTAINS EXPANSION_SET_OPEN HOMEOMORPHIC_PARACOMPACT_SPACE LF_CLOSED_PERFECT_MAP_IMAGE LF_COVERING_IMP_LF_CLOSED LF_COVERING_IMP_LF_OPEN LINDELOF_HAUSDORFF_REGULAR_EQ_PARACOMPACT LOCALLY_FINITE_IN_HOMEOMORPHIC_IMAGE LOCALLY_FINITE_LEVEL_UNION_GEN LOCALLY_FINITE_PRODUCT_TUBES METRIC_COVER_SIGMA_LOCALLY_FINITE METRIZABLE_IMP_COLLECTIONWISE_NORMAL METRIZABLE_IMP_COUNTABLY_PARACOMPACT_SPACE METRIZABLE_IMP_PARACOMPACT_SPACE MICHAEL_LEMMA MICHAEL_PARACOMPACT MICHAEL_PARACOMPACT_EQ NAGATA_SMIRNOV_METRIZATION NORMAL_COUNTABLY_PARACOMPACT_CHARACTERIZATION NORMAL_SPACE_SIGMA_LOCALLY_FINITE_BASE OPEN_SIGMA_LF_CLOSURE_COVER PARACOMPACT_HAUSDORFF_CLOSURE_REFINEMENT PARACOMPACT_HAUSDORFF_EXPANSION_LEMMA PARACOMPACT_HAUSDORFF_IMP_COLLECTIONWISE_NORMAL PARACOMPACT_HAUSDORFF_IMP_NORMAL_SPACE PARACOMPACT_HAUSDORFF_IMP_REGULAR_SPACE PARACOMPACT_HAUSDORFF_INDEXED_SHRINKING PARACOMPACT_IMP_COUNTABLY_PARACOMPACT_SPACE PARACOMPACT_LOCALLY_METRIZABLE_IMP_METRIZABLE PARACOMPACT_LOCALLY_METRIZABLE_SIGMA_LF_BASE PARACOMPACT_PARTITION_OF_UNITY PARACOMPACT_SPACE_CLOSED_MAP_IMAGE PARACOMPACT_SPACE_CLOSED_SUBSET PARACOMPACT_SPACE_DISCRETE_TOPOLOGY PARACOMPACT_SPACE_EQ_CLOSED_REFINEMENT PARACOMPACT_SPACE_EQ_LOCALLY_FINITE_REFINEMENT PARACOMPACT_SPACE_EUCLIDEAN PARACOMPACT_SPACE_EUCLIDEAN_SUBTOPOLOGY PARACOMPACT_SPACE_FSIGMA_SUBSET PARACOMPACT_SPACE_MTOPOLOGY PARACOMPACT_SPACE_PERFECT_MAP_IMAGE PARACOMPACT_SPACE_PERFECT_MAP_PREIMAGE PARACOMPACT_SPACE_PRODUCT_COMPACT_LEFT PARACOMPACT_SPACE_PRODUCT_COMPACT_RIGHT PARACOMPACT_SPACE_RETRACTION_MAP_IMAGE POINT_FINITE_CP_CLOSED_IMP_LOCALLY_FINITE REGULAR_CLOSURE_REFINEMENT_COVERS REGULAR_LINDELOF_IMP_PARACOMPACT_SPACE REGULAR_OPEN_COVER_CLOSURE_SHRINK SECOND_COUNTABLE_LOCALLY_COMPACT_HAUSDORFF_IMP_PARACOMPACT SECOND_COUNTABLE_REGULAR_IMP_PARACOMPACT_SPACE SHRINK_DISJOINT_LATER SHRINK_SEQUENCE_COVERS SHRINK_SEQUENCE_LOCALLY_FINITE SIGMA_LOCALLY_FINITE_IMP_LOCALLY_FINITE_COVERING SMIRNOV_METRIZATION SMIRNOV_METRIZATION_SECOND_COUNTABLE URYSOHN_FUNCTION_CLOSED_GDELTA URYSOHN_FUNCTION_G_DELTA Two Euclidean theorems PARACOMPACT_CLOSED and PARACOMPACT_CLOSED_IN have been removed since they now seem too ad hoc, though PARACOMPACT is retained. --- CHANGES | 18 + Multivariate/complex_database.ml | 45 +- Multivariate/metric.ml | 3256 ++++++++++++++ Multivariate/multivariate_database.ml | 45 +- Multivariate/paracompact.ml | 5976 +++++++++++++++++++++++++ Multivariate/topology.ml | 351 +- holtest.mk | 1 + 7 files changed, 9429 insertions(+), 263 deletions(-) create mode 100644 Multivariate/paracompact.ml diff --git a/CHANGES b/CHANGES index 954b8abd..e4cb236e 100644 --- a/CHANGES +++ b/CHANGES @@ -8,6 +8,24 @@ * page: https://github.com/jrh13/hol-light/commits/master * * ***************************************************************** +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 diff --git a/Multivariate/complex_database.ml b/Multivariate/complex_database.ml index ef61a7de..db5ce052 100644 --- a/Multivariate/complex_database.ml +++ b/Multivariate/complex_database.ml @@ -2676,6 +2676,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; @@ -2722,6 +2723,7 @@ theorems := "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; @@ -2781,6 +2783,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; @@ -3859,6 +3862,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 +4599,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; @@ -6059,6 +6064,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; @@ -8850,6 +8857,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; @@ -11312,6 +11320,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; @@ -11648,6 +11659,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; @@ -12008,10 +12020,12 @@ theorems := "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; @@ -12964,6 +12978,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; @@ -12976,6 +12991,7 @@ 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; @@ -12989,6 +13005,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; @@ -14367,8 +14384,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; @@ -17030,11 +17064,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; @@ -17461,9 +17497,11 @@ theorems := "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; @@ -17802,6 +17840,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; @@ -20414,6 +20453,7 @@ theorems := "pair_INDUCT",pair_INDUCT; "pair_RECURSION",pair_RECURSION; "pairwise",pairwise; +"paracompact_space",paracompact_space; "partcirclepath",partcirclepath; "pastecart",pastecart; "path",path; @@ -20564,6 +20604,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; diff --git a/Multivariate/metric.ml b/Multivariate/metric.ml index 0b0994c0..67f843d1 100644 --- a/Multivariate/metric.ml +++ b/Multivariate/metric.ml @@ -35458,6 +35458,3262 @@ let GDELTA_IN_EQ_COMPLETELY_METRIZABLE_SPACE = prove 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 + (`!(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 + [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 + (* 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 + 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 + (* 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 + (* 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[]]);; + +(* 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 + 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 + (* 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 + 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 + 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[]]);; + +(* 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. + 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[]);; + +(* 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_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 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 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_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 + [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 + 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[]);; + +(* 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 + 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: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 + 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[]);; + +(* 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. + second_countable top /\ regular_space top + ==> paracompact_space top`, + MESON_TAC[REGULAR_LINDELOF_IMP_PARACOMPACT_SPACE; + SECOND_COUNTABLE_IMP_LINDELOF_SPACE]);; + +(* 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 + `!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 + (* 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 + [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 `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 + `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 + (* 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 *) diff --git a/Multivariate/multivariate_database.ml b/Multivariate/multivariate_database.ml index 79705413..c60a956c 100644 --- a/Multivariate/multivariate_database.ml +++ b/Multivariate/multivariate_database.ml @@ -2249,6 +2249,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; @@ -2295,6 +2296,7 @@ theorems := "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; @@ -2353,6 +2355,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; @@ -3128,6 +3131,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 +3736,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; @@ -5070,6 +5075,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; @@ -7367,6 +7374,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; @@ -9697,6 +9705,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; @@ -9947,6 +9958,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; @@ -10290,10 +10302,12 @@ theorems := "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; @@ -11194,6 +11208,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; @@ -11206,6 +11221,7 @@ 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; @@ -11219,6 +11235,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; @@ -12538,8 +12555,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; @@ -14139,11 +14173,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; @@ -14452,9 +14488,11 @@ theorems := "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; @@ -14764,6 +14802,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; @@ -17026,6 +17065,7 @@ theorems := "pair_INDUCT",pair_INDUCT; "pair_RECURSION",pair_RECURSION; "pairwise",pairwise; +"paracompact_space",paracompact_space; "pastecart",pastecart; "path",path; "path_component",path_component; @@ -17138,6 +17178,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; 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/topology.ml b/Multivariate/topology.ml index e8bec2bf..30684109 100644 --- a/Multivariate/topology.ml +++ b/Multivariate/topology.ml @@ -36239,9 +36239,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' /\ @@ -36250,265 +36260,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/holtest.mk b/holtest.mk index 17d37757..17af782a 100644 --- a/holtest.mk +++ b/holtest.mk @@ -110,6 +110,7 @@ EXTENDED_EXAMPLES:=\ Multivariate/homology \ Multivariate/lpspaces \ Multivariate/msum \ + Multivariate/paracompact \ Multivariate/specialtopologies \ Multivariate/tarski \ RichterHilbertAxiomGeometry/Topology \ From 0c9e65f072675de3f537e35379ddf06fd4fa7218 Mon Sep 17 00:00:00 2001 From: John Harrison Date: Thu, 19 Feb 2026 10:44:05 -0800 Subject: [PATCH 15/79] 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 --- CHANGES | 37 + Library/rabin_test.ml | 1644 +++++++++++++++++++++++++++++++++++++++++ Library/ringtheory.ml | 107 +++ holtest.mk | 1 + 4 files changed, 1789 insertions(+) create mode 100644 Library/rabin_test.ml diff --git a/CHANGES b/CHANGES index e4cb236e..6532006d 100644 --- a/CHANGES +++ b/CHANGES @@ -8,6 +8,43 @@ * page: https://github.com/jrh13/hol-light/commits/master * * ***************************************************************** +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 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..a81a3d68 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 @@ -20879,6 +20950,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 <=> diff --git a/holtest.mk b/holtest.mk index 17af782a..cca83dc6 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 \ From 2ce6c3e1af0e7e548f366fd1a693251a153483f0 Mon Sep 17 00:00:00 2001 From: John Harrison Date: Fri, 20 Feb 2026 01:38:37 +0000 Subject: [PATCH 16/79] 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). --- CHANGES | 80 ++ Multivariate/complex_database.ml | 49 + Multivariate/metric.ml | 1594 +++++++++++++++++++++++++ Multivariate/multivariate_database.ml | 49 + Multivariate/paths.ml | 823 ++++--------- Multivariate/topology.ml | 146 +-- 6 files changed, 2032 insertions(+), 709 deletions(-) diff --git a/CHANGES b/CHANGES index 6532006d..d4e0baaa 100644 --- a/CHANGES +++ b/CHANGES @@ -8,6 +8,86 @@ * page: https://github.com/jrh13/hol-light/commits/master * * ***************************************************************** +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 diff --git a/Multivariate/complex_database.ml b/Multivariate/complex_database.ml index db5ce052..67dc8fa4 100644 --- a/Multivariate/complex_database.ml +++ b/Multivariate/complex_database.ml @@ -2708,6 +2708,10 @@ 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_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; @@ -2716,9 +2720,11 @@ 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; @@ -3287,7 +3293,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; @@ -3350,6 +3358,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; @@ -3387,6 +3396,8 @@ 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_CLOPEN_CASES",CONNECTED_IN_CLOPEN_CASES; "CONNECTED_IN_CLOSED_IN",CONNECTED_IN_CLOSED_IN; "CONNECTED_IN_CLOSURE_OF",CONNECTED_IN_CLOSURE_OF; @@ -3403,11 +3414,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; @@ -3415,12 +3430,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; @@ -5786,6 +5805,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; @@ -6268,6 +6288,13 @@ theorems := "FATOU_STRONG",FATOU_STRONG; "FCCOVERABLE_IMP_LOCALLY_CONNECTED",FCCOVERABLE_IMP_LOCALLY_CONNECTED; "FCCOVERABLE_INTERMEDIATE_CLOSURE",FCCOVERABLE_INTERMEDIATE_CLOSURE; +"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; @@ -10562,6 +10589,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; @@ -11947,6 +11975,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; @@ -11993,6 +12022,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; @@ -12550,6 +12580,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; @@ -12585,6 +12616,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; @@ -12634,7 +12666,10 @@ theorems := "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; @@ -12651,6 +12686,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; @@ -13151,6 +13187,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; @@ -13361,6 +13398,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; @@ -18401,6 +18439,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; @@ -19051,6 +19090,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; @@ -19069,6 +19109,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; @@ -19248,6 +19289,8 @@ theorems := "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; @@ -19735,8 +19778,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; @@ -20095,6 +20141,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; @@ -20695,6 +20743,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 67f843d1..e115cf8e 100644 --- a/Multivariate/metric.ml +++ b/Multivariate/metric.ml @@ -12825,6 +12825,291 @@ let CONNECTED_IN_NONSEPARATED_UNION = prove SEPARATED_IN_MONO)) THEN ASM SET_TAC[]);; +(* ------------------------------------------------------------------------- *) +(* Helper: Connected unions with common point in closures *) +(* ------------------------------------------------------------------------- *) + +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[]]);; + +(* Generalization: closed connected sets with one compact member *) + +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[]]]);; + +(* Nested sequence version *) + +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 +14252,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 +19838,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))`, @@ -31550,6 +31918,14 @@ let MDIAMETER_UNION_LE = prove 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 = {}) /\ @@ -31647,6 +32023,1224 @@ let LEBESGUE_COVERING_LEMMA_GEN = prove 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 + [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 + `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 + 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 + 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 + 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 `(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 + [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 + [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 `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]]]);; + + +(* ------------------------------------------------------------------------- *) +(* Uniformly locally connected and Property S for metric spaces *) +(* ------------------------------------------------------------------------- *) + +(* 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 + [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 + `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]]]);; + + +(* ------------------------------------------------------------------------- *) +(* fccoverable_in is equivalent to fccoverable_space on the submetric. *) +(* ------------------------------------------------------------------------- *) + +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`]);; + +(* ------------------------------------------------------------------------- *) +(* fccoverable_in implies locally_connected_space on subtopology *) +(* ------------------------------------------------------------------------- *) + +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]]);; + +(* ------------------------------------------------------------------------- *) +(* Compact + locally connected implies ULC *) +(* ------------------------------------------------------------------------- *) + +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 + `?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[]]);; + +(* 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]);; + +(* ------------------------------------------------------------------------- *) +(* Totally bounded + ULC implies Property S *) +(* ------------------------------------------------------------------------- *) + +(* Note: For general metric spaces, we need totally_bounded_in rather than + just mbounded, since bounded + discrete doesn't imply finite in general. *) + +(* Helper lemma: each mball(x,d/2) INTER t contains at most one element *) + +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 + 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]]);; + +(* 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 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 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]]]);; + + (* ------------------------------------------------------------------------- *) (* "Capped" equivalent bounded metrics and general product metrics. *) (* ------------------------------------------------------------------------- *) diff --git a/Multivariate/multivariate_database.ml b/Multivariate/multivariate_database.ml index c60a956c..50c208a8 100644 --- a/Multivariate/multivariate_database.ml +++ b/Multivariate/multivariate_database.ml @@ -2281,6 +2281,10 @@ 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_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; @@ -2289,9 +2293,11 @@ 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; @@ -2607,7 +2613,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; @@ -2670,6 +2678,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; @@ -2703,6 +2712,8 @@ 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_CLOPEN_CASES",CONNECTED_IN_CLOPEN_CASES; "CONNECTED_IN_CLOSED_IN",CONNECTED_IN_CLOSED_IN; "CONNECTED_IN_CLOSURE_OF",CONNECTED_IN_CLOSURE_OF; @@ -2719,11 +2730,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; @@ -2731,12 +2746,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; @@ -4806,6 +4825,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; @@ -5265,6 +5285,13 @@ theorems := "FATOU_STRONG",FATOU_STRONG; "FCCOVERABLE_IMP_LOCALLY_CONNECTED",FCCOVERABLE_IMP_LOCALLY_CONNECTED; "FCCOVERABLE_INTERMEDIATE_CLOSURE",FCCOVERABLE_INTERMEDIATE_CLOSURE; +"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; @@ -8979,6 +9006,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; @@ -10230,6 +10258,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; @@ -10275,6 +10304,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; @@ -10787,6 +10817,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; @@ -10822,6 +10853,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; @@ -10871,7 +10903,10 @@ theorems := "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; @@ -10888,6 +10923,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; @@ -11366,6 +11402,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; @@ -11574,6 +11611,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; @@ -15251,6 +15289,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; @@ -15844,6 +15883,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; @@ -15862,6 +15902,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; @@ -16032,6 +16073,8 @@ theorems := "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; @@ -16467,8 +16510,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; @@ -16724,6 +16770,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; @@ -17264,6 +17312,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/paths.ml b/Multivariate/paths.ml index e505c994..40de838e 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 <=> @@ -11619,7 +11500,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 +11509,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 +11528,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 +11541,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 +11571,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. diff --git a/Multivariate/topology.ml b/Multivariate/topology.ml index 30684109..058757a8 100644 --- a/Multivariate/topology.ml +++ b/Multivariate/topology.ml @@ -25252,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. *) From 3dbf53f2f9e2af8890b1335cc2eaf5efa1351856 Mon Sep 17 00:00:00 2001 From: John Harrison Date: Fri, 20 Feb 2026 05:56:39 +0000 Subject: [PATCH 17/79] 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. --- CHANGES | 58 ++- Multivariate/complex_database.ml | 39 ++ Multivariate/metric.ml | 544 +++++++++++++++++++++++++- Multivariate/multivariate_database.ml | 55 +++ Multivariate/realanalysis.ml | 5 +- 5 files changed, 695 insertions(+), 6 deletions(-) diff --git a/CHANGES b/CHANGES index d4e0baaa..bae20a46 100644 --- a/CHANGES +++ b/CHANGES @@ -8,6 +8,62 @@ * page: https://github.com/jrh13/hol-light/commits/master * * ***************************************************************** +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 @@ -67,7 +123,7 @@ 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 +theorems (CONNECTED_IMP_WELLCHAINED through CONNECTED_COMPONENT_EQ_WELLCHAINED) are similarly rederived. All theorem statements are preserved. diff --git a/Multivariate/complex_database.ml b/Multivariate/complex_database.ml index 67dc8fa4..100c49b6 100644 --- a/Multivariate/complex_database.ml +++ b/Multivariate/complex_database.ml @@ -1453,6 +1453,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; @@ -2175,6 +2196,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; @@ -2762,6 +2785,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; @@ -8571,6 +8595,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; @@ -13031,6 +13056,7 @@ theorems := "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; @@ -13438,6 +13464,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; @@ -14817,6 +14844,8 @@ theorems := "PCROSS_UNION",PCROSS_UNION; "PCROSS_UNIONS",PCROSS_UNIONS; "PCROSS_UNIONS_UNIONS",PCROSS_UNIONS_UNIONS; +"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; @@ -18783,6 +18812,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; @@ -19018,6 +19048,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; @@ -19054,6 +19085,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; @@ -19285,6 +19317,7 @@ 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; @@ -19941,6 +19974,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; @@ -20012,6 +20046,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; @@ -20720,6 +20758,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; diff --git a/Multivariate/metric.ml b/Multivariate/metric.ml index e115cf8e..655f20c9 100644 --- a/Multivariate/metric.ml +++ b/Multivariate/metric.ml @@ -21046,6 +21046,181 @@ 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]);; + +(* Bound on sum by comparison *) +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. *) (* ------------------------------------------------------------------------- *) @@ -32632,7 +32807,6 @@ let WELLCHAINED_INTERS = prove ASM_MESON_TAC[LT_IMP_LE; ARITH_RULE `i < n ==> SUC i <= n`]; ASM_REAL_ARITH_TAC]]]);; - (* ------------------------------------------------------------------------- *) (* Uniformly locally connected and Property S for metric spaces *) (* ------------------------------------------------------------------------- *) @@ -32675,7 +32849,6 @@ let fccoverable_in = new_definition mbounded m t /\ mdiameter m t <= e)`;; - (* ------------------------------------------------------------------------- *) (* Main theorems *) (* ------------------------------------------------------------------------- *) @@ -33240,7 +33413,6 @@ let COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE = prove STRIP_TAC THEN ASM_REWRITE_TAC[] THEN ASM_MESON_TAC[COMPACT_IN_IMP_MBOUNDED]]]);; - (* ------------------------------------------------------------------------- *) (* "Capped" equivalent bounded metrics and general product metrics. *) (* ------------------------------------------------------------------------- *) @@ -40558,6 +40730,372 @@ let ZERO_DIMENSIONAL_IMP_REGULAR_SPACE = prove 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]);; + (* ------------------------------------------------------------------------- *) (* Theorems from Kuratowski's "Remark on an Invariance Theorem", Fundamenta *) (* Mathematicae vol 37 (1950), pp. 251-252. The idea is that in suitable *) diff --git a/Multivariate/multivariate_database.ml b/Multivariate/multivariate_database.ml index 50c208a8..d6ad26b4 100644 --- a/Multivariate/multivariate_database.ml +++ b/Multivariate/multivariate_database.ml @@ -1182,6 +1182,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; @@ -1773,6 +1794,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; @@ -2334,6 +2357,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; @@ -7182,6 +7206,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; @@ -11261,6 +11286,7 @@ theorems := "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; @@ -11648,6 +11674,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; @@ -12914,6 +12941,8 @@ theorems := "PCROSS_UNION",PCROSS_UNION; "PCROSS_UNIONS",PCROSS_UNIONS; "PCROSS_UNIONS_UNIONS",PCROSS_UNIONS_UNIONS; +"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; @@ -13588,6 +13617,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; @@ -14067,6 +14102,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; @@ -14121,6 +14158,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; @@ -15612,6 +15653,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; @@ -15813,6 +15855,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; @@ -15848,6 +15891,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; @@ -16069,6 +16113,7 @@ 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; @@ -16612,6 +16657,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; @@ -16671,6 +16717,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; @@ -17169,6 +17219,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; @@ -17188,7 +17239,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; @@ -17289,6 +17343,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; 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`;; From c31563b852044a020abf505b7147f016eadb3193 Mon Sep 17 00:00:00 2001 From: John Harrison Date: Sun, 22 Feb 2026 00:48:26 +0000 Subject: [PATCH 18/79] 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. This is another of the "Formalizing 100 Theorems" list. 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. This formalization in HOL Light was almost entirely written by Claude Code (Opus 4.6). I provided the statements and a couple of initial lemmas, which in particular direct it to an explicit formulation using the "division_of" notion from Kurzweil-Henstock integration. --- 100/cubedissection.ml | 1612 +++++++++++++++++++++++++++++++++++++++++ CHANGES | 11 + holtest.mk | 1 + 3 files changed, 1624 insertions(+) create mode 100644 100/cubedissection.ml 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 bae20a46..c68a28a3 100644 --- a/CHANGES +++ b/CHANGES @@ -8,6 +8,17 @@ * page: https://github.com/jrh13/hol-light/commits/master * * ***************************************************************** +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 diff --git a/holtest.mk b/holtest.mk index cca83dc6..042763f1 100644 --- a/holtest.mk +++ b/holtest.mk @@ -135,6 +135,7 @@ GREAT_100_THEOREMS:= \ 100/combinations \ 100/constructible \ 100/cosine \ + 100/cubedissection \ 100/cubic \ 100/derangements \ 100/desargues \ From 955caa3ec354982102c75b543216fa1a686aa82c Mon Sep 17 00:00:00 2001 From: John Harrison Date: Thu, 26 Feb 2026 08:36:36 +0000 Subject: [PATCH 19/79] Added 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. --- CHANGES | 48 ++ Library/fieldtheory.ml | 1380 ++++++++++++++++++++++++++++++++++++++++ Library/ringtheory.ml | 368 +++++++++++ 3 files changed, 1796 insertions(+) diff --git a/CHANGES b/CHANGES index c68a28a3..d4a1b919 100644 --- a/CHANGES +++ b/CHANGES @@ -8,6 +8,54 @@ * page: https://github.com/jrh13/hol-light/commits/master * * ***************************************************************** +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 diff --git a/Library/fieldtheory.ml b/Library/fieldtheory.ml index a71126f1..e360c9f5 100644 --- a/Library/fieldtheory.ml +++ b/Library/fieldtheory.ml @@ -5609,3 +5609,1383 @@ let FINITELY_GENERATED_EXTENSION_TRANS_EQ = prove RULE_ASSUM_TAC(REWRITE_RULE [field_extension; ring_monomorphism; ring_homomorphism]) THEN ASM SET_TAC[]);; + +(* ------------------------------------------------------------------------- *) +(* Algebraically closed fields and algebraic closures. *) +(* ------------------------------------------------------------------------- *) + +let algebraically_closed_field = new_definition + `algebraically_closed_field(k:A ring) <=> + 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/ringtheory.ml b/Library/ringtheory.ml index a81a3d68..ad23e5e6 100644 --- a/Library/ringtheory.ml +++ b/Library/ringtheory.ml @@ -6844,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. *) (* ------------------------------------------------------------------------- *) @@ -11540,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 *) (* ------------------------------------------------------------------------- *) @@ -16666,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) <=> @@ -17460,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 /\ @@ -20312,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 @@ -20452,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 @@ -20730,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. *) (* ------------------------------------------------------------------------- *) @@ -21100,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)) @@ -21169,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 /\ @@ -21230,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. *) (* ------------------------------------------------------------------------- *) @@ -21457,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. *) (* ------------------------------------------------------------------------- *) From d9a37c8a3e82196280ce27089b9af8b9ea2710b9 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 27 Feb 2026 10:10:31 +0800 Subject: [PATCH 20/79] Cleaning up metis (#152) * metis.ml: Apply bugfixes from upstream metis repo gilith/metis@d17c3a8cf6537212c5c4bfdadcf865bd25723132 * metis.ml: Inline Portable.pointerEqual * metis.ml: Replace Option module with OCaml's version * metis.ml: Inline Portable.randomInt * metis.ml: Inline Portable.randomWord * metis.ml: Inline definitions in Math module * metis.ml: Inline Int.toString and Int.div * metis.ml: Remove unused combinators + Replace with version in lib.ml * metis.ml: Remove funpow redefinition This will use the implementation in lib.ml, which is slightly different. In particular, it seems that the original implementation in metis.ml would not terminate for n < 0. * metis.ml: Remove unused Useful.swap * metis.ml: Remove redefinition of curry and uncurry Already in lib.ml * metis.ml: Remove Useful.length and inline Useful.app * metis.ml: Inline Int.maxInt and remove arbitrary precision case Affected function: multInt * metis.ml: Replace exception Error with Failure * metis.ml: Replace exception Subscript with Invalid_argument * metis.ml: Replace zipWith, zip and unzip with lib.ml versions * metis.ml: Inline mem * metis.ml: Add mapi to lib.ml and simplify enumerate * metis.ml: Use List.rev_append instead of Mlist.revAppend * metis.ml: Inline Mlist.all * metis.ml: Replace Mlist.nth with List.nth * metis.ml: Inline Real.floor * metis.ml: Inline Real.fromInt * metis.ml: Replace {foo=foo} pattern matching with {foo} * metis.ml: Remove Order module In particular, instead of defining the order type, we use the OCaml convention of using integers. I think this patch actually makes the code a bit more robust: orderOfInt (and thus toCompare by extension) would fail if the compare function returned something other than -1/0/+1, which Repr.compare doesn't seem to exclude. The applied patch was generated by Claude Code. * metis.ml: Remove Int and Real module * metis.ml: Replace boolCompare with Bool.compare * metis.ml: Copy comment for Portable.critical from upstream Source: gilith/metis/src/Portable.sig * metis.ml: Use Int.compare directly in Word * metis.ml: Qualify Useful usages, remove unused defs + inline sort This should make it easier to tell whether something comes from Useful or not, as the definitions are defined are quite general. Hopefully, it also makes future refactors easier that want to move things out of Useful. * metis.ml: Move list functions from Useful to Mlist * metis.ml: Move Portable.critical to Useful.critical * metis.ml: Inline Sharing module --- lib.ml | 6 + metis.ml | 1704 ++++++++++++++++++++++-------------------------------- 2 files changed, 701 insertions(+), 1009 deletions(-) diff --git a/lib.ml b/lib.ml index a3aea404..66c9a636 100755 --- a/lib.ml +++ b/lib.ml @@ -80,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. *) (* ------------------------------------------------------------------------- *) diff --git a/metis.ml b/metis.ml index e9d38fa9..14f3eb64 100644 --- a/metis.ml +++ b/metis.ml @@ -22,94 +22,14 @@ let metisverb = ref false;; module Metis_prover = struct -(* ------------------------------------------------------------------------- *) -(* Convenient utility modules. *) -(* ------------------------------------------------------------------------- *) - -module Portable = struct - -let pointerEqual (p1, p2) = p1 == p2;; - -let randomInt x = Random.int x;; -let randomWord () = Random.bits ();; - -let critical x = x;; - -end - -module Option = struct - -let getOpt = function - (Some s, _) -> s - | (None, x) -> x;; - -let isSome = function - Some _ -> true - | None -> false;; - -let mapPartial f = function - None -> None - | Some x -> f x;; - -end - -module Order = struct - -type order = Less | Equal | Greater;; - -let orderOfInt = function - -1 -> Less - | 0 -> Equal - | 1 -> Greater - | _ -> failwith "orderOfInt" -;; - -let intOfOrder = function - Less -> -1 - | Equal -> 0 - | Greater -> 1 -;; - -let toCompare f = fun (x, y) -> orderOfInt (f x y);; -let fromCompare f = fun x y -> intOfOrder (f (x, y));; - -end - -module Int = struct - -let toString = string_of_int;; - -let compare = Order.toCompare (compare : int -> int -> int);; - -let maxInt = Some max_int;; - -let div x y = x / y;; - -end - -module Real = struct - -open Order - -type real = float;; - -let compare = toCompare (compare : float -> float -> int);; - -let fromInt = float_of_int;; -let floor x = int_of_float (floor x);; - -end - (* ------------------------------------------------------------------------- *) (* Emulating SML Word type (which is unsigned) and other operations. *) (* ------------------------------------------------------------------------- *) module Word = struct -open Order - type word = int;; -let compare = toCompare (compare: word -> word -> int);; +let compare x y = Int.compare x y;; let shiftLeft (x, y) = x lsl y;; let shiftRight (x, y) = x lsr y;; @@ -127,27 +47,44 @@ let fromInt x = x;; end -module Math = struct - -let ln = log;; -let pow (x,y) = x ** y;; - -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 nth (l, i) = List.nth l i;; 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 revAppend (l1, l2) = List.rev_append l1 l2;; let find p l = try Some (List.find p l) with Not_found -> None;; -let all = List.for_all;; +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 @@ -157,14 +94,8 @@ end module Useful = struct -open Order - -(* ------------------------------------------------------------------------- *) -(* OCaml lists (MF). *) -(* ------------------------------------------------------------------------- *) - -let length = List.length;; -let app = List.iter;; +(* Marking critical sections of code. *) +let critical x = x;; (* ------------------------------------------------------------------------- *) (* Characters (MF). *) @@ -176,161 +107,35 @@ let isDigit c = '0' <= c && c <= '9' (* Exceptions. *) (* ------------------------------------------------------------------------- *) -exception Error of string;; - exception Bug of string;; -exception Subscript;; - -let total f x = try Some (f x) with Error _ -> None;; - -let isSome = function - (Some _) -> true - | None -> false -;; - -let can f x = isSome (total f x);; - -(* ------------------------------------------------------------------------- *) -(* Combinators. *) -(* ------------------------------------------------------------------------- *) - -let cComb f x y = f y x;; - -let iComb x = x;; - -let kComb x y = x;; - -let sComb f g x = f x (g x);; - -let wComb f x = f x x;; - -let rec funpow n f x = match n with - 0 -> x - | _ -> funpow (n - 1) f (f x);; +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)) (Int.div y 2) (if y mod 2 = 0 then z else m (z,x)) + | _ -> f (m (x,x)) (y / 2) (if y mod 2 = 0 then z else m (z,x)) in f ;; -(* ------------------------------------------------------------------------- *) -(* Pairs. *) -(* ------------------------------------------------------------------------- *) - -let pair x y = (x,y);; - -let swap (x,y) = (y,x);; - -let curry f x y = f (x,y);; - -let uncurry f (x,y) = f x y;; - -(* ------------------------------------------------------------------------- *) -(* State transformers. *) -(* ------------------------------------------------------------------------- *) - -let return : 'a -> 's -> 'a * 's = pair;; - -let bind f (g : 'a -> 's -> 'b * 's) x = uncurry g (f x);; - -(*fun mmap f (m : 's -> 'a * 's) = bind m (unit o f); - -fun mjoin (f : 's -> ('s -> 'a * 's) * 's) = bind f I; - -fun mwhile c b = let fun f a = if c a then bind (b a) f else unit a in f end;*) - (* ------------------------------------------------------------------------- *) (* Comparisons. *) (* ------------------------------------------------------------------------- *) -let revCompare cmp x_y = - match cmp x_y with Less -> Greater | Equal -> Equal | Greater -> Less;; +let revCompare cmp x y = cmp y x;; -let prodCompare xCmp yCmp ((x1,y1),(x2,y2)) = - match xCmp (x1,x2) with - Less -> Less - | Equal -> yCmp (y1,y2) - | Greater -> Greater;; +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 = function - ([],[]) -> Equal - | ([], _ :: _) -> Less - | (_ :: _, []) -> Greater + let rec lex xs ys = match (xs, ys) with + ([],[]) -> 0 + | ([], _ :: _) -> -1 + | (_ :: _, []) -> 1 | (x :: xs, y :: ys) -> - (match cmp (x,y) with - Less -> Less - | Equal -> lex (xs,ys) - | Greater -> Greater) - in - lex - ;; - -let boolCompare = function - (false,true) -> Less - | (true,false) -> Greater - | _ -> Equal;; - -(* ------------------------------------------------------------------------- *) -(* Lists. *) -(* ------------------------------------------------------------------------- *) - -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)) - ;; - -let zip xs ys = zipWith pair xs ys;; - -let unzip ab = - let inc ((x,y),(xs,ys)) = (x :: xs, y :: ys) - in Mlist.foldl inc ([],[]) (List.rev ab);; - -let enumerate l = fst (maps (fun x m -> ((m, x), m + 1)) l 0);; - -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);; - -let divide l n = let (a,b) = revDivide l n in (List.rev a, b);; - -let updateNth (n,x) l = - let (a,b) = revDivide l n - in - match b with [] -> raise Subscript | (_ :: t) -> List.rev_append a (x :: t) -;; - -let deleteNth n l = - let (a,b) = revDivide l n - in - match b with [] -> raise Subscript | (_ :: t) -> List.rev_append a t -;; - -(* ------------------------------------------------------------------------- *) -(* Sets implemented with lists. *) -(* ------------------------------------------------------------------------- *) - -let mem x l = List.mem x l;; + let c = cmp x y in if c <> 0 then c else lex xs ys + in lex;; (* ------------------------------------------------------------------------- *) (* Strings. *) @@ -345,23 +150,6 @@ let stripSuffix pred s = else String.sub s 0 (pos + 1) in strip (String.length s - 1);; -(* ------------------------------------------------------------------------- *) -(* Sorting and searching. *) -(* ------------------------------------------------------------------------- *) - -let sort cmp = List.sort (fromCompare cmp);; - -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 (fromCompare ncmp) nxs - in - List.map snd nys - ;; - (* ------------------------------------------------------------------------- *) (* Integers. *) (* ------------------------------------------------------------------------- *) @@ -410,29 +198,11 @@ end module Pmap = struct -open Order - -(* ------------------------------------------------------------------------- *) -(* Importing useful functionality. *) -(* ------------------------------------------------------------------------- *) - -exception Bug = Useful.Bug;; - -exception Error = Useful.Error;; - -let pointerEqual = Portable.pointerEqual;; - -let kComb = Useful.kComb;; - -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;; +let equalKey compareKey key1 key2 = compareKey key1 key2 = 0;; (* ------------------------------------------------------------------------- *) (* Priorities. *) @@ -440,7 +210,7 @@ let equalKey compareKey key1 key2 = compareKey (key1,key2) = Equal;; type priority = Word.word;; -let randomPriority = randomWord;; +let randomPriority = Random.bits;; let comparePriority = Word.compare;; @@ -464,7 +234,7 @@ let lowerPriorityNode node1 node2 = let {priority = p1} = node1 and {priority = p2} = node2 in - comparePriority (p1,p2) = Less + comparePriority p1 p2 < 0 ;; (* ------------------------------------------------------------------------- *) @@ -481,7 +251,7 @@ local let l = checkSizes left and r = checkSizes right - let () = if l + 1 + r = size then () else raise Bug "wrong size" + let () = if l + 1 + r = size then () else raise Useful.Bug "wrong size" in size end;; @@ -497,10 +267,10 @@ local match x with None -> () | Some k -> - match compareKey (k,key) with - Less -> () - | Equal -> raise Bug "duplicate keys" - | Greater -> raise Bug "unsorted" + 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 @@ -519,14 +289,14 @@ local None -> () | Some lnode -> if not (lowerPriorityNode node lnode) then () - else raise Bug "left child has greater priority" + 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 Bug "right child has greater priority" + else raise Useful.Bug "right child has greater priority" in Some node end;; @@ -541,7 +311,7 @@ in in tree end - handle Error err -> raise (Bug err);; + handle Failure err -> raise (Useful.Bug err);; end;; *) @@ -585,7 +355,7 @@ let rec treeLeftSpine acc tree = | Tree node -> nodeLeftSpine acc node and nodeLeftSpine acc node = - let {left=left} = node + let {left} = node in treeLeftSpine (node :: acc) left ;; @@ -596,7 +366,7 @@ let rec treeRightSpine acc tree = | Tree node -> nodeRightSpine acc node and nodeRightSpine acc node = - let {right=right} = node + let {right} = node in treeRightSpine (node :: acc) right ;; @@ -643,13 +413,13 @@ let rec treeAppend tree1 tree2 = Empty -> tree1 | Tree node2 -> if lowerPriorityNode node1 node2 then - let {priority=priority;left=left;key=key;value=value;right=right} = node2 + let {priority;left;key;value;right} = node2 in let left = treeAppend tree1 left in mkTree priority left key value right else - let {priority=priority;left=left;key=key;value=value;right=right} = node1 + let {priority;left;key;value;right} = node1 in let right = treeAppend right tree2 in @@ -678,12 +448,12 @@ let rec treePeek compareKey pkey tree = | Tree node -> nodePeek compareKey pkey node and nodePeek compareKey pkey node = - let {left=left;key=key;value=value;right=right} = node + let {left;key;value;right} = node in - match compareKey (pkey,key) with - Less -> treePeek compareKey pkey left - | Equal -> Some value - | Greater -> treePeek compareKey pkey right + 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 ;; (* ------------------------------------------------------------------------- *) @@ -698,18 +468,18 @@ let rec treePeekPath compareKey pkey path tree = | Tree node -> nodePeekPath compareKey pkey path node and nodePeekPath compareKey pkey path node = - let {left=left;key=key;right=right} = node + let {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 + 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 {priority=priority;left=left;key=key;value=value;right=right} = node + let {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) @@ -722,7 +492,7 @@ let mkSidesPath path = addSidesPath (Empty,Empty) path;; (* Updating the subtree at a path *) let updateTree ((wentLeft,node),tree) = - let {priority=priority;left=left;key=key;value=value;right=right} = node + let {priority;left;key;value;right} = node in if wentLeft then mkTree priority tree key value right else mkTree priority left key value tree;; @@ -767,7 +537,7 @@ let nodePartition compareKey pkey node = in (left,None,right) | Some node -> - let {left=left;key=key;value=value;right=right} = node + let {left;key;value;right} = node in let (left,right) = addSidesPath (left,right) path in @@ -784,12 +554,12 @@ let rec treePeekKey compareKey pkey tree = | Tree node -> nodePeekKey compareKey pkey node and nodePeekKey compareKey pkey node = - let {left=left;key=key;value=value;right=right} = node + let {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 + 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 ;; (* ------------------------------------------------------------------------- *) @@ -807,7 +577,7 @@ let treeInsert compareKey key_value tree = in insertNodePath node path | Some node -> - let {size=size;priority=priority;left=left;right=right} = node + let {size;priority;left;right} = node in let node = {size = size; @@ -827,14 +597,14 @@ let treeInsert compareKey key_value tree = let rec treeDelete compareKey dkey tree = match tree with - Empty -> raise (Bug "Map.delete: element not found") + Empty -> raise (Useful.Bug "Map.delete: element not found") | Tree node -> nodeDelete compareKey dkey node and nodeDelete compareKey dkey node = - let {size=size;priority=priority;left=left;key=key;value=value;right=right} = node + let {size;priority;left;key;value;right} = node in - match compareKey (dkey,key) with - Less -> + let c = compareKey dkey key in + if c < 0 then let size = size - 1 and left = treeDelete compareKey dkey left @@ -847,8 +617,8 @@ and nodeDelete compareKey dkey node = right = right} in Tree node - | Equal -> treeAppend left right - | Greater -> + else if c = 0 then treeAppend left right + else let size = size - 1 and right = treeDelete compareKey dkey right @@ -873,7 +643,7 @@ let rec treeMapPartial f tree = Empty -> Empty | Tree node -> nodeMapPartial f node -and nodeMapPartial f ({priority=priority;left=left;key=key;value=value;right=right}) = +and nodeMapPartial f ({priority;left;key;value;right}) = let left = treeMapPartial f left and vo = f (key,value) and right = treeMapPartial f right @@ -893,7 +663,7 @@ let rec treeMap f tree = | Tree node -> Tree (nodeMap f node) and nodeMap f node = - let {size=size;priority=priority;left=left;key=key;value=value;right=right} = node + let {size;priority;left;key;value;right} = node in let left = treeMap f left and value = f (key,value) @@ -921,7 +691,7 @@ let rec treeMerge compareKey f1 f2 fb tree1 tree2 = | Tree node2 -> nodeMerge compareKey f1 f2 fb node1 node2 and nodeMerge compareKey f1 f2 fb node1 node2 = - let {priority=priority;left=left;key=key;value=value;right=right} = node2 + let {priority;left;key;value;right} = node2 in let (l,kvo,r) = nodePartition compareKey key node1 @@ -954,9 +724,9 @@ let rec treeUnion compareKey f f2 tree1 tree2 = | Tree node2 -> nodeUnion compareKey f f2 node1 node2 and nodeUnion compareKey f f2 node1 node2 = - if pointerEqual (node1,node2) then nodeMapPartial f2 node1 + if node1 == node2 then nodeMapPartial f2 node1 else - let {priority=priority;left=left;key=key;value=value;right=right} = node2 + let {priority;left;key;value;right} = node2 in let (l,kvo,r) = nodePartition compareKey key node1 @@ -989,7 +759,7 @@ let rec treeIntersect compareKey f t1 t2 = | Tree n2 -> nodeIntersect compareKey f n1 n2 and nodeIntersect compareKey f n1 n2 = - let {priority=priority;left=left;key=key;value=value;right=right} = n2 + let {priority;left;key;value;right} = n2 in let (l,kvo,r) = nodePartition compareKey key n1 @@ -1017,11 +787,11 @@ let rec treeUnionDomain compareKey tree1 tree2 = match tree2 with Empty -> tree1 | Tree node2 -> - if pointerEqual (node1,node2) then tree2 + if node1 == node2 then tree2 else nodeUnionDomain compareKey node1 node2 and nodeUnionDomain compareKey node1 node2 = - let {priority=priority;left=left;key=key;value=value;right=right} = node2 + let {priority;left;key;value;right} = node2 in let (l,_,r) = nodePartition compareKey key node1 @@ -1044,18 +814,18 @@ let rec treeIntersectDomain compareKey tree1 tree2 = match tree2 with Empty -> Empty | Tree node2 -> - if pointerEqual (node1,node2) then tree2 + if node1 == node2 then tree2 else nodeIntersectDomain compareKey node1 node2 and nodeIntersectDomain compareKey node1 node2 = - let {priority=priority;left=left;key=key;value=value;right=right} = node2 + let {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 + if Option.is_some kvo then mkTree priority left key value right else treeAppend left right ;; @@ -1072,16 +842,16 @@ let rec treeDifferenceDomain compareKey t1 t2 = | Tree n2 -> nodeDifferenceDomain compareKey n1 n2 and nodeDifferenceDomain compareKey n1 n2 = - if pointerEqual (n1,n2) then Empty + if n1 == n2 then Empty else - let {priority=priority;left=left;key=key;value=value;right=right} = n1 + let {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 + if Option.is_some kvo then treeAppend left right else mkTree priority left key value right ;; @@ -1098,13 +868,13 @@ let rec treeSubsetDomain compareKey tree1 tree2 = | Tree node2 -> nodeSubsetDomain compareKey node1 node2 and nodeSubsetDomain compareKey node1 node2 = - pointerEqual (node1,node2) || - let {size=size;left=left;key=key;right=right} = node1 + node1 == node2 || + let {size;left;key;right} = node1 in size <= nodeSize node2 && let (l,kvo,r) = nodePartition compareKey key node2 in - Option.isSome kvo && + Option.is_some kvo && treeSubsetDomain compareKey left l && treeSubsetDomain compareKey right r ;; @@ -1114,14 +884,14 @@ and nodeSubsetDomain compareKey node1 node2 = (* ------------------------------------------------------------------------- *) let rec nodePick node = - let {key=key;value=value} = node + let {key;value} = node in (key,value) ;; let treePick tree = match tree with - Empty -> raise (Bug "Map.treePick") + Empty -> raise (Useful.Bug "Map.treePick") | Tree node -> nodePick node;; (* ------------------------------------------------------------------------- *) @@ -1129,14 +899,14 @@ let treePick tree = (* ------------------------------------------------------------------------- *) let rec nodeDeletePick node = - let {left=left;key=key;value=value;right=right} = node + let {left;key;value;right} = node in ((key,value), treeAppend left right) ;; let treeDeletePick tree = match tree with - Empty -> raise (Bug "Map.treeDeletePick") + Empty -> raise (Useful.Bug "Map.treeDeletePick") | Tree node -> nodeDeletePick node;; (* ------------------------------------------------------------------------- *) @@ -1145,11 +915,11 @@ let treeDeletePick tree = let rec treeNth n tree = match tree with - Empty -> raise (Bug "Map.treeNth") + Empty -> raise (Useful.Bug "Map.treeNth") | Tree node -> nodeNth n node and nodeNth n node = - let {left=left;key=key;value=value;right=right} = node + let {left;key;value;right} = node in let k = treeSize left in @@ -1164,11 +934,11 @@ and nodeNth n node = let rec treeDeleteNth n tree = match tree with - Empty -> raise (Bug "Map.treeDeleteNth") + Empty -> raise (Useful.Bug "Map.treeDeleteNth") | Tree node -> nodeDeleteNth n node and nodeDeleteNth n node = - let {size=size;priority=priority;left=left;key=key;value=value;right=right} = node + let {size;priority;left;key;value;right} = node in let k = treeSize left in @@ -1218,13 +988,13 @@ type ('key,'value) iterator = let fromSpineLeftToRightIterator nodes = match nodes with [] -> None - | {key=key;value=value;right=right} :: nodes -> + | {key;value;right} :: nodes -> Some (Left_to_right_iterator ((key,value),right,nodes));; let fromSpineRightToLeftIterator nodes = match nodes with [] -> None - | {key=key;value=value;left=left} :: nodes -> + | {key;value;left} :: nodes -> Some (Right_to_left_iterator ((key,value),left,nodes));; let addLeftToRightIterator nodes tree = fromSpineLeftToRightIterator (treeLeftSpine nodes tree);; @@ -1277,25 +1047,23 @@ let rec firstIterator f io = let rec compareIterator compareKey compareValue io1 io2 = match (io1,io2) with - (None,None) -> Equal - | (None, Some _) -> Less - | (Some _, None) -> Greater + (None,None) -> 0 + | (None, Some _) -> -1 + | (Some _, None) -> 1 | (Some i1, Some i2) -> let (k1,v1) = readIterator i1 and (k2,v2) = readIterator i2 in - match compareKey (k1,k2) with - Less -> Less - | Equal -> - (match compareValue (v1,v2) with - Less -> Less - | Equal -> + 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 - | Greater -> Greater) - | Greater -> Greater ;; let rec equalIterator equalKey equalValue io1 io2 = @@ -1320,7 +1088,7 @@ let rec equalIterator equalKey equalValue io1 io2 = (* ------------------------------------------------------------------------- *) type ('key,'value) map = - Map of ('key * 'key -> order) * ('key,'value) tree;; + Map of ('key -> 'key -> int) * ('key,'value) tree;; (* ------------------------------------------------------------------------- *) (* Map debugging functions. *) @@ -1335,7 +1103,7 @@ let checkInvariants s m = in m end - handle Bug bug -> raise (Bug (s ^ "\n" ^ "Map.checkInvariants: " ^ bug));; + handle Useful.Bug bug -> raise (Useful.Bug (s ^ "\n" ^ "Map.checkInvariants: " ^ bug));; *) (* ------------------------------------------------------------------------- *) @@ -1370,11 +1138,11 @@ 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 inDomain key m = Option.is_some (peek m key);; let get m key = match peek m key with - None -> raise (Error "Map.get: element not found") + None -> failwith "Map.get: element not found" | Some value -> value;; let pick (Map (_,tree)) = treePick tree;; @@ -1384,8 +1152,8 @@ 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) + if n = 0 then raise (Useful.Bug "Map.random: empty") + else nth m (Random.int n) ;; (* ------------------------------------------------------------------------- *) @@ -1461,8 +1229,8 @@ let deleteNth = fun m -> fun n -> let deleteRandom m = let n = size m in - if n = 0 then raise (Bug "Map.deleteRandom: empty") - else deleteNth m (randomInt n) + if n = 0 then raise (Useful.Bug "Map.deleteRandom: empty") + else deleteNth m (Random.int n) ;; (* ------------------------------------------------------------------------- *) @@ -1582,7 +1350,7 @@ 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 exists p m = Option.is_some (findl p m);; let all p = let np x = not (p x) @@ -1600,22 +1368,22 @@ let count pred = (* Comparing. *) (* ------------------------------------------------------------------------- *) -let compare compareValue (m1,m2) = - if pointerEqual (m1,m2) then Equal +let compare compareValue m1 m2 = + if m1 == m2 then 0 else - match Int.compare (size m1, size m2) with - Less -> Less - | Equal -> + let c = Int.compare (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 - | Greater -> Greater;; + ;; let equal equalValue m1 m2 = - pointerEqual (m1,m2) || + m1 == m2 || (size m1 = size m2 && let Map (compareKey,_) = m1 @@ -1646,7 +1414,7 @@ let unionDomain = fun m1 -> fun m2 -> let uncurriedUnionDomain (m,acc) = unionDomain acc m;; let unionListDomain ms = match ms with - [] -> raise (Bug "Map.unionListDomain: no sets") + [] -> raise (Useful.Bug "Map.unionListDomain: no sets") | m :: ms -> Mlist.foldl uncurriedUnionDomain m ms;; let intersectDomain (Map (compareKey,tree1)) (Map (_,tree2)) = @@ -1666,7 +1434,7 @@ let intersectDomain = fun m1 -> fun m2 -> let uncurriedIntersectDomain (m,acc) = intersectDomain acc m;; let intersectListDomain ms = match ms with - [] -> raise (Bug "Map.intersectListDomain: no sets") + [] -> raise (Useful.Bug "Map.intersectListDomain: no sets") | m :: ms -> Mlist.foldl uncurriedIntersectDomain m ms;; let differenceDomain (Map (compareKey,tree1)) (Map (_,tree2)) = @@ -1686,7 +1454,7 @@ let differenceDomain = fun m1 -> fun m2 -> let symmetricDifferenceDomain m1 m2 = unionDomain (differenceDomain m1 m2) (differenceDomain m2 m1);; -let equalDomain m1 m2 = equal (kComb (kComb true)) m1 m2;; +let equalDomain m1 m2 = equal (K (K true)) m1 m2;; let subsetDomain (Map (compareKey,tree1)) (Map (_,tree2)) = treeSubsetDomain compareKey tree1 tree2;; @@ -1713,7 +1481,7 @@ let fromList compareKey l = (* Pretty-printing. *) (* ------------------------------------------------------------------------- *) -let toString m = "<" ^ (if null m then "" else Int.toString (size m)) ^ ">";; +let toString m = "<" ^ (if null m then "" else string_of_int (size m)) ^ ">";; end @@ -1727,8 +1495,6 @@ end module Pset = struct -open Order - (* ------------------------------------------------------------------------- *) (* A type of finite sets. *) (* ------------------------------------------------------------------------- *) @@ -1968,11 +1734,11 @@ let count p = (* Comparing. *) (* ------------------------------------------------------------------------- *) -let compareValue ((),()) = Equal;; +let compareValue () () = 0;; let equalValue () () = true;; -let compare (Set m1, Set m2) = Pmap.compare compareValue (m1,m2);; +let compare (Set m1) (Set m2) = Pmap.compare compareValue m1 m2;; let equal (Set m1) (Set m2) = Pmap.equal equalValue m1 m2;; @@ -1999,7 +1765,7 @@ let fromList cmp elts = addList (empty cmp) elts;; (* ------------------------------------------------------------------------- *) let toString set = - "{" ^ (if null set then "" else Int.toString (size set)) ^ "}";; + "{" ^ (if null set then "" else string_of_int (size set)) ^ "}";; (* ------------------------------------------------------------------------- *) (* Iterators over sets *) @@ -2028,8 +1794,6 @@ end module Mmap = struct -exception Error = Useful.Error;; - module type Ordered = sig type t @@ -2046,7 +1810,7 @@ struct let null = Ma.is_empty;; let singleton (k, x) = Ma.singleton k x;; let size = Ma.cardinal;; - let get m k = try Ma.find k m with Not_found -> raise (Error "Mmap.get: element not found");; + let get m k = try Ma.find k m with Not_found -> failwith "Mmap.get: element not found";; let peek m k = try Some (Ma.find k m) with Not_found -> None;; let insert m (k, v) = Ma.add k v m;; let toList = Ma.bindings;; @@ -2072,8 +1836,6 @@ end module Intmap = struct -open Order - module Ordered = struct type t = int let compare = compare end include Mmap.Make (Ordered);; @@ -2082,8 +1844,6 @@ end module Stringmap = struct -open Order - module Ordered = struct type t = string let compare = compare end include Mmap.Make (Ordered);; @@ -2103,7 +1863,7 @@ struct module Se = Set.Make (Ord) type set = Se.t;; - let compare = Order.toCompare Se.compare;; + let compare = Se.compare;; let add s x = Se.add x s;; let foldr f a s = Se.fold (fun x acc -> f (x,acc)) s a;; @@ -2146,8 +1906,6 @@ end module Intset = struct -open Order - module Ordered = struct type t = int let compare = compare end include Mset.Make (Ordered);; @@ -2155,11 +1913,6 @@ include Mset.Make (Ordered);; end -module Sharing = struct - -let map = List.map;; -end - (* ========================================================================= *) (* A HEAP DATATYPE FOR ML *) (* ========================================================================= *) @@ -2168,13 +1921,11 @@ module Heap = struct (* Leftist heaps as in Purely Functional Data Structures, by Chris Okasaki *) -open Order - exception Empty;; type 'a node = Em | Tr of int * 'a * 'a node * 'a node;; -type 'a heap = Heap of ('a * 'a -> order) * int * 'a node;; +type 'a heap = Heap of ('a -> 'a -> int) * int * 'a node;; let rank = function Em -> 0 @@ -2188,9 +1939,8 @@ let merge cmp = (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)) + if cmp x y > 0 then makeT (y, a2, mrg (h1,b2)) + else makeT (x, a1, mrg (b1,h2)) in mrg ;; @@ -2229,7 +1979,7 @@ let rec toList h = ;; let toString h = - "Heap[" ^ (if null h then "" else Int.toString (size h)) ^ "]";; + "Heap[" ^ (if null h then "" else string_of_int (size h)) ^ "]";; end @@ -2239,8 +1989,6 @@ end module Name = struct -open Useful;; - (* ------------------------------------------------------------------------- *) (* A type of names. *) (* ------------------------------------------------------------------------- *) @@ -2251,7 +1999,7 @@ type name = string;; (* A total ordering. *) (* ------------------------------------------------------------------------- *) -let compare = Order.toCompare (compare : name -> name -> int);; +let compare = (compare : name -> name -> int);; let equal n1 n2 = n1 = n2;; @@ -2260,21 +2008,21 @@ let equal n1 n2 = n1 = n2;; (* ------------------------------------------------------------------------- *) let prefix = "_";; -let numName i = mkPrefix prefix (Int.toString i);; -let newName () = numName (newInt ());; -let newNames n = List.map numName (newInts n);; +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 = '\'' || isDigit c + let isDigitOrPrime c = c = '\'' || Useful.isDigit c in if not (avoid n) then n else - let n = stripSuffix isDigitOrPrime n in + let n = Useful.stripSuffix isDigitOrPrime n in let rec variant i = - let n_i = n ^ Int.toString i + let n_i = n ^ string_of_int i in if avoid n_i then variant (i + 1) else n_i in variant 0 ;; @@ -2288,7 +2036,7 @@ let toString s : string = s;; let fromString s : name = s;; module Ordered = -struct type t = name let compare = Order.fromCompare compare end +struct type t = name let compare = compare end module Map = Mmap.Make (Ordered);; module Set = Mset.Make (Ordered);; @@ -2301,9 +2049,6 @@ end module Name_arity = struct -open Useful;; -open Order - (* ------------------------------------------------------------------------- *) (* A type of name/arity pairs. *) (* ------------------------------------------------------------------------- *) @@ -2329,17 +2074,15 @@ 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 compare (n1,i1) (n2,i2) = + let c = Name.compare n1 n2 in + if c <> 0 then c else Int.compare i1 i2;; let equal (n1,i1) (n2,i2) = i1 = i2 && Name.equal n1 n2;; module Ordered = -struct type t = nameArity let compare = fromCompare compare end +struct type t = nameArity let compare = compare end module Map = struct include Mmap.Make (Ordered) @@ -2365,9 +2108,6 @@ end module Term = struct -open Useful -open Order - (* ------------------------------------------------------------------------- *) (* A type of first order logic terms. *) (* ------------------------------------------------------------------------- *) @@ -2392,7 +2132,7 @@ type term = let destVar = function (Var v) -> v - | (Fn _) -> raise (Error "destVar");; + | (Fn _) -> failwith "destVar";; let isVar = can destVar;; @@ -2404,7 +2144,7 @@ let equalVar v = function let destFn = function (Fn f) -> f - | (Var _) -> raise (Error "destFn");; + | (Var _) -> failwith "destFn";; let isFn = can destFn;; @@ -2437,7 +2177,7 @@ let mkConst c = (Fn (c, []));; let destConst = function (Fn (c, [])) -> c - | _ -> raise (Error "destConst");; + | _ -> failwith "destConst";; let isConst = can destConst;; @@ -2447,8 +2187,8 @@ 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");; + 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);; @@ -2471,35 +2211,28 @@ let symbols tm = (* A total comparison function for terms. *) (* ------------------------------------------------------------------------- *) -let compare (tm1,tm2) = +let compare tm1 tm2 = let rec cmp = function - ([], []) -> Equal + ([], []) -> 0 | (tm1 :: tms1, tm2 :: tms2) -> - let tm1_tm2 = (tm1,tm2) - in - if Portable.pointerEqual tm1_tm2 then cmp (tms1, tms2) + if tm1 == tm2 then cmp (tms1, tms2) else - (match tm1_tm2 with + (match (tm1,tm2) with (Var v1, Var v2) -> - (match Name.compare (v1,v2) with - Less -> Less - | Equal -> cmp (tms1, tms2) - | Greater -> Greater) - | (Var _, Fn _) -> Less - | (Fn _, Var _) -> Greater + let c = Name.compare v1 v2 in + if c <> 0 then c else cmp (tms1, tms2) + | (Var _, Fn _) -> -1 + | (Fn _, Var _) -> 1 | (Fn (f1,a1), Fn (f2,a2)) -> - (match Name.compare (f1,f2) with - Less -> Less - | Equal -> - (match Int.compare (List.length a1, List.length a2) with - Less -> Less - | Equal -> cmp (a1 @ tms1, a2 @ tms2) - | Greater -> Greater) - | Greater -> Greater)) - | _ -> raise (Bug "Term.compare") + let c = Name.compare f1 f2 in + if c <> 0 then c + else + let c = Int.compare (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) = Equal;; +let equal tm1 tm2 = compare tm1 tm2 = 0;; (* ------------------------------------------------------------------------- *) (* Subterms. *) @@ -2509,9 +2242,9 @@ type path = int list;; let rec subterm' = function (tm, []) -> tm - | (Var _, _ :: _) -> raise (Error "Term.subterm: Var") + | (Var _, _ :: _) -> failwith "Term.subterm: Var" | (Fn (_,tms), h :: t) -> - if h >= List.length tms then raise (Error "Term.replace: Fn") + if h >= List.length tms then failwith "Term.replace: Fn" else subterm' (List.nth tms h, t);; let subterm s t = subterm' (s, t);; @@ -2523,7 +2256,7 @@ let subterms tm = 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) + | Fn (_,args) -> subtms ((List.map f (Mlist.enumerate args) @ rest), acc) in subtms ([([],tm)], []);; @@ -2531,15 +2264,15 @@ 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") + Var _ -> failwith "Term.replace: Var" | Fn (letc,tms) -> - if h >= List.length tms then raise (Error "Term.replace: Fn") + 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 Portable.pointerEqual (arg',arg) then tm - else Fn (letc, updateNth (h,arg') tms) + if arg' == arg then tm + else Fn (letc, Mlist.updateNth (h,arg') tms) ;; let find pred = @@ -2551,7 +2284,7 @@ let find pred = match tm with Var _ -> search rest | Fn (_,a) -> - let subtms = List.map (fun (i,t) -> (i :: path, t)) (enumerate a) + let subtms = List.map (fun (i,t) -> (i :: path, t)) (Mlist.enumerate a) in search (subtms @ rest) in fun tm -> search [([],tm)];; @@ -2599,11 +2332,11 @@ let hasTypeFunction = (hasTypeFunctionName,2);; let destFnHasType ((f,a) : functionName * term list) = if not (Name.equal f hasTypeFunctionName) then - raise (Error "Term.destFnHasType") + failwith "Term.destFnHasType" else match a with [tm;ty] -> (tm,ty) - | _ -> raise (Error "Term.destFnHasType");; + | _ -> failwith "Term.destFnHasType";; let isFnHasType = can destFnHasType;; @@ -2611,7 +2344,7 @@ let isTypedVar tm = match tm with Var _ -> true | Fn letc -> - match total destFnHasType letc with + match Useful.total destFnHasType letc with Some (Var _, _) -> true | _ -> false;; @@ -2622,7 +2355,7 @@ let typedSymbols tm = match tm with Var _ -> sz (n + 1) tms | Fn letc -> - match total destFnHasType letc with + match Useful.total destFnHasType letc with Some (tm,_) -> sz n (tm :: tms) | None -> let (_,a) = letc @@ -2636,7 +2369,7 @@ let nonVarTypedSubterms tm = (match tm with Var _ -> subtms (rest, acc) | Fn letc -> - (match total destFnHasType letc with + (match Useful.total destFnHasType letc with Some (t,_) -> (match t with Var _ -> subtms (rest, acc) @@ -2649,7 +2382,7 @@ let nonVarTypedSubterms tm = 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 + let rest = List.map f (Mlist.enumerate args) @ rest in subtms (rest, acc))) in subtms ([([],tm)], []);; @@ -2665,17 +2398,17 @@ 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") + if not (Name.equal f appName) then failwith "Term.destFnApp" else match a with [fTm;aTm] -> (fTm,aTm) - | _ -> raise (Error "Term.destFnApp");; + | _ -> failwith "Term.destFnApp";; let isFnApp = can destFnApp;; let destApp tm = match tm with - Var _ -> raise (Error "Term.destApp") + Var _ -> failwith "Term.destApp" | Fn letc -> destFnApp letc;; let isApp = can destApp;; @@ -2684,7 +2417,7 @@ let listMkApp (f,l) = List.fold_left (fun acc x -> mkApp (x, acc)) f l;; let stripApp tm = let rec strip tms tm = - match total destApp tm with + match Useful.total destApp tm with Some (f,a) -> strip (a :: tms) f | None -> (tm,tms) in strip [] tm;; @@ -2699,7 +2432,7 @@ let rec toString = function | Fn (n, l) -> n ^ "(" ^ String.concat ", " (List.map toString l) ^ ")";; module Ordered = -struct type t = term let compare = fromCompare compare end +struct type t = term let compare = compare end module Map = Map.Make (Ordered);; @@ -2713,8 +2446,6 @@ end module Substitute = struct -open Useful - (* ------------------------------------------------------------------------- *) (* A type of first order logic substitutions. *) (* ------------------------------------------------------------------------- *) @@ -2764,12 +2495,12 @@ let subst sub = let rec tmSub = function (Term.Var v as tm) -> (match peek sub v with - Some tm' -> if Portable.pointerEqual (tm,tm') then tm else tm' + Some tm' -> if tm == tm' then tm else tm' | None -> tm) | (Term.Fn (f,args) as tm) -> - let args' = Sharing.map tmSub args + let args' = List.map tmSub args in - if Portable.pointerEqual (args,args') then tm + if args == args' then tm else Term.Fn (f,args') in fun tm -> if null sub then tm else tmSub tm @@ -2812,7 +2543,7 @@ let compose (Subst m1 as sub1) sub2 = 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") + else failwith "Substitute.union: incompatible" in if Name.Map.null m1 then s2 else if Name.Map.null m2 then s1 @@ -2826,9 +2557,9 @@ let union (Subst m1 as s1) (Subst m2 as s2) = 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") + if Name.Map.inDomain w s then failwith "Substitute.invert: non-injective" else Name.Map.insert s (w, Term.Var v) - | (_, Term.Fn _, _) -> raise (Error "Substitute.invert: non-variable") + | (_, Term.Fn _, _) -> failwith "Substitute.invert: non-variable" in Subst (Name.Map.foldl inv (Name.Map.newMap ()) m) ;; @@ -2889,14 +2620,14 @@ let matchTerms sub tm1 tm2 = None -> insert sub (v,tm) | Some tm' -> if Term.equal tm tm' then sub - else raise (Error "Substitute.match: incompatible matches") + 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 raise (Error "Substitute.match: different structure") - | _ -> raise (Error "Substitute.match: functions can't match vars") + else failwith "Substitute.match: different structure" + | _ -> failwith "Substitute.match: functions can't match vars" in matchList sub [(tm1,tm2)] ;; @@ -2907,14 +2638,14 @@ let matchTerms sub tm1 tm2 = 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 + | ((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.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 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 @@ -2924,7 +2655,7 @@ let unify sub tm1 tm2 = if Name.equal f1 f2 && length args1 = length args2 then solve sub (zip args1 args2 @ rest) else - raise (Error "Substitute.unify: different structure") + failwith "Substitute.unify: different structure" in solve sub [(tm1,tm2)];; @@ -2936,9 +2667,6 @@ end module Atom = struct -open Useful -open Order - (* ------------------------------------------------------------------------- *) (* A type for storing first order logic atoms. *) (* ------------------------------------------------------------------------- *) @@ -2979,8 +2707,8 @@ 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");; + 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);; @@ -2995,13 +2723,11 @@ let symbols 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 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) = Equal;; +let equal atm1 atm2 = compare atm1 atm2 = 0;; (* ------------------------------------------------------------------------- *) (* Subterms. *) @@ -3009,28 +2735,28 @@ let equal atm1 atm2 = compare (atm1,atm2) = Equal;; let subterm = let subterm' = function - (_, []) -> raise (Bug "Atom.subterm: empty path") + (_, []) -> raise (Useful.Bug "Atom.subterm: empty path") | ((_,tms), h :: t) -> - if h >= length tms then raise (Error "Atom.subterm: bad path") - else Term.subterm (Mlist.nth (tms,h)) t + if h >= length tms then failwith "Atom.subterm: bad path" + else Term.subterm (List.nth tms h) t in fun x y -> subterm' (x, y) 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 [] (enumerate tms) + Mlist.foldl f [] (Mlist.enumerate tms) ;; let replace ((rel,tms) as atm) = function - ([],_) -> raise (Bug "Atom.replace: empty path") + ([],_) -> raise (Useful.Bug "Atom.replace: empty path") | (h :: t, res) -> - if h >= length tms then raise (Error "Atom.replace: bad path") + if h >= length tms then failwith "Atom.replace: bad path" else - let tm = Mlist.nth (tms,h) + 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) + if tm == tm' then atm + else (rel, Mlist.updateNth (h,tm') tms) ;; let find pred = @@ -3039,7 +2765,7 @@ let find pred = Some path -> Some (i :: path) | None -> None in - fun (_,tms) -> first f (enumerate tms) + fun (_,tms) -> Mlist.first f (Mlist.enumerate tms) ;; (* ------------------------------------------------------------------------- *) @@ -3059,9 +2785,9 @@ let freeVars = (* ------------------------------------------------------------------------- *) let subst sub ((p,tms) as atm) : atom = - let tms' = Sharing.map (Substitute.subst sub) tms + let tms' = List.map (Substitute.subst sub) tms in - if Portable.pointerEqual (tms',tms) then atm else (p,tms') + if tms' == tms then atm else (p,tms') ;; (* ------------------------------------------------------------------------- *) @@ -3071,7 +2797,7 @@ let subst sub ((p,tms) as atm) : atom = 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") + failwith "Atom.match" in Mlist.foldl matchArg sub (zip tms1 tms2) ;; @@ -3083,7 +2809,7 @@ let matchAtoms sub (p1,tms1) (p2,tms2) = 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") + failwith "Atom.unify" in Mlist.foldl unifyArg sub (zip tms1 tms2) ;; @@ -3108,7 +2834,7 @@ 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 let _ = Term.equal l r || failwith "Atom.destRefl" in l ;; @@ -3117,7 +2843,7 @@ 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 let _ = not (Term.equal l r) || failwith "Atom.sym: refl" in mkEq (r,l) ;; @@ -3139,12 +2865,12 @@ let nonVarTypedSubterms (_,tms) = in Mlist.foldl addTm acc (Term.nonVarTypedSubterms arg) in - Mlist.foldl addArg [] (enumerate tms) + Mlist.foldl addArg [] (Mlist.enumerate tms) ;; module Ordered = -struct type t = atom let compare = fromCompare compare end +struct type t = atom let compare = compare end module Map = Mmap.Make (Ordered);; @@ -3159,9 +2885,6 @@ end module Formula = struct -open Useful -open Order - (* ------------------------------------------------------------------------- *) (* A type of first order logic formulas. *) (* ------------------------------------------------------------------------- *) @@ -3191,7 +2914,7 @@ let mkBoolean = function let destBoolean = function True -> true | False -> false - | _ -> raise (Error "destBoolean");; + | _ -> failwith "destBoolean";; let isBoolean = can destBoolean;; @@ -3276,7 +2999,7 @@ let relationNames fm = let destAtom = function (Atom atm) -> atm - | _ -> raise (Error "Formula.destAtom");; + | _ -> failwith "Formula.destAtom";; let isAtom = can destAtom;; @@ -3284,7 +3007,7 @@ let isAtom = can destAtom;; let destNeg = function (Not p) -> p - | _ -> raise (Error "Formula.destNeg");; + | _ -> failwith "Formula.destNeg";; let isNeg = can destNeg;; @@ -3375,7 +3098,7 @@ let flattenEquiv = let destForall = function (Forall (v,f)) -> (v,f) - | _ -> raise (Error "destForall");; + | _ -> failwith "destForall";; let isForall = can destForall;; @@ -3396,7 +3119,7 @@ let stripForall = let destExists = function (Exists (v,f)) -> (v,f) - | _ -> raise (Error "destExists");; + | _ -> failwith "destExists";; let isExists = can destExists;; @@ -3437,57 +3160,51 @@ in (* A total comparison function for formulas. *) (* ------------------------------------------------------------------------- *) -let compare fm1_fm2 = +let compare fm1 fm2 = let rec cmp = function - [] -> Equal - | (f1_f2 :: fs) -> - if Portable.pointerEqual f1_f2 then cmp fs + [] -> 0 + | (((f1, f2) as f1_f2) :: fs) -> + if f1 == f2 then cmp fs else match f1_f2 with (True,True) -> cmp fs - | (True,_) -> Less - | (_,True) -> Greater + | (True,_) -> -1 + | (_,True) -> 1 | (False,False) -> cmp fs - | (False,_) -> Less - | (_,False) -> Greater + | (False,_) -> -1 + | (_,False) -> 1 | (Atom atm1, Atom atm2) -> - (match Atom.compare (atm1,atm2) with - Less -> Less - | Equal -> cmp fs - | Greater -> Greater) - | (Atom _, _) -> Less - | (_, Atom _) -> Greater + 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 _, _) -> Less - | (_, Not _) -> Greater + | (Not _, _) -> -1 + | (_, Not _) -> 1 | (And (p1,q1), And (p2,q2)) -> cmp ((p1,p2) :: (q1,q2) :: fs) - | (And _, _) -> Less - | (_, And _) -> Greater + | (And _, _) -> -1 + | (_, And _) -> 1 | (Or (p1,q1), Or (p2,q2)) -> cmp ((p1,p2) :: (q1,q2) :: fs) - | (Or _, _) -> Less - | (_, Or _) -> Greater + | (Or _, _) -> -1 + | (_, Or _) -> 1 | (Imp (p1,q1), Imp (p2,q2)) -> cmp ((p1,p2) :: (q1,q2) :: fs) - | (Imp _, _) -> Less - | (_, Imp _) -> Greater + | (Imp _, _) -> -1 + | (_, Imp _) -> 1 | (Iff (p1,q1), Iff (p2,q2)) -> cmp ((p1,p2) :: (q1,q2) :: fs) - | (Iff _, _) -> Less - | (_, Iff _) -> Greater + | (Iff _, _) -> -1 + | (_, Iff _) -> 1 | (Forall (v1,p1), Forall (v2,p2)) -> - (match Name.compare (v1,v2) with - Less -> Less - | Equal -> cmp ((p1,p2) :: fs) - | Greater -> Greater) - | (Forall _, Exists _) -> Less - | (Exists _, Forall _) -> Greater + 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)) -> - (match Name.compare (v1,v2) with - Less -> Less - | Equal -> cmp ((p1,p2) :: fs) - | Greater -> Greater) + let c = Name.compare v1 v2 in + if c <> 0 then c else cmp ((p1,p2) :: fs) in - cmp [fm1_fm2];; + cmp [(fm1,fm2)];; -let equal fm1 fm2 = compare (fm1,fm2) = Equal;; +let equal fm1 fm2 = compare fm1 fm2 = 0;; (* ------------------------------------------------------------------------- *) (* Free variables. *) @@ -3547,13 +3264,13 @@ let generalize fm = listMkForall (Name.Set.toList (freeVars fm), fm);; True -> fm | False -> fm | Atom (p,tms) -> - let tms' = Sharing.map (Substitute.subst sub) tms + let tms' = List.map (Substitute.subst sub) tms in - if Portable.pointerEqual (tms,tms') then fm else Atom (p,tms') + if 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' + 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 @@ -3565,8 +3282,7 @@ let generalize fm = listMkForall (Name.Set.toList (freeVars fm), fm);; let p' = substFm sub p and q' = substFm sub q in - if Portable.pointerEqual (p,p') && - Portable.pointerEqual (q,q') + if p == p' && q == q' then fm else conn (p',q') @@ -3590,7 +3306,7 @@ let generalize fm = listMkForall (Name.Set.toList (freeVars fm), fm);; in let p' = substCheck sub p in - if Name.equal v v' && Portable.pointerEqual (p,p') then fm + if Name.equal v v' && p == p' then fm else quant (v',p');; let subst = substCheck;; @@ -3609,7 +3325,7 @@ let mkNeq a_b = Not (mkEq a_b);; let destNeq = function (Not fm) -> destEq fm - | _ -> raise (Error "Formula.destNeq");; + | _ -> failwith "Formula.destNeq";; let isNeq = can destNeq;; @@ -3705,7 +3421,7 @@ let splitGoal = fun fm => *) module Ordered = -struct type t = formula let compare = fromCompare compare end +struct type t = formula let compare = compare end module Map = Mmap.Make (Ordered);; @@ -3720,9 +3436,6 @@ end module Literal = struct -open Useful;; -open Order - (* ------------------------------------------------------------------------- *) (* A type for storing first order logic literals. *) (* ------------------------------------------------------------------------- *) @@ -3775,7 +3488,7 @@ let toFormula = function let fromFormula = function (Formula.Atom atm) -> (true,atm) | (Formula.Not (Formula.Atom atm)) -> (false,atm) - | _ -> raise (Error "Literal.fromFormula");; + | _ -> failwith "Literal.fromFormula";; (* ------------------------------------------------------------------------- *) (* The size of a literal in symbols. *) @@ -3787,7 +3500,7 @@ let symbols ((_,atm) : literal) = Atom.symbols atm;; (* A total comparison function for literals. *) (* ------------------------------------------------------------------------- *) -let compare = prodCompare boolCompare Atom.compare;; +let compare = Useful.prodCompare Bool.compare Atom.compare;; let equal (p1,atm1) (p2,atm2) = p1 = p2 && Atom.equal atm1 atm2;; @@ -3802,7 +3515,7 @@ 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') + if atm == atm' then lit else (pol,atm') ;; (* ------------------------------------------------------------------------- *) @@ -3820,7 +3533,7 @@ let freeVars lit = Atom.freeVars (atom lit);; 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') + if atm' == atm then lit else (pol,atm') ;; (* ------------------------------------------------------------------------- *) @@ -3828,7 +3541,7 @@ let subst sub ((pol,atm) as lit) : literal = (* ------------------------------------------------------------------------- *) let matchLiterals sub ((pol1,atm1) : literal) (pol2,atm2) = - let _ = pol1 = pol2 || raise (Error "Literal.match") + let _ = pol1 = pol2 || failwith "Literal.match" in Atom.matchAtoms sub atm1 atm2 ;; @@ -3838,7 +3551,7 @@ let matchLiterals sub ((pol1,atm1) : literal) (pol2,atm2) = (* ------------------------------------------------------------------------- *) let unify sub ((pol1,atm1) : literal) (pol2,atm2) = - let _ = pol1 = pol2 || raise (Error "Literal.unify") + let _ = pol1 = pol2 || failwith "Literal.unify" in Atom.unify sub atm1 atm2 ;; @@ -3851,7 +3564,7 @@ let mkEq l_r : literal = (true, Atom.mkEq l_r);; let destEq = function ((true,atm) : literal) -> Atom.destEq atm - | (false,_) -> raise (Error "Literal.destEq");; + | (false,_) -> failwith "Literal.destEq";; let isEq = can destEq;; @@ -3859,7 +3572,7 @@ let mkNeq l_r : literal = (false, Atom.mkEq l_r);; let destNeq = function ((false,atm) : literal) -> Atom.destEq atm - | (true,_) -> raise (Error "Literal.destNeq");; + | (true,_) -> failwith "Literal.destNeq";; let isNeq = can destNeq;; @@ -3867,14 +3580,14 @@ let mkRefl tm = (true, Atom.mkRefl tm);; let destRefl = function (true,atm) -> Atom.destRefl atm - | (false,_) -> raise (Error "Literal.destRefl");; + | (false,_) -> failwith "Literal.destRefl";; let isRefl = can destRefl;; let mkIrrefl tm = (false, Atom.mkRefl tm);; let destIrrefl = function - (true,_) -> raise (Error "Literal.destIrrefl") + (true,_) -> failwith "Literal.destIrrefl" | (false,atm) -> Atom.destRefl atm;; let isIrrefl = can destIrrefl;; @@ -3901,7 +3614,7 @@ let toString literal = Formula.toString (toFormula literal);; module Ordered = -struct type t = literal let compare = fromCompare compare end +struct type t = literal let compare = compare end module Map = Mmap.Make (Ordered);; @@ -3958,7 +3671,7 @@ struct let subst sub lits = let substLit (lit,(eq,lits')) = let lit' = subst sub lit - in let eq = eq && Portable.pointerEqual (lit,lit') + in let eq = eq && lit == lit' in (eq, add lits' lit') @@ -3979,7 +3692,7 @@ struct end module Set_ordered = -struct type t = Set.set let compare = fromCompare Set.compare end +struct type t = Set.set let compare = Set.compare end module Set_map = Mmap.Make (Set_ordered);; @@ -3994,9 +3707,6 @@ end module Thm = struct -open Useful;; -open Order - (* ------------------------------------------------------------------------- *) (* An abstract type of first order logic theorems. *) (* ------------------------------------------------------------------------- *) @@ -4045,7 +3755,7 @@ let isContradiction th = Literal.Set.null (clause th);; let destUnit (Thm (cl,_)) = if Literal.Set.size cl = 1 then Literal.Set.pick cl - else raise (Error "Thm.destUnit");; + else failwith "Thm.destUnit";; let isUnit = can destUnit;; @@ -4065,7 +3775,7 @@ 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 compare th1 th2 = Literal.Set.compare (clause th1) (clause th2);; let equal th1 th2 = Literal.Set.equal (clause th1) (clause th2);; @@ -4146,7 +3856,7 @@ let assume lit = let subst sub (Thm (cl,inf) as th) = let cl' = Literal.Set.subst sub cl in - if Portable.pointerEqual (cl,cl') then th + if cl == cl' then th else match inf with (Subst,_) -> Thm (cl',inf) @@ -4172,10 +3882,10 @@ let resolve lit (Thm (cl1,_) as th1) (Thm (cl2,_) as th2) = (*MetisDebug let resolve = fun lit -> fun pos -> fun neg -> resolve lit pos neg - handle Error err -> - raise Error ("Thm.resolve:\nlit = " ^ Literal.toString lit ^ - "\npos = " ^ toString pos ^ - "\nneg = " ^ toString neg ^ "\n" ^ err);; + handle Failure err -> + raise Failure ("Thm.resolve:\nlit = " ^ Literal.toString lit ^ + "\npos = " ^ toString pos ^ + "\nneg = " ^ toString neg ^ "\n" ^ err);; *) (* ------------------------------------------------------------------------- *) @@ -4216,8 +3926,6 @@ end module Proof = struct -open Useful;; - (* ------------------------------------------------------------------------- *) (* A type of first order logic proofs. *) (* ------------------------------------------------------------------------- *) @@ -4260,13 +3968,13 @@ let inferenceToThm = function let () = Print.trace Literal.Set.pp "reconstructSubst: cl" cl let () = Print.trace Literal.Set.pp "reconstructSubst: cl'" cl' *) - raise (Bug "can't reconstruct Subst rule") + 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 total (Literal.matchLiterals sub lit) lit' with + match Useful.total (Literal.matchLiterals sub lit) lit' with None -> acc | Some sub -> (lits,sub) :: acc in @@ -4275,8 +3983,8 @@ let inferenceToThm = function Substitute.normalize (recon [(Literal.Set.toList cl, Substitute.empty)]) ;; (*MetisDebug - handle Error err -> - raise (Bug ("Proof.recontructSubst: shouldn't fail:\n" ^ err));; + handle Failure err -> + raise (Useful.Bug ("Proof.recontructSubst: shouldn't fail:\n" ^ err));; *) let reconstructResolvant cl1 cl2 cl = @@ -4291,11 +3999,11 @@ let inferenceToThm = function 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") + else raise (Useful.Bug "can't reconstruct Resolve rule") );; (*MetisDebug - handle Error err -> - raise (Bug ("Proof.recontructResolvant: shouldn't fail:\n" ^ err));; + handle Failure err -> + raise (Useful.Bug ("Proof.recontructResolvant: shouldn't fail:\n" ^ err));; *) let reconstructEquality cl = @@ -4306,7 +4014,7 @@ let inferenceToThm = function 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') + let itms = Mlist.enumerate (zip a a') in (match List.filter (fun x -> not (uncurry Term.equal (snd x))) itms with [(i,(tm,tm'))] -> @@ -4339,7 +4047,7 @@ let inferenceToThm = function ([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") + | _ -> raise (Useful.Bug "reconstructEquality: malformed") (*MetisTrace3 let ppCands = @@ -4348,13 +4056,13 @@ let inferenceToThm = function "Proof.reconstructEquality: candidates" candidates *) in - match first recon candidates with + match Mlist.first recon candidates with Some info -> info - | None -> raise (Bug "can't reconstruct Equality rule") + | None -> raise (Useful.Bug "can't reconstruct Equality rule") ;; (*MetisDebug - handle Error err -> - raise (Bug ("Proof.recontructEquality: shouldn't fail:\n" ^ err));; + handle Failure err -> + raise (Useful.Bug ("Proof.recontructEquality: shouldn't fail:\n" ^ err));; *) let reconstruct cl = function @@ -4362,7 +4070,7 @@ let inferenceToThm = function | (Thm.Assume,[]) -> (match Literal.Set.findl Literal.positive cl with Some (_,atm) -> Assume atm - | None -> raise (Bug "malformed Assume inference")) + | None -> raise (Useful.Bug "malformed Assume inference")) | (Thm.Subst,[th]) -> Subst (reconstructSubst (Thm.clause th) cl, th) | (Thm.Resolve,[th1;th2]) -> @@ -4372,11 +4080,11 @@ let inferenceToThm = function in if pol then Resolve (atm,th1,th2) else Resolve (atm,th2,th1) | (Thm.Refl,[]) -> - (match Literal.Set.findl (kComb true) cl with + (match Literal.Set.findl (K true) cl with Some lit -> Refl (Literal.destRefl lit) - | None -> raise (Bug "malformed Refl inference")) + | None -> raise (Useful.Bug "malformed Refl inference")) | (Thm.Equality,[]) -> let (x,y,z) = (reconstructEquality cl) in Equality (x,y,z) - | _ -> raise (Bug "malformed inference");; + | _ -> raise (Useful.Bug "malformed inference");; let thmToInference th = (*MetisTrace3 @@ -4405,7 +4113,7 @@ let inferenceToThm = function if Literal.Set.equal (Thm.clause th') cl then () else raise - Bug + Useful.Bug ("Proof.thmToInference: bad inference reconstruction:" ^ "\n th = " ^ Thm.toString th ^ "\n inf = " ^ inferenceToString inf ^ @@ -4415,8 +4123,8 @@ let inferenceToThm = function in inf (*MetisDebug - handle Error err -> - raise (Bug ("Proof.thmToInference: shouldn't fail:\n" ^ err));; + handle Failure err -> + raise (Useful.Bug ("Proof.thmToInference: shouldn't fail:\n" ^ err));; *) ;; @@ -4515,8 +4223,6 @@ end module Rule = struct -open Useful;; - (* ------------------------------------------------------------------------- *) (* Variable names. *) (* ------------------------------------------------------------------------- *) @@ -4530,10 +4236,10 @@ 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 xIVarName i = Name.fromString ("x" ^ string_of_int i);; let xIVar i = Term.Var (xIVarName i);; -let yIVarName i = Name.fromString ("y" ^ Int.toString i);; +let yIVarName i = Name.fromString ("y" ^ string_of_int i);; let yIVar i = Term.Var (yIVarName i);; (* ------------------------------------------------------------------------- *) @@ -4638,22 +4344,22 @@ let transEqn (((x,y), th1) as eqn1) (((_,z), th2) as eqn2) = (*MetisDebug let transEqn = fun eqn1 -> fun eqn2 -> transEqn eqn1 eqn2 - handle Error err -> - raise Error ("Rule.transEqn:\neqn1 = " ^ equationToString eqn1 ^ + 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 Error exception. *) +(* 2. Raises an Failure exception. *) (* ------------------------------------------------------------------------- *) type conv = Term.term -> Term.term * Thm.thm;; let allConv tm = (tm, Thm.refl tm);; -let noConv : conv = fun _ -> raise (Error "noConv");; +let noConv : conv = fun _ -> failwith "noConv";; (*MetisDebug let traceConv s conv tm = @@ -4664,9 +4370,9 @@ let traceConv s conv tm = in res end - handle Error err -> - (trace (s ^ ": " ^ Term.toString tm ^ " --> Error: " ^ err ^ "\n");; - raise (Error (s ^ ": " ^ err)));; + handle Failure err -> + (trace (s ^ ": " ^ Term.toString tm ^ " --> Failure: " ^ err ^ "\n");; + raise (Failure (s ^ ": " ^ err)));; *) let thenConvTrans tm (tm',th1) (tm'',th2) = @@ -4684,14 +4390,14 @@ let thenConv conv1 conv2 tm = thenConvTrans tm res1 res2 ;; -let orelseConv (conv1 : conv) conv2 tm = try conv1 tm with Error _ -> conv2 tm;; +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 raise (Error "changedConv") else res + if tm = tm' then failwith "changedConv" else res ;; let rec repeatConv conv tm = tryConv (thenConv conv (repeatConv conv)) tm;; @@ -4699,7 +4405,7 @@ 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") + [] -> failwith "firstConv" | [conv] -> conv tm | (conv :: convs) -> orelseConv conv (flip firstConv convs) tm;; let firstConv convs tm = firstConv tm convs;; @@ -4730,8 +4436,8 @@ let rewrConv (((x,y), eqTh) as eqn) path tm = (*MetisDebug let rewrConv = fun eqn as ((x,y),eqTh) -> fun path -> fun tm -> rewrConv eqn path tm - handle Error err -> - raise Error ("Rule.rewrConv:\nx = " ^ Term.toString x ^ + handle Failure err -> + raise Failure ("Rule.rewrConv:\nx = " ^ Term.toString x ^ "\ny = " ^ Term.toString y ^ "\neqTh = " ^ Thm.toString eqTh ^ "\npath = " ^ Term.pathToString path ^ @@ -4750,7 +4456,7 @@ 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;; + everyConv (List.map (subtermConv conv) (Useful.interval 0 (length a))) tm;; (* ------------------------------------------------------------------------- *) (* Applying a conversion to every subterm, with some traversal strategy. *) @@ -4773,20 +4479,20 @@ let repeatTopDownConv conv = (*MetisDebug let repeatTopDownConv = fun conv -> fun tm -> repeatTopDownConv conv tm - handle Error err -> raise (Error ("repeatTopDownConv: " ^ err));; + 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 Error exception. *) +(* 2. Raises an Failure exception. *) (* ------------------------------------------------------------------------- *) type literule = Literal.literal -> Literal.literal * Thm.thm;; let allLiterule lit = (lit, Thm.assume lit);; -let noLiterule : literule = fun _ -> raise (Error "noLiterule");; +let noLiterule : literule = fun _ -> failwith "noLiterule";; let thenLiterule literule1 literule2 lit = let (lit',th1) as res1 = literule1 lit @@ -4803,21 +4509,21 @@ let thenLiterule literule1 literule2 lit = ;; let orelseLiterule (literule1 : literule) literule2 lit = - try literule1 lit with Error _ -> 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 raise (Error "changedLiterule") else res + if lit = lit' then failwith "changedLiterule" else res ;; let rec repeatLiterule literule lit = tryLiterule (thenLiterule literule (repeatLiterule literule)) lit;; let rec firstLiterule lit = function - [] -> raise (Error "firstLiterule") + [] -> failwith "firstLiterule" | [literule] -> literule lit | (literule :: literules) -> orelseLiterule literule (flip firstLiterule literules) lit;; @@ -4846,10 +4552,10 @@ let rewrLiterule (((x,y),eqTh) as eqn) path lit = (*MetisDebug let rewrLiterule = fun eqn -> fun path -> fun lit -> rewrLiterule eqn path lit - handle Error err -> - raise Error ("Rule.rewrLiterule:\neqn = " ^ equationToString eqn ^ - "\npath = " ^ Term.pathToString path ^ - "\nlit = " ^ Literal.toString lit ^ "\n" ^ err);; + 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 = @@ -4863,10 +4569,10 @@ let argumentLiterule conv i = pathLiterule conv [i];; let allArgumentsLiterule conv lit = everyLiterule - (List.map (argumentLiterule conv) (interval 0 (Literal.arity lit))) lit;; + (List.map (argumentLiterule conv) (Useful.interval 0 (Literal.arity lit))) lit;; (* ------------------------------------------------------------------------- *) -(* A rule takes one theorem and either deduces another or raises an Error *) +(* A rule takes one theorem and either deduces another or raises an Failure *) (* exception. *) (* ------------------------------------------------------------------------- *) @@ -4874,11 +4580,11 @@ type rule = Thm.thm -> Thm.thm;; let allRule : rule = fun th -> th;; -let noRule : rule = fun _ -> raise (Error "noRule");; +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 Error _ -> rule2 th;; +let orelseRule (rule1 : rule) rule2 th = try rule1 th with Failure _ -> rule2 th;; let tryRule rule = orelseRule rule allRule;; @@ -4886,13 +4592,13 @@ 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") + else failwith "changedRule" ;; let rec repeatRule rule lit = tryRule (thenRule rule (repeatRule rule)) lit;; let rec firstRule th = function - [] -> raise (Error "firstRule") + [] -> failwith "firstRule" | [rule] -> rule th | (rule :: rules) -> orelseRule rule (flip firstRule rules) th;; let firstRule rules th = firstRule th rules;; @@ -4914,9 +4620,9 @@ let literalRule literule lit th = (*MetisDebug let literalRule = fun literule -> fun lit -> fun th -> literalRule literule lit th - handle Error err -> - raise Error ("Rule.literalRule:\nlit = " ^ Literal.toString lit ^ - "\nth = " ^ Thm.toString th ^ "\n" ^ err);; + 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;; @@ -4955,7 +4661,7 @@ let functionCongruence (f,n) = in let reflTh = Thm.refl (Term.Fn (f,xs)) in let reflLit = Thm.destUnit reflTh in - fst (Mlist.foldl cong (reflTh,reflLit) (enumerate ys)) + fst (Mlist.foldl cong (reflTh,reflLit) (Mlist.enumerate ys)) ;; (* ------------------------------------------------------------------------- *) @@ -4979,7 +4685,7 @@ let relationCongruence (r,n) = in let assumeLit = (false,(r,xs)) in let assumeTh = Thm.assume assumeLit in - fst (Mlist.foldl cong (assumeTh,assumeLit) (enumerate ys)) + fst (Mlist.foldl cong (assumeTh,assumeLit) (Mlist.enumerate ys)) ;; (* ------------------------------------------------------------------------- *) @@ -5017,7 +4723,7 @@ let removeIrrefl th = let irrefl = function ((true,_),th) -> th | ((false,atm) as lit, th) -> - match total Atom.destRefl atm with + match Useful.total Atom.destRefl atm with Some x -> Thm.resolve lit th (Thm.refl x) | None -> th in @@ -5033,7 +4739,7 @@ in let removeSym th = let rem ((pol,atm) as lit, (eqs,th)) = - match total Atom.sym atm with + match Useful.total Atom.sym atm with None -> (eqs, th) | Some atm' -> if Literal.Set.member lit eqs then @@ -5055,13 +4761,13 @@ 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") + failwith "Rule.expandAbbrevs: no vars" in let _ = not (Term.equal x y) || - raise (Error "Rule.expandAbbrevs: equal vars") + failwith "Rule.expandAbbrevs: equal vars" in Substitute.unify Substitute.empty x y in - match Literal.Set.firstl (total expand) (Thm.clause th) with + match Literal.Set.firstl (Useful.total expand) (Thm.clause th) with None -> removeIrrefl th | Some sub -> expandAbbrevs (Thm.subst sub th);; @@ -5117,13 +4823,13 @@ let freshVars th = Thm.subst (Substitute.freshVars (Thm.freeVars th)) th;; 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' + 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 Portable.pointerEqual (sub,sub') then Joined else Joinable sub' + if sub == sub' then Joined else Joinable sub' ;; let updateApart sub = @@ -5144,7 +4850,7 @@ let freshVars th = Thm.subst (Substitute.freshVars (Thm.freeVars th)) th;; let edge = Factor_edge (atm,atm') in match joinEdge Substitute.empty edge with - Joined -> raise (Bug "addFactorEdge: joined") + Joined -> raise (Useful.Bug "addFactorEdge: joined") | Joinable sub -> (sub,edge) :: acc | Apart -> acc ;; @@ -5155,7 +4861,7 @@ let freshVars th = Thm.subst (Substitute.freshVars (Thm.freeVars th)) th;; 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") + Joined -> raise (Useful.Bug "addRefl: joined") | Joinable _ -> edge :: acc | Apart -> acc ;; @@ -5167,7 +4873,7 @@ let freshVars th = Thm.subst (Substitute.freshVars (Thm.freeVars th)) th;; 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") + Joined -> raise (Useful.Bug "addRefl: joined") | Joinable sub -> (sub,edge) :: acc | Apart -> acc ;; @@ -5182,7 +4888,7 @@ let freshVars th = Thm.subst (Substitute.freshVars (Thm.freeVars th)) th;; | ((sub,edge) :: sub_edges) -> (*MetisDebug let () = if not (Substitute.null sub) then () - else raise Bug "Rule.factor.init_edges: empty subst" + else raise Useful.Bug "Rule.factor.init_edges: empty subst" *) let (acc,apart) = match updateApart sub apart with @@ -5198,7 +4904,7 @@ let freshVars th = Thm.subst (Substitute.freshVars (Thm.freeVars th)) th;; let sub_edges = Mlist.foldl (addFactorEdge lit) sub_edges lits in let (apart,sub_edges) = - match total Literal.sym lit with + match Useful.total Literal.sym lit with None -> (apart,sub_edges) | Some lit' -> let apart = addReflEdge lit apart @@ -5263,8 +4969,6 @@ end module Model = struct -open Useful;; - (* ------------------------------------------------------------------------- *) (* Constants. *) (* ------------------------------------------------------------------------- *) @@ -5275,14 +4979,9 @@ let maxSpace = 1000;; (* Helper functions. *) (* ------------------------------------------------------------------------- *) -let multInt = - match Int.maxInt with - None -> (fun x -> fun y -> Some (x * y)) - | Some m -> - let m = Real.floor (float_sqrt (Real.fromInt m)) - in - fun x -> fun y -> if x <= m && y <= m then Some (x * y) else None - ;; +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 @@ -5294,7 +4993,7 @@ let multInt = and iexp' x y acc = if y = 1 then Some acc else - let y = Int.div y 2 + let y = y / 2 in match multInt x x with Some x -> iexp x y acc @@ -5305,10 +5004,10 @@ let multInt = if y <= 1 then if y = 0 then Some 1 else if y = 1 then Some x - else raise (Bug "expInt: negative exponent") + else raise (Useful.Bug "expInt: negative exponent") else if x <= 1 then if 0 <= x then Some x - else raise (Bug "expInt: negative exponand") + else raise (Useful.Bug "expInt: negative exponand") else iexp x y 1;; let boolToInt = function @@ -5318,9 +5017,9 @@ let boolToInt = function let intToBool = function 1 -> true | 0 -> false - | _ -> raise (Bug "Model.intToBool");; + | _ -> raise (Useful.Bug "Model.intToBool");; -let minMaxInterval i j = interval i (1 + j - i);; +let minMaxInterval i j = Useful.interval i (1 + j - i);; (* ------------------------------------------------------------------------- *) (* Model size. *) @@ -5368,9 +5067,9 @@ type fixed = {functions : fixedFunction Name_arity.Map.map; relations : fixedRelation Name_arity.Map.map};; -let uselessFixedFunction : fixedFunction = kComb (kComb None);; +let uselessFixedFunction : fixedFunction = K (K None);; -let uselessFixedRelation : fixedRelation = kComb (kComb None);; +let uselessFixedRelation : fixedRelation = K (K None);; let emptyFunctions : fixedFunction Name_arity.Map.map = Name_arity.Map.newMap ();; @@ -5379,17 +5078,17 @@ let emptyRelations : fixedRelation Name_arity.Map.map = Name_arity.Map.newMap () let fixed0 f sz elts = match elts with [] -> f sz - | _ -> raise (Bug "Model.fixed0: wrong arity");; + | _ -> raise (Useful.Bug "Model.fixed0: wrong arity");; let fixed1 f sz elts = match elts with [x] -> f sz x - | _ -> raise (Bug "Model.fixed1: wrong arity");; + | _ -> raise (Useful.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");; + | _ -> raise (Useful.Bug "Model.fixed2: wrong arity");; let emptyFixed = let fns = emptyFunctions @@ -5439,7 +5138,7 @@ let insertRelationFixed fix name_arity_rel = relations = rels} ;; - let union _ = raise (Bug "Model.unionFixed: nameArity clash");; + let union _ = raise (Useful.Bug "Model.unionFixed: nameArity clash");; let unionFixed fix1 fix2 = let {functions = fns1; relations = rels1} = fix1 and {functions = fns2; relations = rels2} = fix2 @@ -5461,12 +5160,12 @@ let unionListFixed = let hasTypeFn _ elts = match elts with [x;_] -> Some x - | _ -> raise (Bug "Model.hasTypeFn: wrong arity");; + | _ -> raise (Useful.Bug "Model.hasTypeFn: wrong arity");; let eqRel _ elts = match elts with [x;y] -> Some (x = y) - | _ -> raise (Bug "Model.eqRel: wrong arity");; + | _ -> raise (Useful.Bug "Model.eqRel: wrong arity");; let basicFixed = let fns = Name_arity.Map.singleton (Term.hasTypeFunction,hasTypeFn) @@ -5511,15 +5210,15 @@ let projectionList = minMaxInterval projectionMin projectionMax;; let projectionName i = let _ = projectionMin <= i || - raise (Bug "Model.projectionName: less than projectionMin") + raise (Useful.Bug "Model.projectionName: less than projectionMin") in let _ = i <= projectionMax || - raise (Bug "Model.projectionName: greater than projectionMax") + raise (Useful.Bug "Model.projectionName: greater than projectionMax") in - Name.fromString ("project" ^ Int.toString i) + Name.fromString ("project" ^ string_of_int i) ;; -let projectionFn i _ elts = Some (Mlist.nth (elts, i - 1));; +let projectionFn i _ elts = Some (List.nth elts (i - 1));; let arityProjectionFixed arity = let mkProj i = ((projectionName i, arity), projectionFn i) @@ -5548,12 +5247,12 @@ let numeralList = minMaxInterval numeralMin numeralMax;; let numeralName i = let _ = numeralMin <= i || - raise (Bug "Model.numeralName: less than numeralMin") + raise (Useful.Bug "Model.numeralName: less than numeralMin") in let _ = i <= numeralMax || - raise (Bug "Model.numeralName: greater than numeralMax") + raise (Useful.Bug "Model.numeralName: greater than numeralMax") - in let s = if i < 0 then "negative" ^ Int.toString (-i) else Int.toString i + in let s = if i < 0 then "negative" ^ string_of_int (-i) else string_of_int i in Name.fromString s ;; @@ -5593,10 +5292,10 @@ and sucName = Name.fromString "suc";; let divFn {size = n} x y = let y = if y = 0 then n else y in - Some (Int.div x y) + Some (x / y) ;; - let expFn sz x y = Some (exp (multN sz) x y (oneN sz));; + let expFn sz x y = Some (Useful.exp (multN sz) x y (oneN sz));; let modFn {size = n} x y = let y = if y = 0 then n else y @@ -5616,7 +5315,7 @@ and sucName = Name.fromString "suc";; (* Relations *) - let dividesRel _ x y = Some (divides x y);; + let dividesRel _ x y = Some (Useful.divides x y);; let evenRel _ x = Some (x mod 2 = 0);; @@ -5676,9 +5375,9 @@ and sucName = Name.fromString "suc";; 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 divFn _ x y = if y = 0 then None else Some (x / y);; - let expFn sz x y = Some (exp (multN sz) x y (oneN sz));; + let expFn sz x y = Some (Useful.exp (multN sz) x y (oneN sz));; let modFn {size = n} x y = if y = 0 || x = n - 1 then None else Some (x mod y);; @@ -5702,7 +5401,7 @@ and sucName = Name.fromString "suc";; 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);; + else Some (Useful.divides x y);; let evenRel {size = n} x = if x = n - 1 then None else Some (x mod 2 = 0);; @@ -5778,7 +5477,7 @@ and universeName = Name.fromString "universe";; let eltN {size = n} = let rec f acc = function 0 -> acc - | x -> f (acc + 1) (Int.div x 2) + | x -> f (acc + 1) (x / 2) in f (-1) n ;; @@ -5934,10 +5633,10 @@ let zeroValuation = constantValuation zeroElement;; let getValuation v' v = match peekValuation v' v with Some i -> i - | None -> raise (Error "Model.getValuation: incomplete valuation");; + | None -> failwith "Model.getValuation: incomplete valuation";; let randomValuation {size = n} vs = - let f (v,v') = insertValuation v' (v, Portable.randomInt n) + let f (v,v') = insertValuation v' (v, Random.int n) in Name.Set.foldl f emptyValuation vs ;; @@ -5990,7 +5689,7 @@ let newTable n arity = | Some space -> Array_table (Array.make space cUNKNOWN);; - let randomResult r = Portable.randomInt r;; + let randomResult r = Random.int r;; let lookupTable n vR table elts = match table with Forgetful_table -> randomResult vR @@ -6112,7 +5811,7 @@ let peekFixedFunction vM (n,elts) = | Some fixFn -> fixFn elts ;; -let isFixedFunction vM n_elts = Option.isSome (peekFixedFunction vM n_elts);; +let isFixedFunction vM n_elts = Option.is_some (peekFixedFunction vM n_elts);; let peekFixedRelation vM (n,elts) = let {fixedRelations = fixRels} = vM @@ -6122,7 +5821,7 @@ let peekFixedRelation vM (n,elts) = | Some fixRel -> fixRel elts ;; -let isFixedRelation vM n_elts = Option.isSome (peekFixedRelation vM n_elts);; +let isFixedRelation vM n_elts = Option.is_some (peekFixedRelation vM n_elts);; (* A default model *) @@ -6317,7 +6016,7 @@ let perturb vM pert = (match tm with Model_var -> acc | Model_fn (func,tms,xs) -> - let onTarget ys = mem (interpretFunction vM (func,ys)) target + let onTarget ys = List.mem (interpretFunction vM (func,ys)) target in let func_xs = (func,xs) @@ -6348,14 +6047,14 @@ let perturb vM pert = (_, [], [], acc) -> acc | (ys, (tm :: tms), (x :: xs), acc) -> let pred y = - y <> x && onTarget (Mlist.revAppend (ys, y :: xs)) + 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 (Bug "Model.pertTerms.pert") + | (_, _, _, _) -> raise (Useful.Bug "Model.pertTerms.pert") in fun x y z -> pert ([],x,y,z) ;; @@ -6380,7 +6079,7 @@ let perturb vM pert = let pickPerturb vM perts = if Mlist.null perts then () - else perturb vM (Mlist.nth (perts, Portable.randomInt (length perts)));; + 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)) []);; @@ -6402,9 +6101,6 @@ end module Term_net = struct -open Useful;; -open Order;; - (* ------------------------------------------------------------------------- *) (* Anonymous variables. *) (* ------------------------------------------------------------------------- *) @@ -6421,30 +6117,28 @@ type qterm = | Fn of Name_arity.nameArity * qterm list;; let rec cmp = function - [] -> Equal - | (q1_q2 :: qs) -> - if Portable.pointerEqual q1_q2 then cmp qs + [] -> 0 + | (((q1, q2) as q1_q2) :: qs) -> + if q1 == q2 then cmp qs else match q1_q2 with - (Var,Var) -> Equal - | (Var, Fn _) -> Less - | (Fn _, Var) -> Greater + (Var,Var) -> 0 + | (Var, Fn _) -> -1 + | (Fn _, Var) -> 1 | (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 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 compareQterm q1 q2 = cmp [(q1,q2)];; - let compareFnQterm (f1,f2) = fnCmp f1 f2 [];; + let compareFnQterm f1 f2 = fnCmp f1 f2 [];; -let equalQterm q1 q2 = compareQterm (q1,q2) = Equal;; +let equalQterm q1 q2 = compareQterm q1 q2 = 0;; -let equalFnQterm f1 f2 = compareFnQterm (f1,f2) = Equal;; +let equalFnQterm f1 f2 = compareFnQterm f1 f2 = 0;; let rec termToQterm = function (Term.Var _) -> Var @@ -6485,9 +6179,9 @@ let rec termToQterm = function (Var, x) -> x | (x, Var) -> x | (Fn (f,a), Fn (g,b)) -> - let _ = Name_arity.equal f g || raise (Error "Term_net.qv") + let _ = Name_arity.equal f g || failwith "Term_net.qv" in - Fn (f, zipWith qv a b) + Fn (f, map2 qv a b) ;; let rec qu qsub = function @@ -6500,11 +6194,11 @@ let rec termToQterm = function 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");; + else failwith "Term_net.qu";; - let unifyQtermQterm qtm qtm' = total (qv qtm) qtm';; + let unifyQtermQterm qtm qtm' = Useful.total (qv qtm) qtm';; - let unifyQtermTerm qsub qtm tm = total (qu qsub) [(qtm,tm)];; + let unifyQtermTerm qsub qtm tm = Useful.total (qu qsub) [(qtm,tm)];; let rec qtermToTerm = function Var -> anonymousVar @@ -6567,7 +6261,7 @@ let singles qtms a = Mlist.foldr (fun (x, y) -> Single (x, y)) a qtms;; 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") + | _ -> raise (Useful.Bug "Term_net.insert: Match") and oadd a qtms = function None -> singles qtms a @@ -6577,7 +6271,7 @@ let singles qtms a = Mlist.foldr (fun (x, y) -> Single (x, y)) a qtms;; 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");; + 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;; @@ -6593,19 +6287,19 @@ let filter pred = None -> None | Some n -> Some (Single (qtm,n))) | (Multiple (vs,fs)) -> - let vs = Option.mapPartial filt vs + let vs = Option.bind vs filt 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 + 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 Error _ -> raise (Bug "Term_net.filter: should never fail");; + with Failure _ -> raise (Useful.Bug "Term_net.filter: should never fail");; -let toString net = "Term_net[" ^ Int.toString (size net) ^ "]";; +let toString net = "Term_net[" ^ string_of_int (size net) ^ "]";; (* ------------------------------------------------------------------------- *) (* Specialized fold operations to support matching and unification. *) @@ -6613,7 +6307,7 @@ let toString net = "Term_net[" ^ Int.toString (size net) ^ "]";; let rec norm = function (0 :: ks, ((_,n) as f) :: fs, qtms) -> - let (a,qtms) = revDivide qtms n + let (a,qtms) = Mlist.revDivide qtms n in addQterm (Fn (f,a)) (ks,fs,qtms) | stack -> stack @@ -6633,7 +6327,7 @@ let toString net = "Term_net[" ^ Int.toString (size net) ^ "]";; let stackValue = function ([],[],[qtm]) -> qtm - | _ -> raise (Bug "Term_net.stackValue");; + | _ -> raise (Useful.Bug "Term_net.stackValue");; let rec fold inc acc = function @@ -6654,7 +6348,7 @@ let toString net = "Term_net[" ^ Int.toString (size net) ^ "]";; (k + n, stackAddFn f stack, net) :: x in fold inc acc (Name_arity.Map.foldr getFns rest fns) - | _ -> raise (Bug "Term_net.foldTerms.fold");; + | _ -> raise (Useful.Bug "Term_net.foldTerms.fold");; let foldTerms inc acc net = fold inc acc [(1,stackEmpty,net)];; @@ -6670,7 +6364,7 @@ let foldEqualTerms pat inc acc = (match Name_arity.Map.peek fns f with None -> acc | Some net -> fold (a @ pats, net)) - | _ -> raise (Bug "Term_net.foldEqualTerms.fold") + | _ -> raise (Useful.Bug "Term_net.foldEqualTerms.fold") in fun net -> fold ([pat],net) ;; @@ -6701,7 +6395,7 @@ let foldEqualTerms pat inc acc = | Some net -> (a @ pats, stackAddFn f stack, net) :: rest in fold inc acc rest - | _ -> raise (Bug "Term_net.foldUnifiableTerms.fold");; + | _ -> raise (Useful.Bug "Term_net.foldUnifiableTerms.fold");; let foldUnifiableTerms pat inc acc net = fold inc acc [([pat],stackEmpty,net)];; @@ -6713,9 +6407,9 @@ let foldEqualTerms pat inc acc = (* Filter afterwards to get the precise set of satisfying values. *) (* ------------------------------------------------------------------------- *) - let idwise ((m,_),(n,_)) = Int.compare (m,n);; + let idwise (m,_) (n,_) = Int.compare m n;; - let fifoize ({fifo=fifo} : parameters) l = if fifo then sort idwise l else l;; + let fifoize ({fifo} : parameters) l = if fifo then List.sort idwise l else l;; let finally parm l = List.map snd (fifoize parm l);; @@ -6737,13 +6431,13 @@ let foldEqualTerms pat inc acc = | Some n -> (n, l @ tms) :: rest in mat acc rest - | _ -> raise (Bug "Term_net.match: Match");; + | _ -> 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 Error _ -> raise (Bug "Term_net.match: should never fail");; + with Failure _ -> raise (Useful.Bug "Term_net.match: should never fail");; let unseenInc qsub v tms (qtm,net,rest) = @@ -6769,13 +6463,13 @@ let foldEqualTerms pat inc acc = | Some net -> (qsub, net, a @ tms) :: rest in mat acc rest - | _ -> raise (Bug "Term_net.matched.mat");; + | _ -> 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 Error _ -> raise (Bug "Term_net.matched: should never fail");; + with Failure _ -> raise (Useful.Bug "Term_net.matched: should never fail");; let inc qsub v tms (qtm,net,rest) = @@ -6801,13 +6495,13 @@ let foldEqualTerms pat inc acc = | Some net -> (qsub, net, a @ tms) :: rest in mat acc rest - | _ -> raise (Bug "Term_net.unify.mat");; + | _ -> 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 Error _ -> raise (Bug "Term_net.unify: should never fail");; + with Failure _ -> raise (Useful.Bug "Term_net.unify: should never fail");; end @@ -6818,8 +6512,6 @@ end module Atom_net = struct -open Useful;; - (* ------------------------------------------------------------------------- *) (* Helper functions. *) (* ------------------------------------------------------------------------- *) @@ -6827,7 +6519,7 @@ open Useful;; let atomToTerm atom = Term.Fn atom;; let termToAtom = function - (Term.Var _) -> raise (Bug "Atom_net.termToAtom") + (Term.Var _) -> raise (Useful.Bug "Atom_net.termToAtom") | (Term.Fn atom) -> atom;; (* ------------------------------------------------------------------------- *) @@ -6852,7 +6544,7 @@ let fromList parm l = Mlist.foldl (fun (atm_a,n) -> insert n atm_a) (newNet parm let filter = Term_net.filter;; -let toString net = "Atom_net[" ^ Int.toString (size net) ^ "]";; +let toString net = "Atom_net[" ^ string_of_int (size net) ^ "]";; (* ------------------------------------------------------------------------- *) @@ -6878,8 +6570,6 @@ end module Literal_net = struct -open Useful;; - (* ------------------------------------------------------------------------- *) (* A type of literal sets that can be efficiently matched and unified. *) (* ------------------------------------------------------------------------- *) @@ -6896,16 +6586,16 @@ type 'a literalNet = let newNet parm = {positive = Atom_net.newNet parm; negative = Atom_net.newNet parm};; - let pos ({positive=positive} : 'a literalNet) = Atom_net.size positive;; + let pos ({positive} : 'a literalNet) = Atom_net.size positive;; - let neg ({negative=negative} : 'a literalNet) = Atom_net.size negative;; + let neg ({negative} : 'a literalNet) = Atom_net.size negative;; let size net = pos net + neg net;; (*let profile net = {positiveN = pos net; negativeN = neg net};;*) -let insert {positive=positive;negative=negative} = function +let insert {positive;negative} = function ((true,atm),a) -> {positive = Atom_net.insert positive (atm,a); negative = negative} | ((false,atm),a) -> @@ -6913,11 +6603,11 @@ let insert {positive=positive;negative=negative} = function let fromList parm l = Mlist.foldl (fun (lit_a,n) -> insert n lit_a) (newNet parm) l;; -let filter pred {positive=positive;negative=negative} = +let filter pred {positive;negative} = {positive = Atom_net.filter pred positive; negative = Atom_net.filter pred negative};; -let toString net = "Literal_net[" ^ Int.toString (size net) ^ "]";; +let toString net = "Literal_net[" ^ string_of_int (size net) ^ "]";; (* ------------------------------------------------------------------------- *) @@ -6927,17 +6617,17 @@ let toString net = "Literal_net[" ^ Int.toString (size net) ^ "]";; (* Filter afterwards to get the precise set of satisfying values. *) (* ------------------------------------------------------------------------- *) -let matchNet ({positive=positive;negative=negative} : 'a literalNet) = function +let matchNet ({positive;negative} : 'a literalNet) = function (true,atm) -> Atom_net.matchNet positive atm | (false,atm) -> Atom_net.matchNet negative atm;; -let matched ({positive=positive;negative=negative} : 'a literalNet) = function +let matched ({positive;negative} : 'a literalNet) = function (true,atm) -> Atom_net.matched positive atm | (false,atm) -> Atom_net.matched negative atm;; -let unify ({positive=positive;negative=negative} : 'a literalNet) = function +let unify ({positive;negative} : 'a literalNet) = function (true,atm) -> Atom_net.unify positive atm | (false,atm) -> Atom_net.unify negative atm;; @@ -6951,9 +6641,6 @@ end module Subsume = struct -open Useful;; -open Order;; - (* ------------------------------------------------------------------------- *) (* Helper functions. *) (* ------------------------------------------------------------------------- *) @@ -6962,13 +6649,13 @@ let findRest pred = let rec f ys = function [] -> None | (x :: xs) -> - if pred x then Some (x, Mlist.revAppend (ys,xs)) else f (x :: ys) xs + if pred x then Some (x, List.rev_append ys xs) else f (x :: ys) xs in f [] ;; let addSym (lit,acc) = - match total Literal.sym lit with + match Useful.total Literal.sym lit with None -> acc | Some lit -> lit :: acc let clauseSym lits = Mlist.foldl addSym lits lits;; @@ -6977,7 +6664,7 @@ let findRest pred = let sortClause cl = let lits = Literal.Set.toList cl in - sortMap Literal.typedSymbols (revCompare Int.compare) lits + Mlist.sortMap Literal.typedSymbols (Useful.revCompare Int.compare) lits ;; let incompatible lit = @@ -6996,11 +6683,9 @@ 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 idCompare (id1,len1) (id2,len2) = + let c = Int.compare len1 len2 in + if c <> 0 then c else Int.compare id1 id2;; let idSetEmpty : idSet = Pset.empty idCompare;; @@ -7036,10 +6721,10 @@ let newSubsume () = fstLits = Literal_net.newNet {fifo = false}; sndLits = Literal_net.newNet {fifo = false}}};; -let size ({empty=empty; unitn=unitn; nonunit = {clauses=clauses}}) = +let size ({empty; unitn; nonunit = {clauses}}) = length empty + Literal_net.size unitn + Intmap.size clauses;; -let insert ({empty=empty;unitn=unitn;nonunit=nonunit}) (cl',a) = +let insert ({empty;unitn;nonunit}) (cl',a) = match sortClause cl' with [] -> let empty = (cl',Substitute.empty,a) :: empty @@ -7050,7 +6735,7 @@ let insert ({empty=empty;unitn=unitn;nonunit=nonunit}) (cl',a) = in {empty = empty; unitn = unitn; nonunit = nonunit} | fstLit :: (sndLit :: otherLits as nonFstLits) -> - let {nextId=nextId;clauses=clauses;fstLits=fstLits;sndLits=sndLits} = nonunit + let {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) = @@ -7067,14 +6752,14 @@ let insert ({empty=empty;unitn=unitn;nonunit=nonunit}) (cl',a) = {empty = empty; unitn = unitn; nonunit = nonunit} ;; -let filter pred ({empty=empty;unitn=unitn;nonunit=nonunit}) = +let filter pred ({empty;unitn;nonunit}) = let pred3 (_,_,x) = pred x in let empty = List.filter pred3 empty in let unitn = Literal_net.filter pred3 unitn in let nonunit = - let {nextId=nextId;clauses=clauses;fstLits=fstLits;sndLits=sndLits} = nonunit + let {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 @@ -7089,7 +6774,7 @@ let filter pred ({empty=empty;unitn=unitn;nonunit=nonunit}) = {empty = empty; unitn = unitn; nonunit = nonunit} ;; -let toString subsume = "Subsume{" ^ Int.toString (size subsume) ^ "}";; +let toString subsume = "Subsume{" ^ string_of_int (size subsume) ^ "}";; (* ------------------------------------------------------------------------- *) @@ -7097,18 +6782,18 @@ let toString subsume = "Subsume{" ^ Int.toString (size subsume) ^ "}";; (* ------------------------------------------------------------------------- *) let matchLit lit' (lit,acc) = - match total (Literal.matchLiterals Substitute.empty lit') lit with + 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, sortMap length Int.compare acc) + [] -> Some (sub, Mlist.sortMap length Int.compare acc) | (lit' :: lits') -> match Mlist.foldl (matchLit lit') [] cl with [] -> None | [sub'] -> - (match total (Substitute.union sub) sub' with + (match Useful.total (Substitute.union sub) sub' with None -> None | Some sub -> mkSubsl acc sub lits') | subs -> mkSubsl (subs :: acc) sub lits' @@ -7123,7 +6808,7 @@ let toString subsume = "Subsume{" ^ Int.toString (size subsume) ^ "}";; | ((sub, (sub' :: subs) :: subsl) :: others) -> let others = (sub, subs :: subsl) :: others in - match total (Substitute.union sub) sub' with + match Useful.total (Substitute.union sub) sub' with None -> search others | Some sub -> search ((sub,subsl) :: others) in @@ -7138,16 +6823,16 @@ let toString subsume = "Subsume{" ^ Int.toString (size subsume) ^ "}";; let unitSubsumes pred unitn = let subLit lit = let subUnit (lit',cl',a) = - match total (Literal.matchLiterals Substitute.empty lit') lit with + 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 - first subUnit (Literal_net.matchNet unitn lit) + Mlist.first subUnit (Literal_net.matchNet unitn lit) in - first subLit + Mlist.first subLit ;; let nonunitSubsumes pred nonunit max cl = @@ -7156,7 +6841,7 @@ let toString subsume = "Subsume{" ^ Int.toString (size subsume) ^ "}";; in let subLit lits (lit,acc) = Mlist.foldl addId acc (Literal_net.matchNet lits lit) - in let {nextId = _; clauses=clauses; fstLits=fstLits; sndLits=sndLits} = nonunit + in let {nextId = _; clauses; fstLits; sndLits} = nonunit in let subCl' (id,_) = let (lits',cl',a) = Intmap.get clauses id @@ -7170,7 +6855,7 @@ let toString subsume = "Subsume{" ^ Int.toString (size subsume) ^ "}";; Pset.firstl subCl' cands ;; - let genSubsumes pred ({empty=empty;unitn=unitn;nonunit=nonunit}) max cl = + let genSubsumes pred ({empty;unitn;nonunit}) max cl = match emptySubsumes pred empty with (Some _) as s -> s | None -> @@ -7224,10 +6909,10 @@ let strictlySubsumes = fun pred -> fun subsume -> fun cl -> end;; *) -let isSubsumed subs cl = Option.isSome (subsumes (kComb true) subs cl);; +let isSubsumed subs cl = Option.is_some (subsumes (K true) subs cl);; let isStrictlySubsumed subs cl = - Option.isSome (strictlySubsumes (kComb true) subs cl);; + Option.is_some (strictlySubsumes (K true) subs cl);; (* ------------------------------------------------------------------------- *) (* Single clause versions. *) @@ -7237,7 +6922,7 @@ let clauseSubsumes cl' cl = let lits' = sortClause cl' and lits = clauseSym (Literal.Set.toList cl) in - match genClauseSubsumes (kComb true) cl' lits' lits () with + match genClauseSubsumes (K true) cl' lits' lits () with Some (_,sub,()) -> Some sub | None -> None ;; @@ -7255,9 +6940,6 @@ end module Knuth_bendix_order = struct -open Useful;; -open Order;; - (* ------------------------------------------------------------------------- *) (* Helper functions. *) (* ------------------------------------------------------------------------- *) @@ -7267,7 +6949,7 @@ 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 (Bug "firstNotEqualTerm");; + | None -> raise (Useful.Bug "firstNotEqualTerm");; (* ------------------------------------------------------------------------- *) (* The weight of all constants must be at least 1, and there must be at most *) @@ -7276,20 +6958,18 @@ let firstNotEqualTerm f l = type kbo = {weight : Term.function_t -> int; - precedence : Term.function_t * Term.function_t -> order};; + precedence : Term.function_t -> Term.function_t -> int};; (* Default weight = uniform *) -let uniformWeight : Term.function_t -> int = kComb 1;; +let uniformWeight : Term.function_t -> int = K 1;; (* Default precedence = by arity *) -let arityPrecedence : Term.function_t * Term.function_t -> order = - fun ((f1,n1),(f2,n2)) -> - match Int.compare (n1,n2) with - Less -> Less - | Equal -> Name.compare (f1,f2) - | Greater -> Greater;; +let arityPrecedence : Term.function_t -> Term.function_t -> int = + fun (f1,n1) (f2,n2) -> + let c = Int.compare n1 n2 in + if c <> 0 then c else Name.compare f1 f2;; (* The default order *) @@ -7327,7 +7007,7 @@ 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) + let n = Option.value (Name.Map.peek m v) ~default:0 in wt (Name.Map.insert m (v, n + 1)) (c + 1) tms | (Term.Fn (f,a) :: tms) -> @@ -7370,7 +7050,7 @@ let weightToString = Print.toString ppWeight;; (* The Knuth-Bendix term order. *) (* ------------------------------------------------------------------------- *) -let compare {weight=weight;precedence=precedence} = +let compare {weight;precedence} = let weightDifference tm1 tm2 = let w1 = weightTerm weight tm1 and w2 = weightTerm weight tm2 @@ -7391,10 +7071,10 @@ let compare {weight=weight;precedence=precedence} = and precedenceLess x y = match (x,y) with (Term.Fn (f1,a1), Term.Fn (f2,a2)) -> - (match precedence ((f1, length a1), (f2, length a2)) with - Less -> true - | Equal -> firstNotEqualTerm weightLess (zip a1 a2) - | Greater -> false) + 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 @@ -7403,33 +7083,33 @@ let compare {weight=weight;precedence=precedence} = 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 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)) -> - (match precedence ((f1, length a1), (f2, length a2)) with - Less -> Some Less - | Equal -> firstNotEqualTerm weightCmp (zip a1 a2) - | Greater -> Some Greater) - | _ -> raise (Bug "kboOrder.precendenceCmp") + 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 Equal else weightCmp tm1 tm2 + fun tm1 tm2 -> + if Term.equal tm1 tm2 then Some 0 else weightCmp tm1 tm2 ;; (*MetisTrace7 -let compare = fun kbo -> fun (tm1,tm2) -> +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 result = compare kbo tm1 tm2 let () = match result with None -> trace "Knuth_bendix_order.compare: result = Incomparable\n" | Some x -> - Print.trace Print.ppOrder "Knuth_bendix_order.compare: result" x + Print.trace Print.ppInt "Knuth_bendix_order.compare: result" x in result end;; @@ -7444,9 +7124,6 @@ end module Rewrite = struct -open Useful;; -open Order;; - (* ------------------------------------------------------------------------- *) (* Orientations of equations. *) (* ------------------------------------------------------------------------- *) @@ -7469,7 +7146,7 @@ let toStringOrientOption orto = (* A type of rewrite systems. *) (* ------------------------------------------------------------------------- *) -type reductionOrder = Term.term * Term.term -> order option;; +type reductionOrder = Term.term -> Term.term -> int option;; type equationId = int;; @@ -7486,14 +7163,14 @@ type rewrite = Rewrite of rewrite_t;; let updateWaiting rw waiting = - let Rewrite {order=order; known=known; redexes=redexes; subterms=subterms; waiting = _} = rw + let Rewrite {order; known; redexes; subterms; waiting = _} = rw in Rewrite {order = order; known = known; redexes = redexes; subterms = subterms; waiting = waiting} ;; -let deleteWaiting (Rewrite {waiting=waiting} as rw) id = +let deleteWaiting (Rewrite {waiting} as rw) id = updateWaiting rw (Intset.delete waiting id);; (* ------------------------------------------------------------------------- *) @@ -7509,11 +7186,11 @@ let newRewrite order = subterms = Term_net.newNet {fifo = false}; waiting = Intset.empty};; -let peek (Rewrite {known=known}) id = Intmap.peek known id;; +let peek (Rewrite {known}) id = Intmap.peek known id;; -let size (Rewrite {known=known}) = Intmap.size known;; +let size (Rewrite {known}) = Intmap.size known;; -let equations (Rewrite {known=known}) = +let equations (Rewrite {known}) = Intmap.foldr (fun (_,(eqn,_),eqns) -> eqn :: eqns) [] known;; @@ -7578,10 +7255,10 @@ end;; let termReducible order known id = let eqnRed ((l,r),_) tm = - match total (Substitute.matchTerms Substitute.empty l) tm with + match Useful.total (Substitute.matchTerms Substitute.empty l) tm with None -> false | Some sub -> - order (tm, Substitute.subst (Substitute.normalize sub) r) = Some Greater + order tm (Substitute.subst (Substitute.normalize sub) r) = Some 1 in let knownRed tm (eqnId,(eqn,ort)) = eqnId <> id && @@ -7610,9 +7287,9 @@ let thmReducible order known id th = (* ------------------------------------------------------------------------- *) let orderToOrient = function - (Some Equal) -> raise (Error "Rewrite.orient: reflexive") - | (Some Greater) -> Some Left_to_right - | (Some Less) -> Some Right_to_left + 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));; @@ -7624,12 +7301,12 @@ let orderToOrient = function | None -> ins (ins redexes l id Left_to_right) r id Right_to_left;; -let add (Rewrite {known=known} as rw) (id,eqn) = +let add (Rewrite {known} as rw) (id,eqn) = if Intmap.inDomain id known then rw else - let Rewrite {order=order;redexes=redexes;subterms=subterms;waiting=waiting} = rw + let Rewrite {order;redexes;subterms;waiting} = rw - in let ort = orderToOrient (order (fst eqn)) + in let ort = let (l,r) = fst eqn in orderToOrient (order l r) in let known = Intmap.insert known (id,(eqn,ort)) @@ -7655,8 +7332,8 @@ let add (Rewrite {known=known} as rw) (id,eqn) = (* 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 reorder (i,_) (j,_) = Int.compare j i;; + let matchingRedexes redexes tm = List.sort reorder (Term_net.matchNet redexes tm);; let wellOriented x y = match (x,y) with @@ -7675,21 +7352,21 @@ let orientedEquation dir eqn = match dir with let rewrIdConv' order known redexes id tm = let rewr (id',lr) = - let _ = id <> id' || raise (Error "same theorem") + let _ = id <> id' || failwith "same theorem" in let (eqn,ort) = Intmap.get known id' - in let _ = wellOriented ort lr || raise (Error "orientation") + 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.isSome ort || - order (tm,tm') = Some Greater || - raise (Error "order") + 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 first (total rewr) (matchingRedexes redexes tm) with - None -> raise (Error "Rewrite.rewrIdConv: no matching rewrites") + match Mlist.first (Useful.total rewr) (matchingRedexes redexes tm) with + None -> failwith "Rewrite.rewrIdConv: no matching rewrites" | Some res -> res ;; @@ -7700,19 +7377,19 @@ let rewriteIdConv' 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 Less -> + 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 raise (Error "mkNeqConv: RL") - | Some Equal -> raise (Error "irreflexive") - | Some Greater -> + 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 raise (Error "mkNeqConv: LR") + if Term.equal tm l then (r,th) else failwith "mkNeqConv: LR" ;; type neqConvs = Neq_convs of Rule.conv Literal.Map.map;; @@ -7722,7 +7399,7 @@ 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 + match Useful.total (mkNeqConv order) lit with None -> None | Some conv -> Some (Neq_convs (Literal.Map.insert m (lit,conv)));; @@ -7770,7 +7447,7 @@ let rewriteIdEqn' order known redexes id ((l_r,th) as eqn) = else if not (Thm.negateMember lit litTh) then litTh else Thm.resolve lit th litTh);; (*MetisDebug - handle Error err -> raise (Error ("Rewrite.rewriteIdEqn':\n" ^ err));; + handle Failure err -> failwith ("Rewrite.rewriteIdEqn':\n" ^ err);; *) let rewriteIdLiteralsRule' order known redexes id lits th = @@ -7782,7 +7459,8 @@ let rewriteIdLiteralsRule' order known redexes id lits th = in if Literal.equal lit lit' then acc else - let th = Thm.resolve lit th litTh + 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) @@ -7822,30 +7500,30 @@ let rewriteIdRule' = fun order -> fun known -> fun redexes -> fun id -> fun th - let () = Print.trace Thm.pp "Rewrite.rewriteIdRule': result" result *) let _ = not (thmReducible order known id result) || - raise Bug "rewriteIdRule: should be normalized" + raise Useful.Bug "rewriteIdRule: should be normalized" in result end - handle Error err -> raise (Error ("Rewrite.rewriteIdRule:\n" ^ err));; + handle Failure err -> failwith ("Rewrite.rewriteIdRule:\n" ^ err);; *) -let rewrIdConv (Rewrite {known=known;redexes=redexes}) order = +let rewrIdConv (Rewrite {known;redexes}) order = rewrIdConv' order known redexes;; let rewrConv rewrite order = rewrIdConv rewrite order (-1);; -let rewriteIdConv (Rewrite {known=known;redexes=redexes}) order = +let rewriteIdConv (Rewrite {known;redexes}) order = rewriteIdConv' order known redexes;; let rewriteConv rewrite order = rewriteIdConv rewrite order (-1);; -let rewriteIdLiteralsRule (Rewrite {known=known;redexes=redexes}) order = +let rewriteIdLiteralsRule (Rewrite {known;redexes}) order = rewriteIdLiteralsRule' order known redexes;; let rewriteLiteralsRule rewrite order = rewriteIdLiteralsRule rewrite order (-1);; -let rewriteIdRule (Rewrite {known=known;redexes=redexes}) order = +let rewriteIdRule (Rewrite {known;redexes}) order = rewriteIdRule' order known redexes;; let rewriteRule rewrite order = rewriteIdRule rewrite order (-1);; @@ -7884,8 +7562,8 @@ let findReducibles order known subterms id = else let tm' = Substitute.subst (Substitute.normalize sub) r in - if order (tm,tm') = Some Greater then () - else raise (Error "order") + 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) && @@ -7901,7 +7579,7 @@ let findReducibles order known subterms id = let reduce1 newx id (eqn0,ort0) (rpl,spl,todo,rw,changed) = let (eq0,_) = eqn0 - in let Rewrite {order=order;known=known;redexes=redexes;subterms=subterms;waiting=waiting} = rw + 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 @@ -7914,7 +7592,7 @@ let reduce1 newx id (eqn0,ort0) (rpl,spl,todo,rw,changed) = 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) + if same_redexes then Some ort0 else let (l,r) = eq in Useful.total orderToOrient (order l r) in match ort with None -> @@ -7999,7 +7677,7 @@ let pick known set = let () = Print.trace ppPl "Rewrite.rebuild: rpl" rpl let () = Print.trace ppPl "Rewrite.rebuild: spl" spl *) - let Rewrite {order=order;known=known;redexes=redexes;subterms=subterms;waiting=waiting} = rw + let Rewrite {order;known;redexes;subterms;waiting} = rw in let redexes = cleanRedexes known redexes rpl in let subterms = cleanSubterms known subterms spl in @@ -8011,7 +7689,7 @@ let pick known set = waiting = waiting} ;; -let rec reduceAcc (rpl, spl, todo, (Rewrite {known=known;waiting=waiting} as rw), changed) = +let rec reduceAcc (rpl, spl, todo, (Rewrite {known;waiting} as rw), changed) = match pick known todo with Some (id,eqn_ort) -> let todo = Intset.delete todo id @@ -8025,7 +7703,7 @@ let rec reduceAcc (rpl, spl, todo, (Rewrite {known=known;waiting=waiting} as rw) reduceAcc (reduce1 true id eqn_ort (rpl,spl,todo,rw,changed)) | None -> (rebuild rpl spl rw, Intset.toList changed);; -let isReduced (Rewrite {waiting=waiting}) = Intset.null waiting;; +let isReduced (Rewrite {waiting}) = Intset.null waiting;; let reduce' rw = if isReduced rw then (rw,[]) @@ -8046,11 +7724,11 @@ let reduce' = fun rw -> let ths = List.map (fun (id,((_,th),_)) -> (id,th)) (Intmap.toList known') let _ = not (List.exists (uncurry (thmReducible order known')) ths) || - raise Bug "Rewrite.reduce': not fully reduced" + raise Useful.Bug "Rewrite.reduce': not fully reduced" in result end - handle Error err -> raise (Bug ("Rewrite.reduce': shouldn't fail\n" ^ err));; + handle Failure err -> raise (Useful.Bug ("Rewrite.reduce': shouldn't fail\n" ^ err));; *) let reduce rw = fst (reduce' rw);; @@ -8061,12 +7739,12 @@ let reduce rw = fst (reduce' rw);; let addEqn (id_eqn,rw) = add rw id_eqn;; let orderedRewrite order ths = - let rw = Mlist.foldl addEqn (newRewrite order) (enumerate ths) + let rw = Mlist.foldl addEqn (newRewrite order) (Mlist.enumerate ths) in rewriteRule rw order ;; - let order : reductionOrder = kComb (Some Greater);; + let order : reductionOrder = fun _ _ -> Some 1;; let rewrite = orderedRewrite order;; @@ -8078,8 +7756,6 @@ end module Units = struct -open Useful;; - (* ------------------------------------------------------------------------- *) (* A type of unit store. *) (* ------------------------------------------------------------------------- *) @@ -8097,7 +7773,7 @@ let empty = Units (Literal_net.newNet {fifo = false});; let size (Units net) = Literal_net.size net;; -let toString units = "U{" ^ Int.toString (size units) ^ "}";; +let toString units = "U{" ^ string_of_int (size units) ^ "}";; (* ------------------------------------------------------------------------- *) (* Add units into the store. *) @@ -8106,7 +7782,7 @@ let toString units = "U{" ^ Int.toString (size units) ^ "}";; let add (Units net) ((lit,th) as uTh) = let net = Literal_net.insert net (lit,uTh) in - match total Literal.sym lit with + 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 @@ -8123,11 +7799,11 @@ let addList = Mlist.foldl (fun (th,u) -> add u th);; let matchUnits (Units net) lit = let check ((lit',_) as uTh) = - match total (Literal.matchLiterals Substitute.empty lit') lit with + match Useful.total (Literal.matchLiterals Substitute.empty lit') lit with None -> None | Some sub -> Some (uTh,sub) in - first check (Literal_net.matchNet net lit) + Mlist.first check (Literal_net.matchNet net lit) ;; (* ------------------------------------------------------------------------- *) @@ -8136,7 +7812,7 @@ let matchUnits (Units net) lit = let reduce units = let red1 (lit,news_th) = - match total Literal.destIrrefl lit with + match Useful.total Literal.destIrrefl lit with Some tm -> let (news,th) = news_th in let th = Thm.resolve lit th (Thm.refl tm) @@ -8172,9 +7848,6 @@ end module Clause = struct -open Useful;; -open Order;; - (* ------------------------------------------------------------------------- *) (* Helper functions. *) (* ------------------------------------------------------------------------- *) @@ -8189,7 +7862,7 @@ let newId = in n in - fun () -> Portable.critical newI () + fun () -> Useful.critical newI () ;; (* ------------------------------------------------------------------------- *) @@ -8217,7 +7890,7 @@ type clause = Clause of clauseInfo;; (* Pretty printing. *) (* ------------------------------------------------------------------------- *) -let toString (Clause {id=id;thm=thm}) = Thm.toString thm;; +let toString (Clause {id;thm}) = Thm.toString thm;; (* ------------------------------------------------------------------------- *) @@ -8244,36 +7917,36 @@ let newClause parameters thm = let literals cl = Thm.clause (thm cl);; -let isTautology (Clause {thm=thm}) = Thm.isTautology thm;; +let isTautology (Clause {thm}) = Thm.isTautology thm;; -let isContradiction (Clause {thm=thm}) = Thm.isContradiction 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 +let strictlyLess ordering x y = + match Knuth_bendix_order.compare ordering x y with + Some c when c < 0 -> true | _ -> false;; -let isLargerTerm ({ordering=ordering;orderTerms=orderTerms} : parameters) l_r = - not orderTerms || not (strictlyLess ordering l_r);; +let isLargerTerm ({ordering;orderTerms} : parameters) (l,r) = + not orderTerms || not (strictlyLess ordering l r);; let atomToTerms atm = - match total Atom.destEq atm with + 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 + let less x = List.exists (fun y -> strictlyLess ordering x y) ys in - not (Mlist.all less xs) + not (List.for_all less xs) ;; - let isLargerLiteral ({ordering=ordering;orderLiterals=orderLiterals} : parameters) lits = + let isLargerLiteral ({ordering;orderLiterals} : parameters) lits = match orderLiterals with - No_literal_order -> kComb true + No_literal_order -> K true | Unsigned_literal_order -> let addLit ((_,atm),acc) = atomToTerms atm @ acc @@ -8281,8 +7954,8 @@ let isLargerTerm ({ordering=ordering;orderTerms=orderTerms} : parameters) l_r = in fun (_,atm') -> notStrictlyLess ordering (atomToTerms atm', tms) | Positive_literal_order -> - match Literal.Set.findl (kComb true) lits with - None -> kComb true + 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 @@ -8295,7 +7968,7 @@ let isLargerTerm ({ordering=ordering;orderTerms=orderTerms} : parameters) l_r = ;; -let largestLiterals (Clause {parameters=parameters;thm=thm}) = +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 @@ -8315,12 +7988,12 @@ let largestLiterals = fun cl -> end;; *) -let largestEquations (Clause {parameters=parameters} as cl) = +let largestEquations (Clause {parameters} as cl) = 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 + match Useful.total Literal.destEq lit with None -> acc | Some (l,r) -> let acc = addEq lit Rewrite.Right_to_left (r,l) acc @@ -8352,20 +8025,20 @@ let subsumes (subs : clause Subsume.subsume) cl = (* Simplifying rules: these preserve the clause id. *) (* ------------------------------------------------------------------------- *) -let freshVars (Clause {parameters=parameters;id=id;thm=thm}) = +let freshVars (Clause {parameters;id;thm}) = Clause {parameters = parameters; id = id; thm = Rule.freshVars thm};; -let simplify (Clause {parameters=parameters;id=id;thm=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=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=parameters;id=id;thm=thm}) = +let rewrite rewr (Clause {parameters;id;thm}) = let simp th = - let {ordering=ordering} = parameters + let {ordering} = parameters in let cmp = Knuth_bendix_order.compare ordering in Rewrite.rewriteIdRule rewr cmp id th @@ -8389,14 +8062,14 @@ let rewrite rewr (Clause {parameters=parameters;id=id;thm=thm}) = in result;; (*MetisDebug - handle Error err -> raise (Error ("Clause.rewrite:\n" ^ err));; + handle Failure err -> failwith "Clause.rewrite:\n" ^ err);; *) (* ------------------------------------------------------------------------- *) (* Inference rules: these generate new clause ids. *) (* ------------------------------------------------------------------------- *) -let factor (Clause {parameters=parameters;thm=thm} as cl) = +let factor (Clause {parameters;thm} as cl) = let lits = largestLiterals cl in let apply sub = newClause parameters (Thm.subst sub thm) @@ -8422,7 +8095,7 @@ let resolve (cl1,lit1) (cl2,lit2) = let () = Print.trace pp "Clause.resolve: cl2" cl2 let () = Print.trace Literal.pp "Clause.resolve: lit2" lit2 *) - let Clause {parameters=parameters; thm = th1} = cl1 + let Clause {parameters; thm = th1} = cl1 and Clause {thm = th2} = cl2 in let sub = Literal.unify Substitute.empty lit1 (Literal.negate lit2) (*MetisTrace5 @@ -8436,12 +8109,12 @@ let resolve (cl1,lit1) (cl2,lit2) = (*MetisTrace5 (trace "Clause.resolve: th1 violates ordering\n";; false) || *) - raise (Error "resolve: clause1: ordering constraints") + failwith "resolve: clause1: ordering constraints" in let _ = isLargerLiteral parameters (Thm.clause th2) lit2 || (*MetisTrace5 (trace "Clause.resolve: th2 violates ordering\n";; false) || *) - raise (Error "resolve: clause2: ordering constraints") + failwith "resolve: clause2: ordering constraints" in let th = Thm.resolve lit1 th1 th2 (*MetisTrace5 let () = Print.trace Thm.pp "Clause.resolve: th" th @@ -8465,7 +8138,7 @@ let paramodulate (cl1,lit1,ort1,tm1) (cl2,lit2,path2,tm2) = let () = Print.trace Term.ppPath "Clause.paramodulate: path2" path2 let () = Print.trace Term.pp "Clause.paramodulate: tm2" tm2 *) - let Clause {parameters=parameters; thm = th1} = cl1 + let Clause {parameters; thm = th1} = cl1 and Clause {thm = th2} = cl2 in let sub = Substitute.unify Substitute.empty tm1 tm2 in let lit1 = Literal.subst sub lit1 @@ -8474,9 +8147,9 @@ let paramodulate (cl1,lit1,ort1,tm1) (cl2,lit2,path2,tm2) = and th2 = Thm.subst sub th2 in let _ = isLargerLiteral parameters (Thm.clause th1) lit1 || - raise (Error "Clause.paramodulate: with clause: ordering") + failwith "Clause.paramodulate: with clause: ordering" in let _ = isLargerLiteral parameters (Thm.clause th2) lit2 || - raise (Error "Clause.paramodulate: into clause: ordering") + failwith "Clause.paramodulate: into clause: ordering" in let eqn = (Literal.destEq lit1, th1) in let (l_r,_) as eqn = @@ -8487,7 +8160,7 @@ let paramodulate (cl1,lit1,ort1,tm1) (cl2,lit2,path2,tm2) = let () = Print.trace Rule.ppEquation "Clause.paramodulate: eqn" eqn *) in let _ = isLargerTerm parameters l_r || - raise (Error "Clause.paramodulate: equation: ordering constraints") + 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 @@ -8495,11 +8168,11 @@ let paramodulate (cl1,lit1,ort1,tm1) (cl2,lit2,path2,tm2) = in Clause {parameters = parameters; id = newId (); thm = th} (*MetisTrace5 - handle Error err -> + handle Failure err -> let let () = trace ("Clause.paramodulate: failed: " ^ err ^ "\n") in - raise Error err + raise Failure err end;; *) @@ -8520,8 +8193,6 @@ end module Active = struct -open Useful;; -open Order;; open Ax_cj (* ------------------------------------------------------------------------- *) @@ -8536,7 +8207,7 @@ local let let {id, thm = th, ...} = Clause.dest cl in - match total Thm.destUnitEq th with + match Useful.total Thm.destUnitEq th with Some l_r -> Rewrite.add rw (id,(l_r,th)) | None -> rw end @@ -8563,7 +8234,7 @@ local let allClause2 cl_lit cl = let let allLiteral2 lit = - match total (Clause.resolve cl_lit) (cl,lit) with + match Useful.total (Clause.resolve cl_lit) (cl,lit) with None -> true | Some cl -> allFactors red [cl] in @@ -8606,7 +8277,7 @@ local let para = Clause.paramodulate cl_lit_ort_tm let allSubterms (path,tm) = - match total para (cl,lit,path,tm) with + match Useful.total para (cl,lit,path,tm) with None -> true | Some cl -> allFactors red [cl] in @@ -8639,7 +8310,7 @@ local let let allCl2 x = List.all (allClause2 x) cls in - match total Literal.destEq lit with + match Useful.total Literal.destEq lit with None -> true | Some (l,r) -> allCl2 (cl,lit,Rewrite.Left_to_right,l) && @@ -8717,7 +8388,7 @@ end;; let checkSaturated ordering subs cls = if isSaturated ordering subs cls then () - else raise (Bug "Active.checkSaturated");; + else raise (Useful.Bug "Active.checkSaturated");; *) (* ------------------------------------------------------------------------- *) @@ -8753,8 +8424,8 @@ let getSubsume (Active {subsume = s}) = s;; let setRewrite active rewrite = let Active - {parameters=parameters;clauses=clauses;units=units;subsume=subsume;literals=literals;equations=equations; - subterms=subterms;allSubterms=allSubterms} = active + {parameters;clauses;units;subsume;literals;equations; + subterms;allSubterms} = active in Active {parameters = parameters; clauses = clauses; units = units; @@ -8775,8 +8446,8 @@ let default : parameters = open Term_net let empty parameters = - let {clause=clause} = parameters - in let {Clause.ordering=ordering} = clause + let {clause} = parameters + in let {Clause.ordering} = clause in Active {parameters = parameters; @@ -8790,7 +8461,7 @@ let empty parameters = allSubterms = Term_net.newNet {fifo = false}} ;; -let size (Active {clauses=clauses}) = Intmap.size clauses;; +let size (Active {clauses}) = Intmap.size clauses;; let clauses (Active {clauses = cls}) = let add (_,cl,acc) = cl :: acc @@ -8834,10 +8505,29 @@ let toString active = "Active{" ^ string_of_int (size active) ^ "}";; let simplify simp units rewr subs = let {subsumes = s; reduce = r; rewrites = w} = simp - in let rewrite cl = + in let rec rewrite cl = let cl' = Clause.rewrite rewr cl in - if Clause.equalThms cl cl' then Some cl else Clause.simplify cl' + 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 @@ -8881,7 +8571,7 @@ let simplify = fun simp -> fun units -> fun rewr -> fun subs -> fun cl -> let () = f () in raise - Bug + Useful.Bug ("Active.simplify: clause should have been simplified "^e) end in @@ -8890,7 +8580,7 @@ let simplify = fun simp -> fun units -> fun rewr -> fun subs -> fun cl -> *) let simplifyActive simp active = - let Active {units=units;rewrite=rewrite;subsume=subsume} = active + let Active {units;rewrite;subsume} = active in simplify simp units rewrite subsume ;; @@ -8902,7 +8592,7 @@ let simplifyActive simp active = let addUnit units cl = let th = Clause.thm cl in - match total Thm.destUnit th with + match Useful.total Thm.destUnit th with Some lit -> Units.add units (lit,th) | None -> units ;; @@ -8910,7 +8600,7 @@ let addUnit units cl = let addRewrite rewrite cl = let th = Clause.thm cl in - match total Thm.destUnitEq th with + match Useful.total Thm.destUnitEq th with Some l_r -> Rewrite.add rewrite (Clause.id cl, (l_r,th)) | None -> rewrite ;; @@ -8948,8 +8638,8 @@ let addAllSubterms allSubterms cl = let addClause active cl = let Active - {parameters=parameters;clauses=clauses;units=units;rewrite=rewrite;subsume=subsume;literals=literals; - equations=equations;subterms=subterms;allSubterms=allSubterms} = 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 @@ -8966,8 +8656,8 @@ let addClause active cl = let addFactorClause active cl = let Active - {parameters=parameters;clauses=clauses;units=units;rewrite=rewrite;subsume=subsume;literals=literals; - equations=equations;subterms=subterms;allSubterms=allSubterms} = active + {parameters;clauses;units;rewrite;subsume;literals; + equations;subterms;allSubterms} = active in let units = addUnit units cl and rewrite = addRewrite rewrite cl in @@ -8988,7 +8678,7 @@ let deduceResolution literals cl ((_,atm) as lit, acc) = print_endline ("lit1 = " ^ Literal.toString lit1); print_endline ("cl = " ^ Clause.toString cl); print_endline ("lit = " ^ Literal.toString lit);*) - match total (Clause.resolve cl_lit) (cl,lit) with + match Useful.total (Clause.resolve cl_lit) (cl,lit) with Some cl' -> cl' :: acc | None -> acc (*MetisTrace4 @@ -9002,7 +8692,7 @@ let deduceResolution literals cl ((_,atm) as lit, acc) = 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 + match Useful.total (Clause.paramodulate (cl,lit,ort,tm)) cl_lit_path_tm with Some cl' -> cl' :: acc | None -> acc in @@ -9011,7 +8701,7 @@ let deduceParamodulationWith subterms cl ((lit,ort,tm),acc) = 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 + match Useful.total (Clause.paramodulate cl_lit_ort_tm) (cl,lit,path,tm) with Some cl' -> cl' :: acc | None -> acc in @@ -9019,7 +8709,7 @@ let deduceParamodulationInto equations cl ((lit,path,tm),acc) = ;; let deduce active cl = - let Active {parameters=parameters;literals=literals;equations=equations;subterms=subterms} = active + let Active {parameters;literals;equations;subterms} = active in let lits = Clause.largestLiterals cl in let eqns = Clause.largestEquations cl @@ -9056,7 +8746,7 @@ let deduce active cl = (* ------------------------------------------------------------------------- *) let clause_rewritables active = - let Active {clauses=clauses;rewrite=rewrite} = active + let Active {clauses;rewrite} = active in let rewr (id,cl,ids) = let cl' = Clause.rewrite rewrite cl @@ -9078,8 +8768,8 @@ let deduce active cl = | Some _ -> [];; let rewrite_rewritables active rewr_ids = - let Active {parameters=parameters;rewrite=rewrite;clauses=clauses;allSubterms=allSubterms} = active - in let {clause = {Clause.ordering=ordering}} = parameters + let Active {parameters;rewrite;clauses;allSubterms} = active + in let {clause = {Clause.ordering}} = parameters in let order = Knuth_bendix_order.compare ordering in let addRewr (id,acc) = @@ -9087,13 +8777,13 @@ let deduce active cl = in let addReduce ((l,r,ord),acc) = let isValidRewr tm = - match total (Substitute.matchTerms Substitute.empty l) tm with + 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 Greater + order tm tm' = Some 1 in let addRed ((cl,tm),acc) = (*MetisTrace5 @@ -9156,7 +8846,7 @@ let deduce active cl = let () = Print.trace ppIds "Active.rewritables: rewrite_ids" rewrite_ids in - raise Bug "Active.rewritables: ~(rewrite_ids SUBSET clause_ids)" + raise Useful.Bug "Active.rewritables: ~(rewrite_ids SUBSET clause_ids)" end in if choose_clause_rewritables active ids then clause_ids else rewrite_ids @@ -9171,15 +8861,15 @@ let deduce active cl = in let clausePred cl = idPred (Clause.id cl) in let Active - {parameters=parameters; - clauses=clauses; - units=units; - rewrite=rewrite; - subsume=subsume; - literals=literals; - equations=equations; - subterms=subterms; - allSubterms=allSubterms} = active + {parameters; + clauses; + units; + rewrite; + subsume; + literals; + equations; + subterms; + allSubterms} = active in let cP1 (x,_) = clausePred x in let cP1_4 (x,_,_,_) = clausePred x @@ -9202,7 +8892,7 @@ let deduce active cl = allSubterms = allSubterms} ;; - let extract_rewritables (Active {clauses=clauses;rewrite=rewrite} as active) = + let extract_rewritables (Active {clauses;rewrite} as active) = if Rewrite.isReduced rewrite then (active,[]) else (*MetisTrace3 @@ -9219,8 +8909,8 @@ let deduce active cl = in (delete active ids, cls) (*MetisDebug - handle Error err -> - raise (Bug ("Active.extract_rewritables: shouldn't fail\n" ^ err));; + handle Failure err -> + raise (Useful.Bug ("Active.extract_rewritables: shouldn't fail\n" ^ err));; *) ;; @@ -9229,15 +8919,15 @@ let deduce active cl = (* ------------------------------------------------------------------------- *) let prefactor_simplify active subsume = - let Active {parameters=parameters;units=units;rewrite=rewrite} = active - in let {prefactor=prefactor} = parameters + let Active {parameters;units;rewrite} = active + in let {prefactor} = parameters in simplify prefactor units rewrite subsume ;; let postfactor_simplify active subsume = - let Active {parameters=parameters;units=units;rewrite=rewrite} = active - in let {postfactor=postfactor} = parameters + let Active {parameters;units;rewrite} = active + in let {postfactor} = parameters in simplify postfactor units rewrite subsume ;; @@ -9249,7 +8939,7 @@ let deduce active cl = | 1 -> if Thm.isUnitEq (Clause.thm cl) then 0 else 1 | n -> n in - sortMap utility Int.compare + Mlist.sortMap utility Int.compare ;; let rec post_factor (cl, ((active,subsume,acc) as active_subsume_acc)) = @@ -9318,8 +9008,8 @@ let factor = fun active -> fun cls -> let mk_clause params th = Clause.mk {Clause.parameters = params; Clause.id = Clause.newId (); Clause.thm = th};; -let newActive parameters {axioms_thm=axioms_thm;conjecture_thm=conjecture_thm} = - let {clause=clause} = parameters +let newActive parameters {axioms_thm;conjecture_thm} = + let {clause} = parameters in let mk_clause = mk_clause clause in let active = empty parameters @@ -9364,15 +9054,13 @@ end module Waiting = struct -open Useful;; open Ax_cj -open Real (* ------------------------------------------------------------------------- *) (* A type of waiting sets of clauses. *) (* ------------------------------------------------------------------------- *) -type weight = real;; +type weight = float;; type modelParameters = {model : Model.parameters; @@ -9387,7 +9075,7 @@ type parameters = literalsWeight : weight; modelsP : modelParameters list};; -type distance = real;; +type distance = float;; type waiting_t = {parameters : parameters; @@ -9414,9 +9102,9 @@ let default : parameters = variablesWeight = 1.0; modelsP = defaultModels};; -let size (Waiting {clauses=clauses}) = Heap.size clauses;; +let size (Waiting {clauses}) = Heap.size clauses;; -let toString w = "Waiting{" ^ Int.toString (size w) ^ "}";; +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));;*) @@ -9446,7 +9134,7 @@ let mkModelClause cl = let mkModelClauses = List.map mkModelClause;; let perturbModel vM cls = - if Mlist.null cls then kComb () + if Mlist.null cls then K () else let vN = {Model.size = Model.msize vM} @@ -9456,13 +9144,13 @@ let perturbModel vM cls = if Model.interpretClause vM vV cl then () else Model.perturbClause vM vV cl - in let perturbClauses () = app perturbClause cls + in let perturbClauses () = List.iter perturbClause cls in fun n -> funpow n perturbClauses () ;; let initialModel axioms conjecture parm = - let {model=model;initialPerturbations=initialPerturbations} = parm + let {model;initialPerturbations} = parm in let m = Model.newModel model in let () = perturbModel m conjecture initialPerturbations in let () = perturbModel m axioms initialPerturbations @@ -9472,64 +9160,64 @@ let initialModel axioms conjecture parm = let checkModels parms models (fv,cl) = let check ((parm,model),z) = - let {maxChecks=maxChecks;weight=weight} = parm + let {maxChecks;weight} = parm in let n = maxChecks in let (vT,vF) = Model.check Model.interpretClause n model fv cl in - Math.pow (1.0 +. Real.fromInt vT /. Real.fromInt (vT + vF), weight) *. z + (1.0 +. float_of_int vT /. float_of_int (vT + vF) ** weight) *. z in Mlist.foldl check 1.0 (zip parms models) ;; let perturbModels parms models cls = let perturb (parm,model) = - let {perturbations=perturbations} = parm + let {perturbations} = parm in perturbModel model cls perturbations in - app perturb (zip parms models) + List.iter perturb (zip parms models) ;; (* ------------------------------------------------------------------------- *) (* Clause weights. *) (* ------------------------------------------------------------------------- *) - let clauseSymbols cl = Real.fromInt (Literal.Set.typedSymbols cl);; + let clauseSymbols cl = float_of_int (Literal.Set.typedSymbols cl);; let clauseVariables cl = - Real.fromInt (Name.Set.size (Literal.Set.freeVars cl) + 1);; + float_of_int (Name.Set.size (Literal.Set.freeVars cl) + 1);; - let clauseLiterals cl = Real.fromInt (Literal.Set.size cl);; + let clauseLiterals cl = float_of_int (Literal.Set.size cl);; - let clausePriority cl = 1e-12 *. Real.fromInt (Clause.id cl);; + let clausePriority cl = 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 {symbolsWeight=symbolsWeight;variablesWeight=variablesWeight;literalsWeight=literalsWeight;modelsP=modelsP} = parm + let {symbolsWeight;variablesWeight;literalsWeight;modelsP} = parm in let lits = Clause.literals cl - in let symbolsW = Math.pow (clauseSymbols lits, symbolsWeight) - in let variablesW = Math.pow (clauseVariables lits, variablesWeight) - in let literalsW = Math.pow (clauseLiterals lits, literalsWeight) + 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 = " ^ - Real.toString dist ^ "\n") + Float.to_string dist ^ "\n") let () = trace ("Waiting.clauseWeight: symbolsW = " ^ - Real.toString symbolsW ^ "\n") + Float.to_string symbolsW ^ "\n") let () = trace ("Waiting.clauseWeight: variablesW = " ^ - Real.toString variablesW ^ "\n") + Float.to_string variablesW ^ "\n") let () = trace ("Waiting.clauseWeight: literalsW = " ^ - Real.toString literalsW ^ "\n") + Float.to_string literalsW ^ "\n") let () = trace ("Waiting.clauseWeight: modelsW = " ^ - Real.toString modelsW ^ "\n") + Float.to_string modelsW ^ "\n") *) in let weight = dist *. symbolsW *. variablesW *. literalsW *. modelsW in let weight = weight +. clausePriority cl (*MetisTrace3 let () = trace ("Waiting.clauseWeight: weight = " ^ - Real.toString weight ^ "\n") + Float.to_string weight ^ "\n") *) in weight @@ -9540,18 +9228,18 @@ let perturbModels parms models cls = (* ------------------------------------------------------------------------- *) let add' waiting dist mcls cls = - let Waiting {parameters=parameters;clauses=clauses;models=models} = waiting + let Waiting {parameters;clauses;models} = waiting in let {modelsP = modelParameters} = parameters (*MetisDebug let _ = not (Mlist.null cls) || - raise Bug "Waiting.add': null" + raise Useful.Bug "Waiting.add': null" let _ = length mcls = length cls || - raise Bug "Waiting.add': different lengths" + raise Useful.Bug "Waiting.add': different lengths" *) - in let dist = dist +. Math.ln (Real.fromInt (length cls)) + in let dist = dist +. log (float_of_int (length cls)) in let addCl ((mcl,cl),acc) = let weight = clauseWeight parameters models dist mcl cl @@ -9582,7 +9270,7 @@ let add waiting (dist,cls) = waiting ;; - let cmp ((w1,_),(w2,_)) = Real.compare (w1,w2);; + let cmp (w1,_) (w2,_) = Float.compare w1 w2;; let empty parameters axioms conjecture = let {modelsP = modelParameters} = parameters @@ -9592,7 +9280,7 @@ let add waiting (dist,cls) = Waiting {parameters = parameters; clauses = clauses; models = models} ;; - let newWaiting parameters {axioms_cl=axioms_cl;conjecture_cl=conjecture_cl} = + let newWaiting parameters {axioms_cl;conjecture_cl} = let mAxioms = mkModelClauses axioms_cl and mConjecture = mkModelClauses conjecture_cl @@ -9613,7 +9301,7 @@ let add waiting (dist,cls) = (* Removing the lightest clause. *) (* ------------------------------------------------------------------------- *) -let remove (Waiting {parameters=parameters;clauses=clauses;models=models}) = +let remove (Waiting {parameters;clauses;models}) = if Heap.null clauses then None else let ((_,dcl),clauses) = Heap.remove clauses @@ -9636,8 +9324,6 @@ end module Resolution = struct -open Useful;; - (* ------------------------------------------------------------------------- *) (* A type of resolution proof procedures. *) (* ------------------------------------------------------------------------- *) @@ -9697,7 +9383,7 @@ type state = | Undecided of resolution;; let iterate res = - let Resolution {parameters=parameters;active=active;waiting=waiting} = res + let Resolution {parameters;active;waiting} = res (*MetisTrace2 let () = Print.trace Active.pp "Resolution.iterate: active" active @@ -10195,11 +9881,11 @@ open Metis_prover let metis_name = string_of_int let rec metis_of_term env consts tm = - if is_var tm && not (mem tm consts) then + if is_var tm && not (List.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 + if List.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)) @@ -10210,7 +9896,7 @@ let metis_of_atom env consts tm = 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 + 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) @@ -10357,7 +10043,7 @@ let SIMPLE_METIS_REFUTE ths = Format.printf "Metis end.\n%!"; end; let allhyps = List.concat (List.map hyp ths) in - assert (forall (fun h -> mem h allhyps) (hyp proof)); + assert (forall (fun h -> List.mem h allhyps) (hyp proof)); assert (concl proof = `F`); proof From 2264f317788b825428fa9b5cca3e00e4e80ba47b Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Sat, 28 Feb 2026 09:51:34 +0800 Subject: [PATCH 21/79] Restore compatibility with OCaml 4.06, Camlp5 7.10 (#154) * metis.ml: Remove references to Int and Bool modules Seems like these are only available starting 4.08. Patch received from John Harrison, generated by Claude. * Revert "metis.ml: Replace {foo=foo} pattern matching with {foo}" This reverts commit aa397c044de616c693bda7d52143bb227b5cb1dd. Seems like this causes parsing issues in old versions (OCaml 4.06, Camlp5 7.10) * metis.ml: Implement parts of the Option module * metis.ml: Remove references to Float module --- metis.ml | 289 ++++++++++++++++++++++++++++++------------------------- 1 file changed, 157 insertions(+), 132 deletions(-) diff --git a/metis.ml b/metis.ml index 14f3eb64..b7fcee9a 100644 --- a/metis.ml +++ b/metis.ml @@ -29,7 +29,7 @@ module Metis_prover = struct module Word = struct type word = int;; -let compare x y = Int.compare x y;; +let compare (x : word) (y : word) = compare x y;; let shiftLeft (x, y) = x lsl y;; let shiftRight (x, y) = x lsr y;; @@ -88,6 +88,24 @@ let sortMap f cmp = function 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 *) (* ========================================================================= *) @@ -137,6 +155,13 @@ let lexCompare cmp = 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 (x : int) y = compare x y;; + (* ------------------------------------------------------------------------- *) (* Strings. *) (* ------------------------------------------------------------------------- *) @@ -355,7 +380,7 @@ let rec treeLeftSpine acc tree = | Tree node -> nodeLeftSpine acc node and nodeLeftSpine acc node = - let {left} = node + let {left=left} = node in treeLeftSpine (node :: acc) left ;; @@ -366,7 +391,7 @@ let rec treeRightSpine acc tree = | Tree node -> nodeRightSpine acc node and nodeRightSpine acc node = - let {right} = node + let {right=right} = node in treeRightSpine (node :: acc) right ;; @@ -413,13 +438,13 @@ let rec treeAppend tree1 tree2 = Empty -> tree1 | Tree node2 -> if lowerPriorityNode node1 node2 then - let {priority;left;key;value;right} = node2 + let {priority=priority;left=left;key=key;value=value;right=right} = node2 in let left = treeAppend tree1 left in mkTree priority left key value right else - let {priority;left;key;value;right} = node1 + let {priority=priority;left=left;key=key;value=value;right=right} = node1 in let right = treeAppend right tree2 in @@ -448,7 +473,7 @@ let rec treePeek compareKey pkey tree = | Tree node -> nodePeek compareKey pkey node and nodePeek compareKey pkey node = - let {left;key;value;right} = node + let {left=left;key=key;value=value;right=right} = node in let c = compareKey pkey key in if c < 0 then treePeek compareKey pkey left @@ -468,7 +493,7 @@ let rec treePeekPath compareKey pkey path tree = | Tree node -> nodePeekPath compareKey pkey path node and nodePeekPath compareKey pkey path node = - let {left;key;right} = node + let {left=left;key=key;right=right} = node in let c = compareKey pkey key in if c < 0 then treePeekPath compareKey pkey ((true,node) :: path) left @@ -479,7 +504,7 @@ and nodePeekPath compareKey pkey path node = (* A path splits a tree into left/right components *) let addSidePath ((wentLeft,node),(leftTree,rightTree)) = - let {priority;left;key;value;right} = node + let {priority=priority;left=left;key=key;value=value;right=right} = node in if wentLeft then (leftTree, mkTree priority rightTree key value right) else (mkTree priority left key value leftTree, rightTree) @@ -492,7 +517,7 @@ let mkSidesPath path = addSidesPath (Empty,Empty) path;; (* Updating the subtree at a path *) let updateTree ((wentLeft,node),tree) = - let {priority;left;key;value;right} = node + let {priority=priority;left=left;key=key;value=value;right=right} = node in if wentLeft then mkTree priority tree key value right else mkTree priority left key value tree;; @@ -537,7 +562,7 @@ let nodePartition compareKey pkey node = in (left,None,right) | Some node -> - let {left;key;value;right} = node + let {left=left;key=key;value=value;right=right} = node in let (left,right) = addSidesPath (left,right) path in @@ -554,7 +579,7 @@ let rec treePeekKey compareKey pkey tree = | Tree node -> nodePeekKey compareKey pkey node and nodePeekKey compareKey pkey node = - let {left;key;value;right} = node + let {left=left;key=key;value=value;right=right} = node in let c = compareKey pkey key in if c < 0 then treePeekKey compareKey pkey left @@ -577,7 +602,7 @@ let treeInsert compareKey key_value tree = in insertNodePath node path | Some node -> - let {size;priority;left;right} = node + let {size=size;priority=priority;left=left;right=right} = node in let node = {size = size; @@ -601,7 +626,7 @@ let rec treeDelete compareKey dkey tree = | Tree node -> nodeDelete compareKey dkey node and nodeDelete compareKey dkey node = - let {size;priority;left;key;value;right} = node + let {size=size;priority=priority;left=left;key=key;value=value;right=right} = node in let c = compareKey dkey key in if c < 0 then @@ -643,7 +668,7 @@ let rec treeMapPartial f tree = Empty -> Empty | Tree node -> nodeMapPartial f node -and nodeMapPartial f ({priority;left;key;value;right}) = +and nodeMapPartial f ({priority=priority;left=left;key=key;value=value;right=right}) = let left = treeMapPartial f left and vo = f (key,value) and right = treeMapPartial f right @@ -663,7 +688,7 @@ let rec treeMap f tree = | Tree node -> Tree (nodeMap f node) and nodeMap f node = - let {size;priority;left;key;value;right} = node + let {size=size;priority=priority;left=left;key=key;value=value;right=right} = node in let left = treeMap f left and value = f (key,value) @@ -691,7 +716,7 @@ let rec treeMerge compareKey f1 f2 fb tree1 tree2 = | Tree node2 -> nodeMerge compareKey f1 f2 fb node1 node2 and nodeMerge compareKey f1 f2 fb node1 node2 = - let {priority;left;key;value;right} = node2 + let {priority=priority;left=left;key=key;value=value;right=right} = node2 in let (l,kvo,r) = nodePartition compareKey key node1 @@ -726,7 +751,7 @@ let rec treeUnion compareKey f f2 tree1 tree2 = and nodeUnion compareKey f f2 node1 node2 = if node1 == node2 then nodeMapPartial f2 node1 else - let {priority;left;key;value;right} = node2 + let {priority=priority;left=left;key=key;value=value;right=right} = node2 in let (l,kvo,r) = nodePartition compareKey key node1 @@ -759,7 +784,7 @@ let rec treeIntersect compareKey f t1 t2 = | Tree n2 -> nodeIntersect compareKey f n1 n2 and nodeIntersect compareKey f n1 n2 = - let {priority;left;key;value;right} = n2 + let {priority=priority;left=left;key=key;value=value;right=right} = n2 in let (l,kvo,r) = nodePartition compareKey key n1 @@ -791,7 +816,7 @@ let rec treeUnionDomain compareKey tree1 tree2 = else nodeUnionDomain compareKey node1 node2 and nodeUnionDomain compareKey node1 node2 = - let {priority;left;key;value;right} = node2 + let {priority=priority;left=left;key=key;value=value;right=right} = node2 in let (l,_,r) = nodePartition compareKey key node1 @@ -818,7 +843,7 @@ let rec treeIntersectDomain compareKey tree1 tree2 = else nodeIntersectDomain compareKey node1 node2 and nodeIntersectDomain compareKey node1 node2 = - let {priority;left;key;value;right} = node2 + let {priority=priority;left=left;key=key;value=value;right=right} = node2 in let (l,kvo,r) = nodePartition compareKey key node1 @@ -844,7 +869,7 @@ let rec treeDifferenceDomain compareKey t1 t2 = and nodeDifferenceDomain compareKey n1 n2 = if n1 == n2 then Empty else - let {priority;left;key;value;right} = n1 + let {priority=priority;left=left;key=key;value=value;right=right} = n1 in let (l,kvo,r) = nodePartition compareKey key n2 @@ -869,7 +894,7 @@ let rec treeSubsetDomain compareKey tree1 tree2 = and nodeSubsetDomain compareKey node1 node2 = node1 == node2 || - let {size;left;key;right} = node1 + let {size=size;left=left;key=key;right=right} = node1 in size <= nodeSize node2 && let (l,kvo,r) = nodePartition compareKey key node2 @@ -884,7 +909,7 @@ and nodeSubsetDomain compareKey node1 node2 = (* ------------------------------------------------------------------------- *) let rec nodePick node = - let {key;value} = node + let {key=key;value=value} = node in (key,value) ;; @@ -899,7 +924,7 @@ let treePick tree = (* ------------------------------------------------------------------------- *) let rec nodeDeletePick node = - let {left;key;value;right} = node + let {left=left;key=key;value=value;right=right} = node in ((key,value), treeAppend left right) ;; @@ -919,7 +944,7 @@ let rec treeNth n tree = | Tree node -> nodeNth n node and nodeNth n node = - let {left;key;value;right} = node + let {left=left;key=key;value=value;right=right} = node in let k = treeSize left in @@ -938,7 +963,7 @@ let rec treeDeleteNth n tree = | Tree node -> nodeDeleteNth n node and nodeDeleteNth n node = - let {size;priority;left;key;value;right} = node + let {size=size;priority=priority;left=left;key=key;value=value;right=right} = node in let k = treeSize left in @@ -988,13 +1013,13 @@ type ('key,'value) iterator = let fromSpineLeftToRightIterator nodes = match nodes with [] -> None - | {key;value;right} :: nodes -> + | {key=key;value=value;right=right} :: nodes -> Some (Left_to_right_iterator ((key,value),right,nodes));; let fromSpineRightToLeftIterator nodes = match nodes with [] -> None - | {key;value;left} :: nodes -> + | {key=key;value=value;left=left} :: nodes -> Some (Right_to_left_iterator ((key,value),left,nodes));; let addLeftToRightIterator nodes tree = fromSpineLeftToRightIterator (treeLeftSpine nodes tree);; @@ -1371,7 +1396,7 @@ let count pred = let compare compareValue m1 m2 = if m1 == m2 then 0 else - let c = Int.compare (size m1) (size m2) in + let c = Useful.intCompare (size m1) (size m2) in if c <> 0 then c else let Map (compareKey,_) = m1 @@ -2076,7 +2101,7 @@ and ternary = nary 3;; let compare (n1,i1) (n2,i2) = let c = Name.compare n1 n2 in - if c <> 0 then c else Int.compare i1 i2;; + if c <> 0 then c else Useful.intCompare i1 i2;; let equal (n1,i1) (n2,i2) = i1 = i2 && Name.equal n1 n2;; @@ -2227,7 +2252,7 @@ let compare tm1 tm2 = let c = Name.compare f1 f2 in if c <> 0 then c else - let c = Int.compare (List.length a1) (List.length a2) in + 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]);; @@ -3500,7 +3525,7 @@ let symbols ((_,atm) : literal) = Atom.symbols atm;; (* A total comparison function for literals. *) (* ------------------------------------------------------------------------- *) -let compare = Useful.prodCompare Bool.compare Atom.compare;; +let compare = Useful.prodCompare Useful.boolCompare Atom.compare;; let equal (p1,atm1) (p2,atm2) = p1 = p2 && Atom.equal atm1 atm2;; @@ -6407,9 +6432,9 @@ let foldEqualTerms pat inc acc = (* Filter afterwards to get the precise set of satisfying values. *) (* ------------------------------------------------------------------------- *) - let idwise (m,_) (n,_) = Int.compare m n;; + let idwise (m,_) (n,_) = Useful.intCompare m n;; - let fifoize ({fifo} : parameters) l = if fifo then List.sort idwise l else l;; + let fifoize ({fifo=fifo} : parameters) l = if fifo then List.sort idwise l else l;; let finally parm l = List.map snd (fifoize parm l);; @@ -6586,16 +6611,16 @@ type 'a literalNet = let newNet parm = {positive = Atom_net.newNet parm; negative = Atom_net.newNet parm};; - let pos ({positive} : 'a literalNet) = Atom_net.size positive;; + let pos ({positive=positive} : 'a literalNet) = Atom_net.size positive;; - let neg ({negative} : 'a literalNet) = Atom_net.size negative;; + let neg ({negative=negative} : 'a literalNet) = Atom_net.size negative;; let size net = pos net + neg net;; (*let profile net = {positiveN = pos net; negativeN = neg net};;*) -let insert {positive;negative} = function +let insert {positive=positive;negative=negative} = function ((true,atm),a) -> {positive = Atom_net.insert positive (atm,a); negative = negative} | ((false,atm),a) -> @@ -6603,7 +6628,7 @@ let insert {positive;negative} = function let fromList parm l = Mlist.foldl (fun (lit_a,n) -> insert n lit_a) (newNet parm) l;; -let filter pred {positive;negative} = +let filter pred {positive=positive;negative=negative} = {positive = Atom_net.filter pred positive; negative = Atom_net.filter pred negative};; @@ -6617,17 +6642,17 @@ let toString net = "Literal_net[" ^ string_of_int (size net) ^ "]";; (* Filter afterwards to get the precise set of satisfying values. *) (* ------------------------------------------------------------------------- *) -let matchNet ({positive;negative} : 'a literalNet) = function +let matchNet ({positive=positive;negative=negative} : 'a literalNet) = function (true,atm) -> Atom_net.matchNet positive atm | (false,atm) -> Atom_net.matchNet negative atm;; -let matched ({positive;negative} : 'a literalNet) = function +let matched ({positive=positive;negative=negative} : 'a literalNet) = function (true,atm) -> Atom_net.matched positive atm | (false,atm) -> Atom_net.matched negative atm;; -let unify ({positive;negative} : 'a literalNet) = function +let unify ({positive=positive;negative=negative} : 'a literalNet) = function (true,atm) -> Atom_net.unify positive atm | (false,atm) -> Atom_net.unify negative atm;; @@ -6664,7 +6689,7 @@ let findRest pred = let sortClause cl = let lits = Literal.Set.toList cl in - Mlist.sortMap Literal.typedSymbols (Useful.revCompare Int.compare) lits + Mlist.sortMap Literal.typedSymbols (Useful.revCompare Useful.intCompare) lits ;; let incompatible lit = @@ -6684,8 +6709,8 @@ type clauseLength = int;; type idSet = (clauseId * clauseLength) Pset.set;; let idCompare (id1,len1) (id2,len2) = - let c = Int.compare len1 len2 in - if c <> 0 then c else Int.compare id1 id2;; + let c = Useful.intCompare len1 len2 in + if c <> 0 then c else Useful.intCompare id1 id2;; let idSetEmpty : idSet = Pset.empty idCompare;; @@ -6721,10 +6746,10 @@ let newSubsume () = fstLits = Literal_net.newNet {fifo = false}; sndLits = Literal_net.newNet {fifo = false}}};; -let size ({empty; unitn; nonunit = {clauses}}) = +let size ({empty=empty; unitn=unitn; nonunit = {clauses=clauses}}) = length empty + Literal_net.size unitn + Intmap.size clauses;; -let insert ({empty;unitn;nonunit}) (cl',a) = +let insert ({empty=empty;unitn=unitn;nonunit=nonunit}) (cl',a) = match sortClause cl' with [] -> let empty = (cl',Substitute.empty,a) :: empty @@ -6735,7 +6760,7 @@ let insert ({empty;unitn;nonunit}) (cl',a) = in {empty = empty; unitn = unitn; nonunit = nonunit} | fstLit :: (sndLit :: otherLits as nonFstLits) -> - let {nextId;clauses;fstLits;sndLits} = nonunit + let {nextId=nextId;clauses=clauses;fstLits=fstLits;sndLits=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) = @@ -6752,14 +6777,14 @@ let insert ({empty;unitn;nonunit}) (cl',a) = {empty = empty; unitn = unitn; nonunit = nonunit} ;; -let filter pred ({empty;unitn;nonunit}) = +let filter pred ({empty=empty;unitn=unitn;nonunit=nonunit}) = let pred3 (_,_,x) = pred x in let empty = List.filter pred3 empty in let unitn = Literal_net.filter pred3 unitn in let nonunit = - let {nextId;clauses;fstLits;sndLits} = nonunit + let {nextId=nextId;clauses=clauses;fstLits=fstLits;sndLits=sndLits} = nonunit in let clauses' = Intmap.filter (fun x -> pred3 (snd x)) clauses in if Intmap.size clauses = Intmap.size clauses' then nonunit @@ -6788,7 +6813,7 @@ let toString subsume = "Subsume{" ^ string_of_int (size subsume) ^ "}";; let genClauseSubsumes pred cl' lits' cl a = let rec mkSubsl acc sub = function - [] -> Some (sub, Mlist.sortMap length Int.compare acc) + [] -> Some (sub, Mlist.sortMap length Useful.intCompare acc) | (lit' :: lits') -> match Mlist.foldl (matchLit lit') [] cl with [] -> None @@ -6841,7 +6866,7 @@ let toString subsume = "Subsume{" ^ string_of_int (size subsume) ^ "}";; in let subLit lits (lit,acc) = Mlist.foldl addId acc (Literal_net.matchNet lits lit) - in let {nextId = _; clauses; fstLits; sndLits} = nonunit + in let {nextId = _; clauses=clauses; fstLits=fstLits; sndLits=sndLits} = nonunit in let subCl' (id,_) = let (lits',cl',a) = Intmap.get clauses id @@ -6855,7 +6880,7 @@ let toString subsume = "Subsume{" ^ string_of_int (size subsume) ^ "}";; Pset.firstl subCl' cands ;; - let genSubsumes pred ({empty;unitn;nonunit}) max cl = + let genSubsumes pred ({empty=empty;unitn=unitn;nonunit=nonunit}) max cl = match emptySubsumes pred empty with (Some _) as s -> s | None -> @@ -6968,7 +6993,7 @@ let uniformWeight : Term.function_t -> int = K 1;; let arityPrecedence : Term.function_t -> Term.function_t -> int = fun (f1,n1) (f2,n2) -> - let c = Int.compare n1 n2 in + let c = Useful.intCompare n1 n2 in if c <> 0 then c else Name.compare f1 f2;; (* The default order *) @@ -7050,7 +7075,7 @@ let weightToString = Print.toString ppWeight;; (* The Knuth-Bendix term order. *) (* ------------------------------------------------------------------------- *) -let compare {weight;precedence} = +let compare {weight=weight;precedence=precedence} = let weightDifference tm1 tm2 = let w1 = weightTerm weight tm1 and w2 = weightTerm weight tm2 @@ -7163,14 +7188,14 @@ type rewrite = Rewrite of rewrite_t;; let updateWaiting rw waiting = - let Rewrite {order; known; redexes; subterms; waiting = _} = rw + let Rewrite {order=order; known=known; redexes=redexes; subterms=subterms; waiting = _} = rw in Rewrite {order = order; known = known; redexes = redexes; subterms = subterms; waiting = waiting} ;; -let deleteWaiting (Rewrite {waiting} as rw) id = +let deleteWaiting (Rewrite {waiting=waiting} as rw) id = updateWaiting rw (Intset.delete waiting id);; (* ------------------------------------------------------------------------- *) @@ -7186,11 +7211,11 @@ let newRewrite order = subterms = Term_net.newNet {fifo = false}; waiting = Intset.empty};; -let peek (Rewrite {known}) id = Intmap.peek known id;; +let peek (Rewrite {known=known}) id = Intmap.peek known id;; -let size (Rewrite {known}) = Intmap.size known;; +let size (Rewrite {known=known}) = Intmap.size known;; -let equations (Rewrite {known}) = +let equations (Rewrite {known=known}) = Intmap.foldr (fun (_,(eqn,_),eqns) -> eqn :: eqns) [] known;; @@ -7301,10 +7326,10 @@ let orderToOrient = function | None -> ins (ins redexes l id Left_to_right) r id Right_to_left;; -let add (Rewrite {known} as rw) (id,eqn) = +let add (Rewrite {known=known} as rw) (id,eqn) = if Intmap.inDomain id known then rw else - let Rewrite {order;redexes;subterms;waiting} = rw + let Rewrite {order=order;redexes=redexes;subterms=subterms;waiting=waiting} = rw in let ort = let (l,r) = fst eqn in orderToOrient (order l r) @@ -7332,7 +7357,7 @@ let add (Rewrite {known} as rw) (id,eqn) = (* Rewriting (the order must be a refinement of the rewrite order). *) (* ------------------------------------------------------------------------- *) - let reorder (i,_) (j,_) = Int.compare j i;; + let reorder (i,_) (j,_) = Useful.intCompare j i;; let matchingRedexes redexes tm = List.sort reorder (Term_net.matchNet redexes tm);; @@ -7507,23 +7532,23 @@ let rewriteIdRule' = fun order -> fun known -> fun redexes -> fun id -> fun th - handle Failure err -> failwith ("Rewrite.rewriteIdRule:\n" ^ err);; *) -let rewrIdConv (Rewrite {known;redexes}) order = +let rewrIdConv (Rewrite {known=known;redexes=redexes}) order = rewrIdConv' order known redexes;; let rewrConv rewrite order = rewrIdConv rewrite order (-1);; -let rewriteIdConv (Rewrite {known;redexes}) order = +let rewriteIdConv (Rewrite {known=known;redexes=redexes}) order = rewriteIdConv' order known redexes;; let rewriteConv rewrite order = rewriteIdConv rewrite order (-1);; -let rewriteIdLiteralsRule (Rewrite {known;redexes}) order = +let rewriteIdLiteralsRule (Rewrite {known=known;redexes=redexes}) order = rewriteIdLiteralsRule' order known redexes;; let rewriteLiteralsRule rewrite order = rewriteIdLiteralsRule rewrite order (-1);; -let rewriteIdRule (Rewrite {known;redexes}) order = +let rewriteIdRule (Rewrite {known=known;redexes=redexes}) order = rewriteIdRule' order known redexes;; let rewriteRule rewrite order = rewriteIdRule rewrite order (-1);; @@ -7579,7 +7604,7 @@ let findReducibles order known subterms id = 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 Rewrite {order=order;known=known;redexes=redexes;subterms=subterms;waiting=waiting} = rw in let (eq,_) as eqn = rewriteIdEqn' order known redexes id eqn0 in let identical = let (l0,r0) = eq0 @@ -7677,7 +7702,7 @@ let pick known set = let () = Print.trace ppPl "Rewrite.rebuild: rpl" rpl let () = Print.trace ppPl "Rewrite.rebuild: spl" spl *) - let Rewrite {order;known;redexes;subterms;waiting} = rw + let Rewrite {order=order;known=known;redexes=redexes;subterms=subterms;waiting=waiting} = rw in let redexes = cleanRedexes known redexes rpl in let subterms = cleanSubterms known subterms spl in @@ -7689,7 +7714,7 @@ let pick known set = waiting = waiting} ;; -let rec reduceAcc (rpl, spl, todo, (Rewrite {known;waiting} as rw), changed) = +let rec reduceAcc (rpl, spl, todo, (Rewrite {known=known;waiting=waiting} as rw), changed) = match pick known todo with Some (id,eqn_ort) -> let todo = Intset.delete todo id @@ -7703,7 +7728,7 @@ let rec reduceAcc (rpl, spl, todo, (Rewrite {known;waiting} as rw), changed) = 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 isReduced (Rewrite {waiting=waiting}) = Intset.null waiting;; let reduce' rw = if isReduced rw then (rw,[]) @@ -7890,7 +7915,7 @@ type clause = Clause of clauseInfo;; (* Pretty printing. *) (* ------------------------------------------------------------------------- *) -let toString (Clause {id;thm}) = Thm.toString thm;; +let toString (Clause {id=id;thm=thm}) = Thm.toString thm;; (* ------------------------------------------------------------------------- *) @@ -7917,9 +7942,9 @@ let newClause parameters thm = let literals cl = Thm.clause (thm cl);; -let isTautology (Clause {thm}) = Thm.isTautology thm;; +let isTautology (Clause {thm=thm}) = Thm.isTautology thm;; -let isContradiction (Clause {thm}) = Thm.isContradiction thm;; +let isContradiction (Clause {thm=thm}) = Thm.isContradiction thm;; (* ------------------------------------------------------------------------- *) (* The term ordering is used to cut down inferences. *) @@ -7930,7 +7955,7 @@ let strictlyLess ordering x y = Some c when c < 0 -> true | _ -> false;; -let isLargerTerm ({ordering;orderTerms} : parameters) (l,r) = +let isLargerTerm ({ordering=ordering;orderTerms=orderTerms} : parameters) (l,r) = not orderTerms || not (strictlyLess ordering l r);; let atomToTerms atm = @@ -7944,7 +7969,7 @@ let isLargerTerm ({ordering;orderTerms} : parameters) (l,r) = not (List.for_all less xs) ;; - let isLargerLiteral ({ordering;orderLiterals} : parameters) lits = + let isLargerLiteral ({ordering=ordering;orderLiterals=orderLiterals} : parameters) lits = match orderLiterals with No_literal_order -> K true | Unsigned_literal_order -> @@ -7968,7 +7993,7 @@ let isLargerTerm ({ordering;orderTerms} : parameters) (l,r) = ;; -let largestLiterals (Clause {parameters;thm}) = +let largestLiterals (Clause {parameters=parameters;thm=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 @@ -7988,7 +8013,7 @@ let largestLiterals = fun cl -> end;; *) -let largestEquations (Clause {parameters} as cl) = +let largestEquations (Clause {parameters=parameters} as cl) = let addEq lit ort ((l,_) as l_r) acc = if isLargerTerm parameters l_r then (lit,ort,l) :: acc else acc @@ -8025,20 +8050,20 @@ let subsumes (subs : clause Subsume.subsume) cl = (* Simplifying rules: these preserve the clause id. *) (* ------------------------------------------------------------------------- *) -let freshVars (Clause {parameters;id;thm}) = +let freshVars (Clause {parameters=parameters;id=id;thm=thm}) = Clause {parameters = parameters; id = id; thm = Rule.freshVars thm};; -let simplify (Clause {parameters;id;thm}) = +let simplify (Clause {parameters=parameters;id=id;thm=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}) = +let reduce units (Clause {parameters=parameters;id=id;thm=thm}) = Clause {parameters = parameters; id = id; thm = Units.reduce units thm};; -let rewrite rewr (Clause {parameters;id;thm}) = +let rewrite rewr (Clause {parameters=parameters;id=id;thm=thm}) = let simp th = - let {ordering} = parameters + let {ordering=ordering} = parameters in let cmp = Knuth_bendix_order.compare ordering in Rewrite.rewriteIdRule rewr cmp id th @@ -8069,7 +8094,7 @@ let rewrite rewr (Clause {parameters;id;thm}) = (* Inference rules: these generate new clause ids. *) (* ------------------------------------------------------------------------- *) -let factor (Clause {parameters;thm} as cl) = +let factor (Clause {parameters=parameters;thm=thm} as cl) = let lits = largestLiterals cl in let apply sub = newClause parameters (Thm.subst sub thm) @@ -8095,7 +8120,7 @@ let resolve (cl1,lit1) (cl2,lit2) = let () = Print.trace pp "Clause.resolve: cl2" cl2 let () = Print.trace Literal.pp "Clause.resolve: lit2" lit2 *) - let Clause {parameters; thm = th1} = cl1 + let Clause {parameters=parameters; thm = th1} = cl1 and Clause {thm = th2} = cl2 in let sub = Literal.unify Substitute.empty lit1 (Literal.negate lit2) (*MetisTrace5 @@ -8138,7 +8163,7 @@ let paramodulate (cl1,lit1,ort1,tm1) (cl2,lit2,path2,tm2) = let () = Print.trace Term.ppPath "Clause.paramodulate: path2" path2 let () = Print.trace Term.pp "Clause.paramodulate: tm2" tm2 *) - let Clause {parameters; thm = th1} = cl1 + let Clause {parameters=parameters; thm = th1} = cl1 and Clause {thm = th2} = cl2 in let sub = Substitute.unify Substitute.empty tm1 tm2 in let lit1 = Literal.subst sub lit1 @@ -8424,8 +8449,8 @@ let getSubsume (Active {subsume = s}) = s;; let setRewrite active rewrite = let Active - {parameters;clauses;units;subsume;literals;equations; - subterms;allSubterms} = active + {parameters=parameters;clauses=clauses;units=units;subsume=subsume;literals=literals;equations=equations; + subterms=subterms;allSubterms=allSubterms} = active in Active {parameters = parameters; clauses = clauses; units = units; @@ -8446,8 +8471,8 @@ let default : parameters = open Term_net let empty parameters = - let {clause} = parameters - in let {Clause.ordering} = clause + let {clause=clause} = parameters + in let {Clause.ordering=ordering} = clause in Active {parameters = parameters; @@ -8461,7 +8486,7 @@ let empty parameters = allSubterms = Term_net.newNet {fifo = false}} ;; -let size (Active {clauses}) = Intmap.size clauses;; +let size (Active {clauses=clauses}) = Intmap.size clauses;; let clauses (Active {clauses = cls}) = let add (_,cl,acc) = cl :: acc @@ -8580,7 +8605,7 @@ let simplify = fun simp -> fun units -> fun rewr -> fun subs -> fun cl -> *) let simplifyActive simp active = - let Active {units;rewrite;subsume} = active + let Active {units=units;rewrite=rewrite;subsume=subsume} = active in simplify simp units rewrite subsume ;; @@ -8638,8 +8663,8 @@ let addAllSubterms allSubterms cl = let addClause active cl = let Active - {parameters;clauses;units;rewrite;subsume;literals; - equations;subterms;allSubterms} = active + {parameters=parameters;clauses=clauses;units=units;rewrite=rewrite;subsume=subsume;literals=literals; + equations=equations;subterms=subterms;allSubterms=allSubterms} = active in let clauses = Intmap.insert clauses (Clause.id cl, cl) and subsume = addSubsume subsume cl and literals = addLiterals literals cl @@ -8656,8 +8681,8 @@ let addClause active cl = let addFactorClause active cl = let Active - {parameters;clauses;units;rewrite;subsume;literals; - equations;subterms;allSubterms} = active + {parameters=parameters;clauses=clauses;units=units;rewrite=rewrite;subsume=subsume;literals=literals; + equations=equations;subterms=subterms;allSubterms=allSubterms} = active in let units = addUnit units cl and rewrite = addRewrite rewrite cl in @@ -8709,7 +8734,7 @@ let deduceParamodulationInto equations cl ((lit,path,tm),acc) = ;; let deduce active cl = - let Active {parameters;literals;equations;subterms} = active + let Active {parameters=parameters;literals=literals;equations=equations;subterms=subterms} = active in let lits = Clause.largestLiterals cl in let eqns = Clause.largestEquations cl @@ -8746,7 +8771,7 @@ let deduce active cl = (* ------------------------------------------------------------------------- *) let clause_rewritables active = - let Active {clauses;rewrite} = active + let Active {clauses=clauses;rewrite=rewrite} = active in let rewr (id,cl,ids) = let cl' = Clause.rewrite rewrite cl @@ -8768,8 +8793,8 @@ let deduce active cl = | Some _ -> [];; let rewrite_rewritables active rewr_ids = - let Active {parameters;rewrite;clauses;allSubterms} = active - in let {clause = {Clause.ordering}} = parameters + let Active {parameters=parameters;rewrite=rewrite;clauses=clauses;allSubterms=allSubterms} = active + in let {clause = {Clause.ordering=ordering}} = parameters in let order = Knuth_bendix_order.compare ordering in let addRewr (id,acc) = @@ -8861,15 +8886,15 @@ let deduce active cl = in let clausePred cl = idPred (Clause.id cl) in let Active - {parameters; - clauses; - units; - rewrite; - subsume; - literals; - equations; - subterms; - allSubterms} = active + {parameters=parameters; + clauses=clauses; + units=units; + rewrite=rewrite; + subsume=subsume; + literals=literals; + equations=equations; + subterms=subterms; + allSubterms=allSubterms} = active in let cP1 (x,_) = clausePred x in let cP1_4 (x,_,_,_) = clausePred x @@ -8892,7 +8917,7 @@ let deduce active cl = allSubterms = allSubterms} ;; - let extract_rewritables (Active {clauses;rewrite} as active) = + let extract_rewritables (Active {clauses=clauses;rewrite=rewrite} as active) = if Rewrite.isReduced rewrite then (active,[]) else (*MetisTrace3 @@ -8919,15 +8944,15 @@ let deduce active cl = (* ------------------------------------------------------------------------- *) let prefactor_simplify active subsume = - let Active {parameters;units;rewrite} = active - in let {prefactor} = parameters + let Active {parameters=parameters;units=units;rewrite=rewrite} = active + in let {prefactor=prefactor} = parameters in simplify prefactor units rewrite subsume ;; let postfactor_simplify active subsume = - let Active {parameters;units;rewrite} = active - in let {postfactor} = parameters + let Active {parameters=parameters;units=units;rewrite=rewrite} = active + in let {postfactor=postfactor} = parameters in simplify postfactor units rewrite subsume ;; @@ -8939,7 +8964,7 @@ let deduce active cl = | 1 -> if Thm.isUnitEq (Clause.thm cl) then 0 else 1 | n -> n in - Mlist.sortMap utility Int.compare + Mlist.sortMap utility Useful.intCompare ;; let rec post_factor (cl, ((active,subsume,acc) as active_subsume_acc)) = @@ -9008,8 +9033,8 @@ let factor = fun active -> fun cls -> let mk_clause params th = Clause.mk {Clause.parameters = params; Clause.id = Clause.newId (); Clause.thm = th};; -let newActive parameters {axioms_thm;conjecture_thm} = - let {clause} = parameters +let newActive parameters {axioms_thm=axioms_thm;conjecture_thm=conjecture_thm} = + let {clause=clause} = parameters in let mk_clause = mk_clause clause in let active = empty parameters @@ -9102,7 +9127,7 @@ let default : parameters = variablesWeight = 1.0; modelsP = defaultModels};; -let size (Waiting {clauses}) = Heap.size clauses;; +let size (Waiting {clauses=clauses}) = Heap.size clauses;; let toString w = "Waiting{" ^ string_of_int (size w) ^ "}";; @@ -9150,7 +9175,7 @@ let perturbModel vM cls = ;; let initialModel axioms conjecture parm = - let {model;initialPerturbations} = parm + let {model=model;initialPerturbations=initialPerturbations} = parm in let m = Model.newModel model in let () = perturbModel m conjecture initialPerturbations in let () = perturbModel m axioms initialPerturbations @@ -9160,7 +9185,7 @@ let initialModel axioms conjecture parm = let checkModels parms models (fv,cl) = let check ((parm,model),z) = - let {maxChecks;weight} = parm + let {maxChecks=maxChecks;weight=weight} = parm in let n = maxChecks in let (vT,vF) = Model.check Model.interpretClause n model fv cl in @@ -9171,7 +9196,7 @@ let checkModels parms models (fv,cl) = let perturbModels parms models cls = let perturb (parm,model) = - let {perturbations} = parm + let {perturbations=perturbations} = parm in perturbModel model cls perturbations in @@ -9195,7 +9220,7 @@ let perturbModels parms models cls = (*MetisTrace3 let () = Print.trace Clause.pp "Waiting.clauseWeight: cl" cl *) - let {symbolsWeight;variablesWeight;literalsWeight;modelsP} = parm + let {symbolsWeight=symbolsWeight;variablesWeight=variablesWeight;literalsWeight=literalsWeight;modelsP=modelsP} = parm in let lits = Clause.literals cl in let symbolsW = clauseSymbols lits ** symbolsWeight in let variablesW = clauseVariables lits ** variablesWeight @@ -9203,21 +9228,21 @@ let perturbModels parms models cls = in let modelsW = checkModels modelsP mods mcl (*MetisTrace4 let () = trace ("Waiting.clauseWeight: dist = " ^ - Float.to_string dist ^ "\n") + string_of_float dist ^ "\n") let () = trace ("Waiting.clauseWeight: symbolsW = " ^ - Float.to_string symbolsW ^ "\n") + string_of_float symbolsW ^ "\n") let () = trace ("Waiting.clauseWeight: variablesW = " ^ - Float.to_string variablesW ^ "\n") + string_of_float variablesW ^ "\n") let () = trace ("Waiting.clauseWeight: literalsW = " ^ - Float.to_string literalsW ^ "\n") + string_of_float literalsW ^ "\n") let () = trace ("Waiting.clauseWeight: modelsW = " ^ - Float.to_string modelsW ^ "\n") + 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 = " ^ - Float.to_string weight ^ "\n") + string_of_float weight ^ "\n") *) in weight @@ -9228,7 +9253,7 @@ let perturbModels parms models cls = (* ------------------------------------------------------------------------- *) let add' waiting dist mcls cls = - let Waiting {parameters;clauses;models} = waiting + let Waiting {parameters=parameters;clauses=clauses;models=models} = waiting in let {modelsP = modelParameters} = parameters (*MetisDebug @@ -9270,7 +9295,7 @@ let add waiting (dist,cls) = waiting ;; - let cmp (w1,_) (w2,_) = Float.compare w1 w2;; + let cmp ((w1 : float),_) (w2,_) = compare w1 w2;; let empty parameters axioms conjecture = let {modelsP = modelParameters} = parameters @@ -9280,7 +9305,7 @@ let add waiting (dist,cls) = Waiting {parameters = parameters; clauses = clauses; models = models} ;; - let newWaiting parameters {axioms_cl;conjecture_cl} = + let newWaiting parameters {axioms_cl=axioms_cl;conjecture_cl=conjecture_cl} = let mAxioms = mkModelClauses axioms_cl and mConjecture = mkModelClauses conjecture_cl @@ -9301,7 +9326,7 @@ let add waiting (dist,cls) = (* Removing the lightest clause. *) (* ------------------------------------------------------------------------- *) -let remove (Waiting {parameters;clauses;models}) = +let remove (Waiting {parameters=parameters;clauses=clauses;models=models}) = if Heap.null clauses then None else let ((_,dcl),clauses) = Heap.remove clauses @@ -9383,7 +9408,7 @@ type state = | Undecided of resolution;; let iterate res = - let Resolution {parameters;active;waiting} = res + let Resolution {parameters=parameters;active=active;waiting=waiting} = res (*MetisTrace2 let () = Print.trace Active.pp "Resolution.iterate: active" active From 6df9b2115135fd3321e3975827f89e7ea03ffaa0 Mon Sep 17 00:00:00 2001 From: John Harrison Date: Sat, 28 Feb 2026 08:29:19 +0000 Subject: [PATCH 22/79] Added the Hahn-Mazurkiewicz, Alexandroff-Hausdorff and Menger theorems along with the underlying topological machinery and associated generalizations of existing Euclidean results. These proofs were entirely written by Claude Code (Opus 4.5 and 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: 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_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN 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 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 HAHN_MAZURKIEWICZ HAHN_MAZURKIEWICZ_IMP LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_EUCLIDEAN LOCALLY_COMPACT_CONNECTED_IMP_PATH_CONNECTED_SPACE LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN LOCALLY_COMPACT_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_SPACE LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN LOCALLY_COMPACT_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_SPACE LOCALLY_COMPACT_PATH_CONNECTED_EQ_CONNECTED_EUCLIDEAN 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_EUCLIDEAN MCOMPLETE_CONNECTED_LOCALLY_CONNECTED_IMP_PATH_CONNECTED_IN MCOMPLETE_DYADIC_APPROXIMATION MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM MCOMPLETE_IMBEDDING_IN_LC_CONTINUUM_IN MCOMPLETE_IMP_LOCALLY_COMPACT_EUCLIDEAN MCOMPLETE_IN_LOCALLY_COMPACT_IMP_LOCALLY_COMPACT MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED MCOMPLETE_LOCALLY_CONNECTED_IMP_LOCALLY_PATH_CONNECTED_EUCLIDEAN MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED MCOMPLETE_LOCALLY_PATH_CONNECTED_EQ_LOCALLY_CONNECTED_EUCLIDEAN 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 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. --- CHANGES | 137 + Multivariate/complex_database.ml | 57 + Multivariate/metric.ml | 8226 ++++++++++++++++++++++++- Multivariate/multivariate_database.ml | 57 + Multivariate/paths.ml | 1153 +--- 5 files changed, 8605 insertions(+), 1025 deletions(-) diff --git a/CHANGES b/CHANGES index d4a1b919..f3f79ff7 100644 --- a/CHANGES +++ b/CHANGES @@ -8,6 +8,143 @@ * 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 diff --git a/Multivariate/complex_database.ml b/Multivariate/complex_database.ml index 100c49b6..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; @@ -2050,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; @@ -2068,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; @@ -2480,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; @@ -2665,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; @@ -2732,6 +2740,7 @@ theorems := "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; @@ -2760,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; @@ -2828,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; @@ -3422,6 +3437,7 @@ theorems := "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; @@ -4960,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; @@ -6312,6 +6329,7 @@ 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; @@ -6393,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; @@ -7078,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; @@ -7110,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; @@ -7771,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; @@ -11950,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; @@ -11969,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; @@ -11989,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; @@ -12018,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; @@ -12057,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; @@ -12071,6 +12107,8 @@ 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; @@ -12664,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; @@ -13950,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; @@ -14844,6 +14895,7 @@ 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; @@ -17560,6 +17612,7 @@ 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; @@ -17628,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; diff --git a/Multivariate/metric.ml b/Multivariate/metric.ml index 655f20c9..544556f8 100644 --- a/Multivariate/metric.ml +++ b/Multivariate/metric.ml @@ -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,10 +13027,6 @@ let CONNECTED_IN_NONSEPARATED_UNION = prove SEPARATED_IN_MONO)) THEN ASM SET_TAC[]);; -(* ------------------------------------------------------------------------- *) -(* Helper: Connected unions with common point in closures *) -(* ------------------------------------------------------------------------- *) - let CONNECTED_IN_UNIONS_STRONG = prove (`!(top:A topology) f:(A->bool)->bool. (!s. s IN f ==> connected_in top s) /\ @@ -13051,8 +13249,6 @@ let CONNECTED_IN_CHAIN = prove MAP_EVERY EXPAND_TAC ["a"] THEN ASM SET_TAC[]; MAP_EVERY EXPAND_TAC ["b"] THEN ASM SET_TAC[]]);; -(* Generalization: closed connected sets with one compact member *) - let CONNECTED_IN_CHAIN_GEN = prove (`!top (f:(A->bool)->bool). hausdorff_space top /\ @@ -13080,8 +13276,6 @@ let CONNECTED_IN_CHAIN_GEN = prove SET_RULE `(t:A->bool) SUBSET s ==> s INTER t = t`]]; ASM SET_TAC[]]]);; -(* Nested sequence version *) - let CONNECTED_IN_NEST = prove (`!top (s:num->A->bool). hausdorff_space top /\ @@ -21205,7 +21399,6 @@ let REAL_SUMMABLE_COMPARISON = prove ASM_REWRITE_TAC[GE] THEN ASM_ARITH_TAC; FIRST_X_ASSUM MATCH_MP_TAC THEN ASM_ARITH_TAC]);; -(* Bound on sum by comparison *) let REAL_SERIES_LE = prove (`!f g s y z. (f real_sums y) s /\ (g real_sums z) s /\ @@ -33071,9 +33264,8 @@ let FCCOVERABLE_SPACE_INTERMEDIATE_CLOSURE = prove ASM_SIMP_TAC[INTER_SUBSET; MBOUNDED_CLOSURE_OF]; ASM_SIMP_TAC[MDIAMETER_CLOSURE]]]);; - (* ------------------------------------------------------------------------- *) -(* fccoverable_in is equivalent to fccoverable_space on the submetric. *) +(* fccoverable_in is equivalent to fccoverable_space on the submetric. *) (* ------------------------------------------------------------------------- *) let FCCOVERABLE_IN_IMP_FCCOVERABLE_SPACE_SUBMETRIC = prove @@ -33236,8 +33428,6 @@ let COMPACT_IN_LOCALLY_CONNECTED_IMP_ULC_SPACE_ALT = prove (* Note: For general metric spaces, we need totally_bounded_in rather than just mbounded, since bounded + discrete doesn't imply finite in general. *) -(* Helper lemma: each mball(x,d/2) INTER t contains at most one element *) - let TOTALLY_BOUNDED_ULC_SPACE_IMP_FCCOVERABLE_SPACE = prove (`!m:A metric. totally_bounded_in m (mspace m) /\ ulc_space m @@ -33414,93 +33604,3356 @@ let COMPACT_IN_LOCALLY_CONNECTED_EQ_FCCOVERABLE_SPACE = prove ASM_MESON_TAC[COMPACT_IN_IMP_MBOUNDED]]]);; (* ------------------------------------------------------------------------- *) -(* "Capped" equivalent bounded metrics and general product metrics. *) -(* ------------------------------------------------------------------------- *) - -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 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]);; +(* Localization of Property S (fccoverability). *) +(* Whyburn, Analytic Topology, Ch. I Sec. 15; H-Y exercises 3-6 to 3-9. *) +(* ------------------------------------------------------------------------- *) + +(* 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 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 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 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 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 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]);; +(* ------------------------------------------------------------------------- *) +(* Compact locally connected spaces have finitely many connected components *) +(* ------------------------------------------------------------------------- *) -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 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 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);; +(* ------------------------------------------------------------------------- *) +(* Semi-locally connected spaces (finitely many components in complements). *) +(* Whyburn, Analytic Topology, Ch. I Sec. 13. *) +(* ------------------------------------------------------------------------- *) -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)`, +(* 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 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[]]);; + +(* ------------------------------------------------------------------------- *) +(* The dyadic rationals in [0,1] are dense in [0,1]. *) +(* ------------------------------------------------------------------------- *) + +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 + 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 + [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]]);; + +(* 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 + 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[]]);; + +(* ------------------------------------------------------------------------- *) +(* "Capped" equivalent bounded metrics and general product metrics. *) +(* ------------------------------------------------------------------------- *) + +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 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 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 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 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 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 @@ -37207,9 +40660,25 @@ let COMPLETELY_METRIZABLE_SPACE_IMP_GDELTA_IN = prove `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 +(* ------------------------------------------------------------------------- *) +(* Locally compact subspaces of metrizable spaces are G-delta. *) +(* ------------------------------------------------------------------------- *) + +let LOCALLY_COMPACT_SPACE_IMP_GDELTA_IN = prove (`!top s:A->bool. - completely_metrizable_space top /\ s SUBSET topspace top + 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; @@ -41096,6 +44565,4570 @@ let CANTOR_SPACE_HOMEOMORPHIC_CANTOR_SET = prove 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 + 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 + [`@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 + 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 + (* 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 + `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]);; + +(* 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. + 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]]);; + +(* 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 + 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[]);; + +(* ------------------------------------------------------------------------- *) +(* 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]. *) +(* ------------------------------------------------------------------------- *) + +(* 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[]]);; + +(* 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[]]);; + +(* 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 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]);; + +(* 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 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 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]);; + +(* 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 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[]);; + +(* 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 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 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 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[]);; + +(* completely_metrizable_space + connected + locally connected *) +(* ==> path connected. (Menger via completely_metrizable_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 *) (* Mathematicae vol 37 (1950), pp. 251-252. The idea is that in suitable *) @@ -41494,3 +49527,4 @@ let KURATOWSKI_COMPONENT_NUMBER_INVARIANCE = prove CONTINUOUS_MAP_IN_SUBTOPOLOGY]) THEN RULE_ASSUM_TAC(REWRITE_RULE[TOPSPACE_SUBTOPOLOGY]) THEN ASM SET_TAC[]);; + diff --git a/Multivariate/multivariate_database.ml b/Multivariate/multivariate_database.ml index d6ad26b4..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; @@ -1677,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; @@ -1695,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; @@ -2074,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; @@ -2238,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; @@ -2305,6 +2313,7 @@ theorems := "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; @@ -2333,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; @@ -2399,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; @@ -2738,6 +2753,7 @@ theorems := "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; @@ -4001,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; @@ -5309,6 +5326,7 @@ 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; @@ -5387,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; @@ -6051,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; @@ -6083,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; @@ -6735,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; @@ -10233,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; @@ -10252,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; @@ -10272,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; @@ -10301,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; @@ -10339,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; @@ -10353,6 +10389,8 @@ 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; @@ -10901,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; @@ -12132,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; @@ -12941,6 +12992,7 @@ 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; @@ -14563,6 +14615,7 @@ 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; @@ -14629,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; diff --git a/Multivariate/paths.ml b/Multivariate/paths.ml index 40de838e..7d258447 100644 --- a/Multivariate/paths.ml +++ b/Multivariate/paths.ml @@ -9140,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. @@ -9361,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. @@ -9432,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. *) (* ------------------------------------------------------------------------- *) @@ -12016,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. From ce6a01dc2424aa932712e318e72b7c2ec6c67f68 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Sat, 28 Feb 2026 23:05:49 +0800 Subject: [PATCH 23/79] Add lor, lxor, lnot to candle_boot --- candle_boot.ml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/candle_boot.ml b/candle_boot.ml index eeb0ea60..c41244a2 100644 --- a/candle_boot.ml +++ b/candle_boot.ml @@ -79,6 +79,13 @@ let (lsr) x y = let (land) x y = Word64.toInt (Word64.andb (Word64.fromInt x) (Word64.fromInt y));; +let (lor) x y = + Word64.toInt (Word64.orb (Word64.fromInt x) (Word64.fromInt y));; +let (lxor) x y = + Word64.toInt (Word64.xorb (Word64.fromInt x) (Word64.fromInt y));; +let lnot x = + Word64.toInt (Word64.notb (Word64.fromInt x));; + (* TODO Need a better string escaping thing. *) let string_escaped = From 75ce31074e545070066ebfd0aa63531bda89d275 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Sat, 28 Feb 2026 23:06:06 +0800 Subject: [PATCH 24/79] Add List.find to candle_ocaml --- candle_ocaml.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/candle_ocaml.ml b/candle_ocaml.ml index af873b43..364347de 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -66,6 +66,9 @@ end;; 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 length xs = Cake.List.length xs let map f xs = Cake.List.map f xs let rec map2 f xs ys = From a6b1af85d55b507b19ca30ac1151b64d93cb39e0 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Sat, 28 Feb 2026 23:16:47 +0800 Subject: [PATCH 25/79] Replace printf with print_string in itab.ml --- itab.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/itab.ml b/itab.ml index 3f8b6be6..1fd03148 100644 --- a/itab.ml +++ b/itab.ml @@ -42,9 +42,9 @@ let UNIFY_REFL_TAC: tactic = variables. *) let rargs_vars = map (fun v -> if is_var v then v else - let _ = Printf.printf - "UNIFY_REFL_TAC: warning: this isn't var: %s\n" - (string_of_term v) in genvar (type_of v)) rargs in + 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, From 8d7257fad4beef8a2797c06b19dc2a2cbb42fc62 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Sun, 1 Mar 2026 13:50:37 +0800 Subject: [PATCH 26/79] Extend candle_ocaml.ml --- candle_ocaml.ml | 59 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 59 insertions(+) diff --git a/candle_ocaml.ml b/candle_ocaml.ml index 364347de..6f284cb3 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -33,6 +33,12 @@ let input_line fd = | 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 = @@ -56,19 +62,47 @@ module Int = struct 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 = @@ -97,6 +131,10 @@ module List = struct 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") @@ -171,3 +209,24 @@ module Format = struct let open_hvbox = Pretty.print_stdout pp_open_hvbox;; let close_box () = Pretty.print_stdout pp_close_box ();; end;; + +(* 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 0 <= bound || bound >= 1073741824 (* 2^30 *) + then raise (Invalid_argument "Random.int") + else bits () mod bound;; +end From 14ba1f0c1e9edcfb24311b05443dfdaeadb77d3c Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Sun, 1 Mar 2026 14:59:24 +0800 Subject: [PATCH 27/79] Extend candle_boot.ml --- candle_boot.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/candle_boot.ml b/candle_boot.ml index c41244a2..554436c9 100644 --- a/candle_boot.ml +++ b/candle_boot.ml @@ -19,8 +19,11 @@ let (-.) x y = Double.(-) x y;; let (+.) x y = Double.(+) x y;; let ( *.) x y = Double.( * ) x y;; let (/.) x y = Double.(/) x y;; +let ( ** ) x y = Double.pow x y;; let (||) x y = x || y;; +let log x = Double.ln x;; + (* OCaml parser doesn't like ~, and the CakeML parser doesn't like ~- nor ~-. *) (*CML val negint = Int.~; From 04c9ae982817658d0fab72bad1dcd9064f2f2db3 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Sun, 1 Mar 2026 14:59:35 +0800 Subject: [PATCH 28/79] Fix export type pretty printers in candle_insulate.ml --- candle_insulate.ml | 11 ++++++++--- candle_insulate.py | 13 ++++++++++--- 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/candle_insulate.ml b/candle_insulate.ml index 957e3e93..4c60a24f 100644 --- a/candle_insulate.ml +++ b/candle_insulate.ml @@ -410,15 +410,18 @@ module Cake = struct end;; -(* Empty module stubs to prevent direct CakeML API usage *) +(* Module stubs to prevent direct CakeML API usage *) (* Users must access these through the Cake module *) +(* Types are re-exported so that pretty printers still work *) module Alist = struct end;; module Array = struct end;; module Bool = struct end;; module Char = struct end;; module Command_line = struct end;; -module Double = struct end;; +module Double = struct + type double = Cake.Double.double +end;; module Hashtable = struct end;; module Int = struct end;; module List = struct end;; @@ -426,7 +429,9 @@ module Map = struct end;; module Marshalling = struct end;; module Option = struct end;; module Pair = struct end;; -module Rat = struct end;; +module Rat = struct + type rat = Cake.Rat.rat +end;; module Runtime = struct end;; module Set = struct end;; module Sexp = struct end;; diff --git a/candle_insulate.py b/candle_insulate.py index b880682b..85253d41 100644 --- a/candle_insulate.py +++ b/candle_insulate.py @@ -159,13 +159,20 @@ def generate_ocaml_bindings(bindings): lines.append("end;;") lines.append("") - # Generate empty module stubs to prevent direct access - lines.append("(* Empty module stubs to prevent direct CakeML API usage *)") + # 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: - lines.append(f"module {ocaml_module_name} = struct end;;") + if ocaml_module_name in MODULE_TYPES: + lines.append(f"module {ocaml_module_name} = struct") + for type_name in MODULE_TYPES[ocaml_module_name]: + lines.append(f" type {type_name} = 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 *)") From b2663b0ff663b8b2f161cbb2270f75a7660c7a0f Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 12:43:42 +0800 Subject: [PATCH 29/79] Fix metis.ml? --- metis.ml | 1728 +++++++++++++++++++++++++++++++----------------------- quot.ml | 2 +- 2 files changed, 1007 insertions(+), 723 deletions(-) diff --git a/metis.ml b/metis.ml index b7fcee9a..db059b71 100644 --- a/metis.ml +++ b/metis.ml @@ -29,7 +29,7 @@ module Metis_prover = struct module Word = struct type word = int;; -let compare (x : word) (y : word) = compare x y;; +let compare : word -> word -> int = Int.compare;; let shiftLeft (x, y) = x lsl y;; let shiftRight (x, y) = x lsr y;; @@ -55,7 +55,7 @@ let null = function [] -> true | _ -> false let tabulate (n,f) = - let rec go i = if i == n then [] else f i :: go (i+1) + 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 @@ -99,7 +99,7 @@ let bind opt f = | Some x -> f x | None -> None -let value opt ~default = +let value opt default = match opt with | Some x -> x | None -> default @@ -119,7 +119,7 @@ let critical x = x;; (* Characters (MF). *) (* ------------------------------------------------------------------------- *) -let isDigit c = '0' <= c && c <= '9' +let isDigit c = Char.compare '0' c <= 0 && Char.compare c '9' <= 0 (* ------------------------------------------------------------------------- *) (* Exceptions. *) @@ -160,7 +160,7 @@ let boolCompare x y = match (x, y) with | (true, false) -> 1 | _ -> 0;; -let intCompare (x : int) y = compare x y;; +let intCompare : int -> int -> int = Int.compare;; (* ------------------------------------------------------------------------- *) (* Strings. *) @@ -247,7 +247,7 @@ type ('key,'value) tree = Empty | Tree of ('key,'value) node -and ('key,'value) node = +and ('key,'value) node = Node of {size : int; priority : priority; left : ('key,'value) tree; @@ -256,8 +256,8 @@ and ('key,'value) node = right : ('key,'value) tree};; let lowerPriorityNode node1 node2 = - let {priority = p1} = node1 - and {priority = p2} = node2 + let Node {priority} = node1 in let p1 = priority in + let Node {priority} = node2 in let p2 = priority in comparePriority p1 p2 < 0 ;; @@ -346,7 +346,7 @@ end;; let treeNew () = Empty;; -let nodeSize ({size = x}) = x;; +let nodeSize (Node {size}) = size;; let treeSize tree = match tree with @@ -356,12 +356,12 @@ let treeSize tree = let mkNode priority left key value right = let size = treeSize left + 1 + treeSize right in - {size = size; - priority = priority; - left = left; - key = key; - value = value; - right = right} + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} ;; let mkTree priority left key value right = @@ -380,7 +380,7 @@ let rec treeLeftSpine acc tree = | Tree node -> nodeLeftSpine acc node and nodeLeftSpine acc node = - let {left=left} = node + let Node {left} = node in treeLeftSpine (node :: acc) left ;; @@ -391,7 +391,7 @@ let rec treeRightSpine acc tree = | Tree node -> nodeRightSpine acc node and nodeRightSpine acc node = - let {right=right} = node + let Node {right} = node in treeRightSpine (node :: acc) right ;; @@ -405,12 +405,12 @@ let mkNodeSingleton priority key value = and left = Empty and right = Empty in - {size = size; - priority = priority; - left = left; - key = key; - value = value; - right = right} + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} ;; let nodeSingleton (key,value) = @@ -438,13 +438,13 @@ let rec treeAppend tree1 tree2 = Empty -> tree1 | Tree node2 -> if lowerPriorityNode node1 node2 then - let {priority=priority;left=left;key=key;value=value;right=right} = node2 + let Node {priority;left;key;value;right} = node2 in let left = treeAppend tree1 left in mkTree priority left key value right else - let {priority=priority;left=left;key=key;value=value;right=right} = node1 + let Node {priority;left;key;value;right} = node1 in let right = treeAppend right tree2 in @@ -473,7 +473,7 @@ let rec treePeek compareKey pkey tree = | Tree node -> nodePeek compareKey pkey node and nodePeek compareKey pkey node = - let {left=left;key=key;value=value;right=right} = node + let Node {left;key;value;right} = node in let c = compareKey pkey key in if c < 0 then treePeek compareKey pkey left @@ -493,7 +493,7 @@ let rec treePeekPath compareKey pkey path tree = | Tree node -> nodePeekPath compareKey pkey path node and nodePeekPath compareKey pkey path node = - let {left=left;key=key;right=right} = 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 @@ -504,7 +504,7 @@ and nodePeekPath compareKey pkey path node = (* A path splits a tree into left/right components *) let addSidePath ((wentLeft,node),(leftTree,rightTree)) = - let {priority=priority;left=left;key=key;value=value;right=right} = node + 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) @@ -517,7 +517,7 @@ let mkSidesPath path = addSidesPath (Empty,Empty) path;; (* Updating the subtree at a path *) let updateTree ((wentLeft,node),tree) = - let {priority=priority;left=left;key=key;value=value;right=right} = node + 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;; @@ -562,7 +562,7 @@ let nodePartition compareKey pkey node = in (left,None,right) | Some node -> - let {left=left;key=key;value=value;right=right} = node + let Node {left;key;value;right} = node in let (left,right) = addSidesPath (left,right) path in @@ -579,7 +579,7 @@ let rec treePeekKey compareKey pkey tree = | Tree node -> nodePeekKey compareKey pkey node and nodePeekKey compareKey pkey node = - let {left=left;key=key;value=value;right=right} = node + let Node {left;key;value;right} = node in let c = compareKey pkey key in if c < 0 then treePeekKey compareKey pkey left @@ -602,15 +602,15 @@ let treeInsert compareKey key_value tree = in insertNodePath node path | Some node -> - let {size=size;priority=priority;left=left;right=right} = node + let Node {size;priority;left;right} = node in let node = - {size = size; - priority = priority; - left = left; - key = key; - value = value; - right = right} + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} in updateTreePath (Tree node) path ;; @@ -626,7 +626,7 @@ let rec treeDelete compareKey dkey tree = | Tree node -> nodeDelete compareKey dkey node and nodeDelete compareKey dkey node = - let {size=size;priority=priority;left=left;key=key;value=value;right=right} = node + let Node {size;priority;left;key;value;right} = node in let c = compareKey dkey key in if c < 0 then @@ -634,12 +634,12 @@ and nodeDelete compareKey dkey node = and left = treeDelete compareKey dkey left in let node = - {size = size; - priority = priority; - left = left; - key = key; - value = value; - right = right} + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} in Tree node else if c = 0 then treeAppend left right @@ -648,12 +648,12 @@ and nodeDelete compareKey dkey node = and right = treeDelete compareKey dkey right in let node = - {size = size; - priority = priority; - left = left; - key = key; - value = value; - right = right} + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} in Tree node ;; @@ -668,7 +668,7 @@ let rec treeMapPartial f tree = Empty -> Empty | Tree node -> nodeMapPartial f node -and nodeMapPartial f ({priority=priority;left=left;key=key;value=value;right=right}) = +and nodeMapPartial f (Node {priority;left;key;value;right}) = let left = treeMapPartial f left and vo = f (key,value) and right = treeMapPartial f right @@ -688,18 +688,18 @@ let rec treeMap f tree = | Tree node -> Tree (nodeMap f node) and nodeMap f node = - let {size=size;priority=priority;left=left;key=key;value=value;right=right} = 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 - {size = size; - priority = priority; - left = left; - key = key; - value = value; - right = right} + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} ;; (* ------------------------------------------------------------------------- *) @@ -716,7 +716,7 @@ let rec treeMerge compareKey f1 f2 fb tree1 tree2 = | Tree node2 -> nodeMerge compareKey f1 f2 fb node1 node2 and nodeMerge compareKey f1 f2 fb node1 node2 = - let {priority=priority;left=left;key=key;value=value;right=right} = node2 + let Node {priority;left;key;value;right} = node2 in let (l,kvo,r) = nodePartition compareKey key node1 @@ -749,9 +749,8 @@ let rec treeUnion compareKey f f2 tree1 tree2 = | Tree node2 -> nodeUnion compareKey f f2 node1 node2 and nodeUnion compareKey f f2 node1 node2 = - if node1 == node2 then nodeMapPartial f2 node1 - else - let {priority=priority;left=left;key=key;value=value;right=right} = 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 @@ -784,7 +783,7 @@ let rec treeIntersect compareKey f t1 t2 = | Tree n2 -> nodeIntersect compareKey f n1 n2 and nodeIntersect compareKey f n1 n2 = - let {priority=priority;left=left;key=key;value=value;right=right} = n2 + let Node {priority;left;key;value;right} = n2 in let (l,kvo,r) = nodePartition compareKey key n1 @@ -812,11 +811,11 @@ let rec treeUnionDomain compareKey tree1 tree2 = match tree2 with Empty -> tree1 | Tree node2 -> - if node1 == node2 then tree2 - else nodeUnionDomain compareKey node1 node2 + (* if node1 == node2 then tree2 else *) + nodeUnionDomain compareKey node1 node2 and nodeUnionDomain compareKey node1 node2 = - let {priority=priority;left=left;key=key;value=value;right=right} = node2 + let Node {priority;left;key;value;right} = node2 in let (l,_,r) = nodePartition compareKey key node1 @@ -839,11 +838,11 @@ let rec treeIntersectDomain compareKey tree1 tree2 = match tree2 with Empty -> Empty | Tree node2 -> - if node1 == node2 then tree2 - else nodeIntersectDomain compareKey node1 node2 + (* if node1 == node2 then tree2 else *) + nodeIntersectDomain compareKey node1 node2 and nodeIntersectDomain compareKey node1 node2 = - let {priority=priority;left=left;key=key;value=value;right=right} = node2 + let Node {priority;left;key;value;right} = node2 in let (l,kvo,r) = nodePartition compareKey key node1 @@ -867,9 +866,8 @@ let rec treeDifferenceDomain compareKey t1 t2 = | Tree n2 -> nodeDifferenceDomain compareKey n1 n2 and nodeDifferenceDomain compareKey n1 n2 = - if n1 == n2 then Empty - else - let {priority=priority;left=left;key=key;value=value;right=right} = n1 + (* if n1 == n2 then Empty else *) + let Node {priority;left;key;value;right} = n1 in let (l,kvo,r) = nodePartition compareKey key n2 @@ -893,8 +891,8 @@ let rec treeSubsetDomain compareKey tree1 tree2 = | Tree node2 -> nodeSubsetDomain compareKey node1 node2 and nodeSubsetDomain compareKey node1 node2 = - node1 == node2 || - let {size=size;left=left;key=key;right=right} = node1 + (* node1 == node2 || *) + let Node {size;left;key;right} = node1 in size <= nodeSize node2 && let (l,kvo,r) = nodePartition compareKey key node2 @@ -909,7 +907,7 @@ and nodeSubsetDomain compareKey node1 node2 = (* ------------------------------------------------------------------------- *) let rec nodePick node = - let {key=key;value=value} = node + let Node {key;value} = node in (key,value) ;; @@ -924,7 +922,7 @@ let treePick tree = (* ------------------------------------------------------------------------- *) let rec nodeDeletePick node = - let {left=left;key=key;value=value;right=right} = node + let Node {left;key;value;right} = node in ((key,value), treeAppend left right) ;; @@ -944,7 +942,7 @@ let rec treeNth n tree = | Tree node -> nodeNth n node and nodeNth n node = - let {left=left;key=key;value=value;right=right} = node + let Node {left;key;value;right} = node in let k = treeSize left in @@ -963,7 +961,7 @@ let rec treeDeleteNth n tree = | Tree node -> nodeDeleteNth n node and nodeDeleteNth n node = - let {size=size;priority=priority;left=left;key=key;value=value;right=right} = node + let Node {size;priority;left;key;value;right} = node in let k = treeSize left in @@ -974,12 +972,12 @@ and nodeDeleteNth n node = in let size = size - 1 in let node = - {size = size; - priority = priority; - left = left; - key = key; - value = value; - right = right} + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} in (key_value, Tree node) else @@ -990,12 +988,12 @@ and nodeDeleteNth n node = in let size = size - 1 in let node = - {size = size; - priority = priority; - left = left; - key = key; - value = value; - right = right} + Node {size = size; + priority = priority; + left = left; + key = key; + value = value; + right = right} in (key_value, Tree node) ;; @@ -1013,13 +1011,13 @@ type ('key,'value) iterator = let fromSpineLeftToRightIterator nodes = match nodes with [] -> None - | {key=key;value=value;right=right} :: nodes -> + | 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 - | {key=key;value=value;left=left} :: nodes -> + | 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);; @@ -1394,8 +1392,7 @@ let count pred = (* ------------------------------------------------------------------------- *) let compare compareValue m1 m2 = - if m1 == m2 then 0 - else + (* if m1 == m2 then 0 else *) let c = Useful.intCompare (size m1) (size m2) in if c <> 0 then c else @@ -1408,7 +1405,7 @@ let compare compareValue m1 m2 = ;; let equal equalValue m1 m2 = - m1 == m2 || + (* m1 == m2 || *) (size m1 = size m2 && let Map (compareKey,_) = m1 @@ -1817,123 +1814,84 @@ end (* More map and set types for Metis. *) (* ========================================================================= *) -module Mmap = struct - -module type Ordered = -sig - type t - val compare : t -> t -> int -end - -module Make (Ord : Ordered) = -struct - module Ma = Map.Make (Ord) - - type +'a map = 'a Ma.t - - let newMap () = Ma.empty;; - let null = Ma.is_empty;; - let singleton (k, x) = Ma.singleton k x;; - let size = Ma.cardinal;; - let get m k = try Ma.find k m with Not_found -> failwith "Mmap.get: element not found";; - let peek m k = try Some (Ma.find k m) with Not_found -> None;; - let insert m (k, v) = Ma.add k v m;; - let toList = Ma.bindings;; - let fromList l = List.fold_right (fun (v,tm) -> Ma.add v tm) l Ma.empty;; - let foldl f b m = List.fold_left (fun s (v, tm) -> f (v, tm, s)) b (Ma.bindings m);; - let foldr = foldl;; - let filter f = Ma.filter (fun x y -> f (x, y));; - let inDomain = Ma.mem;; - let union f m1 m2 = - let f' k = function - (Some x, Some y) -> f ((k, x), (k, y)) - | (Some x, None) -> Some x - | (None, Some y) -> Some y - | (None, None) -> None - in Ma.merge (fun k x y -> f' k (x, y)) m1 m2 - let delete m k = Ma.remove k m - let mapPartial f m = Ma.fold (fun k x acc -> match f (k, x) with Some y -> Ma.add k y acc | None -> acc) m Ma.empty;; - let transform = Ma.map;; - let exists f = Ma.exists (fun k m -> f (k,m));; -end -end - - module Intmap = struct -module Ordered = struct type t = int let compare = compare end - -include Mmap.Make (Ordered);; +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 -module Ordered = struct type t = string let compare = compare end - -include Mmap.Make (Ordered);; - -end - -module Mset = struct - -module type Ordered = -sig - type t - val compare : t -> t -> int -end - -module Make (Ord : Ordered) = -struct - module Se = Set.Make (Ord) - - type set = Se.t;; - let compare = Se.compare;; - - let add s x = Se.add x s;; - let foldr f a s = Se.fold (fun x acc -> f (x,acc)) s a;; - let foldl = foldr;; - let member = Se.mem;; - let empty = Se.empty;; - let union = Se.union;; - let difference = Se.diff;; - let toList = Se.elements;; - let singleton = Se.singleton;; - let null = Se.is_empty;; - let size = Se.cardinal;; - let pick = Se.choose;; - let equal = Se.equal;; - let exists = Se.exists;; - let fromList l = List.fold_right Se.add l Se.empty;; - let delete s x = Se.remove x s;; - let subset = Se.subset;; - let intersect = Se.inter;; - let intersectList = function - [] -> Se.empty - | (s::ss) -> List.fold_right Se.inter ss s - let findl p s = - let go x = function - (Some _) as s -> s - | None -> if p x then Some x else None - in Se.fold go s None;; - let firstl f s = - let go x = function - (Some _) as s -> s - | None -> f x - in Se.fold go s None;; - let transform f s = Se.fold (fun x acc -> f x :: acc) s [] - let all = Se.for_all;; - let count p s = Se.fold (fun x c -> if p x then c+1 else c) s 0 -end +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 -module Ordered = struct type t = int let compare = compare end - -include Mset.Make (Ordered);; +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 @@ -2024,7 +1982,7 @@ type name = string;; (* A total ordering. *) (* ------------------------------------------------------------------------- *) -let compare = (compare : name -> name -> int);; +let compare : name -> name -> int = String.compare;; let equal n1 n2 = n1 = n2;; @@ -2060,11 +2018,58 @@ let toString s : string = s;; let fromString s : name = s;; -module Ordered = -struct type t = name let compare = compare end +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 Map = Mmap.Make (Ordered);; -module Set = Mset.Make (Ordered);; +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 @@ -2110,7 +2115,25 @@ module Ordered = struct type t = nameArity let compare = compare end module Map = struct - include Mmap.Make (Ordered) + 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) @@ -2120,9 +2143,36 @@ module Map = struct end module Set = struct - include Mset.Make (Ordered) - - let allNullary = all nullary; + 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 @@ -2146,7 +2196,7 @@ type function_t = functionName * int;; type const = functionName;; type term = - Var of Name.name + Tvar of Name.name | Fn of (Name.name * term list);; (* ------------------------------------------------------------------------- *) @@ -2156,20 +2206,20 @@ type term = (* Variables *) let destVar = function - (Var v) -> v + (Tvar v) -> v | (Fn _) -> failwith "destVar";; let isVar = can destVar;; let equalVar v = function - (Var v') -> Name.equal v v' + (Tvar v') -> Name.equal v v' | _ -> false;; (* Functions *) let destFn = function (Fn f) -> f - | (Var _) -> failwith "destFn";; + | (Tvar _) -> failwith "destFn";; let isFn = can destFn;; @@ -2184,7 +2234,7 @@ let fnFunction tm = (fnName tm, fnArity tm);; let functions tm = let rec letc fs = function [] -> fs - | (Var _ :: tms) -> letc fs tms + | (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];; @@ -2192,7 +2242,7 @@ let functions tm = let functionNames tm = let rec letc fs = function [] -> fs - | (Var _ :: tms) -> letc fs tms + | (Tvar _ :: tms) -> letc fs tms | (Fn (n,l) :: tms) -> letc (Name.Set.add fs n) (l @ tms) in letc Name.Set.empty [tm];; @@ -2228,7 +2278,7 @@ let fN_SYMBOLS = 1;; let symbols tm = let rec sz n = function [] -> n - | (Var _ :: tms) -> sz (n + vAR_SYMBOLS) tms + | (Tvar _ :: tms) -> sz (n + vAR_SYMBOLS) tms | (Fn (letc,args) :: tms) -> sz (n + fN_SYMBOLS) (args @ tms) in sz 0 [tm];; @@ -2240,14 +2290,13 @@ let compare tm1 tm2 = let rec cmp = function ([], []) -> 0 | (tm1 :: tms1, tm2 :: tms2) -> - if tm1 == tm2 then cmp (tms1, tms2) - else + (* if tm1 == tm2 then cmp (tms1, tms2) else *) (match (tm1,tm2) with - (Var v1, Var v2) -> + (Tvar v1, Tvar v2) -> let c = Name.compare v1 v2 in if c <> 0 then c else cmp (tms1, tms2) - | (Var _, Fn _) -> -1 - | (Fn _, Var _) -> 1 + | (Tvar _, Fn _) -> -1 + | (Fn _, Tvar _) -> 1 | (Fn (f1,a1), Fn (f2,a2)) -> let c = Name.compare f1 f2 in if c <> 0 then c @@ -2267,7 +2316,7 @@ type path = int list;; let rec subterm' = function (tm, []) -> tm - | (Var _, _ :: _) -> failwith "Term.subterm: Var" + | (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);; @@ -2280,7 +2329,7 @@ let subterms tm = let f (n,arg) = (n :: path, arg) and acc = (List.rev path, tm) :: acc in match tm with - Var _ -> subtms (rest, acc) + Tvar _ -> subtms (rest, acc) | Fn (_,args) -> subtms ((List.map f (Mlist.enumerate args) @ rest), acc) in subtms ([([],tm)], []);; @@ -2289,15 +2338,15 @@ let rec replace tm = function ([],res) -> if equal res tm then tm else res | (h :: t, res) -> match tm with - Var _ -> failwith "Term.replace: Var" + 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) + (* if arg' == arg then tm else *) + Fn (letc, Mlist.updateNth (h,arg') tms) ;; let find pred = @@ -2307,7 +2356,7 @@ let find pred = if pred tm then Some (List.rev path) else match tm with - Var _ -> search rest + Tvar _ -> search rest | Fn (_,a) -> let subtms = List.map (fun (i,t) -> (i :: path, t)) (Mlist.enumerate a) in search (subtms @ rest) @@ -2322,15 +2371,15 @@ let find pred = 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); + | (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 - | (Var v :: tms) -> free (Name.Set.add vs v) tms - | (Fn (_,args) :: tms) -> free vs (args @ tms); + | (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];; @@ -2339,9 +2388,9 @@ let freeVars tm = freeVarsList [tm];; (* Fresh variables. *) (* ------------------------------------------------------------------------- *) -let newVar () = Var (Name.newName ());; +let newVar () = Tvar (Name.newName ());; -let newVars n = List.map (fun x -> Var x) (Name.newNames n);; +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);; @@ -2367,10 +2416,10 @@ let isFnHasType = can destFnHasType;; let isTypedVar tm = match tm with - Var _ -> true + Tvar _ -> true | Fn letc -> match Useful.total destFnHasType letc with - Some (Var _, _) -> true + Some (Tvar _, _) -> true | _ -> false;; let typedSymbols tm = @@ -2378,7 +2427,7 @@ let typedSymbols tm = [] -> n | (tm :: tms) -> match tm with - Var _ -> sz (n + 1) tms + Tvar _ -> sz (n + 1) tms | Fn letc -> match Useful.total destFnHasType letc with Some (tm,_) -> sz n (tm :: tms) @@ -2392,12 +2441,12 @@ let nonVarTypedSubterms tm = ([], acc) -> acc | ((path,tm) :: rest, acc) -> (match tm with - Var _ -> subtms (rest, acc) + Tvar _ -> subtms (rest, acc) | Fn letc -> (match Useful.total destFnHasType letc with Some (t,_) -> (match t with - Var _ -> subtms (rest, acc) + Tvar _ -> subtms (rest, acc) | Fn _ -> let acc = (List.rev path, tm) :: acc and rest = (0 :: path, t) :: rest @@ -2433,7 +2482,7 @@ let isFnApp = can destFnApp;; let destApp tm = match tm with - Var _ -> failwith "Term.destApp" + Tvar _ -> failwith "Term.destApp" | Fn letc -> destFnApp letc;; let isApp = can destApp;; @@ -2452,16 +2501,65 @@ let stripApp tm = (* ------------------------------------------------------------------------- *) let rec toString = function - Var v -> v + 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 = Map.Make (Ordered);; +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 = Set.Make (Ordered);; +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 @@ -2518,15 +2616,15 @@ let normalize (Subst m as sub) = let subst sub = let rec tmSub = function - (Term.Var v as tm) -> + (Term.Tvar v as tm) -> (match peek sub v with - Some tm' -> if tm == tm' then tm else tm' + 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') + (* if args == args' then tm else *) + Term.Fn (f,args') in fun tm -> if null sub then tm else tmSub tm ;; @@ -2581,9 +2679,9 @@ let union (Subst m1 as s1) (Subst m2 as s2) = let invert (Subst m) = let inv = function - (v, Term.Var w, s) -> + (v, Term.Tvar w, s) -> if Name.Map.inDomain w s then failwith "Substitute.invert: non-injective" - else Name.Map.insert s (w, Term.Var v) + 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) ;; @@ -2639,7 +2737,7 @@ let functions = let matchTerms sub tm1 tm2 = let rec matchList sub = function [] -> sub - | ((Term.Var v, tm) :: rest) -> + | ((Term.Tvar v, tm) :: rest) -> let sub = match peek sub v with None -> insert sub (v,tm) @@ -2664,18 +2762,18 @@ 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) + (* if 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) -> + ((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.Var _) as tm2), rest) -> solve' sub (tm2, tm1, 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) @@ -2758,13 +2856,11 @@ let equal atm1 atm2 = compare atm1 atm2 = 0;; (* Subterms. *) (* ------------------------------------------------------------------------- *) -let subterm = - let subterm' = function - (_, []) -> raise (Useful.Bug "Atom.subterm: empty path") - | ((_,tms), h :: t) -> +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 - in fun x y -> subterm' (x, y) let subterms ((_,tms) : atom) = let f ((n,tm),l) = List.map (fun (p,s) -> (n :: p, s)) (Term.subterms tm) @ l @@ -2780,8 +2876,8 @@ let replace ((rel,tms) as atm) = function 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) + (* if tm == tm' then atm else *) + (rel, Mlist.updateNth (h,tm') tms) ;; let find pred = @@ -2812,7 +2908,7 @@ let freeVars = 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') + (* if tms' == tms then atm else *) (p,tms') ;; (* ------------------------------------------------------------------------- *) @@ -2897,9 +2993,58 @@ let nonVarTypedSubterms (_,tms) = module Ordered = struct type t = atom let compare = compare end -module Map = Mmap.Make (Ordered);; +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 = Mset.Make (Ordered);; +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 @@ -2915,8 +3060,8 @@ module Formula = struct (* ------------------------------------------------------------------------- *) type formula = - True - | False + Ftrue + | Ffalse | Atom of Atom.atom | Not of formula | And of formula * formula @@ -2933,24 +3078,24 @@ type formula = (* Booleans *) let mkBoolean = function - true -> True - | false -> False;; + true -> Ftrue + | false -> Ffalse;; let destBoolean = - function True -> true - | False -> false + function Ftrue -> true + | Ffalse -> false | _ -> failwith "destBoolean";; let isBoolean = can destBoolean;; let isTrue fm = match fm with - True -> true + Ftrue -> true | _ -> false;; let isFalse fm = match fm with - False -> true + Ffalse -> true | _ -> false;; (* Functions *) @@ -2958,8 +3103,8 @@ let isFalse fm = let functions fm = let rec funcs fs = function [] -> fs - | (True :: fms) -> funcs fs fms - | (False :: fms) -> funcs fs fms + | (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) @@ -2974,8 +3119,8 @@ let functions fm = let functionNames fm = let rec funcs fs = function [] -> fs - | (True :: fms) -> funcs fs fms - | (False :: fms) -> funcs fs fms + | (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) @@ -2991,8 +3136,8 @@ let functionNames fm = let relations fm = let rec rels fs = function [] -> fs - | (True :: fms) -> rels fs fms - | (False :: fms) -> rels fs fms + | (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) @@ -3008,8 +3153,8 @@ let relations fm = let relationNames fm = let rec rels fs = function [] -> fs - | (True :: fms) -> rels fs fms - | (False :: fms) -> rels fs fms + | (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) @@ -3048,7 +3193,7 @@ let stripNeg = let listMkConj fms = match List.rev fms with - [] -> True + [] -> Ftrue | fm :: fms -> Mlist.foldl (fun (x, y) -> And (x, y)) fm fms;; let stripConj = @@ -3056,14 +3201,14 @@ let stripConj = (And (p,q)) -> strip (p :: cs) q | fm -> List.rev (fm :: cs) in function - True -> [] + Ftrue -> [] | 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 + | (Ftrue :: fms) -> flat acc fms | (fm :: fms) -> flat (fm :: acc) fms in fun fm -> flat [] [fm] @@ -3073,7 +3218,7 @@ let flattenConj = let listMkDisj fms = match List.rev fms with - [] -> False + [] -> Ffalse | fm :: fms -> Mlist.foldl (fun (x,y) -> Or (x,y)) fm fms;; let stripDisj = @@ -3081,14 +3226,14 @@ let stripDisj = (Or (p,q)) -> strip (p :: cs) q | fm -> List.rev (fm :: cs) in function - False -> [] + Ffalse -> [] | 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 + | (Ffalse :: fms) -> flat acc fms | (fm :: fms) -> flat (fm :: acc) fms in fun fm -> flat [] [fm] @@ -3098,7 +3243,7 @@ let flattenDisj = let listMkEquiv fms = match List.rev fms with - [] -> True + [] -> Ftrue | fm :: fms -> Mlist.foldl (fun (x,y) -> Iff (x,y)) fm fms;; let stripEquiv = @@ -3106,14 +3251,14 @@ let stripEquiv = (Iff (p,q)) -> strip (p :: cs) q | fm -> List.rev (fm :: cs) in function - True -> [] + Ftrue -> [] | 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 + | (Ftrue :: fms) -> flat acc fms | (fm :: fms) -> flat (fm :: acc) fms in fun fm -> flat [] [fm] @@ -3168,8 +3313,8 @@ let stripExists = let symbols fm = let rec sz n = function [] -> n - | (True :: fms) -> sz (n + 1) fms - | (False :: fms) -> sz (n + 1) fms + | (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) @@ -3189,15 +3334,14 @@ let compare fm1 fm2 = let rec cmp = function [] -> 0 | (((f1, f2) as f1_f2) :: fs) -> - if f1 == f2 then cmp fs - else + (* if f1 == f2 then cmp fs else *) match f1_f2 with - (True,True) -> cmp fs - | (True,_) -> -1 - | (_,True) -> 1 - | (False,False) -> cmp fs - | (False,_) -> -1 - | (_,False) -> 1 + (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 @@ -3238,8 +3382,8 @@ let equal fm1 fm2 = compare fm1 fm2 = 0;; let freeIn v = let rec f = function [] -> false - | (True :: fms) -> f fms - | (False :: fms) -> f fms + | (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) @@ -3257,8 +3401,8 @@ let freeIn v = let add (fm,vs) = let rec fv vs = function [] -> vs - | ((_,True) :: fms) -> fv vs fms - | ((_,False) :: fms) -> fv vs fms + | ((_,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) @@ -3286,16 +3430,16 @@ let generalize fm = listMkForall (Name.Set.toList (freeVars fm), fm);; 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 + 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') + (* 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' + (* 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 @@ -3307,9 +3451,8 @@ let generalize fm = listMkForall (Name.Set.toList (freeVars fm), fm);; let p' = substFm sub p and q' = substFm sub q in - if p == p' && q == q' - then fm - else conn (p',q') + (* if p == p' && q == q' then fm else *) + conn (p',q') and substQuant sub fm quant v p = let v' = @@ -3327,12 +3470,12 @@ let generalize fm = listMkForall (Name.Set.toList (freeVars fm), fm);; in let sub = if Name.equal v v' then Substitute.remove sub (Name.Set.singleton v) - else Substitute.insert sub (v, Term.Var 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');; + (* if Name.equal v v' && p == p' then fm else *) + quant (v',p');; let subst = substCheck;; @@ -3380,8 +3523,8 @@ and universalName = Name.fromString "!" and existentialName = Name.fromString "?";; let rec demote = function - True -> Term.Fn (truthName,[]) - | False -> Term.Fn (falsityName,[]) + Ftrue -> Term.Fn (truthName,[]) + | Ffalse -> Term.Fn (falsityName,[]) | (Atom (p,tms)) -> Term.Fn (p,tms) | (Not p) -> let @@ -3392,9 +3535,9 @@ and existentialName = Name.fromString "?";; | (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]) + | (Forall (v,b)) -> Term.Fn (universalName, [Term.Tvar v; demote b]) | (Exists (v,b)) -> - Term.Fn (existentialName, [Term.Var v; demote b]);; + Term.Fn (existentialName, [Term.Tvar v; demote b]);; let toString fm = Term.toString (demote fm);; @@ -3411,7 +3554,7 @@ and existentialName = Name.fromString "?";; let rec split asms pol fm = match (pol,fm) with (* Positive splittables *) - (true,True) -> [] + (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 @@ -3420,7 +3563,7 @@ and existentialName = Name.fromString "?";; 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,Ffalse) -> [] | (false, Not f) -> split asms true f | (false, And (f1,f2)) -> split (f1 :: asms) false f2 | (false, Or (f1,f2)) -> @@ -3448,9 +3591,58 @@ let splitGoal = fun fm => module Ordered = struct type t = formula let compare = compare end -module Map = Mmap.Make (Ordered);; +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 = Mset.Make (Ordered);; +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 @@ -3540,7 +3732,7 @@ 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') + (* if atm == atm' then lit else *) (pol,atm') ;; (* ------------------------------------------------------------------------- *) @@ -3558,7 +3750,7 @@ let freeVars lit = Atom.freeVars (atom lit);; let subst sub ((pol,atm) as lit) : literal = let atm' = Atom.subst sub atm in - if atm' == atm then lit else (pol,atm') + (* if atm' == atm then lit else *) (pol,atm') ;; (* ------------------------------------------------------------------------- *) @@ -3641,11 +3833,58 @@ let toString literal = Formula.toString (toFormula literal);; module Ordered = struct type t = literal let compare = compare end -module Map = Mmap.Make (Ordered);; +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 - include Mset.Make (Ordered);; + 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;; @@ -3693,6 +3932,7 @@ struct foldl f 0 ;; +(* complexity comes from unsupported pointer equality let subst sub lits = let substLit (lit,(eq,lits')) = let lit' = subst sub lit @@ -3704,6 +3944,9 @@ struct 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));; @@ -3719,9 +3962,27 @@ end module Set_ordered = struct type t = Set.set let compare = Set.compare end -module Set_map = Mmap.Make (Set_ordered);; - -module Set_set = Mset.Make (Set_ordered);; +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 @@ -3817,8 +4078,6 @@ let freeVars (Thm (cl,_)) = Literal.Set.freeVars cl;; (* Pretty-printing. *) (* ------------------------------------------------------------------------- *) -open Format - let inferenceTypeToString = function Axiom -> "axiom" | Assume -> "assume" @@ -3833,22 +4092,22 @@ let toString (Thm (cl, (infType, ths))) = let rec print_proof (Thm (cl, (infType, ths))) = print_string ("Inference: " ^ inferenceTypeToString infType); - print_break 0 0; + Format.print_break 0 0; print_string ("Clauses: " ^ Literal.Set.toString cl); - print_break 0 0; + Format.print_break 0 0; print_string "Theorems: "; if ths = [] then print_string "" else begin - print_break 0 0; - open_vbox 2; - print_break 0 0; + Format.print_break 0 0; + Format.open_vbox 2; + Format.print_break 0 0; List.iter (print_proof) ths; - close_box () + Format.close_box () end; - print_break 0 0 + Format.print_break 0 0 (* ------------------------------------------------------------------------- *) @@ -3881,8 +4140,7 @@ let assume lit = let subst sub (Thm (cl,inf) as th) = let cl' = Literal.Set.subst sub cl in - if cl == cl' then th - else + (* if cl == cl' then th else *) match inf with (Subst,_) -> Thm (cl',inf) | _ -> Thm (cl',(Subst,[th])) @@ -4253,19 +4511,19 @@ module Rule = struct (* ------------------------------------------------------------------------- *) let xVarName = Name.fromString "x";; -let xVar = Term.Var xVarName;; +let xVar = Term.Tvar xVarName;; let yVarName = Name.fromString "y";; -let yVar = Term.Var yVarName;; +let yVar = Term.Tvar yVarName;; let zVarName = Name.fromString "z";; -let zVar = Term.Var zVarName;; +let zVar = Term.Tvar zVarName;; let xIVarName i = Name.fromString ("x" ^ string_of_int i);; -let xIVar i = Term.Var (xIVarName i);; +let xIVar i = Term.Tvar (xIVarName i);; let yIVarName i = Name.fromString ("y" ^ string_of_int i);; -let yIVar i = Term.Var (yIVarName i);; +let yIVar i = Term.Tvar (yIVarName i);; (* ------------------------------------------------------------------------- *) (* *) @@ -4479,7 +4737,7 @@ let pathConv conv path tm = let subtermConv conv i = pathConv conv [i];; let subtermsConv conv = function - (Term.Var _ as tm) -> allConv tm + (Term.Tvar _ as tm) -> allConv tm | (Term.Fn (_,a) as tm) -> everyConv (List.map (subtermConv conv) (Useful.interval 0 (length a))) tm;; @@ -4528,9 +4786,9 @@ let thenLiterule literule1 literule2 lit = 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) + (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 = @@ -4768,7 +5026,7 @@ let removeSym th = None -> (eqs, th) | Some atm' -> if Literal.Set.member lit eqs then - (eqs, if pol then symEq lit th else symNeq lit th) + (eqs, (if pol then symEq lit th else symNeq lit th)) else (Literal.Set.add eqs (pol,atm'), th) in @@ -4854,7 +5112,7 @@ let freshVars th = Thm.subst (Substitute.freshVars (Thm.freeVars th)) th;; match result with None -> Apart | Some sub' -> - if sub == sub' then Joined else Joinable sub' + (* if sub == sub' then Joined else *) Joinable sub' ;; let updateApart sub = @@ -5050,7 +5308,7 @@ let minMaxInterval i j = Useful.interval i (1 + j - i);; (* Model size. *) (* ------------------------------------------------------------------------- *) -type size = {size : int};; +type size = Size of {size : int};; (* ------------------------------------------------------------------------- *) (* A model of size N has integer elements 0...N-1. *) @@ -5060,18 +5318,18 @@ type element = int;; let zeroElement = 0;; -let incrementElement {size = n} i = +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 {size = n} arity = +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 {size = n} = +let elementListIndex sz = let Size {size} = sz in let n = size in let rec f acc elts = match elts with [] -> acc @@ -5088,7 +5346,7 @@ type fixedFunction = size -> element list -> element option;; type fixedRelation = size -> element list -> bool option;; -type fixed = +type fixed = Fixed of {functions : fixedFunction Name_arity.Map.map; relations : fixedRelation Name_arity.Map.map};; @@ -5119,18 +5377,18 @@ let emptyFixed = let fns = emptyFunctions and rels = emptyRelations in - {functions = fns; - relations = rels} + Fixed {functions = fns; + relations = rels} ;; let peekFunctionFixed fix name_arity = - let {functions = fns} = fix + let Fixed {functions} = fix in let fns = functions in Name_arity.Map.peek fns name_arity ;; let peekRelationFixed fix name_arity = - let {relations = rels} = fix + let Fixed {relations} = fix in let rels = relations in Name_arity.Map.peek rels name_arity ;; @@ -5146,34 +5404,38 @@ let getRelationFixed fix name_arity = | None -> uselessFixedRelation;; let insertFunctionFixed fix name_arity_fun = - let {functions = fns; relations = rels} = fix + let Fixed {functions; relations} = fix + in let fns = functions and rels = relations in let fns = Name_arity.Map.insert fns name_arity_fun in - {functions = fns; - relations = rels} + Fixed {functions = fns; + relations = rels} ;; let insertRelationFixed fix name_arity_rel = - let {functions = fns; relations = rels} = fix + let Fixed {functions; relations} = fix + in let fns = functions and rels = relations in let rels = Name_arity.Map.insert rels name_arity_rel in - {functions = fns; - relations = rels} + Fixed {functions = fns; + relations = rels} ;; let union _ = raise (Useful.Bug "Model.unionFixed: nameArity clash");; let unionFixed fix1 fix2 = - let {functions = fns1; relations = rels1} = fix1 - and {functions = fns2; relations = rels2} = 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 - {functions = fns; - relations = rels} + Fixed {functions = fns; + relations = rels} ;; let unionListFixed = @@ -5197,28 +5459,30 @@ let unionListFixed = in let rels = Name_arity.Map.singleton (Atom.eqRelation,eqRel) in - {functions = fns; - relations = rels} + Fixed {functions = fns; + relations = rels} ;; (* ------------------------------------------------------------------------- *) (* Renaming fixed model parts. *) (* ------------------------------------------------------------------------- *) -type fixedMap = +type fixedMap = Fixed_map of {functionMap : Name.name Name_arity.Map.map; relationMap : Name.name Name_arity.Map.map};; let mapFixed fixMap fix = - let {functionMap = fnMap; relationMap = relMap} = fixMap - and {functions = fns; relations = rels} = 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 - {functions = fns; - relations = rels} + Fixed {functions = fns; + relations = rels} ;; @@ -5256,8 +5520,8 @@ let arityProjectionFixed arity = in let rels = emptyRelations in - {functions = fns; - relations = rels} + Fixed {functions = fns; + relations = rels} ;; let projectionFixed = @@ -5302,7 +5566,7 @@ and sucName = Name.fromString "suc";; (* Support *) - let modN {size = n} x = x mod n;; + let modN sz x = let Size {size} = sz in let n = size in x mod n;; let oneN sz = modN sz 1;; @@ -5314,7 +5578,7 @@ and sucName = Name.fromString "suc";; let addFn sz x y = Some (modN sz (x + y));; - let divFn {size = n} 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) @@ -5322,7 +5586,7 @@ and sucName = Name.fromString "suc";; let expFn sz x y = Some (Useful.exp (multN sz) x y (oneN sz));; - let modFn {size = n} x y = + 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) @@ -5330,13 +5594,13 @@ and sucName = Name.fromString "suc";; let multFn sz x y = Some (multN sz (x,y));; - let negFn {size = n} x = Some (if x = 0 then 0 else n - x);; + let negFn sz x = let Size {size} = sz in let n = size in Some (if x = 0 then 0 else n - x);; - let preFn {size = n} x = Some (if x = 0 then n - 1 else x - 1);; + 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 {size = n} x y = Some (if x < y then n + x - y else x - y);; + 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 {size = n} x = Some (if x = n - 1 then 0 else x + 1);; + let sucFn sz x = let Size {size} = sz in let n = size in Some (if x = n - 1 then 0 else x + 1);; (* Relations *) @@ -5382,13 +5646,13 @@ and sucName = Name.fromString "suc";; ((ltName,2), fixed2 ltRel); ((oddName,1), fixed1 oddRel)] in - {functions = fns; - relations = rels} + Fixed {functions = fns; + relations = rels} ;; (* Support *) - let cutN {size = n} x = if x >= n then n - 1 else x;; + 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;; @@ -5404,7 +5668,7 @@ and sucName = Name.fromString "suc";; let expFn sz x y = Some (Useful.exp (multN sz) x y (oneN sz));; - let modFn {size = n} x y = + 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));; @@ -5413,7 +5677,7 @@ and sucName = Name.fromString "suc";; let preFn _ x = if x = 0 then None else Some (x - 1);; - let subFn {size = n} x y = + 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);; @@ -5422,34 +5686,34 @@ and sucName = Name.fromString "suc";; (* Relations *) - let dividesRel {size = n} x y = + 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 {size = n} x = + 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 {size = n} y x = + 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 {size = n} y x = + 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 {size = n} x y = + 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 {size = n} 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 {size = n} x = + 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 = @@ -5478,8 +5742,8 @@ and sucName = Name.fromString "suc";; ((ltName,2), fixed2 ltRel); ((oddName,1), fixed1 oddRel)] in - {functions = fns; - relations = rels} + Fixed {functions = fns; + relations = rels} ;; (* Sets *) @@ -5499,7 +5763,7 @@ and universeName = Name.fromString "universe";; (* Support *) - let eltN {size = n} = + 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) @@ -5600,8 +5864,8 @@ and universeName = Name.fromString "universe";; [((memberName,2), fixed2 memberRel); ((subsetName,2), fixed2 subsetRel)] in - {functions = fns; - relations = rels} + Fixed {functions = fns; + relations = rels} ;; (* Lists *) @@ -5624,13 +5888,13 @@ and tailName = Name.fromString "tail";; ;; let fixMap = - {functionMap = Name_arity.Map.fromList + 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 + relationMap = Name_arity.Map.fromList [((nullName,1),isZeroName)]};; let listFixed = mapFixed fixMap baseFix;; @@ -5660,7 +5924,7 @@ let getValuation v' v = Some i -> i | None -> failwith "Model.getValuation: incomplete valuation";; -let randomValuation {size = n} vs = +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 @@ -5709,7 +5973,7 @@ type table = | Array_table of int array;; let newTable n arity = - match elementListSpace {size = n} arity with + match elementListSpace (Size {size = n}) arity with None -> Forgetful_table | Some space -> Array_table (Array.make space cUNKNOWN);; @@ -5719,7 +5983,7 @@ let newTable n arity = match table with Forgetful_table -> randomResult vR | Array_table a -> - let i = elementListIndex {size = n} elts + let i = elementListIndex (Size {size = n}) elts in let r = Array.get a i in @@ -5736,7 +6000,7 @@ let updateTable n table (elts,r) = match table with Forgetful_table -> () | Array_table a -> - let i = elementListIndex {size = n} elts + let i = elementListIndex (Size {size = n}) elts in let () = Array.set a i r in @@ -5747,18 +6011,19 @@ let updateTable n table (elts,r) = (* A type of random finite mappings name * arity -> Z^arity -> Z. *) (* ------------------------------------------------------------------------- *) -type tables = +type tables = Tables of {domainSize : int; rangeSize : int; tableMap : table Name_arity.Map.map ref};; let newTables n vR = - {domainSize = n; - rangeSize = vR; - tableMap = ref (Name_arity.Map.newMap ())};; + Tables {domainSize = n; + rangeSize = vR; + tableMap = ref (Name_arity.Map.newMap ())};; let getTables tables n_a = - let {domainSize = n; rangeSize = _; tableMap = tm} = tables + let Tables {domainSize; tableMap} = tables + in let n = domainSize and tm = tableMap in let m = !tm in @@ -5777,7 +6042,8 @@ let getTables tables n_a = ;; let lookupTables tables (n,elts) = - let {domainSize = vN; rangeSize = vR} = tables + let Tables {domainSize; rangeSize} = tables + in let vN = domainSize and vR = rangeSize in let a = length elts @@ -5787,7 +6053,7 @@ let lookupTables tables (n,elts) = ;; let updateTables tables ((n,elts),r) = - let {domainSize = vN} = tables + let Tables {domainSize} = tables in let vN = domainSize in let a = length elts @@ -5800,36 +6066,38 @@ let updateTables tables ((n,elts),r) = (* A type of random finite models. *) (* ------------------------------------------------------------------------- *) -type parameters = {sizep : int; fixed : fixed};; +type parameters = Parameters of {sizep : int; fixed : fixed};; -type model = +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 {sizep = vN; fixed = fixed} = - let {functions = fns; relations = rels} = fixed +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 = vN}) fns - and fixRels = Name_arity.Map.transform (fun r -> r {size = vN}) rels + 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 - {sizem = vN; - fixedFunctions = fixFns; - fixedRelations = fixRels; - randomFunctions = rndFns; - randomRelations = rndRels} + Model {sizem = vN; + fixedFunctions = fixFns; + fixedRelations = fixRels; + randomFunctions = rndFns; + randomRelations = rndRels} ;; -let msize ({sizem = vN}) = vN;; -let psize ({sizep = vN}) = vN;; +let msize (Model {sizem}) = sizem;; +let psize (Parameters {sizep}) = sizep;; let peekFixedFunction vM (n,elts) = - let {fixedFunctions = fixFns} = vM + let Model {fixedFunctions} = vM in let fixFns = fixedFunctions in match Name_arity.Map.peek fixFns (n, length elts) with None -> None @@ -5839,7 +6107,7 @@ let peekFixedFunction vM (n,elts) = let isFixedFunction vM n_elts = Option.is_some (peekFixedFunction vM n_elts);; let peekFixedRelation vM (n,elts) = - let {fixedRelations = fixRels} = vM + let Model {fixedRelations} = vM in let fixRels = fixedRelations in match Name_arity.Map.peek fixRels (n, length elts) with None -> None @@ -5860,7 +6128,7 @@ let defaultFixed = setFixed; listFixed];; -let default = {sizep = defaultSize; fixed = defaultFixed};; +let default = Parameters {sizep = defaultSize; fixed = defaultFixed};; (* ------------------------------------------------------------------------- *) (* Taking apart terms to interpret them. *) @@ -5868,11 +6136,11 @@ let default = {sizep = defaultSize; fixed = defaultFixed};; let destTerm tm = match tm with - Term.Var _ -> tm + Term.Tvar _ -> tm | Term.Fn f_tms -> match Term.stripApp tm with (_,[]) -> tm - | (Term.Var _ as v, tms) -> Term.Fn (Term.appName, v :: tms) + | (Term.Tvar _ as v, tms) -> Term.Fn (Term.appName, v :: tms) | (Term.Fn (f,tms), tms') -> Term.Fn (f, tms @ tms');; (* ------------------------------------------------------------------------- *) @@ -5883,7 +6151,7 @@ let interpretFunction vM n_elts = match peekFixedFunction vM n_elts with Some r -> r | None -> - let {randomFunctions = rndFns} = vM + let Model {randomFunctions} = vM in let rndFns = randomFunctions in lookupTables rndFns n_elts ;; @@ -5892,7 +6160,7 @@ let interpretRelation vM n_elts = match peekFixedRelation vM n_elts with Some r -> r | None -> - let {randomRelations = rndRels} = vM + let Model {randomRelations} = vM in let rndRels = randomRelations in intToBool (lookupTables rndRels n_elts) ;; @@ -5900,7 +6168,7 @@ let interpretRelation vM n_elts = let interpretTerm vM vV = let rec interpret tm = match destTerm tm with - Term.Var v -> getValuation vV v + Term.Tvar v -> getValuation vV v | Term.Fn (f,tms) -> interpretFunction vM (f, List.map interpret tms) in interpret @@ -5914,8 +6182,8 @@ let interpretFormula vM = in let rec interpret vV fm = match fm with - Formula.True -> true - | Formula.False -> false + 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 @@ -5956,7 +6224,7 @@ let check interpret maxChecks vM fv x = 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 = vN} fv, acc) + in let randomCheck acc = score (randomValuation (Size {size = vN}) fv, acc) in let maxChecks = match maxChecks with @@ -5968,7 +6236,7 @@ let check interpret maxChecks vM fv x = in match maxChecks with Some m -> funpow m randomCheck (0, 0) - | None -> foldValuation {size = vN} fv score (0, 0) + | None -> foldValuation (Size {size = vN}) fv score (0, 0) ;; let checkAtom maxChecks vM atm = @@ -5988,7 +6256,7 @@ let checkClause maxChecks vM cl = (* ------------------------------------------------------------------------- *) let updateFunction vM func_elts_elt = - let {randomFunctions = rndFns} = vM + let Model {randomFunctions} = vM in let rndFns = randomFunctions in let () = updateTables rndFns func_elts_elt in @@ -5996,7 +6264,7 @@ let updateFunction vM func_elts_elt = ;; let updateRelation vM (rel_elts,pol) = - let {randomRelations = rndRels} = vM + let Model {randomRelations} = vM in let rndRels = randomRelations in let () = updateTables rndRels (rel_elts, boolToInt pol) in @@ -6014,7 +6282,7 @@ type modelTerm = let modelTerm vM vV = let rec modelTm tm = match destTerm tm with - Term.Var v -> (Model_var, getValuation vV v) + Term.Tvar v -> (Model_var, getValuation vV v) | Term.Fn (f,tms) -> let (tms,xs) = unzip (List.map modelTm tms) in @@ -6131,25 +6399,24 @@ module Term_net = struct (* ------------------------------------------------------------------------- *) let anonymousName = Name.fromString "_";; -let anonymousVar = Term.Var anonymousName;; +let anonymousVar = Term.Tvar anonymousName;; (* ------------------------------------------------------------------------- *) (* Quotient terms. *) (* ------------------------------------------------------------------------- *) type qterm = - Var + 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 + (* if q1 == q2 then cmp qs else *) match q1_q2 with - (Var,Var) -> 0 - | (Var, Fn _) -> -1 - | (Fn _, Var) -> 1 + (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 = @@ -6166,13 +6433,13 @@ let equalQterm q1 q2 = compareQterm q1 q2 = 0;; let equalFnQterm f1 f2 = compareFnQterm f1 f2 = 0;; let rec termToQterm = function - (Term.Var _) -> Var + (Term.Tvar _) -> Qvar | (Term.Fn (f,l)) -> Fn ((f, length l), List.map termToQterm l);; let rec qm = function [] -> true - | ((Var,_) :: rest) -> qm rest - | ((Fn _, Var) :: _) -> false + | ((Qvar,_) :: rest) -> qm rest + | ((Fn _, Qvar) :: _) -> false | ((Fn (f,a), Fn (g,b)) :: rest) -> Name_arity.equal f g && qm (zip a b @ rest);; @@ -6180,8 +6447,8 @@ let rec termToQterm = function let rec qm = function [] -> true - | ((Var,_) :: rest) -> qm rest - | ((Fn _, Term.Var _) :: _) -> false + | ((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);; @@ -6189,11 +6456,11 @@ let rec termToQterm = function let rec qn qsub = function [] -> Some qsub - | ((Term.Var v, qtm) :: rest) -> + | ((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 _, Var) :: _) -> 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;; @@ -6201,8 +6468,8 @@ let rec termToQterm = function let matchTermQterm qsub tm qtm = qn qsub [(tm,qtm)];; let rec qv s t = match (s,t) with - (Var, x) -> x - | (x, Var) -> x + (Qvar, x) -> x + | (x, Qvar) -> x | (Fn (f,a), Fn (g,b)) -> let _ = Name_arity.equal f g || failwith "Term_net.qv" in @@ -6211,8 +6478,8 @@ let rec termToQterm = function let rec qu qsub = function [] -> qsub - | ((Var, _) :: rest) -> qu qsub rest - | ((qtm, Term.Var v) :: rest) -> + | ((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 @@ -6226,7 +6493,7 @@ let rec termToQterm = function let unifyQtermTerm qsub qtm tm = Useful.total (qu qsub) [(qtm,tm)];; let rec qtermToTerm = function - Var -> anonymousVar + Qvar -> anonymousVar | (Fn ((f,_),l)) -> Term.Fn (f, List.map qtermToTerm l);; @@ -6234,7 +6501,7 @@ let rec termToQterm = function (* A type of term sets that can be efficiently matched and unified. *) (* ------------------------------------------------------------------------- *) -type parameters = {fifo : bool};; +type parameters = Parameters of {fifo : bool};; type 'a net = Result of 'a list @@ -6280,7 +6547,7 @@ let singles qtms a = Mlist.foldr (fun (x, y) -> Single (x, y)) a qtms;; | (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)) -> + | (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 @@ -6367,7 +6634,7 @@ let toString net = "Term_net[" ^ string_of_int (size net) ^ "]";; in let rest = match v with None -> rest - | Some net -> (n, stackAddQterm Var stack, net) :: rest + | Some net -> (n, stackAddQterm Qvar stack, net) :: rest in let getFns ((_,k) as f, net, x) = (k + n, stackAddFn f stack, net) :: x @@ -6383,7 +6650,7 @@ let foldEqualTerms pat inc acc = ([],net) -> inc (pat,net,acc) | (pat :: pats, Single (qtm,net)) -> if equalQterm pat qtm then fold (pats,net) else acc - | (Var :: pats, Multiple (v,_)) -> + | (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 @@ -6399,7 +6666,7 @@ let foldEqualTerms pat inc acc = [] -> acc | (([],stack,net) :: rest) -> fold inc (inc (stackValue stack, net, acc)) rest - | ((Var :: pats, stack, net) :: 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) @@ -6434,7 +6701,8 @@ let foldEqualTerms pat inc acc = let idwise (m,_) (n,_) = Useful.intCompare m n;; - let fifoize ({fifo=fifo} : parameters) l = if fifo then List.sort idwise l else l;; + let fifoize (Parameters {fifo}) l = + if fifo then List.sort idwise l else l;; let finally parm l = List.map snd (fifoize parm l);; @@ -6449,7 +6717,7 @@ let foldEqualTerms pat inc acc = in let rest = match tm with - Term.Var _ -> rest + Term.Tvar _ -> rest | Term.Fn (f,l) -> match Name_arity.Map.peek fs (f, length l) with None -> rest @@ -6477,7 +6745,7 @@ let foldEqualTerms pat inc acc = (match matchTermQterm qsub tm qtm with None -> mat acc rest | Some qsub -> mat acc ((qsub,net,tms) :: rest)) - | ((qsub, (Multiple _ as net), Term.Var v :: 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)) @@ -6507,7 +6775,7 @@ let foldEqualTerms pat inc acc = (match unifyQtermTerm qsub qtm tm with None -> mat acc rest | Some qsub -> mat acc ((qsub,net,tms) :: rest)) - | ((qsub, (Multiple _ as net), Term.Var v :: 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)) @@ -6544,7 +6812,7 @@ module Atom_net = struct let atomToTerm atom = Term.Fn atom;; let termToAtom = function - (Term.Var _) -> raise (Useful.Bug "Atom_net.termToAtom") + (Term.Tvar _) -> raise (Useful.Bug "Atom_net.termToAtom") | (Term.Fn atom) -> atom;; (* ------------------------------------------------------------------------- *) @@ -6601,7 +6869,7 @@ module Literal_net = struct type parameters = Atom_net.parameters;; -type 'a literalNet = +type 'a literalNet = Literal_net of {positive : 'a Atom_net.atomNet; negative : 'a Atom_net.atomNet};; @@ -6609,28 +6877,28 @@ type 'a literalNet = (* Basic operations. *) (* ------------------------------------------------------------------------- *) -let newNet parm = {positive = Atom_net.newNet parm; negative = Atom_net.newNet parm};; +let newNet parm = Literal_net {positive = Atom_net.newNet parm; negative = Atom_net.newNet parm};; - let pos ({positive=positive} : 'a literalNet) = Atom_net.size positive;; + let pos (Literal_net {positive}) = Atom_net.size positive;; - let neg ({negative=negative} : 'a literalNet) = Atom_net.size negative;; + 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 {positive=positive;negative=negative} = function +let insert (Literal_net {positive;negative}) = function ((true,atm),a) -> - {positive = Atom_net.insert positive (atm,a); negative = negative} + Literal_net {positive = Atom_net.insert positive (atm,a); negative = negative} | ((false,atm),a) -> - {positive = positive; negative = Atom_net.insert negative (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 {positive=positive;negative=negative} = - {positive = Atom_net.filter pred positive; - negative = Atom_net.filter pred negative};; +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) ^ "]";; @@ -6642,17 +6910,17 @@ let toString net = "Literal_net[" ^ string_of_int (size net) ^ "]";; (* Filter afterwards to get the precise set of satisfying values. *) (* ------------------------------------------------------------------------- *) -let matchNet ({positive=positive;negative=negative} : 'a literalNet) = function +let matchNet (Literal_net {positive;negative}) = function (true,atm) -> Atom_net.matchNet positive atm | (false,atm) -> Atom_net.matchNet negative atm;; -let matched ({positive=positive;negative=negative} : 'a literalNet) = function +let matched (Literal_net {positive;negative}) = function (true,atm) -> Atom_net.matched positive atm | (false,atm) -> Atom_net.matched negative atm;; -let unify ({positive=positive;negative=negative} : 'a literalNet) = function +let unify (Literal_net {positive;negative}) = function (true,atm) -> Atom_net.unify positive atm | (false,atm) -> Atom_net.unify negative atm;; @@ -6725,42 +6993,42 @@ type clauseLength = int;; (* A type of clause sets that supports efficient subsumption checking. *) (* ------------------------------------------------------------------------- *) -type 'a nonunit_t = +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 = +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};; -open Term_net let newSubsume () = - {empty = []; - unitn = Literal_net.newNet {fifo = false}; + Subsume {empty = []; + unitn = Literal_net.newNet (Term_net.Parameters {fifo = false}); nonunit = - {nextId = 0; + Nonunit {nextId = 0; clauses = Intmap.newMap (); - fstLits = Literal_net.newNet {fifo = false}; - sndLits = Literal_net.newNet {fifo = false}}};; + fstLits = Literal_net.newNet (Term_net.Parameters {fifo = false}); + sndLits = Literal_net.newNet (Term_net.Parameters {fifo = false})}};; -let size ({empty=empty; unitn=unitn; nonunit = {clauses=clauses}}) = +let size (Subsume {empty; unitn; nonunit}) = + let Nonunit {clauses} = nonunit in length empty + Literal_net.size unitn + Intmap.size clauses;; -let insert ({empty=empty;unitn=unitn;nonunit=nonunit}) (cl',a) = +let insert (Subsume {empty;unitn;nonunit}) (cl',a) = match sortClause cl' with [] -> let empty = (cl',Substitute.empty,a) :: empty in - {empty = empty; unitn = unitn; nonunit = nonunit} + Subsume {empty = empty; unitn = unitn; nonunit = nonunit} | [lit] -> let unitn = Literal_net.insert unitn (lit,(lit,cl',a)) in - {empty = empty; unitn = unitn; nonunit = nonunit} + Subsume {empty = empty; unitn = unitn; nonunit = nonunit} | fstLit :: (sndLit :: otherLits as nonFstLits) -> - let {nextId=nextId;clauses=clauses;fstLits=fstLits;sndLits=sndLits} = nonunit + 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) = @@ -6771,21 +7039,20 @@ let insert ({empty=empty;unitn=unitn;nonunit=nonunit}) (cl',a) = in let lits' = otherLits @ [fstLit;sndLit] in let clauses = Intmap.insert clauses (nextId,(lits',cl',a)) in let nextId = nextId + 1 - in let nonunit = {nextId = nextId; clauses = clauses; + in let nonunit = Nonunit {nextId = nextId; clauses = clauses; fstLits = fstLits; sndLits = sndLits} in - {empty = empty; unitn = unitn; nonunit = nonunit} + Subsume {empty = empty; unitn = unitn; nonunit = nonunit} ;; -let filter pred ({empty=empty;unitn=unitn;nonunit=nonunit}) = - let pred3 (_,_,x) = pred x - in let empty = List.filter pred3 empty +let filter pred (Subsume {empty;unitn;nonunit}) = + let empty = List.filter (fun (_,_,x) -> pred x) empty - in let unitn = Literal_net.filter pred3 unitn + in let unitn = Literal_net.filter (fun (_,_,x) -> pred x) unitn in let nonunit = - let {nextId=nextId;clauses=clauses;fstLits=fstLits;sndLits=sndLits} = nonunit - in let clauses' = Intmap.filter (fun x -> pred3 (snd x)) clauses + 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 @@ -6793,10 +7060,10 @@ let filter pred ({empty=empty;unitn=unitn;nonunit=nonunit}) = in let fstLits = Literal_net.filter predId fstLits and sndLits = Literal_net.filter predId sndLits in - {nextId = nextId; clauses = clauses'; + Nonunit {nextId = nextId; clauses = clauses'; fstLits = fstLits; sndLits = sndLits} in - {empty = empty; unitn = unitn; nonunit = nonunit} + Subsume {empty = empty; unitn = unitn; nonunit = nonunit} ;; let toString subsume = "Subsume{" ^ string_of_int (size subsume) ^ "}";; @@ -6866,7 +7133,7 @@ let toString subsume = "Subsume{" ^ string_of_int (size subsume) ^ "}";; in let subLit lits (lit,acc) = Mlist.foldl addId acc (Literal_net.matchNet lits lit) - in let {nextId = _; clauses=clauses; fstLits=fstLits; sndLits=sndLits} = nonunit + in let Nonunit {clauses;fstLits;sndLits} = nonunit in let subCl' (id,_) = let (lits',cl',a) = Intmap.get clauses id @@ -6880,7 +7147,7 @@ let toString subsume = "Subsume{" ^ string_of_int (size subsume) ^ "}";; Pset.firstl subCl' cands ;; - let genSubsumes pred ({empty=empty;unitn=unitn;nonunit=nonunit}) max cl = + let genSubsumes pred (Subsume {empty;unitn;nonunit}) max cl = match emptySubsumes pred empty with (Some _) as s -> s | None -> @@ -6981,7 +7248,7 @@ let firstNotEqualTerm f l = (* one unary function with weight 0. *) (* ------------------------------------------------------------------------- *) -type kbo = +type kbo = Kbo of {weight : Term.function_t -> int; precedence : Term.function_t -> Term.function_t -> int};; @@ -6998,7 +7265,7 @@ let arityPrecedence : Term.function_t -> Term.function_t -> int = (* The default order *) -let default = {weight = uniformWeight; precedence = arityPrecedence};; +let default = Kbo {weight = uniformWeight; precedence = arityPrecedence};; (* ------------------------------------------------------------------------- *) (* Term weight-1 represented as a linear function of the weight-1 of the *) @@ -7031,8 +7298,8 @@ 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.value (Name.Map.peek m v) ~default:0 + | (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) -> @@ -7075,7 +7342,7 @@ let weightToString = Print.toString ppWeight;; (* The Knuth-Bendix term order. *) (* ------------------------------------------------------------------------- *) -let compare {weight=weight;precedence=precedence} = +let compare (Kbo {weight;precedence}) = let weightDifference tm1 tm2 = let w1 = weightTerm weight tm1 and w2 = weightTerm weight tm2 @@ -7177,45 +7444,42 @@ type equationId = int;; type equation = Rule.equation;; -type rewrite_t = +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};; -type rewrite = - Rewrite of rewrite_t;; - let updateWaiting rw waiting = - let Rewrite {order=order; known=known; redexes=redexes; subterms=subterms; waiting = _} = rw + let Rewrite {order; known; redexes; subterms} = rw in Rewrite {order = order; known = known; redexes = redexes; subterms = subterms; waiting = waiting} ;; -let deleteWaiting (Rewrite {waiting=waiting} as rw) id = +let deleteWaiting rw id = + let Rewrite {waiting} = rw in updateWaiting rw (Intset.delete waiting id);; (* ------------------------------------------------------------------------- *) (* Basic operations *) (* ------------------------------------------------------------------------- *) -open Term_net let newRewrite order = Rewrite {order = order; known = Intmap.newMap (); - redexes = Term_net.newNet {fifo = false}; - subterms = Term_net.newNet {fifo = false}; + 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=known}) id = Intmap.peek known id;; +let peek (Rewrite {known}) id = Intmap.peek known id;; -let size (Rewrite {known=known}) = Intmap.size known;; +let size (Rewrite {known}) = Intmap.size known;; -let equations (Rewrite {known=known}) = +let equations (Rewrite {known}) = Intmap.foldr (fun (_,(eqn,_),eqns) -> eqn :: eqns) [] known;; @@ -7292,7 +7556,7 @@ let termReducible order known id = in let rec termRed tm = Intmap.exists (knownRed tm) known || subtermRed tm and subtermRed = function - (Term.Var _) -> false + (Term.Tvar _) -> false | (Term.Fn (_,tms)) -> List.exists termRed tms in termRed @@ -7326,10 +7590,11 @@ let orderToOrient = function | None -> ins (ins redexes l id Left_to_right) r id Right_to_left;; -let add (Rewrite {known=known} as rw) (id,eqn) = +let add rw (id,eqn) = + let Rewrite {known} = rw in if Intmap.inDomain id known then rw else - let Rewrite {order=order;redexes=redexes;subterms=subterms;waiting=waiting} = rw + let Rewrite {order;redexes;subterms;waiting} = rw in let ort = let (l,r) = fst eqn in orderToOrient (order l r) @@ -7468,9 +7733,9 @@ let rewriteIdEqn' order known redexes id ((l_r,th) as eqn) = 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);; + (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);; *) @@ -7532,23 +7797,23 @@ let rewriteIdRule' = fun order -> fun known -> fun redexes -> fun id -> fun th - handle Failure err -> failwith ("Rewrite.rewriteIdRule:\n" ^ err);; *) -let rewrIdConv (Rewrite {known=known;redexes=redexes}) order = +let rewrIdConv (Rewrite {known;redexes}) order = rewrIdConv' order known redexes;; let rewrConv rewrite order = rewrIdConv rewrite order (-1);; -let rewriteIdConv (Rewrite {known=known;redexes=redexes}) order = +let rewriteIdConv (Rewrite {known;redexes}) order = rewriteIdConv' order known redexes;; let rewriteConv rewrite order = rewriteIdConv rewrite order (-1);; -let rewriteIdLiteralsRule (Rewrite {known=known;redexes=redexes}) order = +let rewriteIdLiteralsRule (Rewrite {known;redexes}) order = rewriteIdLiteralsRule' order known redexes;; let rewriteLiteralsRule rewrite order = rewriteIdLiteralsRule rewrite order (-1);; -let rewriteIdRule (Rewrite {known=known;redexes=redexes}) order = +let rewriteIdRule (Rewrite {known;redexes}) order = rewriteIdRule' order known redexes;; let rewriteRule rewrite order = rewriteIdRule rewrite order (-1);; @@ -7604,7 +7869,7 @@ let findReducibles order known subterms id = let reduce1 newx id (eqn0,ort0) (rpl,spl,todo,rw,changed) = let (eq0,_) = eqn0 - in let Rewrite {order=order;known=known;redexes=redexes;subterms=subterms;waiting=waiting} = rw + 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 @@ -7702,7 +7967,7 @@ let pick known set = let () = Print.trace ppPl "Rewrite.rebuild: rpl" rpl let () = Print.trace ppPl "Rewrite.rebuild: spl" spl *) - let Rewrite {order=order;known=known;redexes=redexes;subterms=subterms;waiting=waiting} = rw + let Rewrite {order;known;redexes;subterms;waiting} = rw in let redexes = cleanRedexes known redexes rpl in let subterms = cleanSubterms known subterms spl in @@ -7714,7 +7979,8 @@ let pick known set = waiting = waiting} ;; -let rec reduceAcc (rpl, spl, todo, (Rewrite {known=known;waiting=waiting} as rw), changed) = +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 @@ -7728,7 +7994,7 @@ let rec reduceAcc (rpl, spl, todo, (Rewrite {known=known;waiting=waiting} as rw) reduceAcc (reduce1 true id eqn_ort (rpl,spl,todo,rw,changed)) | None -> (rebuild rpl spl rw, Intset.toList changed);; -let isReduced (Rewrite {waiting=waiting}) = Intset.null waiting;; +let isReduced (Rewrite {waiting}) = Intset.null waiting;; let reduce' rw = if isReduced rw then (rw,[]) @@ -7793,8 +8059,7 @@ type units = Units of unitThm Literal_net.literalNet;; (* Basic operations. *) (* ------------------------------------------------------------------------- *) -open Term_net -let empty = Units (Literal_net.newNet {fifo = false});; +let empty = Units (Literal_net.newNet (Term_net.Parameters {fifo = false}));; let size (Units net) = Literal_net.size net;; @@ -7899,23 +8164,21 @@ type literalOrder = | Unsigned_literal_order | Positive_literal_order;; -type parameters = +type parameters = Parameters of {ordering : Knuth_bendix_order.kbo; orderLiterals : literalOrder; orderTerms : bool};; type clauseId = int;; -type clauseInfo = {parameters : parameters; id : clauseId; thm : Thm.thm};; - -type clause = Clause of clauseInfo;; +type clause = Clause of {parameters : parameters; id : clauseId; thm : Thm.thm};; (* ------------------------------------------------------------------------- *) (* Pretty printing. *) (* ------------------------------------------------------------------------- *) -let toString (Clause {id=id;thm=thm}) = Thm.toString thm;; +let toString (Clause {id;thm}) = Thm.toString thm;; (* ------------------------------------------------------------------------- *) @@ -7923,17 +8186,15 @@ let toString (Clause {id=id;thm=thm}) = Thm.toString thm;; (* ------------------------------------------------------------------------- *) let default : parameters = - {ordering = Knuth_bendix_order.default; + Parameters {ordering = Knuth_bendix_order.default; orderLiterals = Positive_literal_order; orderTerms = true};; -let mk info = Clause info +(* mk and dest removed - use Clause {fields} directly *) -let dest (Clause info) = info;; +let id (Clause {id}) = id;; -let id (Clause {id = i}) = i;; - -let thm (Clause {thm = th}) = th;; +let thm (Clause {thm}) = thm;; let equalThms cl cl' = Thm.equal (thm cl) (thm cl');; @@ -7942,9 +8203,9 @@ let newClause parameters thm = let literals cl = Thm.clause (thm cl);; -let isTautology (Clause {thm=thm}) = Thm.isTautology thm;; +let isTautology (Clause {thm}) = Thm.isTautology thm;; -let isContradiction (Clause {thm=thm}) = Thm.isContradiction thm;; +let isContradiction (Clause {thm}) = Thm.isContradiction thm;; (* ------------------------------------------------------------------------- *) (* The term ordering is used to cut down inferences. *) @@ -7955,7 +8216,7 @@ let strictlyLess ordering x y = Some c when c < 0 -> true | _ -> false;; -let isLargerTerm ({ordering=ordering;orderTerms=orderTerms} : parameters) (l,r) = +let isLargerTerm (Parameters {ordering;orderTerms}) (l,r) = not orderTerms || not (strictlyLess ordering l r);; let atomToTerms atm = @@ -7969,7 +8230,7 @@ let isLargerTerm ({ordering=ordering;orderTerms=orderTerms} : parameters) (l,r) not (List.for_all less xs) ;; - let isLargerLiteral ({ordering=ordering;orderLiterals=orderLiterals} : parameters) lits = + let isLargerLiteral (Parameters {ordering;orderLiterals}) lits = match orderLiterals with No_literal_order -> K true | Unsigned_literal_order -> @@ -7993,7 +8254,7 @@ let isLargerTerm ({ordering=ordering;orderTerms=orderTerms} : parameters) (l,r) ;; -let largestLiterals (Clause {parameters=parameters;thm=thm}) = +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 @@ -8013,7 +8274,8 @@ let largestLiterals = fun cl -> end;; *) -let largestEquations (Clause {parameters=parameters} as cl) = +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 @@ -8050,20 +8312,20 @@ let subsumes (subs : clause Subsume.subsume) cl = (* Simplifying rules: these preserve the clause id. *) (* ------------------------------------------------------------------------- *) -let freshVars (Clause {parameters=parameters;id=id;thm=thm}) = +let freshVars (Clause {parameters;id;thm}) = Clause {parameters = parameters; id = id; thm = Rule.freshVars thm};; -let simplify (Clause {parameters=parameters;id=id;thm=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=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=parameters;id=id;thm=thm}) = +let rewrite rewr (Clause {parameters;id;thm}) = let simp th = - let {ordering=ordering} = parameters + let Parameters {ordering} = parameters in let cmp = Knuth_bendix_order.compare ordering in Rewrite.rewriteIdRule rewr cmp id th @@ -8094,7 +8356,8 @@ let rewrite rewr (Clause {parameters=parameters;id=id;thm=thm}) = (* Inference rules: these generate new clause ids. *) (* ------------------------------------------------------------------------- *) -let factor (Clause {parameters=parameters;thm=thm} as cl) = +let factor cl = + let Clause {parameters;thm} = cl in let lits = largestLiterals cl in let apply sub = newClause parameters (Thm.subst sub thm) @@ -8120,8 +8383,8 @@ let resolve (cl1,lit1) (cl2,lit2) = let () = Print.trace pp "Clause.resolve: cl2" cl2 let () = Print.trace Literal.pp "Clause.resolve: lit2" lit2 *) - let Clause {parameters=parameters; thm = th1} = cl1 - and Clause {thm = th2} = cl2 + 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 @@ -8163,8 +8426,8 @@ let paramodulate (cl1,lit1,ort1,tm1) (cl2,lit2,path2,tm2) = let () = Print.trace Term.ppPath "Clause.paramodulate: path2" path2 let () = Print.trace Term.pp "Clause.paramodulate: tm2" tm2 *) - let Clause {parameters=parameters; thm = th1} = cl1 - and Clause {thm = th2} = cl2 + 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 @@ -8207,8 +8470,8 @@ end module Ax_cj = struct -type ax_cj_thm = {axioms_thm : Thm.thm list; conjecture_thm : Thm.thm list};; -type ax_cj_cl = {axioms_cl : Clause.clause list; conjecture_cl : Clause.clause list};; +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 @@ -8218,8 +8481,6 @@ end module Active = struct -open Ax_cj - (* ------------------------------------------------------------------------- *) (* Helper functions. *) (* ------------------------------------------------------------------------- *) @@ -8230,7 +8491,7 @@ local let let add (cl,rw) = let - let {id, thm = th, ...} = Clause.dest cl + 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)) @@ -8420,14 +8681,14 @@ let checkSaturated ordering subs cls = (* A type of active clause sets. *) (* ------------------------------------------------------------------------- *) -type simplify = {subsumes : bool; reduce : bool; rewrites : bool};; +type simplify = Simplify of {subsumes : bool; reduce : bool; rewrites : bool};; -type parameters = +type parameters = Parameters of {clause : Clause.parameters; prefactor : simplify; postfactor : simplify};; -type active_t = +type active = Active of {parameters : parameters; clauses : Clause.clause Intmap.map; units : Units.units; @@ -8442,15 +8703,12 @@ type active_t = Term_net.termNet; allSubterms : (Clause.clause * Term.term) Term_net.termNet};; -type active = - Active of active_t;; - -let getSubsume (Active {subsume = s}) = s;; +let getSubsume (Active {subsume}) = subsume;; let setRewrite active rewrite = let Active - {parameters=parameters;clauses=clauses;units=units;subsume=subsume;literals=literals;equations=equations; - subterms=subterms;allSubterms=allSubterms} = active + {parameters;clauses;units;subsume;literals;equations; + subterms;allSubterms} = active in Active {parameters = parameters; clauses = clauses; units = units; @@ -8462,17 +8720,16 @@ let setRewrite active rewrite = (* Basic operations. *) (* ------------------------------------------------------------------------- *) -let maxSimplify : simplify = {subsumes = true; reduce = true; rewrites = true};; +let maxSimplify : simplify = Simplify {subsumes = true; reduce = true; rewrites = true};; let default : parameters = - {clause = Clause.default; + Parameters {clause = Clause.default; prefactor = maxSimplify; postfactor = maxSimplify};; -open Term_net let empty parameters = - let {clause=clause} = parameters - in let {Clause.ordering=ordering} = clause + let Parameters {clause} = parameters + in let Clause.Parameters {ordering} = clause in Active {parameters = parameters; @@ -8480,15 +8737,16 @@ let empty parameters = units = Units.empty; rewrite = Rewrite.newRewrite (Knuth_bendix_order.compare ordering); subsume = Subsume.newSubsume (); - literals = Literal_net.newNet {fifo = false}; - equations = Term_net.newNet {fifo = false}; - subterms = Term_net.newNet {fifo = false}; - allSubterms = Term_net.newNet {fifo = false}} + 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=clauses}) = Intmap.size clauses;; +let size (Active {clauses}) = Intmap.size clauses;; -let clauses (Active {clauses = cls}) = +let clauses (Active {clauses}) = + let cls = clauses in let add (_,cl,acc) = cl :: acc in Intmap.foldr add [] cls @@ -8528,7 +8786,8 @@ let toString active = "Active{" ^ string_of_int (size active) ^ "}";; (* ------------------------------------------------------------------------- *) let simplify simp units rewr subs = - let {subsumes = s; reduce = r; rewrites = w} = simp + 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 @@ -8605,7 +8864,7 @@ let simplify = fun simp -> fun units -> fun rewr -> fun subs -> fun cl -> *) let simplifyActive simp active = - let Active {units=units;rewrite=rewrite;subsume=subsume} = active + let Active {units;rewrite;subsume} = active in simplify simp units rewrite subsume ;; @@ -8663,8 +8922,8 @@ let addAllSubterms allSubterms cl = let addClause active cl = let Active - {parameters=parameters;clauses=clauses;units=units;rewrite=rewrite;subsume=subsume;literals=literals; - equations=equations;subterms=subterms;allSubterms=allSubterms} = 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 @@ -8681,8 +8940,8 @@ let addClause active cl = let addFactorClause active cl = let Active - {parameters=parameters;clauses=clauses;units=units;rewrite=rewrite;subsume=subsume;literals=literals; - equations=equations;subterms=subterms;allSubterms=allSubterms} = active + {parameters;clauses;units;rewrite;subsume;literals; + equations;subterms;allSubterms} = active in let units = addUnit units cl and rewrite = addRewrite rewrite cl in @@ -8734,7 +8993,7 @@ let deduceParamodulationInto equations cl ((lit,path,tm),acc) = ;; let deduce active cl = - let Active {parameters=parameters;literals=literals;equations=equations;subterms=subterms} = active + let Active {parameters;literals;equations;subterms} = active in let lits = Clause.largestLiterals cl in let eqns = Clause.largestEquations cl @@ -8771,7 +9030,7 @@ let deduce active cl = (* ------------------------------------------------------------------------- *) let clause_rewritables active = - let Active {clauses=clauses;rewrite=rewrite} = active + let Active {clauses;rewrite} = active in let rewr (id,cl,ids) = let cl' = Clause.rewrite rewrite cl @@ -8793,8 +9052,9 @@ let deduce active cl = | Some _ -> [];; let rewrite_rewritables active rewr_ids = - let Active {parameters=parameters;rewrite=rewrite;clauses=clauses;allSubterms=allSubterms} = active - in let {clause = {Clause.ordering=ordering}} = parameters + 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) = @@ -8886,24 +9146,24 @@ let deduce active cl = in let clausePred cl = idPred (Clause.id cl) in let Active - {parameters=parameters; - clauses=clauses; - units=units; - rewrite=rewrite; - subsume=subsume; - literals=literals; - equations=equations; - subterms=subterms; - allSubterms=allSubterms} = 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 cP1 literals - and equations = Term_net.filter cP1_4 equations - and subterms = Term_net.filter cP1_4 subterms - and allSubterms = Term_net.filter cP1 allSubterms + 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; @@ -8917,7 +9177,8 @@ let deduce active cl = allSubterms = allSubterms} ;; - let extract_rewritables (Active {clauses=clauses;rewrite=rewrite} as active) = + let extract_rewritables active = + let Active {clauses;rewrite} = active in if Rewrite.isReduced rewrite then (active,[]) else (*MetisTrace3 @@ -8944,15 +9205,15 @@ let deduce active cl = (* ------------------------------------------------------------------------- *) let prefactor_simplify active subsume = - let Active {parameters=parameters;units=units;rewrite=rewrite} = active - in let {prefactor=prefactor} = parameters + 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=parameters;units=units;rewrite=rewrite} = active - in let {postfactor=postfactor} = parameters + let Active {parameters;units;rewrite} = active + in let Parameters {postfactor} = parameters in simplify postfactor units rewrite subsume ;; @@ -9031,17 +9292,17 @@ let factor = fun active -> fun cls -> (* ------------------------------------------------------------------------- *) let mk_clause params th = - Clause.mk {Clause.parameters = params; Clause.id = Clause.newId (); Clause.thm = th};; + Clause.Clause {parameters = params; id = Clause.newId (); thm = th};; -let newActive parameters {axioms_thm=axioms_thm;conjecture_thm=conjecture_thm} = - let {clause=clause} = parameters +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, {axioms_cl = axioms; conjecture_cl = conjecture}) + (active, Ax_cj.Ax_cj_cl {axioms_cl = axioms; conjecture_cl = conjecture}) ;; (* ------------------------------------------------------------------------- *) @@ -9079,22 +9340,20 @@ end module Waiting = struct -open Ax_cj - (* ------------------------------------------------------------------------- *) (* A type of waiting sets of clauses. *) (* ------------------------------------------------------------------------- *) type weight = float;; -type modelParameters = +type modelParameters = Model_parameters of {model : Model.parameters; initialPerturbations : int; maxChecks : int option; perturbations : int; weight : weight} -type parameters = +type parameters = Parameters of {symbolsWeight : weight; variablesWeight : weight; literalsWeight : weight; @@ -9102,32 +9361,29 @@ type parameters = type distance = float;; -type waiting_t = +type waiting = Waiting of {parameters : parameters; clauses : (weight * (distance * Clause.clause)) Heap.heap; models : Model.model list};; -type waiting = - Waiting of waiting_t;; - (* ------------------------------------------------------------------------- *) (* Basic operations. *) (* ------------------------------------------------------------------------- *) let defaultModels : modelParameters list = - [{model = Model.default; + [Model_parameters {model = Model.default; initialPerturbations = 100; maxChecks = Some 20; perturbations = 0; - weight = 1.0}];; + weight = Float.one}];; let default : parameters = - {symbolsWeight = 1.0; - literalsWeight = 1.0; - variablesWeight = 1.0; + Parameters {symbolsWeight = Float.one; + literalsWeight = Float.one; + variablesWeight = Float.one; modelsP = defaultModels};; -let size (Waiting {clauses=clauses}) = Heap.size clauses;; +let size (Waiting {clauses}) = Heap.size clauses;; let toString w = "Waiting{" ^ string_of_int (size w) ^ "}";; @@ -9161,7 +9417,7 @@ let mkModelClauses = List.map mkModelClause;; let perturbModel vM cls = if Mlist.null cls then K () else - let vN = {Model.size = Model.msize vM} + let vN = Model.Size {size = Model.msize vM} in let perturbClause (fv,cl) = let vV = Model.randomValuation vN fv @@ -9175,7 +9431,7 @@ let perturbModel vM cls = ;; let initialModel axioms conjecture parm = - let {model=model;initialPerturbations=initialPerturbations} = 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 @@ -9185,18 +9441,18 @@ let initialModel axioms conjecture parm = let checkModels parms models (fv,cl) = let check ((parm,model),z) = - let {maxChecks=maxChecks;weight=weight} = parm + let Model_parameters {maxChecks;weight} = parm in let n = maxChecks in let (vT,vF) = Model.check Model.interpretClause n model fv cl in - (1.0 +. float_of_int vT /. float_of_int (vT + vF) ** weight) *. z + (Float.one +. float_of_int vT /. float_of_int (vT + vF) ** weight) *. z in - Mlist.foldl check 1.0 (zip parms models) + Mlist.foldl check Float.one (zip parms models) ;; let perturbModels parms models cls = let perturb (parm,model) = - let {perturbations=perturbations} = parm + let Model_parameters {perturbations} = parm in perturbModel model cls perturbations in @@ -9214,13 +9470,13 @@ let perturbModels parms models cls = let clauseLiterals cl = float_of_int (Literal.Set.size cl);; - let clausePriority cl = 1e-12 *. float_of_int (Clause.id 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 {symbolsWeight=symbolsWeight;variablesWeight=variablesWeight;literalsWeight=literalsWeight;modelsP=modelsP} = parm + 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 @@ -9253,8 +9509,8 @@ let perturbModels parms models cls = (* ------------------------------------------------------------------------- *) let add' waiting dist mcls cls = - let Waiting {parameters=parameters;clauses=clauses;models=models} = waiting - in let {modelsP = modelParameters} = parameters + let Waiting {parameters;clauses;models} = waiting + in let Parameters {modelsP} = parameters in let modelParameters = modelsP (*MetisDebug let _ = not (Mlist.null cls) || @@ -9295,24 +9551,24 @@ let add waiting (dist,cls) = waiting ;; - let cmp ((w1 : float),_) (w2,_) = compare w1 w2;; + let cmp ((w1 : float),_) ((w2 : float),_) = Float.compare w1 w2;; let empty parameters axioms conjecture = - let {modelsP = modelParameters} = parameters + 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 {axioms_cl=axioms_cl;conjecture_cl=conjecture_cl} = + 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 0.0 (mAxioms @ mConjecture) (axioms_cl @ conjecture_cl) + else add' waiting Float.zero (mAxioms @ mConjecture) (axioms_cl @ conjecture_cl) (*MetisDebug handle e -> let @@ -9326,7 +9582,7 @@ let add waiting (dist,cls) = (* Removing the lightest clause. *) (* ------------------------------------------------------------------------- *) -let remove (Waiting {parameters=parameters;clauses=clauses;models=models}) = +let remove (Waiting {parameters;clauses;models}) = if Heap.null clauses then None else let ((_,dcl),clauses) = Heap.remove clauses @@ -9353,28 +9609,26 @@ module Resolution = struct (* A type of resolution proof procedures. *) (* ------------------------------------------------------------------------- *) -type parameters = +type parameters = Parameters of {activeP : Active.parameters; waitingP : Waiting.parameters};; -type resolution_t = +type resolution = Resolution of {parameters : parameters; active : Active.active; waiting : Waiting.waiting};; -type resolution = - Resolution of resolution_t;; - (* ------------------------------------------------------------------------- *) (* Basic operations. *) (* ------------------------------------------------------------------------- *) let default : parameters = - {activeP = Active.default; + Parameters {activeP = Active.default; waitingP = Waiting.default};; let newResolution parameters ths = - let {activeP = activeParm; waitingP = waitingParm} = parameters + let Parameters {activeP; waitingP} = parameters + in let activeParm = activeP and waitingParm = waitingP in let (active,cls) = Active.newActive activeParm ths (* cls = factored ths *) @@ -9390,9 +9644,9 @@ let newResolution parameters ths = end;; *) -let active (Resolution {active = a}) = a;; +let active (Resolution {active}) = active;; -let waiting (Resolution {waiting = w}) = w;; +let waiting (Resolution {waiting}) = waiting;; (* ------------------------------------------------------------------------- *) @@ -9408,7 +9662,7 @@ type state = | Undecided of resolution;; let iterate res = - let Resolution {parameters=parameters;active=active;waiting=waiting} = res + let Resolution {parameters;active;waiting} = res (*MetisTrace2 let () = Print.trace Active.pp "Resolution.iterate: active" active @@ -9467,10 +9721,8 @@ let rec loop res = Resolution.Decided dec -> Some dec | Resolution.Undecided res -> loop res -open Ax_cj - let run rules = - let ths = {axioms_thm = rules; conjecture_thm = []} in + 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" @@ -9516,6 +9768,7 @@ 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)]) @@ -9523,6 +9776,7 @@ assert Combp (Combp (Varp ("1", Ptycon ("", [])), Varp ("2", Ptycon ("", []))), Varp ("3", Ptycon ("", []))) );; +*) let list_mk_disjp = function [] -> preterm_of_term `F` @@ -9554,8 +9808,6 @@ end module Metis_mapping = struct -open Metis_prover - let reset_consts,fol_of_const,hol_of_const = Meson.reset_consts,Meson.fol_of_const,Meson.hol_of_const @@ -9564,8 +9816,8 @@ 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) -> + 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) @@ -9608,8 +9860,6 @@ end module Metis_path = struct -open Metis_prover - (* The term `f 1 2 3` is encoded in HOL Light as follows: @ @@ -9624,50 +9874,52 @@ open Metis_prover let rec hol_of_term_path tm path = match tm, path with (tm, []) -> tm, "" - | Term.Fn (f, args), i :: is -> + | Metis_prover.Term.Fn (f, args), i :: is -> let arity = length args in - assert (i < arity); + (* 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 (Term.Fn (p, args)) +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 + (s, (if pol then path else "r" ^ path)) end module Metis_unify = struct -open Metis_prover - 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%!" - (Term.toString fat) (string_of_term tm); + (Metis_prover.Term.toString fat) (string_of_term tm); +*) match fat with - Term.Var v when List.mem_assoc v m -> - if !verb then Format.printf "var_assoc\n%!"; + 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 - | Term.Var v -> - if !verb then Format.printf "var\n%!"; + | 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) - | Term.Fn (f, args) -> - if !verb then Format.printf "fn\n%!"; + 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 @@ -9676,7 +9928,7 @@ 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 (Term.Fn (p, args)) htm m + 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 @@ -9746,25 +9998,37 @@ end module Metis_reconstruct2 = struct -open Metis_prover - 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) @@ -9786,11 +10050,11 @@ let reorient_tysubst vars sub = 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%!" (Thm.toString 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 Proof.thmToInference fth with - Proof.Axiom clause -> - let clausel = Literal.Set.toList clause 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 @@ -9799,66 +10063,78 @@ let rec hol_of_thm axioms fth = 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 + (* 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)" *) - | Proof.Subst (fsub, fth1) -> + | 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); + (* if !metisverb then Format.printf "subst with th1 = %s\n%!" (string_of_thm th1); *) - let fsubl = Substitute.toList fsub in - if !metisverb then Format.printf "before substitution lifting\n%!"; - let hsub = map (fun (v, t) -> t, Term.Var v) fsubl |> + 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); + (* 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 - | Proof.Resolve (atom, fth1, fth2) -> + | 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%!"; + (* if !metisverb then Format.printf "Reorienting type substitution ...\n%!"; *) let tyinsts = reorient_tysubst tyvars tyinsts in - if !metisverb then Format.printf "Resolving ...\n%!"; + (* if !metisverb then Format.printf "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) -> + | 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 @@ -9866,31 +10142,37 @@ let rec hol_of_thm axioms fth = 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' = Thm.clause fth |> Literal.Set.toList |> Metis_mapping.hol_of_clause env in + 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 @@ -9901,24 +10183,22 @@ end module Metis_generate = struct -open Metis_prover - let metis_name = string_of_int let rec metis_of_term env consts tm = if is_var tm && not (List.mem tm consts) then - (Term.Var(metis_name (Meson.fol_of_var tm))) + (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 - Term.Fn (metis_name ff, map (metis_of_term env consts) args)) + 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 - Atom.mkEq (l', r') + 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 @@ -9935,8 +10215,8 @@ let metis_of_clause th = 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 set = Metis_prover.Literal.Set.fromList flits in + Metis_prover.Thm.axiom set let metis_of_clauses = map metis_of_clause @@ -9949,8 +10229,6 @@ end module Metis = struct -open Metis_prover - (* ------------------------------------------------------------------------- *) (* Some parameters controlling Metis behaviour. *) (* ------------------------------------------------------------------------- *) @@ -10050,15 +10328,18 @@ 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 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 Format.printf "ths:\n%!"; @@ -10067,9 +10348,12 @@ let SIMPLE_METIS_REFUTE ths = print_thm proof; Format.printf "Metis end.\n%!"; end; +*) let allhyps = List.concat (List.map hyp ths) in +(* assert (forall (fun h -> List.mem h allhyps) (hyp proof)); assert (concl proof = `F`); +*) proof let PURE_METIS_TAC g = 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 *) From 0a56ed8d863927221762cb56e5010593bc94819b Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 13:00:21 +0800 Subject: [PATCH 30/79] Fix impconv.ml --- impconv.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From 70fc251030f5d38818e85525606fad00711a51ac Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 14:53:05 +0800 Subject: [PATCH 31/79] Add a bit of Hashtbl --- candle_insulate.ml | 6 +++++- candle_insulate.py | 37 +++++++++++++++++++++++++++++++------ candle_ocaml.ml | 22 +++++++++++++++++++++- 3 files changed, 57 insertions(+), 8 deletions(-) diff --git a/candle_insulate.ml b/candle_insulate.ml index 4c60a24f..c672eff7 100644 --- a/candle_insulate.ml +++ b/candle_insulate.ml @@ -109,6 +109,8 @@ module Cake = struct end;; module Hashtable = struct + type ('a, 'b) hashtable = ('a, 'b) Hashtable.hashtable + let clear x0 = Hashtable.clear x0 let delete x0 x1 = Hashtable.delete x0 x1 let empty x0 x1 x2 = Hashtable.empty x0 x1 x2 @@ -422,7 +424,9 @@ module Command_line = struct end;; module Double = struct type double = Cake.Double.double end;; -module Hashtable = struct end;; +module Hashtable = struct + type ('a, 'b) hashtable = ('a, 'b) Cake.Hashtable.hashtable +end;; module Int = struct end;; module List = struct end;; module Map = struct end;; diff --git a/candle_insulate.py b/candle_insulate.py index 85253d41..301365dc 100644 --- a/candle_insulate.py +++ b/candle_insulate.py @@ -35,11 +35,34 @@ # 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'] + '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. @@ -137,8 +160,9 @@ def generate_ocaml_bindings(bindings): # Add type rebindings if specified for this module if module_name in MODULE_TYPES: - for type_name in MODULE_TYPES[module_name]: - lines.append(f" type {type_name} = {module_name}.{type_name}") + 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 @@ -168,8 +192,9 @@ def generate_ocaml_bindings(bindings): for ocaml_module_name in module_names: if ocaml_module_name in MODULE_TYPES: lines.append(f"module {ocaml_module_name} = struct") - for type_name in MODULE_TYPES[ocaml_module_name]: - lines.append(f" type {type_name} = Cake.{ocaml_module_name}.{type_name}") + 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;;") diff --git a/candle_ocaml.ml b/candle_ocaml.ml index 6f284cb3..db3b7ac6 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -47,6 +47,11 @@ module Candle = struct | 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 @@ -229,4 +234,19 @@ module Random = struct if 0 <= bound || bound >= 1073741824 (* 2^30 *) then raise (Invalid_argument "Random.int") else bits () mod bound;; -end +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;; From f0bc95168d272d7b2338d09cc4ed3a39594a320a Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 15:51:42 +0800 Subject: [PATCH 32/79] Add String.hash --- candle_ocaml.ml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/candle_ocaml.ml b/candle_ocaml.ml index db3b7ac6..83775591 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -157,6 +157,15 @@ module String = struct 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 From b18baece635b4ee92cc4bd866fa84ecc93c301d1 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 16:39:03 +0800 Subject: [PATCH 33/79] Add Array.fold_left --- candle_ocaml.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/candle_ocaml.ml b/candle_ocaml.ml index 83775591..96fcb1d6 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -174,6 +174,7 @@ module Array = struct 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 end;; module Printexc = struct From 1e7f6c0a95d1830273925c9e19d80faef6f1ec7f Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 16:40:16 +0800 Subject: [PATCH 34/79] Fix compute.ml --- compute.ml | 375 +++++++++++++++++++++++++++++++---------------------- 1 file changed, 221 insertions(+), 154 deletions(-) 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;; From 7d929ff922b70fb8607a3f30c3011a53ae6f3bac Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 16:57:17 +0800 Subject: [PATCH 35/79] Fix nums.ml + recursion.ml, continue with arith.ml --- arith.ml | 10 +++++----- nums.ml | 6 +++--- recursion.ml | 2 +- 3 files changed, 9 insertions(+), 9 deletions(-) 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/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/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 From dbf17d50af6884bb9e63b4688f84ffb1b5de5750 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 17:29:47 +0800 Subject: [PATCH 36/79] Fix bound check in Random.int --- candle_ocaml.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/candle_ocaml.ml b/candle_ocaml.ml index 96fcb1d6..5b4bd6b6 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -241,7 +241,7 @@ module Random = struct state := next_s; next_s;; let int bound = - if 0 <= bound || bound >= 1073741824 (* 2^30 *) + if bound <= 0 || bound >= 1073741824 (* 2^30 *) then raise (Invalid_argument "Random.int") else bits () mod bound;; end;; From be00d5aade887fe14d23caf03bc56d458d831311 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 17:52:47 +0800 Subject: [PATCH 37/79] Add Array.of_list to candle_ocaml.ml --- candle_ocaml.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/candle_ocaml.ml b/candle_ocaml.ml index 5b4bd6b6..8a8e926e 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -175,6 +175,7 @@ module Array = struct 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 end;; module Printexc = struct From 99e924560f2632e70f7874dbc3fe955d9eb64d1e Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 17:52:59 +0800 Subject: [PATCH 38/79] Fix calc_num.ml --- calc_num.ml | 74 ++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 56 insertions(+), 18 deletions(-) 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";; From 98cc6730ca68b29e681b00a87aeb573ad9deec3d Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 17:58:37 +0800 Subject: [PATCH 39/79] Fix grobner.ml --- grobner.ml | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) 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 From 2ee89c06eee1d68ddb82497c34df178a0f266a1b Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 18:04:28 +0800 Subject: [PATCH 40/79] Fix ind_types.ml --- ind_types.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) 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 From 261f2d3d88d0dbfdd4db8813fa61c97773c4708d Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 18:16:45 +0800 Subject: [PATCH 41/79] Add Array.map to candle_ocaml.ml --- candle_ocaml.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/candle_ocaml.ml b/candle_ocaml.ml index 8a8e926e..928ebb8b 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -176,6 +176,8 @@ module Array = struct 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 From 08d3b05dba1f37d48abc3f12609e25298e878e9d Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 2 Mar 2026 18:18:04 +0800 Subject: [PATCH 42/79] Fix lists.ml --- lists.ml | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) 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 = From 0a78c78fdc34962795fbe7ffd784af7cc523b985 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 10:10:03 +0800 Subject: [PATCH 43/79] Fix hol_lib.ml --- hol_lib.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hol_lib.ml b/hol_lib.ml index 2f7ac1bd..5ee86b99 100644 --- a/hol_lib.ml +++ b/hol_lib.ml @@ -125,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);; From 2b9f0f2c8097828504f026dc9bcae5741149615d Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 10:30:04 +0800 Subject: [PATCH 44/79] Fix define.ml/hol.lib --- define.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From b22fc5df9e7388716c1f8775c383428b872f03be Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 10:53:43 +0800 Subject: [PATCH 45/79] Add partial, stubbed out versions of Sys and Filename --- candle_ocaml.ml | 27 +++++++++++++++++++++++---- printer.ml | 7 ------- 2 files changed, 23 insertions(+), 11 deletions(-) diff --git a/candle_ocaml.ml b/candle_ocaml.ml index 928ebb8b..e0b38b53 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -184,10 +184,6 @@ module Printexc = struct let to_string (e: exn) = "TODO stub (Printexc.to_string)" end;; -module Sys = struct - let time () = Float.zero;; (* TODO stub *) -end;; - module Format = struct type formatter = Pretty_imp.state;; @@ -228,6 +224,10 @@ module Format = struct 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 *) @@ -263,3 +263,22 @@ module Hashtbl = struct 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/printer.ml b/printer.ml index 494ceafb..32a236fa 100755 --- a/printer.ml +++ b/printer.ml @@ -125,15 +125,8 @@ 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_to_string = Pretty.print_to_string;; - -(* Functions that print to stdout: *) - -let print_string = Format.print_string;; let print_break l i = Format.print_break l i;; let print_space () = Format.print_space ();; -let print_newline () = Format.print_newline ();; -let print_endline s = print_string s; print_newline ();; let open_box = Format.open_box;; let open_hbox () = Format.open_hbox ();; From aaba9055b97267981be55079d53995abb3d9d7a4 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 10:53:59 +0800 Subject: [PATCH 46/79] Implement string_of_file in lib.ml using Text_io --- lib.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib.ml b/lib.ml index 55d9a1e7..45f05e15 100755 --- a/lib.ml +++ b/lib.ml @@ -978,12 +978,12 @@ let strings_of_file filename = let data = suck_lines [] in (close_in fd; data);; -(* let string_of_file filename = - let fd = open_in_bin filename in - let data = really_input_string fd (in_channel_length fd) 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 (close_in fd; data);; -*) let file_of_string filename s = let fd = open_out filename in From b2987601a5a7267b8892e76bf2e513431158a91b Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 10:54:21 +0800 Subject: [PATCH 47/79] Fix Library/pocklington.ml --- Library/pocklington.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From 1029d5fe1ee20546b6f99e1f65676b5df7c0ad6f Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 11:10:41 +0800 Subject: [PATCH 48/79] Explain how to restore in candletest.mk --- candletest.mk | 3 +++ 1 file changed, 3 insertions(+) diff --git a/candletest.mk b/candletest.mk index 22da3640..a53394ed 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 From 953b0f0c2f9d92e682c3727487834930f71f9cde Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 12:24:44 +0800 Subject: [PATCH 49/79] Add missing theorem to int.ml --- int.ml | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) 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. *) (* ------------------------------------------------------------------------- *) From a1bb3025b3bfe99bf345cdf4cb6694a0753d6326 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 12:24:50 +0800 Subject: [PATCH 50/79] Fix ringtheory.ml --- Library/ringtheory.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Library/ringtheory.ml b/Library/ringtheory.ml index ad23e5e6..f6b6dd09 100644 --- a/Library/ringtheory.ml +++ b/Library/ringtheory.ml @@ -4905,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;; From e763ac04f38b77afad4b2e9cf8289c2d27fab160 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 12:32:01 +0800 Subject: [PATCH 51/79] Use Cake.Runtime instead of Runtime in candletest.mk --- candletest.mk | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/candletest.mk b/candletest.mk index a53394ed..39c06ee7 100644 --- a/candletest.mk +++ b/candletest.mk @@ -124,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 From 31c7bf64b890f4df23b7514194fa3a94ba05c245 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 13:21:16 +0800 Subject: [PATCH 52/79] Adjust comparison in candle_kernel.ml I don't think we should rely on compare returning -1 or 1 exactly. Also added (>) which makes a change in simp.ml a bit more straightforward. --- candle_kernel.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/candle_kernel.ml b/candle_kernel.ml index f3c66484..87703cb9 100644 --- a/candle_kernel.ml +++ b/candle_kernel.ml @@ -95,7 +95,7 @@ module Type = struct Pair.compare String.compare (List.compare compare) (x1,a1) (x2,a2) | Tyapp _, Tyvar _ -> 1 ;; - let (<) ty1 ty2 = compare ty1 ty2 = -1 + let (<) ty1 ty2 = compare ty1 ty2 < 0 ;; let (<=) ty1 ty2 = compare ty1 ty2 <> 1 ;; @@ -120,7 +120,9 @@ module Term = struct Pair.compare compare compare (s1,s2) (t1,t2) | Abs _, _ -> 1 ;; - let (<) t1 t2 = compare t1 t2 = -1 + let (<) t1 t2 = compare t1 t2 < 0 + ;; + let (>) t1 t2 = compare t1 t2 > 0 ;; let (<=) t1 t2 = compare t1 t2 <> 1 ;; @@ -132,7 +134,7 @@ module Thm = struct (dest_thm th1) (dest_thm th2) ;; - let (<) th1 th2 = compare th1 th2 = -1 + let (<) th1 th2 = compare th1 th2 < 0 ;; let (<=) th1 th2 = compare th1 th2 <> 1 ;; From e4afc1de077d98f02ea1f48d1bf6d0fe79d380fe Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 13:29:35 +0800 Subject: [PATCH 53/79] Make simp.ml closer to upstream --- simp.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) 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;; (* ------------------------------------------------------------------------- *) From bc1bbdf867fde3bfcd51813a54a77ebd1ff1883f Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 14:34:52 +0800 Subject: [PATCH 54/79] Fix calc_real.ml --- Library/calc_real.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) 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 Date: Tue, 3 Mar 2026 14:35:10 +0800 Subject: [PATCH 55/79] Fix tactics.ml --- tactics.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tactics.ml b/tactics.ml index 6ca3b1fd..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_ = +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_ = 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_,thenl_,then_,(fun tac1 tac2 -> thenl_ tac1 [tac2]);; let ((ORELSE): tactic -> tactic -> tactic) = fun tac1 tac2 g -> From b9d77973f5dc4cee2400696df7dfe798efd267cd Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 14:51:42 +0800 Subject: [PATCH 56/79] Fix Multivariate/metric.ml --- Multivariate/metric.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/Multivariate/metric.ml b/Multivariate/metric.ml index 544556f8..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 @@ -49527,4 +49527,3 @@ let KURATOWSKI_COMPONENT_NUMBER_INVARIANCE = prove CONTINUOUS_MAP_IN_SUBTOPOLOGY]) THEN RULE_ASSUM_TAC(REWRITE_RULE[TOPSPACE_SUBTOPOLOGY]) THEN ASM SET_TAC[]);; - From 8182265f977e8874e162d5c81ab08a317c74f685 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Tue, 3 Mar 2026 15:19:14 +0800 Subject: [PATCH 57/79] Fix Library/grouptheory.ml --- Library/grouptheory.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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 From a53c2ccf6e2b4861a8e282c1a7617b474c1bb731 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Thu, 5 Mar 2026 17:31:43 +0800 Subject: [PATCH 58/79] Print out when a file is done loading Hopefully with this I can set up a regression suite that tells me which files are broken --- candle_boot.ml | 37 ++++++++++++++++++++++++++++++------- 1 file changed, 30 insertions(+), 7 deletions(-) diff --git a/candle_boot.ml b/candle_boot.ml index 554436c9..5e9a20e1 100644 --- a/candle_boot.ml +++ b/candle_boot.ml @@ -297,7 +297,7 @@ type token = | T_char of string | T_number of string | T_spaces of string - | T_done (* pseudo-token at switch from loading to user input *) + | T_done (* pseudo-token after loading a file *) ;; let string_of_token unquote tok = @@ -540,6 +540,15 @@ exception Repl_error;; let () = let prompt = ref (!prompt2) in + let pushLoad, popLoad, clearLoadStack = + let stack = ref ([]: string list) in + let pushLoad fname = stack := fname :: !stack in + let popLoad () = + match !stack with + | fname :: rest as res -> stack := rest; Some (fname, rest) + | _ -> None in + let clearLoadStack () = stack := [] in + pushLoad, popLoad, clearLoadStack in let peekChar, nextChar = let lookahead = ref (None: char option) in let peek () = @@ -635,10 +644,9 @@ let () = let scan = Lexer.scan nextChar peekChar in let rec nom acc = match scan () with - | None -> List.app (Buffer.push_front input_buffer) acc + | None -> List.app (Buffer.push_front input_buffer) (Lexer.T_done :: acc) | Some tok -> nom (tok::acc) in - nom []; - Buffer.push_back input_buffer Lexer.T_done in + nom [] in let next () = match Buffer.dequeue input_buffer with | Some tok -> Some tok @@ -651,8 +659,17 @@ let () = 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) -> + (* Attempt to use token as part of loading directive if it sits at the + top level (i.e. not inside parenthesis). The REPL fails and reports + and error unless the token is followed by a string literal and then + double semicolons. Ideally we should also check that the token sits + at the start of the line, but we don't, so odd things such as this: + foo needs "bar.ml";; + are OK and will cause the file bar.ml to be loaded and appear + directly after 'foo' in the token stream. + *) + | Some (Lexer.T_use | Lexer.T_needs | Lexer.T_loads as tok) + when level = 0 -> begin let dir = Option.valOf (Lexer.directive_of_token tok) in match next_nonspace () with @@ -665,6 +682,7 @@ let () = let lines = load dir fname in if List.null lines then scan level else begin + pushLoad fname; userInput := false; scan_lines lines; scan level @@ -688,7 +706,11 @@ let () = " double semicolon [;;].\n"]) end | Some (Lexer.T_done) -> - userInput := true; + (match popLoad () with + | Some (fname, rest) -> ( + print ("- Finished loading " ^ fname ^ "\n"); + if List.null rest then userInput := true) + | None -> failwith "candle_boot.ml: scan - should be unreachable"); scan level | Some tok -> Buffer.push_back output_buffer tok; @@ -726,6 +748,7 @@ let () = if not (!userInput) then print (!prompt1); Buffer.flush input_buffer; Buffer.flush output_buffer; + clearLoadStack (); Repl.nextString := ""; userInput := true in Repl.readNextString := (fun () -> From 7b387aa9a952f5c0c07f9a5a081618ee4905216f Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 6 Mar 2026 20:19:14 +0800 Subject: [PATCH 59/79] Start sketching a Python program to interact with Candle --- candle-regression.py | 98 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 98 insertions(+) create mode 100644 candle-regression.py diff --git a/candle-regression.py b/candle-regression.py new file mode 100644 index 00000000..9c9368a7 --- /dev/null +++ b/candle-regression.py @@ -0,0 +1,98 @@ +import sys +import pexpect +import time + + +class StartFailure(Exception): + """Starting Candle failed (pre-boot).""" + + +class BootFailure(Exception): + """Booting Candle failed (pre-boot).""" + + +class LoadFailure(Exception): + """Loading a file failed.""" + + +class CandleREPL: + def __init__(self): + try: + self.process = pexpect.spawn('./candle', encoding='utf-8', logfile=sys.stdout) + except Exception as e: + raise StartFailure from e + + try: + self._check_boot() + except BootFailure: + self.process.close(force=True) + raise + + self.load_stack = [] + self.last_val = None + + def _check_boot(self): + try: + index = self.process.expect([ + r'\n# ', # 0: REPL prompt → success + r'\n(ERROR: .+)', # 1: any boot error + pexpect.TIMEOUT, + pexpect.EOF, + ]) + except Exception as e: + raise BootFailure from e + + if index != 0: + reasons = {1: f"{_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 _set_last_val(self, val): + self.last_val = (val, time.perf_counter()) + + def _check_output(self): + 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, + ]) + except Exception as e: + raise LoadFailure from e + + match index: + case 0: + dependency = _get_match(1) + self.load_stack.push(dependency) + case 1: + self._set_last_val(_get_match(1)) + case 2 | 3 | 4: + raise LoadFailure(_get_match(1)) + case 5: + finished = _get_match(1) + expected = self.load_stack.pop() + assert finished == expected, f'Expected to finish loading {expected}. Actual: {finished}' + case 6: + pass + case 7: + raise LoadFailure("Process exited unexpectedly") + case _: + pass + + def load(self, file): + self.load_stack.push(file) + self.process.sendline(f'#use "{file}"') + + # todo: while load_stack not empty: + while not load_stack: + self._check_output() + +candle = CandleREPL() + From 46d7e52a02e1d51548f96224e7fa80d143ba58ec Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 13 Mar 2026 14:17:49 +0800 Subject: [PATCH 60/79] Start sketching candle-regression.py --- candle-regression.py | 34 +++++++++++++++++++++------------- 1 file changed, 21 insertions(+), 13 deletions(-) diff --git a/candle-regression.py b/candle-regression.py index 9c9368a7..b6b0b9a8 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -16,16 +16,17 @@ class LoadFailure(Exception): class CandleREPL: - def __init__(self): + def __init__(self, base): + self.base = base try: - self.process = pexpect.spawn('./candle', encoding='utf-8', logfile=sys.stdout) + self.process = pexpect.spawn(os.path.join(self.base, "candle"), encoding='utf-8', logfile=sys.stdout) except Exception as e: raise StartFailure from e try: self._check_boot() except BootFailure: - self.process.close(force=True) + self.kill() raise self.load_stack = [] @@ -43,7 +44,7 @@ def _check_boot(self): raise BootFailure from e if index != 0: - reasons = {1: f"{_get_match(1)}", 2: "Timeout", 3: "Process exited unexpectedly"} + reasons = {1: str(self._get_match(1)), 2: "Timeout", 3: "Process exited unexpectedly"} raise BootFailure(reasons[index]) def _get_match(self, idx): @@ -69,14 +70,14 @@ def _check_output(self): match index: case 0: - dependency = _get_match(1) - self.load_stack.push(dependency) + dependency = self._get_match(1) + self.load_stack.append(dependency) case 1: - self._set_last_val(_get_match(1)) + self._set_last_val(self._get_match(1)) case 2 | 3 | 4: - raise LoadFailure(_get_match(1)) + raise LoadFailure(self._get_match(1)) case 5: - finished = _get_match(1) + finished = self._get_match(1) expected = self.load_stack.pop() assert finished == expected, f'Expected to finish loading {expected}. Actual: {finished}' case 6: @@ -87,12 +88,19 @@ def _check_output(self): pass def load(self, file): - self.load_stack.push(file) - self.process.sendline(f'#use "{file}"') + self.process.sendline(f'#use "{file}";;') - # todo: while load_stack not empty: - while not load_stack: + while self.load_stack: self._check_output() + def kill(self): + self.process.close(force=True) + + def dump(self): + pass + + def restore(self): + pass + candle = CandleREPL() From f967a9bff192ea0ed6317bd4f95349c18d4e05a7 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 13 Mar 2026 15:59:37 +0800 Subject: [PATCH 61/79] Implement dump/restore --- candle-regression.py | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) diff --git a/candle-regression.py b/candle-regression.py index b6b0b9a8..e39e7545 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -1,6 +1,8 @@ import sys import pexpect import time +import subprocess +import os class StartFailure(Exception): @@ -17,9 +19,11 @@ class LoadFailure(Exception): class CandleREPL: def __init__(self, base): - self.base = base + os.chdir(base) + + self.checkpoint_dir = "checkpoint" try: - self.process = pexpect.spawn(os.path.join(self.base, "candle"), encoding='utf-8', logfile=sys.stdout) + self.process = pexpect.spawn("./candle", encoding='utf-8', logfile=sys.stdout) except Exception as e: raise StartFailure from e @@ -89,6 +93,7 @@ def _check_output(self): def load(self, file): self.process.sendline(f'#use "{file}";;') + self._check_output() while self.load_stack: self._check_output() @@ -97,10 +102,20 @@ def kill(self): self.process.close(force=True) def dump(self): - pass + os.makedirs(self.checkpoint_dir, exist_ok=True) + pid = self.process.pid + subprocess.run( + ["sudo", "criu", "dump", "-D", self.checkpoint_dir, "-t", str(pid), "--shell-job"], + check=True, + ) + self.process.wait() def restore(self): - pass + self.process = pexpect.spawn( + "sudo", ["criu", "restore", "-D", self.checkpoint_dir, "--shell-job"], + encoding='utf-8', + logfile=sys.stdout, + ) -candle = CandleREPL() +#candle = CandleREPL("/home/daniel/code/candles/candle") From 84ede354982a3e720f9db775fa001f31e0ce1dc9 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 20 Mar 2026 08:59:38 +0800 Subject: [PATCH 62/79] Evolve candle-regression.py into a proper regression test suite Add TestStatus enum, TestResult dataclass, and the 64 Great 100 Theorems test list. Extend CandleREPL with checkpoint restore, loads command, timeout support, and exit handling. Add TestRunner for orchestrating test runs with XFAIL/XPASS tracking, and Reporter for console summary tables and JSON output. Wire up CLI via argparse. Co-Authored-By: Claude Opus 4.6 --- candle-regression.py | 461 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 448 insertions(+), 13 deletions(-) diff --git a/candle-regression.py b/candle-regression.py index e39e7545..7154dcbf 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -3,8 +3,17 @@ import time import subprocess import os +import argparse +import json +from dataclasses import dataclass, field, asdict +from enum import Enum +from datetime import datetime +# --------------------------------------------------------------------------- +# Exceptions +# --------------------------------------------------------------------------- + class StartFailure(Exception): """Starting Candle failed (pre-boot).""" @@ -17,13 +26,119 @@ class LoadFailure(Exception): """Loading a file failed.""" +# --------------------------------------------------------------------------- +# Test status and result +# --------------------------------------------------------------------------- + +class TestStatus(Enum): + PASS = "PASS" + FAIL = "FAIL" + TIMEOUT = "TIMEOUT" + SKIP = "SKIP" + XFAIL = "XFAIL" + XPASS = "XPASS" + + +@dataclass +class TestResult: + name: str + status: TestStatus + elapsed: float = 0.0 + error_message: str = "" + output_log: str = "" + + +# --------------------------------------------------------------------------- +# Test list — 64 Great 100 Theorems from candletest.mk +# --------------------------------------------------------------------------- + +GREAT_100_THEOREMS = [ + "100/arithmetic_geometric_mean", + "100/arithmetic", + "100/ballot", + "100/bernoulli", + "100/bertrand", + "100/birthday", + "100/cantor", + "100/cayley_hamilton", + "100/ceva", + "100/circle", + "100/chords", + "100/combinations", + "100/constructible", + "100/cosine", + "100/cubic", + "100/derangements", + "100/desargues", + "100/descartes", + "100/dirichlet", + "100/div3", + "100/divharmonic", + "100/e_is_transcendental", + "100/euler", + "100/feuerbach", + "100/fourier", + "100/four_squares", + "100/friendship", + "100/fta", + "100/gcd", + "100/heron", + "100/inclusion_exclusion", + "100/independence", + "100/isoperimetric", + "100/isosceles", + "100/konigsberg", + "100/lagrange", + "100/leibniz", + "100/lhopital", + "100/liouville", + "100/minkowski", + "100/morley", + "100/pascal", + "100/perfect", + "100/pick", + "100/piseries", + "100/platonic", + "100/pnt", + "100/polyhedron", + "100/primerecip", + "100/ptolemy", + "100/pythagoras", + "100/quartic", + "100/ramsey", + "100/ratcountable", + "100/realsuncountable", + "100/reciprocity", + "100/sqrt", + "100/stirling", + "100/subsequence", + "100/thales", + "100/transcendence", + "100/triangular", + "100/two_squares", + "100/wilson", +] + +# Tests known to fail — maps test name to reason. +# Tests here that fail get XFAIL; tests here that pass get XPASS. +KNOWN_FAILURES = {} + + +# --------------------------------------------------------------------------- +# CandleREPL +# --------------------------------------------------------------------------- + class CandleREPL: - def __init__(self, base): + def __init__(self, base, logfile=None): os.chdir(base) - + self.base = base self.checkpoint_dir = "checkpoint" + self._logfile = logfile or sys.stdout + try: - self.process = pexpect.spawn("./candle", encoding='utf-8', logfile=sys.stdout) + self.process = pexpect.spawn( + "./candle", encoding='utf-8', logfile=self._logfile, + ) except Exception as e: raise StartFailure from e @@ -36,6 +151,19 @@ def __init__(self, base): self.load_stack = [] self.last_val = None + @classmethod + def from_checkpoint(cls, base_dir, logfile=None): + """Create a CandleREPL by restoring from an existing checkpoint.""" + obj = object.__new__(cls) + obj.base = base_dir + obj.checkpoint_dir = "checkpoint" + obj._logfile = logfile or sys.stdout + obj.load_stack = [] + obj.last_val = None + os.chdir(base_dir) + obj.restore() + return obj + def _check_boot(self): try: index = self.process.expect([ @@ -57,7 +185,7 @@ def _get_match(self, idx): def _set_last_val(self, val): self.last_val = (val, time.perf_counter()) - def _check_output(self): + def _check_output(self, timeout=600): try: index = self.process.expect([ r'\n\- Loading (\S+)', @@ -68,7 +196,7 @@ def _check_output(self): r'\n\- Finished loading (\S+)', pexpect.TIMEOUT, pexpect.EOF, - ]) + ], timeout=timeout) except Exception as e: raise LoadFailure from e @@ -85,21 +213,42 @@ def _check_output(self): expected = self.load_stack.pop() assert finished == expected, f'Expected to finish loading {expected}. Actual: {finished}' case 6: - pass + raise LoadFailure("Timeout waiting for output") case 7: raise LoadFailure("Process exited unexpectedly") case _: pass - def load(self, file): + def load(self, file, timeout=600): self.process.sendline(f'#use "{file}";;') - self._check_output() + self._check_output(timeout=timeout) while self.load_stack: - self._check_output() + self._check_output(timeout=timeout) + + def run_loads(self, file, timeout=600): + """Send loads "file";; — HOL Light's dependency-aware loader.""" + self.process.sendline(f'loads "{file}";;') + self._check_output(timeout=timeout) + + while self.load_stack: + self._check_output(timeout=timeout) + + def send_exit(self, timeout=30): + """Send Cake.Runtime.exit 0;; and wait for the process to terminate.""" + self.process.sendline('Cake.Runtime.exit 0;;') + self.process.expect(pexpect.EOF, timeout=timeout) + + def wait_for_prompt(self, timeout=30): + """After restore, send ();; to elicit a prompt from the restored process.""" + self.process.sendline('();;') + self.process.expect(r'# ', timeout=timeout) def kill(self): - self.process.close(force=True) + try: + self.process.close(force=True) + except Exception: + pass def dump(self): os.makedirs(self.checkpoint_dir, exist_ok=True) @@ -110,12 +259,298 @@ def dump(self): ) self.process.wait() - def restore(self): + def restore(self, logfile=None): + lf = logfile if logfile is not None else self._logfile self.process = pexpect.spawn( "sudo", ["criu", "restore", "-D", self.checkpoint_dir, "--shell-job"], encoding='utf-8', - logfile=sys.stdout, + logfile=lf, ) -#candle = CandleREPL("/home/daniel/code/candles/candle") +# --------------------------------------------------------------------------- +# Reporter +# --------------------------------------------------------------------------- + +class Reporter: + STATUS_SYMBOLS = { + TestStatus.PASS: "PASS", + TestStatus.FAIL: "FAIL", + TestStatus.TIMEOUT: "TIME", + TestStatus.SKIP: "SKIP", + TestStatus.XFAIL: "XFAIL", + TestStatus.XPASS: "XPASS", + } + + @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)] + xpasses = [r for r in results if r.status == TestStatus.XPASS] + + if failures: + print() + print("NEW FAILURES:") + for r in failures: + msg = f" {r.name}: {r.status.value}" + if r.error_message: + msg += f" — {r.error_message}" + print(msg) + + if xpasses: + print() + print("REGRESSIONS (now passing — update KNOWN_FAILURES):") + for r in xpasses: + print(f" {r.name}") + + @staticmethod + def write_json(results, path): + counts = {} + for s in TestStatus: + c = sum(1 for r in results if r.status == s) + if c: + counts[s.value] = c + + data = { + "timestamp": datetime.now().isoformat(), + "summary": { + "total": len(results), + **counts, + }, + "tests": [ + { + "name": r.name, + "status": r.status.value, + "elapsed": round(r.elapsed, 2), + "error_message": r.error_message, + } + for r in results + ], + } + + with open(path, "w") as f: + json.dump(data, f, indent=2) + f.write("\n") + print(f"\nJSON results written to {path}") + + +# --------------------------------------------------------------------------- +# TestRunner +# --------------------------------------------------------------------------- + +class TestRunner: + def __init__(self, base_dir, timeout=600, verbose=False): + self.base_dir = base_dir + self.timeout = timeout + self.verbose = verbose + + 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...") + logfile = sys.stdout if self.verbose else None + repl = CandleREPL(self.base_dir, logfile=logfile) + 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.""" + logfile = sys.stdout if self.verbose else None + start = time.perf_counter() + + try: + repl = CandleREPL.from_checkpoint(self.base_dir, logfile=logfile) + 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.wait_for_prompt(timeout=30) + repl.run_loads(f"{name}.ml", timeout=self.timeout) + repl.send_exit(timeout=30) + elapsed = time.perf_counter() - start + + if name in KNOWN_FAILURES: + return TestResult(name=name, status=TestStatus.XPASS, elapsed=elapsed) + return TestResult(name=name, status=TestStatus.PASS, elapsed=elapsed) + + except LoadFailure as e: + elapsed = time.perf_counter() - start + err = str(e) + if "Timeout" in err: + status = TestStatus.TIMEOUT + elif name in KNOWN_FAILURES: + status = TestStatus.XFAIL + else: + status = TestStatus.FAIL + return TestResult(name=name, status=status, elapsed=elapsed, error_message=err) + + except pexpect.TIMEOUT: + elapsed = time.perf_counter() - start + if name in KNOWN_FAILURES: + status = TestStatus.XFAIL + else: + status = TestStatus.TIMEOUT + return TestResult( + name=name, status=status, + elapsed=elapsed, error_message="Timeout", + ) + + except Exception as e: + elapsed = time.perf_counter() - start + if name in KNOWN_FAILURES: + status = TestStatus.XFAIL + else: + status = TestStatus.FAIL + return TestResult( + name=name, status=status, + elapsed=elapsed, error_message=str(e), + ) + + finally: + repl.kill() + self._cleanup_stuck_processes() + + def _cleanup_stuck_processes(self): + """Kill any leftover cake --candle processes.""" + try: + subprocess.run( + ["sudo", "pkill", "-f", "cake --candle"], + stdout=subprocess.DEVNULL, stderr=subprocess.DEVNULL, + ) + except Exception: + pass + + def run_all(self, tests): + """Run all tests, printing progress inline.""" + results = [] + total = len(tests) + + 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) + + 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( + "-t", "--test", action="append", default=[], + help="Run specific test(s) by name (can be repeated)", + ) + parser.add_argument( + "--json", metavar="FILE", + help="Write JSON results to FILE", + ) + parser.add_argument( + "--list", action="store_true", + help="List available tests and exit", + ) + parser.add_argument( + "-v", "--verbose", action="store_true", + help="Show verbose REPL output", + ) + 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() + + if args.list: + for name in GREAT_100_THEOREMS: + marker = " (KNOWN_FAILURE)" if name in KNOWN_FAILURES else "" + print(f" {name}{marker}") + print(f"\n{len(GREAT_100_THEOREMS)} tests available") + return + + # Determine which tests to run + if args.test: + tests = [] + for t in args.test: + if t in GREAT_100_THEOREMS: + tests.append(t) + else: + print(f"Unknown test: {t}", file=sys.stderr) + sys.exit(1) + else: + tests = list(GREAT_100_THEOREMS) + + runner = TestRunner( + base_dir=args.base_dir, + timeout=args.timeout, + verbose=args.verbose, + ) + + # Setup checkpoint + runner.setup(reuse_checkpoint=args.reuse_checkpoint) + + # Run tests + results = runner.run_all(tests) + + # Report + Reporter.print_summary(results) + if args.json: + Reporter.write_json(results, args.json) + + # Exit code: 0 if no unexpected failures + unexpected = [r for r in results if r.status in (TestStatus.FAIL, TestStatus.TIMEOUT, TestStatus.XPASS)] + sys.exit(1 if unexpected else 0) + + +if __name__ == "__main__": + main() From 6679b73b7dec3110d4de8ab28a513c5938c6c1e8 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 20 Mar 2026 09:33:16 +0800 Subject: [PATCH 63/79] Fix kill() for CRIU-restored processes After restore, pexpect only tracks the "sudo criu restore" wrapper, not the restored cake process. Use pkill to kill the entire process group so that child processes checkpointed by CRIU are also cleaned up, freeing their PIDs for the next restore. Co-Authored-By: Claude Opus 4.6 --- candle-regression.py | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/candle-regression.py b/candle-regression.py index 7154dcbf..0fb20424 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -26,6 +26,7 @@ class LoadFailure(Exception): """Loading a file failed.""" + # --------------------------------------------------------------------------- # Test status and result # --------------------------------------------------------------------------- @@ -249,10 +250,15 @@ def kill(self): self.process.close(force=True) except Exception: pass + if hasattr(self, '_cake_pid'): + subprocess.run(["pkill", "-9", "-g", str(self._cake_pid)]) def dump(self): os.makedirs(self.checkpoint_dir, exist_ok=True) pid = self.process.pid + pidfile = os.path.join(self.checkpoint_dir, "cake.pid") + with open(pidfile, "w") as f: + f.write(str(pid)) subprocess.run( ["sudo", "criu", "dump", "-D", self.checkpoint_dir, "-t", str(pid), "--shell-job"], check=True, @@ -266,6 +272,10 @@ def restore(self, logfile=None): encoding='utf-8', logfile=lf, ) + # Assumption: CRIU restores processes with their original PIDs. + # Read the cake PID (saved during dump) so kill() can target it. + pidfile = os.path.join(self.checkpoint_dir, "cake.pid") + self._cake_pid = int(open(pidfile).read().strip()) # --------------------------------------------------------------------------- @@ -443,17 +453,6 @@ def run_test(self, name): finally: repl.kill() - self._cleanup_stuck_processes() - - def _cleanup_stuck_processes(self): - """Kill any leftover cake --candle processes.""" - try: - subprocess.run( - ["sudo", "pkill", "-f", "cake --candle"], - stdout=subprocess.DEVNULL, stderr=subprocess.DEVNULL, - ) - except Exception: - pass def run_all(self, tests): """Run all tests, printing progress inline.""" From be7a4bac2d87828f73b47154fc592aab53de0176 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 20 Mar 2026 11:05:35 +0800 Subject: [PATCH 64/79] Handle Ctrl-C gracefully in regression suite Catch KeyboardInterrupt in run_all so that interrupting the test run still prints the summary of results collected so far. Co-Authored-By: Claude Opus 4.6 --- candle-regression.py | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/candle-regression.py b/candle-regression.py index 0fb20424..1ce0f8c4 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -459,14 +459,17 @@ def run_all(self, tests): results = [] total = len(tests) - 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) + 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) + except KeyboardInterrupt: + print("\nInterrupted — showing results so far.") return results From 63f22b6b6646ebcf9c295ccd0a62874d2f6502b9 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 20 Mar 2026 11:08:51 +0800 Subject: [PATCH 65/79] Add --fail-fast option to stop on first unexpected failure Co-Authored-By: Claude Opus 4.6 --- candle-regression.py | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/candle-regression.py b/candle-regression.py index 1ce0f8c4..74488812 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -370,10 +370,11 @@ def write_json(results, path): # --------------------------------------------------------------------------- class TestRunner: - def __init__(self, base_dir, timeout=600, verbose=False): + def __init__(self, base_dir, timeout=600, verbose=False, fail_fast=False): self.base_dir = base_dir self.timeout = timeout self.verbose = verbose + self.fail_fast = fail_fast def setup(self, reuse_checkpoint=False): """Start candle, load hol.ml, and dump a checkpoint.""" @@ -468,6 +469,9 @@ def run_all(self, tests): 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.") @@ -502,6 +506,10 @@ def main(): "-v", "--verbose", action="store_true", help="Show verbose REPL output", ) + 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)", @@ -536,6 +544,7 @@ def main(): base_dir=args.base_dir, timeout=args.timeout, verbose=args.verbose, + fail_fast=args.fail_fast, ) # Setup checkpoint From b8212754bf841de1ceaec8f9b5c54573d89f04be Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 20 Mar 2026 11:11:39 +0800 Subject: [PATCH 66/79] Include last successful val in test failure messages Co-Authored-By: Claude Opus 4.6 --- candle-regression.py | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/candle-regression.py b/candle-regression.py index 74488812..b6dfa78a 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -422,7 +422,9 @@ def run_test(self, name): except LoadFailure as e: elapsed = time.perf_counter() - start err = str(e) - if "Timeout" in err: + if repl.last_val: + err += f" (last val: {repl.last_val[0]})" + if "Timeout" in str(e): status = TestStatus.TIMEOUT elif name in KNOWN_FAILURES: status = TestStatus.XFAIL @@ -432,24 +434,30 @@ def run_test(self, name): except pexpect.TIMEOUT: elapsed = time.perf_counter() - start + err = "Timeout" + if repl.last_val: + err += f" (last val: {repl.last_val[0]})" if name in KNOWN_FAILURES: status = TestStatus.XFAIL else: status = TestStatus.TIMEOUT return TestResult( name=name, status=status, - elapsed=elapsed, error_message="Timeout", + elapsed=elapsed, error_message=err, ) except Exception as e: elapsed = time.perf_counter() - start + err = str(e) + if repl.last_val: + err += f" (last val: {repl.last_val[0]})" if name in KNOWN_FAILURES: status = TestStatus.XFAIL else: status = TestStatus.FAIL return TestResult( name=name, status=status, - elapsed=elapsed, error_message=str(e), + elapsed=elapsed, error_message=err, ) finally: From 0eb4a264f37e05766f872e2994e32ce2176787cd Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 20 Mar 2026 14:32:52 +0800 Subject: [PATCH 67/79] Fix pkill/restore race in regression suite by waiting for process reap After sending SIGKILL, wait for /proc/ to disappear before returning from kill(). Without this, the next test's CRIU restore can fail because the old PID is still held by an unreaped zombie. Co-Authored-By: Claude Opus 4.6 --- candle-regression.py | 2 ++ 1 file changed, 2 insertions(+) diff --git a/candle-regression.py b/candle-regression.py index b6dfa78a..a8329104 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -252,6 +252,8 @@ def kill(self): pass if hasattr(self, '_cake_pid'): subprocess.run(["pkill", "-9", "-g", str(self._cake_pid)]) + while os.path.exists(f"/proc/{self._cake_pid}"): + time.sleep(0.1) def dump(self): os.makedirs(self.checkpoint_dir, exist_ok=True) From 13129cb05c7a9be0aa1cf59b548b4d0e860f9d0b Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 20 Mar 2026 14:37:57 +0800 Subject: [PATCH 68/79] Include loading dependency chain in test failure messages Co-Authored-By: Claude Opus 4.6 --- candle-regression.py | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/candle-regression.py b/candle-regression.py index a8329104..d383d2b7 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -424,6 +424,8 @@ def run_test(self, name): except LoadFailure as e: elapsed = time.perf_counter() - start err = str(e) + if repl.load_stack: + err += f" [while loading: {' > '.join(repl.load_stack)}]" if repl.last_val: err += f" (last val: {repl.last_val[0]})" if "Timeout" in str(e): @@ -437,6 +439,8 @@ def run_test(self, name): except pexpect.TIMEOUT: elapsed = time.perf_counter() - start err = "Timeout" + if repl.load_stack: + err += f" [while loading: {' > '.join(repl.load_stack)}]" if repl.last_val: err += f" (last val: {repl.last_val[0]})" if name in KNOWN_FAILURES: @@ -451,6 +455,8 @@ def run_test(self, name): except Exception as e: elapsed = time.perf_counter() - start err = str(e) + if repl.load_stack: + err += f" [while loading: {' > '.join(repl.load_stack)}]" if repl.last_val: err += f" (last val: {repl.last_val[0]})" if name in KNOWN_FAILURES: From e5f7b51aa95905cd3979b511b9fb9231c3122482 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 20 Mar 2026 21:26:09 +0800 Subject: [PATCH 69/79] Try another way to fix the race condition --- candle-regression.py | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/candle-regression.py b/candle-regression.py index d383d2b7..5c1ee1c2 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -3,12 +3,20 @@ import time import subprocess import os +import signal import argparse import json from dataclasses import dataclass, field, asdict from enum import Enum from datetime import datetime +def wait_group(pgid): + while True: + try: + os.killpg(pgid, 0) + except ProcessLookupError: + return + time.sleep(0.1) # --------------------------------------------------------------------------- # Exceptions @@ -252,8 +260,7 @@ def kill(self): pass if hasattr(self, '_cake_pid'): subprocess.run(["pkill", "-9", "-g", str(self._cake_pid)]) - while os.path.exists(f"/proc/{self._cake_pid}"): - time.sleep(0.1) + wait_group(self._cake_pid) def dump(self): os.makedirs(self.checkpoint_dir, exist_ok=True) From 9c87dd9cfbb6d2e9a2b8a124685b76f3a8ac5236 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Fri, 20 Mar 2026 22:03:38 +0800 Subject: [PATCH 70/79] Add --local and --quick flags to regression suite --local runs tests in a single REPL session without CRIU, leveraging Candle's `needs` to deduplicate library loads across tests. --quick selects a curated 18-test subset covering all major code paths. Co-Authored-By: Claude Opus 4.6 --- candle-regression.py | 220 +++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 214 insertions(+), 6 deletions(-) diff --git a/candle-regression.py b/candle-regression.py index 5c1ee1c2..1cb2c62d 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -1,3 +1,6 @@ +""" +Mostly vibe-coded, sigh. +""" import sys import pexpect import time @@ -128,6 +131,85 @@ class TestResult: "100/wilson", ] +# Curated 18-test subset for --quick: maximum code coverage, no binding conflicts. +QUICK_TESTS = [ + # Core tactics (no extra deps) + "100/arithmetic", # INDUCT_TAC, ARITH_TAC + "100/cantor", # set theory, MESON + "100/konigsberg", # graph theory (safe — no standard name redefinitions) + # Library coverage (one per major library) + "100/gcd", # Library/prime.ml + "100/wilson", # Library/pocklington.ml + "100/combinations", # Library/binomial.ml + "100/ratcountable", # Library/card.ml + "100/euler", # Library/binary.ml + "100/lhopital", # Library/analysis.ml + "100/stirling", # Library/transc.ml + "100/liouville", # Library/floor.ml + Library/poly.ml + # Multivariate coverage (one per chain level) + "100/thales", # Multivariate/convex.ml chain + "100/desargues", # Multivariate/cross.ml + "100/cosine", # Multivariate/transcendentals.ml + "100/descartes", # Multivariate/realanalysis.ml + "100/heron", # Multivariate/measure.ml + "100/fourier", # Multivariate/lpspaces.ml + # Complex coverage + "100/cubic", # Complex/complex_transc.ml +] + +# Dependency-optimized order for --local mode (needs deduplicates library loads). +LOCAL_ORDER = [ + # Phase 1: No extra deps + "100/arithmetic", "100/birthday", "100/cantor", "100/divharmonic", + "100/inclusion_exclusion", "100/konigsberg", "100/quartic", "100/subsequence", + # Phase 2: Library/prime.ml + "100/gcd", "100/perfect", "100/fta", "100/two_squares", "100/lagrange", + # Phase 3: + pocklington.ml + "100/friendship", "100/div3", "100/wilson", "100/reciprocity", + # Phase 4: Library/binomial.ml + "100/combinations", "100/ballot", + # Phase 5: Library/card.ml + "100/ratcountable", "100/realsuncountable", + # Phase 6: Library/binary.ml + "100/euler", + # Phase 7: Library/analysis.ml + transc + "100/lhopital", "100/four_squares", "100/stirling", "100/leibniz", + "100/bernoulli", "100/derangements", "100/arithmetic_geometric_mean", + # Phase 8: Library/floor + poly + "100/liouville", + # Phase 9: Multivariate/misc + vectors + "100/triangular", "100/pythagoras", + # Phase 10: Multivariate/convex.ml + "100/chords", "100/thales", "100/feuerbach", "100/ceva", + # Phase 11: Multivariate/cross.ml + "100/desargues", "100/pascal", + # Phase 12: Multivariate/complexes.ml + "100/cayley_hamilton", + # Phase 13: Multivariate/transcendentals.ml + "100/ptolemy", "100/cosine", "100/constructible", + # Phase 14: Multivariate/realanalysis.ml + "100/descartes", + # Phase 15: Multivariate/geom.ml + "100/isosceles", "100/morley", + # Phase 16: Multivariate/measure.ml + "100/heron", "100/minkowski", "100/circle", + # Phase 17: Multivariate/polytope.ml + "100/polyhedron", "100/pick", + # Phase 18: Multivariate/lpspaces.ml + "100/fourier", + # Phase 19: Multivariate/cauchy.ml + "100/independence", "100/isoperimetric", + # Phase 20: Complex + "100/cubic", + # Phase 21: Heavy compound (deps already loaded) + "100/bertrand", "100/primerecip", "100/e_is_transcendental", "100/piseries", + "100/platonic", "100/dirichlet", "100/pnt", "100/transcendence", + # Phase 22: ramsey last — redefines standard conversions + "100/ramsey", + # sqrt not in candletest.mk phases but is in GREAT_100_THEOREMS + "100/sqrt", +] + # Tests known to fail — maps test name to reason. # Tests here that fail get XFAIL; tests here that pass get XPASS. KNOWN_FAILURES = {} @@ -478,6 +560,110 @@ def run_test(self, name): finally: repl.kill() + def run_test_local(self, repl, name): + """Run a single test in an existing REPL session, return TestResult.""" + start = time.perf_counter() + + try: + repl.run_loads(f"{name}.ml", timeout=self.timeout) + elapsed = time.perf_counter() - start + + if name in KNOWN_FAILURES: + return TestResult(name=name, status=TestStatus.XPASS, elapsed=elapsed) + 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" [while loading: {' > '.join(repl.load_stack)}]" + if repl.last_val: + err += f" (last val: {repl.last_val[0]})" + repl.load_stack.clear() + if "Timeout" in str(e): + status = TestStatus.TIMEOUT + elif name in KNOWN_FAILURES: + status = TestStatus.XFAIL + 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" [while loading: {' > '.join(repl.load_stack)}]" + if repl.last_val: + err += f" (last val: {repl.last_val[0]})" + repl.load_stack.clear() + if name in KNOWN_FAILURES: + status = TestStatus.XFAIL + 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" [while loading: {' > '.join(repl.load_stack)}]" + if repl.last_val: + err += f" (last val: {repl.last_val[0]})" + repl.load_stack.clear() + if name in KNOWN_FAILURES: + status = TestStatus.XFAIL + else: + status = TestStatus.FAIL + return TestResult( + name=name, status=status, + elapsed=elapsed, error_message=err, + ) + + def run_all_local(self, tests): + """Run all tests in a single REPL session (no CRIU).""" + results = [] + total = len(tests) + logfile = sys.stdout if self.verbose else None + + print("Starting candle and loading hol.ml...") + repl = CandleREPL(self.base_dir, logfile=logfile) + try: + repl.load("hol.ml", timeout=3600) + print("hol.ml loaded.") + except Exception: + repl.kill() + raise + + try: + for i, name in enumerate(tests, 1): + print(f"[{i}/{total}] {name} ... ", end="", flush=True) + result = self.run_test_local(repl, 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 + # After a failure, check the REPL is still alive + if result.status in (TestStatus.FAIL, TestStatus.TIMEOUT, TestStatus.XFAIL): + try: + repl.process.sendline('();;') + repl.process.expect(r'# ', timeout=30) + except Exception: + print("REPL unresponsive after failure — aborting remaining tests.") + break + except KeyboardInterrupt: + print("\nInterrupted — showing results so far.") + finally: + repl.kill() + + return results + def run_all(self, tests): """Run all tests, printing progress inline.""" results = [] @@ -533,6 +719,14 @@ def main(): "--fail-fast", action="store_true", help="Stop after the first unexpected failure", ) + parser.add_argument( + "--local", action="store_true", + help="Run tests in a single REPL session (no CRIU, deduplicates library loads)", + ) + parser.add_argument( + "--quick", action="store_true", + help="Run curated 18-test subset for maximum coverage", + ) parser.add_argument( "--timeout", type=int, default=600, help="Per-test timeout in seconds (default: 600)", @@ -544,11 +738,15 @@ def main(): args = parser.parse_args() + # Select test list + available = QUICK_TESTS if args.quick else GREAT_100_THEOREMS + if args.list: - for name in GREAT_100_THEOREMS: + for name in available: marker = " (KNOWN_FAILURE)" if name in KNOWN_FAILURES else "" print(f" {name}{marker}") - print(f"\n{len(GREAT_100_THEOREMS)} tests available") + label = "quick" if args.quick else "available" + print(f"\n{len(available)} {label} tests") return # Determine which tests to run @@ -560,9 +758,16 @@ def main(): else: print(f"Unknown test: {t}", file=sys.stderr) sys.exit(1) + elif args.quick: + tests = list(QUICK_TESTS) else: tests = list(GREAT_100_THEOREMS) + # In local mode without explicit --test, reorder for optimal library dedup + if args.local and not args.test: + order = {name: i for i, name in enumerate(LOCAL_ORDER)} + tests.sort(key=lambda t: order.get(t, len(LOCAL_ORDER))) + runner = TestRunner( base_dir=args.base_dir, timeout=args.timeout, @@ -570,11 +775,14 @@ def main(): fail_fast=args.fail_fast, ) - # Setup checkpoint - runner.setup(reuse_checkpoint=args.reuse_checkpoint) + if args.local: + results = runner.run_all_local(tests) + else: + # Setup checkpoint + runner.setup(reuse_checkpoint=args.reuse_checkpoint) - # Run tests - results = runner.run_all(tests) + # Run tests + results = runner.run_all(tests) # Report Reporter.print_summary(results) From e74e71fda790ec9e890d32c4405b7be4090aa330 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Sat, 21 Mar 2026 11:40:02 +0800 Subject: [PATCH 71/79] Clean up some slop --- candle-regression.py | 546 ++++++++----------------------------------- 1 file changed, 96 insertions(+), 450 deletions(-) diff --git a/candle-regression.py b/candle-regression.py index 1cb2c62d..044e746c 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -1,25 +1,11 @@ -""" -Mostly vibe-coded, sigh. -""" import sys import pexpect import time import subprocess import os -import signal import argparse -import json -from dataclasses import dataclass, field, asdict +from dataclasses import dataclass from enum import Enum -from datetime import datetime - -def wait_group(pgid): - while True: - try: - os.killpg(pgid, 0) - except ProcessLookupError: - return - time.sleep(0.1) # --------------------------------------------------------------------------- # Exceptions @@ -46,10 +32,6 @@ class TestStatus(Enum): PASS = "PASS" FAIL = "FAIL" TIMEOUT = "TIMEOUT" - SKIP = "SKIP" - XFAIL = "XFAIL" - XPASS = "XPASS" - @dataclass class TestResult: @@ -57,209 +39,68 @@ class TestResult: status: TestStatus elapsed: float = 0.0 error_message: str = "" - output_log: str = "" -# --------------------------------------------------------------------------- -# Test list — 64 Great 100 Theorems from candletest.mk -# --------------------------------------------------------------------------- - -GREAT_100_THEOREMS = [ - "100/arithmetic_geometric_mean", +TESTS = [ "100/arithmetic", - "100/ballot", - "100/bernoulli", - "100/bertrand", - "100/birthday", "100/cantor", - "100/cayley_hamilton", - "100/ceva", - "100/circle", - "100/chords", + "100/konigsberg", + "100/gcd", + "100/wilson", "100/combinations", - "100/constructible", - "100/cosine", - "100/cubic", - "100/derangements", - "100/desargues", - "100/descartes", - "100/dirichlet", - "100/div3", - "100/divharmonic", - "100/e_is_transcendental", + "100/ratcountable", "100/euler", - "100/feuerbach", - "100/fourier", - "100/four_squares", - "100/friendship", - "100/fta", - "100/gcd", - "100/heron", - "100/inclusion_exclusion", - "100/independence", - "100/isoperimetric", - "100/isosceles", - "100/konigsberg", - "100/lagrange", - "100/leibniz", "100/lhopital", - "100/liouville", - "100/minkowski", - "100/morley", - "100/pascal", - "100/perfect", - "100/pick", - "100/piseries", - "100/platonic", - "100/pnt", - "100/polyhedron", - "100/primerecip", - "100/ptolemy", - "100/pythagoras", - "100/quartic", - "100/ramsey", - "100/ratcountable", - "100/realsuncountable", - "100/reciprocity", - "100/sqrt", "100/stirling", - "100/subsequence", - "100/thales", - "100/transcendence", - "100/triangular", - "100/two_squares", - "100/wilson", -] - -# Curated 18-test subset for --quick: maximum code coverage, no binding conflicts. -QUICK_TESTS = [ - # Core tactics (no extra deps) - "100/arithmetic", # INDUCT_TAC, ARITH_TAC - "100/cantor", # set theory, MESON - "100/konigsberg", # graph theory (safe — no standard name redefinitions) - # Library coverage (one per major library) - "100/gcd", # Library/prime.ml - "100/wilson", # Library/pocklington.ml - "100/combinations", # Library/binomial.ml - "100/ratcountable", # Library/card.ml - "100/euler", # Library/binary.ml - "100/lhopital", # Library/analysis.ml - "100/stirling", # Library/transc.ml - "100/liouville", # Library/floor.ml + Library/poly.ml - # Multivariate coverage (one per chain level) - "100/thales", # Multivariate/convex.ml chain - "100/desargues", # Multivariate/cross.ml - "100/cosine", # Multivariate/transcendentals.ml - "100/descartes", # Multivariate/realanalysis.ml - "100/heron", # Multivariate/measure.ml - "100/fourier", # Multivariate/lpspaces.ml - # Complex coverage - "100/cubic", # Complex/complex_transc.ml -] - -# Dependency-optimized order for --local mode (needs deduplicates library loads). -LOCAL_ORDER = [ - # Phase 1: No extra deps - "100/arithmetic", "100/birthday", "100/cantor", "100/divharmonic", - "100/inclusion_exclusion", "100/konigsberg", "100/quartic", "100/subsequence", - # Phase 2: Library/prime.ml - "100/gcd", "100/perfect", "100/fta", "100/two_squares", "100/lagrange", - # Phase 3: + pocklington.ml - "100/friendship", "100/div3", "100/wilson", "100/reciprocity", - # Phase 4: Library/binomial.ml - "100/combinations", "100/ballot", - # Phase 5: Library/card.ml - "100/ratcountable", "100/realsuncountable", - # Phase 6: Library/binary.ml - "100/euler", - # Phase 7: Library/analysis.ml + transc - "100/lhopital", "100/four_squares", "100/stirling", "100/leibniz", - "100/bernoulli", "100/derangements", "100/arithmetic_geometric_mean", - # Phase 8: Library/floor + poly "100/liouville", - # Phase 9: Multivariate/misc + vectors - "100/triangular", "100/pythagoras", - # Phase 10: Multivariate/convex.ml - "100/chords", "100/thales", "100/feuerbach", "100/ceva", - # Phase 11: Multivariate/cross.ml - "100/desargues", "100/pascal", - # Phase 12: Multivariate/complexes.ml - "100/cayley_hamilton", - # Phase 13: Multivariate/transcendentals.ml - "100/ptolemy", "100/cosine", "100/constructible", - # Phase 14: Multivariate/realanalysis.ml - "100/descartes", - # Phase 15: Multivariate/geom.ml - "100/isosceles", "100/morley", - # Phase 16: Multivariate/measure.ml - "100/heron", "100/minkowski", "100/circle", - # Phase 17: Multivariate/polytope.ml - "100/polyhedron", "100/pick", - # Phase 18: Multivariate/lpspaces.ml - "100/fourier", - # Phase 19: Multivariate/cauchy.ml - "100/independence", "100/isoperimetric", - # Phase 20: Complex - "100/cubic", - # Phase 21: Heavy compound (deps already loaded) - "100/bertrand", "100/primerecip", "100/e_is_transcendental", "100/piseries", - "100/platonic", "100/dirichlet", "100/pnt", "100/transcendence", - # Phase 22: ramsey last — redefines standard conversions - "100/ramsey", - # sqrt not in candletest.mk phases but is in GREAT_100_THEOREMS - "100/sqrt", + "100/thales", + "100/desargues", ] -# Tests known to fail — maps test name to reason. -# Tests here that fail get XFAIL; tests here that pass get XPASS. -KNOWN_FAILURES = {} - # --------------------------------------------------------------------------- # CandleREPL # --------------------------------------------------------------------------- class CandleREPL: - def __init__(self, base, logfile=None): + def __init__(self, base, restore=False): + # Easier to assume that we are in the candle directory for now. os.chdir(base) - self.base = base - self.checkpoint_dir = "checkpoint" - self._logfile = logfile or sys.stdout - try: - self.process = pexpect.spawn( - "./candle", encoding='utf-8', logfile=self._logfile, - ) - except Exception as e: - raise StartFailure from e + # 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 - try: - self._check_boot() - except BootFailure: - self.kill() - raise + self._logfile = sys.stdout + self._base = base + self._checkpoint_dir = "checkpoint" + self._pidfile_name = "cake.pid" self.load_stack = [] self.last_val = None - @classmethod - def from_checkpoint(cls, base_dir, logfile=None): - """Create a CandleREPL by restoring from an existing checkpoint.""" - obj = object.__new__(cls) - obj.base = base_dir - obj.checkpoint_dir = "checkpoint" - obj._logfile = logfile or sys.stdout - obj.load_stack = [] - obj.last_val = None - os.chdir(base_dir) - obj.restore() - return obj + 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# ', # 0: REPL prompt → success - r'\n(ERROR: .+)', # 1: any boot error + r'\n# ', + r'\n(ERROR: .+)', pexpect.TIMEOUT, pexpect.EOF, ]) @@ -267,15 +108,16 @@ def _check_boot(self): raise BootFailure from e if index != 0: - reasons = {1: str(self._get_match(1)), 2: "Timeout", 3: "Process exited unexpectedly"} + 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 _set_last_val(self, val): - self.last_val = (val, time.perf_counter()) - def _check_output(self, timeout=600): try: index = self.process.expect([ @@ -296,7 +138,7 @@ def _check_output(self, timeout=600): dependency = self._get_match(1) self.load_stack.append(dependency) case 1: - self._set_last_val(self._get_match(1)) + self.last_val = self._get_match(1) case 2 | 3 | 4: raise LoadFailure(self._get_match(1)) case 5: @@ -308,7 +150,7 @@ def _check_output(self, timeout=600): case 7: raise LoadFailure("Process exited unexpectedly") case _: - pass + assert False, "Unreachable: Did you add a new case in _check_output?" def load(self, file, timeout=600): self.process.sendline(f'#use "{file}";;') @@ -317,56 +159,54 @@ def load(self, file, timeout=600): while self.load_stack: self._check_output(timeout=timeout) - def run_loads(self, file, timeout=600): - """Send loads "file";; — HOL Light's dependency-aware loader.""" - self.process.sendline(f'loads "{file}";;') - self._check_output(timeout=timeout) - - while self.load_stack: - self._check_output(timeout=timeout) - - def send_exit(self, timeout=30): - """Send Cake.Runtime.exit 0;; and wait for the process to terminate.""" - self.process.sendline('Cake.Runtime.exit 0;;') - self.process.expect(pexpect.EOF, timeout=timeout) - - def wait_for_prompt(self, timeout=30): - """After restore, send ();; to elicit a prompt from the restored process.""" - self.process.sendline('();;') - self.process.expect(r'# ', timeout=timeout) - def kill(self): - try: - self.process.close(force=True) - except Exception: - pass - if hasattr(self, '_cake_pid'): + 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)]) - wait_group(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) - pid = self.process.pid - pidfile = os.path.join(self.checkpoint_dir, "cake.pid") - with open(pidfile, "w") as f: - f.write(str(pid)) + 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"], + ["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, logfile=None): - lf = logfile if logfile is not None else self._logfile + def restore(self): self.process = pexpect.spawn( - "sudo", ["criu", "restore", "-D", self.checkpoint_dir, "--shell-job"], + "sudo", ["criu", "restore", "-D", self._checkpoint_dir, "--shell-job"], encoding='utf-8', - logfile=lf, + logfile=self._logfile, ) # Assumption: CRIU restores processes with their original PIDs. # Read the cake PID (saved during dump) so kill() can target it. - pidfile = os.path.join(self.checkpoint_dir, "cake.pid") - self._cake_pid = int(open(pidfile).read().strip()) + self._cake_pid = int(open(self._pidfile()).read().strip()) # --------------------------------------------------------------------------- @@ -378,9 +218,6 @@ class Reporter: TestStatus.PASS: "PASS", TestStatus.FAIL: "FAIL", TestStatus.TIMEOUT: "TIME", - TestStatus.SKIP: "SKIP", - TestStatus.XFAIL: "XFAIL", - TestStatus.XPASS: "XPASS", } @staticmethod @@ -408,63 +245,25 @@ def print_summary(results): # Highlight problems failures = [r for r in results if r.status in (TestStatus.FAIL, TestStatus.TIMEOUT)] - xpasses = [r for r in results if r.status == TestStatus.XPASS] if failures: print() - print("NEW FAILURES:") + print("FAILURES:") for r in failures: msg = f" {r.name}: {r.status.value}" if r.error_message: msg += f" — {r.error_message}" print(msg) - if xpasses: - print() - print("REGRESSIONS (now passing — update KNOWN_FAILURES):") - for r in xpasses: - print(f" {r.name}") - - @staticmethod - def write_json(results, path): - counts = {} - for s in TestStatus: - c = sum(1 for r in results if r.status == s) - if c: - counts[s.value] = c - - data = { - "timestamp": datetime.now().isoformat(), - "summary": { - "total": len(results), - **counts, - }, - "tests": [ - { - "name": r.name, - "status": r.status.value, - "elapsed": round(r.elapsed, 2), - "error_message": r.error_message, - } - for r in results - ], - } - - with open(path, "w") as f: - json.dump(data, f, indent=2) - f.write("\n") - print(f"\nJSON results written to {path}") - # --------------------------------------------------------------------------- # TestRunner # --------------------------------------------------------------------------- class TestRunner: - def __init__(self, base_dir, timeout=600, verbose=False, fail_fast=False): + def __init__(self, base_dir, timeout=600, fail_fast=False): self.base_dir = base_dir self.timeout = timeout - self.verbose = verbose self.fail_fast = fail_fast def setup(self, reuse_checkpoint=False): @@ -475,8 +274,7 @@ def setup(self, reuse_checkpoint=False): return print("Starting candle and loading hol.ml...") - logfile = sys.stdout if self.verbose else None - repl = CandleREPL(self.base_dir, logfile=logfile) + repl = CandleREPL(self.base_dir) try: repl.load("hol.ml", timeout=3600) print("hol.ml loaded. Dumping checkpoint...") @@ -488,11 +286,10 @@ def setup(self, reuse_checkpoint=False): def run_test(self, name): """Restore from checkpoint, run a single test, return TestResult.""" - logfile = sys.stdout if self.verbose else None start = time.perf_counter() try: - repl = CandleREPL.from_checkpoint(self.base_dir, logfile=logfile) + repl = CandleREPL(self.base_dir, restore=True) except Exception as e: elapsed = time.perf_counter() - start return TestResult( @@ -501,13 +298,9 @@ def run_test(self, name): ) try: - repl.wait_for_prompt(timeout=30) - repl.run_loads(f"{name}.ml", timeout=self.timeout) - repl.send_exit(timeout=30) + repl.load(f"{name}.ml", timeout=self.timeout) elapsed = time.perf_counter() - start - if name in KNOWN_FAILURES: - return TestResult(name=name, status=TestStatus.XPASS, elapsed=elapsed) return TestResult(name=name, status=TestStatus.PASS, elapsed=elapsed) except LoadFailure as e: @@ -516,74 +309,10 @@ def run_test(self, name): if repl.load_stack: err += f" [while loading: {' > '.join(repl.load_stack)}]" if repl.last_val: - err += f" (last val: {repl.last_val[0]})" + err += f" (last val: {repl.last_val})" if "Timeout" in str(e): status = TestStatus.TIMEOUT - elif name in KNOWN_FAILURES: - status = TestStatus.XFAIL - 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" [while loading: {' > '.join(repl.load_stack)}]" - if repl.last_val: - err += f" (last val: {repl.last_val[0]})" - if name in KNOWN_FAILURES: - status = TestStatus.XFAIL - 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" [while loading: {' > '.join(repl.load_stack)}]" - if repl.last_val: - err += f" (last val: {repl.last_val[0]})" - if name in KNOWN_FAILURES: - status = TestStatus.XFAIL - else: - status = TestStatus.FAIL - return TestResult( - name=name, status=status, - elapsed=elapsed, error_message=err, - ) - - finally: - repl.kill() - def run_test_local(self, repl, name): - """Run a single test in an existing REPL session, return TestResult.""" - start = time.perf_counter() - - try: - repl.run_loads(f"{name}.ml", timeout=self.timeout) - elapsed = time.perf_counter() - start - - if name in KNOWN_FAILURES: - return TestResult(name=name, status=TestStatus.XPASS, elapsed=elapsed) - 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" [while loading: {' > '.join(repl.load_stack)}]" - if repl.last_val: - err += f" (last val: {repl.last_val[0]})" - repl.load_stack.clear() - if "Timeout" in str(e): - status = TestStatus.TIMEOUT - elif name in KNOWN_FAILURES: - status = TestStatus.XFAIL else: status = TestStatus.FAIL return TestResult(name=name, status=status, elapsed=elapsed, error_message=err) @@ -594,10 +323,7 @@ def run_test_local(self, repl, name): if repl.load_stack: err += f" [while loading: {' > '.join(repl.load_stack)}]" if repl.last_val: - err += f" (last val: {repl.last_val[0]})" - repl.load_stack.clear() - if name in KNOWN_FAILURES: - status = TestStatus.XFAIL + err += f" (last val: {repl.last_val})" else: status = TestStatus.TIMEOUT return TestResult( @@ -611,10 +337,7 @@ def run_test_local(self, repl, name): if repl.load_stack: err += f" [while loading: {' > '.join(repl.load_stack)}]" if repl.last_val: - err += f" (last val: {repl.last_val[0]})" - repl.load_stack.clear() - if name in KNOWN_FAILURES: - status = TestStatus.XFAIL + err += f" (last val: {repl.last_val})" else: status = TestStatus.FAIL return TestResult( @@ -622,47 +345,9 @@ def run_test_local(self, repl, name): elapsed=elapsed, error_message=err, ) - def run_all_local(self, tests): - """Run all tests in a single REPL session (no CRIU).""" - results = [] - total = len(tests) - logfile = sys.stdout if self.verbose else None - - print("Starting candle and loading hol.ml...") - repl = CandleREPL(self.base_dir, logfile=logfile) - try: - repl.load("hol.ml", timeout=3600) - print("hol.ml loaded.") - except Exception: - repl.kill() - raise - - try: - for i, name in enumerate(tests, 1): - print(f"[{i}/{total}] {name} ... ", end="", flush=True) - result = self.run_test_local(repl, 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 - # After a failure, check the REPL is still alive - if result.status in (TestStatus.FAIL, TestStatus.TIMEOUT, TestStatus.XFAIL): - try: - repl.process.sendline('();;') - repl.process.expect(r'# ', timeout=30) - except Exception: - print("REPL unresponsive after failure — aborting remaining tests.") - break - except KeyboardInterrupt: - print("\nInterrupted — showing results so far.") finally: repl.kill() - return results def run_all(self, tests): """Run all tests, printing progress inline.""" @@ -700,33 +385,17 @@ def main(): help="Skip hol.ml loading if a checkpoint already exists", ) parser.add_argument( - "-t", "--test", action="append", default=[], - help="Run specific test(s) by name (can be repeated)", - ) - parser.add_argument( - "--json", metavar="FILE", - help="Write JSON results to FILE", + "--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( - "-v", "--verbose", action="store_true", - help="Show verbose REPL output", - ) parser.add_argument( "--fail-fast", action="store_true", help="Stop after the first unexpected failure", ) - parser.add_argument( - "--local", action="store_true", - help="Run tests in a single REPL session (no CRIU, deduplicates library loads)", - ) - parser.add_argument( - "--quick", action="store_true", - help="Run curated 18-test subset for maximum coverage", - ) parser.add_argument( "--timeout", type=int, default=600, help="Per-test timeout in seconds (default: 600)", @@ -738,59 +407,36 @@ def main(): args = parser.parse_args() - # Select test list - available = QUICK_TESTS if args.quick else GREAT_100_THEOREMS - + available = TESTS if args.list: for name in available: - marker = " (KNOWN_FAILURE)" if name in KNOWN_FAILURES else "" - print(f" {name}{marker}") - label = "quick" if args.quick else "available" - print(f"\n{len(available)} {label} tests") + print(f" {name}") + print(f"\n{len(available)} tests") return # Determine which tests to run if args.test: - tests = [] - for t in args.test: - if t in GREAT_100_THEOREMS: - tests.append(t) - else: - print(f"Unknown test: {t}", file=sys.stderr) - sys.exit(1) - elif args.quick: - tests = list(QUICK_TESTS) + tests = args.test else: - tests = list(GREAT_100_THEOREMS) - - # In local mode without explicit --test, reorder for optimal library dedup - if args.local and not args.test: - order = {name: i for i, name in enumerate(LOCAL_ORDER)} - tests.sort(key=lambda t: order.get(t, len(LOCAL_ORDER))) + tests = list(TESTS) runner = TestRunner( base_dir=args.base_dir, timeout=args.timeout, - verbose=args.verbose, fail_fast=args.fail_fast, ) - if args.local: - results = runner.run_all_local(tests) - else: - # Setup checkpoint - runner.setup(reuse_checkpoint=args.reuse_checkpoint) + # Setup checkpoint + runner.setup(reuse_checkpoint=args.reuse_checkpoint) - # Run tests - results = runner.run_all(tests) + # Run tests + results = runner.run_all(tests) # Report Reporter.print_summary(results) - if args.json: - Reporter.write_json(results, args.json) # Exit code: 0 if no unexpected failures - unexpected = [r for r in results if r.status in (TestStatus.FAIL, TestStatus.TIMEOUT, TestStatus.XPASS)] + unexpected = [r for r in results if r.status in (TestStatus.FAIL, TestStatus.TIMEOUT)] sys.exit(1 if unexpected else 0) From 0cf4d00de56e7b4898d40f82aad5b8c556f13969 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Sat, 21 Mar 2026 12:31:07 +0800 Subject: [PATCH 72/79] Print load_stack when failing early --- candle-regression.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/candle-regression.py b/candle-regression.py index 044e746c..be8b145b 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -140,7 +140,7 @@ def _check_output(self, timeout=600): case 1: self.last_val = self._get_match(1) case 2 | 3 | 4: - raise LoadFailure(self._get_match(1)) + raise LoadFailure(f"{self._get_match(1)} [while loading: {' > '.join(self.load_stack)}]") case 5: finished = self._get_match(1) expected = self.load_stack.pop() From 3f88bd916fc3695822df867e86601391f4b15240 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Sat, 21 Mar 2026 14:21:19 +0800 Subject: [PATCH 73/79] Add auto-generated files to .gitignore and clean up --- .gitignore | 6 +- Examples/update_database.ml | 181 --------- build-instructions.sh | 6 + candle_boot.ml | 760 ------------------------------------ candle_insulate.ml | 448 --------------------- hol_lib.ml | 2 +- 6 files changed, 12 insertions(+), 1391 deletions(-) delete mode 100644 Examples/update_database.ml delete mode 100644 candle_boot.ml delete mode 100644 candle_insulate.ml 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/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/build-instructions.sh b/build-instructions.sh index b7418cc2..09deca95 100755 --- a/build-instructions.sh +++ b/build-instructions.sh @@ -15,6 +15,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/candle_boot.ml b/candle_boot.ml deleted file mode 100644 index 5e9a20e1..00000000 --- a/candle_boot.ml +++ /dev/null @@ -1,760 +0,0 @@ -(* ------------------------------------------------------------------------- * - * Prelude - * ------------------------------------------------------------------------- *) - -(* This is pointer equality, which is missing from CakeML. - The way we want to implement this is by using (=) for mutable types such as - references, and false otherwise. - By defining (==) as follows, we get the correct behavior for reference types, - and type errors everywhere else. Those need to be manually fixed, using (=) - for mutable types, and false otherwise. The hope is that the type error - messages make this decision easier. - *) -let (==) x y = !x; !y; x = y - -let ref x = Ref x;; - -let (/) x y = div x y;; -let (-.) x y = Double.(-) x y;; -let (+.) x y = Double.(+) x y;; -let ( *.) x y = Double.( * ) x y;; -let (/.) x y = Double.(/) x y;; -let ( ** ) x y = Double.pow x y;; -let (||) x y = x || y;; - -let log x = Double.ln x;; - -(* OCaml parser doesn't like ~, and the CakeML parser doesn't like ~- nor ~-. *) -(*CML -val negint = Int.~; -val negfloat = Double.~; -*) -let (~-) x = negint x;; -let (~-.) x = negfloat x;; - -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));; -let (lor) x y = - Word64.toInt (Word64.orb (Word64.fromInt x) (Word64.fromInt y));; -let (lxor) x y = - Word64.toInt (Word64.xorb (Word64.fromInt x) (Word64.fromInt y));; -let lnot x = - Word64.toInt (Word64.notb (Word64.fromInt x));; - - -(* 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 after loading a file *) -;; - -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 pushLoad, popLoad, clearLoadStack = - let stack = ref ([]: string list) in - let pushLoad fname = stack := fname :: !stack in - let popLoad () = - match !stack with - | fname :: rest as res -> stack := rest; Some (fname, rest) - | _ -> None in - let clearLoadStack () = stack := [] in - pushLoad, popLoad, clearLoadStack 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) (Lexer.T_done :: acc) - | Some tok -> nom (tok::acc) in - nom [] 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 - (* Attempt to use token as part of loading directive if it sits at the - top level (i.e. not inside parenthesis). The REPL fails and reports - and error unless the token is followed by a string literal and then - double semicolons. Ideally we should also check that the token sits - at the start of the line, but we don't, so odd things such as this: - foo needs "bar.ml";; - are OK and will cause the file bar.ml to be loaded and appear - directly after 'foo' in the token stream. - *) - | Some (Lexer.T_use | Lexer.T_needs | Lexer.T_loads as tok) - when level = 0 -> - 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 - pushLoad fname; - 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) -> - (match popLoad () with - | Some (fname, rest) -> ( - print ("- Finished loading " ^ fname ^ "\n"); - if List.null rest then userInput := true) - | None -> failwith "candle_boot.ml: scan - should be unreachable"); - 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; - clearLoadStack (); - Repl.nextString := ""; - userInput := true in - Repl.readNextString := (fun () -> - print (!prompt1); - next (); - Repl.readNextString := next) -;; - -end;; (* struct *) diff --git a/candle_insulate.ml b/candle_insulate.ml deleted file mode 100644 index c672eff7..00000000 --- a/candle_insulate.ml +++ /dev/null @@ -1,448 +0,0 @@ -(* Generated by candle_insulate.py based on CakeML's types.txt *) -(* This file insulates the codebase from direct CakeML API usage *) - -module Cake = struct - module Alist = struct - let delete x0 x1 = Alist.delete x0 x1 - let every x0 x1 = Alist.every x0 x1 - let lookup x0 x1 = Alist.lookup x0 x1 - let map x0 x1 = Alist.map x0 x1 - let update x0 x1 = Alist.update x0 x1 - end;; - - module Array = struct - let all x0 x1 = Array.all x0 x1 - let app x0 x1 = Array.app x0 x1 - let appi x0 x1 = Array.appi x0 x1 - let array x0 x1 = Array.array x0 x1 - let arrayEmpty x0 = Array.arrayEmpty x0 - let collate x0 x1 x2 = Array.collate x0 x1 x2 - let copy x0 x1 x2 = Array.copy x0 x1 x2 - let copyVec x0 x1 x2 = Array.copyVec x0 x1 x2 - let exists x0 x1 = Array.exists x0 x1 - let find x0 x1 = Array.find x0 x1 - let findi x0 x1 = Array.findi x0 x1 - let foldl x0 x1 x2 = Array.foldl x0 x1 x2 - let foldli x0 x1 x2 = Array.foldli x0 x1 x2 - let foldr x0 x1 x2 = Array.foldr x0 x1 x2 - let foldri x0 x1 x2 = Array.foldri x0 x1 x2 - let fromList x0 = Array.fromList x0 - let length x0 = Array.length x0 - let lookup x0 x1 x2 = Array.lookup x0 x1 x2 - let modify x0 x1 = Array.modify x0 x1 - let modifyi x0 x1 = Array.modifyi x0 x1 - let sub x0 x1 = Array.sub x0 x1 - let tabulate x0 x1 = Array.tabulate x0 x1 - let update x0 x1 x2 = Array.update x0 x1 x2 - let updateResize x0 x1 x2 x3 = Array.updateResize x0 x1 x2 x3 - end;; - - module Bool = struct - let (=) x0 x1 = Bool.(=) x0 x1 - let compare x0 x1 = Bool.compare x0 x1 - let fromString x0 = Bool.fromString x0 - let not x0 = Bool.not x0 - let toString x0 = Bool.toString x0 - end;; - - module Char = struct - let (<) x0 x1 = Char.(<) x0 x1 - let (<=) x0 x1 = Char.(<=) x0 x1 - let (=) x0 x1 = Char.(=) x0 x1 - let (>) x0 x1 = Char.(>) x0 x1 - let (>=) x0 x1 = Char.(>=) x0 x1 - let chr x0 = Char.chr x0 - let fromByte x0 = Char.fromByte x0 - let isSpace x0 = Char.isSpace x0 - let ord x0 = Char.ord x0 - let some x0 = Char.some x0 - end;; - - module Command_line = struct - let arguments x0 = Command_line.arguments x0 - let cline x0 = Command_line.cline x0 - let name x0 = Command_line.name x0 - end;; - - module Double = struct - type double = Double.double - - let ( * ) x0 x1 = Double.( * ) x0 x1 - let (+) x0 x1 = Double.(+) x0 x1 - let (-) x0 x1 = Double.(-) x0 x1 - let (/) x0 x1 = Double.(/) x0 x1 - let (<) x0 x1 = Double.(<) x0 x1 - let (<=) x0 x1 = Double.(<=) x0 x1 - let (=) x0 x1 = Double.(=) x0 x1 - let (>) x0 x1 = Double.(>) x0 x1 - let (>=) x0 x1 = Double.(>=) x0 x1 - let abs x0 = Double.abs x0 - let construct x0 x1 x2 = Double.construct x0 x1 x2 - let exp x0 = Double.exp x0 - let exponent x0 = Double.exponent x0 - let ffloat_ulp x0 = Double.ffloat_ulp x0 - let float_is_finite x0 = Double.float_is_finite x0 - let float_is_zero x0 = Double.float_is_zero x0 - let floor x0 = Double.floor x0 - let flt_max = Double.flt_max - let fma x0 x1 x2 = Double.fma x0 x1 x2 - let fnext_hi x0 = Double.fnext_hi x0 - let fnext_lo x0 = Double.fnext_lo x0 - let fromInt x0 = Double.fromInt x0 - let fromString x0 = Double.fromString x0 - let fromWord x0 = Double.fromWord x0 - let ln x0 = Double.ln x0 - let maxulp = Double.maxulp - let neginf64 = Double.neginf64 - let posinf64 = Double.posinf64 - let posmin64 = Double.posmin64 - let poszero64 = Double.poszero64 - let pow x0 x1 = Double.pow x0 x1 - let pp_double x0 = Double.pp_double x0 - let sign x0 = Double.sign x0 - let significand x0 = Double.significand x0 - let sqrt x0 = Double.sqrt x0 - let toInt x0 = Double.toInt x0 - let toString x0 = Double.toString x0 - let toWord x0 = Double.toWord x0 - let twicemaxulp = Double.twicemaxulp - end;; - - module Hashtable = struct - type ('a, 'b) hashtable = ('a, 'b) Hashtable.hashtable - - let clear x0 = Hashtable.clear x0 - let delete x0 x1 = Hashtable.delete x0 x1 - let empty x0 x1 x2 = Hashtable.empty x0 x1 x2 - let insert x0 x1 x2 = Hashtable.insert x0 x1 x2 - let lookup x0 x1 = Hashtable.lookup x0 x1 - let size x0 = Hashtable.size x0 - let toAscList x0 = Hashtable.toAscList x0 - end;; - - module Int = struct - let ( * ) x0 x1 = Int.( * ) x0 x1 - let (+) x0 x1 = Int.(+) x0 x1 - let (-) x0 x1 = Int.(-) x0 x1 - let (<) x0 x1 = Int.(<) x0 x1 - let (<=) x0 x1 = Int.(<=) x0 x1 - let (>) x0 x1 = Int.(>) x0 x1 - let (>=) x0 x1 = Int.(>=) x0 x1 - let (mod) x0 x1 = Int.(mod) x0 x1 - let compare x0 x1 = Int.compare x0 x1 - let div x0 x1 = Int.div x0 x1 - let fromNatString x0 = Int.fromNatString x0 - let fromString x0 = Int.fromString x0 - let gcd x0 x1 = Int.gcd x0 x1 - let int_to_string x0 x1 = Int.int_to_string x0 x1 - let toString x0 = Int.toString x0 - end;; - - module List = struct - let (@) x0 x1 = List.(@) x0 x1 - let all x0 x1 = List.all x0 x1 - let all_distinct x0 = List.all_distinct x0 - let app x0 x1 = List.app x0 x1 - let cmp x0 x1 x2 = List.cmp x0 x1 x2 - let collate x0 x1 x2 = List.collate x0 x1 x2 - let compare x0 x1 x2 = List.compare x0 x1 x2 - let concat x0 = List.concat x0 - let drop x0 x1 = List.drop x0 x1 - let dropUntil x0 x1 = List.dropUntil x0 x1 - let exists x0 x1 = List.exists x0 x1 - let filter x0 x1 = List.filter x0 x1 - let filterRev x0 x1 = List.filterRev x0 x1 - let find x0 x1 = List.find x0 x1 - let flatRev x0 = List.flatRev x0 - let foldl x0 x1 x2 = List.foldl x0 x1 x2 - let foldli x0 x1 x2 = List.foldli x0 x1 x2 - let foldr x0 x1 x2 = List.foldr x0 x1 x2 - let foldri x0 x1 x2 = List.foldri x0 x1 x2 - let front x0 = List.front x0 - let genlist x0 x1 = List.genlist x0 x1 - let getItem x0 = List.getItem x0 - let hd x0 = List.hd x0 - let isPrefix x0 x1 = List.isPrefix x0 x1 - let last x0 = List.last x0 - let length x0 = List.length x0 - let map x0 x1 = List.map x0 x1 - let mapPartial x0 x1 = List.mapPartial x0 x1 - let mapRev x0 x1 = List.mapRev x0 x1 - let mapi x0 x1 = List.mapi x0 x1 - let member x0 x1 = List.member x0 x1 - let nth x0 x1 = List.nth x0 x1 - let null x0 = List.null x0 - let pad_left x0 x1 x2 = List.pad_left x0 x1 x2 - let pad_right x0 x1 x2 = List.pad_right x0 x1 x2 - let partition x0 x1 = List.partition x0 x1 - let rev x0 = List.rev x0 - let snoc x0 x1 = List.snoc x0 x1 - let sort x0 x1 = List.sort x0 x1 - let split x0 x1 = List.split x0 x1 - let splitAtPki x0 x1 x2 = List.splitAtPki x0 x1 x2 - let sum x0 = List.sum x0 - let tabulate x0 x1 = List.tabulate x0 x1 - let take x0 x1 = List.take x0 x1 - let takeUntil x0 x1 = List.takeUntil x0 x1 - let tl x0 = List.tl x0 - let unzip x0 = List.unzip x0 - let update x0 x1 x2 = List.update x0 x1 x2 - let zip x0 = List.zip x0 - end;; - - module Map = struct - let all x0 x1 = Map.all x0 x1 - let compare x0 x1 x2 = Map.compare x0 x1 x2 - let delete x0 x1 = Map.delete x0 x1 - let empty x0 = Map.empty x0 - let exists x0 x1 = Map.exists x0 x1 - let filter x0 x1 = Map.filter x0 x1 - let filterWithKey x0 x1 = Map.filterWithKey x0 x1 - let foldrWithKey x0 x1 x2 = Map.foldrWithKey x0 x1 x2 - let fromList x0 x1 = Map.fromList x0 x1 - let insert x0 x1 x2 = Map.insert x0 x1 x2 - let isSubmap x0 x1 = Map.isSubmap x0 x1 - let isSubmapBy x0 x1 x2 = Map.isSubmapBy x0 x1 x2 - let lookup x0 x1 = Map.lookup x0 x1 - let map x0 x1 = Map.map x0 x1 - let mapWithKey x0 x1 = Map.mapWithKey x0 x1 - let member x0 x1 = Map.member x0 x1 - let null x0 = Map.null x0 - let singleton x0 x1 x2 = Map.singleton x0 x1 x2 - let size x0 = Map.size x0 - let toAscList x0 = Map.toAscList x0 - let union x0 x1 = Map.union x0 x1 - let unionWith x0 x1 x2 = Map.unionWith x0 x1 x2 - let unionWithKey x0 x1 x2 = Map.unionWithKey x0 x1 x2 - end;; - - module Marshalling = struct - let n2w2 x0 x1 x2 = Marshalling.n2w2 x0 x1 x2 - let w22n x0 x1 = Marshalling.w22n x0 x1 - end;; - - module Option = struct - let compare x0 x1 x2 = Option.compare x0 x1 x2 - let compose x0 x1 x2 = Option.compose x0 x1 x2 - let composePartial x0 x1 x2 = Option.composePartial x0 x1 x2 - let getOpt x0 x1 = Option.getOpt x0 x1 - let isNone x0 = Option.isNone x0 - let isSome x0 = Option.isSome x0 - let join x0 = Option.join x0 - let map x0 x1 = Option.map x0 x1 - let map2 x0 x1 x2 = Option.map2 x0 x1 x2 - let mapPartial x0 x1 = Option.mapPartial x0 x1 - let valOf x0 = Option.valOf x0 - end;; - - module Pair = struct - let compare x0 x1 x2 x3 = Pair.compare x0 x1 x2 x3 - let map x0 x1 x2 = Pair.map x0 x1 x2 - let toString x0 x1 x2 = Pair.toString x0 x1 x2 - end;; - - module Rat = struct - type rat = Rat.rat - - let ( * ) x0 x1 = Rat.( * ) x0 x1 - let (+) x0 x1 = Rat.(+) x0 x1 - let (-) x0 x1 = Rat.(-) x0 x1 - let (/) x0 x1 = Rat.(/) x0 x1 - let (<) x0 x1 = Rat.(<) x0 x1 - let (<=) x0 x1 = Rat.(<=) x0 x1 - let (>) x0 x1 = Rat.(>) x0 x1 - let (>=) x0 x1 = Rat.(>=) x0 x1 - let ceiling x0 = Rat.ceiling x0 - let compare x0 x1 = Rat.compare x0 x1 - let denominator x0 = Rat.denominator x0 - let floor x0 = Rat.floor x0 - let fromInt x0 = Rat.fromInt x0 - let inv x0 = Rat.inv x0 - let is_int x0 = Rat.is_int x0 - let max x0 x1 = Rat.max x0 x1 - let min x0 x1 = Rat.min x0 x1 - let numerator x0 = Rat.numerator x0 - let pp_rat x0 = Rat.pp_rat x0 - let toString x0 = Rat.toString x0 - end;; - - module Runtime = struct - let abort x0 = Runtime.abort x0 - let debugMsg x0 = Runtime.debugMsg x0 - let exit x0 = Runtime.exit x0 - let fail x0 = Runtime.fail x0 - let fullGC x0 = Runtime.fullGC x0 - end;; - - module Set = struct - let all x0 x1 = Set.all x0 x1 - let compare x0 x1 = Set.compare x0 x1 - let delete x0 x1 = Set.delete x0 x1 - let empty x0 = Set.empty x0 - let exists x0 x1 = Set.exists x0 x1 - let filter x0 x1 = Set.filter x0 x1 - let fold x0 x1 x2 = Set.fold x0 x1 x2 - let fromList x0 x1 = Set.fromList x0 x1 - let insert x0 x1 = Set.insert x0 x1 - let isSubset x0 x1 = Set.isSubset x0 x1 - let map x0 x1 = Set.map x0 x1 - let member x0 x1 = Set.member x0 x1 - let null x0 = Set.null x0 - let singleton x0 x1 = Set.singleton x0 x1 - let size x0 = Set.size x0 - let toList x0 = Set.toList x0 - let translate x0 x1 x2 = Set.translate x0 x1 x2 - let union x0 x1 = Set.union x0 x1 - end;; - - module Sexp = struct - let fromString x0 = Sexp.fromString x0 - let inputSexp x0 = Sexp.inputSexp x0 - let pp_sexp x0 = Sexp.pp_sexp x0 - let pp_str_tree x0 = Sexp.pp_str_tree x0 - let str_tree_to_strings x0 x1 = Sexp.str_tree_to_strings x0 x1 - let toPrettyString x0 = Sexp.toPrettyString x0 - let toString x0 = Sexp.toString x0 - end;; - - module String = struct - let (<) x0 x1 = String.(<) x0 x1 - let (<=) x0 x1 = String.(<=) x0 x1 - let (=) x0 x1 = String.(=) x0 x1 - let (>) x0 x1 = String.(>) x0 x1 - let (>=) x0 x1 = String.(>=) x0 x1 - let (^) x0 x1 = String.(^) x0 x1 - let char_escape_seq x0 = String.char_escape_seq x0 - let collate x0 x1 x2 = String.collate x0 x1 x2 - let compare x0 x1 = String.compare x0 x1 - let concat x0 = String.concat x0 - let concatWith x0 x1 = String.concatWith x0 x1 - let escape_char x0 = String.escape_char x0 - let escape_str x0 = String.escape_str x0 - let explode x0 = String.explode x0 - let extract x0 x1 x2 = String.extract x0 x1 x2 - let fields x0 x1 = String.fields x0 x1 - let findi x0 x1 x2 = String.findi x0 x1 x2 - let implode x0 = String.implode x0 - let isPrefix x0 x1 = String.isPrefix x0 x1 - let isSubstring x0 x1 = String.isSubstring x0 x1 - let isSuffix x0 x1 = String.isSuffix x0 x1 - let size x0 = String.size x0 - let split x0 x1 = String.split x0 x1 - let str x0 = String.str x0 - let strcat x0 x1 = String.strcat x0 x1 - let sub x0 x1 = String.sub x0 x1 - let substring x0 x1 x2 = String.substring x0 x1 x2 - let tokens x0 x1 = String.tokens x0 x1 - let translate x0 x1 = String.translate x0 x1 - end;; - - module Vector = struct - let all x0 x1 = Vector.all x0 x1 - let collate x0 x1 x2 = Vector.collate x0 x1 x2 - let concat x0 = Vector.concat x0 - let exists x0 x1 = Vector.exists x0 x1 - let find x0 x1 = Vector.find x0 x1 - let findi x0 x1 = Vector.findi x0 x1 - let foldl x0 x1 x2 = Vector.foldl x0 x1 x2 - let foldli x0 x1 x2 = Vector.foldli x0 x1 x2 - let foldr x0 x1 x2 = Vector.foldr x0 x1 x2 - let foldri x0 x1 x2 = Vector.foldri x0 x1 x2 - let fromList x0 = Vector.fromList x0 - let length x0 = Vector.length x0 - let map x0 x1 = Vector.map x0 x1 - let mapi x0 x1 = Vector.mapi x0 x1 - let sub x0 x1 = Vector.sub x0 x1 - let tabulate x0 x1 = Vector.tabulate x0 x1 - let toList x0 = Vector.toList x0 - let update x0 x1 x2 = Vector.update x0 x1 x2 - end;; - - module Word64 = struct - let (+) x0 x1 = Word64.(+) x0 x1 - let (-) x0 x1 = Word64.(-) x0 x1 - let (<) x0 x1 = Word64.(<) x0 x1 - let (<<) x0 x1 = Word64.(<<) x0 x1 - let (<=) x0 x1 = Word64.(<=) x0 x1 - let (=) x0 x1 = Word64.(=) x0 x1 - let (>) x0 x1 = Word64.(>) x0 x1 - let (>=) x0 x1 = Word64.(>=) x0 x1 - let (>>) x0 x1 = Word64.(>>) x0 x1 - let andb x0 x1 = Word64.andb x0 x1 - let concatAll x0 x1 x2 x3 x4 x5 x6 x7 = Word64.concatAll x0 x1 x2 x3 x4 x5 x6 x7 - let fromInt x0 = Word64.fromInt x0 - let notb x0 = Word64.notb x0 - let orb x0 x1 = Word64.orb x0 x1 - let ror x0 x1 = Word64.ror x0 x1 - let toInt x0 = Word64.toInt x0 - let toIntSigned x0 = Word64.toIntSigned x0 - let xorb x0 x1 = Word64.xorb x0 x1 - end;; - - module Word8 = struct - let (+) x0 x1 = Word8.(+) x0 x1 - let (-) x0 x1 = Word8.(-) x0 x1 - let (<) x0 x1 = Word8.(<) x0 x1 - let (<<) x0 x1 = Word8.(<<) x0 x1 - let (<=) x0 x1 = Word8.(<=) x0 x1 - let (=) x0 x1 = Word8.(=) x0 x1 - let (>) x0 x1 = Word8.(>) x0 x1 - let (>=) x0 x1 = Word8.(>=) x0 x1 - let (>>) x0 x1 = Word8.(>>) x0 x1 - let andb x0 x1 = Word8.andb x0 x1 - let fromInt x0 = Word8.fromInt x0 - let notb x0 = Word8.notb x0 - let orb x0 x1 = Word8.orb x0 x1 - let ror x0 x1 = Word8.ror x0 x1 - let toInt x0 = Word8.toInt x0 - let toIntSigned x0 = Word8.toIntSigned x0 - let xorb x0 x1 = Word8.xorb x0 x1 - end;; - - module Word8_array = struct - let array x0 x1 = Word8_array.array x0 x1 - let copy x0 x1 x2 x3 x4 = Word8_array.copy x0 x1 x2 x3 x4 - let copyVec x0 x1 x2 x3 x4 = Word8_array.copyVec x0 x1 x2 x3 x4 - let findi x0 x1 = Word8_array.findi x0 x1 - let length x0 = Word8_array.length x0 - let sub x0 x1 = Word8_array.sub x0 x1 - let substring x0 x1 x2 = Word8_array.substring x0 x1 x2 - let update x0 x1 x2 = Word8_array.update x0 x1 x2 - end;; - -end;; - -(* Module stubs to prevent direct CakeML API usage *) -(* Users must access these through the Cake module *) -(* Types are re-exported so that pretty printers still work *) - -module Alist = struct end;; -module Array = struct end;; -module Bool = struct end;; -module Char = struct end;; -module Command_line = struct end;; -module Double = struct - type double = Cake.Double.double -end;; -module Hashtable = struct - type ('a, 'b) hashtable = ('a, 'b) Cake.Hashtable.hashtable -end;; -module Int = struct end;; -module List = struct end;; -module Map = struct end;; -module Marshalling = struct end;; -module Option = struct end;; -module Pair = struct end;; -module Rat = struct - type rat = Cake.Rat.rat -end;; -module Runtime = struct end;; -module Set = struct end;; -module Sexp = struct end;; -module String = struct end;; -module Vector = struct end;; -module Word64 = struct end;; -module Word8 = struct end;; -module Word8_array = struct end;; - -(* End of generated section *) \ No newline at end of file diff --git a/hol_lib.ml b/hol_lib.ml index 5ee86b99..2270e999 100644 --- a/hol_lib.ml +++ b/hol_lib.ml @@ -20,7 +20,7 @@ open Hol_loader;; (* compatiblity layer. *) (* ------------------------------------------------------------------------- *) -loads "candle_insulate.ml";; (* Move most of CakeML to Cake module. *) +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. *) From 278d34faedcf5a88ac7fb20912a117d42f985125 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 23 Mar 2026 16:01:06 +0800 Subject: [PATCH 74/79] Various adjustments --- build-instructions.sh | 2 +- candle-regression.py | 15 +++++++++------ candle_ocaml.ml | 2 +- test.sh | 7 +++++++ 4 files changed, 18 insertions(+), 8 deletions(-) create mode 100755 test.sh diff --git a/build-instructions.sh b/build-instructions.sh index 09deca95..949c7c01 100755 --- a/build-instructions.sh +++ b/build-instructions.sh @@ -1,7 +1,7 @@ #!/bin/sh # 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 diff --git a/candle-regression.py b/candle-regression.py index be8b145b..f36f7844 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -118,6 +118,9 @@ def _check_boot(self): 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([ @@ -140,15 +143,15 @@ def _check_output(self, timeout=600): case 1: self.last_val = self._get_match(1) case 2 | 3 | 4: - raise LoadFailure(f"{self._get_match(1)} [while loading: {' > '.join(self.load_stack)}]") + 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("Timeout waiting for output") + raise LoadFailure(f"Timeout waiting for output {self.load_stack_str()}") case 7: - raise LoadFailure("Process exited unexpectedly") + raise LoadFailure(f"Process exited unexpectedly {self.load_stack_str()}") case _: assert False, "Unreachable: Did you add a new case in _check_output?" @@ -307,7 +310,7 @@ def run_test(self, name): elapsed = time.perf_counter() - start err = str(e) if repl.load_stack: - err += f" [while loading: {' > '.join(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): @@ -321,7 +324,7 @@ def run_test(self, name): elapsed = time.perf_counter() - start err = "Timeout" if repl.load_stack: - err += f" [while loading: {' > '.join(repl.load_stack)}]" + err += f" {repl.load_stack_str()}" if repl.last_val: err += f" (last val: {repl.last_val})" else: @@ -335,7 +338,7 @@ def run_test(self, name): elapsed = time.perf_counter() - start err = str(e) if repl.load_stack: - err += f" [while loading: {' > '.join(repl.load_stack)}]" + err += f" {repl.load_stack_str()}" if repl.last_val: err += f" (last val: {repl.last_val})" else: diff --git a/candle_ocaml.ml b/candle_ocaml.ml index e0b38b53..e3d4e932 100644 --- a/candle_ocaml.ml +++ b/candle_ocaml.ml @@ -28,7 +28,7 @@ let close_in fd = Text_io.closeIn fd;; let close_out fd = Text_io.closeOut fd;; let input_line fd = - match Text_io.inputLine '\n' fd with + match Text_io.inputLine fd with | Some l -> l | None -> raise End_of_file ;; diff --git a/test.sh b/test.sh new file mode 100755 index 00000000..2746dcf3 --- /dev/null +++ b/test.sh @@ -0,0 +1,7 @@ +#!/bin/bash + +# Set up Candle +./build-instructions.sh + +# Run regression suite +python candle-regression.py \ No newline at end of file From 61c98d117bd715eac4dca0ada25454077ba4f62a Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 23 Mar 2026 16:13:40 +0800 Subject: [PATCH 75/79] Add GitHub regression --- .github/workflows/regression-tests.yml | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 .github/workflows/regression-tests.yml 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 From 7e523fe96694bf0cc2bbc17cd08058a5b51742a2 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 23 Mar 2026 16:22:19 +0800 Subject: [PATCH 76/79] Remove some failing tests for now --- candle-regression.py | 2 -- 1 file changed, 2 deletions(-) diff --git a/candle-regression.py b/candle-regression.py index f36f7844..8a7a3ea7 100644 --- a/candle-regression.py +++ b/candle-regression.py @@ -53,8 +53,6 @@ class TestResult: "100/lhopital", "100/stirling", "100/liouville", - "100/thales", - "100/desargues", ] From 482299c678c674665d481b89863a5fc68282d324 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 23 Mar 2026 17:07:13 +0800 Subject: [PATCH 77/79] Make bash behavior more strict --- test.sh | 1 + 1 file changed, 1 insertion(+) diff --git a/test.sh b/test.sh index 2746dcf3..dd3d64a8 100755 --- a/test.sh +++ b/test.sh @@ -1,4 +1,5 @@ #!/bin/bash +set -euo pipefail # Set up Candle ./build-instructions.sh From babed679d46eb6ed62aeb7a962c8ddc294327560 Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 23 Mar 2026 17:09:08 +0800 Subject: [PATCH 78/79] Make build-instructions.sh more strict --- build-instructions.sh | 1 + 1 file changed, 1 insertion(+) diff --git a/build-instructions.sh b/build-instructions.sh index 949c7c01..2ff1cc03 100755 --- a/build-instructions.sh +++ b/build-instructions.sh @@ -1,4 +1,5 @@ #!/bin/sh +set -euo pipefail # Get the 64-bit CakeML compiler from here: #curl -OL https://cakeml.org/regression/artefacts/3149/cake-x64-64.tar.gz From 85e67445780ea5cad8f9ff9488c2bf9dbe1d9efd Mon Sep 17 00:00:00 2001 From: Daniel Nezamabadi <55559979+dnezam@users.noreply.github.com> Date: Mon, 23 Mar 2026 17:09:59 +0800 Subject: [PATCH 79/79] Use bash --- build-instructions.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-instructions.sh b/build-instructions.sh index 2ff1cc03..0ca1b038 100755 --- a/build-instructions.sh +++ b/build-instructions.sh @@ -1,4 +1,4 @@ -#!/bin/sh +#!/bin/bash set -euo pipefail # Get the 64-bit CakeML compiler from here: