(*
  File: Topology.thy
  Author: Bohua Zhan

  Basics of topological spaces.
*)

theory Topology
  imports Auto2_FOL.Morphism Auto2_FOL.BigSet
begin

section \<open>Topological structure\<close>

definition "open_sets_name = succ(\<emptyset>)"
definition "open_sets(X) = graph_eval(X, open_sets_name)"
setup {* add_field_data (@{term open_sets_name}, @{term open_sets}) *}

definition is_open :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite_bidir]:
  "is_open(X,A) \<longleftrightarrow> A \<in> open_sets(X)"

definition is_top_space_raw :: "i \<Rightarrow> o" where [rewrite]:
  "is_top_space_raw(X) \<longleftrightarrow> open_sets(X) \<subseteq> Pow(carrier(X))"

lemma is_top_space_rawD [forward]: "is_top_space_raw(X) \<Longrightarrow> is_open(X,A) \<Longrightarrow> A \<subseteq> carrier(X)" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_top_space_raw_def} *}

definition top_space_form :: "i \<Rightarrow> o" where [rewrite]:
  "top_space_form(X) \<longleftrightarrow> is_top_space_raw(X) \<and> is_func_graph(X,{carrier_name,open_sets_name})"

lemma top_space_form_to_raw [forward]: "top_space_form(X) \<Longrightarrow> is_top_space_raw(X)" by auto2

(* Space of all topological structures on S *)
definition raw_top_spaces :: "i \<Rightarrow> i" where [rewrite]:
  "raw_top_spaces(S) = {Struct({\<langle>carrier_name,S\<rangle>, \<langle>open_sets_name,T\<rangle>}). T\<in>Pow(Pow(S))}"

lemma raw_top_spacesD [forward]:
  "X \<in> raw_top_spaces(S) \<Longrightarrow> top_space_form(X) \<and> carrier(X) = S" by auto2

lemma raw_top_spacesI [resolve]:
  "top_space_form(X) \<Longrightarrow> X \<in> raw_top_spaces(carrier(X))"
@proof @have "X = Struct({\<langle>carrier_name,carrier(X)\<rangle>, \<langle>open_sets_name,open_sets(X)\<rangle>})" @qed

definition Top :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "Top(S,T) = Struct({\<langle>carrier_name,S\<rangle>, \<langle>open_sets_name,T\<rangle>})"
setup {* add_prfstep_check_req ("Top(S,T)", "T \<subseteq> Pow(S)") *}

lemma Top_is_top_space_raw [typing]: "T \<subseteq> Pow(S) \<Longrightarrow> Top(S,T) \<in> raw_top_spaces(S)" by auto2

lemma eval_Top [rewrite]: "is_open(Top(S,T),A) \<longleftrightarrow> A \<in> T" by auto2
lemma open_sets_Top: "open_sets(Top(S,T)) = T" by auto2
setup {* add_forward_prfstep_cond @{thm open_sets_Top} [with_term "Top(?S,?T)"] *}

lemma top_space_form_eq [backward]:
  "top_space_form(X) \<Longrightarrow> top_space_form(Y) \<Longrightarrow> carrier(X) = carrier(Y) \<Longrightarrow>
   \<forall>U. is_open(X,U) \<longleftrightarrow> is_open(Y,U) \<Longrightarrow> X = Y" by auto2

setup {* fold del_prfstep_thm [
  @{thm top_space_form_def}, @{thm raw_top_spaces_def}, @{thm Top_def}, @{thm is_open_def}] *}
setup {* add_rewrite_rule_back @{thm is_open_def} *}
setup {* add_rewrite_rule_cond @{thm is_open_def} [with_term "open_sets(?X)"] *}

section \<open>Definition of a topological space\<close>

definition union_closed :: "i \<Rightarrow> o" where [rewrite]:
  "union_closed(X) \<longleftrightarrow> (\<forall>C. (\<forall>x\<in>source(C). is_open(X,C`x)) \<longrightarrow> is_open(X,\<Union>x\<in>source(C).C`x))"

lemma union_closedD1 [backward]:
  "union_closed(X) \<Longrightarrow> \<forall>U\<in>C. is_open(X,U) \<Longrightarrow> is_open(X,\<Union>C)"
@proof
  @let "F = Tup(C, \<lambda>x. x)" @have "(\<Union>C) = (\<Union>x\<in>source(F). F`x)"
@qed

lemma union_closedD2 [backward]:
  "union_closed(X) \<Longrightarrow> \<forall>a\<in>I. is_open(X,C(a)) \<Longrightarrow> is_open(X,\<Union>a\<in>I. C(a))"
@proof @have "(\<Union>a\<in>I. C(a)) = \<Union>{C(a). a\<in>I}" @qed

lemma union_closedI [backward]:
  "\<forall>C. (\<forall>x\<in>source(C). is_open(X,C`x)) \<longrightarrow> is_open(X,\<Union>x\<in>source(C).C`x) \<Longrightarrow> union_closed(X)" by auto2
setup {* del_prfstep_thm @{thm union_closed_def} *}

definition finite_inter_closed :: "i \<Rightarrow> o" where [rewrite]:
  "finite_inter_closed(X) \<longleftrightarrow> (\<forall>U V. is_open(X,U) \<longrightarrow> is_open(X,V) \<longrightarrow> is_open(X,U \<inter> V))"

lemma finite_inter_closedD [backward1,backward2]:
  "finite_inter_closed(X) \<Longrightarrow> is_open(X,U) \<Longrightarrow> is_open(X,V) \<Longrightarrow> is_open(X,U \<inter> V)" by auto2
setup {* del_prfstep_thm_eqforward @{thm finite_inter_closed_def} *}

definition is_top_space :: "i \<Rightarrow> o" where [rewrite]:
  "is_top_space(X) \<longleftrightarrow> (is_top_space_raw(X) \<and> is_open(X,\<emptyset>) \<and> is_open(X,carrier(X)) \<and>
                        union_closed(X) \<and> finite_inter_closed(X))"

lemma is_top_spaceD1 [forward]:
  "is_top_space(X) \<Longrightarrow> is_top_space_raw(X)"
  "is_top_space(X) \<Longrightarrow> union_closed(X)"
  "is_top_space(X) \<Longrightarrow> finite_inter_closed(X)" by auto2+

lemma is_top_spaceD2 [resolve]:
  "is_top_space(X) \<Longrightarrow> is_open(X,\<emptyset>)"
  "is_top_space(X) \<Longrightarrow> is_open(X,carrier(X))" by auto2+
setup {* del_prfstep_thm_eqforward @{thm is_top_space_def} *}

section \<open>Finer topologies\<close>

definition top_space_finer :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "top_space_finer(X,Y) \<longleftrightarrow> is_top_space_raw(X) \<and> is_top_space_raw(Y) \<and>
     carrier(X) = carrier(Y) \<and> open_sets(Y) \<subseteq> open_sets(X)"
setup {* register_wellform_data ("top_space_finer(X,Y)", ["carrier(X) = carrier(Y)"]) *}

definition eq_str_top :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "eq_str_top(X,Y) \<longleftrightarrow> is_top_space_raw(X) \<and> is_top_space_raw(Y) \<and>
     carrier(X) = carrier(Y) \<and> open_sets(X) = open_sets(Y)"
setup {* register_wellform_data ("eq_str_top(X,Y)", ["carrier(X) = carrier(Y)"]) *}

lemma eq_str_top_from_finer [forward]:
  "top_space_finer(X,Y) \<Longrightarrow> top_space_finer(Y,X) \<Longrightarrow> eq_str_top(X,Y)" by auto2

lemma topoloogy_eq_from_eq_str [forward]:
  "top_space_form(X) \<Longrightarrow> top_space_form(Y) \<Longrightarrow> eq_str_top(X,Y) \<Longrightarrow> X = Y" by auto2

lemma eq_str_top_is_top_space [forward]:
  "is_top_space(X) \<Longrightarrow> eq_str_top(X,Y) \<Longrightarrow> is_top_space(Y)" by auto2

lemma eq_str_top_sym [forward]:
  "eq_str_top(X,Y) \<Longrightarrow> eq_str_top(Y,X)" by auto2

section \<open>Constructing a topological space from a basis\<close>

definition collection_is_basis :: "i \<Rightarrow> o" where [rewrite]:
  "collection_is_basis(\<B>) \<longleftrightarrow> (\<forall>U\<in>\<B>. \<forall>V\<in>\<B>. \<forall>x\<in>U\<inter>V. \<exists>W\<in>\<B>. x\<in>W \<and> W\<subseteq>U\<inter>V)"

lemma collection_is_basisD [backward2]:
  "collection_is_basis(\<B>) \<Longrightarrow> x \<in> U \<inter> V \<Longrightarrow> U \<in> \<B> \<Longrightarrow> V \<in> \<B> \<Longrightarrow> \<exists>W\<in>\<B>. x \<in> W \<and> W \<subseteq> U \<inter> V" by auto2

lemma collection_is_basisI [forward]:
  "\<forall>U\<in>\<B>. \<forall>V\<in>\<B>. \<forall>x\<in>U\<inter>V. \<exists>W\<in>\<B>. x\<in>W \<and> W\<subseteq>U\<inter>V \<Longrightarrow> collection_is_basis(\<B>)" by auto2

lemma collection_is_basisI2 [forward]:
  "\<forall>U\<in>\<B>. \<forall>V\<in>\<B>. U \<inter> V \<in> \<B> \<Longrightarrow> collection_is_basis(\<B>)" by auto2

lemma top_all_open_sets_is_basis [forward]:
  "is_top_space(X) \<Longrightarrow> collection_is_basis(open_sets(X))" by auto2

setup {* del_prfstep_thm @{thm collection_is_basis_def} *}

definition top_from_basis :: "i \<Rightarrow> i" where [rewrite]:
  "top_from_basis(\<B>) = {\<Union>S. S\<in>Pow(\<B>)}"

definition top_has_basis :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "top_has_basis(X,\<B>) \<longleftrightarrow> (collection_is_basis(\<B>) \<and> carrier(X) = \<Union>\<B> \<and> open_sets(X) = top_from_basis(\<B>))"

lemma top_from_basis_type [backward]:
  "carrier(X) = \<Union>\<B> \<Longrightarrow> top_from_basis(\<B>) \<subseteq> Pow(carrier(X))" by auto2

lemma top_has_basisI [backward1]:
  "collection_is_basis(\<B>) \<Longrightarrow> carrier(X) = \<Union>\<B> \<Longrightarrow> open_sets(X) = top_from_basis(\<B>) \<Longrightarrow>
   top_has_basis(X,\<B>)" by auto2

lemma top_has_basisD1 [forward]:
  "top_has_basis(X,\<B>) \<Longrightarrow> collection_is_basis(\<B>)" by auto2

lemma top_has_basisD2 [rewrite_back]:
  "top_has_basis(X,\<B>) \<Longrightarrow> carrier(X) = \<Union>\<B>" by auto2

lemma top_has_basis_is_openE [backward2]:
  "top_has_basis(X,\<B>) \<Longrightarrow> is_open(X,U) \<Longrightarrow> \<exists>S\<in>Pow(\<B>). U = \<Union>S" by auto2

lemma top_has_basis_is_openI [forward]:
  "top_has_basis(X,\<B>) \<Longrightarrow> S \<in> Pow(\<B>) \<Longrightarrow> is_open(X, \<Union>S)" by auto2

lemma top_has_basis_is_openE' [forward]:
  "top_has_basis(X,\<B>) \<Longrightarrow> is_open(X,U) \<Longrightarrow> \<forall>x\<in>U. \<exists>B\<in>\<B>. x \<in> B \<and> B \<subseteq> U" by auto2

lemma top_has_basis_is_openI' [backward2]:
  "top_has_basis(X,\<B>) \<Longrightarrow> \<forall>x\<in>U. \<exists>B\<in>\<B>. x \<in> B \<and> B \<subseteq> U \<Longrightarrow> is_open(X,U)"
@proof
  @case "\<forall>x\<in>U. \<exists>B\<in>\<B>. x \<in> B \<and> B \<subseteq> U" @with
    @let "S = {(SOME B\<in>\<B>. x \<in> B \<and> B \<subseteq> U). x\<in>U}" @have "\<Union>S = U" @end
@qed

lemma top_has_basis_id [resolve]:
  "is_top_space(X) \<Longrightarrow> top_has_basis(X, open_sets(X))"
@proof @have (@rule) "\<forall>U\<in>open_sets(X). U = \<Union>{U}" @qed

lemma top_has_basis_eq_str_top [rewrite]:
  "eq_str_top(X,Y) \<Longrightarrow> top_has_basis(X,\<B>) \<longleftrightarrow> top_has_basis(Y,\<B>)" by auto2

lemma top_has_basisI' [backward1]:
  "is_top_space(X) \<Longrightarrow> \<B> \<subseteq> open_sets(X) \<Longrightarrow> \<forall>U\<in>open_sets(X). \<forall>x\<in>U. \<exists>C\<in>\<B>. x \<in> C \<and> C \<subseteq> U \<Longrightarrow>
   top_has_basis(X,\<B>)"
@proof
  @have "collection_is_basis(\<B>)" @with
    @have "\<forall>U\<in>\<B>. \<forall>V\<in>\<B>. \<forall>x\<in>U\<inter>V. \<exists>W\<in>\<B>. x\<in>W \<and> W\<subseteq>U\<inter>V" @with
      @have "is_open(X,U \<inter> V)" @end @end
  @have "carrier(X) = \<Union>\<B>" @with @have "is_open(X,carrier(X))" @end
  @have "\<forall>U\<in>open_sets(X). U \<in> {\<Union>S. S\<in>Pow(\<B>)}" @with
    @let "S = {(SOME B\<in>\<B>. x \<in> B \<and> B \<subseteq> U). x\<in>U}" @have "\<Union>S = U" @end
@qed

lemma topology_basis_eq [forward]:
  "top_space_form(X) \<Longrightarrow> top_space_form(Y) \<Longrightarrow> top_has_basis(X,\<B>) \<Longrightarrow> top_has_basis(Y,\<B>) \<Longrightarrow> X = Y"
  by auto2

lemma topology_basis_finer [backward1]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> carrier(X) = carrier(Y) \<Longrightarrow> top_has_basis(Y,\<B>) \<Longrightarrow>
   \<forall>U\<in>\<B>. is_open(X,U) \<Longrightarrow> top_space_finer(X,Y)" by auto2

setup {* del_prfstep_thm @{thm top_has_basis_def} *}

lemma top_has_basis_finite_inter_closed [forward]:
  "top_has_basis(X,\<B>) \<Longrightarrow> finite_inter_closed(X)"
@proof
  @have "\<forall>U V. is_open(X,U) \<longrightarrow> is_open(X,V) \<longrightarrow> is_open(X,U \<inter> V)" @with
    @have "\<forall>x\<in>U\<inter>V. \<exists>B\<in>\<B>. x \<in> B \<and> B \<subseteq> U\<inter>V" @with
      @obtain "B1\<in>\<B>" where "x \<in> B1 \<and> B1 \<subseteq> U"
      @obtain "B2\<in>\<B>" where "x \<in> B2 \<and> B2 \<subseteq> V"
      @have "x \<in> B1 \<inter> B2"
      @obtain "W\<in>\<B>" where "x \<in> W \<and> W \<subseteq> B1 \<inter> B2" @end @end
@qed

lemma top_has_basis_is_topology [forward]:
  "is_top_space_raw(X) \<Longrightarrow> top_has_basis(X,\<B>) \<Longrightarrow> is_top_space(X)"
@proof @have "carrier(X) = \<Union>\<B>" @qed

lemma top_has_basis_is_open_trivial [forward]:
  "top_has_basis(X,\<B>) \<Longrightarrow> S \<in> \<B> \<Longrightarrow> is_open(X,S)" by auto2

setup {* add_gen_prfstep ("Top_from_basis_case",
  [WithTerm @{term_pat "Top(?S,top_from_basis(?B))"},
   CreateConcl @{term_pat "top_has_basis(Top(?S,top_from_basis(?B)),?B)"}]) *}

section \<open>Open and closed sets\<close>

lemma open_union_pair [backward1,backward2]:
  "is_top_space(X) \<Longrightarrow> is_open(X,U) \<Longrightarrow> is_open(X,V) \<Longrightarrow> is_open(X,U \<union> V)"
@proof @have "U \<union> V = \<Union>{U,V}" @qed

definition is_closed :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "is_closed(X,A) \<longleftrightarrow> (A \<subseteq> carrier(X) \<and> is_open(X, carrier(X) \<midarrow> A))"

definition closed_sets :: "i \<Rightarrow> i" where [rewrite]:
  "closed_sets(X) = {A \<in> Pow(carrier(X)). is_closed(X,A)}"

lemma closed_sets_iff [rewrite_back]: "is_closed(X,A) \<longleftrightarrow> A \<in> closed_sets(X)" by auto2
setup {* add_rewrite_rule_cond @{thm closed_sets_iff} [with_term "closed_sets(?X)"] *}
setup {* del_prfstep_thm @{thm closed_sets_def} *}

lemma is_closed_empty [resolve]:
  "is_top_space(X) \<Longrightarrow> is_closed(X,\<emptyset>)"
@proof  @have "\<emptyset> = carrier(X) \<midarrow> carrier(X)" @qed

lemma is_closed_full [resolve]:
  "is_top_space(X) \<Longrightarrow> is_closed(X,carrier(X))"
@proof  @have "\<emptyset> = carrier(X) \<midarrow> carrier(X)" @qed

lemma is_open_compl [rewrite]:
  "is_top_space(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> is_open(X, carrier(X) \<midarrow> A) \<longleftrightarrow> is_closed(X,A)" by auto2

lemma is_closed_compl [rewrite]:
  "is_top_space(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> is_closed(X, carrier(X) \<midarrow> A) \<longleftrightarrow> is_open(X,A)" by auto2

lemma closed_union_pair [backward1,backward2]:
  "is_top_space(X) \<Longrightarrow> is_closed(X,A) \<Longrightarrow> is_closed(X,B) \<Longrightarrow> is_closed(X,A \<union> B)" by auto2

lemma closed_inter_pair [backward1,backward2]:
  "is_top_space(X) \<Longrightarrow> is_closed(X,A) \<Longrightarrow> is_closed(X,B) \<Longrightarrow> is_closed(X,A \<inter> B)" by auto2

lemma closed_inter1 [backward]:
  "is_top_space(X) \<Longrightarrow> I \<noteq> \<emptyset> \<Longrightarrow> \<forall>a\<in>I. is_closed(X,C(a)) \<Longrightarrow> is_closed(X,\<Inter>a\<in>I. C(a))" by auto2

lemma closed_inter2 [backward]:
  "is_top_space(X) \<Longrightarrow> C \<noteq> \<emptyset> \<Longrightarrow> \<forall>A\<in>C. is_closed(X,A) \<Longrightarrow> is_closed(X,\<Inter>C)"
@proof
  @let "F = Tup(C, \<lambda>x. x)" @have "(\<Inter>C) = (\<Inter>x\<in>source(F). F`x)"
@qed

section \<open>Empty topological space\<close>

definition empty_top_space :: i where [rewrite]:
  "empty_top_space = Top(\<emptyset>,{\<emptyset>})"

lemma empty_top_space_type [typing]: "empty_top_space \<in> raw_top_spaces(\<emptyset>)" by auto2
lemma empty_is_top_space [forward]: "is_top_space(empty_top_space)" by auto2
lemma top_space_on_empty [forward]:
  "top_space_form(X) \<Longrightarrow> is_top_space(X) \<Longrightarrow> carrier(X) = \<emptyset> \<Longrightarrow> X = empty_top_space" by auto2
setup {* del_prfstep_thm @{thm empty_top_space_def} *}

section \<open>Subspace topology\<close>

definition subspace :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "subspace(X,Y) = Top(Y, {Y \<inter> U. U \<in> open_sets(X)})"
setup {* register_wellform_data ("subspace(X,Y)", ["Y \<subseteq> carrier(X)"]) *}
setup {* add_prfstep_check_req ("subspace(X,Y)", "Y \<subseteq> carrier(X)") *}

lemma subspace_type [typing]: "subspace(X,Y) \<in> raw_top_spaces(Y)" by auto2

lemma subspace_is_openD [resolve]:
  "is_open(subspace(X,Y),U) \<Longrightarrow> \<exists>V\<in>open_sets(X). U = Y \<inter> V" by auto2

lemma subspace_is_openI [backward]:
  "is_open(X,U) \<Longrightarrow> is_open(subspace(X,Y), Y \<inter> U)" by auto2
setup {* del_prfstep_thm @{thm subspace_def} *}

lemma subspace_is_top_space:
  "is_top_space(\<X>) \<Longrightarrow> Y \<subseteq> carrier(\<X>) \<Longrightarrow> is_top_space(subspace(\<X>,Y))"
@proof
  @let "\<Y> = subspace(\<X>,Y)"
  @have "\<emptyset> = Y \<inter> \<emptyset>" @have "Y = Y \<inter> carrier(\<X>)"
  @have "\<forall>C. (\<forall>x\<in>source(C). is_open(\<Y>,C`x)) \<longrightarrow> is_open(\<Y>,\<Union>x\<in>source(C). C`x)" @with
    @let "C' = Tup(source(C), \<lambda>x. (SOME V\<in>open_sets(\<X>). C`x = Y \<inter> V))"
    @have "\<forall>x\<in>source(C). C`x = Y \<inter> C'`x"
    @have "(Y \<inter> (\<Union>x\<in>source(C).C'`x)) = (\<Union>x\<in>source(C). C`x)" @end
  @have "\<forall>U V. is_open(\<Y>,U) \<longrightarrow> is_open(\<Y>,V) \<longrightarrow> is_open(\<Y>,U \<inter> V)" @with
    @obtain "U'\<in>open_sets(\<X>)" where "U = Y \<inter> U'"
    @obtain "V'\<in>open_sets(\<X>)" where "V = Y \<inter> V'"
    @have "Y \<inter> (U' \<inter> V') = U \<inter> V" @end
@qed
setup {* add_forward_prfstep_cond @{thm subspace_is_top_space} [with_term "subspace(?\<X>,?Y)"] *}

lemma subspace_is_closedD [resolve]:
  "is_top_space(\<X>) \<Longrightarrow> X = carrier(\<X>) \<Longrightarrow> Y \<subseteq> X \<Longrightarrow> is_closed(subspace(\<X>,Y),A) \<Longrightarrow>
   \<exists>B\<in>closed_sets(\<X>). A = Y \<inter> B"
@proof
  @obtain "U\<in>open_sets(\<X>)" where "Y \<midarrow> A = Y \<inter> U"
  @have "A = Y \<inter> (X \<midarrow> U)" @with
    @have "Y \<inter> (X \<midarrow> U) = Y \<inter> X \<midarrow> Y \<inter> U" @end
@qed

lemma subspace_is_closedI [backward]:
  "is_top_space(\<X>) \<Longrightarrow> X = carrier(\<X>) \<Longrightarrow> Y \<subseteq> X \<Longrightarrow> is_closed(\<X>,C) \<Longrightarrow> is_closed(subspace(\<X>,Y), Y \<inter> C)"
@proof
  @have "is_open(subspace(\<X>,Y), Y \<inter> (X \<midarrow> C))"
  @have "Y \<inter> (X \<midarrow> C) = Y \<midarrow> (Y \<inter> C)"
@qed

(* Open subspaces *)
lemma open_subspace_is_open [rewrite]:
  "is_top_space(X) \<Longrightarrow> is_open(X,Y) \<Longrightarrow> U \<subseteq> carrier(subspace(X,Y)) \<Longrightarrow>
   is_open(subspace(X,Y),U) \<longleftrightarrow> is_open(X,U)"
@proof @contradiction @obtain "V\<in>open_sets(X)" where "U = Y \<inter> V" @qed

(* Closed subspaces *)
lemma closed_subspace_is_closed [rewrite]:
  "is_top_space(X) \<Longrightarrow> is_closed(X,Y) \<Longrightarrow> A \<subseteq> carrier(subspace(X,Y)) \<Longrightarrow>
   is_closed(subspace(X,Y),A) \<longleftrightarrow> is_closed(X,A)"
@proof @contradiction @obtain "B\<in>closed_sets(X)" where "A = Y \<inter> B" @qed

lemma subspace_basis [backward]:
  "is_top_space(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> top_has_basis(X,\<B>) \<Longrightarrow> top_has_basis(subspace(X,A), {A \<inter> U. U \<in> \<B>})"
@proof
  @let "\<C> = {A \<inter> U. U \<in> \<B>}"
  @have "\<forall>U\<in>open_sets(subspace(X,A)). \<forall>x\<in>U. \<exists>C\<in>\<C>. x \<in> C \<and> C \<subseteq> U" @with
    @obtain "V\<in>open_sets(X)" where "U = A \<inter> V"
    @obtain "B\<in>\<B>" where "x \<in> B \<and> B \<subseteq> V"
    @have "x \<in> A \<inter> B \<and> A \<inter> B \<subseteq> U" @end
@qed

lemma subspace_id [rewrite]:
  "top_space_form(X) \<Longrightarrow> is_top_space(X) \<Longrightarrow> subspace(X,carrier(X)) = X"
@proof
  @have "top_has_basis(X, open_sets(X))"
  @have "top_has_basis(subspace(X,carrier(X)), {carrier(X) \<inter> U. U \<in> open_sets(X)})"
@qed

lemma subspace_trans [rewrite]:
  "is_top_space(X) \<Longrightarrow> A \<subseteq> carrier(X) \<Longrightarrow> B \<subseteq> carrier(subspace(X,A)) \<Longrightarrow>
   subspace(subspace(X,A),B) = subspace(X,B)"
@proof
  @let "\<A> = {A \<inter> U. U \<in> open_sets(X)}"
  @let "\<B> = {B \<inter> U. U \<in> open_sets(X)}"
  @have "top_has_basis(subspace(X,A), \<A>)"
  @have "top_has_basis(subspace(X,B), \<B>)"
  @have "top_has_basis(subspace(subspace(X,A),B), {B \<inter> U. U \<in> \<A>})"
  @have "\<B> = {B \<inter> U. U \<in> \<A>}" @with
    @have (@rule) "\<forall>U\<in>open_sets(X). B \<inter> U = B \<inter> (A \<inter> U)" @end
@qed

section \<open>Neighborhoods\<close>

definition neighs :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "neighs(X,x) = {U \<in> open_sets(X). x \<in> U}"
setup {* register_wellform_data ("neighs(X,x)", ["x \<in>. X"]) *}

lemma neighsI [typing2,backward]: "x \<in> U \<Longrightarrow> is_open(X,U) \<Longrightarrow> U \<in> neighs(X,x)" by auto2
lemma neighsE [forward]: "U \<in> neighs(X,x) \<Longrightarrow> x \<in> U \<and> is_open(X,U)" by auto2
setup {* del_prfstep_thm @{thm neighs_def} *}

lemma top_space_is_open_local [backward1]:
  "is_top_space(X) \<Longrightarrow> V \<subseteq> carrier(X) \<Longrightarrow> \<forall>x\<in>V. \<exists>U\<in>neighs(X,x). U \<subseteq> V \<Longrightarrow> is_open(X,V)"
@proof
  @let "C = Tup(V, \<lambda>x. SOME U\<in>neighs(X,x). U \<subseteq> V)"
  @have "V = (\<Union>x\<in>V. C`x)"
@qed

section \<open>Continuous functions\<close>

definition is_morphism_top :: "i \<Rightarrow> o" where [rewrite]:
  "is_morphism_top(f) \<longleftrightarrow> (is_morphism(f) \<and> is_top_space(source_str(f)) \<and> is_top_space(target_str(f)))"

lemma is_morphism_topD [forward]:
  "is_morphism_top(f) \<Longrightarrow> is_morphism(f)"
  "is_morphism_top(f) \<Longrightarrow> is_top_space(source_str(f))"
  "is_morphism_top(f) \<Longrightarrow> is_top_space(target_str(f))" by auto2+

lemma is_morphism_topI [forward]:
  "is_morphism(f) \<Longrightarrow> is_top_space(source_str(f)) \<Longrightarrow> is_top_space(target_str(f)) \<Longrightarrow> is_morphism_top(f)" by auto2
setup {* del_prfstep_thm @{thm is_morphism_top_def} *}

definition continuous :: "i \<Rightarrow> o" where [rewrite]:
  "continuous(f) \<longleftrightarrow> (is_morphism_top(f) \<and>
                      (\<forall>V\<in>open_sets(target_str(f)). is_open(source_str(f), f -`` V)))"

lemma continuousD1 [forward]:
  "continuous(f) \<Longrightarrow> is_morphism_top(f)" by auto2

lemma continuousD2 [backward]:
  "continuous(f) \<Longrightarrow> is_open(target_str(f),V) \<Longrightarrow> is_open(source_str(f),f-``V)" by auto2
setup {* add_forward_prfstep_cond @{thm continuousD2} [with_term "?f -`` ?V"] *}

lemma continuousI [forward]:
  "is_morphism_top(f) \<Longrightarrow> X = source_str(f) \<Longrightarrow> Y = target_str(f) \<Longrightarrow>
   \<forall>V\<in>open_sets(Y). is_open(X, f -`` V) \<Longrightarrow> continuous(f)" by auto2

definition continuous_fun_space :: "i \<Rightarrow> i \<Rightarrow> i" (infix "\<rightharpoonup>\<^sub>T" 60) where [rewrite]:
  "X \<rightharpoonup>\<^sub>T Y = {f \<in> X \<rightharpoonup> Y. continuous(f)}"

lemma continuous_fun_spaceD [forward]:
  "f \<in> X \<rightharpoonup>\<^sub>T Y \<Longrightarrow> f \<in> X \<rightharpoonup> Y \<and> continuous(f)" by auto2

lemma continuous_fun_spaceI [typing, backward]:
  "mor_form(f) \<Longrightarrow> continuous(f) \<Longrightarrow> f \<in> source_str(f) \<rightharpoonup>\<^sub>T target_str(f)" by auto2
setup {* del_prfstep_thm @{thm continuous_fun_space_def} *}

lemma id_continuous [typing]: "is_top_space(X) \<Longrightarrow> id_mor(X) \<in> X \<rightharpoonup>\<^sub>T X" by auto2

lemma inj_continuous [typing]:
  "is_top_space(X) \<Longrightarrow> Y \<subseteq> carrier(X) \<Longrightarrow> inj_mor(subspace(X,Y),X) \<in> subspace(X,Y) \<rightharpoonup>\<^sub>T X" by auto2

lemma comp_continuous:
  "continuous(f) \<Longrightarrow> continuous(g) \<Longrightarrow> target_str(f) = source_str(g) \<Longrightarrow> continuous(g \<circ>\<^sub>m f)" by auto2
setup {* add_forward_prfstep_cond @{thm comp_continuous} [with_term "?g \<circ>\<^sub>m ?f"] *}

lemma comp_continuous' [backward]:
  "Y = source_str(G) \<Longrightarrow> G \<in> Y \<rightharpoonup>\<^sub>T target_str(G) \<Longrightarrow> F = Mor(X,Y,\<lambda>x. f(x)) \<Longrightarrow> F \<in> X \<rightharpoonup>\<^sub>T Y \<Longrightarrow>
   continuous(Mor(X,target_str(G),\<lambda>x. G`(f(x))))"
@proof
  @have (@rule) "\<forall>x\<in>.X. F`x = f(x)"
  @have "Mor(X,target_str(G),\<lambda>x. G`(f(x))) = G \<circ>\<^sub>m F"
@qed

lemma comp_continuous'' [backward2]:
  "is_top_space(Z) \<Longrightarrow> A \<subseteq> carrier(Z) \<Longrightarrow> Y = source_str(G) \<Longrightarrow> target_str(G) = subspace(Z,A) \<Longrightarrow>
   F = Mor(X,Y,\<lambda>x. f(x)) \<Longrightarrow> G \<in> Y \<rightharpoonup>\<^sub>T subspace(Z,A) \<Longrightarrow> F \<in> X \<rightharpoonup>\<^sub>T Y \<Longrightarrow>
   continuous(Mor(X,Z,\<lambda>x. G`(f(x))))"
@proof
  @have (@rule) "\<forall>x\<in>.X. F`x = f(x)"
  @have "Mor(X,Z,\<lambda>x. G`(f(x))) = inj_mor(subspace(Z,A),Z) \<circ>\<^sub>m G \<circ>\<^sub>m F"
@qed
setup {* del_prfstep_thm @{thm continuous_def} *}

lemma continuousD_neighs [backward]:
  "continuous(f) \<Longrightarrow> X = source_str(f) \<Longrightarrow> x \<in>. X \<Longrightarrow> V \<in> neighs(target_str(f),f`x) \<Longrightarrow>
   \<exists>U\<in>neighs(X,x). f``U \<subseteq> V"
@proof @have "is_open(source_str(f), f -`` V)" @qed

lemma continuousI_neighs [forward]:
  "is_morphism_top(f) \<Longrightarrow> X = source_str(f) \<Longrightarrow> Y = target_str(f) \<Longrightarrow>
   \<forall>x\<in>.X. \<forall>V\<in>neighs(Y,f`x). \<exists>U\<in>neighs(X,x). f``U \<subseteq> V \<Longrightarrow> continuous(f)"
@proof
  @have "\<forall>V\<in>open_sets(Y). is_open(X,f-``V)" @with
    @have "\<forall>x\<in>f-``V. \<exists>U\<in>neighs(X,x). U \<subseteq> f-``V"
  @end
@qed

lemma continuousI_basis [forward]:
  "is_morphism_top(f) \<Longrightarrow> X = source_str(f) \<Longrightarrow> Y = target_str(f) \<Longrightarrow>
   top_has_basis(Y,\<B>) \<Longrightarrow> \<forall>V\<in>\<B>. is_open(X, f -`` V) \<Longrightarrow> continuous(f)"
@proof @have "\<forall>x\<in>.X. \<forall>V\<in>neighs(Y,f`x). \<exists>U\<in>neighs(X,x). f``U \<subseteq> V" @qed

lemma continuousD_closed [backward]:
  "continuous(f) \<Longrightarrow> is_closed(target_str(f),B) \<Longrightarrow> is_closed(source_str(f),f-``B)"
@proof @have "is_open(source_str(f), f -`` (target(f) \<midarrow> B))" @qed
setup {* add_forward_prfstep_cond @{thm continuousD_closed} [with_term "?f -`` ?B"] *}

lemma continuousI_closed [forward]:
  "is_morphism_top(f) \<Longrightarrow> X = source_str(f) \<Longrightarrow> Y = target_str(f) \<Longrightarrow>
   \<forall>B\<in>closed_sets(Y). is_closed(X, f -`` B) \<Longrightarrow> continuous(f)"
@proof
  @have "\<forall>V\<in>open_sets(Y). is_open(X,f-``V)" @with
    @have "is_closed(Y,target(f)\<midarrow>V)" @end
@qed

lemma const_continuous:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> y \<in>. Y \<Longrightarrow> const_mor(X,Y,y) \<in> X \<rightharpoonup>\<^sub>T Y"
@proof
  @have "\<forall>V\<in>open_sets(Y). is_open(X,const_mor(X,Y,y)-``V)" @with @case "y \<in> V" @end
@qed
setup {* add_forward_prfstep_cond @{thm const_continuous} [with_term "const_mor(?X,?Y,?y)"] *}

definition mor_restrict_top :: "i \<Rightarrow> i \<Rightarrow> i"  (infix "|\<^sub>T" 55) where [rewrite]:
  "f |\<^sub>T A = Mor(subspace(source_str(f),A),target_str(f),\<lambda>x. f`x)"
setup {* register_wellform_data ("f |\<^sub>T A", ["A \<subseteq> source(f)"]) *}
setup {* add_prfstep_check_req ("f |\<^sub>T A", "A \<subseteq> source(f)") *}

lemma mor_restrict_top_is_morphism [typing]:
  "is_morphism(f) \<Longrightarrow> X = source_str(f) \<Longrightarrow> A \<subseteq> source(f) \<Longrightarrow> f |\<^sub>T A \<in> subspace(X,A) \<rightharpoonup> target_str(f)" by auto2

lemma mor_restrict_top_is_continuous [typing]:
  "continuous(f) \<Longrightarrow> X = source_str(f) \<Longrightarrow> A \<subseteq> source(f) \<Longrightarrow> f |\<^sub>T A \<in> subspace(X,A) \<rightharpoonup>\<^sub>T target_str(f)"
@proof @have "f |\<^sub>T A = f \<circ>\<^sub>m inj_mor(subspace(X,A),X)" @qed

lemma mor_restrict_top_eval [rewrite]:
  "is_morphism(f) \<Longrightarrow> A \<subseteq> source(f) \<Longrightarrow> x \<in> source(f |\<^sub>T A) \<Longrightarrow> (f |\<^sub>T A) ` x = f ` x" by auto2
setup {* del_prfstep_thm @{thm mor_restrict_top_def} *}

lemma mor_restrict_top_vImage [rewrite]:
  "is_morphism(f) \<Longrightarrow> A \<subseteq> source(f) \<Longrightarrow> B \<subseteq> target(f) \<Longrightarrow> (f |\<^sub>T A) -`` B = A \<inter> (f -`` B)" by auto2

lemma mor_restrict_top_image [rewrite]:
  "is_morphism(f) \<Longrightarrow> A \<subseteq> source(f) \<Longrightarrow> image(f |\<^sub>T A) = f `` A"
@proof
  @have "\<forall>x\<in>f``A. x \<in> image(f |\<^sub>T A)" @with
    @obtain "y \<in> A" where "f`y = x"
    @have "(f |\<^sub>T A) ` y = x"
  @end
@qed

definition mor_restrict_image_top :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "mor_restrict_image_top(f,A) = Mor(source_str(f),subspace(target_str(f),A),\<lambda>x. f`x)"
setup {* register_wellform_data ("mor_restrict_image_top(f,A)", ["image(f) \<subseteq> A", "A \<subseteq> target(f)"]) *}
setup {* add_prfstep_check_req ("mor_restrict_image_top(f,A)", "image(f) \<subseteq> A \<and> A \<subseteq> target(f)") *}

lemma mor_restrict_image_top_is_continuous [typing]:
  "continuous(f) \<Longrightarrow> X = source_str(f) \<Longrightarrow> Y = target_str(f) \<Longrightarrow> image(f) \<subseteq> A \<Longrightarrow> A \<subseteq> target(f) \<Longrightarrow>
   Z = subspace(Y,A) \<Longrightarrow> mor_restrict_image_top(f,A) \<in> X \<rightharpoonup>\<^sub>T Z"
@proof
  @let "g = mor_restrict_image_top(f,A)"
  @have "\<forall>V\<in>open_sets(Z). is_open(X, g -`` V)" @with
    @obtain "U\<in>open_sets(Y)" where "V = A \<inter> U"
    @have "g -`` V = f -`` U" @end
@qed

lemma mor_restrict_image_top_eval [rewrite]:
  "is_morphism(f) \<Longrightarrow> g = mor_restrict_image_top(f,A) \<Longrightarrow> image(f) \<subseteq> A \<Longrightarrow>
   x \<in> source(g) \<Longrightarrow> g`x = f`x" by auto2
setup {* del_prfstep_thm @{thm mor_restrict_image_top_def} *}

lemma continuous_paste_open:
  "is_morphism_top(f) \<Longrightarrow> X = source_str(f) \<Longrightarrow> Y = target_str(f) \<Longrightarrow>
   carrier(X) = A \<union> B \<Longrightarrow> is_open(X,A) \<Longrightarrow> is_open(X,B) \<Longrightarrow>
   continuous(f |\<^sub>T A) \<Longrightarrow> continuous(f |\<^sub>T B) \<Longrightarrow> continuous(f)"
@proof
  @have "\<forall>V\<in>open_sets(Y). is_open(X, f -`` V)" @with
    @have "f -`` V = ((f |\<^sub>T A) -`` V) \<union> ((f |\<^sub>T B) -`` V)" @end
@qed

(* Pasting lemma *)
lemma continuous_paste_closed [backward2]:
  "is_morphism_top(f) \<Longrightarrow> X = source_str(f) \<Longrightarrow> Y = target_str(f) \<Longrightarrow>
   carrier(X) = A \<union> B \<Longrightarrow> is_closed(X,A) \<Longrightarrow> is_closed(X,B) \<Longrightarrow>
   continuous(f |\<^sub>T A) \<Longrightarrow> continuous(f |\<^sub>T B) \<Longrightarrow> continuous(f)"
@proof
  @have "\<forall>D\<in>closed_sets(Y). is_closed(X, f -`` D)" @with
    @have "f -`` D = ((f |\<^sub>T A) -`` D) \<union> ((f |\<^sub>T B) -`` D)" @end
@qed

definition glue_morphism :: "[i, i, i] \<Rightarrow> i" where [rewrite]:
  "glue_morphism(X,g,h) = Mor(X,target_str(g),\<lambda>x. if x\<in>source(g) then g`x else h`x)"
setup {* register_wellform_data ("glue_morphism(X,g,h)",
  ["carrier(X) = source(g) \<union> source(h)", "target_str(g) = target_str(h)"]) *}
setup {* add_prfstep_check_req ("glue_morphism(X,g,h)", "carrier(X) = source(g) \<union> source(h)") *}

lemma glue_is_morphism [typing]:
  "is_top_space(X) \<Longrightarrow> is_morphism(g) \<Longrightarrow> is_morphism(h) \<Longrightarrow>
   carrier(X) = source(g) \<union> source(h) \<Longrightarrow> target_str(g) = target_str(h) \<Longrightarrow>
   glue_morphism(X,g,h) \<in> X \<rightharpoonup> target_str(g)" by auto2

lemma glue_morphism_top_eval [rewrite]:
  "is_top_space(X) \<Longrightarrow> is_morphism(g) \<Longrightarrow> is_morphism(h) \<Longrightarrow>
   carrier(X) = source(g) \<union> source(h) \<Longrightarrow> target_str(g) = target_str(h) \<Longrightarrow>
   x \<in> source(glue_morphism(X,g,h)) \<Longrightarrow>
   glue_morphism(X,g,h)`x = (if x \<in> source(g) then g`x else h`x)" by auto2
setup {* del_prfstep_thm @{thm glue_morphism_def} *}

lemma continuous_paste_closed2 [backward]:
  "is_top_space(X) \<Longrightarrow> A = source(g) \<Longrightarrow> B = source(h) \<Longrightarrow> carrier(X) = A \<union> B \<Longrightarrow>
   g \<in> subspace(X,A) \<rightharpoonup>\<^sub>T Y \<Longrightarrow> h \<in> subspace(X,B) \<rightharpoonup>\<^sub>T Y \<Longrightarrow> is_closed(X,A) \<Longrightarrow> is_closed(X,B) \<Longrightarrow>
   \<forall>x\<in>source(g)\<inter>source(h). g`x = h`x \<Longrightarrow> glue_morphism(X,g,h) \<in> X \<rightharpoonup>\<^sub>T Y"
@proof
  @let "f = glue_morphism(X,g,h)"
  @have "f |\<^sub>T source(g) = g" @have "f |\<^sub>T source(h) = h"
@qed
setup {* del_prfstep_thm @{thm continuous_paste_closed} *}

section \<open>Homeomorphisms\<close>

definition homeomorphism :: "i \<Rightarrow> o" where [rewrite]:
  "homeomorphism(f) \<longleftrightarrow> (is_morphism_top(f) \<and> bijective(f) \<and> continuous(f) \<and> continuous(inverse_mor(f)))"

lemma top_inverse_pair_homeomorphism [forward]:
  "mor_form(g) \<Longrightarrow> mor_form(f) \<Longrightarrow> continuous(f) \<Longrightarrow> continuous(g) \<Longrightarrow> inverse_mor_pair(f,g) \<Longrightarrow>
   homeomorphism(f) \<and> homeomorphism(g)" by auto2

lemma homeomorphismD [backward]:
  "homeomorphism(f) \<Longrightarrow> is_open(source_str(f),U) \<Longrightarrow> is_open(target_str(f),f``U)"
@proof
  @have (@rule) "\<forall>y\<in>target(f). \<exists>x\<in>source(f). f`x = y"
  @have "inverse_mor(f) -`` U = f``U"
@qed

definition top_iso_space :: "i \<Rightarrow> i \<Rightarrow> i"  (infix "\<cong>\<^sub>T" 60) where [rewrite]:
  "top_iso_space(X,Y) = {f \<in> mor_space(X,Y). homeomorphism(f)}"

lemma top_iso_spaceD [forward]:
  "f \<in> X \<cong>\<^sub>T Y \<Longrightarrow> f \<in> X \<rightharpoonup> Y \<and> homeomorphism(f)" by auto2

lemma top_iso_spaceI [backward]:
  "mor_form(f) \<Longrightarrow> homeomorphism(f) \<Longrightarrow> f \<in> source_str(f) \<cong>\<^sub>T target_str(f)" by auto2
setup {* del_prfstep_thm @{thm top_iso_space_def} *}

definition homeomorphic :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "homeomorphic(X,Y) \<longleftrightarrow> (\<exists>f. f \<in> X \<cong>\<^sub>T Y)"

lemma homeomorphicI [forward]: "f \<in> X \<cong>\<^sub>T Y \<Longrightarrow> homeomorphic(X,Y)" by auto2
lemma homeomorphicD [resolve]: "homeomorphic(X,Y) \<Longrightarrow> \<exists>f. f \<in> X \<cong>\<^sub>T Y" by auto2
setup {* del_prfstep_thm @{thm homeomorphic_def} *}

lemma eq_str_top_to_homeomorphic [resolve]:
  "is_top_space(X) \<Longrightarrow> is_top_space(Y) \<Longrightarrow> eq_str_top(X,Y) \<Longrightarrow> homeomorphic(X,Y)"
@proof
  @let "f = Mor(X,Y,\<lambda>x. x)" @have "continuous(f)" @with
    @have "\<forall>U\<in>open_sets(Y). is_open(X,f-``U)" @with @have "f-``U = U" @end @end
  @let "g = Mor(Y,X,\<lambda>x. x)" @have "continuous(g)" @with
    @have "\<forall>U\<in>open_sets(X). is_open(Y,g-``U)" @with @have "g-``U = U" @end @end
  @have "inverse_mor_pair(f,g)" @have "f \<in> X \<cong>\<^sub>T Y"
@qed

end


theory Ex044
  imports Main
begin

theorem "\<lbrakk>\<not>(\<not>(A \<longrightarrow> B) \<and> \<not>B) ; \<not>C \<longrightarrow> A \<rbrakk> \<Longrightarrow> C \<or> B"
proof -
  assume a:"\<not>(\<not>(A \<longrightarrow> B) \<and> \<not>B)"
  and b:"\<not>C \<longrightarrow> A"
  {
    assume c:"\<not>(C \<or> B)"
    {
      assume d:"\<not>C"
      {
        assume e:"\<not>B"
        {
          assume f:"A \<longrightarrow> B"
          from b d have A by (rule mp)
          with f have B by (rule mp)
          with e have False by contradiction
        }
        hence "\<not>(A \<longrightarrow> B)" by (rule notI)
        from this e have "\<not>(A \<longrightarrow> B) \<and> \<not>B" by (rule conjI)
        with a have False by (rule notE)
      }
      hence "\<not>\<not>B" by (rule notI)
      hence B by (rule notnotD)
      hence "C \<or> B" by (rule disjI2)
      with c have False by (rule notE)
    }
    hence "\<not>\<not>C" by (rule notI)
    hence C by (rule notnotD)
    hence "C \<or> B" by (rule disjI1)
    with c have False by (rule notE)
  }
  hence "\<not>\<not> (C \<or> B)" by (rule notI)
  thus "C \<or> B" by (rule notnotD)
qed


theory Iter_Reduction_Results
  imports Main Iter_Reduction_Lemmas CancelResults
begin

(*The following were the lemmas to be proven:*)

lemma reduced_iter_length: "reduced (iter (length xs) reduce xs)"
proof(induction xs)
  case Nil
then have "(iter (length []) reduce []) = []" by simp
  then show ?case by simp
next
  case (Cons a xs)
  have 2: "(((length (a#xs) div 2 + 1))* 2) \<ge> length (a#xs) " using mult_2_greater by auto
  have "length (a # xs) > 0" by simp
  then have 1:"length (a # xs) div 2 + 1 \<le> length (a#xs)" by (meson discrete div_less_dividend one_less_numeral_iff semiring_norm(76))
  then show ?case
  proof(cases "\<not>reduced (iter (length (a # xs)) reduce (a # xs))")
    case True
  then have a: "\<not>reduced (iter (length (a # xs)) reduce (a # xs))" by simp
  then have cont:"\<not>reduced (iter (length (a # xs) div 2 + 1) reduce (a # xs))" using not_reduced_iter_suc 1 by blast
  then have "length (iter (length (a # xs) div 2 + 1) reduce (a # xs)) = length (a#xs) - (((length (a#xs) div 2 + 1))* 2)" using reduce_iter_minus by (metis mult.commute)
  then have "length (iter (length (a # xs) div 2 + 1) reduce (a # xs)) = 0" using subtract_greater[of "length (a#xs)" "(length (a # xs) div 2 + 1) * 2"] 2 by argo
  then have "(iter (length (a # xs) div 2 + 1) reduce (a # xs)) = []" by simp
  then have "reduced (iter (length (a # xs) div 2 + 1) reduce (a # xs))" by simp
   then show ?thesis using cont by blast
  next
    case False
    then show ?thesis by simp
  qed
qed

lemma iter_imp_cancels: assumes "iter (length xs) reduce xs = iter (length ys) reduce ys"
  shows "cancels_eq xs ys"
proof-
  have "cancels_to xs (iter (length xs) reduce xs)" using iter_cancels_to by auto
  then have a: "cancels_eq  xs (iter (length xs) reduce xs)" unfolding cancels_eq_def by blast
  have "cancels_to ys (iter (length ys) reduce ys)" using iter_cancels_to by auto
  then have b: "cancels_eq (iter (length ys) reduce ys) ys" unfolding cancels_eq_def by blast
  then show ?thesis using a b unfolding cancels_eq_def using assms by auto
qed

lemma cancels_imp_iter: assumes "cancels_eq xs ys"
  shows "iter (length xs) reduce xs = iter (length ys) reduce ys"
proof-
  have "cancels_to xs (iter (length xs) reduce xs)" using iter_cancels_to by auto
  then have "cancels_eq  (iter (length xs) reduce xs) xs" unfolding cancels_eq_def by blast
  then have a: "cancels_eq (iter (length xs) reduce xs) ys" using assms unfolding cancels_eq_def by auto
  have "cancels_to ys (iter (length ys) reduce ys)" using iter_cancels_to by auto
  then have b: "cancels_eq ys (iter (length ys) reduce ys)" unfolding cancels_eq_def by blast
  have rel: "cancels_eq (iter (length xs) reduce xs)  (iter (length ys) reduce ys)"  using a b unfolding cancels_eq_def by auto
  have x: "reduced (iter (length xs) reduce xs)" using reduced_iter_length by blast
  have y:  "reduced (iter (length ys) reduce ys)" using reduced_iter_length by blast
  then show ?thesis using rel x y reduced_cancel_eq by blast
qed

lemma cancels_eq_imp_reln:
  "cancels_eq x y ⟹ x~y"
  unfolding cancels_eq_def
  using cancels_imp_iter[of "x" "y"] iter_cancels_to[of "x" "length x"] cancels_imp_rel[of "x" "y"]
  by (metis cancels_eq_def cancels_imp_rel iter_cancels_to reln.sym reln.trans)

end


theory Homework7sol
imports
  "../IMP/Small_Step"
  "~~/src/HOL/Library/Code_Target_Nat"   (* Makes value-command compute with ML-integers rather than unary Suc (Suc ...) objects. *)
begin

  (*
    ISSUED: Wednesday, Nov 1
    DUE: Wednesday, Nov 7, 11:59pm
    POINTS: 10   (5 per part)
  *)

  (********** PART 1 ***************)

  (*
    In this homework, we will develop a faster way to interpret programs.

    First, we want to define a functional version of a small step,
    that is, a function
      small_stepf :: com * state \<Rightarrow> (com * state) option
    that returns the next configuration, after performing one small step.
    If the configuration was final, it shall return None.
    The equations of this function correspond to the rules of SmallStep.

    Complete the function!
  *)

  (* Hint: Ignore *warnings* about ambiguous inputs ... the \<Rightarrow> in case and big-step causes them.
    If you get type *errors*, though, DO NOT IGNORE THEM!
  *)

  fun small_stepf :: "com * state \<Rightarrow> (com * state) option" where
    "small_stepf (x ::= a, s) = Some (SKIP, s(x := aval a s))"
  | "small_stepf (SKIP;;c\<^sub>2,s) = Some (c\<^sub>2,s)"
  | "small_stepf (c\<^sub>1;;c\<^sub>2,s) = (*<*)(
      case small_stepf (c\<^sub>1,s) of
        None \<Rightarrow> None
      | Some (c\<^sub>1',s') \<Rightarrow> Some (c\<^sub>1';;c\<^sub>2,s')
      )(*>*)"
  | "small_stepf (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) = (*<*)(if bval b s then Some (c\<^sub>1,s) else Some (c\<^sub>2,s))(*>*)"
        (* Note: Although there are two If-rules in SmallStep, you only need a single equation here!  *)
  | "small_stepf (WHILE b DO c,s) = (*<*)Some (IF b THEN c;; WHILE b DO c ELSE SKIP,s)(*>*)"
  | "small_stepf _ = None" (* Catch-all case*)

  (* Show that small_stepf indeed computes a single small step! *)
  lemma small_stepf_eq: "cs\<rightarrow>cs'\<longleftrightarrow> small_stepf cs = Some cs'"
  (*<*)
    apply (induction cs arbitrary: cs' rule: small_stepf.induct)
    using deterministic
    by (auto split: prod.splits option.split)
  (*>*)

  (* Show that None is returned only for final configurations.
    Hint: Already implied by thm small_stepf_eq, no separate induction required!
  *)
  lemma final_eq: "final cs \<longleftrightarrow> small_stepf cs = None"
    (*<*)
    by (metis final_def option.distinct(1) option.exhaust small_stepf_eq)
  (*>*)

  (*
    Write a function iterate that iterates small_stepf, until a final
    configuration is reached, but for at most n iterations.

    If no final configuration is reached after n iterations, the function
    shall return None.

    n is also called fuel: Each iteration uses one unit of fuel,
      and when running out of fuel the computation stops.

    Do not use \<rightarrow> or final in your function, but
    use small_stepsf instead (cf. thms small_stepf_eq and final_eq)!

  *)
  fun iterate :: "nat \<Rightarrow> com * state \<Rightarrow> (com * state) option" where
  (*<*)
    "iterate 0 cs = (case small_stepf cs of None \<Rightarrow> Some cs | Some cs' \<Rightarrow> None)"
  | "iterate (Suc n) cs = (case small_stepf cs of None \<Rightarrow> Some cs | Some cs' \<Rightarrow> iterate n cs')"
  (*>*)

  (* Show that iterate behaves as expected!
    There is a terminating execution if, and only if, there is an
    initial fuel value such that iterate returns Some.

    Hint: Prove both directions separately.
  *)
  lemma iterate_eq: "(cs \<rightarrow>* cs' \<and> final cs') \<longleftrightarrow> (\<exists>n. iterate n cs = Some cs')"
  (*<*)
  proof
    assume "cs \<rightarrow>* cs' \<and> final cs'"
    hence "cs \<rightarrow>* cs'" "final cs'" by simp_all
    then show "\<exists>n. iterate n cs = Some cs'"
      apply induction
      apply (auto simp: final_eq intro: exI[where x=1]) []
      apply (auto simp: small_stepf_eq)
      by (metis iterate.simps(2) option.simps(5))
  next
    assume "\<exists>n. iterate n cs = Some cs'"
    then obtain n where "iterate n cs = Some cs'" ..
    thus "cs \<rightarrow>* cs' \<and> final cs'"
      apply (induction n cs rule: iterate.induct)
      apply (auto split: prod.splits option.splits simp: final_eq)
      by (simp add: small_stepf_eq star.step)
  qed
  (*>*)

  (*
    The iterate function gives you another way to execute programs, which
    is considerably faster than constructing derivation trees.

    Notes:
      * the extracts the value cs from Some cs, and the None is undefined.
      * snd extracts the second component of a pair
      * If you do not specify enough initial fuel, the command will just return
        \<open>snd (the None) ''a''\<close>, otherwise it returns teh correct result, e.g., 225.
        Specifying too much fuel, on the other hand, is no problem, as the iteration
        stops once it reaches a final result, not necessarily using up all its fuel.

  *)

  value "(snd (the (iterate 100000000000 (DerTreeExample.square,<''x'':=15>)))) ''a''"

  (********** PART 2 ***************)

  (*
    In this part, you are supposed to write some programs,
    satisfying a given specification. Test your programs!

    Try to find short and simple programs that only use the
    available operations of IMP!
  *)

  (* Write a program power2 that returns 2^c (2 to the power of c) in variable a

    Specification: { c\<ge>0 \<and> c=i\<^sub>c } power2 { a=2^i\<^sub>c }, i\<^sub>c does not occur in power2!
  *)

  definition power2 where "power2 \<equiv> (*<*)
    ''a''::=N 1;;
    WHILE Less (N 0) (V ''c'') DO (
      ''a'' ::= Plus (V ''a'') (V ''a'');;
      ''c'' ::= Plus (V ''c'') (N (-1))
    ) (*>*)
    "

  (* Template for testing \<dots> *)
  value "(snd (the (iterate 100000000000 (power2,<''c'':=2>)))) ''a''"

  (* If you did not succeed with the iterate function, use the standard big-step
    derivation to test your programs ... will be much slower, though!
  *)
  schematic_goal "(power2,<''c'':=10>) \<Rightarrow> ?s"
    unfolding power2_def
    by BigSteps

  (* Write a program that replaces variable a by a*b, and does not change b!
    You may assume that a and b are positive!

    Specification: { a=i\<^sub>a \<and> b=i\<^sub>b \<and> i\<^sub>a>0 \<and> i\<^sub>b>0 } mult { a=i\<^sub>a*i\<^sub>b \<and> b=i\<^sub>b }, i\<^sub>a,i\<^sub>b do not occur in mult!
  *)

  definition mult where "mult \<equiv> (*<*)
    ''x'' ::= Plus (V ''b'') (N (-1));;
    ''y'' ::= V ''a'';;
    WHILE Less (N 0) (V ''x'') DO (
      ''a'' ::= Plus (V ''a'') (V ''y'');;
      ''x'' ::= Plus (V ''x'') (N (-1))
    ) (*>*)
  "

  value "(snd (the (iterate 100000000000 (mult,<''a'':=0, ''b'':=7>)))) ''a''"

  (* Write a program that returns b^c in variable a.
    You may assume that b is positive and c is non-negative.

    Specification: { b=i\<^sub>b \<and> c=i\<^sub>c \<and> b>0 \<and> c\<ge>0 } power { a=i\<^sub>b^i\<^sub>c }, i\<^sub>b,i\<^sub>c do not occur in power

    Hint: Combine the ideas from the two above programs, you'll need two nested while loops.
      If your multiplication program uses auxiliary variables, keep care that they do not
      conflict with the variables used in your main program!

  *)

  definition power where "power \<equiv> (*<*)
    ''a''::=N 1;;
    WHILE Less (N 0) (V ''c'') DO (
      mult;;
      ''c'' ::= Plus (V ''c'') (N (-1))
    ) (*>*)
    "

  value "(snd (the (iterate 100000000000 (power,<''b'':=3, ''c'':=4>)))) ''a''"

end


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

header {* Inverse Functions *}

theory OrdinalInverse
imports OrdinalArith
begin

lemma (in normal) oInv_ex:
"F 0 \<le> a \<Longrightarrow> \<exists>q. F q \<le> a \<and> a < F (oSuc q)"
 apply (subgoal_tac "\<forall>z. a < F z \<longrightarrow> (\<exists>q<z. F q \<le> a \<and> a < F (oSuc q))")
  apply (drule_tac x="oSuc a" in spec, drule mp)
   apply (rule_tac y="F a" in order_le_less_trans)
    apply (rule increasing)
   apply (rule strict_monoD[OF less_oSuc])
  apply force
 apply (rule allI, rule_tac a=z in oLimit_induct)
   apply simp
  apply clarsimp
  apply (case_tac "a < F x")
   apply clarsimp
   apply (rule_tac x=q in exI)
   apply (simp add: order_less_trans[OF _ less_oSuc])
  apply (rule_tac x=x in exI, simp)
 apply (clarsimp simp add: oLimit)
 apply (drule less_oLimitD, clarify)
 apply (drule spec, drule mp, assumption)
 apply (clarify, rule_tac x=q in exI)
 apply (simp add: order_less_le_trans[OF _ le_oLimit])
done

lemma oInv_uniq:
"\<lbrakk>mono (F::ordinal \<Rightarrow> ordinal);
  F x \<le> a \<and> a < F (oSuc x); F y \<le> a \<and> a < F (oSuc y)\<rbrakk>
 \<Longrightarrow> x = y"
 apply clarify
 apply (rule_tac x=x and y=y in linorder_cases)
   apply (subgoal_tac "a < a", simp)
   apply (erule_tac y="F (oSuc x)" in order_less_le_trans)
   apply (rule_tac y="F y" in order_trans)
    apply (erule monoD, erule oSuc_leI)
   apply assumption
  apply assumption
 apply (subgoal_tac "a < a", simp)
 apply (erule_tac y="F (oSuc y)" in order_less_le_trans)
 apply (rule_tac y="F x" in order_trans)
  apply (erule monoD, erule oSuc_leI)
 apply assumption
done

definition
  oInv :: "(ordinal \<Rightarrow> ordinal) \<Rightarrow> ordinal \<Rightarrow> ordinal" where
  "oInv F a = (if F 0 \<le> a then (THE x. F x \<le> a \<and> a < F (oSuc x)) else 0)"

lemma (in normal) oInv_bounds:
"F 0 \<le> a \<Longrightarrow> F (oInv F a) \<le> a \<and> a < F (oSuc (oInv F a))"
 apply (simp add: oInv_def)
 apply (rule theI')
 apply (rule ex_ex1I)
  apply (simp add: oInv_ex)
 apply (simp add: oInv_uniq[OF mono])
done

lemma (in normal) oInv_bound1:
"F 0 \<le> a \<Longrightarrow> F (oInv F a) \<le> a"
by (rule oInv_bounds[THEN conjunct1])

lemma (in normal) oInv_bound2:
"a < F (oSuc (oInv F a))"
 apply (case_tac "F 0 \<le> a")
  apply (simp only: oInv_bounds[THEN conjunct2])
 apply (simp add: oInv_def, simp add: linorder_not_le)
 apply (erule order_less_le_trans)
 apply (simp add: cancel_le)
done

lemma (in normal) oInv_equality:
"\<lbrakk>F x \<le> a; a < F (oSuc x)\<rbrakk> \<Longrightarrow> oInv F a = x"
 apply (subgoal_tac "F 0 \<le> a")
  apply (simp add: oInv_def)
  apply (rule the_equality)
   apply simp
  apply (simp add: oInv_uniq[OF mono])
 apply (rule_tac y="F x" in order_trans)
  apply (simp add: cancel_le)
 apply assumption
done

lemma (in normal) oInv_inverse: "oInv F (F x) = x"
by (rule oInv_equality, simp_all add: cancel_less)

lemma (in normal) oInv_equality': "a = F x \<Longrightarrow> oInv F a = x"
by (simp add: oInv_inverse)

lemma (in normal) oInv_eq_0: "a \<le> F 0 \<Longrightarrow> oInv F a = 0"
 apply (case_tac "F 0 \<le> a")
  apply (rule oInv_equality')
  apply (simp only: order_antisym)
 apply (simp add: oInv_def)
done

lemma (in normal) oInv_less:
"\<lbrakk>F 0 \<le> a; a < F z\<rbrakk> \<Longrightarrow> oInv F a < z"
 apply (subst cancel_less[symmetric])
 apply (simp only: order_le_less_trans[OF oInv_bound1])
done

lemma (in normal) le_oInv:
"F z \<le> a \<Longrightarrow> z \<le> oInv F a"
 apply (subst less_oSuc_eq_le[symmetric])
 apply (subst cancel_less[symmetric])
 apply (erule order_le_less_trans)
 apply (rule oInv_bound2)
done

lemma (in normal) less_oInvD:
"x < oInv F a \<Longrightarrow> F (oSuc x) \<le> a"
 apply (case_tac "F 0 \<le> a")
  apply (rule order_trans[OF _ oInv_bound1])
   apply (simp add: cancel_le oSuc_leI)
  apply assumption
 apply (simp add: oInv_def)
done

lemma (in normal) oInv_le:
"a < F (oSuc x) \<Longrightarrow> oInv F a \<le> x"
 apply (erule contrapos_pp)
 apply (simp add: linorder_not_less linorder_not_le less_oInvD)
done

lemma (in normal) mono_oInv: "mono (oInv F)"
proof
  fix x y :: ordinal
  assume "x \<le> y"
  show "oInv F x \<le> oInv F y"
  proof (rule linorder_le_cases [of x "F 0"])
    assume "x \<le> F 0" then show ?thesis by (simp add: oInv_eq_0)
  next
    assume "F 0 \<le> x" show ?thesis
      by (rule le_oInv, simp only: `x \<le> y` `F 0 \<le> x` order_trans [OF oInv_bound1])
  qed
qed

lemma (in normal) oInv_decreasing:
"F 0 \<le> x \<Longrightarrow> oInv F x \<le> x"
 apply (subst cancel_le[symmetric])
 apply (rule_tac y=x in order_trans)
  apply (erule oInv_bound1)
 apply (rule increasing)
done

subsection {* Division *}

instantiation ordinal :: "{Divides.div}"
begin

definition
  div_ordinal_def:
   "x div y = (if 0 < y then oInv (op * y) x else 0)"

definition
  mod_ordinal_def:
   "x mod y = ((x::ordinal) - y * (x div y))"

instance ..

end

lemma ordinal_divI: "\<lbrakk>x = y * q + r; r < y\<rbrakk> \<Longrightarrow> x div y = (q::ordinal)"
 apply (simp add: div_ordinal_def, safe)
 apply (simp add: normal.oInv_equality[OF normal_times])
done

lemma ordinal_times_div_le: "y * (x div y) \<le> (x::ordinal)"
 apply (simp add: div_ordinal_def, safe)
 apply (erule normal.oInv_bound1[OF normal_times])
 apply simp
done

lemma ordinal_less_times_div_plus:
"0 < y \<Longrightarrow> x < y * (x div y) + (y::ordinal)"
 apply (simp add: div_ordinal_def)
 apply (subst ordinal_times_oSuc[symmetric])
 apply (erule normal.oInv_bound2[OF normal_times])
done

lemma ordinal_modI: "\<lbrakk>x = y * q + r; r < y\<rbrakk> \<Longrightarrow> x mod y = (r::ordinal)"
 apply (unfold mod_ordinal_def)
 apply (rule ordinal_minusI)
 apply (simp add: ordinal_divI)
done

lemma ordinal_mod_less: "0 < y \<Longrightarrow> x mod y < (y::ordinal)"
 apply (unfold mod_ordinal_def)
 apply (simp add: ordinal_times_div_le)
 apply (simp add: div_ordinal_def)
 apply (subst ordinal_times_oSuc[symmetric])
 apply (erule normal.oInv_bound2[OF normal_times])
done

lemma ordinal_div_plus_mod: "y * (x div y) + (x mod y) = (x::ordinal)"
 apply (simp add: mod_ordinal_def)
 apply (rule ordinal_plus_minus2)
 apply (rule ordinal_times_div_le)
done

lemma ordinal_div_less: "x < y * z \<Longrightarrow> x div y < (z::ordinal)"
 apply (auto simp add: div_ordinal_def)
 apply (simp add: normal.oInv_less[OF normal_times])
done

lemma ordinal_le_div: "\<lbrakk>0 < y; y * z \<le> x\<rbrakk> \<Longrightarrow> (z::ordinal) \<le> x div y"
 apply (auto simp add: div_ordinal_def)
 apply (simp add: normal.le_oInv[OF normal_times])
done

lemma ordinal_div_monoL: "x \<le> x' \<Longrightarrow> x div y \<le> x' div (y::ordinal)"
by (erule monoD[OF ordinal_mono_div])

lemma ordinal_div_decreasing: "(x::ordinal) div y \<le> x"
 apply (auto simp add: div_ordinal_def)
 apply (simp add: normal.oInv_decreasing[OF normal_times])
done

lemma ordinal_div_0: "x div 0 = (0::ordinal)"
by (simp add: div_ordinal_def)

lemma ordinal_mod_0: "x mod 0 = (x::ordinal)"
by (simp add: mod_ordinal_def)

subsection {* Derived properties of division *}

lemma ordinal_div_1 [simp]: "x div oSuc 0 = x"
by (rule_tac r=0 in ordinal_divI, simp_all)

lemma ordinal_mod_1 [simp]: "x mod oSuc 0 = 0"
by (rule_tac q=x in ordinal_modI, simp_all)

lemma ordinal_div_self [simp]: "0 < x \<Longrightarrow> x div x = (1::ordinal)"
by (rule_tac r=0 in ordinal_divI, simp_all)

lemma ordinal_mod_self [simp]: "x mod x = (0::ordinal)"
 apply (case_tac "x=0", simp add: ordinal_mod_0, simp)
 apply (rule_tac q=1 in ordinal_modI, simp_all)
done

lemma ordinal_div_greater [simp]: "x < y \<Longrightarrow> x div y = (0::ordinal)"
by (rule_tac r=x in ordinal_divI, simp_all)

lemma ordinal_mod_greater [simp]: "x < y \<Longrightarrow> x mod y = (x::ordinal)"
by (rule_tac q=0 in ordinal_modI, simp_all)

lemma ordinal_0_div [simp]: "0 div x = (0::ordinal)"
by (case_tac "x=0", simp add: ordinal_div_0, simp)

lemma ordinal_0_mod [simp]: "0 mod x = (0::ordinal)"
by (case_tac "x=0", simp add: ordinal_mod_0, simp)

lemma ordinal_1_dvd [simp]: "oSuc 0 dvd x"
by (rule_tac k=x in dvdI, simp)

lemma ordinal_dvd_mod: "y dvd x = (x mod y = (0::ordinal))"
 apply safe
  apply (erule dvdE)
  apply (case_tac "y=0", simp add: ordinal_mod_0, simp)
  apply (rule ordinal_modI, simp, simp)
 apply (cut_tac x=x and y=y in ordinal_div_plus_mod)
 apply (rule_tac k="x div y" in dvdI, simp)
done

lemma ordinal_dvd_times_div:
"y dvd x \<Longrightarrow> y * (x div y) = (x::ordinal)"
 apply (cut_tac x=x and y=y in ordinal_div_plus_mod)
 apply (simp add: ordinal_dvd_mod)
done

lemma ordinal_dvd_oLimit: "\<forall>n. x dvd f n \<Longrightarrow> x dvd oLimit f"
 apply (rule_tac k="oLimit (\<lambda>n. f n div x)" in dvdI)
 apply (simp add: ordinal_dvd_times_div)
done

subsection {* Logarithms *}

definition
  oLog :: "ordinal \<Rightarrow> ordinal \<Rightarrow> ordinal" where
  "oLog b = (\<lambda>x. if 1 < b then oInv (op ** b) x else 0)"

lemma ordinal_oLogI:
"\<lbrakk>b ** y \<le> x; x < b ** y * b\<rbrakk> \<Longrightarrow> oLog b x = y"
 apply (rule_tac x=1 and y=b in linorder_cases, simp_all)
 apply (simp add: oLog_def normal.oInv_equality[OF normal_exp])
done

lemma ordinal_exp_oLog_le:
"\<lbrakk>0 < x; oSuc 0 < b\<rbrakk> \<Longrightarrow> b ** (oLog b x) \<le> x"
 apply (simp add: oLog_def)
 apply (frule_tac order_less_trans[OF less_oSuc])
 apply (simp add: normal.oInv_bound1[OF normal_exp] oSuc_leI)
done

lemma ordinal_less_exp_oLog:
"oSuc 0 < b \<Longrightarrow> x < b ** (oLog b x) * b"
 apply (simp add: oLog_def)
 apply (subst ordinal_exp_oSuc[symmetric])
 apply (erule normal.oInv_bound2[OF normal_exp])
done

lemma ordinal_oLog_less:
"\<lbrakk>0 < x; oSuc 0 < b; x < b ** y\<rbrakk> \<Longrightarrow> oLog b x < y"
 apply (simp add: oLog_def)
 apply (frule_tac order_less_trans[OF less_oSuc])
 apply (simp add: normal.oInv_less[OF normal_exp] oSuc_leI)
done

lemma ordinal_le_oLog:
"\<lbrakk>oSuc 0 < b; b ** y \<le> x\<rbrakk> \<Longrightarrow> y \<le> oLog b x"
by (simp add: oLog_def normal.le_oInv[OF normal_exp])

lemma ordinal_oLogI2:
"\<lbrakk>oSuc 0 < b; x = b ** y * q + r; 0 < q; q < b; r < b ** y\<rbrakk> \<Longrightarrow> oLog b x = y"
 apply simp
 apply (rule ordinal_oLogI)
  apply (rule_tac y="b ** y * q" in order_trans, simp, simp)
 apply (rule order_less_le_trans)
  apply (erule ordinal_plus_strict_monoR)
 apply (subst ordinal_times_oSuc[symmetric])
 apply (rule ordinal_times_monoR)
 apply (erule oSuc_leI)
done

lemma ordinal_div_exp_oLog_less:
"oSuc 0 < b \<Longrightarrow> x div (b ** oLog b x) < b"
 apply (frule_tac order_less_trans[OF less_oSuc])
 apply (case_tac "x=0", simp_all)
 apply (rule ordinal_div_less)
by (rule ordinal_less_exp_oLog)

lemma ordinal_oLog_base_0: "oLog 0 x = 0"
by (simp add: oLog_def)

lemma ordinal_oLog_base_1: "oLog (oSuc 0) x = 0"
by (simp add: oLog_def)

lemma ordinal_oLog_exp: "oSuc 0 < b \<Longrightarrow> oLog b (b ** x) = x"
by (simp add: oLog_def normal.oInv_inverse[OF normal_exp])

lemma ordinal_oLog_self: "oSuc 0 < b \<Longrightarrow> oLog b b = oSuc 0"
 apply (subgoal_tac "oLog b (b ** oSuc 0) = oSuc 0")
  apply (simp only: ordinal_exp_1)
 apply (simp only: ordinal_oLog_exp)
done

lemma ordinal_mono_oLog: "mono (oLog b)"
 apply (case_tac "oSuc 0 < b")
  apply (simp add: oLog_def normal.mono_oInv[OF normal_exp])
 apply (simp add: oLog_def monoI)
done

lemma ordinal_oLog_monoR: "x \<le> y \<Longrightarrow> oLog b x \<le> oLog b y"
by (erule monoD[OF ordinal_mono_oLog])

lemma ordinal_oLog_decreasing: "oLog b x \<le> x"
 apply (rule_tac x=b and y=1 in linorder_cases)
   apply (simp add: ordinal_oLog_base_0)
  apply (simp add: ordinal_oLog_base_1)
 apply (case_tac "x = 0")
  apply (simp add: ordinal_oLog_0)
 apply (simp add: oLog_def)
 apply (simp add: normal.oInv_decreasing[OF normal_exp] oSuc_leI)
done

end


(*  Title:      HOL/Algebra/Lattice.thy
    Author:     Clemens Ballarin, started 7 November 2003
    Copyright:  Clemens Ballarin

Most congruence rules by Stephan Hohe. With additional contributions from Alasdair Armstrong
and Simon Foster.
*)

theory Lattice
imports Order
begin

section \<open> Lattices \<close>

subsection \<open> Supremum and infimum \<close>

definition
  asup :: "[_, 'a set] => 'a" ("\<Squnion>\<index>_" [90] 90)
  where "\<Squnion>\<^bsub>L\<^esub>A = (SOME x. least L x (Upper L A))"

definition
  ainf :: "[_, 'a set] => 'a" ("\<Sqinter>\<index>_" [90] 90)
  where "\<Sqinter>\<^bsub>L\<^esub>A = (SOME x. greatest L x (Lower L A))"

definition asupr ::
  "('a, 'b) gorder_scheme \<Rightarrow> 'c set \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> 'a " where
"asupr L A f = \<Squnion>\<^bsub>L \<^esub>(f ` A)"

definition ainfi ::
  "('a, 'b) gorder_scheme \<Rightarrow> 'c set \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> 'a " where
"ainfi L A f = \<Sqinter>\<^bsub>L \<^esub>(f ` A)"

syntax
  "_inf1"     :: "('a, 'b) gorder_scheme \<Rightarrow> pttrns \<Rightarrow> 'a \<Rightarrow> 'a" ("(3IINF\<index> _./ _)" [0, 10] 10)
  "_inf"      :: "('a, 'b) gorder_scheme \<Rightarrow> pttrn \<Rightarrow> 'c set \<Rightarrow> 'a \<Rightarrow> 'a"  ("(3IINF\<index> _:_./ _)" [0, 0, 10] 10)
  "_sup1"     :: "('a, 'b) gorder_scheme \<Rightarrow> pttrns \<Rightarrow> 'a \<Rightarrow> 'a" ("(3SSUP\<index> _./ _)" [0, 10] 10)
  "_sup"      :: "('a, 'b) gorder_scheme \<Rightarrow> pttrn \<Rightarrow> 'c set \<Rightarrow> 'a \<Rightarrow> 'a"  ("(3SSUP\<index> _:_./ _)" [0, 0, 10] 10)

translations
  "IINF\<^bsub>L\<^esub> x. B"     == "CONST ainfi L CONST UNIV (%x. B)"
  "IINF\<^bsub>L\<^esub> x:A. B"   == "CONST ainfi L A (%x. B)"
  "SSUP\<^bsub>L\<^esub> x. B"     == "CONST asupr L CONST UNIV (%x. B)"
  "SSUP\<^bsub>L\<^esub> x:A. B"   == "CONST asupr L A (%x. B)"

definition
  join :: "[_, 'a, 'a] => 'a" (infixl "\<squnion>\<index>" 65)
  where "x \<squnion>\<^bsub>L\<^esub> y = \<Squnion>\<^bsub>L\<^esub>{x, y}"

definition
  meet :: "[_, 'a, 'a] => 'a" (infixl "\<sqinter>\<index>" 70)
  where "x \<sqinter>\<^bsub>L\<^esub> y = \<Sqinter>\<^bsub>L\<^esub>{x, y}"

definition
  LFP :: "('a, 'b) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("\<mu>\<index>") where
  "LFP L f = \<Sqinter>\<^bsub>L\<^esub> {u \<in> carrier L. f u \<sqsubseteq>\<^bsub>L\<^esub> u}"    --\<open>least fixed point\<close>

definition
  GFP:: "('a, 'b) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("\<nu>\<index>") where
  "GFP L f = \<Squnion>\<^bsub>L\<^esub> {u \<in> carrier L. u \<sqsubseteq>\<^bsub>L\<^esub> f u}"    --\<open>greatest fixed point\<close>

subsection \<open> Dual operators \<close>

lemma sup_dual [simp]:
  "\<Squnion>\<^bsub>inv_gorder L\<^esub>A = \<Sqinter>\<^bsub>L\<^esub>A"
  by (simp add:asup_def ainf_def)

lemma inf_dual [simp]:
  "\<Sqinter>\<^bsub>inv_gorder L\<^esub>A = \<Squnion>\<^bsub>L\<^esub>A"
  by (simp add:asup_def ainf_def)

lemma join_dual [simp]:
  "p \<squnion>\<^bsub>inv_gorder L\<^esub> q = p \<sqinter>\<^bsub>L\<^esub> q"
  by (simp add:join_def meet_def)

lemma meet_dual [simp]:
  "p \<sqinter>\<^bsub>inv_gorder L\<^esub> q = p \<squnion>\<^bsub>L\<^esub> q"
  by (simp add:join_def meet_def)

lemma top_dual [simp]:
  "\<top>\<^bsub>inv_gorder L\<^esub> = \<bottom>\<^bsub>L\<^esub>"
  by (simp add:atop_def abottom_def)

lemma bottom_dual [simp]:
  "\<bottom>\<^bsub>inv_gorder L\<^esub> = \<top>\<^bsub>L\<^esub>"
  by (simp add:atop_def abottom_def)

lemma LFP_dual [simp]:
  "LFP (inv_gorder L) f = GFP L f"
  by (simp add:LFP_def GFP_def)

lemma GFP_dual [simp]:
  "GFP (inv_gorder L) f = LFP L f"
  by (simp add:LFP_def GFP_def)

subsection \<open> Lattices \<close>

locale weak_upper_semilattice = weak_partial_order +
  assumes sup_of_two_exists:
    "[| x \<in> carrier L; y \<in> carrier L |] ==> EX s. least L s (Upper L {x, y})"

locale weak_lower_semilattice = weak_partial_order +
  assumes inf_of_two_exists:
    "[| x \<in> carrier L; y \<in> carrier L |] ==> EX s. greatest L s (Lower L {x, y})"

locale weak_lattice = weak_upper_semilattice + weak_lower_semilattice

lemma (in weak_lattice) dual_weak_lattice:
  "weak_lattice (inv_gorder L)"
proof -
  interpret dual: weak_partial_order "inv_gorder L"
    by (metis dual_weak_order)

  show ?thesis
    apply (unfold_locales)
    apply (simp_all add: inf_of_two_exists sup_of_two_exists)
  done
qed

subsubsection \<open> Supremum \<close>

lemma (in weak_upper_semilattice) joinI:
  "[| !!l. least L l (Upper L {x, y}) ==> P l; x \<in> carrier L; y \<in> carrier L |]
  ==> P (x \<squnion> y)"
proof (unfold join_def asup_def)
  assume L: "x \<in> carrier L"  "y \<in> carrier L"
    and P: "!!l. least L l (Upper L {x, y}) ==> P l"
  with sup_of_two_exists obtain s where "least L s (Upper L {x, y})" by fast
  with L show "P (SOME l. least L l (Upper L {x, y}))"
    by (fast intro: someI2 P)
qed

lemma (in weak_upper_semilattice) join_closed [simp]:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<squnion> y \<in> carrier L"
  by (rule joinI) (rule least_closed)

lemma (in weak_upper_semilattice) join_cong_l:
  assumes carr: "x \<in> carrier L" "x' \<in> carrier L" "y \<in> carrier L"
    and xx': "x .= x'"
  shows "x \<squnion> y .= x' \<squnion> y"
proof (rule joinI, rule joinI)
  fix a b
  from xx' carr
      have seq: "{x, y} {.=} {x', y}" by (rule set_eq_pairI)

  assume leasta: "least L a (Upper L {x, y})"
  assume "least L b (Upper L {x', y})"
  with carr
      have leastb: "least L b (Upper L {x, y})"
      by (simp add: least_Upper_cong_r[OF _ _ seq])

  from leasta leastb
      show "a .= b" by (rule weak_least_unique)
qed (rule carr)+

lemma (in weak_upper_semilattice) join_cong_r:
  assumes carr: "x \<in> carrier L" "y \<in> carrier L" "y' \<in> carrier L"
    and yy': "y .= y'"
  shows "x \<squnion> y .= x \<squnion> y'"
proof (rule joinI, rule joinI)
  fix a b
  have "{x, y} = {y, x}" by fast
  also from carr yy'
      have "{y, x} {.=} {y', x}" by (intro set_eq_pairI)
  also have "{y', x} = {x, y'}" by fast
  finally
      have seq: "{x, y} {.=} {x, y'}" .

  assume leasta: "least L a (Upper L {x, y})"
  assume "least L b (Upper L {x, y'})"
  with carr
      have leastb: "least L b (Upper L {x, y})"
      by (simp add: least_Upper_cong_r[OF _ _ seq])

  from leasta leastb
      show "a .= b" by (rule weak_least_unique)
qed (rule carr)+

lemma (in weak_partial_order) sup_of_singletonI:      (* only reflexivity needed ? *)
  "x \<in> carrier L ==> least L x (Upper L {x})"
  by (rule least_UpperI) auto

lemma (in weak_partial_order) weak_sup_of_singleton [simp]:
  "x \<in> carrier L ==> \<Squnion>{x} .= x"
  unfolding asup_def
  by (rule someI2) (auto intro: weak_least_unique sup_of_singletonI)

lemma (in weak_partial_order) sup_of_singleton_closed [simp]:
  "x \<in> carrier L \<Longrightarrow> \<Squnion>{x} \<in> carrier L"
  unfolding asup_def
  by (rule someI2) (auto intro: sup_of_singletonI)

text \<open> Condition on @{text A}: supremum exists. \<close>

lemma (in weak_upper_semilattice) sup_insertI:
  "[| !!s. least L s (Upper L (insert x A)) ==> P s;
  least L a (Upper L A); x \<in> carrier L; A \<subseteq> carrier L |]
  ==> P (\<Squnion>(insert x A))"
proof (unfold asup_def)
  assume L: "x \<in> carrier L"  "A \<subseteq> carrier L"
    and P: "!!l. least L l (Upper L (insert x A)) ==> P l"
    and least_a: "least L a (Upper L A)"
  from L least_a have La: "a \<in> carrier L" by simp
  from L sup_of_two_exists least_a
  obtain s where least_s: "least L s (Upper L {a, x})" by blast
  show "P (SOME l. least L l (Upper L (insert x A)))"
  proof (rule someI2)
    show "least L s (Upper L (insert x A))"
    proof (rule least_UpperI)
      fix z
      assume "z \<in> insert x A"
      then show "z \<sqsubseteq> s"
      proof
        assume "z = x" then show ?thesis
          by (simp add: least_Upper_above [OF least_s] L La)
      next
        assume "z \<in> A"
        with L least_s least_a show ?thesis
          by (rule_tac le_trans [where y = a]) (auto dest: least_Upper_above)
      qed
    next
      fix y
      assume y: "y \<in> Upper L (insert x A)"
      show "s \<sqsubseteq> y"
      proof (rule least_le [OF least_s], rule Upper_memI)
        fix z
        assume z: "z \<in> {a, x}"
        then show "z \<sqsubseteq> y"
        proof
          have y': "y \<in> Upper L A"
            apply (rule subsetD [where A = "Upper L (insert x A)"])
             apply (rule Upper_antimono)
             apply blast
            apply (rule y)
            done
          assume "z = a"
          with y' least_a show ?thesis by (fast dest: least_le)
        next
          assume "z \<in> {x}"  (* FIXME "z = x"; declare specific elim rule for "insert x {}" (!?) *)
          with y L show ?thesis by blast
        qed
      qed (rule Upper_closed [THEN subsetD, OF y])
    next
      from L show "insert x A \<subseteq> carrier L" by simp
      from least_s show "s \<in> carrier L" by simp
    qed
  qed (rule P)
qed

lemma (in weak_upper_semilattice) finite_sup_least:
  "[| finite A; A \<subseteq> carrier L; A ~= {} |] ==> least L (\<Squnion>A) (Upper L A)"
proof (induct set: finite)
  case empty
  then show ?case by simp
next
  case (insert x A)
  show ?case
  proof (cases "A = {}")
    case True
    with insert show ?thesis
      by simp (simp add: least_cong [OF weak_sup_of_singleton] sup_of_singletonI)
        (* The above step is hairy; least_cong can make simp loop.
        Would want special version of simp to apply least_cong. *)
  next
    case False
    with insert have "least L (\<Squnion>A) (Upper L A)" by simp
    with _ show ?thesis
      by (rule sup_insertI) (simp_all add: insert [simplified])
  qed
qed

lemma (in weak_upper_semilattice) finite_sup_insertI:
  assumes P: "!!l. least L l (Upper L (insert x A)) ==> P l"
    and xA: "finite A"  "x \<in> carrier L"  "A \<subseteq> carrier L"
  shows "P (\<Squnion> (insert x A))"
proof (cases "A = {}")
  case True with P and xA show ?thesis
    by (simp add: finite_sup_least)
next
  case False with P and xA show ?thesis
    by (simp add: sup_insertI finite_sup_least)
qed

lemma (in weak_upper_semilattice) finite_sup_closed [simp]:
  "[| finite A; A \<subseteq> carrier L; A ~= {} |] ==> \<Squnion>A \<in> carrier L"
proof (induct set: finite)
  case empty then show ?case by simp
next
  case insert then show ?case
    by - (rule finite_sup_insertI, simp_all)
qed

lemma (in weak_upper_semilattice) join_left:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqsubseteq> x \<squnion> y"
  by (rule joinI [folded join_def]) (blast dest: least_mem)

lemma (in weak_upper_semilattice) join_right:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> y \<sqsubseteq> x \<squnion> y"
  by (rule joinI [folded join_def]) (blast dest: least_mem)

lemma (in weak_upper_semilattice) sup_of_two_least:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> least L (\<Squnion>{x, y}) (Upper L {x, y})"
proof (unfold asup_def)
  assume L: "x \<in> carrier L"  "y \<in> carrier L"
  with sup_of_two_exists obtain s where "least L s (Upper L {x, y})" by fast
  with L show "least L (SOME z. least L z (Upper L {x, y})) (Upper L {x, y})"
  by (fast intro: someI2 weak_least_unique)  (* blast fails *)
qed

lemma (in weak_upper_semilattice) join_le:
  assumes sub: "x \<sqsubseteq> z"  "y \<sqsubseteq> z"
    and x: "x \<in> carrier L" and y: "y \<in> carrier L" and z: "z \<in> carrier L"
  shows "x \<squnion> y \<sqsubseteq> z"
proof (rule joinI [OF _ x y])
  fix s
  assume "least L s (Upper L {x, y})"
  with sub z show "s \<sqsubseteq> z" by (fast elim: least_le intro: Upper_memI)
qed

lemma (in weak_lattice) weak_le_iff_meet:
  assumes "x \<in> carrier L" "y \<in> carrier L"
  shows "x \<sqsubseteq> y \<longleftrightarrow> (x \<squnion> y) .= y"
  by (meson assms(1) assms(2) join_closed join_le join_left join_right le_cong_r local.le_refl weak_le_antisym)

lemma (in weak_upper_semilattice) weak_join_assoc_lemma:
  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
  shows "x \<squnion> (y \<squnion> z) .= \<Squnion>{x, y, z}"
proof (rule finite_sup_insertI)
  -- \<open> The textbook argument in Jacobson I, p 457 \<close>
  fix s
  assume sup: "least L s (Upper L {x, y, z})"
  show "x \<squnion> (y \<squnion> z) .= s"
  proof (rule weak_le_antisym)
    from sup L show "x \<squnion> (y \<squnion> z) \<sqsubseteq> s"
      by (fastforce intro!: join_le elim: least_Upper_above)
  next
    from sup L show "s \<sqsubseteq> x \<squnion> (y \<squnion> z)"
    by (erule_tac least_le)
      (blast intro!: Upper_memI intro: le_trans join_left join_right join_closed)
  qed (simp_all add: L least_closed [OF sup])
qed (simp_all add: L)

text \<open> Commutativity holds for @{text "="}. \<close>

lemma join_comm:
  fixes L (structure)
  shows "x \<squnion> y = y \<squnion> x"
  by (unfold join_def) (simp add: insert_commute)

lemma (in weak_upper_semilattice) weak_join_assoc:
  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
  shows "(x \<squnion> y) \<squnion> z .= x \<squnion> (y \<squnion> z)"
proof -
  (* FIXME: could be simplified by improved simp: uniform use of .=,
     omit [symmetric] in last step. *)
  have "(x \<squnion> y) \<squnion> z = z \<squnion> (x \<squnion> y)" by (simp only: join_comm)
  also from L have "... .= \<Squnion>{z, x, y}" by (simp add: weak_join_assoc_lemma)
  also from L have "... = \<Squnion>{x, y, z}" by (simp add: insert_commute)
  also from L have "... .= x \<squnion> (y \<squnion> z)" by (simp add: weak_join_assoc_lemma [symmetric])
  finally show ?thesis by (simp add: L)
qed

subsubsection \<open> Infimum \<close>

lemma (in weak_lower_semilattice) meetI:
  "[| !!i. greatest L i (Lower L {x, y}) ==> P i;
  x \<in> carrier L; y \<in> carrier L |]
  ==> P (x \<sqinter> y)"
proof (unfold meet_def ainf_def)
  assume L: "x \<in> carrier L"  "y \<in> carrier L"
    and P: "!!g. greatest L g (Lower L {x, y}) ==> P g"
  with inf_of_two_exists obtain i where "greatest L i (Lower L {x, y})" by fast
  with L show "P (SOME g. greatest L g (Lower L {x, y}))"
  by (fast intro: someI2 weak_greatest_unique P)
qed

lemma (in weak_lower_semilattice) meet_closed [simp]:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqinter> y \<in> carrier L"
  by (rule meetI) (rule greatest_closed)

lemma (in weak_lower_semilattice) meet_cong_l:
  assumes carr: "x \<in> carrier L" "x' \<in> carrier L" "y \<in> carrier L"
    and xx': "x .= x'"
  shows "x \<sqinter> y .= x' \<sqinter> y"
proof (rule meetI, rule meetI)
  fix a b
  from xx' carr
      have seq: "{x, y} {.=} {x', y}" by (rule set_eq_pairI)

  assume greatesta: "greatest L a (Lower L {x, y})"
  assume "greatest L b (Lower L {x', y})"
  with carr
      have greatestb: "greatest L b (Lower L {x, y})"
      by (simp add: greatest_Lower_cong_r[OF _ _ seq])

  from greatesta greatestb
      show "a .= b" by (rule weak_greatest_unique)
qed (rule carr)+

lemma (in weak_lower_semilattice) meet_cong_r:
  assumes carr: "x \<in> carrier L" "y \<in> carrier L" "y' \<in> carrier L"
    and yy': "y .= y'"
  shows "x \<sqinter> y .= x \<sqinter> y'"
proof (rule meetI, rule meetI)
  fix a b
  have "{x, y} = {y, x}" by fast
  also from carr yy'
      have "{y, x} {.=} {y', x}" by (intro set_eq_pairI)
  also have "{y', x} = {x, y'}" by fast
  finally
      have seq: "{x, y} {.=} {x, y'}" .

  assume greatesta: "greatest L a (Lower L {x, y})"
  assume "greatest L b (Lower L {x, y'})"
  with carr
      have greatestb: "greatest L b (Lower L {x, y})"
      by (simp add: greatest_Lower_cong_r[OF _ _ seq])

  from greatesta greatestb
      show "a .= b" by (rule weak_greatest_unique)
qed (rule carr)+

lemma (in weak_partial_order) inf_of_singletonI:      (* only reflexivity needed ? *)
  "x \<in> carrier L ==> greatest L x (Lower L {x})"
  by (rule greatest_LowerI) auto

lemma (in weak_partial_order) weak_inf_of_singleton [simp]:
  "x \<in> carrier L ==> \<Sqinter>{x} .= x"
  unfolding ainf_def
  by (rule someI2) (auto intro: weak_greatest_unique inf_of_singletonI)

lemma (in weak_partial_order) inf_of_singleton_closed:
  "x \<in> carrier L ==> \<Sqinter>{x} \<in> carrier L"
  unfolding ainf_def
  by (rule someI2) (auto intro: inf_of_singletonI)

text \<open> Condition on @{text A}: infimum exists. \<close>

lemma (in weak_lower_semilattice) inf_insertI:
  "[| !!i. greatest L i (Lower L (insert x A)) ==> P i;
  greatest L a (Lower L A); x \<in> carrier L; A \<subseteq> carrier L |]
  ==> P (\<Sqinter>(insert x A))"
proof (unfold ainf_def)
  assume L: "x \<in> carrier L"  "A \<subseteq> carrier L"
    and P: "!!g. greatest L g (Lower L (insert x A)) ==> P g"
    and greatest_a: "greatest L a (Lower L A)"
  from L greatest_a have La: "a \<in> carrier L" by simp
  from L inf_of_two_exists greatest_a
  obtain i where greatest_i: "greatest L i (Lower L {a, x})" by blast
  show "P (SOME g. greatest L g (Lower L (insert x A)))"
  proof (rule someI2)
    show "greatest L i (Lower L (insert x A))"
    proof (rule greatest_LowerI)
      fix z
      assume "z \<in> insert x A"
      then show "i \<sqsubseteq> z"
      proof
        assume "z = x" then show ?thesis
          by (simp add: greatest_Lower_below [OF greatest_i] L La)
      next
        assume "z \<in> A"
        with L greatest_i greatest_a show ?thesis
          by (rule_tac le_trans [where y = a]) (auto dest: greatest_Lower_below)
      qed
    next
      fix y
      assume y: "y \<in> Lower L (insert x A)"
      show "y \<sqsubseteq> i"
      proof (rule greatest_le [OF greatest_i], rule Lower_memI)
        fix z
        assume z: "z \<in> {a, x}"
        then show "y \<sqsubseteq> z"
        proof
          have y': "y \<in> Lower L A"
            apply (rule subsetD [where A = "Lower L (insert x A)"])
            apply (rule Lower_antimono)
             apply blast
            apply (rule y)
            done
          assume "z = a"
          with y' greatest_a show ?thesis by (fast dest: greatest_le)
        next
          assume "z \<in> {x}"
          with y L show ?thesis by blast
        qed
      qed (rule Lower_closed [THEN subsetD, OF y])
    next
      from L show "insert x A \<subseteq> carrier L" by simp
      from greatest_i show "i \<in> carrier L" by simp
    qed
  qed (rule P)
qed

lemma (in weak_lower_semilattice) finite_inf_greatest:
  "[| finite A; A \<subseteq> carrier L; A ~= {} |] ==> greatest L (\<Sqinter>A) (Lower L A)"
proof (induct set: finite)
  case empty then show ?case by simp
next
  case (insert x A)
  show ?case
  proof (cases "A = {}")
    case True
    with insert show ?thesis
      by simp (simp add: greatest_cong [OF weak_inf_of_singleton]
        inf_of_singleton_closed inf_of_singletonI)
  next
    case False
    from insert show ?thesis
    proof (rule_tac inf_insertI)
      from False insert show "greatest L (\<Sqinter>A) (Lower L A)" by simp
    qed simp_all
  qed
qed

lemma (in weak_lower_semilattice) finite_inf_insertI:
  assumes P: "!!i. greatest L i (Lower L (insert x A)) ==> P i"
    and xA: "finite A"  "x \<in> carrier L"  "A \<subseteq> carrier L"
  shows "P (\<Sqinter> (insert x A))"
proof (cases "A = {}")
  case True with P and xA show ?thesis
    by (simp add: finite_inf_greatest)
next
  case False with P and xA show ?thesis
    by (simp add: inf_insertI finite_inf_greatest)
qed

lemma (in weak_lower_semilattice) finite_inf_closed [simp]:
  "[| finite A; A \<subseteq> carrier L; A ~= {} |] ==> \<Sqinter>A \<in> carrier L"
proof (induct set: finite)
  case empty then show ?case by simp
next
  case insert then show ?case
    by (rule_tac finite_inf_insertI) (simp_all)
qed

lemma (in weak_lower_semilattice) meet_left:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqinter> y \<sqsubseteq> x"
  by (rule meetI [folded meet_def]) (blast dest: greatest_mem)

lemma (in weak_lower_semilattice) meet_right:
  "[| x \<in> carrier L; y \<in> carrier L |] ==> x \<sqinter> y \<sqsubseteq> y"
  by (rule meetI [folded meet_def]) (blast dest: greatest_mem)

lemma (in weak_lower_semilattice) inf_of_two_greatest:
  "[| x \<in> carrier L; y \<in> carrier L |] ==>
  greatest L (\<Sqinter> {x, y}) (Lower L {x, y})"
proof (unfold ainf_def)
  assume L: "x \<in> carrier L"  "y \<in> carrier L"
  with inf_of_two_exists obtain s where "greatest L s (Lower L {x, y})" by fast
  with L
  show "greatest L (SOME z. greatest L z (Lower L {x, y})) (Lower L {x, y})"
  by (fast intro: someI2 weak_greatest_unique)  (* blast fails *)
qed

lemma (in weak_lower_semilattice) meet_le:
  assumes sub: "z \<sqsubseteq> x"  "z \<sqsubseteq> y"
    and x: "x \<in> carrier L" and y: "y \<in> carrier L" and z: "z \<in> carrier L"
  shows "z \<sqsubseteq> x \<sqinter> y"
proof (rule meetI [OF _ x y])
  fix i
  assume "greatest L i (Lower L {x, y})"
  with sub z show "z \<sqsubseteq> i" by (fast elim: greatest_le intro: Lower_memI)
qed

lemma (in weak_lattice) weak_le_iff_join:
  assumes "x \<in> carrier L" "y \<in> carrier L"
  shows "x \<sqsubseteq> y \<longleftrightarrow> x .= (x \<sqinter> y)"
  by (meson assms(1) assms(2) local.le_refl local.le_trans meet_closed meet_le meet_left meet_right weak_le_antisym weak_refl)

lemma (in weak_lower_semilattice) weak_meet_assoc_lemma:
  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
  shows "x \<sqinter> (y \<sqinter> z) .= \<Sqinter>{x, y, z}"
proof (rule finite_inf_insertI)
  txt \<open> The textbook argument in Jacobson I, p 457 \<close>
  fix i
  assume inf: "greatest L i (Lower L {x, y, z})"
  show "x \<sqinter> (y \<sqinter> z) .= i"
  proof (rule weak_le_antisym)
    from inf L show "i \<sqsubseteq> x \<sqinter> (y \<sqinter> z)"
      by (fastforce intro!: meet_le elim: greatest_Lower_below)
  next
    from inf L show "x \<sqinter> (y \<sqinter> z) \<sqsubseteq> i"
    by (erule_tac greatest_le)
      (blast intro!: Lower_memI intro: le_trans meet_left meet_right meet_closed)
  qed (simp_all add: L greatest_closed [OF inf])
qed (simp_all add: L)

lemma (in weak_lower_semilattice) weak_meet_assoc:
  assumes L: "x \<in> carrier L"  "y \<in> carrier L"  "z \<in> carrier L"
  shows "(x \<sqinter> y) \<sqinter> z .= x \<sqinter> (y \<sqinter> z)"
proof -
  (* FIXME: improved simp, see weak_join_assoc above *)
  have "(x \<sqinter> y) \<sqinter> z = z \<sqinter> (x \<sqinter> y)" by (simp only: meet_comm)
  also from L have "... .= \<Sqinter> {z, x, y}" by (simp add: weak_meet_assoc_lemma)
  also from L have "... = \<Sqinter> {x, y, z}" by (simp add: insert_commute)
  also from L have "... .= x \<sqinter> (y \<sqinter> z)" by (simp add: weak_meet_assoc_lemma [symmetric])
  finally show ?thesis by (simp add: L)
qed

text \<open> Total orders are lattices. \<close>

sublocale weak_total_order < weak: weak_lattice
proof
  fix x y
  assume L: "x \<in> carrier L"  "y \<in> carrier L"
  show "EX s. least L s (Upper L {x, y})"
  proof -
    note total L
    moreover
    {
      assume "x \<sqsubseteq> y"
      with L have "least L y (Upper L {x, y})"
        by (rule_tac least_UpperI) auto
    }
    moreover
    {
      assume "y \<sqsubseteq> x"
      with L have "least L x (Upper L {x, y})"
        by (rule_tac least_UpperI) auto
    }
    ultimately show ?thesis by blast
  qed
next
  fix x y
  assume L: "x \<in> carrier L"  "y \<in> carrier L"
  show "EX i. greatest L i (Lower L {x, y})"
  proof -
    note total L
    moreover
    {
      assume "y \<sqsubseteq> x"
      with L have "greatest L y (Lower L {x, y})"
        by (rule_tac greatest_LowerI) auto
    }
    moreover
    {
      assume "x \<sqsubseteq> y"
      with L have "greatest L x (Lower L {x, y})"
        by (rule_tac greatest_LowerI) auto
    }
    ultimately show ?thesis by blast
  qed
qed

subsection \<open> Weak Bounded Lattices \<close>

locale weak_bounded_lattice =
  weak_lattice +
  weak_partial_order_bottom +
  weak_partial_order_top
begin

lemma bottom_meet: "x \<in> carrier L \<Longrightarrow> \<bottom> \<sqinter> x .= \<bottom>"
  by (metis bottom_least least_def meet_closed meet_left weak_le_antisym)

lemma bottom_join: "x \<in> carrier L \<Longrightarrow> \<bottom> \<squnion> x .= x"
  by (metis bottom_least join_closed join_le join_right le_refl least_def weak_le_antisym)

lemma bottom_weak_eq:
  "\<lbrakk> b \<in> carrier L; \<And> x. x \<in> carrier L \<Longrightarrow> b \<sqsubseteq> x \<rbrakk> \<Longrightarrow> b .= \<bottom>"
  by (metis bottom_closed bottom_lower weak_le_antisym)

lemma top_join: "x \<in> carrier L \<Longrightarrow> \<top> \<squnion> x .= \<top>"
  by (metis join_closed join_left top_closed top_higher weak_le_antisym)

lemma top_meet: "x \<in> carrier L \<Longrightarrow> \<top> \<sqinter> x .= x"
  by (metis le_refl meet_closed meet_le meet_right top_closed top_higher weak_le_antisym)

lemma top_weak_eq:  "\<lbrakk> t \<in> carrier L; \<And> x. x \<in> carrier L \<Longrightarrow> x \<sqsubseteq> t \<rbrakk> \<Longrightarrow> t .= \<top>"
  by (metis top_closed top_higher weak_le_antisym)

end

sublocale weak_bounded_lattice \<subseteq> weak_partial_order ..

subsection \<open> Lattices where @{text eq} is the Equality \<close>

locale upper_semilattice = partial_order +
  assumes sup_of_two_exists:
    "[| x \<in> carrier L; y \<in> carrier L |] ==> EX s. least L s (Upper L {x, y})"

sublocale upper_semilattice < weak: weak_upper_semilattice
  by unfold_locales (rule sup_of_two_exists)

locale lower_semilattice = partial_order +
  assumes inf_of_two_exists:
    "[| x \<in> carrier L; y \<in> carrier L |] ==> EX s. greatest L s (Lower L {x, y})"

sublocale lower_semilattice < weak: weak_lower_semilattice
  by unfold_locales (rule inf_of_two_exists)

locale lattice = upper_semilattice + lower_semilattice

sublocale lattice \<subseteq> weak_lattice ..

lemma (in lattice) dual_lattice:
  "lattice (inv_gorder L)"
proof -
  interpret dual: weak_lattice "inv_gorder L"
    by (metis dual_weak_lattice)

  show ?thesis
    apply (unfold_locales)
    apply (simp_all add: inf_of_two_exists sup_of_two_exists)
    apply (simp add:eq_is_equal)
  done
qed

lemma (in lattice) le_iff_join:
  assumes "x \<in> carrier L" "y \<in> carrier L"
  shows "x \<sqsubseteq> y \<longleftrightarrow> x = (x \<sqinter> y)"
  by (simp add: assms(1) assms(2) eq_is_equal weak_le_iff_join)

lemma (in lattice) le_iff_meet:
  assumes "x \<in> carrier L" "y \<in> carrier L"
  shows "x \<sqsubseteq> y \<longleftrightarrow> (x \<squnion> y) = y"
  by (simp add: assms(1) assms(2) eq_is_equal weak_le_iff_meet)

text \<open> Total orders are lattices. \<close>

sublocale total_order < weak: lattice
  by standard (auto intro: weak.weak.sup_of_two_exists weak.weak.inf_of_two_exists)

text \<open> Functions that preserve joins and meets \<close>

definition join_pres :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
"join_pres X Y f \<equiv> lattice X \<and> lattice Y \<and> (\<forall> x \<in> carrier X. \<forall> y \<in> carrier X. f (x \<squnion>\<^bsub>X\<^esub> y) = f x \<squnion>\<^bsub>Y\<^esub> f y)"

definition meet_pres :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
"meet_pres X Y f \<equiv> lattice X \<and> lattice Y \<and> (\<forall> x \<in> carrier X. \<forall> y \<in> carrier X. f (x \<sqinter>\<^bsub>X\<^esub> y) = f x \<sqinter>\<^bsub>Y\<^esub> f y)"

lemma join_pres_isotone:
  assumes "f \<in> carrier X \<rightarrow> carrier Y" "join_pres X Y f"
  shows "isotone X Y f"
  using assms
  apply (rule_tac isotoneI)
  apply (auto simp add: join_pres_def lattice.le_iff_meet funcset_carrier)
  using lattice_def partial_order_def upper_semilattice_def apply blast
  using lattice_def partial_order_def upper_semilattice_def apply blast
  apply fastforce
done

lemma meet_pres_isotone:
  assumes "f \<in> carrier X \<rightarrow> carrier Y" "meet_pres X Y f"
  shows "isotone X Y f"
  using assms
  apply (rule_tac isotoneI)
  apply (auto simp add: meet_pres_def lattice.le_iff_join funcset_carrier)
  using lattice_def partial_order_def upper_semilattice_def apply blast
  using lattice_def partial_order_def upper_semilattice_def apply blast
  apply fastforce
done

subsection \<open> Bounded Lattices \<close>

locale bounded_lattice =
  lattice +
  weak_partial_order_bottom +
  weak_partial_order_top

sublocale bounded_lattice \<subseteq> weak_bounded_lattice ..

context bounded_lattice
begin

lemma bottom_eq:
  "\<lbrakk> b \<in> carrier L; \<And> x. x \<in> carrier L \<Longrightarrow> b \<sqsubseteq> x \<rbrakk> \<Longrightarrow> b = \<bottom>"
  by (metis bottom_closed bottom_lower le_antisym)

lemma top_eq:  "\<lbrakk> t \<in> carrier L; \<And> x. x \<in> carrier L \<Longrightarrow> x \<sqsubseteq> t \<rbrakk> \<Longrightarrow> t = \<top>"
  by (metis le_antisym top_closed top_higher)

end

end