(*
  Title: Closure and Co-Closure Operators
  Author: Georg Struth
  Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Closure and Co-Closure Operators\<close>

theory Closure_Operators
  imports Galois_Connections

begin

subsection \<open>Closure Operators\<close>

text \<open>Closure and coclosure operators in orders and complete lattices are defined in this section,
and some basic properties are proved. Isabelle infers the appropriate types. Facts are
taken mainly from the Compendium of Continuous Lattices~\cite{GierzHKLMS80} and
Rosenthal's book on quantales~\cite{Rosenthal90}.\<close>

definition clop :: "('a::order \<Rightarrow> 'a) \<Rightarrow> bool" where
  "clop f = (id \<le> f \<and> mono f \<and> f \<circ> f \<le> f)"

lemma clop_extensive: "clop f \<Longrightarrow> id \<le> f"
  by (simp add: clop_def)

lemma clop_extensive_var: "clop f \<Longrightarrow> x \<le> f x"
  by (simp add: clop_def le_fun_def)

lemma clop_iso: "clop f \<Longrightarrow> mono f"
  by (simp add: clop_def)

lemma clop_iso_var: "clop f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (simp add: clop_def mono_def)

lemma clop_idem: "clop f \<Longrightarrow> f \<circ> f = f"
  by (simp add: antisym clop_def le_fun_def)

lemma clop_Fix_range: "clop f \<Longrightarrow> (Fix f = range f)"
  by (simp add: clop_idem retraction_prop_fix)

lemma clop_Inf_closed_var:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "clop f \<Longrightarrow> f \<circ> Inf \<circ> (`) f  = Inf \<circ> (`) f"
  unfolding clop_def mono_def comp_def le_fun_def
  by (metis (mono_tags, lifting) antisym id_apply le_INF_iff order_refl)

lemma clop_top:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows "clop f \<Longrightarrow> f \<top> = \<top>"
  by (simp add: clop_extensive_var top.extremum_uniqueI)

lemma "clop (f::'a::complete_lattice \<Rightarrow> 'a) \<Longrightarrow> f (\<Squnion>x \<in> X. f x) = (\<Squnion>x \<in> X. f x)" (*nitpick*)
  oops

lemma "clop (f::'a::complete_lattice \<Rightarrow> 'a) \<Longrightarrow> f (f x \<squnion> f y) = f x \<squnion> f y" (*nitpick*)
  oops

lemma  "clop (f::'a::complete_lattice \<Rightarrow> 'a) \<Longrightarrow> f \<bottom> = \<bottom>" (*nitpick *)
  oops

lemma "clop (f::'a set \<Rightarrow> 'a set) \<Longrightarrow> f (\<Squnion>x \<in> X. f x) = (\<Squnion>x \<in> X. f x)" (*nitpick*)
  oops

lemma "clop (f::'a set \<Rightarrow> 'a set) \<Longrightarrow> f (f x \<squnion> f y) = f x \<squnion> f y" (*nitpick*)
  oops

lemma  "clop (f::'a set \<Rightarrow> 'a set) \<Longrightarrow> f \<bottom> = \<bottom>" (*nitpick *)
  oops

lemma clop_closure: "clop f \<Longrightarrow> (x \<in> range f) = (f x = x)"
  by (simp add: clop_idem retraction_prop)

lemma clop_closure_set: "clop f \<Longrightarrow> range f = Fix f"
  by (simp add: clop_Fix_range)

lemma clop_closure_prop: "(clop::('a::complete_lattice_with_dual\<Rightarrow> 'a) \<Rightarrow> bool) (Inf \<circ> \<up>)"
  by (simp add: clop_def mono_def)

lemma clop_closure_prop_var: "clop (\<lambda>x::'a::complete_lattice. \<Sqinter>{y. x \<le> y})"
  unfolding clop_def comp_def le_fun_def mono_def by (simp add: Inf_lower le_Inf_iff)

lemma clop_alt: "(clop f) = (\<forall>x y. x \<le> f y \<longleftrightarrow> f x \<le> f y)"
  unfolding clop_def mono_def le_fun_def comp_def id_def by (meson dual_order.refl order_trans)

text \<open>Finally it is shown that adjoints in a Galois connection yield closure operators.\<close>

lemma clop_adj:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> clop (g \<circ> f)"
  by (simp add: adj_cancel2 adj_idem2 adj_iso4 clop_def)

text \<open>Closure operators are monads for posets, and monads arise from adjunctions.
This fact is not formalised at this point. But here is the first step: every function
can be decomposed into a surjection followed by an injection.\<close>

definition "surj_on f Y = (\<forall>y \<in> Y. \<exists>x. y = f x)"

lemma surj_surj_on: "surj f \<Longrightarrow> surj_on f Y"
  by (simp add: surjD surj_on_def)

lemma fun_surj_inj: "\<exists>g h. f = g \<circ> h \<and> surj_on h (range f) \<and> inj_on g (range f)"
proof-
  obtain h where a: "\<forall>x. f x = h x"
    by blast
  then have "surj_on h (range f)"
    by (metis (mono_tags, lifting) imageE surj_on_def)
  then show ?thesis
    unfolding inj_on_def surj_on_def fun_eq_iff using a by auto
qed

text \<open>Connections between downsets, upsets and closure operators are outlined next.\<close>

lemma preorder_clop: "clop (\<Down>::'a::preorder set \<Rightarrow> 'a set)"
  by (simp add: clop_def downset_set_ext downset_set_iso)

lemma clop_preorder_aux: "clop f \<Longrightarrow> (x \<in> f {y} \<longleftrightarrow> f {x} \<subseteq> f {y})"
  by (simp add: clop_alt)

lemma clop_preorder: "clop f \<Longrightarrow> class.preorder (\<lambda>x y. f {x} \<subseteq> f {y}) (\<lambda>x y. f {x} \<subset> f {y})"
  unfolding clop_def mono_def le_fun_def id_def comp_def by standard (auto simp: subset_not_subset_eq)

lemma preorder_clop_dual: "clop (\<Up>::'a::preorder_with_dual set \<Rightarrow> 'a set)"
  by (simp add: clop_def upset_set_anti upset_set_ext)

text \<open>The closed elements of any closure operator over a complete lattice form an Inf-closed set (a Moore family).\<close>

lemma clop_Inf_closed:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows  "clop f \<Longrightarrow> Inf_closed_set (Fix f)"
  unfolding clop_def Inf_closed_set_def mono_def le_fun_def comp_def id_def Fix_def
  by (smt Inf_greatest Inf_lower antisym mem_Collect_eq subsetCE)

lemma clop_top_Fix:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows  "clop f \<Longrightarrow> \<top> \<in> Fix f"
  by (simp add: clop_Fix_range clop_closure clop_top)

text \<open>Conversely, every Inf-closed subset of a complete lattice is the set of fixpoints of some closure operator.\<close>

lemma Inf_closed_clop:
  fixes X :: "'a::complete_lattice set"
  shows "Inf_closed_set X \<Longrightarrow> clop (\<lambda>y. \<Sqinter>{x \<in> X. y \<le> x})"
  by (smt Collect_mono_iff Inf_superset_mono clop_alt dual_order.trans le_Inf_iff mem_Collect_eq)

lemma Inf_closed_clop_var:
  fixes X :: "'a::complete_lattice set"
  shows "clop f \<Longrightarrow> \<forall>x \<in> X. x \<in> range f \<Longrightarrow> \<Sqinter>X \<in> range f"
  by (metis Inf_closed_set_def clop_Fix_range clop_Inf_closed subsetI)

text \<open>It is well known that downsets and upsets over an ordering form subalgebras of the complete powerset lattice.\<close>

typedef (overloaded) 'a downsets = "range (\<Down>::'a::order set \<Rightarrow> 'a set)"
  by fastforce

setup_lifting type_definition_downsets

typedef (overloaded) 'a upsets = "range (\<Up>::'a::order set \<Rightarrow> 'a set)"
  by fastforce

setup_lifting type_definition_upsets

instantiation downsets :: (order) Inf_lattice
begin

lift_definition Inf_downsets :: "'a downsets set \<Rightarrow> 'a downsets" is "Abs_downsets \<circ> Inf \<circ> (`) Rep_downsets".

lift_definition less_eq_downsets :: "'a downsets \<Rightarrow> 'a downsets \<Rightarrow> bool" is "\<lambda>X Y. Rep_downsets X \<subseteq> Rep_downsets Y".

lift_definition less_downsets :: "'a downsets \<Rightarrow> 'a downsets \<Rightarrow> bool" is "\<lambda>X Y. Rep_downsets X \<subset> Rep_downsets Y".

instance
  apply intro_classes
      apply (transfer, simp)
     apply (transfer, blast)
    apply (simp add: Closure_Operators.less_eq_downsets.abs_eq Rep_downsets_inject)
   apply (transfer, smt Abs_downsets_inverse INF_lower Inf_closed_clop_var Rep_downsets image_iff o_def preorder_clop)
  by transfer (smt comp_def Abs_downsets_inverse Inf_closed_clop_var Rep_downsets image_iff le_INF_iff preorder_clop)

end

instantiation upsets :: (order_with_dual) Inf_lattice
begin

lift_definition Inf_upsets :: "'a upsets set \<Rightarrow> 'a upsets" is "Abs_upsets \<circ> Inf \<circ> (`) Rep_upsets".

lift_definition less_eq_upsets :: "'a upsets \<Rightarrow> 'a upsets \<Rightarrow> bool" is "\<lambda>X Y. Rep_upsets X \<subseteq> Rep_upsets Y".

lift_definition less_upsets :: "'a upsets \<Rightarrow> 'a upsets \<Rightarrow> bool" is "\<lambda>X Y. Rep_upsets X \<subset> Rep_upsets Y".

instance
  apply intro_classes
      apply (transfer, simp)
     apply (transfer, blast)
    apply (simp add: Closure_Operators.less_eq_upsets.abs_eq Rep_upsets_inject)
   apply (transfer, smt Abs_upsets_inverse Inf_closed_clop_var Inf_lower Rep_upsets comp_apply image_iff preorder_clop_dual)
  by transfer (smt comp_def Abs_upsets_inverse Inf_closed_clop_var Inter_iff Rep_upsets image_iff preorder_clop_dual subsetCE subsetI)

end

text \<open>It has already been shown in the section on representations that the map ds, which maps elements of the order to its downset, is an order
embedding. However, the duality between the underlying ordering and the lattices of up- and down-closed sets as categories can probably not be expressed,
as there is no easy access to contravariant functors. \<close>

subsection \<open>Co-Closure Operators\<close>

text \<open>Next, the co-closure (or kernel) operation satisfies dual laws.\<close>

definition coclop :: "('a::order \<Rightarrow> 'a::order) \<Rightarrow> bool" where
  "coclop f = (f \<le> id \<and> mono f \<and> f \<le> f \<circ> f)"

lemma coclop_dual: "(coclop::('a::order_with_dual \<Rightarrow> 'a) \<Rightarrow> bool) = clop \<circ> \<partial>\<^sub>F"
  unfolding coclop_def clop_def id_def mono_def map_dual_def comp_def fun_eq_iff le_fun_def
  by (metis invol_dual_var ord_dual)

lemma coclop_dual_var:
  fixes f :: "'a::order_with_dual \<Rightarrow> 'a"
  shows "coclop f = clop (\<partial>\<^sub>F f)"
  by (simp add: coclop_dual)

lemma clop_dual: "(clop::('a::order_with_dual \<Rightarrow> 'a) \<Rightarrow> bool) = coclop \<circ> \<partial>\<^sub>F"
  by (simp add: coclop_dual comp_assoc map_dual_invol)

lemma clop_dual_var:
  fixes f :: "'a::order_with_dual \<Rightarrow> 'a"
  shows "clop f = coclop (\<partial>\<^sub>F f)"
  by (simp add: clop_dual)

lemma coclop_coextensive: "coclop f \<Longrightarrow> f \<le> id"
  by (simp add: coclop_def)

lemma coclop_coextensive_var: "coclop f \<Longrightarrow> f x \<le> x"
  using coclop_def le_funD by fastforce

lemma coclop_iso: "coclop f \<Longrightarrow> mono f"
  by (simp add: coclop_def)

lemma coclop_iso_var: "coclop f \<Longrightarrow> (x \<le> y \<longrightarrow> f x \<le> f y)"
  by (simp add: coclop_iso monoD)

lemma coclop_idem: "coclop f \<Longrightarrow> f \<circ> f = f"
  by (simp add: antisym coclop_def le_fun_def)

lemma coclop_closure: "coclop f \<Longrightarrow> (x \<in> range f) = (f x = x)"
  by (simp add: coclop_idem retraction_prop)

lemma coclop_Fix_range: "coclop f \<Longrightarrow> (Fix f = range f)"
  by (simp add: coclop_idem retraction_prop_fix)

lemma coclop_idem_var: "coclop f \<Longrightarrow> f (f x) = f x"
  by (simp add: coclop_idem retraction_prop)

lemma coclop_Sup_closed_var:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'a"
  shows "coclop f \<Longrightarrow> f \<circ> Sup \<circ> (`) f  = Sup \<circ> (`) f"
  unfolding coclop_def mono_def comp_def le_fun_def
  by (metis (mono_tags, lifting) SUP_le_iff antisym id_apply order_refl)

lemma Sup_closed_coclop_var:
  fixes X :: "'a::complete_lattice set"
  shows "coclop f \<Longrightarrow> \<forall>x \<in> X. x \<in> range f \<Longrightarrow> \<Squnion>X \<in> range f"
  by (smt Inf.INF_id_eq Sup.SUP_cong antisym coclop_closure coclop_coextensive_var coclop_iso id_apply mono_SUP)

lemma coclop_bot:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'a"
  shows "coclop f \<Longrightarrow> f \<bottom> = \<bottom>"
  by (simp add: bot.extremum_uniqueI coclop_coextensive_var)

lemma "coclop (f::'a::complete_lattice \<Rightarrow> 'a) \<Longrightarrow> f (\<Sqinter>x \<in> X. f x) = (\<Sqinter>x \<in> X. f x)" (*nitpick*)
  oops

lemma "coclop (f::'a::complete_lattice \<Rightarrow> 'a) \<Longrightarrow> f (f x \<sqinter> f y) = f x \<sqinter> f y" (*nitpick*)
  oops

lemma  "coclop (f::'a::complete_lattice \<Rightarrow> 'a) \<Longrightarrow> f \<top> = \<top>" (*nitpick*)
  oops

lemma "coclop (f::'a set \<Rightarrow> 'a set) \<Longrightarrow> f (\<Sqinter>x \<in> X. f x) = (\<Sqinter>x \<in> X. f x)" (*nitpick*)
  oops

lemma "coclop (f::'a set \<Rightarrow> 'a set) \<Longrightarrow> f (f x \<sqinter> f y) = f x \<sqinter> f y" (*nitpick*)
  oops

lemma  "coclop (f::'a set \<Rightarrow> 'a set) \<Longrightarrow> f \<top> = \<top>" (*nitpick *)
  oops

lemma coclop_coclosure: "coclop f \<Longrightarrow> f x = x \<longleftrightarrow> x \<in> range f"
 by (simp add: coclop_idem retraction_prop)

lemma coclop_coclosure_set: "coclop f \<Longrightarrow> range f = Fix f"
  by (simp add: coclop_idem retraction_prop_fix)

lemma coclop_coclosure_prop: "(coclop::('a::complete_lattice \<Rightarrow> 'a) \<Rightarrow> bool) (Sup \<circ> \<down>)"
  by (simp add: coclop_def mono_def)

lemma coclop_coclosure_prop_var: "coclop (\<lambda>x::'a::complete_lattice. \<Squnion>{y. y \<le> x})"
  by (metis (mono_tags, lifting) Sup_atMost atMost_def coclop_def comp_apply eq_id_iff eq_refl mono_def)

lemma coclop_alt: "(coclop f) = (\<forall>x y. f x \<le> y \<longleftrightarrow> f x \<le> f y)"
  unfolding coclop_def mono_def le_fun_def comp_def id_def
  by (meson dual_order.refl order_trans)

lemma coclop_adj:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "f \<stileturn> g \<Longrightarrow> coclop (f \<circ> g)"
  by (simp add: adj_cancel1 adj_idem1 adj_iso3 coclop_def)

text \<open>Finally, a subset of a complete lattice is Sup-closed if and only if it is the set of fixpoints
of some co-closure operator.\<close>

lemma coclop_Sup_closed:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  shows  "coclop f \<Longrightarrow> Sup_closed_set (Fix f)"
  unfolding coclop_def Sup_closed_set_def mono_def le_fun_def comp_def id_def Fix_def
  by (smt Sup_least Sup_upper antisym_conv mem_Collect_eq subsetCE)

lemma Sup_closed_coclop:
  fixes X :: "'a::complete_lattice set"
  shows "Sup_closed_set X \<Longrightarrow> coclop (\<lambda>y. \<Squnion>{x \<in> X. x \<le> y})"
  unfolding Sup_closed_set_def coclop_def mono_def le_fun_def comp_def
  apply safe
  apply (metis (no_types, lifting) Sup_least eq_id_iff mem_Collect_eq)
  apply (smt Collect_mono_iff Sup_subset_mono dual_order.trans)
  by (simp add: Collect_mono_iff Sup_subset_mono Sup_upper)

subsection \<open>Complete Lattices of Closed Elements\<close>

text \<open>The machinery developed allows showing that the closed elements in a complete
lattice (with respect to some closure operation) form themselves a complete lattice.\<close>

class cl_op = ord +
  fixes cl_op :: "'a \<Rightarrow> 'a"
  assumes clop_ext: "x \<le> cl_op x"
  and clop_iso: "x \<le> y \<Longrightarrow> cl_op x \<le> cl_op y"
  and clop_wtrans: "cl_op (cl_op x) \<le> cl_op x"

class clattice_with_clop = complete_lattice + cl_op

begin

lemma clop_cl_op: "clop cl_op"
  unfolding clop_def le_fun_def comp_def
  by (simp add: cl_op_class.clop_ext cl_op_class.clop_iso cl_op_class.clop_wtrans order_class.mono_def)

lemma clop_idem [simp]: "cl_op \<circ> cl_op = cl_op"
  using clop_ext clop_wtrans order.antisym by auto

lemma clop_idem_var [simp]: "cl_op (cl_op x) = cl_op x"
  by (simp add: antisym clop_ext clop_wtrans)

lemma clop_range_Fix: "range cl_op = Fix cl_op"
  by (simp add: retraction_prop_fix)

lemma Inf_closed_cl_op_var:
  fixes X :: "'a set"
  shows "\<forall>x \<in> X. x \<in> range cl_op \<Longrightarrow> \<Sqinter>X \<in> range cl_op"
proof-
  assume h: "\<forall>x \<in> X. x \<in> range cl_op"
  hence "\<forall>x \<in> X. cl_op x = x"
    by (simp add: retraction_prop)
  hence "cl_op (\<Sqinter>X) = \<Sqinter>X"
    by (metis Inf_lower clop_ext clop_iso dual_order.antisym le_Inf_iff)
  thus ?thesis
    by (metis rangeI)
qed

lemma inf_closed_cl_op_var: "x \<in> range cl_op \<Longrightarrow> y \<in> range cl_op \<Longrightarrow> x \<sqinter> y \<in> range cl_op"
  by (smt Inf_closed_cl_op_var UnI1 insert_iff insert_is_Un inf_Inf)

end

typedef (overloaded) 'a::clattice_with_clop cl_op_im = "range (cl_op::'a \<Rightarrow> 'a)"
  by force

setup_lifting type_definition_cl_op_im

lemma cl_op_prop [iff]: "(cl_op (x \<squnion> y) = cl_op y) = (cl_op (x::'a::clattice_with_clop) \<le> cl_op y)"
  by (smt cl_op_class.clop_iso clop_ext clop_wtrans inf_sup_ord(4) le_iff_sup sup.absorb_iff1 sup_left_commute)

lemma cl_op_prop_var [iff]: "(cl_op (x \<squnion> cl_op y) = cl_op y) = (cl_op (x::'a::clattice_with_clop) \<le> cl_op y)"
  by (metis cl_op_prop clattice_with_clop_class.clop_idem_var)

instantiation cl_op_im :: (clattice_with_clop) complete_lattice
begin

lift_definition Inf_cl_op_im :: "'a cl_op_im set \<Rightarrow> 'a cl_op_im" is Inf
  by (simp add: Inf_closed_cl_op_var)

lift_definition Sup_cl_op_im :: "'a cl_op_im set \<Rightarrow> 'a cl_op_im" is "\<lambda>X. cl_op (\<Squnion>X)"
  by simp

lift_definition inf_cl_op_im :: "'a cl_op_im \<Rightarrow> 'a cl_op_im \<Rightarrow> 'a cl_op_im" is inf
  by (simp add: inf_closed_cl_op_var)

lift_definition sup_cl_op_im :: "'a cl_op_im \<Rightarrow> 'a cl_op_im \<Rightarrow> 'a cl_op_im" is "\<lambda>x y. cl_op (x \<squnion> y)"
  by simp

lift_definition less_eq_cl_op_im :: "'a cl_op_im \<Rightarrow> 'a cl_op_im \<Rightarrow> bool" is "(\<le>)".

lift_definition less_cl_op_im :: "'a cl_op_im \<Rightarrow> 'a cl_op_im \<Rightarrow> bool" is "(<)".

lift_definition bot_cl_op_im :: "'a cl_op_im" is "cl_op \<bottom>"
  by simp

lift_definition top_cl_op_im :: "'a cl_op_im" is "\<top>"
  by (simp add: clop_cl_op clop_closure clop_top)

instance
  apply (intro_classes; transfer)
                 apply (simp_all add: less_le_not_le Inf_lower Inf_greatest)
      apply (meson clop_cl_op clop_extensive_var dual_order.trans inf_sup_ord(3))
     apply (meson clop_cl_op clop_extensive_var dual_order.trans sup_ge2)
    apply (metis cl_op_class.clop_iso clop_cl_op clop_closure le_sup_iff)
   apply (meson Sup_upper clop_cl_op clop_extensive_var dual_order.trans)
  by (metis Sup_le_iff cl_op_class.clop_iso clop_cl_op clop_closure)

end

text \<open>This statement is perhaps less useful as it might seem, because it is difficult to make it cooperate with concrete closure operators,
which one would not generally like to define within a type class. Alternatively, a sublocale statement could perhaps be given. It would also
have been nice to prove this statement for Sup-lattices---this would have cut down the number of proof obligations significantly.
But this would require a tighter integration of these structures. A similar statement could have been proved for co-closure operators. But this would
not lead to new insights.\<close>

text \<open>Next I show that for every surjective Sup-preserving function between complete lattices there is a closure operator
such that the set of closed elements is isomorphic to the range of the surjection.\<close>

lemma surj_Sup_pres_id:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  assumes "surj f"
  and "Sup_pres f"
  shows "f \<circ> (radj f) = id"
proof-
  have "f \<stileturn> (radj f)"
    using Sup_pres_ladj assms(2) radj_adj by auto
  thus ?thesis
    using adj_sur_inv assms(1) by blast
qed

lemma surj_Sup_pres_inj:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  assumes "surj f"
  and "Sup_pres f"
  shows "inj (radj f)"
  by (metis assms comp_eq_dest_lhs id_apply injI surj_Sup_pres_id)

lemma surj_Sup_pres_inj_on:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  assumes "surj f"
  and "Sup_pres f"
  shows "inj_on f (range (radj f \<circ> f))"
  by (smt Sup_pres_ladj_aux adj_idem2 assms(2) comp_apply inj_on_def retraction_prop)

lemma surj_Sup_pres_bij_on:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  assumes "surj f"
  and "Sup_pres f"
  shows "bij_betw f (range (radj f \<circ> f)) UNIV"
  unfolding bij_betw_def
  apply safe
    apply (simp add: assms(1) assms(2) surj_Sup_pres_inj_on cong del: image_cong_simp)
   apply auto
  apply (metis (mono_tags) UNIV_I assms(1) assms(2) comp_apply id_apply image_image surj_Sup_pres_id surj_def)
  done

text \<open>Thus the restriction of $f$ to the set of closed elements is indeed a bijection. The final fact
shows that it preserves Sups of closed elements, and hence is an isomorphism of complete lattices.\<close>

lemma surj_Sup_pres_iso:
  fixes f :: "'a::complete_lattice_with_dual \<Rightarrow> 'b::complete_lattice_with_dual"
  assumes "surj f"
  and "Sup_pres f"
  shows "f ((radj f \<circ> f) (\<Squnion>X)) = (\<Squnion>x \<in> X. f x)"
  by (metis assms(1) assms(2) comp_def pointfree_idE surj_Sup_pres_id)

subsection \<open>A Quick Example: Dedekind-MacNeille Completions\<close>

text \<open>I only outline the basic construction. Additional facts about join density, and that the completion yields
the least complete lattice that contains all Sups and Infs of the underlying posets, are left for future consideration.\<close>

abbreviation "dm \<equiv> lb_set \<circ> ub_set"

lemma up_set_prop: "(X::'a::preorder set) \<noteq> {} \<Longrightarrow> ub_set X = \<Inter>{\<up>x |x. x \<in> X}"
  unfolding ub_set_def upset_def upset_set_def by (safe, simp_all, blast)

lemma lb_set_prop: "(X::'a::preorder set) \<noteq> {} \<Longrightarrow> lb_set X = \<Inter>{\<down>x |x. x \<in> X}"
  unfolding lb_set_def downset_def downset_set_def by (safe, simp_all, blast)

lemma dm_downset_var: "dm {x} = \<down>(x::'a::preorder)"
  unfolding lb_set_def ub_set_def downset_def downset_set_def
  by (clarsimp, meson order_refl order_trans)

lemma dm_downset: "dm \<circ> \<eta> = (\<down>::'a::preorder \<Rightarrow> 'a set)"
  using dm_downset_var fun.map_cong by fastforce

lemma dm_inj: "inj ((dm::'a::order set \<Rightarrow> 'a set) \<circ> \<eta>)"
  by (simp add: dm_downset downset_inj)

lemma "clop (lb_set \<circ> ub_set)"
  unfolding clop_def lb_set_def ub_set_def
  apply safe
  unfolding le_fun_def comp_def id_def mono_def
  by auto

end


(*
  File:     List_Inversions.thy
  Author:   Manuel Eberl, TU München

  A formalisation of inversions of a list and the O(n log n) divide-and-conquer algorithm
  to count them.
*)
section \<open>The Inversions of a List\<close>
theory List_Inversions
imports
  Main
  "HOL-Combinatorics.Permutations"
begin

subsection \<open>Definition of inversions\<close>

context preorder
begin

text \<open>
  We define inversions as pair of indices w.\,r.\,t.\ a preorder.
\<close>
inductive_set inversions :: "'a list \<Rightarrow> (nat \<times> nat) set" for xs :: "'a list" where
  "i < j \<Longrightarrow> j < length xs \<Longrightarrow> less (xs ! j) (xs ! i) \<Longrightarrow> (i, j) \<in> inversions xs"

lemma inversions_subset: "inversions xs \<subseteq> Sigma {..<length xs} (\<lambda>i. {i<..<length xs})"
  by (auto simp: inversions.simps)

lemma finite_inversions [intro]: "finite (inversions xs)"
  by (rule finite_subset[OF inversions_subset]) auto

lemma inversions_altdef: "inversions xs = {(i, j). i < j \<and> j < length xs \<and> less (xs ! j) (xs ! i)}"
  by (auto simp: inversions.simps)

lemma inversions_code:
  "inversions xs =
     Sigma {..<length xs} (\<lambda>i. Set.filter (\<lambda>j. less (xs ! j) (xs ! i)) {i<..<length xs})"
  by (auto simp: inversions_altdef)

lemmas (in -) [code] = inversions_code

lemma inversions_trivial [simp]: "length xs \<le> Suc 0 \<Longrightarrow> inversions xs = {}"
  by (auto simp: inversions_altdef)

lemma inversions_imp_less:
  "z \<in> inversions xs \<Longrightarrow> fst z < snd z"
  "z \<in> inversions xs \<Longrightarrow> snd z < length xs"
  by (auto simp: inversions_altdef)

lemma inversions_Nil [simp]: "inversions [] = {}"
  by (auto simp: inversions_altdef)

lemma inversions_Cons:
  "inversions (x # xs) =
     (\<lambda>j. (0, j + 1)) ` {j\<in>{..<length xs}. less (xs ! j) x} \<union>
     map_prod Suc Suc ` inversions xs" (is "_ = ?rhs")
proof -
  have "z \<in> inversions (x # xs) \<longleftrightarrow> z \<in> ?rhs" for z
    by (cases z) (auto simp: inversions_altdef map_prod_def nth_Cons split: nat.splits)
  thus ?thesis by blast
qed

text \<open>
  The following function returns the inversions between two lists, i.\,e.\ all pairs of
  an element in the first list with an element in the second list such that the former
  is greater than the latter.
\<close>
definition inversions_between :: "'a list \<Rightarrow> 'a list \<Rightarrow> (nat \<times> nat) set" where
  "inversions_between xs ys =
     {(i, j) \<in> {..<length xs}\<times>{..<length ys}. less (ys ! j) (xs ! i)}"

lemma finite_inversions_between [intro]: "finite (inversions_between xs ys)"
    by (rule finite_subset[of _ "{..<length xs} \<times> {..<length xs + length ys}"])
       (auto simp: inversions_between_def)

lemma inversions_between_Nil [simp]:
  "inversions_between [] ys = {}"
  "inversions_between xs [] = {}"
  by (simp_all add: inversions_between_def)

text \<open>
  We can now show the following equality for the inversions of the concatenation of two lists:
\<close>
proposition inversions_append:
  fixes xs ys
  defines "m \<equiv> length xs" and "n \<equiv> length ys"
  shows "inversions (xs @ ys) =
           inversions xs \<union> map_prod ((+) m) ((+) m) ` inversions ys \<union>
           map_prod id ((+) m) ` inversions_between xs ys"
        (is "_ = ?rhs")
proof -
  note defs = inversions_altdef inversions_between_def m_def n_def map_prod_def
  have "z \<in> inversions (xs @ ys) \<longleftrightarrow> z \<in> ?rhs" for z
  proof
    assume "z \<in> inversions (xs @ ys)"
    then obtain i j where [simp]: "z = (i, j)"
                      and ij: "i < j" "j < m + n" "less ((xs @ ys) ! j) ((xs @ ys) ! i)"
      by (cases z) (auto simp: inversions_altdef m_def n_def)
    from ij consider "j < m" | "i \<ge> m" | "i < m" "j \<ge> m" by linarith
    thus "z \<in> ?rhs"
    proof cases
      assume "i < m" "j \<ge> m"
      define j' where "j' = j - m"
      have [simp]: "j = m + j'"
        using \<open>j \<ge> m\<close> by (simp add: j'_def)
      from ij and \<open>i < m\<close> show ?thesis
        by (auto simp: inversions_altdef map_prod_def inversions_between_def nth_append m_def n_def)
    next
      assume "i \<ge> m"
      define i' j' where "i' = i - m" and "j' = j - m"
      have [simp]: "i = m + i'" "j = m + j'"
        using \<open>i < j\<close> and \<open>i \<ge> m\<close> by (simp_all add: i'_def j'_def)
      from ij show ?thesis
        by (auto simp: inversions_altdef map_prod_def nth_append m_def n_def)
    qed (use ij in \<open>auto simp: nth_append defs\<close>)
  qed (auto simp: nth_append defs)
  thus ?thesis by blast
qed

subsection \<open>Counting inversions\<close>

text \<open>
  We now define versions of @{const inversions} and @{const inversions_between} that
  only return the \<^emph>\<open>number\<close> of inversions.
\<close>
definition inversion_number :: "'a list \<Rightarrow> nat" where
  "inversion_number xs = card (inversions xs)"

definition inversion_number_between where
  "inversion_number_between xs ys = card (inversions_between xs ys)"

lemma inversions_between_code:
  "inversions_between xs ys =
     Set.filter (\<lambda>(i,j). less (ys ! j) (xs ! i)) ({..<length xs}\<times>{..<length ys})"
  by (auto simp: inversions_between_def)

lemmas (in -) [code] = inversions_between_code

lemma inversion_number_Nil [simp]: "inversion_number [] = 0"
  by (simp add: inversion_number_def)

lemma inversion_number_trivial [simp]: "length xs \<le> Suc 0 \<Longrightarrow> inversion_number xs = 0"
  by (auto simp: inversion_number_def)

lemma inversion_number_between_Nil [simp]:
  "inversion_number_between [] ys = 0"
  "inversion_number_between xs [] = 0"
  by (simp_all add: inversion_number_between_def)

text \<open>
  We again get the following nice equation for the number of inversions of a concatenation:
\<close>
proposition inversion_number_append:
  "inversion_number (xs @ ys) =
     inversion_number xs + inversion_number ys + inversion_number_between xs ys"
proof -
  define m n where "m = length xs" and "n = length ys"
  let ?A = "inversions xs"
  let ?B = "map_prod ((+) m) ((+) m) ` inversions ys"
  let ?C = "map_prod id ((+) m) ` inversions_between xs ys"

  have "inversion_number (xs @ ys) = card (?A \<union> ?B \<union> ?C)"
    by (simp add: inversion_number_def inversions_append m_def)
  also have "\<dots> = card (?A \<union> ?B) + card ?C"
    by (intro card_Un_disjoint finite_inversions finite_inversions_between finite_UnI finite_imageI)
       (auto simp: inversions_altdef inversions_between_def m_def n_def)
  also have "card (?A \<union> ?B) = inversion_number xs + card ?B" unfolding inversion_number_def
    by (intro card_Un_disjoint finite_inversions finite_UnI finite_imageI)
       (auto simp: inversions_altdef m_def n_def)
  also have "card ?B = inversion_number ys" unfolding inversion_number_def
    by (intro card_image) (auto simp: map_prod_def inj_on_def)
  also have "card ?C = inversion_number_between xs ys"
    unfolding inversion_number_between_def by (intro card_image inj_onI) (auto simp: map_prod_def)
  finally show ?thesis .
qed

subsection \<open>Stability of inversions between lists under permutations\<close>

text \<open>
  A crucial fact for counting list inversions with merge sort is that the number
  of inversions \<^emph>\<open>between\<close> two lists does not change when the lists are permuted. This is
  true because the set of inversions commutes with the act of permuting the list:
\<close>
lemma inversions_between_permute1:
  assumes "\<pi> permutes {..<length xs}"
  shows   "inversions_between (permute_list \<pi> xs) ys =
             map_prod (inv \<pi>) id ` inversions_between xs ys"
proof -
  from assms have [simp]: "\<pi> i < length xs" if "i < length xs" "\<pi> permutes {..<length xs}" for i \<pi>
    using permutes_in_image[OF that(2)] that by auto
  have *: "inv \<pi> permutes {..<length xs}"
    using assms by (rule permutes_inv)
  from assms * show ?thesis unfolding inversions_between_def map_prod_def
    by (force simp: image_iff permute_list_nth permutes_inverses intro: exI[of _ "\<pi> i" for i])
qed

lemma inversions_between_permute2:
  assumes "\<pi> permutes {..<length ys}"
  shows   "inversions_between xs (permute_list \<pi> ys) =
             map_prod id (inv \<pi>) ` inversions_between xs ys"
proof -
  from assms have [simp]: "\<pi> i < length ys" if "i < length ys" "\<pi> permutes {..<length ys}" for i \<pi>
    using permutes_in_image[OF that(2)] that by auto
  have *: "inv \<pi> permutes {..<length ys}"
    using assms by (rule permutes_inv)
  from assms * show ?thesis unfolding inversions_between_def map_prod_def
    by (force simp: image_iff permute_list_nth permutes_inverses intro: exI[of _ "\<pi> i" for i])
qed

proposition inversions_between_permute:
  assumes "\<pi>1 permutes {..<length xs}" and "\<pi>2 permutes {..<length ys}"
  shows   "inversions_between (permute_list \<pi>1 xs) (permute_list \<pi>2 ys) =
             map_prod (inv \<pi>1) (inv \<pi>2) ` inversions_between xs ys"
  by (simp add: inversions_between_permute1 inversions_between_permute2 assms
                map_prod_def image_image case_prod_unfold)

corollary inversion_number_between_permute:
  assumes "\<pi>1 permutes {..<length xs}" and "\<pi>2 permutes {..<length ys}"
  shows   "inversion_number_between (permute_list \<pi>1 xs) (permute_list \<pi>2 ys) =
             inversion_number_between xs ys"
proof -
  have "inversion_number_between (permute_list \<pi>1 xs) (permute_list \<pi>2 ys) =
          card (map_prod (inv \<pi>1) (inv \<pi>2) ` inversions_between xs ys)"
    by (simp add: inversion_number_between_def inversions_between_permute assms)
  also have "\<dots> = inversion_number_between xs ys"
    unfolding inversion_number_between_def using assms[THEN permutes_inj_on[OF permutes_inv]]
    by (intro card_image inj_onI) (auto simp: map_prod_def)
  finally show ?thesis .
qed

text \<open>
  The following form of the above theorem is nicer to apply since it has the form of a
  congruence rule.
\<close>
corollary inversion_number_between_cong_mset:
  assumes "mset xs = mset xs'" and "mset ys = mset ys'"
  shows   "inversion_number_between xs ys = inversion_number_between xs' ys'"
proof -
  obtain \<pi>1 \<pi>2 where \<pi>12: "\<pi>1 permutes {..<length xs'}" "xs = permute_list \<pi>1 xs'"
                          "\<pi>2 permutes {..<length ys'}" "ys = permute_list \<pi>2 ys'"
    using assms[THEN mset_eq_permutation] by metis
  thus ?thesis by (simp add: inversion_number_between_permute)
qed

subsection \<open>Inversions between sorted lists\<close>

text \<open>
  Another fact that is crucial to the efficient computation of the inversion number is this:
  If we have two sorted lists, we can reduce computing the inversions by inspecting the
  first elements and deleting one of them.
\<close>
lemma inversions_between_Cons_Cons:
  assumes "sorted_wrt less_eq (x # xs)" and "sorted_wrt less_eq (y # ys)"
  shows   "inversions_between (x # xs) (y # ys) =
             (if \<not>less y x then
                map_prod Suc id ` inversions_between xs (y # ys)
              else
                {..<length (x#xs)} \<times> {0} \<union>
                map_prod id Suc ` inversions_between (x # xs) ys)"
  using assms  unfolding inversions_between_def map_prod_def
  by (auto, (auto simp: set_conv_nth nth_Cons less_le_not_le image_iff
                  intro: order_trans split: nat.splits)?)
  (* A bit fragile, but doing this manually is annoying *)

text \<open>
  This leads to the following analogous equation for counting the inversions between two
  sorted lists. Note that a single step of this only takes constant time (assuming we
  pre-computed the lengths of the lists) so that the entire function runs in linear time.
\<close>

text \<open>
  We now define a function to compute the inversion number between two lists that are
  assumed to be sorted using the equalities we just derived.
\<close>
fun inversion_number_between_sorted :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat" where
  "inversion_number_between_sorted [] ys = 0"
| "inversion_number_between_sorted xs [] = 0"
| "inversion_number_between_sorted (x # xs) (y # ys) =
             (if \<not>less y x then
                inversion_number_between_sorted xs (y # ys)
              else
                inversion_number_between_sorted (x # xs) ys + length (x # xs))"

theorem inversion_number_between_sorted_correct:
  "sorted_wrt less_eq xs \<Longrightarrow> sorted_wrt less_eq ys \<Longrightarrow>
     inversion_number_between_sorted xs ys = inversion_number_between xs ys"
  by (induction xs ys rule: inversion_number_between_sorted.induct)
     (simp_all add: inversion_number_between_Cons_Cons)

end

subsection \<open>Merge sort\<close>

(* TODO: Could be replaced by mergesort from HOL-Library in Isabelle 2019. *)
text \<open>
  For convenience, we first define a simple merge sort that does not compute the inversions.
  At this point, we need to start assuming a linear ordering since the merging function
  does not work otherwise.
\<close>

context linorder
begin

definition split_list
  where "split_list xs = (let n = length xs div 2 in (take n xs, drop n xs))"

fun merge_lists :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "merge_lists [] ys = ys"
| "merge_lists xs [] = xs"
| "merge_lists (x # xs) (y # ys) =
    (if less_eq x y then x # merge_lists xs (y # ys) else y # merge_lists (x # xs) ys)"

lemma set_merge_lists [simp]: "set (merge_lists xs ys) = set xs \<union> set ys"
  by (induction xs ys rule: merge_lists.induct) auto

lemma mset_merge_lists [simp]: "mset (merge_lists xs ys) = mset xs + mset ys"
  by (induction xs ys rule: merge_lists.induct) auto

lemma sorted_merge_lists [simp, intro]:
  "sorted xs \<Longrightarrow> sorted ys \<Longrightarrow> sorted (merge_lists xs ys)"
  by (induction xs ys rule: merge_lists.induct) auto

fun merge_sort :: "'a list \<Rightarrow> 'a list" where
  "merge_sort xs =
    (if length xs \<le> 1 then
       xs
     else
       merge_lists (merge_sort (take (length xs div 2) xs))
                   (merge_sort (drop (length xs div 2) xs)))"

lemmas [simp del] = merge_sort.simps

lemma merge_sort_trivial [simp]: "length xs \<le> Suc 0 \<Longrightarrow> merge_sort xs = xs"
  by (subst merge_sort.simps) auto

theorem mset_merge_sort [simp]: "mset (merge_sort xs) = mset xs"
  by (induction xs rule: merge_sort.induct)
     (subst merge_sort.simps, auto simp flip: mset_append)

corollary set_merge_sort [simp]: "set (merge_sort xs) = set xs"
  by (rule mset_eq_setD) simp_all

theorem sorted_merge_sort [simp, intro]: "sorted (merge_sort xs)"
  by (induction xs rule: merge_sort.induct)
     (subst merge_sort.simps, use sorted01 in auto)

lemma inversion_number_between_code:
  "inversion_number_between xs ys = inversion_number_between_sorted (sort xs) (sort ys)"
  by (subst inversion_number_between_sorted_correct)
     (simp_all add: cong: inversion_number_between_cong_mset)

lemmas (in -) [code_unfold] = inversion_number_between_code

subsection \<open>Merge sort with inversion counting\<close>

text \<open>
  Finally, we can put together all the components and define a variant of merge sort that
  counts the number of inversions in the original list:
\<close>
function sort_and_count_inversions :: "'a list \<Rightarrow> 'a list \<times> nat" where
  "sort_and_count_inversions xs =
     (if length xs \<le> 1 then
        (xs, 0)
      else
        let (xs1, xs2) = split_list xs;
            (xs1', m) = sort_and_count_inversions xs1;
            (xs2', n) = sort_and_count_inversions xs2
        in
            (merge_lists xs1' xs2', m + n + inversion_number_between_sorted xs1' xs2'))"
  by auto
termination by (relation "measure length") (auto simp: split_list_def Let_def)

lemmas [simp del] = sort_and_count_inversions.simps

text \<open>
  The projection of this function to the first component is simply the standard merge sort
  algorithm that we defined and proved correct before.
\<close>
theorem fst_sort_and_count_inversions [simp]:
  "fst (sort_and_count_inversions xs) = merge_sort xs"
  by (induction xs rule: length_induct)
     (subst sort_and_count_inversions.simps, subst merge_sort.simps,
      simp_all add: split_list_def case_prod_unfold Let_def)

text \<open>
  The projection to the second component is the inversion number.
\<close>
theorem snd_sort_and_count_inversions [simp]:
  "snd (sort_and_count_inversions xs) = inversion_number xs"
proof (induction xs rule: length_induct)
  case (1 xs)
  show ?case
  proof (cases "length xs \<le> 1")
    case False
    have "xs = take (length xs div 2) xs @ drop (length xs div 2) xs" by simp
    also have "inversion_number \<dots> = snd (sort_and_count_inversions xs)"
      by (subst inversion_number_append, subst sort_and_count_inversions.simps)
         (use False 1 in \<open>auto simp: Let_def split_list_def case_prod_unfold
                                     inversion_number_between_sorted_correct
                               cong: inversion_number_between_cong_mset\<close>)
    finally show ?thesis ..
  qed (auto simp: sort_and_count_inversions.simps)
qed

lemmas (in -) [code_unfold] = snd_sort_and_count_inversions [symmetric]

end

end


(* -------------------------------------------------------------------------- *)
subsection \<open>Generalized Unitary Matrices\<close>
(* -------------------------------------------------------------------------- *)

theory Unitary_Matrices
imports Matrices More_Complex
begin

text \<open>In this section (generalized) $2\times 2$ unitary matrices are introduced.\<close>

text \<open>Unitary matrices\<close>
definition unitary where
  "unitary M \<longleftrightarrow> mat_adj M *\<^sub>m\<^sub>m M = eye"

text \<open>Generalized unitary matrices\<close>
definition unitary_gen where
  "unitary_gen M \<longleftrightarrow>
   (\<exists> k::complex. k \<noteq> 0 \<and> mat_adj M *\<^sub>m\<^sub>m M = k *\<^sub>s\<^sub>m eye)"

text \<open>Scalar can be always be a positive real\<close>
lemma unitary_gen_real:
  assumes "unitary_gen M"
  shows "(\<exists> k::real. k > 0 \<and> mat_adj M *\<^sub>m\<^sub>m M = cor k *\<^sub>s\<^sub>m eye)"
proof-
  obtain k where *: "mat_adj M *\<^sub>m\<^sub>m M = k *\<^sub>s\<^sub>m eye" "k \<noteq> 0"
    using assms
    by (auto simp add: unitary_gen_def)
  obtain a b c d where "M = (a, b, c, d)"
    by (cases M) auto
  hence "k = cor ((cmod a)\<^sup>2) + cor ((cmod c)\<^sup>2)"
    using *
    by (subst  complex_mult_cnj_cmod[symmetric])+ (auto simp add: mat_adj_def mat_cnj_def)
  hence "is_real k \<and> Re k > 0"
    using \<open>k \<noteq> 0\<close>
    by (smt add_cancel_left_left arg_0_iff arg_complex_of_real_positive not_sum_power2_lt_zero of_real_0 plus_complex.simps(1) plus_complex.simps(2))
  thus ?thesis
    using *
    by (rule_tac x="Re k" in exI) simp
qed

text \<open>Generalized unitary matrices can be factored into a product of a unitary matrix and a real
positive scalar multiple of the identity matrix\<close>
lemma unitary_gen_unitary:
  shows "unitary_gen M \<longleftrightarrow>
         (\<exists> k M'. k > 0 \<and> unitary M' \<and> M = (cor k *\<^sub>s\<^sub>m eye) *\<^sub>m\<^sub>m M')" (is "?lhs = ?rhs")
proof
  assume ?lhs
  then obtain k where *: "k>0" "mat_adj M *\<^sub>m\<^sub>m M = cor k *\<^sub>s\<^sub>m eye"
    using unitary_gen_real[of M]
    by auto

  let ?k' = "cor (sqrt k)"
  have "?k' * cnj ?k' = cor k"
    using \<open>k > 0\<close>
    by simp
  moreover
  have "Re ?k' > 0" "is_real ?k'" "?k' \<noteq> 0"
    using \<open>k > 0\<close>
    by auto
  ultimately
  show ?rhs
    using * mat_eye_l
    unfolding unitary_gen_def unitary_def
    by (rule_tac x="Re ?k'" in exI) (rule_tac x="(1/?k')*\<^sub>s\<^sub>mM" in exI, simp add: mult_sm_mm[symmetric])
next
  assume ?rhs
  then obtain k M' where "k > 0" "unitary M'" "M = (cor k *\<^sub>s\<^sub>m eye) *\<^sub>m\<^sub>m M'"
    by blast
  hence "M = cor k *\<^sub>s\<^sub>m M'"
    using mult_sm_mm[of "cor k" eye M'] mat_eye_l
    by simp
  thus ?lhs
    using \<open>unitary M'\<close> \<open>k > 0\<close>
    by (simp add: unitary_gen_def unitary_def)
qed

text \<open>When they represent Möbius transformations, eneralized unitary matrices fix the imaginary unit circle. Therefore, they
fix a Hermitean form with (2, 0) signature (two positive and no negative diagonal elements).\<close>
lemma unitary_gen_iff':
  shows "unitary_gen M \<longleftrightarrow>
         (\<exists> k::complex. k \<noteq> 0 \<and> congruence M (1, 0, 0, 1) = k *\<^sub>s\<^sub>m (1, 0, 0, 1))"
  unfolding unitary_gen_def
  using mat_eye_r
  by (auto simp add: mult.assoc)

text \<open>Unitary matrices are special cases of general unitary matrices\<close>
lemma unitary_unitary_gen [simp]:
  assumes "unitary M"
  shows "unitary_gen M"
  using assms
  unfolding unitary_gen_def unitary_def
  by auto

text \<open>Generalized unitary matrices are regular\<close>
lemma unitary_gen_regular:
  assumes "unitary_gen M"
  shows "mat_det M \<noteq> 0"
proof-
  from assms obtain k where
    "k \<noteq> 0" "mat_adj M *\<^sub>m\<^sub>m M = k *\<^sub>s\<^sub>m eye"
    unfolding unitary_gen_def
    by auto
  hence "mat_det (mat_adj M *\<^sub>m\<^sub>m M) \<noteq> 0"
    by simp
  thus ?thesis
    by (simp add: mat_det_adj)
qed

lemmas unitary_regular = unitary_gen_regular[OF unitary_unitary_gen]

(* -------------------------------------------------------------------------- *)
subsubsection \<open>Group properties\<close>
(* -------------------------------------------------------------------------- *)

text \<open>Generalized $2\times 2$ unitary matrices form a group under
multiplication (usually denoted by $GU(2, \mathbb{C})$). The group is closed
under non-zero complex scalar multiplication. Since these matrices are
always regular, they form a subgroup of general linear group (usually
denoted by $GL(2, \mathbb{C})$) of all regular matrices.\<close>

lemma unitary_gen_scale [simp]:
  assumes "unitary_gen M" and "k \<noteq> 0"
  shows "unitary_gen (k *\<^sub>s\<^sub>m M)"
  using assms
  unfolding unitary_gen_def
  by auto

lemma unitary_comp:
  assumes "unitary M1" and "unitary M2"
  shows "unitary (M1 *\<^sub>m\<^sub>m M2)"
  using assms
  unfolding unitary_def
  by (metis mat_adj_mult_mm mat_eye_l mult_mm_assoc)

lemma unitary_gen_comp:
  assumes "unitary_gen M1" and "unitary_gen M2"
  shows "unitary_gen (M1 *\<^sub>m\<^sub>m M2)"
proof-
  obtain k1 k2 where *: "k1 * k2 \<noteq> 0" "mat_adj M1 *\<^sub>m\<^sub>m M1 = k1 *\<^sub>s\<^sub>m eye" "mat_adj M2 *\<^sub>m\<^sub>m M2 = k2 *\<^sub>s\<^sub>m eye"
    using assms
    unfolding unitary_gen_def
    by auto
  have "mat_adj M2 *\<^sub>m\<^sub>m mat_adj M1 *\<^sub>m\<^sub>m (M1 *\<^sub>m\<^sub>m M2) = mat_adj M2 *\<^sub>m\<^sub>m (mat_adj M1 *\<^sub>m\<^sub>m M1) *\<^sub>m\<^sub>m M2"
    by (auto simp add: mult_mm_assoc)
  also have "... = mat_adj M2 *\<^sub>m\<^sub>m ((k1 *\<^sub>s\<^sub>m eye) *\<^sub>m\<^sub>m M2)"
    using *
    by (auto simp add: mult_mm_assoc)
  also have "... = mat_adj M2 *\<^sub>m\<^sub>m (k1 *\<^sub>s\<^sub>m M2)"
    using mult_sm_eye_mm[of k1 M2]
    by (simp del: eye_def)
  also have "... = k1 *\<^sub>s\<^sub>m (k2 *\<^sub>s\<^sub>m eye)"
    using *
    by auto
  finally
  show ?thesis
    using *
    unfolding unitary_gen_def
    by (rule_tac x="k1*k2" in exI, simp del: eye_def)
qed

lemma unitary_adj_eq_inv:
  shows "unitary M \<longleftrightarrow> mat_det M \<noteq> 0 \<and> mat_adj M = mat_inv M"
  using  unitary_regular[of M] mult_mm_inv_r[of M "mat_adj M" eye]  mat_eye_l[of "mat_inv M"] mat_inv_l[of M]
  unfolding unitary_def
  by - (rule, simp_all)

lemma unitary_inv:
  assumes "unitary M"
  shows "unitary (mat_inv M)"
  using assms
  unfolding unitary_adj_eq_inv
  using mat_adj_inv[of M] mat_det_inv[of M]
  by simp

lemma unitary_gen_inv:
  assumes "unitary_gen M"
  shows "unitary_gen (mat_inv M)"
proof-
    obtain k M' where "0 < k" "unitary M'" "M = cor k *\<^sub>s\<^sub>m eye *\<^sub>m\<^sub>m M'"
      using unitary_gen_unitary[of M] assms
      by blast
    hence "mat_inv M = cor (1/k) *\<^sub>s\<^sub>m mat_inv M'"
      by (metis mat_inv_mult_sm mult_sm_eye_mm norm_not_less_zero of_real_1 of_real_divide of_real_eq_0_iff sgn_1_neg sgn_greater sgn_if sgn_pos sgn_sgn)
    thus ?thesis
      using \<open>k > 0\<close> \<open>unitary M'\<close>
      by (subst unitary_gen_unitary[of "mat_inv M"]) (rule_tac x="1/k" in exI, rule_tac x="mat_inv M'" in exI, metis divide_pos_pos mult_sm_eye_mm unitary_inv zero_less_one)
  qed

(* -------------------------------------------------------------------------- *)
subsubsection \<open>The characterization in terms of matrix elements\<close>
(* -------------------------------------------------------------------------- *)

text \<open>Special matrices are those having the determinant equal to 1. We first give their characterization.\<close>
lemma unitary_special:
  assumes "unitary M" and "mat_det M = 1"
  shows "\<exists> a b. M = (a, b, -cnj b, cnj a)"
proof-
  have "mat_adj M = mat_inv M"
    using assms mult_mm_inv_r[of M "mat_adj M" "eye"] mat_eye_r mat_eye_l
    by (simp add: unitary_def)
  thus ?thesis
    using \<open>mat_det M = 1\<close>
    by (cases M) (auto simp add: mat_adj_def mat_cnj_def)
qed

lemma unitary_gen_special:
  assumes "unitary_gen M" and "mat_det M = 1"
  shows "\<exists> a b. M = (a, b, -cnj b, cnj a)"
proof-
  from assms
  obtain k where *: "k \<noteq> 0" "mat_adj M *\<^sub>m\<^sub>m M = k *\<^sub>s\<^sub>m eye"
    unfolding unitary_gen_def
    by auto
  hence "mat_det (mat_adj M *\<^sub>m\<^sub>m M) = k*k"
    by simp
  hence "k*k = 1"
    using assms(2)
    by (simp add: mat_det_adj)
  hence "k = 1 \<or> k = -1"
    using square_eq_1_iff[of k]
    by simp
  moreover
  have "mat_adj M = k *\<^sub>s\<^sub>m mat_inv M"
    using *
    using assms mult_mm_inv_r[of M "mat_adj M" "k *\<^sub>s\<^sub>m eye"] mat_eye_r mat_eye_l
    by simp (metis mult_sm_eye_mm *(2))
  moreover
  obtain a b c d where "M = (a, b, c, d)"
    by (cases M) auto
  ultimately
  have "M = (a, b, -cnj b, cnj a) \<or> M = (a, b, cnj b, -cnj a)"
    using assms(2)
    by (auto simp add: mat_adj_def mat_cnj_def)
  moreover
  have "Re (- (cor (cmod a))\<^sup>2 - (cor (cmod b))\<^sup>2) < 1"
    by (smt cmod_square complex_norm_square minus_complex.simps(1) of_real_power realpow_square_minus_le uminus_complex.simps(1))
  hence "- (cor (cmod a))\<^sup>2 - (cor (cmod b))\<^sup>2 \<noteq> 1"
    by force
  hence "M \<noteq> (a, b, cnj b, -cnj a)"
    using \<open>mat_det M = 1\<close> complex_mult_cnj_cmod[of a] complex_mult_cnj_cmod[of b]
    by auto
  ultimately
  show ?thesis
    by auto
qed

text \<open>A characterization of all generalized unitary matrices\<close>
lemma unitary_gen_iff:
  shows "unitary_gen M \<longleftrightarrow>
         (\<exists> a b k. k \<noteq> 0 \<and> mat_det (a, b, -cnj b, cnj a) \<noteq> 0 \<and>
                           M = k *\<^sub>s\<^sub>m (a, b, -cnj b, cnj a))" (is "?lhs = ?rhs")
proof
  assume ?lhs
  obtain d where *: "d*d = mat_det M"
    using ex_complex_sqrt
    by auto
  hence "d \<noteq> 0"
    using unitary_gen_regular[OF \<open>unitary_gen M\<close>]
    by auto
  from \<open>unitary_gen M\<close>
  obtain k where "k \<noteq> 0" "mat_adj M *\<^sub>m\<^sub>m M = k *\<^sub>s\<^sub>m eye"
    unfolding unitary_gen_def
    by auto
  hence "mat_adj ((1/d)*\<^sub>s\<^sub>mM) *\<^sub>m\<^sub>m ((1/d)*\<^sub>s\<^sub>mM) = (k / (d*cnj d)) *\<^sub>s\<^sub>m eye"
    by simp
  obtain a b where "(a, b, - cnj b, cnj a) = (1 / d) *\<^sub>s\<^sub>m M"
    using unitary_gen_special[of "(1 / d) *\<^sub>s\<^sub>m M"]  \<open>unitary_gen M\<close> *  unitary_gen_regular[of M] \<open>d \<noteq> 0\<close>
    by force
  moreover
  hence "mat_det (a, b, - cnj b, cnj a) \<noteq> 0"
    using unitary_gen_regular[OF \<open>unitary_gen M\<close>] \<open>d \<noteq> 0\<close>
    by auto
  ultimately
  show ?rhs
    apply (rule_tac x="a" in exI, rule_tac x="b" in exI, rule_tac x="d" in exI)
    using mult_sm_inv_l[of "1/d" M]
    by (auto simp add: field_simps)
next
  assume ?rhs
  then obtain a b k where "k \<noteq> 0 \<and> mat_det (a, b, - cnj b, cnj a) \<noteq> 0 \<and> M = k *\<^sub>s\<^sub>m (a, b, - cnj b, cnj a)"
    by auto
  thus ?lhs
    unfolding unitary_gen_def
    apply (auto simp add: mat_adj_def mat_cnj_def)
    using mult_eq_0_iff[of "cnj k * k" "cnj a * a + cnj b * b"]
    by (auto simp add: field_simps)
qed

text \<open>A characterization of unitary matrices\<close>

lemma unitary_iff:
  shows "unitary M \<longleftrightarrow>
         (\<exists> a b k. (cmod a)\<^sup>2 + (cmod b)\<^sup>2 \<noteq> 0 \<and>
                           (cmod k)\<^sup>2 = 1 / ((cmod a)\<^sup>2 + (cmod b)\<^sup>2) \<and>
                           M = k *\<^sub>s\<^sub>m (a, b, -cnj b, cnj a))" (is "?lhs = ?rhs")
proof
  assume ?lhs
  obtain k a b where *: "M = k *\<^sub>s\<^sub>m (a, b, -cnj b, cnj a)" "k \<noteq> 0" "mat_det (a, b, -cnj b, cnj a) \<noteq> 0"
    using unitary_gen_iff  unitary_unitary_gen[OF \<open>unitary M\<close>]
    by auto

  have md: "mat_det (a, b, -cnj b, cnj a) = cor ((cmod a)\<^sup>2 + (cmod b)\<^sup>2)"
    by (auto simp add: complex_mult_cnj_cmod)

  have "k * cnj k * mat_det (a, b, -cnj b, cnj a) = 1"
    using \<open>unitary M\<close> *
    unfolding unitary_def
    by (auto simp add: mat_adj_def mat_cnj_def field_simps)
  hence "(cmod k)\<^sup>2 * ((cmod a)\<^sup>2 + (cmod b)\<^sup>2) = 1"
    by (subst (asm) complex_mult_cnj_cmod, subst (asm) md, subst (asm) cor_mult[symmetric]) (metis of_real_1 of_real_eq_iff)
  thus ?rhs
    using * mat_eye_l
    apply (rule_tac x="a" in exI, rule_tac x="b" in exI, rule_tac x="k" in exI)
    apply (auto simp add: complex_mult_cnj_cmod)
    by (metis \<open>(cmod k)\<^sup>2 * ((cmod a)\<^sup>2 + (cmod b)\<^sup>2) = 1\<close> mult_eq_0_iff nonzero_eq_divide_eq zero_neq_one)
next
  assume ?rhs
  then obtain a b k where  *: "(cmod a)\<^sup>2 + (cmod b)\<^sup>2 \<noteq> 0" "(cmod k)\<^sup>2 = 1 / ((cmod a)\<^sup>2 + (cmod b)\<^sup>2)" "M = k *\<^sub>s\<^sub>m (a, b, -cnj b, cnj a)"
    by auto
  have "(k * cnj k) * (a * cnj a) + (k * cnj k) * (b * cnj b) = 1"
    apply (subst complex_mult_cnj_cmod)+
    using *(1-2)
    by (metis (no_types, lifting) distrib_left nonzero_eq_divide_eq of_real_1 of_real_add of_real_divide of_real_eq_0_iff)
  thus ?lhs
    using *
    unfolding unitary_def
    by (simp add: mat_adj_def mat_cnj_def field_simps)
qed

end


(*  Title:      HOL/Library/Nat_Bijection.thy
    Author:     Brian Huffman
    Author:     Florian Haftmann
    Author:     Stefan Richter
    Author:     Tobias Nipkow
    Author:     Alexander Krauss
*)

section \<open>Bijections between natural numbers and other types\<close>

theory Nat_Bijection
  imports Main
begin

subsection \<open>Type @{typ "nat \<times> nat"}\<close>

text \<open>Triangle numbers: 0, 1, 3, 6, 10, 15, ...\<close>

definition triangle :: "nat \<Rightarrow> nat"
  where "triangle n = (n * Suc n) div 2"

lemma triangle_0 [simp]: "triangle 0 = 0"
  by (simp add: triangle_def)

lemma triangle_Suc [simp]: "triangle (Suc n) = triangle n + Suc n"
  by (simp add: triangle_def)

definition prod_encode :: "nat \<times> nat \<Rightarrow> nat"
  where "prod_encode = (\<lambda>(m, n). triangle (m + n) + m)"

text \<open>In this auxiliary function, @{term "triangle k + m"} is an invariant.\<close>

fun prod_decode_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat"
  where "prod_decode_aux k m =
    (if m \<le> k then (m, k - m) else prod_decode_aux (Suc k) (m - Suc k))"

declare prod_decode_aux.simps [simp del]

definition prod_decode :: "nat \<Rightarrow> nat \<times> nat"
  where "prod_decode = prod_decode_aux 0"

lemma prod_encode_prod_decode_aux: "prod_encode (prod_decode_aux k m) = triangle k + m"
  apply (induct k m rule: prod_decode_aux.induct)
  apply (subst prod_decode_aux.simps)
  apply (simp add: prod_encode_def)
  done

lemma prod_decode_inverse [simp]: "prod_encode (prod_decode n) = n"
  by (simp add: prod_decode_def prod_encode_prod_decode_aux)

lemma prod_decode_triangle_add: "prod_decode (triangle k + m) = prod_decode_aux k m"
  apply (induct k arbitrary: m)
   apply (simp add: prod_decode_def)
  apply (simp only: triangle_Suc add.assoc)
  apply (subst prod_decode_aux.simps)
  apply simp
  done

lemma prod_encode_inverse [simp]: "prod_decode (prod_encode x) = x"
  unfolding prod_encode_def
  apply (induct x)
  apply (simp add: prod_decode_triangle_add)
  apply (subst prod_decode_aux.simps)
  apply simp
  done

lemma inj_prod_encode: "inj_on prod_encode A"
  by (rule inj_on_inverseI) (rule prod_encode_inverse)

lemma inj_prod_decode: "inj_on prod_decode A"
  by (rule inj_on_inverseI) (rule prod_decode_inverse)

lemma surj_prod_encode: "surj prod_encode"
  by (rule surjI) (rule prod_decode_inverse)

lemma surj_prod_decode: "surj prod_decode"
  by (rule surjI) (rule prod_encode_inverse)

lemma bij_prod_encode: "bij prod_encode"
  by (rule bijI [OF inj_prod_encode surj_prod_encode])

lemma bij_prod_decode: "bij prod_decode"
  by (rule bijI [OF inj_prod_decode surj_prod_decode])

lemma prod_encode_eq: "prod_encode x = prod_encode y \<longleftrightarrow> x = y"
  by (rule inj_prod_encode [THEN inj_eq])

lemma prod_decode_eq: "prod_decode x = prod_decode y \<longleftrightarrow> x = y"
  by (rule inj_prod_decode [THEN inj_eq])

text \<open>Ordering properties\<close>

lemma le_prod_encode_1: "a \<le> prod_encode (a, b)"
  by (simp add: prod_encode_def)

lemma le_prod_encode_2: "b \<le> prod_encode (a, b)"
  by (induct b) (simp_all add: prod_encode_def)

subsection \<open>Type @{typ "nat + nat"}\<close>

definition sum_encode :: "nat + nat \<Rightarrow> nat"
  where "sum_encode x = (case x of Inl a \<Rightarrow> 2 * a | Inr b \<Rightarrow> Suc (2 * b))"

definition sum_decode :: "nat \<Rightarrow> nat + nat"
  where "sum_decode n = (if even n then Inl (n div 2) else Inr (n div 2))"

lemma sum_encode_inverse [simp]: "sum_decode (sum_encode x) = x"
  by (induct x) (simp_all add: sum_decode_def sum_encode_def)

lemma sum_decode_inverse [simp]: "sum_encode (sum_decode n) = n"
  by (simp add: even_two_times_div_two sum_decode_def sum_encode_def)

lemma inj_sum_encode: "inj_on sum_encode A"
  by (rule inj_on_inverseI) (rule sum_encode_inverse)

lemma inj_sum_decode: "inj_on sum_decode A"
  by (rule inj_on_inverseI) (rule sum_decode_inverse)

lemma surj_sum_encode: "surj sum_encode"
  by (rule surjI) (rule sum_decode_inverse)

lemma surj_sum_decode: "surj sum_decode"
  by (rule surjI) (rule sum_encode_inverse)

lemma bij_sum_encode: "bij sum_encode"
  by (rule bijI [OF inj_sum_encode surj_sum_encode])

lemma bij_sum_decode: "bij sum_decode"
  by (rule bijI [OF inj_sum_decode surj_sum_decode])

lemma sum_encode_eq: "sum_encode x = sum_encode y \<longleftrightarrow> x = y"
  by (rule inj_sum_encode [THEN inj_eq])

lemma sum_decode_eq: "sum_decode x = sum_decode y \<longleftrightarrow> x = y"
  by (rule inj_sum_decode [THEN inj_eq])

subsection \<open>Type @{typ "int"}\<close>

definition int_encode :: "int \<Rightarrow> nat"
  where "int_encode i = sum_encode (if 0 \<le> i then Inl (nat i) else Inr (nat (- i - 1)))"

definition int_decode :: "nat \<Rightarrow> int"
  where "int_decode n = (case sum_decode n of Inl a \<Rightarrow> int a | Inr b \<Rightarrow> - int b - 1)"

lemma int_encode_inverse [simp]: "int_decode (int_encode x) = x"
  by (simp add: int_decode_def int_encode_def)

lemma int_decode_inverse [simp]: "int_encode (int_decode n) = n"
  unfolding int_decode_def int_encode_def
  using sum_decode_inverse [of n] by (cases "sum_decode n") simp_all

lemma inj_int_encode: "inj_on int_encode A"
  by (rule inj_on_inverseI) (rule int_encode_inverse)

lemma inj_int_decode: "inj_on int_decode A"
  by (rule inj_on_inverseI) (rule int_decode_inverse)

lemma surj_int_encode: "surj int_encode"
  by (rule surjI) (rule int_decode_inverse)

lemma surj_int_decode: "surj int_decode"
  by (rule surjI) (rule int_encode_inverse)

lemma bij_int_encode: "bij int_encode"
  by (rule bijI [OF inj_int_encode surj_int_encode])

lemma bij_int_decode: "bij int_decode"
  by (rule bijI [OF inj_int_decode surj_int_decode])

lemma int_encode_eq: "int_encode x = int_encode y \<longleftrightarrow> x = y"
  by (rule inj_int_encode [THEN inj_eq])

lemma int_decode_eq: "int_decode x = int_decode y \<longleftrightarrow> x = y"
  by (rule inj_int_decode [THEN inj_eq])

subsection \<open>Type @{typ "nat list"}\<close>

fun list_encode :: "nat list \<Rightarrow> nat"
  where
    "list_encode [] = 0"
  | "list_encode (x # xs) = Suc (prod_encode (x, list_encode xs))"

function list_decode :: "nat \<Rightarrow> nat list"
  where
    "list_decode 0 = []"
  | "list_decode (Suc n) = (case prod_decode n of (x, y) \<Rightarrow> x # list_decode y)"
  by pat_completeness auto

termination list_decode
  apply (relation "measure id")
   apply simp_all
  apply (drule arg_cong [where f="prod_encode"])
  apply (drule sym)
  apply (simp add: le_imp_less_Suc le_prod_encode_2)
  done

lemma list_encode_inverse [simp]: "list_decode (list_encode x) = x"
  by (induct x rule: list_encode.induct) simp_all

lemma list_decode_inverse [simp]: "list_encode (list_decode n) = n"
  apply (induct n rule: list_decode.induct)
   apply simp
  apply (simp split: prod.split)
  apply (simp add: prod_decode_eq [symmetric])
  done

lemma inj_list_encode: "inj_on list_encode A"
  by (rule inj_on_inverseI) (rule list_encode_inverse)

lemma inj_list_decode: "inj_on list_decode A"
  by (rule inj_on_inverseI) (rule list_decode_inverse)

lemma surj_list_encode: "surj list_encode"
  by (rule surjI) (rule list_decode_inverse)

lemma surj_list_decode: "surj list_decode"
  by (rule surjI) (rule list_encode_inverse)

lemma bij_list_encode: "bij list_encode"
  by (rule bijI [OF inj_list_encode surj_list_encode])

lemma bij_list_decode: "bij list_decode"
  by (rule bijI [OF inj_list_decode surj_list_decode])

lemma list_encode_eq: "list_encode x = list_encode y \<longleftrightarrow> x = y"
  by (rule inj_list_encode [THEN inj_eq])

lemma list_decode_eq: "list_decode x = list_decode y \<longleftrightarrow> x = y"
  by (rule inj_list_decode [THEN inj_eq])

subsection \<open>Finite sets of naturals\<close>

subsubsection \<open>Preliminaries\<close>

lemma finite_vimage_Suc_iff: "finite (Suc -` F) \<longleftrightarrow> finite F"
  apply (safe intro!: finite_vimageI inj_Suc)
  apply (rule finite_subset [where B="insert 0 (Suc ` Suc -` F)"])
   apply (rule subsetI)
   apply (case_tac x)
    apply simp
   apply simp
  apply (rule finite_insert [THEN iffD2])
  apply (erule finite_imageI)
  done

lemma vimage_Suc_insert_0: "Suc -` insert 0 A = Suc -` A"
  by auto

lemma vimage_Suc_insert_Suc: "Suc -` insert (Suc n) A = insert n (Suc -` A)"
  by auto

lemma div2_even_ext_nat:
  fixes x y :: nat
  assumes "x div 2 = y div 2"
    and "even x \<longleftrightarrow> even y"
  shows "x = y"
proof -
  from \<open>even x \<longleftrightarrow> even y\<close> have "x mod 2 = y mod 2"
    by (simp only: even_iff_mod_2_eq_zero) auto
  with assms have "x div 2 * 2 + x mod 2 = y div 2 * 2 + y mod 2"
    by simp
  then show ?thesis
    by simp
qed

subsubsection \<open>From sets to naturals\<close>

definition set_encode :: "nat set \<Rightarrow> nat"
  where "set_encode = sum (op ^ 2)"

lemma set_encode_empty [simp]: "set_encode {} = 0"
  by (simp add: set_encode_def)

lemma set_encode_inf: "\<not> finite A \<Longrightarrow> set_encode A = 0"
  by (simp add: set_encode_def)

lemma set_encode_insert [simp]: "finite A \<Longrightarrow> n \<notin> A \<Longrightarrow> set_encode (insert n A) = 2^n + set_encode A"
  by (simp add: set_encode_def)

lemma even_set_encode_iff: "finite A \<Longrightarrow> even (set_encode A) \<longleftrightarrow> 0 \<notin> A"
  by (induct set: finite) (auto simp: set_encode_def)

lemma set_encode_vimage_Suc: "set_encode (Suc -` A) = set_encode A div 2"
  apply (cases "finite A")
   apply (erule finite_induct)
    apply simp
   apply (case_tac x)
    apply (simp add: even_set_encode_iff vimage_Suc_insert_0)
   apply (simp add: finite_vimageI add.commute vimage_Suc_insert_Suc)
  apply (simp add: set_encode_def finite_vimage_Suc_iff)
  done

lemmas set_encode_div_2 = set_encode_vimage_Suc [symmetric]

subsubsection \<open>From naturals to sets\<close>

definition set_decode :: "nat \<Rightarrow> nat set"
  where "set_decode x = {n. odd (x div 2 ^ n)}"

lemma set_decode_0 [simp]: "0 \<in> set_decode x \<longleftrightarrow> odd x"
  by (simp add: set_decode_def)

lemma set_decode_Suc [simp]: "Suc n \<in> set_decode x \<longleftrightarrow> n \<in> set_decode (x div 2)"
  by (simp add: set_decode_def div_mult2_eq)

lemma set_decode_zero [simp]: "set_decode 0 = {}"
  by (simp add: set_decode_def)

lemma set_decode_div_2: "set_decode (x div 2) = Suc -` set_decode x"
  by auto

lemma set_decode_plus_power_2:
  "n \<notin> set_decode z \<Longrightarrow> set_decode (2 ^ n + z) = insert n (set_decode z)"
proof (induct n arbitrary: z)
  case 0
  show ?case
  proof (rule set_eqI)
    show "q \<in> set_decode (2 ^ 0 + z) \<longleftrightarrow> q \<in> insert 0 (set_decode z)" for q
      by (induct q) (use 0 in simp_all)
  qed
next
  case (Suc n)
  show ?case
  proof (rule set_eqI)
    show "q \<in> set_decode (2 ^ Suc n + z) \<longleftrightarrow> q \<in> insert (Suc n) (set_decode z)" for q
      by (induct q) (use Suc in simp_all)
  qed
qed

lemma finite_set_decode [simp]: "finite (set_decode n)"
  apply (induct n rule: nat_less_induct)
  apply (case_tac "n = 0")
   apply simp
  apply (drule_tac x="n div 2" in spec)
  apply simp
  apply (simp add: set_decode_div_2)
  apply (simp add: finite_vimage_Suc_iff)
  done

subsubsection \<open>Proof of isomorphism\<close>

lemma set_decode_inverse [simp]: "set_encode (set_decode n) = n"
  apply (induct n rule: nat_less_induct)
  apply (case_tac "n = 0")
   apply simp
  apply (drule_tac x="n div 2" in spec)
  apply simp
  apply (simp add: set_decode_div_2 set_encode_vimage_Suc)
  apply (erule div2_even_ext_nat)
  apply (simp add: even_set_encode_iff)
  done

lemma set_encode_inverse [simp]: "finite A \<Longrightarrow> set_decode (set_encode A) = A"
  apply (erule finite_induct)
   apply simp_all
  apply (simp add: set_decode_plus_power_2)
  done

lemma inj_on_set_encode: "inj_on set_encode (Collect finite)"
  by (rule inj_on_inverseI [where g = "set_decode"]) simp

lemma set_encode_eq: "finite A \<Longrightarrow> finite B \<Longrightarrow> set_encode A = set_encode B \<longleftrightarrow> A = B"
  by (rule iffI) (simp_all add: inj_onD [OF inj_on_set_encode])

lemma subset_decode_imp_le:
  assumes "set_decode m \<subseteq> set_decode n"
  shows "m \<le> n"
proof -
  have "n = m + set_encode (set_decode n - set_decode m)"
  proof -
    obtain A B where
      "m = set_encode A" "finite A"
      "n = set_encode B" "finite B"
      by (metis finite_set_decode set_decode_inverse)
  with assms show ?thesis
    by auto (simp add: set_encode_def add.commute sum.subset_diff)
  qed
  then show ?thesis
    by (metis le_add1)
qed

end


theory Chapter2 imports Main begin

(* Exercise 2.1 *)

value "1 + (2::nat)"
value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"

(* Exercise 2.2 *)

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc n) m = Suc(add n m)"

theorem AddAssociative: "add (add n m) p = add n (add m p)"
  apply(induction n)
  apply(auto)
  done

lemma [simp]: "Suc (add m n) = add m (Suc n)"
  apply(induction m)
  apply(auto)
  done

theorem AddCommutative[simp]: "add n m = add m n"
  apply(induction n)
  apply(auto)
  done

(* Exercise 2.3 *)

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count a [] = 0" |
"count a (x # xs) = add (if a = x then 1::nat else 0::nat) (count a xs)"

theorem CountLessThanEqLength: "count x xs \<le> length xs"
  apply(induction xs)
  apply(auto)
  done

(* Exercise 2.4 *)

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc [] a = [a]" |
"snoc (x # xs) a = x # (snoc xs a)"

fun reverse :: "'a list \<Rightarrow> 'a list" where
"reverse [] = []" |
"reverse (x # xs) = snoc (reverse xs) x"

lemma [simp]: "reverse (snoc xs a) = a # reverse xs"
  apply(induction xs)
  apply(auto)
  done

theorem DoubleReverse[simp]: "reverse (reverse xs) = xs"
  apply(induction xs)
  apply(auto)
  done

(* Exercise 2.5 *)
fun sum_upto :: "nat \<Rightarrow> nat" where
"sum_upto 0 = 0" |
"sum_upto n  = (+) n (sum_upto (n - 1))"

theorem "sum_upto n = (n * (n + 1)) div 2"
  apply(induction n)
  apply(auto)
  done

(* Exercise 2.6 *)
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

(* inorder traversal *)
fun contents :: "'a tree \<Rightarrow> 'a list" where
"contents Tip = []" |
"contents (Node left x right) = contents(left) @ [x] @ contents(right)"

fun sum_tree :: "nat tree \<Rightarrow> nat" where
"sum_tree Tip = 0" |
"sum_tree (Node left x right) = x + (sum_tree left) + (sum_tree right)"

theorem "sum_tree t = sum_list (contents t)"
  apply(induction t)
  apply(auto)
  done

(* Exercise 2.7 *)
datatype 'a tree2 = Tip 'a | Node "'a tree2" 'a "'a tree2"

fun mirror :: "'a tree2 \<Rightarrow> 'a tree2" where
"mirror (Tip x) = Tip x" |
"mirror (Node left x right) = Node (mirror right) x (mirror left)"

fun pre_order :: "'a tree2 \<Rightarrow> 'a list" where
"pre_order (Tip x) = [x]" |
"pre_order (Node left x right) = x # (pre_order left @ pre_order right)"

fun post_order :: "'a tree2 \<Rightarrow> 'a list" where
"post_order (Tip x) = [x]" |
"post_order (Node left x right) = (post_order left @ post_order right) @ [x]"

theorem "pre_order (mirror t) = rev (post_order t)"
  apply(induction t)
  apply(auto)
  done

(* Exercise 2.8 *)

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"intersperse a [] = [a]" |
"intersperse a (x # xs) = x # a # intersperse a xs"

theorem "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply(induction xs)
  apply(auto)
  done

(* Exercise 2.9 *)

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"itadd acc 0 = acc" |
"itadd acc (Suc m) = itadd (Suc acc) m"

theorem "itadd m n = m + n"
  apply(induction n arbitrary: m)
  apply(auto)
  done

(* Exercise 2.10 *)
datatype tree0 = Leaf | Node tree0 tree0

fun nodes :: "tree0 \<Rightarrow> nat" where
"nodes Leaf = 1" |
"nodes (Node l r) = 1 + nodes l + nodes r"

fun explode :: "nat \<Rightarrow> tree0 \<Rightarrow> tree0" where
"explode 0 t = t" |
"explode (Suc n) t = explode n (Node t t)"

fun explode_size :: "nat \<Rightarrow> tree0 \<Rightarrow> nat" where
"explode_size n t = 2^n * (nodes t) + (2^n-1)"

lemma "nodes (explode n t) = explode_size n t"
  apply(induction n arbitrary: t)
  apply(auto simp add: algebra_simps)
  done

(* Exercise 2.11 *)
datatype exp = Var | Const int | Add exp exp | Mult exp exp

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var x = x" |
"eval (Const a) x = a" |
"eval (Add e1 e2) x = (eval e1 x) + (eval e2 x)" |
"eval (Mult e1 e2) x = (eval e1 x) * (eval e2 x)"

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
"evalp [] x = 0" |
"evalp (c # cfs) x = c + x * (evalp cfs x) "

(* TODO: coeffs *)

end


(*  Title:      HOL/Equiv_Relations.thy
    Author:     Lawrence C Paulson, 1996 Cambridge University Computer Laboratory
*)

section \<open>Equivalence Relations in Higher-Order Set Theory\<close>

theory Equiv_Relations
  imports BNF_Least_Fixpoint
begin

subsection \<open>Equivalence relations -- set version\<close>

definition equiv :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"
  where "equiv A r \<longleftrightarrow> refl_on A r \<and> sym r \<and> trans r"

lemma equivI: "refl_on A r \<Longrightarrow> sym r \<Longrightarrow> trans r \<Longrightarrow> equiv A r"
  by (simp add: equiv_def)

lemma equivE:
  assumes "equiv A r"
  obtains "refl_on A r" and "sym r" and "trans r"
  using assms by (simp add: equiv_def)

text \<open>
  Suppes, Theorem 70: \<open>r\<close> is an equiv relation iff \<open>r\<inverse> O r = r\<close>.

  First half: \<open>equiv A r \<Longrightarrow> r\<inverse> O r = r\<close>.
\<close>

lemma sym_trans_comp_subset: "sym r \<Longrightarrow> trans r \<Longrightarrow> r\<inverse> O r \<subseteq> r"
  unfolding trans_def sym_def converse_unfold by blast

lemma refl_on_comp_subset: "refl_on A r \<Longrightarrow> r \<subseteq> r\<inverse> O r"
  unfolding refl_on_def by blast

lemma equiv_comp_eq: "equiv A r \<Longrightarrow> r\<inverse> O r = r"
  unfolding equiv_def
  by (iprover intro: sym_trans_comp_subset refl_on_comp_subset equalityI)

text \<open>Second half.\<close>

lemma comp_equivI:
  assumes "r\<inverse> O r = r" "Domain r = A"
  shows "equiv A r"
proof -
  have *: "\<And>x y. (x, y) \<in> r \<Longrightarrow> (y, x) \<in> r"
    using assms by blast
  show ?thesis
    unfolding equiv_def refl_on_def sym_def trans_def
    using assms by (auto intro: *)
qed

subsection \<open>Equivalence classes\<close>

lemma equiv_class_subset: "equiv A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> r``{a} \<subseteq> r``{b}"
  \<comment> \<open>lemma for the next result\<close>
  unfolding equiv_def trans_def sym_def by blast

theorem equiv_class_eq: "equiv A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> r``{a} = r``{b}"
  by (intro equalityI equiv_class_subset; force simp add: equiv_def sym_def)

lemma equiv_class_self: "equiv A r \<Longrightarrow> a \<in> A \<Longrightarrow> a \<in> r``{a}"
  unfolding equiv_def refl_on_def by blast

lemma subset_equiv_class: "equiv A r \<Longrightarrow> r``{b} \<subseteq> r``{a} \<Longrightarrow> b \<in> A \<Longrightarrow> (a, b) \<in> r"
  \<comment> \<open>lemma for the next result\<close>
  unfolding equiv_def refl_on_def by blast

lemma eq_equiv_class: "r``{a} = r``{b} \<Longrightarrow> equiv A r \<Longrightarrow> b \<in> A \<Longrightarrow> (a, b) \<in> r"
  by (iprover intro: equalityD2 subset_equiv_class)

lemma equiv_class_nondisjoint: "equiv A r \<Longrightarrow> x \<in> (r``{a} \<inter> r``{b}) \<Longrightarrow> (a, b) \<in> r"
  unfolding equiv_def trans_def sym_def by blast

lemma equiv_type: "equiv A r \<Longrightarrow> r \<subseteq> A \<times> A"
  unfolding equiv_def refl_on_def by blast

lemma equiv_class_eq_iff: "equiv A r \<Longrightarrow> (x, y) \<in> r \<longleftrightarrow> r``{x} = r``{y} \<and> x \<in> A \<and> y \<in> A"
  by (blast intro!: equiv_class_eq dest: eq_equiv_class equiv_type)

lemma eq_equiv_class_iff: "equiv A r \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> r``{x} = r``{y} \<longleftrightarrow> (x, y) \<in> r"
  by (blast intro!: equiv_class_eq dest: eq_equiv_class equiv_type)

lemma disjnt_equiv_class: "equiv A r \<Longrightarrow> disjnt (r``{a}) (r``{b}) \<longleftrightarrow> (a, b) \<notin> r"
  by (auto dest: equiv_class_self simp: equiv_class_eq_iff disjnt_def)

subsection \<open>Quotients\<close>

definition quotient :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set set"  (infixl "'/'/" 90)
  where "A//r = (\<Union>x \<in> A. {r``{x}})"  \<comment> \<open>set of equiv classes\<close>

lemma quotientI: "x \<in> A \<Longrightarrow> r``{x} \<in> A//r"
  unfolding quotient_def by blast

lemma quotientE: "X \<in> A//r \<Longrightarrow> (\<And>x. X = r``{x} \<Longrightarrow> x \<in> A \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding quotient_def by blast

lemma Union_quotient: "equiv A r \<Longrightarrow> \<Union>(A//r) = A"
  unfolding equiv_def refl_on_def quotient_def by blast

lemma quotient_disj: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> Y \<in> A//r \<Longrightarrow> X = Y \<or> X \<inter> Y = {}"
  unfolding quotient_def equiv_def trans_def sym_def by blast

lemma quotient_eqI:
  assumes "equiv A r" "X \<in> A//r" "Y \<in> A//r" and xy: "x \<in> X" "y \<in> Y" "(x, y) \<in> r"
  shows "X = Y"
proof -
  obtain a b where "a \<in> A" and a: "X = r `` {a}" and "b \<in> A" and b: "Y = r `` {b}"
    using assms by (auto elim!: quotientE)
  then have "(a,b) \<in> r"
      using xy \<open>equiv A r\<close> unfolding equiv_def sym_def trans_def by blast
  then show ?thesis
    unfolding a b by (rule equiv_class_eq [OF \<open>equiv A r\<close>])
qed

lemma quotient_eq_iff:
  assumes "equiv A r" "X \<in> A//r" "Y \<in> A//r" and xy: "x \<in> X" "y \<in> Y"
  shows "X = Y \<longleftrightarrow> (x, y) \<in> r"
proof
  assume L: "X = Y"
  with assms show "(x, y) \<in> r"
    unfolding equiv_def sym_def trans_def by (blast elim!: quotientE)
next
  assume \<section>: "(x, y) \<in> r" show "X = Y"
    by (rule quotient_eqI) (use \<section> assms in \<open>blast+\<close>)
qed

lemma eq_equiv_class_iff2: "equiv A r \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> {x}//r = {y}//r \<longleftrightarrow> (x, y) \<in> r"
  by (simp add: quotient_def eq_equiv_class_iff)

lemma quotient_empty [simp]: "{}//r = {}"
  by (simp add: quotient_def)

lemma quotient_is_empty [iff]: "A//r = {} \<longleftrightarrow> A = {}"
  by (simp add: quotient_def)

lemma quotient_is_empty2 [iff]: "{} = A//r \<longleftrightarrow> A = {}"
  by (simp add: quotient_def)

lemma singleton_quotient: "{x}//r = {r `` {x}}"
  by (simp add: quotient_def)

lemma quotient_diff1: "inj_on (\<lambda>a. {a}//r) A \<Longrightarrow> a \<in> A \<Longrightarrow> (A - {a})//r = A//r - {a}//r"
  unfolding quotient_def inj_on_def by blast

subsection \<open>Refinement of one equivalence relation WRT another\<close>

lemma refines_equiv_class_eq: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> R``(S``{a}) = S``{a}"
  by (auto simp: equiv_class_eq_iff)

lemma refines_equiv_class_eq2: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> S``(R``{a}) = S``{a}"
  by (auto simp: equiv_class_eq_iff)

lemma refines_equiv_image_eq: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> (\<lambda>X. S``X) ` (A//R) = A//S"
   by (auto simp: quotient_def image_UN refines_equiv_class_eq2)

lemma finite_refines_finite:
  "finite (A//R) \<Longrightarrow> R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> finite (A//S)"
  by (erule finite_surj [where f = "\<lambda>X. S``X"]) (simp add: refines_equiv_image_eq)

lemma finite_refines_card_le:
  "finite (A//R) \<Longrightarrow> R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> card (A//S) \<le> card (A//R)"
  by (subst refines_equiv_image_eq [of R S A, symmetric])
    (auto simp: card_image_le [where f = "\<lambda>X. S``X"])

subsection \<open>Defining unary operations upon equivalence classes\<close>

text \<open>A congruence-preserving function.\<close>

definition congruent :: "('a \<times> 'a) set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "congruent r f \<longleftrightarrow> (\<forall>(y, z) \<in> r. f y = f z)"

lemma congruentI: "(\<And>y z. (y, z) \<in> r \<Longrightarrow> f y = f z) \<Longrightarrow> congruent r f"
  by (auto simp add: congruent_def)

lemma congruentD: "congruent r f \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> f y = f z"
  by (auto simp add: congruent_def)

abbreviation RESPECTS :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"  (infixr "respects" 80)
  where "f respects r \<equiv> congruent r f"

lemma UN_constant_eq: "a \<in> A \<Longrightarrow> \<forall>y \<in> A. f y = c \<Longrightarrow> (\<Union>y \<in> A. f y) = c"
  \<comment> \<open>lemma required to prove \<open>UN_equiv_class\<close>\<close>
  by auto

lemma UN_equiv_class:
  assumes "equiv A r" "f respects r" "a \<in> A"
  shows "(\<Union>x \<in> r``{a}. f x) = f a"
  \<comment> \<open>Conversion rule\<close>
proof -
  have \<section>: "\<forall>x\<in>r `` {a}. f x = f a"
    using assms unfolding equiv_def congruent_def sym_def by blast
  show ?thesis
    by (iprover intro: assms UN_constant_eq [OF equiv_class_self \<section>])
qed

lemma UN_equiv_class_type:
  assumes r: "equiv A r" "f respects r" and X: "X \<in> A//r" and AB: "\<And>x. x \<in> A \<Longrightarrow> f x \<in> B"
  shows "(\<Union>x \<in> X. f x) \<in> B"
  using assms unfolding quotient_def
  by (auto simp: UN_equiv_class [OF r])

text \<open>
  Sufficient conditions for injectiveness.  Could weaken premises!
  major premise could be an inclusion; \<open>bcong\<close> could be
  \<open>\<And>y. y \<in> A \<Longrightarrow> f y \<in> B\<close>.
\<close>

lemma UN_equiv_class_inject:
  assumes "equiv A r" "f respects r"
    and eq: "(\<Union>x \<in> X. f x) = (\<Union>y \<in> Y. f y)"
    and X: "X \<in> A//r" and Y: "Y \<in> A//r"
    and fr: "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x = f y \<Longrightarrow> (x, y) \<in> r"
  shows "X = Y"
proof -
  obtain a b where "a \<in> A" and a: "X = r `` {a}" and "b \<in> A" and b: "Y = r `` {b}"
    using assms by (auto elim!: quotientE)
  then have "\<Union> (f ` r `` {a}) = f a" "\<Union> (f ` r `` {b}) = f b"
    by (iprover intro: UN_equiv_class [OF \<open>equiv A r\<close>] assms)+
  then have "f a = f b"
    using eq unfolding a b by (iprover intro: trans sym)
  then have "(a,b) \<in> r"
    using fr \<open>a \<in> A\<close> \<open>b \<in> A\<close> by blast
  then show ?thesis
    unfolding a b by (rule equiv_class_eq [OF \<open>equiv A r\<close>])
qed

subsection \<open>Defining binary operations upon equivalence classes\<close>

text \<open>A congruence-preserving function of two arguments.\<close>

definition congruent2 :: "('a \<times> 'a) set \<Rightarrow> ('b \<times> 'b) set \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> bool"
  where "congruent2 r1 r2 f \<longleftrightarrow> (\<forall>(y1, z1) \<in> r1. \<forall>(y2, z2) \<in> r2. f y1 y2 = f z1 z2)"

lemma congruent2I':
  assumes "\<And>y1 z1 y2 z2. (y1, z1) \<in> r1 \<Longrightarrow> (y2, z2) \<in> r2 \<Longrightarrow> f y1 y2 = f z1 z2"
  shows "congruent2 r1 r2 f"
  using assms by (auto simp add: congruent2_def)

lemma congruent2D: "congruent2 r1 r2 f \<Longrightarrow> (y1, z1) \<in> r1 \<Longrightarrow> (y2, z2) \<in> r2 \<Longrightarrow> f y1 y2 = f z1 z2"
  by (auto simp add: congruent2_def)

text \<open>Abbreviation for the common case where the relations are identical.\<close>
abbreviation RESPECTS2:: "('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"  (infixr "respects2" 80)
  where "f respects2 r \<equiv> congruent2 r r f"

lemma congruent2_implies_congruent:
  "equiv A r1 \<Longrightarrow> congruent2 r1 r2 f \<Longrightarrow> a \<in> A \<Longrightarrow> congruent r2 (f a)"
  unfolding congruent_def congruent2_def equiv_def refl_on_def by blast

lemma congruent2_implies_congruent_UN:
  assumes "equiv A1 r1" "equiv A2 r2" "congruent2 r1 r2 f" "a \<in> A2"
  shows "congruent r1 (\<lambda>x1. \<Union>x2 \<in> r2``{a}. f x1 x2)"
  unfolding congruent_def
proof clarify
  fix c d
  assume cd: "(c,d) \<in> r1"
  then have "c \<in> A1" "d \<in> A1"
    using \<open>equiv A1 r1\<close> by (auto elim!: equiv_type [THEN subsetD, THEN SigmaE2])
  moreover have "f c a = f d a"
    using assms cd unfolding congruent2_def equiv_def refl_on_def by blast
  ultimately show "\<Union> (f c ` r2 `` {a}) = \<Union> (f d ` r2 `` {a})"
    using assms by (simp add: UN_equiv_class congruent2_implies_congruent)
qed

lemma UN_equiv_class2:
  "equiv A1 r1 \<Longrightarrow> equiv A2 r2 \<Longrightarrow> congruent2 r1 r2 f \<Longrightarrow> a1 \<in> A1 \<Longrightarrow> a2 \<in> A2 \<Longrightarrow>
    (\<Union>x1 \<in> r1``{a1}. \<Union>x2 \<in> r2``{a2}. f x1 x2) = f a1 a2"
  by (simp add: UN_equiv_class congruent2_implies_congruent congruent2_implies_congruent_UN)

lemma UN_equiv_class_type2:
  "equiv A1 r1 \<Longrightarrow> equiv A2 r2 \<Longrightarrow> congruent2 r1 r2 f
    \<Longrightarrow> X1 \<in> A1//r1 \<Longrightarrow> X2 \<in> A2//r2
    \<Longrightarrow> (\<And>x1 x2. x1 \<in> A1 \<Longrightarrow> x2 \<in> A2 \<Longrightarrow> f x1 x2 \<in> B)
    \<Longrightarrow> (\<Union>x1 \<in> X1. \<Union>x2 \<in> X2. f x1 x2) \<in> B"
  unfolding quotient_def
  by (blast intro: UN_equiv_class_type congruent2_implies_congruent_UN
                   congruent2_implies_congruent quotientI)

lemma UN_UN_split_split_eq:
  "(\<Union>(x1, x2) \<in> X. \<Union>(y1, y2) \<in> Y. A x1 x2 y1 y2) =
    (\<Union>x \<in> X. \<Union>y \<in> Y. (\<lambda>(x1, x2). (\<lambda>(y1, y2). A x1 x2 y1 y2) y) x)"
  \<comment> \<open>Allows a natural expression of binary operators,\<close>
  \<comment> \<open>without explicit calls to \<open>split\<close>\<close>
  by auto

lemma congruent2I:
  "equiv A1 r1 \<Longrightarrow> equiv A2 r2
    \<Longrightarrow> (\<And>y z w. w \<in> A2 \<Longrightarrow> (y,z) \<in> r1 \<Longrightarrow> f y w = f z w)
    \<Longrightarrow> (\<And>y z w. w \<in> A1 \<Longrightarrow> (y,z) \<in> r2 \<Longrightarrow> f w y = f w z)
    \<Longrightarrow> congruent2 r1 r2 f"
  \<comment> \<open>Suggested by John Harrison -- the two subproofs may be\<close>
  \<comment> \<open>\<^emph>\<open>much\<close> simpler than the direct proof.\<close>
  unfolding congruent2_def equiv_def refl_on_def
  by (blast intro: trans)

lemma congruent2_commuteI:
  assumes equivA: "equiv A r"
    and commute: "\<And>y z. y \<in> A \<Longrightarrow> z \<in> A \<Longrightarrow> f y z = f z y"
    and congt: "\<And>y z w. w \<in> A \<Longrightarrow> (y,z) \<in> r \<Longrightarrow> f w y = f w z"
  shows "f respects2 r"
proof (rule congruent2I [OF equivA equivA])
  note eqv = equivA [THEN equiv_type, THEN subsetD, THEN SigmaE2]
  show "\<And>y z w. \<lbrakk>w \<in> A; (y, z) \<in> r\<rbrakk> \<Longrightarrow> f y w = f z w"
    by (iprover intro: commute [THEN trans] sym congt elim: eqv)
  show "\<And>y z w. \<lbrakk>w \<in> A; (y, z) \<in> r\<rbrakk> \<Longrightarrow> f w y = f w z"
    by (iprover intro: congt elim: eqv)
qed

subsection \<open>Quotients and finiteness\<close>

text \<open>Suggested by Florian Kammüller\<close>

lemma finite_quotient:
  assumes "finite A" "r \<subseteq> A \<times> A"
  shows "finite (A//r)"
    \<comment> \<open>recall @{thm equiv_type}\<close>
proof -
  have "A//r \<subseteq> Pow A"
    using assms unfolding quotient_def by blast
  moreover have "finite (Pow A)"
    using assms by simp
  ultimately show ?thesis
    by (iprover intro: finite_subset)
qed

lemma finite_equiv_class: "finite A \<Longrightarrow> r \<subseteq> A \<times> A \<Longrightarrow> X \<in> A//r \<Longrightarrow> finite X"
  unfolding quotient_def
  by (erule rev_finite_subset) blast

lemma equiv_imp_dvd_card:
  assumes "finite A" "equiv A r" "\<And>X. X \<in> A//r \<Longrightarrow> k dvd card X"
  shows "k dvd card A"
proof (rule Union_quotient [THEN subst])
  show "k dvd card (\<Union> (A // r))"
    apply (rule dvd_partition)
    using assms
    by (auto simp: Union_quotient dest: quotient_disj)
qed (use assms in blast)

subsection \<open>Projection\<close>

definition proj :: "('b \<times> 'a) set \<Rightarrow> 'b \<Rightarrow> 'a set"
  where "proj r x = r `` {x}"

lemma proj_preserves: "x \<in> A \<Longrightarrow> proj r x \<in> A//r"
  unfolding proj_def by (rule quotientI)

lemma proj_in_iff:
  assumes "equiv A r"
  shows "proj r x \<in> A//r \<longleftrightarrow> x \<in> A"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs
  then show ?lhs by (simp add: proj_preserves)
next
  assume ?lhs
  then show ?rhs
    unfolding proj_def quotient_def
  proof safe
    fix y
    assume y: "y \<in> A" and "r `` {x} = r `` {y}"
    moreover have "y \<in> r `` {y}"
      using assms y unfolding equiv_def refl_on_def by blast
    ultimately have "(x, y) \<in> r" by blast
    then show "x \<in> A"
      using assms unfolding equiv_def refl_on_def by blast
  qed
qed

lemma proj_iff: "equiv A r \<Longrightarrow> {x, y} \<subseteq> A \<Longrightarrow> proj r x = proj r y \<longleftrightarrow> (x, y) \<in> r"
  by (simp add: proj_def eq_equiv_class_iff)

(*
lemma in_proj: "\<lbrakk>equiv A r; x \<in> A\<rbrakk> \<Longrightarrow> x \<in> proj r x"
unfolding proj_def equiv_def refl_on_def by blast
*)

lemma proj_image: "proj r ` A = A//r"
  unfolding proj_def[abs_def] quotient_def by blast

lemma in_quotient_imp_non_empty: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> X \<noteq> {}"
  unfolding quotient_def using equiv_class_self by fast

lemma in_quotient_imp_in_rel: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> {x, y} \<subseteq> X \<Longrightarrow> (x, y) \<in> r"
  using quotient_eq_iff[THEN iffD1] by fastforce

lemma in_quotient_imp_closed: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> x \<in> X \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> y \<in> X"
  unfolding quotient_def equiv_def trans_def by blast

lemma in_quotient_imp_subset: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> X \<subseteq> A"
  using in_quotient_imp_in_rel equiv_type by fastforce

subsection \<open>Equivalence relations -- predicate version\<close>

text \<open>Partial equivalences.\<close>

definition part_equivp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
  where "part_equivp R \<longleftrightarrow> (\<exists>x. R x x) \<and> (\<forall>x y. R x y \<longleftrightarrow> R x x \<and> R y y \<and> R x = R y)"
    \<comment> \<open>John-Harrison-style characterization\<close>

lemma part_equivpI: "\<exists>x. R x x \<Longrightarrow> symp R \<Longrightarrow> transp R \<Longrightarrow> part_equivp R"
  by (auto simp add: part_equivp_def) (auto elim: sympE transpE)

lemma part_equivpE:
  assumes "part_equivp R"
  obtains x where "R x x" and "symp R" and "transp R"
proof -
  from assms have 1: "\<exists>x. R x x"
    and 2: "\<And>x y. R x y \<longleftrightarrow> R x x \<and> R y y \<and> R x = R y"
    unfolding part_equivp_def by blast+
  from 1 obtain x where "R x x" ..
  moreover have "symp R"
  proof (rule sympI)
    fix x y
    assume "R x y"
    with 2 [of x y] show "R y x" by auto
  qed
  moreover have "transp R"
  proof (rule transpI)
    fix x y z
    assume "R x y" and "R y z"
    with 2 [of x y] 2 [of y z] show "R x z" by auto
  qed
  ultimately show thesis by (rule that)
qed

lemma part_equivp_refl_symp_transp: "part_equivp R \<longleftrightarrow> (\<exists>x. R x x) \<and> symp R \<and> transp R"
  by (auto intro: part_equivpI elim: part_equivpE)

lemma part_equivp_symp: "part_equivp R \<Longrightarrow> R x y \<Longrightarrow> R y x"
  by (erule part_equivpE, erule sympE)

lemma part_equivp_transp: "part_equivp R \<Longrightarrow> R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
  by (erule part_equivpE, erule transpE)

lemma part_equivp_typedef: "part_equivp R \<Longrightarrow> \<exists>d. d \<in> {c. \<exists>x. R x x \<and> c = Collect (R x)}"
  by (auto elim: part_equivpE)

text \<open>Total equivalences.\<close>

definition equivp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
  where "equivp R \<longleftrightarrow> (\<forall>x y. R x y = (R x = R y))" \<comment> \<open>John-Harrison-style characterization\<close>

lemma equivpI: "reflp R \<Longrightarrow> symp R \<Longrightarrow> transp R \<Longrightarrow> equivp R"
  by (auto elim: reflpE sympE transpE simp add: equivp_def)

lemma equivpE:
  assumes "equivp R"
  obtains "reflp R" and "symp R" and "transp R"
  using assms by (auto intro!: that reflpI sympI transpI simp add: equivp_def)

lemma equivp_implies_part_equivp: "equivp R \<Longrightarrow> part_equivp R"
  by (auto intro: part_equivpI elim: equivpE reflpE)

lemma equivp_equiv: "equiv UNIV A \<longleftrightarrow> equivp (\<lambda>x y. (x, y) \<in> A)"
  by (auto intro!: equivI equivpI [to_set] elim!: equivE equivpE [to_set])

lemma equivp_reflp_symp_transp: "equivp R \<longleftrightarrow> reflp R \<and> symp R \<and> transp R"
  by (auto intro: equivpI elim: equivpE)

lemma identity_equivp: "equivp (=)"
  by (auto intro: equivpI reflpI sympI transpI)

lemma equivp_reflp: "equivp R \<Longrightarrow> R x x"
  by (erule equivpE, erule reflpE)

lemma equivp_symp: "equivp R \<Longrightarrow> R x y \<Longrightarrow> R y x"
  by (erule equivpE, erule sympE)

lemma equivp_transp: "equivp R \<Longrightarrow> R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
  by (erule equivpE, erule transpE)

lemma equivp_rtranclp: "symp r \<Longrightarrow> equivp r\<^sup>*\<^sup>*"
  by(intro equivpI reflpI sympI transpI)(auto dest: sympD[OF symp_rtranclp])

lemmas equivp_rtranclp_symclp [simp] = equivp_rtranclp[OF symp_on_symclp]

lemma equivp_vimage2p: "equivp R \<Longrightarrow> equivp (vimage2p f f R)"
  by(auto simp add: equivp_def vimage2p_def dest: fun_cong)

lemma equivp_imp_transp: "equivp R \<Longrightarrow> transp R"
  by(simp add: equivp_reflp_symp_transp)

subsection \<open>Equivalence closure\<close>

definition equivclp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "equivclp r = (symclp r)\<^sup>*\<^sup>*"

lemma transp_equivclp [simp]: "transp (equivclp r)"
  by(simp add: equivclp_def)

lemma reflp_equivclp [simp]: "reflp (equivclp r)"
  by(simp add: equivclp_def)

lemma symp_equivclp [simp]: "symp (equivclp r)"
  by(simp add: equivclp_def)

lemma equivp_evquivclp [simp]: "equivp (equivclp r)"
  by(simp add: equivpI)

lemma tranclp_equivclp [simp]: "(equivclp r)\<^sup>+\<^sup>+ = equivclp r"
  by(simp add: equivclp_def)

lemma rtranclp_equivclp [simp]: "(equivclp r)\<^sup>*\<^sup>* = equivclp r"
  by(simp add: equivclp_def)

lemma symclp_equivclp [simp]: "symclp (equivclp r) = equivclp r"
  by(simp add: equivclp_def symp_symclp_eq)

lemma equivclp_symclp [simp]: "equivclp (symclp r) = equivclp r"
  by(simp add: equivclp_def)

lemma equivclp_conversep [simp]: "equivclp (conversep r) = equivclp r"
  by(simp add: equivclp_def)

lemma equivclp_sym [sym]: "equivclp r x y \<Longrightarrow> equivclp r y x"
  by(rule sympD[OF symp_equivclp])

lemma equivclp_OO_equivclp_le_equivclp: "equivclp r OO equivclp r \<le> equivclp r"
  by(rule transp_relcompp_less_eq transp_equivclp)+

lemma rtranlcp_le_equivclp: "r\<^sup>*\<^sup>* \<le> equivclp r"
  unfolding equivclp_def by(rule rtranclp_mono)(simp add: symclp_pointfree)

lemma rtranclp_conversep_le_equivclp: "r\<inverse>\<inverse>\<^sup>*\<^sup>* \<le> equivclp r"
  unfolding equivclp_def by(rule rtranclp_mono)(simp add: symclp_pointfree)

lemma symclp_rtranclp_le_equivclp: "symclp r\<^sup>*\<^sup>* \<le> equivclp r"
  unfolding symclp_pointfree
  by(rule le_supI)(simp_all add: rtranclp_conversep[symmetric] rtranlcp_le_equivclp rtranclp_conversep_le_equivclp)

lemma r_OO_conversep_into_equivclp:
  "r\<^sup>*\<^sup>* OO r\<inverse>\<inverse>\<^sup>*\<^sup>* \<le> equivclp r"
  by(blast intro: order_trans[OF _ equivclp_OO_equivclp_le_equivclp] relcompp_mono rtranlcp_le_equivclp rtranclp_conversep_le_equivclp del: predicate2I)

lemma equivclp_induct [consumes 1, case_names base step, induct pred: equivclp]:
  assumes a: "equivclp r a b"
    and cases: "P a" "\<And>y z. equivclp r a y \<Longrightarrow> r y z \<or> r z y \<Longrightarrow> P y \<Longrightarrow> P z"
  shows "P b"
  using a unfolding equivclp_def
  by(induction rule: rtranclp_induct; fold equivclp_def; blast intro: cases elim: symclpE)

lemma converse_equivclp_induct [consumes 1, case_names base step]:
  assumes major: "equivclp r a b"
    and cases: "P b" "\<And>y z. r y z \<or> r z y \<Longrightarrow> equivclp r z b \<Longrightarrow> P z \<Longrightarrow> P y"
  shows "P a"
  using major unfolding equivclp_def
  by(induction rule: converse_rtranclp_induct; fold equivclp_def; blast intro: cases elim: symclpE)

lemma equivclp_refl [simp]: "equivclp r x x"
  by(rule reflpD[OF reflp_equivclp])

lemma r_into_equivclp [intro]: "r x y \<Longrightarrow> equivclp r x y"
  unfolding equivclp_def by(blast intro: symclpI)

lemma converse_r_into_equivclp [intro]: "r y x \<Longrightarrow> equivclp r x y"
  unfolding equivclp_def by(blast intro: symclpI)

lemma rtranclp_into_equivclp: "r\<^sup>*\<^sup>* x y \<Longrightarrow> equivclp r x y"
  using rtranlcp_le_equivclp[of r] by blast

lemma converse_rtranclp_into_equivclp: "r\<^sup>*\<^sup>* y x \<Longrightarrow> equivclp r x y"
  by(blast intro: equivclp_sym rtranclp_into_equivclp)

lemma equivclp_into_equivclp: "\<lbrakk> equivclp r a b; r b c \<or> r c b \<rbrakk> \<Longrightarrow> equivclp r a c"
  unfolding equivclp_def by(erule rtranclp.rtrancl_into_rtrancl)(auto intro: symclpI)

lemma equivclp_trans [trans]: "\<lbrakk> equivclp r a b; equivclp r b c \<rbrakk> \<Longrightarrow> equivclp r a c"
  using equivclp_OO_equivclp_le_equivclp[of r] by blast

hide_const (open) proj

end