section \<open>Boolos Curious Proof Problem\<close>

theory Boolos_Curious_Inference_Automated imports Main
begin   (* sledgehammer_params[timeout=60] *)

text\<open>First declare a non-empty type @{term "i"} of objects (natural numbers in the context of this paper).\<close>
typedecl i

text \<open>The signature for BCP consists of four uninterpreted constant symbols.\<close>
consts
 e :: "i" ("\<^bold>e")  \<comment>\<open>one\<close>
 s :: "i\<Rightarrow>i" ("\<^bold>s_")  \<comment>\<open>successor function\<close>
 f :: "i\<Rightarrow>i\<Rightarrow>i" ("\<^bold>f__")  \<comment>\<open>binary function; axiomatised below as Ackermann function\<close>
 d :: "i\<Rightarrow>bool" ("\<^bold>d_")  \<comment>\<open>arbitrary uninterpreted unary predicate\<close>

text \<open>Axioms @{term "A1"}-@{term "A3"} model the Ackermann function and Axioms @{term "A4"} and @{term "A5"}
stipulate the properties of predicate @{term "d"}.\<close>
axiomatization where
A1: "\<forall>n. \<^bold>fn\<^bold>e = \<^bold>s\<^bold>e"  and   \<comment>\<open>Axiom 1 for Ackermann function @{term "f"}\<close>
A2: "\<forall>y. \<^bold>f\<^bold>e\<^bold>sy = \<^bold>s\<^bold>s\<^bold>f\<^bold>ey"  and   \<comment>\<open>Axiom 2 for Ackermann function @{term "f"}\<close>
A3: "\<forall>x y. \<^bold>f\<^bold>sx\<^bold>sy = \<^bold>fx\<^bold>f(\<^bold>sx)y"  and  \<comment>\<open>Axiom 3 for Ackermann function @{term "f"}\<close>
A4: "\<^bold>d\<^bold>e"  and  \<comment>\<open>@{term "d"} (an arbitrary predicate) holds for one\<close>
A5: "\<forall>x. \<^bold>dx \<longrightarrow> \<^bold>d\<^bold>sx"  \<comment>\<open>if @{term "d"} holds for @{term "x"} it also holds for the successor of @{term "x"}\<close>

text \<open>Trying to prove automatically with \textit{Sledgehammer} @{cite Sledgehammer} that @{term "d"} holds
for fssssesssse still fails at this point. As Boolos'
explains, a naive first-order proof would require more modus ponens steps (with A5 and A4) than
there are atoms in the
universe.\<close>
lemma "\<^bold>d\<^bold>f\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e" \<comment>\<open>sledgehammer\<close> oops  \<comment>\<open>no proof found; timeout\<close>

section \<open>Automated Proof: Using Two Definitions\<close>

text \<open>We interactively provide two shorthand notations @{term "ind"} and @{term "p"}. After their
introduction a proof can be found fully automatically with \textit{Sledgehammer}. @{term "ind X"}
is defined to hold if
and only if  @{term "X"} is `inductive' over  @{term "e"} and  @{term "s"}.
 @{term "pxy"} holds if and only if @{term "pxy"} is in smallest inductive set
over  @{term "e"} and  @{term "s"}.
Note that the symbols @{term "ind"} and @{term "p"} do not occur in the BCP problem
statement.\<close>
definition ind ("\<^bold>i\<^bold>n\<^bold>d_") where "ind \<equiv> \<lambda>X. X\<^bold>e \<and> (\<forall>x. X x \<longrightarrow> X \<^bold>sx)"
definition p ("\<^bold>p_") where "p \<equiv> \<lambda>x y. (\<lambda>z::i. (\<forall>X. \<^bold>i\<^bold>n\<^bold>d X \<longrightarrow> X z)) \<^bold>f x y"

text \<open>Using these definitions, state-of-art higher-order ATPs integrated with Isabelle/HOL can now fully
automatically prove Boolos' Curious Problem:\<close>
theorem "\<^bold>d\<^bold>f\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e"  \<comment>\<open>@{term sledgehammer}\<close> (*
   sledgehammer [z3]  (* z3 found a proof... *)
   sledgehammer [vampire]  (* vampire found a proof... *)
   sledgehammer [remote_leo2]  (* remote_leo2 found a proof... *)
   sledgehammer [e] (* e found a proof ... *)
   sledgehammer [zipperposition]  (* zipperposition found a proof... *)
   sledgehammer [cvc4]  (* No proof found *)
   sledgehammer [verit] (* No proof found *)
   sledgehammer [spass] (* No proof found *)
   sledgehammer [remote_leo3]  (* No proof found *)  *)
 by (metis A1 A2 A3 A4 A5 ind_def p_def)  \<comment>\<open>metis proof reconstruction succeeds\<close>

text \<open>In experiments (using a MacBook Pro (16-inch, 2019), 2,6 GHz 6-Core Intel Core i7,
16 GB 2667 MHz DDR4) running Isabelle2022 automatically found proofs were reported by various theorem
provers, including
@{term "Z3"} @{cite Z3},
@{term "Vampire"} @{cite Vampire},
@{term "Zipperposition"} @{cite Zipperpin},
@{term "E"} @{cite Eprover},
and Leo-II (@{term "remote_leo2"}) @{cite Leo2}.\<close>

section \<open>Automated Proof: Using a Single Definition\<close>

definition p' ("\<^bold>p'_") where
  "p' \<equiv> \<lambda>x y. (\<lambda>z::i. (\<forall>X. (X\<^bold>e \<and> (\<forall>x. X x \<longrightarrow> X \<^bold>sx)) \<longrightarrow> X z)) \<^bold>f x y"

theorem "\<^bold>d\<^bold>f\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e"  \<comment>\<open>@{term "sledgehammer (A1 A2 A3 A4 A5 p'_def)"}\<close>  (*
  sledgehammer[remote_leo2]  (A1 A2 A3 A4 A5 p'_def)
 \<comment>\<open>sledgehammer [z3] (A1 A2 A3 A4 A5 p'\_def)   (* z3 found a proof... *)
   sledgehammer [vampire] (A1 A2 A3 A4 A5 p'\_def)  (* vampire found a proof... *)
   sledgehammer [remote\_leo2] (A1 A2 A3 A4 A5 p'\_def)  (* remote\_leo2 found a proof... *)
   sledgehammer [zipperposition] (A1 A2 A3 A4 A5 p'\_def)  (* zipperposition found a proof... *)
   sledgehammer [e] (A1 A2 A3 A4 A5 p'\_def)  (* e found a proof ... *)
   sledgehammer [cvc4] (A1 A2 A3 A4 A5 p'\_def)  (* No proof found *)
   sledgehammer [verit] (A1 A2 A3 A4 A5 p'\_def)  (* No proof found *)
   sledgehammer [spass] (A1 A2 A3 A4 A5 p'\_def)  (* No proof found *)
   sledgehammer [remote\_leo3] (A1 A2 A3 A4 A5 p'\_def)  (* No proof found *)\<close> *)
  by (smt A1 A2 A3 A4 A5 p'_def)  \<comment>\<open>smt proof reconstruction succeeds\<close>

text \<open>In experiments (using the same environment as above) several provers reported
proofs, including @{term "Z3"} and @{term "E"}.\<close>

section\<open>Proof Reconstruction: E's Proof from @{cite BCI}\<close>
text \<open>In this section we reconstruct and verify in Isabelle/HOL the proof argument found by E
as reported in @{cite BCI}. Analysing E's proof we can identify the following five lemmata:\<close>
lemma L1a: "\<^bold>i\<^bold>n\<^bold>d d" by (simp add: A4 A5 ind_def)
lemma L1b: "\<forall>x. \<^bold>px\<^bold>e" by (simp add: A1 ind_def p_def)
lemma L1c: "\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>e" by (metis A2 L1b ind_def p_def)
lemma L2: "\<forall>x Y. (\<^bold>i\<^bold>n\<^bold>d \<^bold>px \<and> \<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>sx \<and> \<^bold>i\<^bold>n\<^bold>d Y) \<longrightarrow> Y\<^bold>f\<^bold>sx\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e" by (metis ind_def p_def)
lemma L3: "\<forall>x. \<^bold>i\<^bold>n\<^bold>d \<^bold>px \<longrightarrow> \<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>sx" by (metis A3 L1b ind_def p_def)

text \<open>Using these lemmata E then constructs the following refutation argument:\<close>
theorem "\<^bold>d\<^bold>f\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e"
  proof -
    { assume L4: "\<not>\<^bold>d\<^bold>f\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e"
      have L5: "\<not>\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e \<or> \<not>\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>s\<^bold>e" using L1a L1b L1c L2 L4 by blast
      have L6: "\<not>\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>s\<^bold>e \<and> \<not>\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>e \<and> \<not>\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>e" using L3 L5 by blast
      have "False" using L1c L3 L6 by auto
    }
  then show ?thesis by blast
  qed

text \<open>This refutation argument can alternatively be replaced by:\<close>
theorem "\<^bold>d\<^bold>f\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e"
  proof -
    have L7: "\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>e" using L1c L3 by blast
    have L8: "\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>e" using L3 L7 by blast
    have L9: "\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>s\<^bold>e" using L3 L8 by blast
    have L10: "\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e" using L3 L9 by blast
    have L11: "(\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>s\<^bold>e \<and> \<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e \<and> \<^bold>i\<^bold>n\<^bold>d d)" using L10 L1a L9 by blast
  then show ?thesis using L2 by blast
qed

text \<open>Lemma @{term "L2"} can actually be simplified (this was also hinted at by an anonymous
reviewer of @{cite J63}):\<close>
lemma L2_1: "\<forall>x Y. (\<^bold>i\<^bold>n\<^bold>d \<^bold>px \<and> \<^bold>i\<^bold>n\<^bold>d Y) \<longrightarrow> Y\<^bold>fx\<^bold>e" by (metis ind_def p_def)
lemma L2_2: "\<forall>x Y. (\<^bold>i\<^bold>n\<^bold>d \<^bold>px \<and> \<^bold>i\<^bold>n\<^bold>d Y) \<longrightarrow> Y\<^bold>fx\<^bold>s\<^bold>e" by (metis ind_def p_def)
lemma L2_3: "\<forall>x Y. (\<^bold>i\<^bold>n\<^bold>d \<^bold>px \<and> \<^bold>i\<^bold>n\<^bold>d Y) \<longrightarrow> Y\<^bold>fx\<^bold>s\<^bold>s\<^bold>e" by (metis ind_def p_def)
lemma L2_4: "\<forall>x Y. (\<^bold>i\<^bold>n\<^bold>d \<^bold>px \<and> \<^bold>i\<^bold>n\<^bold>d Y) \<longrightarrow> Y\<^bold>fx\<^bold>s\<^bold>s\<^bold>s\<^bold>e" by (metis ind_def p_def)
lemma L2_5: "\<forall>x Y. (\<^bold>i\<^bold>n\<^bold>d \<^bold>px \<and> \<^bold>i\<^bold>n\<^bold>d Y) \<longrightarrow> Y\<^bold>fx\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e" by (metis ind_def p_def)
text \<open>etc.\<close>

text \<open>The following statement, however, has a countermodel.\<close>
lemma L2_1: "\<forall>x y Y. (\<^bold>i\<^bold>n\<^bold>d \<^bold>px \<and> \<^bold>i\<^bold>n\<^bold>d Y) \<longrightarrow> Y\<^bold>f x y"
  nitpick[user_axioms,expect=genuine] oops \<comment>\<open>countermodel by nitpick\<close>

  text \<open>Instead of using @{term "L2"} we can now use @{term "L2_5"} in our proof of BCP from above:\<close>

theorem "\<^bold>d\<^bold>f\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e"
  proof -
    have L7: "\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>e" using L1c L3 by blast
    have L8: "\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>e" using L3 L7 by blast
    have L9: "\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>s\<^bold>e" using L3 L8 by blast
    have L10: "\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e" using L3 L9 by blast
    have L11: "(\<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>s\<^bold>e \<and> \<^bold>i\<^bold>n\<^bold>d \<^bold>p\<^bold>s\<^bold>s\<^bold>s\<^bold>s\<^bold>e \<and> \<^bold>i\<^bold>n\<^bold>d d)" using L10 L1a L9 by blast
  then show ?thesis using L2_5 by blast
qed

section\<open>Conclusion\<close>
text \<open>Isabelle/HOL data sources were provided in relation to @{cite J63}, which describes recent progress
and remaining challenges in automating Boolos' Curious Problem.
The interactive introduction of lemmas, as still exercised in @{cite KetlandAFP} and earlier
in @{cite BoolosOmegaMizar}, is no longer necessary, since higher-order theorem provers are
now able to speculate the required lemmas automatically, provided that appropriate shorthand
notations are provided (see the definitions of @{term "ind"} and @{term "p"}).

Since Boolos' example for speeding up proofs is interesting in several respects, it is now being used as
an exercise in lecture courses at several universities (including University of Bamberg, University
of Greifswald, University of Luxembourg, Free University of Berlin); having our source files
permanently maintained in AFP hence makes sense.\<close>

end


section \<open>Neighbourhood bases and Locally path-connected spaces\<close>

theory Locally
  imports
    Path_Connected Function_Topology
begin

subsection\<open>Neighbourhood Bases\<close>

text \<open>Useful for "local" properties of various kinds\<close>

definition neighbourhood_base_at where
 "neighbourhood_base_at x P X \<equiv>
        \<forall>W. openin X W \<and> x \<in> W
            \<longrightarrow> (\<exists>U V. openin X U \<and> P V \<and> x \<in> U \<and> U \<subseteq> V \<and> V \<subseteq> W)"

definition neighbourhood_base_of where
 "neighbourhood_base_of P X \<equiv>
        \<forall>x \<in> topspace X. neighbourhood_base_at x P X"

lemma neighbourhood_base_of:
   "neighbourhood_base_of P X \<longleftrightarrow>
        (\<forall>W x. openin X W \<and> x \<in> W
          \<longrightarrow> (\<exists>U V. openin X U \<and> P V \<and> x \<in> U \<and> U \<subseteq> V \<and> V \<subseteq> W))"
  unfolding neighbourhood_base_at_def neighbourhood_base_of_def
  using openin_subset by blast

lemma neighbourhood_base_at_mono:
   "\<lbrakk>neighbourhood_base_at x P X; \<And>S. \<lbrakk>P S; x \<in> S\<rbrakk> \<Longrightarrow> Q S\<rbrakk> \<Longrightarrow> neighbourhood_base_at x Q X"
  unfolding neighbourhood_base_at_def
  by (meson subset_eq)

lemma neighbourhood_base_of_mono:
   "\<lbrakk>neighbourhood_base_of P X; \<And>S. P S \<Longrightarrow> Q S\<rbrakk> \<Longrightarrow> neighbourhood_base_of Q X"
  unfolding neighbourhood_base_of_def
  using neighbourhood_base_at_mono by force

lemma open_neighbourhood_base_at:
   "(\<And>S. \<lbrakk>P S; x \<in> S\<rbrakk> \<Longrightarrow> openin X S)
        \<Longrightarrow> neighbourhood_base_at x P X \<longleftrightarrow> (\<forall>W. openin X W \<and> x \<in> W \<longrightarrow> (\<exists>U. P U \<and> x \<in> U \<and> U \<subseteq> W))"
  unfolding neighbourhood_base_at_def
  by (meson subsetD)

lemma open_neighbourhood_base_of:
  "(\<forall>S. P S \<longrightarrow> openin X S)
        \<Longrightarrow> neighbourhood_base_of P X \<longleftrightarrow> (\<forall>W x. openin X W \<and> x \<in> W \<longrightarrow> (\<exists>U. P U \<and> x \<in> U \<and> U \<subseteq> W))"
  apply (simp add: neighbourhood_base_of, safe, blast)
  by meson

lemma neighbourhood_base_of_open_subset:
   "\<lbrakk>neighbourhood_base_of P X; openin X S\<rbrakk>
        \<Longrightarrow> neighbourhood_base_of P (subtopology X S)"
  apply (clarsimp simp add: neighbourhood_base_of openin_subtopology_alt image_def)
  apply (rename_tac x V)
  apply (drule_tac x="S \<inter> V" in spec)
  apply (simp add: Int_ac)
  by (metis IntI le_infI1 openin_Int)

lemma neighbourhood_base_of_topology_base:
   "openin X = arbitrary union_of (\<lambda>W. W \<in> \<B>)
        \<Longrightarrow> neighbourhood_base_of P X \<longleftrightarrow>
             (\<forall>W x. W \<in> \<B> \<and> x \<in> W  \<longrightarrow> (\<exists>U V. openin X U \<and> P V \<and> x \<in> U \<and> U \<subseteq> V \<and> V \<subseteq> W))"
  apply (auto simp: openin_topology_base_unique neighbourhood_base_of)
  by (meson subset_trans)

lemma neighbourhood_base_at_unlocalized:
  assumes "\<And>S T. \<lbrakk>P S; openin X T; x \<in> T; T \<subseteq> S\<rbrakk> \<Longrightarrow> P T"
  shows "neighbourhood_base_at x P X
     \<longleftrightarrow> (x \<in> topspace X \<longrightarrow> (\<exists>U V. openin X U \<and> P V \<and> x \<in> U \<and> U \<subseteq> V \<and> V \<subseteq> topspace X))"
         (is "?lhs = ?rhs")
proof
  assume R: ?rhs show ?lhs
    unfolding neighbourhood_base_at_def
  proof clarify
    fix W
    assume "openin X W" "x \<in> W"
    then have "x \<in> topspace X"
      using openin_subset by blast
    with R obtain U V where "openin X U" "P V" "x \<in> U" "U \<subseteq> V" "V \<subseteq> topspace X"
      by blast
    then show "\<exists>U V. openin X U \<and> P V \<and> x \<in> U \<and> U \<subseteq> V \<and> V \<subseteq> W"
      by (metis IntI \<open>openin X W\<close> \<open>x \<in> W\<close> assms inf_le1 inf_le2 openin_Int)
  qed
qed (simp add: neighbourhood_base_at_def)

lemma neighbourhood_base_at_with_subset:
   "\<lbrakk>openin X U; x \<in> U\<rbrakk>
        \<Longrightarrow> (neighbourhood_base_at x P X \<longleftrightarrow> neighbourhood_base_at x (\<lambda>T. T \<subseteq> U \<and> P T) X)"
  apply (simp add: neighbourhood_base_at_def)
  apply (metis IntI Int_subset_iff openin_Int)
  done

lemma neighbourhood_base_of_with_subset:
   "neighbourhood_base_of P X \<longleftrightarrow> neighbourhood_base_of (\<lambda>t. t \<subseteq> topspace X \<and> P t) X"
  using neighbourhood_base_at_with_subset
  by (fastforce simp add: neighbourhood_base_of_def)

subsection\<open>Locally path-connected spaces\<close>

definition weakly_locally_path_connected_at
  where "weakly_locally_path_connected_at x X \<equiv> neighbourhood_base_at x (path_connectedin X) X"

definition locally_path_connected_at
  where "locally_path_connected_at x X \<equiv>
    neighbourhood_base_at x (\<lambda>U. openin X U \<and> path_connectedin X U) X"

definition locally_path_connected_space
  where "locally_path_connected_space X \<equiv> neighbourhood_base_of (path_connectedin X) X"

lemma locally_path_connected_space_alt:
  "locally_path_connected_space X \<longleftrightarrow> neighbourhood_base_of (\<lambda>U. openin X U \<and> path_connectedin X U) X"
  (is "?P = ?Q")
  and locally_path_connected_space_eq_open_path_component_of:
  "locally_path_connected_space X \<longleftrightarrow>
        (\<forall>U x. openin X U \<and> x \<in> U \<longrightarrow> openin X (Collect (path_component_of (subtopology X U) x)))"
  (is "?P = ?R")
proof -
  have ?P if ?Q
    using locally_path_connected_space_def neighbourhood_base_of_mono that by auto
  moreover have ?R if P: ?P
  proof -
    show ?thesis
    proof clarify
      fix U y
      assume "openin X U" "y \<in> U"
      have "\<exists>T. openin X T \<and> x \<in> T \<and> T \<subseteq> Collect (path_component_of (subtopology X U) y)"
        if "path_component_of (subtopology X U) y x" for x

      proof -
        have "x \<in> U"
          using path_component_of_equiv that topspace_subtopology by fastforce
        then have "\<exists>Ua. openin X Ua \<and> (\<exists>V. path_connectedin X V \<and> x \<in> Ua \<and> Ua \<subseteq> V \<and> V \<subseteq> U)"
      using P
      by (simp add: \<open>openin X U\<close> locally_path_connected_space_def neighbourhood_base_of)
        then show ?thesis
          by (metis dual_order.trans path_component_of_equiv path_component_of_maximal path_connectedin_subtopology subset_iff that)
      qed
      then show "openin X (Collect (path_component_of (subtopology X U) y))"
        using openin_subopen by force
    qed
  qed
  moreover have ?Q if ?R
    using that
    apply (simp add: open_neighbourhood_base_of)
    by (metis mem_Collect_eq openin_subset path_component_of_refl path_connectedin_path_component_of path_connectedin_subtopology that topspace_subtopology_subset)
  ultimately show "?P = ?Q" "?P = ?R"
    by blast+
qed

lemma locally_path_connected_space:
   "locally_path_connected_space X
   \<longleftrightarrow> (\<forall>V x. openin X V \<and> x \<in> V \<longrightarrow> (\<exists>U. openin X U \<and> path_connectedin X U \<and> x \<in> U \<and> U \<subseteq> V))"
  by (simp add: locally_path_connected_space_alt open_neighbourhood_base_of)

lemma locally_path_connected_space_open_path_components:
   "locally_path_connected_space X \<longleftrightarrow>
        (\<forall>U c. openin X U \<and> c \<in> path_components_of(subtopology X U) \<longrightarrow> openin X c)"
  apply (auto simp: locally_path_connected_space_eq_open_path_component_of path_components_of_def)
  by (metis imageI inf.absorb_iff2 openin_closedin_eq)

lemma openin_path_component_of_locally_path_connected_space:
   "locally_path_connected_space X \<Longrightarrow> openin X (Collect (path_component_of X x))"
  apply (auto simp: locally_path_connected_space_eq_open_path_component_of)
  by (metis openin_empty openin_topspace path_component_of_eq_empty subtopology_topspace)

lemma openin_path_components_of_locally_path_connected_space:
   "\<lbrakk>locally_path_connected_space X; c \<in> path_components_of X\<rbrakk> \<Longrightarrow> openin X c"
  apply (auto simp: locally_path_connected_space_eq_open_path_component_of)
  by (metis (no_types, lifting) imageE openin_topspace path_components_of_def subtopology_topspace)

lemma closedin_path_components_of_locally_path_connected_space:
   "\<lbrakk>locally_path_connected_space X; c \<in> path_components_of X\<rbrakk> \<Longrightarrow> closedin X c"
  by (simp add: closedin_def complement_path_components_of_Union openin_path_components_of_locally_path_connected_space openin_clauses(3) path_components_of_subset)

lemma closedin_path_component_of_locally_path_connected_space:
  assumes "locally_path_connected_space X"
  shows "closedin X (Collect (path_component_of X x))"
proof (cases "x \<in> topspace X")
  case True
  then show ?thesis
    by (simp add: assms closedin_path_components_of_locally_path_connected_space path_component_in_path_components_of)
next
  case False
  then show ?thesis
    by (metis closedin_empty path_component_of_eq_empty)
qed

lemma weakly_locally_path_connected_at:
   "weakly_locally_path_connected_at x X \<longleftrightarrow>
    (\<forall>V. openin X V \<and> x \<in> V
          \<longrightarrow> (\<exists>U. openin X U \<and> x \<in> U \<and> U \<subseteq> V \<and>
                  (\<forall>y \<in> U. \<exists>C. path_connectedin X C \<and> C \<subseteq> V \<and> x \<in> C \<and> y \<in> C)))"
         (is "?lhs = ?rhs")
proof
  assume ?lhs then show ?rhs
    apply (simp add: weakly_locally_path_connected_at_def neighbourhood_base_at_def)
    by (meson order_trans subsetD)
next
  have *: "\<exists>V. path_connectedin X V \<and> U \<subseteq> V \<and> V \<subseteq> W"
    if "(\<forall>y\<in>U. \<exists>C. path_connectedin X C \<and> C \<subseteq> W \<and> x \<in> C \<and> y \<in> C)"
    for W U
  proof (intro exI conjI)
    let ?V = "(Collect (path_component_of (subtopology X W) x))"
      show "path_connectedin X (Collect (path_component_of (subtopology X W) x))"
        by (meson path_connectedin_path_component_of path_connectedin_subtopology)
      show "U \<subseteq> ?V"
        by (auto simp: path_component_of path_connectedin_subtopology that)
      show "?V \<subseteq> W"
        by (meson path_connectedin_path_component_of path_connectedin_subtopology)
    qed
  assume ?rhs
  then show ?lhs
    unfolding weakly_locally_path_connected_at_def neighbourhood_base_at_def by (metis "*")
qed

lemma locally_path_connected_space_im_kleinen:
   "locally_path_connected_space X \<longleftrightarrow>
      (\<forall>V x. openin X V \<and> x \<in> V
             \<longrightarrow> (\<exists>U. openin X U \<and>
                    x \<in> U \<and> U \<subseteq> V \<and>
                    (\<forall>y \<in> U. \<exists>c. path_connectedin X c \<and>
                                c \<subseteq> V \<and> x \<in> c \<and> y \<in> c)))"
  apply (simp add: locally_path_connected_space_def neighbourhood_base_of_def)
  apply (simp add: weakly_locally_path_connected_at flip: weakly_locally_path_connected_at_def)
  using openin_subset apply force
  done

lemma locally_path_connected_space_open_subset:
   "\<lbrakk>locally_path_connected_space X; openin X s\<rbrakk>
        \<Longrightarrow> locally_path_connected_space (subtopology X s)"
  apply (simp add: locally_path_connected_space_def neighbourhood_base_of openin_open_subtopology path_connectedin_subtopology)
  by (meson order_trans)

lemma locally_path_connected_space_quotient_map_image:
  assumes f: "quotient_map X Y f" and X: "locally_path_connected_space X"
  shows "locally_path_connected_space Y"
  unfolding locally_path_connected_space_open_path_components
proof clarify
  fix V C
  assume V: "openin Y V" and c: "C \<in> path_components_of (subtopology Y V)"
  then have sub: "C \<subseteq> topspace Y"
    using path_connectedin_path_components_of path_connectedin_subset_topspace path_connectedin_subtopology by blast
  have "openin X {x \<in> topspace X. f x \<in> C}"
  proof (subst openin_subopen, clarify)
    fix x
    assume x: "x \<in> topspace X" and "f x \<in> C"
    let ?T = "Collect (path_component_of (subtopology X {z \<in> topspace X. f z \<in> V}) x)"
    show "\<exists>T. openin X T \<and> x \<in> T \<and> T \<subseteq> {x \<in> topspace X. f x \<in> C}"
    proof (intro exI conjI)
      have "\<exists>U. openin X U \<and> ?T \<in> path_components_of (subtopology X U)"
      proof (intro exI conjI)
        show "openin X ({z \<in> topspace X. f z \<in> V})"
          using V f openin_subset quotient_map_def by fastforce
        show "Collect (path_component_of (subtopology X {z \<in> topspace X. f z \<in> V}) x)
        \<in> path_components_of (subtopology X {z \<in> topspace X. f z \<in> V})"
          by (metis (no_types, lifting) Int_iff \<open>f x \<in> C\<close> c mem_Collect_eq path_component_in_path_components_of path_components_of_subset topspace_subtopology topspace_subtopology_subset x)
      qed
      with X show "openin X ?T"
        using locally_path_connected_space_open_path_components by blast
      show x: "x \<in> ?T"
        using V \<open>f x \<in> C\<close> c openin_subset path_component_of_equiv path_components_of_subset topspace_subtopology topspace_subtopology_subset x
        by fastforce
      have "f ` ?T \<subseteq> C"
      proof (rule path_components_of_maximal)
        show "C \<in> path_components_of (subtopology Y V)"
          by (simp add: c)
        show "path_connectedin (subtopology Y V) (f ` ?T)"
        proof -
          have "quotient_map (subtopology X {a \<in> topspace X. f a \<in> V}) (subtopology Y V) f"
            by (simp add: V f quotient_map_restriction)
          then show ?thesis
            by (meson path_connectedin_continuous_map_image path_connectedin_path_component_of quotient_imp_continuous_map)
        qed
        show "\<not> disjnt C (f ` ?T)"
          by (metis (no_types, lifting) \<open>f x \<in> C\<close> x disjnt_iff image_eqI)
      qed
      then show "?T \<subseteq> {x \<in> topspace X. f x \<in> C}"
        by (force simp: path_component_of_equiv)
    qed
  qed
  then show "openin Y C"
    using f sub by (simp add: quotient_map_def)
qed

lemma homeomorphic_locally_path_connected_space:
  assumes "X homeomorphic_space Y"
  shows "locally_path_connected_space X \<longleftrightarrow> locally_path_connected_space Y"
proof -
  obtain f g where "homeomorphic_maps X Y f g"
    using assms homeomorphic_space_def by fastforce
  then show ?thesis
    by (metis (no_types) homeomorphic_map_def homeomorphic_maps_map locally_path_connected_space_quotient_map_image)
qed

lemma locally_path_connected_space_retraction_map_image:
   "\<lbrakk>retraction_map X Y r; locally_path_connected_space X\<rbrakk>
        \<Longrightarrow> locally_path_connected_space Y"
  using Abstract_Topology.retraction_imp_quotient_map locally_path_connected_space_quotient_map_image by blast

lemma locally_path_connected_space_euclideanreal: "locally_path_connected_space euclideanreal"
  unfolding locally_path_connected_space_def neighbourhood_base_of
  proof clarsimp
  fix W and x :: "real"
  assume "open W" "x \<in> W"
  then obtain e where "e > 0" and e: "\<And>x'. \<bar>x' - x\<bar> < e \<longrightarrow> x' \<in> W"
    by (auto simp: open_real)
  then show "\<exists>U. open U \<and> (\<exists>V. path_connected V \<and> x \<in> U \<and> U \<subseteq> V \<and> V \<subseteq> W)"
    by (force intro!: convex_imp_path_connected exI [where x = "{x-e<..<x+e}"])
qed

lemma locally_path_connected_space_discrete_topology:
   "locally_path_connected_space (discrete_topology U)"
  using locally_path_connected_space_open_path_components by fastforce

lemma path_component_eq_connected_component_of:
  assumes "locally_path_connected_space X"
  shows "(path_component_of_set X x = connected_component_of_set X x)"
proof (cases "x \<in> topspace X")
  case True
  then show ?thesis
    using connectedin_connected_component_of [of X x]
    apply (clarsimp simp add: connectedin_def connected_space_clopen_in topspace_subtopology_subset cong: conj_cong)
    apply (drule_tac x="path_component_of_set X x" in spec)
    by (metis assms closedin_closed_subtopology closedin_connected_component_of closedin_path_component_of_locally_path_connected_space inf.absorb_iff2 inf.orderE openin_path_component_of_locally_path_connected_space openin_subtopology path_component_of_eq_empty path_component_subset_connected_component_of)
next
  case False
  then show ?thesis
    using connected_component_of_eq_empty path_component_of_eq_empty by fastforce
qed

lemma path_components_eq_connected_components_of:
   "locally_path_connected_space X \<Longrightarrow> (path_components_of X = connected_components_of X)"
  by (simp add: path_components_of_def connected_components_of_def image_def path_component_eq_connected_component_of)

lemma path_connected_eq_connected_space:
   "locally_path_connected_space X
         \<Longrightarrow> path_connected_space X \<longleftrightarrow> connected_space X"
  by (metis connected_components_of_subset_sing path_components_eq_connected_components_of path_components_of_subset_singleton)

lemma locally_path_connected_space_product_topology:
   "locally_path_connected_space(product_topology X I) \<longleftrightarrow>
        topspace(product_topology X I) = {} \<or>
        finite {i. i \<in> I \<and> ~path_connected_space(X i)} \<and>
        (\<forall>i \<in> I. locally_path_connected_space(X i))"
    (is "?lhs \<longleftrightarrow> ?empty \<or> ?rhs")
proof (cases ?empty)
  case True
  then show ?thesis
    by (simp add: locally_path_connected_space_def neighbourhood_base_of openin_closedin_eq)
next
  case False
  then obtain z where z: "z \<in> (\<Pi>\<^sub>E i\<in>I. topspace (X i))"
    by auto
  have ?rhs if L: ?lhs
  proof -
    obtain U C where U: "openin (product_topology X I) U"
      and V: "path_connectedin (product_topology X I) C"
      and "z \<in> U" "U \<subseteq> C" and Csub: "C \<subseteq> (\<Pi>\<^sub>E i\<in>I. topspace (X i))"
      using L apply (clarsimp simp add: locally_path_connected_space_def neighbourhood_base_of)
      by (metis openin_topspace topspace_product_topology z)
    then obtain V where finV: "finite {i \<in> I. V i \<noteq> topspace (X i)}"
      and XV: "\<And>i. i\<in>I \<Longrightarrow> openin (X i) (V i)" and "z \<in> Pi\<^sub>E I V" and subU: "Pi\<^sub>E I V \<subseteq> U"
      by (force simp: openin_product_topology_alt)
    show ?thesis
    proof (intro conjI ballI)
      have "path_connected_space (X i)" if "i \<in> I" "V i = topspace (X i)" for i
      proof -
        have pc: "path_connectedin (X i) ((\<lambda>x. x i) ` C)"
          apply (rule path_connectedin_continuous_map_image [OF _ V])
          by (simp add: continuous_map_product_projection \<open>i \<in> I\<close>)
        moreover have "((\<lambda>x. x i) ` C) = topspace (X i)"
        proof
          show "(\<lambda>x. x i) ` C \<subseteq> topspace (X i)"
            by (simp add: pc path_connectedin_subset_topspace)
          have "V i \<subseteq> (\<lambda>x. x i) ` (\<Pi>\<^sub>E i\<in>I. V i)"
            by (metis \<open>z \<in> Pi\<^sub>E I V\<close> empty_iff image_projection_PiE order_refl that(1))
          also have "\<dots> \<subseteq> (\<lambda>x. x i) ` U"
            using subU by blast
          finally show "topspace (X i) \<subseteq> (\<lambda>x. x i) ` C"
            using \<open>U \<subseteq> C\<close> that by blast
        qed
        ultimately show ?thesis
          by (simp add: path_connectedin_topspace)
      qed
      then have "{i \<in> I. \<not> path_connected_space (X i)} \<subseteq> {i \<in> I. V i \<noteq> topspace (X i)}"
        by blast
      with finV show "finite {i \<in> I. \<not> path_connected_space (X i)}"
        using finite_subset by blast
    next
      show "locally_path_connected_space (X i)" if "i \<in> I" for i
        apply (rule locally_path_connected_space_quotient_map_image [OF _ L, where f = "\<lambda>x. x i"])
        by (metis False Abstract_Topology.retraction_imp_quotient_map retraction_map_product_projection that)
    qed
  qed
  moreover have ?lhs if R: ?rhs
  proof (clarsimp simp add: locally_path_connected_space_def neighbourhood_base_of)
    fix F z
    assume "openin (product_topology X I) F" and "z \<in> F"
    then obtain W where finW: "finite {i \<in> I. W i \<noteq> topspace (X i)}"
            and opeW: "\<And>i. i \<in> I \<Longrightarrow> openin (X i) (W i)" and "z \<in> Pi\<^sub>E I W" "Pi\<^sub>E I W \<subseteq> F"
      by (auto simp: openin_product_topology_alt)
    have "\<forall>i \<in> I. \<exists>U C. openin (X i) U \<and> path_connectedin (X i) C \<and> z i \<in> U \<and> U \<subseteq> C \<and> C \<subseteq> W i \<and>
                        (W i = topspace (X i) \<and>
                         path_connected_space (X i) \<longrightarrow> U = topspace (X i) \<and> C = topspace (X i))"
          (is "\<forall>i \<in> I. ?\<Phi> i")
    proof
      fix i assume "i \<in> I"
      have "locally_path_connected_space (X i)"
        by (simp add: R \<open>i \<in> I\<close>)
      moreover have "openin (X i) (W i) " "z i \<in> W i"
        using \<open>z \<in> Pi\<^sub>E I W\<close> opeW \<open>i \<in> I\<close> by auto
      ultimately obtain U C where UC: "openin (X i) U" "path_connectedin (X i) C" "z i \<in> U" "U \<subseteq> C" "C \<subseteq> W i"
        using \<open>i \<in> I\<close> by (force simp: locally_path_connected_space_def neighbourhood_base_of)
      show "?\<Phi> i"
      proof (cases "W i = topspace (X i) \<and> path_connected_space(X i)")
        case True
        then show ?thesis
          using \<open>z i \<in> W i\<close> path_connectedin_topspace by blast
      next
        case False
        then show ?thesis
          by (meson UC)
      qed
    qed
    then obtain U C where
      *: "\<And>i. i \<in> I \<Longrightarrow> openin (X i) (U i) \<and> path_connectedin (X i) (C i) \<and> z i \<in> (U i) \<and> (U i) \<subseteq> (C i) \<and> (C i) \<subseteq> W i \<and>
                        (W i = topspace (X i) \<and> path_connected_space (X i)
                         \<longrightarrow> (U i) = topspace (X i) \<and> (C i) = topspace (X i))"
      by metis
    let ?A = "{i \<in> I. \<not> path_connected_space (X i)} \<union> {i \<in> I. W i \<noteq> topspace (X i)}"
    have "{i \<in> I. U i \<noteq> topspace (X i)} \<subseteq> ?A"
      by (clarsimp simp add: "*")
    moreover have "finite ?A"
      by (simp add: that finW)
    ultimately have "finite {i \<in> I. U i \<noteq> topspace (X i)}"
      using finite_subset by auto
    then have "openin (product_topology X I) (Pi\<^sub>E I U)"
      using * by (simp add: openin_PiE_gen)
    then show "\<exists>U. openin (product_topology X I) U \<and>
            (\<exists>V. path_connectedin (product_topology X I) V \<and> z \<in> U \<and> U \<subseteq> V \<and> V \<subseteq> F)"
      apply (rule_tac x="PiE I U" in exI, simp)
      apply (rule_tac x="PiE I C" in exI)
      using \<open>z \<in> Pi\<^sub>E I W\<close> \<open>Pi\<^sub>E I W \<subseteq> F\<close> *
      apply (simp add: path_connectedin_PiE subset_PiE PiE_iff PiE_mono dual_order.trans)
      done
  qed
  ultimately show ?thesis
    using False by blast
qed

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Galois Equivalences\<close>
theory Galois_Equivalences
  imports
    Galois_Connections
    Order_Equivalences
    Partial_Equivalence_Relations
begin

context galois
begin

text\<open>In the literature, an adjoint equivalence is an adjunction for which
the unit and counit are natural isomorphisms.
Translated to the category of orders,
this means that a \<^emph>\<open>Galois equivalence\<close> between two relations
@{term "(\<le>\<^bsub>L\<^esub>)"} and @{term "(\<le>\<^bsub>R\<^esub>)"} is a Galois connection for which the unit
@{term "\<eta>"} is @{term "deflationary"} and the counit @{term "\<epsilon>"} is
@{term "inflationary"}.

For reasons of symmetry, we give a different definition which next to
@{term "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"} requires @{term "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"}.
In other words, a Galois equivalence is a Galois connection for which the left
and right adjoints are also right and left adjoints, respectively.
As shown below, in the case of preorders, the definitions coincide.\<close>

definition "galois_equivalence \<equiv> ((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r \<and> ((\<le>\<^bsub>R\<^esub>) \<unlhd> (\<le>\<^bsub>L\<^esub>)) r l"

notation galois.galois_equivalence (infix "\<equiv>\<^sub>G" 50)

lemma galois_equivalenceI [intro]:
  assumes "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  and "((\<le>\<^bsub>R\<^esub>) \<unlhd> (\<le>\<^bsub>L\<^esub>)) r l"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  unfolding galois_equivalence_def using assms by blast

lemma galois_equivalenceE [elim]:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  obtains "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r" "((\<le>\<^bsub>R\<^esub>) \<stileturn> (\<le>\<^bsub>L\<^esub>)) r l"
  using assms unfolding galois_equivalence_def
  by (blast intro: galois.galois_connectionI)

context
begin

interpretation g : galois S T f g for S T f g.

lemma galois_equivalence_eq_galois_connection_rel_inf_galois_prop:
  "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) = ((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) \<sqinter> ((\<ge>\<^bsub>L\<^esub>) \<unlhd> (\<ge>\<^bsub>R\<^esub>))"
  by (intro ext) auto

lemma rel_inv_galois_equivalence_eq_galois_equivalence [simp]:
  "((\<le>\<^bsub>R\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>L\<^esub>))\<inverse> = ((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>))"
  by (intro ext) auto

corollary galois_equivalence_right_left_iff_galois_equivalence_left_right:
  "((\<le>\<^bsub>R\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>L\<^esub>)) r l \<longleftrightarrow> ((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  by auto

lemma galois_equivalence_rel_inv_eq_galois_equivalence [simp]:
  "((\<ge>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<ge>\<^bsub>R\<^esub>)) = ((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>))"
  by (intro ext) auto

lemma inflationary_on_unit_if_reflexive_on_if_galois_equivalence:
  fixes P :: "'a \<Rightarrow> bool"
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  and "reflexive_on P (\<le>\<^bsub>L\<^esub>)"
  shows "inflationary_on P (\<le>\<^bsub>L\<^esub>) \<eta>"
  using assms by (intro inflationary_on_unit_if_reflexive_on_if_galois_connection)
  (elim galois_equivalenceE)

end

lemma deflationary_on_unit_if_reflexive_on_if_galois_equivalence:
  fixes P :: "'a \<Rightarrow> bool"
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  and "reflexive_on P (\<le>\<^bsub>L\<^esub>)"
  shows "deflationary_on P (\<le>\<^bsub>L\<^esub>) \<eta>"
proof -
  interpret flip : galois R L r l .
  show ?thesis using assms
  by (auto intro: flip.deflationary_on_counit_if_reflexive_on_if_galois_connection
    simp only: flip.flip_unit_eq_counit)
qed

text \<open>Every @{term "galois_equivalence"} on reflexive orders is a Galois
equivalence in the sense of the common literature.\<close>
lemma rel_equivalence_on_unit_if_reflexive_on_if_galois_equivalence:
  fixes P :: "'a \<Rightarrow> bool"
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  and "reflexive_on P (\<le>\<^bsub>L\<^esub>)"
  shows "rel_equivalence_on P (\<le>\<^bsub>L\<^esub>) \<eta>"
  using assms by (intro rel_equivalence_onI
    inflationary_on_unit_if_reflexive_on_if_galois_equivalence
    deflationary_on_unit_if_reflexive_on_if_galois_equivalence)

lemma galois_equivalence_partial_equivalence_rel_not_reflexive_not_transitive:
  assumes "\<exists>(y :: 'b) y'. y \<noteq> y'"
  shows "\<exists>(L :: 'a \<Rightarrow> 'a \<Rightarrow> bool) (R :: 'b \<Rightarrow> 'b \<Rightarrow> bool) l r.
    (L \<equiv>\<^sub>G R) l r \<and> partial_equivalence_rel L \<and>
    \<not>(reflexive_on (in_field R) R) \<and> \<not>(transitive_on (in_field R) R)"
proof -
  from assms obtain cy cy' where "(cy :: 'b) \<noteq> cy'" by blast
  let ?cx = "undefined :: 'a"
  let ?L = "\<lambda>x x'. ?cx = x \<and> x = x'"
  and ?R = "\<lambda>y y'. (y = cy \<or> y = cy') \<and> (y' = cy \<or> y' = cy') \<and> (y \<noteq> cy' \<or> y' \<noteq> cy')"
  and ?l = "\<lambda>(a :: 'a). cy"
  and ?r = "\<lambda>(b :: 'b). ?cx"
  interpret g : galois ?L ?R ?l ?r .
  interpret flip_g : galois ?R ?L ?r ?l .
  have "(?L \<equiv>\<^sub>G ?R) ?l ?r" using \<open>cy \<noteq> cy'\<close> by blast
  moreover have "partial_equivalence_rel ?L" by blast
  moreover have
    "\<not>(transitive_on (in_field ?R) ?R)" and "\<not>(reflexive_on (in_field ?R) ?R)"
    using \<open>cy \<noteq> cy'\<close> by auto
  ultimately show "?thesis" by blast
qed

subsubsection \<open>Equivalence of Order Equivalences and Galois Equivalences\<close>

text \<open>In general categories, every adjoint equivalence is an equivalence
but not vice versa.
In the category of preorders, however, they are morally the same: the
adjoint zigzag equations are satisfied up to unique isomorphism rather than
equality.
In the category of partial orders, the concepts coincide.\<close>

lemma half_galois_prop_left_left_right_if_transitive_if_order_equivalence:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  and "transitive (\<le>\<^bsub>L\<^esub>)" "transitive (\<le>\<^bsub>R\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms
  by (intro half_galois_prop_left_left_right_if_transitive_if_deflationary_on_if_mono_wrt_rel)
  (auto elim!: order_equivalenceE
    intro: deflationary_on_if_le_pred_if_deflationary_on in_field_if_in_codom
    intro!: le_predI)

lemma half_galois_prop_right_left_right_if_transitive_if_order_equivalence:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  and "transitive (\<le>\<^bsub>L\<^esub>)" "transitive (\<le>\<^bsub>R\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  using assms
  by (intro half_galois_prop_right_left_right_if_transitive_if_inflationary_on_if_mono_wrt_rel)
  (auto elim!: order_equivalenceE
    intro: inflationary_on_if_le_pred_if_inflationary_on in_field_if_in_dom
    intro!: le_predI
    simp only: flip_counit_eq_unit)

lemma galois_prop_left_right_if_transitive_if_order_equivalence:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  and "transitive (\<le>\<^bsub>L\<^esub>)" "transitive (\<le>\<^bsub>R\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms
    half_galois_prop_left_left_right_if_transitive_if_order_equivalence
    half_galois_prop_right_left_right_if_transitive_if_order_equivalence
  by blast

corollary galois_connection_left_right_if_transitive_if_order_equivalence:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  and "transitive (\<le>\<^bsub>L\<^esub>)" "transitive (\<le>\<^bsub>R\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms galois_prop_left_right_if_transitive_if_order_equivalence
  by (intro galois_connectionI) auto

interpretation flip : galois R L r l
  rewrites "flip.unit \<equiv> \<epsilon>"
  by (simp only: flip_unit_eq_counit)

corollary galois_equivalence_left_right_if_transitive_if_order_equivalence:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  and "transitive (\<le>\<^bsub>L\<^esub>)" "transitive (\<le>\<^bsub>R\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  using assms galois_connection_left_right_if_transitive_if_order_equivalence
    flip.galois_prop_left_right_if_transitive_if_order_equivalence
  by (intro galois_equivalenceI)
  (auto simp only: order_equivalence_right_left_iff_order_equivalence_left_right)

lemma order_equivalence_if_reflexive_on_in_field_if_galois_equivalence:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  and "reflexive_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)" "reflexive_on (in_field (\<le>\<^bsub>R\<^esub>)) (\<le>\<^bsub>R\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  using assms rel_equivalence_on_unit_if_reflexive_on_if_galois_equivalence
    flip.rel_equivalence_on_unit_if_reflexive_on_if_galois_equivalence
  by (intro order_equivalenceI)
  (auto simp only: galois_equivalence_right_left_iff_galois_equivalence_left_right)

corollary galois_equivalence_eq_order_equivalence_if_preorder_on_in_field:
  assumes "preorder_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)" "preorder_on (in_field (\<le>\<^bsub>R\<^esub>)) (\<le>\<^bsub>R\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) = ((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>))"
  using assms
    galois.order_equivalence_if_reflexive_on_in_field_if_galois_equivalence
    galois.galois_equivalence_left_right_if_transitive_if_order_equivalence
  by (elim preorder_on_in_fieldE, intro ext) blast

end

end


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory MapOps
imports Main
begin
(*>*)

subsection{* Finite map operations *}

text{*

\label{sec:kbps-theory-map-ops}

The algorithm represents an automaton as a pair of maps, which we
capture abstractly with a record and a predicate:

*}

record ('m, 'k, 'e) MapOps =
  empty :: "'m"
  lookup :: "'m \<Rightarrow> 'k \<rightharpoonup> 'e"
  update :: "'k \<Rightarrow> 'e \<Rightarrow> 'm \<Rightarrow> 'm"

definition
  MapOps :: "('k \<Rightarrow> 'kabs) \<Rightarrow> 'kabs set \<Rightarrow> ('m, 'k, 'e) MapOps \<Rightarrow> bool"
where
  "MapOps \<alpha> d ops \<equiv>
      (\<forall>k. \<alpha> k \<in> d \<longrightarrow> lookup ops (empty ops) k = None)
    \<and> (\<forall>e k k' M. \<alpha> k \<in> d \<and> \<alpha> k' \<in> d
        \<longrightarrow> lookup ops (update ops k e M) k'
          = (if \<alpha> k' = \<alpha> k then Some e else lookup ops M k'))"
(*<*)

lemma MapOpsI[intro]:
  "\<lbrakk> \<And>k. \<alpha> k \<in> d \<Longrightarrow> lookup ops (empty ops) k = None;
     \<And>e k k' M. \<lbrakk> \<alpha> k \<in> d; \<alpha> k' \<in> d \<rbrakk> \<Longrightarrow>
                 lookup ops (update ops k e M) k'
              = (if \<alpha> k' = \<alpha> k then Some e else lookup ops M k') \<rbrakk>
     \<Longrightarrow> MapOps \<alpha> d ops"
  unfolding MapOps_def by blast

lemma MapOps_emptyD:
  "\<lbrakk> \<alpha> k \<in> d; MapOps \<alpha> d ops \<rbrakk> \<Longrightarrow> lookup ops (empty ops) k = None"
  unfolding MapOps_def by simp

lemma MapOps_lookup_updateD:
  "\<lbrakk> \<alpha> k \<in> d; \<alpha> k' \<in> d; MapOps \<alpha> d ops \<rbrakk> \<Longrightarrow> lookup ops (update ops k e M) k' = (if \<alpha> k' = \<alpha> k then Some e else lookup ops M k')"
  unfolding MapOps_def by simp

(*>*)

text{*

The function @{term "\<alpha>"} abstracts concrete keys of type @{typ "'k"},
and the parameter @{term "d"} specifies the valid abstract keys.

This approach has the advantage over a locale that we can pass records
to functions, while for a locale we would need to pass the three
functions separately (as in the DFS theory of \S\ref{sec:dfs}).

We use the following function to test for membership in the domain of
the map:

*}

definition isSome :: "'a option \<Rightarrow> bool" where
  "isSome opt \<equiv> case opt of None \<Rightarrow> False | Some _ \<Rightarrow> True"
(*<*)

lemma isSome_simps[simp]:
  "\<And>x. isSome (Some x)"
  "\<And>x. \<not> isSome x \<longleftrightarrow> x = None"
  unfolding isSome_def by (auto split: option.split)

lemma isSome_eq:
  "isSome x \<longleftrightarrow> (\<exists>y. x = Some y)"
  unfolding isSome_def by (auto split: option.split)

lemma isSomeE: "\<lbrakk> isSome x; \<And>s. x = Some s \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  unfolding isSome_def by (cases x) auto

end
(*>*)


theory Refine_Mono_Prover
imports Main Automatic_Refinement.Refine_Lib
begin
  ML_file \<open>refine_mono_prover.ML\<close>

  setup Refine_Mono_Prover.setup
  declaration Refine_Mono_Prover.decl_setup

  method_setup refine_mono =
    \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (
      Refine_Mono_Prover.untriggered_mono_tac ctxt
    ))\<close>
    "Refinement framework: Monotonicity prover"

  locale mono_setup_loc =
    \<comment> \<open>Locale to set up monotonicity prover for given ordering operator\<close>
    fixes le :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
    assumes refl: "le x x"
  begin
    lemma monoI: "(\<And>f g x. (\<And>x. le (f x) (g x)) \<Longrightarrow> le (B f x) (B g x))
      \<Longrightarrow> monotone (fun_ord le) (fun_ord le) B"
      unfolding monotone_def fun_ord_def by blast

    lemma mono_if: "\<lbrakk>le t t'; le e e'\<rbrakk> \<Longrightarrow> le (If b t e) (If b t' e')" by auto
    lemma mono_let: "(\<And>x. le (f x) (f' x)) \<Longrightarrow> le (Let x f) (Let x f')" by auto

    lemmas mono_thms[refine_mono] = monoI mono_if mono_let refl

    declaration \<open>Refine_Mono_Prover.declare_mono_triggers @{thms monoI}\<close>

  end

  interpretation order_mono_setup: mono_setup_loc "(\<le>) :: 'a::preorder \<Rightarrow> _"
    by standard auto

  declaration \<open>Refine_Mono_Prover.declare_mono_triggers @{thms Orderings.monoI}\<close>

  lemmas [refine_mono] =
    lfp_mono[OF le_funI, THEN le_funD]
    gfp_mono[OF le_funI, THEN le_funD]

end


theory InsertionSort
  imports  Syntax
begin

no_notation Set.image (infixr "`" 90)

record ('a :: ord) insertion_state =
  k :: 'a
  i :: nat
  j :: nat
  A :: "'a list"

lemma insertion_sort: "\<turnstile> \<lbrace> length Ao > 0 \<and> `A = Ao \<rbrace>
  `i := 1;
  while `i < length `A
  inv sorted (take `i `A) \<and> `A <~~> Ao
  do
    `j := `i;
    while 0 < `j \<and> `A ! `j < `A ! (`j - 1)
    inv
      (sorted_but (take (`i + 1) `A) `j) \<and> (`i < length `A) \<and> (`j \<le> `i) \<and>
      (`j \<noteq> `i \<longrightarrow> `A ! `j \<le> `A ! (`j + 1)) \<and> (`A <~~> Ao)
    do
      `k := `A ! `j;
      `A ! `j := `A ! (`j - 1);
      `A ! (`j - 1) := `k;
      `j := `j - 1
    od;
    `i := `i + 1
  od
  \<lbrace>sorted `A \<and> `A <~~> Ao \<rbrace>"
  apply (hoare, auto)
  apply (metis One_nat_def not_le take_sorted_butE_n)
  apply (metis One_nat_def take_sorted_butE_0)
  apply (simp add: take_sorted_butE)
  apply (unfold sorted_equals_nth_mono sorted_but_def, auto)
  apply (smt Suc_pred diff_less_Suc le_SucE le_less_trans less_Suc_eq_le nth_list_update)
  apply (metis (hide_lams, no_types) One_nat_def perm.trans perm_swap_list)
  apply (smt Suc_pred diff_less_Suc le_SucE le_less_trans less_Suc_eq_le nth_list_update)
  by (smt One_nat_def le_less_trans perm.trans perm_swap_list)

lemma insertion_sort_morgan: "\<lbrakk> length Ao > 0 \<and> `A = Ao, sorted `A \<and> `A <~~> Ao\<rbrakk> \<sqsubseteq>
  `i := 1;
  while `i \<noteq> length `A do
    `j := `i;
    while 0 < `j \<and> `A ! `j < `A ! (`j - 1) do
      `k := `A ! `j;
      `A ! `j := `A ! (`j - 1);
      `A ! (`j - 1) := `k;
      `j := `j - 1
    od;
    `i := `i + 1
  od"
proof -
  have "\<lbrakk> length Ao > 0 \<and> `A = Ao, sorted `A \<and> `A <~~> Ao\<rbrakk> \<sqsubseteq>
    `i := 1;
    \<lbrakk>`i = 1 \<and> sorted (take `i `A) \<and> `i \<le> length `A \<and> `A <~~> Ao, sorted `A \<and> `A <~~> Ao\<rbrakk>"
    apply (morgan, auto)
    by (metis Suc_le_eq length_0_conv neq0_conv)
  also have "... \<sqsubseteq>
    `i := 1;
    while `i \<noteq> length `A do
      \<lbrakk> sorted (take `i `A) \<and> `i < length `A \<and> `A <~~> Ao, sorted (take `i `A) \<and> `i \<le> length `A \<and> `A <~~> Ao\<rbrakk>
    od"
    by morgan auto
  also have "... \<sqsubseteq>
      `i := 1;
      while `i \<noteq> length `A do
        \<lbrakk> sorted (take `i `A) \<and> `i < length `A \<and> `A <~~> Ao, sorted (take (`i + 1) `A) \<and> (`i + 1) \<le> length `A \<and> `A <~~> Ao\<rbrakk>;
        `i := `i + 1
      od"
    by morgan auto
  also have "... \<sqsubseteq>
      `i := 1;
      while `i \<noteq> length `A do
        \<lbrakk> sorted_but (take (`i + 1) `A) `i \<and> `i < length `A \<and> `A <~~> Ao, sorted (take (`i + 1) `A) \<and> (`i + 1) \<le> length `A \<and> `A <~~> Ao\<rbrakk>;
        `i := `i + 1
      od"
    by morgan (auto intro: take_sorted_butI)
  also have "... \<sqsubseteq>
      `i := 1;
      while `i \<noteq> length `A do
        \<lbrakk> sorted_but (take (`i + 1) `A) `i \<and> `i < length `A \<and> `A <~~> Ao,
          `j \<le> `i \<and> sorted_but (take (`i + 1) `A) `j
          \<and> (`j \<noteq> `i \<longrightarrow> `A ! `j \<le> `A ! (`j + 1)) \<and> (`i + 1) \<le> length `A
          \<and> (`j = 0 \<or> `A ! (`j - 1) \<le> `A ! `j) \<and> `A <~~> Ao\<rbrakk>;
        `i := `i + 1
      od"
    apply (morgan, auto)
    apply (metis One_nat_def take_sorted_butE_0)
    apply (metis One_nat_def take_sorted_butE_n)
    by (metis One_nat_def Suc_eq_plus1 less_Suc_eq_le take_sorted_butE)
  also have "... \<sqsubseteq>
      `i := 1;
      while `i \<noteq> length `A do
        `j := `i;
        \<lbrakk> `j \<le> `i \<and> sorted_but (take (`i + 1) `A) `j
          \<and> (`j \<noteq> `i \<longrightarrow> `A ! `j \<le> `A ! (`j + 1)) \<and> (`i + 1) \<le> length `A  \<and> `A <~~> Ao,
          `j \<le> `i \<and> sorted_but (take (`i + 1) `A) `j
          \<and> (`j \<noteq> `i \<longrightarrow> `A ! `j \<le> `A ! (`j + 1)) \<and> (`i + 1) \<le> length `A
          \<and> (`j = 0 \<or> `A ! (`j - 1) \<le> `A ! `j) \<and> `A <~~> Ao\<rbrakk>;
        `i := `i + 1
      od"
    by morgan auto
  also have "... \<sqsubseteq>
      `i := 1;
      while `i \<noteq> length `A do
        `j := `i;
        while `j \<noteq> 0 \<and> `A ! `j < `A ! (`j - 1) do
          \<lbrakk> `j \<le> `i \<and> sorted_but (take (`i + 1) `A) `j
            \<and> (`j \<noteq> `i \<longrightarrow> `A ! `j \<le> `A ! (`j + 1)) \<and> (`i + 1) \<le> length `A
            \<and> `j \<noteq> 0 \<and> `A ! `j < `A ! (`j - 1) \<and> `A <~~> Ao,
            `j \<le> `i \<and> sorted_but (take (`i + 1) `A) `j
            \<and> (`j \<noteq> `i \<longrightarrow> `A ! `j \<le> `A ! (`j + 1)) \<and> (`i + 1) \<le> length `A  \<and> `A <~~> Ao\<rbrakk>
        od;
        `i := `i + 1
      od"
    by morgan auto
  also have "... \<sqsubseteq>
      `i := 1;
      while `i \<noteq> length `A do
        `j := `i;
        while `j \<noteq> 0 \<and> `A ! `j < `A ! (`j - 1) do
          \<lbrakk> `j \<le> `i \<and> sorted_but (take (`i + 1) `A) `j
            \<and> (`j \<noteq> `i \<longrightarrow> `A ! `j \<le> `A ! (`j + 1)) \<and> (`i + 1) \<le> length `A
            \<and> `j \<noteq> 0 \<and> `A ! `j < `A ! (`j - 1) \<and> `A <~~> Ao,
            `j - 1 \<le> `i \<and> sorted_but (take (`i + 1) `A) (`j - 1)
            \<and> (`j - 1 \<noteq> `i \<longrightarrow> `A ! (`j - 1) \<le> `A ! `j) \<and> (`i + 1) \<le> length `A \<and> `j \<noteq> 0  \<and> `A <~~> Ao\<rbrakk>;
          `j := `j - 1
        od;
        `i := `i + 1
      od"
      by morgan auto
  also have "... \<sqsubseteq>
      `i := 1;
      while `i \<noteq> length `A do
        `j := `i;
        while `j \<noteq> 0 \<and> `A ! `j < `A ! (`j - 1) do
          \<lbrakk> `j \<le> `i \<and> sorted_but (take (`i + 1) `A) `j
            \<and> (`j \<noteq> `i \<longrightarrow> `A ! `j \<le> `A ! (`j + 1)) \<and> (`i + 1) \<le> length `A
            \<and> `j \<noteq> 0 \<and> `A ! `j < `A ! (`j - 1) \<and> `A <~~> Ao,
            `j - 1 \<le> `i \<and> sorted_but (take (`i + 1) (`A[(`j - 1) := `k])) (`j - 1)
            \<and> (`j - 1 \<noteq> `i \<longrightarrow> (`A[(`j - 1) := `k]) ! (`j - 1) \<le> (`A[(`j - 1) := `k]) ! `j)
            \<and> (`i + 1) \<le> length (`A[(`j - 1) := `k]) \<and> `j \<noteq> 0 \<and> (`A[(`j - 1) := `k]) <~~> Ao \<rbrakk>;
          `A ! (`j - 1) := `k;
          `j := `j - 1
        od;
        `i := `i + 1
      od"
    by morgan auto
  also have "... \<sqsubseteq>
      `i := 1;
      while `i \<noteq> length `A do
        `j := `i;
        while `j \<noteq> 0 \<and> `A ! `j < `A ! (`j - 1) do
          \<lbrakk> `j \<le> `i \<and> sorted_but (take (`i + 1) `A) `j
            \<and> (`j \<noteq> `i \<longrightarrow> `A ! `j \<le> `A ! (`j + 1)) \<and> (`i + 1) \<le> length `A
            \<and> `j \<noteq> 0 \<and> `A ! `j < `A ! (`j - 1) \<and> `A <~~> Ao,
            `j - 1 \<le> `i \<and> sorted_but (take (`i + 1) (`A[(`j - 1) := `k, `j := `A ! (`j - 1)])) (`j - 1)
            \<and> (`j - 1 \<noteq> `i \<longrightarrow> (`A[(`j - 1) := `k, `j := `A ! (`j - 1)]) ! (`j - 1) \<le> (`A[(`j - 1) := `k, `j := `A ! (`j - 1)]) ! `j)
            \<and> (`i + 1) \<le> length (`A[(`j - 1) := `k, `j := `A ! (`j - 1)]) \<and> `j \<noteq> 0
            \<and> (`A[(`j - 1) := `k, `j := `A ! (`j - 1)]) <~~> Ao \<rbrakk>;
          `A  ! `j := `A ! (`j - 1);
          `A ! (`j - 1) := `k;
          `j := `j - 1
        od;
        `i := `i + 1
      od"
    by morgan (auto simp add: list_update_swap)
  also have "... \<sqsubseteq>
      `i := 1;
      while `i \<noteq> length `A do
        `j := `i;
        while `j \<noteq> 0 \<and> `A ! `j < `A ! (`j - 1) do
          `k := `A ! `j;
          `A  ! `j := `A ! (`j - 1);
          `A ! (`j - 1) := `k;
          `j := `j - 1
        od;
        `i := `i + 1
      od"
    apply morgan
    apply (unfold sorted_equals_nth_mono sorted_but_def, auto)
    apply (smt Suc_le_lessD Suc_pred diff_less_Suc eq_iff leD le_SucE length_list_update less_SucE nth_list_update order.strict_trans2)
    apply (smt One_nat_def Suc_le_lessD list_update_swap perm.trans perm_swap_list)
    apply (smt Suc_le_lessD Suc_pred diff_le_self le_neq_implies_less le_refl le_trans list_update_swap not_less_eq not_less_eq_eq nth_list_update_eq nth_list_update_neq)
    by (smt One_nat_def Suc_le_lessD le_less_trans list_update_swap perm.trans perm_swap_list)
  finally show ?thesis
    by auto
qed

hide_const k i j A

end