(* Title:      Filters
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Filters\<close>

text \<open>
This theory develops filters based on orders, semilattices, lattices and distributive lattices.
We prove the ultrafilter lemma for orders with a least element.
We show the following structure theorems:
\begin{itemize}
\item The set of filters over a directed semilattice forms a lattice with a greatest element.
\item The set of filters over a bounded semilattice forms a bounded lattice.
\item The set of filters over a distributive lattice with a greatest element forms a bounded distributive lattice.
\end{itemize}
Another result is that in a distributive lattice ultrafilters are prime filters.
We also prove a lemma of Gr\"atzer and Schmidt about principal filters.

We apply these results in proving the construction theorem for Stone algebras (described in a separate theory).
See, for example, \<^cite>\<open>"BalbesDwinger1974" and "Birkhoff1967" and "Blyth2005" and "DaveyPriestley2002" and "Graetzer1971"\<close> for further results about filters.
\<close>

theory Filters

imports Lattice_Basics

begin

subsection \<open>Orders\<close>

text \<open>
This section gives the basic definitions related to filters in terms of orders.
The main result is the ultrafilter lemma.
\<close>

context ord
begin

abbreviation down :: "'a \<Rightarrow> 'a set" ("\<down>_" [81] 80)
  where "\<down>x \<equiv> { y . y \<le> x }"

abbreviation down_set :: "'a set \<Rightarrow> 'a set" ("\<Down>_" [81] 80)
  where "\<Down>X \<equiv> { y . \<exists>x\<in>X . y \<le> x }"

abbreviation is_down_set :: "'a set \<Rightarrow> bool"
  where "is_down_set X \<equiv> \<forall>x\<in>X . \<forall>y . y \<le> x \<longrightarrow> y\<in>X"

abbreviation is_principal_down :: "'a set \<Rightarrow> bool"
  where "is_principal_down X \<equiv> \<exists>x . X = \<down>x"

abbreviation up :: "'a \<Rightarrow> 'a set" ("\<up>_" [81] 80)
  where "\<up>x \<equiv> { y . x \<le> y }"

abbreviation up_set :: "'a set \<Rightarrow> 'a set" ("\<Up>_" [81] 80)
  where "\<Up>X \<equiv> { y . \<exists>x\<in>X . x \<le> y }"

abbreviation is_up_set :: "'a set \<Rightarrow> bool"
  where "is_up_set X \<equiv> \<forall>x\<in>X . \<forall>y . x \<le> y \<longrightarrow> y\<in>X"

abbreviation is_principal_up :: "'a set \<Rightarrow> bool"
  where "is_principal_up X \<equiv> \<exists>x . X = \<up>x"

text \<open>
A filter is a non-empty, downward directed, up-closed set.
\<close>

definition filter :: "'a set \<Rightarrow> bool"
  where "filter F \<equiv> (F \<noteq> {}) \<and> (\<forall>x\<in>F . \<forall>y\<in>F . \<exists>z\<in>F . z \<le> x \<and> z \<le> y) \<and> is_up_set F"

abbreviation proper_filter :: "'a set \<Rightarrow> bool"
  where "proper_filter F \<equiv> filter F \<and> F \<noteq> UNIV"

abbreviation ultra_filter :: "'a set \<Rightarrow> bool"
  where "ultra_filter F \<equiv> proper_filter F \<and> (\<forall>G . proper_filter G \<and> F \<subseteq> G \<longrightarrow> F = G)"

abbreviation filters :: "'a set set"
  where "filters \<equiv> { F::'a set . filter F }"

lemma filter_map_filter:
  assumes "filter F"
      and "mono f"
      and "\<forall>x y . f x \<le> y \<longrightarrow> (\<exists>z . x \<le> z \<and> y = f z)"
    shows "filter (f ` F)"
proof (unfold ord_class.filter_def, intro conjI)
  show "f ` F \<noteq> {}"
    using assms(1) ord_class.filter_def by auto
next
  show "\<forall>x\<in>f ` F . \<forall>y\<in>f ` F . \<exists>z\<in>f ` F . z \<le> x \<and> z \<le> y"
  proof (intro ballI)
    fix x y
    assume "x \<in> f ` F" and "y \<in> f ` F"
    then obtain u v where 1: "x = f u \<and> u \<in> F \<and> y = f v \<and> v \<in> F"
      by auto
    then obtain w where "w \<le> u \<and> w \<le> v \<and> w \<in> F"
      by (meson assms(1) ord_class.filter_def)
    thus "\<exists>z\<in>f ` F . z \<le> x \<and> z \<le> y"
      using 1 assms(2) mono_def image_eqI by blast
  qed
next
  show "is_up_set (f ` F)"
  proof
    fix x
    assume "x \<in> f ` F"
    then obtain u where 1: "x = f u \<and> u \<in> F"
      by auto
    show "\<forall>y . x \<le> y \<longrightarrow> y \<in> f ` F"
    proof (rule allI, rule impI)
      fix y
      assume "x \<le> y"
      hence "f u \<le> y"
        using 1 by simp
      then obtain z where "u \<le> z \<and> y = f z"
        using assms(3) by auto
      thus "y \<in> f ` F"
        by (meson 1 assms(1) image_iff ord_class.filter_def)
    qed
  qed
qed

end

context order
begin

lemma self_in_downset [simp]:
  "x \<in> \<down>x"
  by simp

lemma self_in_upset [simp]:
  "x \<in> \<up>x"
  by simp

lemma up_filter [simp]:
  "filter (\<up>x)"
  using filter_def order_lesseq_imp by auto

lemma up_set_up_set [simp]:
  "is_up_set (\<Up>X)"
  using order.trans by fastforce

lemma up_injective:
  "\<up>x = \<up>y \<Longrightarrow> x = y"
  using order.antisym by auto

lemma up_antitone:
  "x \<le> y \<longleftrightarrow> \<up>y \<subseteq> \<up>x"
  by auto

end

context order_bot
begin

lemma bot_in_downset [simp]:
  "bot \<in> \<down>x"
  by simp

lemma down_bot [simp]:
  "\<down>bot = {bot}"
  by (simp add: bot_unique)

lemma up_bot [simp]:
  "\<up>bot = UNIV"
  by simp

text \<open>
The following result is the ultrafilter lemma, generalised from \<^cite>\<open>\<open>10.17\<close> in "DaveyPriestley2002"\<close> to orders with a least element.
Its proof uses Isabelle/HOL's \<open>Zorn_Lemma\<close>, which requires closure under union of arbitrary (possibly empty) chains.
Actually, the proof does not use any of the underlying order properties except \<open>bot_least\<close>.
\<close>

lemma ultra_filter:
  assumes "proper_filter F"
    shows "\<exists>G . ultra_filter G \<and> F \<subseteq> G"
proof -
  let ?A = "{ G . (proper_filter G \<and> F \<subseteq> G) \<or> G = {} }"
  have "\<forall>C \<in> chains ?A . \<Union>C \<in> ?A"
  proof
    fix C :: "'a set set"
    let ?D = "C - {{}}"
    assume 1: "C \<in> chains ?A"
    hence 2: "\<forall>x\<in>\<Union>?D . \<exists>H\<in>?D . x \<in> H \<and> proper_filter H"
      using chainsD2 by fastforce
    have 3: "\<Union>?D = \<Union>C"
      by blast
    have "\<Union>?D \<in> ?A"
    proof (cases "?D = {}")
      assume "?D = {}"
      thus ?thesis
        by auto
    next
      assume 4: "?D \<noteq> {}"
      then obtain G where "G \<in> ?D"
        by auto
      hence 5: "F \<subseteq> \<Union>?D"
        using 1 chainsD2 by blast
      have 6: "is_up_set (\<Union>?D)"
      proof
        fix x
        assume "x \<in> \<Union>?D"
        then obtain H where "x \<in> H \<and> H \<in> ?D \<and> filter H"
          using 2 by auto
        thus "\<forall>y . x \<le> y \<longrightarrow> y\<in>\<Union>?D"
          using filter_def UnionI by fastforce
      qed
      have 7: "\<Union>?D \<noteq> UNIV"
      proof (rule ccontr)
        assume "\<not> \<Union>?D \<noteq> UNIV"
        then obtain H where "bot \<in> H \<and> proper_filter H"
          using 2 by blast
        thus False
          by (meson UNIV_I bot_least filter_def subsetI subset_antisym)
      qed
      {
        fix x y
        assume "x\<in>\<Union>?D \<and> y\<in>\<Union>?D"
        then obtain H I where 8: "x \<in> H \<and> H \<in> ?D \<and> filter H \<and> y \<in> I \<and> I \<in> ?D \<and> filter I"
          using 2 by metis
        have "\<exists>z\<in>\<Union>?D . z \<le> x \<and> z \<le> y"
        proof (cases "H \<subseteq> I")
          assume "H \<subseteq> I"
          hence "\<exists>z\<in>I . z \<le> x \<and> z \<le> y"
            using 8 by (metis subsetCE filter_def)
          thus ?thesis
            using 8 by (metis UnionI)
        next
          assume "\<not> (H \<subseteq> I)"
          hence "I \<subseteq> H"
            using 1 8 by (meson DiffE chainsD)
          hence "\<exists>z\<in>H . z \<le> x \<and> z \<le> y"
            using 8 by (metis subsetCE filter_def)
          thus ?thesis
            using 8 by (metis UnionI)
        qed
      }
      thus ?thesis
        using 4 5 6 7 filter_def by auto
    qed
    thus "\<Union>C \<in> ?A"
      using 3 by simp
  qed
  hence "\<exists>M\<in>?A . \<forall>X\<in>?A . M \<subseteq> X \<longrightarrow> X = M"
    by (rule Zorn_Lemma)
  then obtain M where 9: "M \<in> ?A \<and> (\<forall>X\<in>?A . M \<subseteq> X \<longrightarrow> X = M)"
    by auto
  hence 10: "M \<noteq> {}"
    using assms filter_def by auto
  {
    fix G
    assume 11: "proper_filter G \<and> M \<subseteq> G"
    hence "F \<subseteq> G"
      using 9 10 by blast
    hence "M = G"
      using 9 11 by auto
  }
  thus ?thesis
    using 9 10 by blast
qed

end

context order_top
begin

lemma down_top [simp]:
  "\<down>top = UNIV"
  by simp

lemma top_in_upset [simp]:
  "top \<in> \<up>x"
  by simp

lemma up_top [simp]:
  "\<up>top = {top}"
  by (simp add: top_unique)

lemma filter_top [simp]:
  "filter {top}"
  using filter_def top_unique by auto

lemma top_in_filter [simp]:
  "filter F \<Longrightarrow> top \<in> F"
  using filter_def by fastforce

end

text \<open>
The existence of proper filters and ultrafilters requires that the underlying order contains at least two elements.
\<close>

context non_trivial_order
begin

lemma proper_filter_exists:
  "\<exists>F . proper_filter F"
proof -
  from consistent obtain x y :: 'a where "x \<noteq> y"
    by auto
  hence "\<up>x \<noteq> UNIV \<or> \<up>y \<noteq> UNIV"
    using order.antisym by blast
  hence "proper_filter (\<up>x) \<or> proper_filter (\<up>y)"
    by simp
  thus ?thesis
    by blast
qed

end

context non_trivial_order_bot
begin

lemma ultra_filter_exists:
  "\<exists>F . ultra_filter F"
  using ultra_filter proper_filter_exists by blast

end

context non_trivial_bounded_order
begin

lemma proper_filter_top:
  "proper_filter {top}"
  using bot_not_top filter_top by blast

lemma ultra_filter_top:
  "\<exists>G . ultra_filter G \<and> top \<in> G"
  using ultra_filter proper_filter_top by fastforce

end

subsection \<open>Lattices\<close>

text \<open>
This section develops the lattice structure of filters based on a semilattice structure of the underlying order.
The main results are that filters over a directed semilattice form a lattice with a greatest element and that filters over a bounded semilattice form a bounded lattice.
\<close>

context semilattice_sup
begin

abbreviation prime_filter :: "'a set \<Rightarrow> bool"
  where "prime_filter F \<equiv> proper_filter F \<and> (\<forall>x y . x \<squnion> y \<in> F \<longrightarrow> x \<in> F \<or> y \<in> F)"

end

context semilattice_inf
begin

lemma filter_inf_closed:
  "filter F \<Longrightarrow> x \<in> F \<Longrightarrow> y \<in> F \<Longrightarrow> x \<sqinter> y \<in> F"
  by (meson filter_def inf.boundedI)

lemma filter_univ:
  "filter UNIV"
  by (meson UNIV_I UNIV_not_empty filter_def inf.cobounded1 inf.cobounded2)

text \<open>
The operation \<open>filter_sup\<close> is the join operation in the lattice of filters.
\<close>

definition "filter_sup F G \<equiv> { z . \<exists>x\<in>F . \<exists>y\<in>G . x \<sqinter> y \<le> z }"

lemma filter_sup:
  assumes "filter F"
      and "filter G"
    shows "filter (filter_sup F G)"
proof -
  have "F \<noteq> {} \<and> G \<noteq> {}"
    using assms filter_def by blast
  hence 1: "filter_sup F G \<noteq> {}"
    using filter_sup_def by blast
  have 2: "\<forall>x\<in>filter_sup F G . \<forall>y\<in>filter_sup F G . \<exists>z\<in>filter_sup F G . z \<le> x \<and> z \<le> y"
  proof
    fix x
    assume "x\<in>filter_sup F G"
    then obtain t u where 3: "t \<in> F \<and> u \<in> G \<and> t \<sqinter> u \<le> x"
      using filter_sup_def by auto
    show "\<forall>y\<in>filter_sup F G . \<exists>z\<in>filter_sup F G . z \<le> x \<and> z \<le> y"
    proof
      fix y
      assume "y\<in>filter_sup F G"
      then obtain v w where 4: "v \<in> F \<and> w \<in> G \<and> v \<sqinter> w \<le> y"
        using filter_sup_def by auto
      let ?z = "(t \<sqinter> v) \<sqinter> (u \<sqinter> w)"
      have 5: "?z \<le> x \<and> ?z \<le> y"
        using 3 4 by (meson order.trans inf.cobounded1 inf.cobounded2 inf_mono)
      have "?z \<in> filter_sup F G"
        unfolding filter_sup_def using assms 3 4 filter_inf_closed by blast
      thus "\<exists>z\<in>filter_sup F G . z \<le> x \<and> z \<le> y"
        using 5 by blast
    qed
  qed
  have "\<forall>x\<in>filter_sup F G . \<forall>y . x \<le> y \<longrightarrow> y \<in> filter_sup F G"
    unfolding filter_sup_def using order_trans by blast
  thus ?thesis
    using 1 2 filter_def by presburger
qed

lemma filter_sup_left_upper_bound:
  assumes "filter G"
    shows "F \<subseteq> filter_sup F G"
proof -
  from assms obtain y where "y\<in>G"
    using all_not_in_conv filter_def by auto
  thus ?thesis
    unfolding filter_sup_def using inf.cobounded1 by blast
qed

lemma filter_sup_symmetric:
  "filter_sup F G = filter_sup G F"
  unfolding filter_sup_def using inf.commute by fastforce

lemma filter_sup_right_upper_bound:
  "filter F \<Longrightarrow> G \<subseteq> filter_sup F G"
  using filter_sup_symmetric filter_sup_left_upper_bound by simp

lemma filter_sup_least_upper_bound:
  assumes "filter H"
      and "F \<subseteq> H"
      and "G \<subseteq> H"
    shows "filter_sup F G \<subseteq> H"
proof
  fix x
  assume "x \<in> filter_sup F G"
  then obtain y z where 1: "y \<in> F \<and> z \<in> G \<and> y \<sqinter> z \<le> x"
    using filter_sup_def by auto
  hence "y \<in> H \<and> z \<in> H"
    using assms(2-3) by auto
  hence "y \<sqinter> z \<in> H"
    by (simp add: assms(1) filter_inf_closed)
  thus "x \<in> H"
    using 1 assms(1) filter_def by auto
qed

lemma filter_sup_left_isotone:
  "G \<subseteq> H \<Longrightarrow> filter_sup G F \<subseteq> filter_sup H F"
  unfolding filter_sup_def by blast

lemma filter_sup_right_isotone:
  "G \<subseteq> H \<Longrightarrow> filter_sup F G \<subseteq> filter_sup F H"
  unfolding filter_sup_def by blast

lemma filter_sup_right_isotone_var:
  "filter_sup F (G \<inter> H) \<subseteq> filter_sup F H"
  unfolding filter_sup_def by blast

lemma up_dist_inf:
  "\<up>(x \<sqinter> y) = filter_sup (\<up>x) (\<up>y)"
proof
  show "\<up>(x \<sqinter> y) \<subseteq> filter_sup (\<up>x) (\<up>y)"
    unfolding filter_sup_def by blast
next
  show "filter_sup (\<up>x) (\<up>y) \<subseteq> \<up>(x \<sqinter> y)"
  proof
    fix z
    assume "z \<in> filter_sup (\<up>x) (\<up>y)"
    then obtain u v where "u\<in>\<up>x \<and> v\<in>\<up>y \<and> u \<sqinter> v \<le> z"
      using filter_sup_def by auto
    hence "x \<sqinter> y \<le> z"
      using order.trans inf_mono by blast
    thus "z \<in> \<up>(x \<sqinter> y)"
      by blast
  qed
qed

text \<open>
The following result is part of \<^cite>\<open>\<open>Exercise 2.23\<close> in "DaveyPriestley2002"\<close>.
\<close>

lemma filter_inf_filter [simp]:
  assumes "filter F"
    shows "filter (\<Up>{ y . \<exists>z\<in>F . x \<sqinter> z = y})"
proof -
  let ?G = "\<Up>{ y . \<exists>z\<in>F . x \<sqinter> z = y}"
  have "F \<noteq> {}"
    using assms filter_def by simp
  hence 1: "?G \<noteq> {}"
    by blast
  have 2: "is_up_set ?G"
    by auto
  {
    fix y z
    assume "y \<in> ?G \<and> z \<in> ?G"
    then obtain v w where "v \<in> F \<and> w \<in> F \<and> x \<sqinter> v \<le> y \<and> x \<sqinter> w \<le> z"
      by auto
    hence "v \<sqinter> w \<in> F \<and> x \<sqinter> (v \<sqinter> w) \<le> y \<sqinter> z"
      by (meson assms filter_inf_closed order.trans inf.boundedI inf.cobounded1 inf.cobounded2)
    hence "\<exists>u\<in>?G . u \<le> y \<and> u \<le> z"
      by auto
  }
  hence "\<forall>x\<in>?G . \<forall>y\<in>?G . \<exists>z\<in>?G . z \<le> x \<and> z \<le> y"
    by auto
  thus ?thesis
    using 1 2 filter_def by presburger
qed

end

context directed_semilattice_inf
begin

text \<open>
Set intersection is the meet operation in the lattice of filters.
\<close>

lemma filter_inf:
  assumes "filter F"
      and "filter G"
    shows "filter (F \<inter> G)"
proof (unfold filter_def, intro conjI)
  from assms obtain x y where 1: "x\<in>F \<and> y\<in>G"
    using all_not_in_conv filter_def by auto
  from ub obtain z where "x \<le> z \<and> y \<le> z"
    by auto
  hence "z \<in> F \<inter> G"
    using 1 by (meson assms Int_iff filter_def)
  thus "F \<inter> G \<noteq> {}"
    by blast
next
  show "is_up_set (F \<inter> G)"
    by (meson assms Int_iff filter_def)
next
  show "\<forall>x\<in>F \<inter> G . \<forall>y\<in>F \<inter> G . \<exists>z\<in>F \<inter> G . z \<le> x \<and> z \<le> y"
    by (metis assms Int_iff filter_inf_closed inf.cobounded2 inf.commute)
qed

end

text \<open>
We introduce the following type of filters to instantiate the lattice classes and thereby inherit the results shown about lattices.
\<close>

typedef (overloaded) 'a filter = "{ F::'a::order set . filter F }"
  by (meson mem_Collect_eq up_filter)

lemma simp_filter [simp]:
  "filter (Rep_filter x)"
  using Rep_filter by simp

setup_lifting type_definition_filter

text \<open>
The set of filters over a directed semilattice forms a lattice with a greatest element.
\<close>

instantiation filter :: (directed_semilattice_inf) bounded_lattice_top
begin

lift_definition top_filter :: "'a filter" is UNIV
  by (simp add: filter_univ)

lift_definition sup_filter :: "'a filter \<Rightarrow> 'a filter \<Rightarrow> 'a filter" is filter_sup
  by (simp add: filter_sup)

lift_definition inf_filter :: "'a filter \<Rightarrow> 'a filter \<Rightarrow> 'a filter" is inter
  by (simp add: filter_inf)

lift_definition less_eq_filter :: "'a filter \<Rightarrow> 'a filter \<Rightarrow> bool" is subset_eq .

lift_definition less_filter :: "'a filter \<Rightarrow> 'a filter \<Rightarrow> bool" is subset .

instance
  apply intro_classes
  subgoal apply transfer by (simp add: less_le_not_le)
  subgoal apply transfer by simp
  subgoal apply transfer by simp
  subgoal apply transfer by simp
  subgoal apply transfer by simp
  subgoal apply transfer by simp
  subgoal apply transfer by simp
  subgoal apply transfer by (simp add: filter_sup_left_upper_bound)
  subgoal apply transfer by (simp add: filter_sup_right_upper_bound)
  subgoal apply transfer by (simp add: filter_sup_least_upper_bound)
  subgoal apply transfer by simp
  done

end

context bounded_semilattice_inf_top
begin

abbreviation "filter_complements F G \<equiv> filter F \<and> filter G \<and> filter_sup F G = UNIV \<and> F \<inter> G = {top}"

end

text \<open>
The set of filters over a bounded semilattice forms a bounded lattice.
\<close>

instantiation filter :: (bounded_semilattice_inf_top) bounded_lattice
begin

lift_definition bot_filter :: "'a filter" is "{top}"
  by simp

instance
  apply intro_classes
  apply transfer
  by simp

end

context lattice
begin

lemma up_dist_sup:
  "\<up>(x \<squnion> y) = \<up>x \<inter> \<up>y"
  by auto

end

text \<open>
For convenience, the following function injects principal filters into the filter type.
We cannot define it in the \<open>order\<close> class since the type filter requires the sort constraint \<open>order\<close> that is not available in the class.
The result of the function is a filter by lemma \<open>up_filter\<close>.
\<close>

abbreviation up_filter :: "'a::order \<Rightarrow> 'a filter"
  where "up_filter x \<equiv> Abs_filter (\<up>x)"

lemma up_filter_dist_inf:
  "up_filter ((x::'a::lattice) \<sqinter> y) = up_filter x \<squnion> up_filter y"
  by (simp add: eq_onp_def sup_filter.abs_eq up_dist_inf)

lemma up_filter_dist_sup:
  "up_filter ((x::'a::lattice) \<squnion> y) = up_filter x \<sqinter> up_filter y"
  by (metis eq_onp_def inf_filter.abs_eq up_dist_sup up_filter)

lemma up_filter_injective:
  "up_filter x = up_filter y \<Longrightarrow> x = y"
  by (metis Abs_filter_inject mem_Collect_eq up_filter up_injective)

lemma up_filter_antitone:
  "x \<le> y \<longleftrightarrow> up_filter y \<le> up_filter x"
  by (metis eq_onp_same_args less_eq_filter.abs_eq up_antitone up_filter)

text \<open>
The following definition applies a function to each element of a filter.
The subsequent lemma gives conditions under which the result of this application is a filter.
\<close>

abbreviation filter_map :: "('a::order \<Rightarrow> 'b::order) \<Rightarrow> 'a filter \<Rightarrow> 'b filter"
  where "filter_map f F \<equiv> Abs_filter (f ` Rep_filter F)"

lemma filter_map_filter:
  assumes "mono f"
      and "\<forall>x y . f x \<le> y \<longrightarrow> (\<exists>z . x \<le> z \<and> y = f z)"
    shows "filter (f ` Rep_filter F)"
  by (simp add: assms inf.filter_map_filter)

subsection \<open>Distributive Lattices\<close>

text \<open>
In this section we additionally assume that the underlying order forms a distributive lattice.
Then filters form a bounded distributive lattice if the underlying order has a greatest element.
Moreover ultrafilters are prime filters.
We also prove a lemma of Gr\"atzer and Schmidt about principal filters.
\<close>

context distrib_lattice
begin

lemma filter_sup_left_dist_inf:
  assumes "filter F"
      and "filter G"
      and "filter H"
    shows "filter_sup F (G \<inter> H) = filter_sup F G \<inter> filter_sup F H"
proof
  show "filter_sup F (G \<inter> H) \<subseteq> filter_sup F G \<inter> filter_sup F H"
    unfolding filter_sup_def using filter_sup_right_isotone_var by blast
next
  show "filter_sup F G \<inter> filter_sup F H \<subseteq> filter_sup F (G \<inter> H)"
  proof
    fix x
    assume "x \<in> filter_sup F G \<inter> filter_sup F H"
    then obtain t u v w where 1: "t \<in> F \<and> u \<in> G \<and> v \<in> F \<and> w \<in> H \<and> t \<sqinter> u \<le> x \<and> v \<sqinter> w \<le> x"
      using filter_sup_def by auto
    let ?y = "t \<sqinter> v"
    let ?z = "u \<squnion> w"
    have 2: "?y \<in> F"
      using 1 by (simp add: assms(1) filter_inf_closed)
    have 3: "?z \<in> G \<inter> H"
      using 1 by (meson assms(2-3) Int_iff filter_def sup_ge1 sup_ge2)
    have "?y \<sqinter> ?z = (t \<sqinter> v \<sqinter> u) \<squnion> (t \<sqinter> v \<sqinter> w)"
      by (simp add: inf_sup_distrib1)
    also have "... \<le> (t \<sqinter> u) \<squnion> (v \<sqinter> w)"
      by (metis inf.cobounded1 inf.cobounded2 inf.left_idem inf_mono sup.mono)
    also have "... \<le> x"
      using 1 by (simp add: le_supI)
    finally show "x \<in> filter_sup F (G \<inter> H)"
      unfolding filter_sup_def using 2 3 by blast
  qed
qed

lemma filter_inf_principal_rep:
  "F \<inter> G = \<up>z \<Longrightarrow> (\<exists>x\<in>F . \<exists>y\<in>G . z = x \<squnion> y)"
  by force

lemma filter_sup_principal_rep:
  assumes "filter F"
      and "filter G"
      and "filter_sup F G = \<up>z"
    shows "\<exists>x\<in>F . \<exists>y\<in>G . z = x \<sqinter> y"
proof -
  from assms(3) obtain x y where 1: "x\<in>F \<and> y\<in>G \<and> x \<sqinter> y \<le> z"
    unfolding filter_sup_def using order_refl by blast
  hence 2: "x \<squnion> z \<in> F \<and> y \<squnion> z \<in> G"
    by (meson assms(1-2) sup_ge1 filter_def)
  have "(x \<squnion> z) \<sqinter> (y \<squnion> z) = z"
    using 1 sup_absorb2 sup_inf_distrib2 by fastforce
  thus ?thesis
    using 2 by force
qed

lemma inf_sup_principal_aux:
  assumes "filter F"
      and "filter G"
      and "is_principal_up (filter_sup F G)"
      and "is_principal_up (F \<inter> G)"
    shows "is_principal_up F"
proof -
  from assms(3-4) obtain x y where 1: "filter_sup F G = \<up>x \<and> F \<inter> G = \<up>y"
    by blast
  from filter_inf_principal_rep obtain t u where 2: "t\<in>F \<and> u\<in>G \<and> y = t \<squnion> u"
    using 1 by meson
  from filter_sup_principal_rep obtain v w where 3: "v\<in>F \<and> w\<in>G \<and> x = v \<sqinter> w"
    using 1 by (meson assms(1-2))
  have "t \<in> filter_sup F G \<and> u \<in> filter_sup F G"
    unfolding filter_sup_def using 2 inf.cobounded1 inf.cobounded2 by blast
  hence "x \<le> t \<and> x \<le> u"
    using 1 by blast
  hence 4: "(t \<sqinter> v) \<sqinter> (u \<sqinter> w) = x"
    using 3 by (simp add: inf.absorb2 inf.assoc inf.left_commute)
  have "(t \<sqinter> v) \<squnion> (u \<sqinter> w) \<in> F \<and> (t \<sqinter> v) \<squnion> (u \<sqinter> w) \<in> G"
    using 2 3 by (metis (no_types, lifting) assms(1-2) filter_inf_closed sup.cobounded1 sup.cobounded2 filter_def)
  hence "y \<le> (t \<sqinter> v) \<squnion> (u \<sqinter> w)"
    using 1 Int_iff by blast
  hence 5: "(t \<sqinter> v) \<squnion> (u \<sqinter> w) = y"
    using 2 by (simp add: order.antisym inf.coboundedI1)
  have "F = \<up>(t \<sqinter> v)"
  proof
    show "F \<subseteq> \<up>(t \<sqinter> v)"
    proof
      fix z
      assume 6: "z \<in> F"
      hence "z \<in> filter_sup F G"
        unfolding filter_sup_def using 2 inf.cobounded1 by blast
      hence "x \<le> z"
        using 1 by simp
      hence 7: "(t \<sqinter> v \<sqinter> z) \<sqinter> (u \<sqinter> w) = x"
        using 4 by (metis inf.absorb1 inf.assoc inf.commute)
      have "z \<squnion> u \<in> F \<and> z \<squnion> u \<in> G \<and> z \<squnion> w \<in> F \<and> z \<squnion> w \<in> G"
        using 2 3 6 by (meson assms(1-2) filter_def sup_ge1 sup_ge2)
      hence "y \<le> (z \<squnion> u) \<sqinter> (z \<squnion> w)"
        using 1 Int_iff filter_inf_closed by auto
      hence 8: "(t \<sqinter> v \<sqinter> z) \<squnion> (u \<sqinter> w) = y"
        using 5 by (metis inf.absorb1 sup.commute sup_inf_distrib2)
      have "t \<sqinter> v \<sqinter> z = t \<sqinter> v"
        using 4 5 7 8 relative_equality by blast
      thus "z \<in> \<up>(t \<sqinter> v)"
        by (simp add: inf.orderI)
    qed
  next
    show "\<up>(t \<sqinter> v) \<subseteq> F"
    proof
      fix z
      have 9: "t \<sqinter> v \<in> F"
        using 2 3 by (simp add: assms(1) filter_inf_closed)
      assume "z \<in> \<up>(t \<sqinter> v)"
      hence "t \<sqinter> v \<le> z" by simp
      thus "z \<in> F"
        using assms(1) 9 filter_def by auto
    qed
  qed
  thus ?thesis
    by blast
qed

text \<open>
The following result is \<^cite>\<open>\<open>Lemma II\<close> in "GraetzerSchmidt1958"\<close>.
If both join and meet of two filters are principal filters, both filters are principal filters.
\<close>

lemma inf_sup_principal:
  assumes "filter F"
      and "filter G"
      and "is_principal_up (filter_sup F G)"
      and "is_principal_up (F \<inter> G)"
    shows "is_principal_up F \<and> is_principal_up G"
proof -
  have "filter G \<and> filter F \<and> is_principal_up (filter_sup G F) \<and> is_principal_up (G \<inter> F)"
    by (simp add: assms Int_commute filter_sup_symmetric)
  thus ?thesis
    using assms(3) inf_sup_principal_aux by blast
qed

lemma filter_sup_absorb_inf: "filter F \<Longrightarrow> filter G \<Longrightarrow> filter_sup (F \<inter> G) G = G"
  by (simp add: filter_inf filter_sup_least_upper_bound filter_sup_left_upper_bound filter_sup_symmetric subset_antisym)

lemma filter_inf_absorb_sup: "filter F \<Longrightarrow> filter G \<Longrightarrow> filter_sup F G \<inter> G = G"
  apply (rule subset_antisym)
  apply simp
  by (simp add: filter_sup_right_upper_bound)

lemma filter_inf_right_dist_sup:
  assumes "filter F"
      and "filter G"
      and "filter H"
    shows "filter_sup F G \<inter> H = filter_sup (F \<inter> H) (G \<inter> H)"
proof -
  have "filter_sup (F \<inter> H) (G \<inter> H) = filter_sup (F \<inter> H) G \<inter> filter_sup (F \<inter> H) H"
    by (simp add: assms filter_sup_left_dist_inf filter_inf)
  also have "... = filter_sup (F \<inter> H) G \<inter> H"
    using assms(1,3) filter_sup_absorb_inf by simp
  also have "... = filter_sup F G \<inter> filter_sup G H \<inter> H"
    using assms filter_sup_left_dist_inf filter_sup_symmetric by simp
  also have "... = filter_sup F G \<inter> H"
    by (simp add: assms(2-3) filter_inf_absorb_sup semilattice_inf_class.inf_assoc)
  finally show ?thesis
    by simp
qed

text \<open>
The following result generalises \<^cite>\<open>\<open>10.11\<close> in "DaveyPriestley2002"\<close> to distributive lattices as remarked after that section.
\<close>

lemma ultra_filter_prime:
  assumes "ultra_filter F"
    shows "prime_filter F"
proof -
  {
    fix x y
    assume 1: "x \<squnion> y \<in> F \<and> x \<notin> F"
    let ?G = "\<Up>{ z . \<exists>w\<in>F . x \<sqinter> w = z }"
    have 2: "filter ?G"
      using assms filter_inf_filter by simp
    have "x \<in> ?G"
      using 1 by auto
    hence 3: "F \<noteq> ?G"
      using 1 by auto
    have "F \<subseteq> ?G"
      using inf_le2 order_trans by blast
    hence "?G = UNIV"
      using 2 3 assms by blast
    then obtain z where 4: "z \<in> F \<and> x \<sqinter> z \<le> y"
      by blast
    hence "y \<sqinter> z = (x \<squnion> y) \<sqinter> z"
      by (simp add: inf_sup_distrib2 sup_absorb2)
    also have "... \<in> F"
      using 1 4 assms filter_inf_closed by auto
    finally have "y \<in> F"
      using assms by (simp add: filter_def)
  }
  thus ?thesis
    using assms by blast
qed

lemma up_dist_inf_inter:
  assumes "is_up_set S"
    shows "\<up>(x \<sqinter> y) \<inter> S = filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S"
proof
  show "\<up>(x \<sqinter> y) \<inter> S \<subseteq> filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S"
  proof
    fix z
    let ?x = "x \<squnion> z"
    let ?y = "y \<squnion> z"
    assume "z \<in> \<up>(x \<sqinter> y) \<inter> S"
    hence 1: "x \<sqinter> y \<le> z \<and> z \<in> S"
      by auto
    hence "?x \<in> (\<up>x \<inter> S) \<and> ?y \<in> (\<up>y \<inter> S) \<and> ?x \<sqinter> ?y \<le> z"
      using assms sup_absorb2 sup_inf_distrib2 by fastforce
    thus "z \<in> filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S"
      using filter_sup_def 1 by fastforce
  qed
next
  show "filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S \<subseteq> \<up>(x \<sqinter> y) \<inter> S"
  proof
    fix z
    assume "z \<in> filter_sup (\<up>x \<inter> S) (\<up>y \<inter> S) \<inter> S"
    then obtain u v where 2: "u\<in>\<up>x \<and> v\<in>\<up>y \<and> u \<sqinter> v \<le> z \<and> z \<in> S"
      using filter_sup_def by auto
    hence "x \<sqinter> y \<le> z"
      using order.trans inf_mono by blast
    thus "z \<in> \<up>(x \<sqinter> y) \<inter> S"
      using 2 by blast
  qed
qed

end

context distrib_lattice_bot
begin

lemma prime_filter:
  "proper_filter F \<Longrightarrow> \<exists>G . prime_filter G \<and> F \<subseteq> G"
  by (metis ultra_filter ultra_filter_prime)

end

context distrib_lattice_top
begin

lemma complemented_filter_inf_principal:
  assumes "filter_complements F G"
    shows "is_principal_up (F \<inter> \<up>x)"
proof -
  have 1: "filter F \<and> filter G"
    by (simp add: assms)
  hence 2: "filter (F \<inter> \<up>x) \<and> filter (G \<inter> \<up>x)"
    by (simp add: filter_inf)
  have "(F \<inter> \<up>x) \<inter> (G \<inter> \<up>x) = {top}"
    using assms Int_assoc Int_insert_left_if1 inf_bot_left inf_sup_aci(3) top_in_upset inf.idem by auto
  hence 3: "is_principal_up ((F \<inter> \<up>x) \<inter> (G \<inter> \<up>x))"
    using up_top by blast
  have "filter_sup (F \<inter> \<up>x) (G \<inter> \<up>x) = filter_sup F G \<inter> \<up>x"
    using 1 filter_inf_right_dist_sup up_filter by auto
  also have "... = \<up>x"
    by (simp add: assms)
  finally have "is_principal_up (filter_sup (F \<inter> \<up>x) (G \<inter> \<up>x))"
    by auto
  thus ?thesis
    using 1 2 3 inf_sup_principal_aux by blast
qed

end

text \<open>
The set of filters over a distributive lattice with a greatest element forms a bounded distributive lattice.
\<close>

instantiation filter :: (distrib_lattice_top) bounded_distrib_lattice
begin

instance
  apply intro_classes
  apply transfer
  by (simp add: filter_sup_left_dist_inf)

end

end


(*  Title:      HOL/Algebra/Cycles.thy
    Author:     Paulo Emílio de Vilhena
*)

theory Cycles
  imports "HOL-Library.Permutations" "HOL-Library.FuncSet"
begin

section \<open>Cycles\<close>

subsection \<open>Definitions\<close>

abbreviation cycle :: "'a list \<Rightarrow> bool"
  where "cycle cs \<equiv> distinct cs"

fun cycle_of_list :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a"
  where
    "cycle_of_list (i # j # cs) = (Fun.swap i j id) \<circ> (cycle_of_list (j # cs))"
  | "cycle_of_list cs = id"

subsection \<open>Basic Properties\<close>

text \<open>We start proving that the function derived from a cycle rotates its support list.\<close>

lemma id_outside_supp:
  assumes "x \<notin> set cs" shows "(cycle_of_list cs) x = x"
  using assms by (induct cs rule: cycle_of_list.induct) (simp_all)

lemma permutation_of_cycle: "permutation (cycle_of_list cs)"
proof (induct cs rule: cycle_of_list.induct)
  case 1 thus ?case
    using permutation_compose[OF permutation_swap_id] unfolding comp_apply by simp
qed simp_all

lemma cycle_permutes: "(cycle_of_list cs) permutes (set cs)"
  using permutation_bijective[OF permutation_of_cycle] id_outside_supp[of _ cs]
  by (simp add: bij_iff permutes_def)

theorem cyclic_rotation:
  assumes "cycle cs" shows "map ((cycle_of_list cs) ^^ n) cs = rotate n cs"
proof -
  { have "map (cycle_of_list cs) cs = rotate1 cs" using assms(1)
    proof (induction cs rule: cycle_of_list.induct)
      case (1 i j cs) thus ?case
      proof (cases)
        assume "cs = Nil" thus ?thesis by simp
      next
        assume "cs \<noteq> Nil" hence ge_two: "length (j # cs) \<ge> 2"
          using not_less by auto
        have "map (cycle_of_list (i # j # cs)) (i # j # cs) =
              map (Fun.swap i j id) (map (cycle_of_list (j # cs)) (i # j # cs))" by simp
        also have " ... = map (Fun.swap i j id) (i # (rotate1 (j # cs)))"
          by (metis "1.IH" "1.prems" distinct.simps(2) id_outside_supp list.simps(9))
        also have " ... = map (Fun.swap i j id) (i # (cs @ [j]))" by simp
        also have " ... = j # (map (Fun.swap i j id) cs) @ [i]" by simp
        also have " ... = j # cs @ [i]"
          by (metis "1.prems" distinct.simps(2) list.set_intros(2) map_idI swap_id_eq)
        also have " ... = rotate1 (i # j # cs)" by simp
        finally show ?thesis .
      qed
    qed simp_all }
  note cyclic_rotation' = this

  show ?thesis
    using cyclic_rotation' by (induct n) (auto, metis map_map rotate1_rotate_swap rotate_map)
qed

corollary cycle_is_surj:
  assumes "cycle cs" shows "(cycle_of_list cs) ` (set cs) = (set cs)"
  using cyclic_rotation[OF assms, of "Suc 0"] by (simp add: image_set)

corollary cycle_is_id_root:
  assumes "cycle cs" shows "(cycle_of_list cs) ^^ (length cs) = id"
proof -
  have "map ((cycle_of_list cs) ^^ (length cs)) cs = cs"
    unfolding cyclic_rotation[OF assms] by simp
  hence "((cycle_of_list cs) ^^ (length cs)) i = i" if "i \<in> set cs" for i
    using that map_eq_conv by fastforce
  moreover have "((cycle_of_list cs) ^^ n) i = i" if "i \<notin> set cs" for i n
    using id_outside_supp[OF that] by (induct n) (simp_all)
  ultimately show ?thesis
    by fastforce
qed

corollary cycle_of_list_rotate_independent:
  assumes "cycle cs" shows "(cycle_of_list cs) = (cycle_of_list (rotate n cs))"
proof -
  { fix cs :: "'a list" assume cs: "cycle cs"
    have "(cycle_of_list cs) = (cycle_of_list (rotate1 cs))"
    proof -
      from cs have rotate1_cs: "cycle (rotate1 cs)" by simp
      hence "map (cycle_of_list (rotate1 cs)) (rotate1 cs) = (rotate 2 cs)"
        using cyclic_rotation[OF rotate1_cs, of 1] by (simp add: numeral_2_eq_2)
      moreover have "map (cycle_of_list cs) (rotate1 cs) = (rotate 2 cs)"
        using cyclic_rotation[OF cs]
        by (metis One_nat_def Suc_1 funpow.simps(2) id_apply map_map rotate0 rotate_Suc)
      ultimately have "(cycle_of_list cs) i = (cycle_of_list (rotate1 cs)) i" if "i \<in> set cs" for i
        using that map_eq_conv unfolding sym[OF set_rotate1[of cs]] by fastforce
      moreover have "(cycle_of_list cs) i = (cycle_of_list (rotate1 cs)) i" if "i \<notin> set cs" for i
        using that by (simp add: id_outside_supp)
      ultimately show "(cycle_of_list cs) = (cycle_of_list (rotate1 cs))"
        by blast
    qed } note rotate1_lemma = this

  show ?thesis
    using rotate1_lemma[of "rotate n cs"] by (induct n) (auto, metis assms distinct_rotate rotate1_lemma)
qed

subsection\<open>Conjugation of cycles\<close>

lemma conjugation_of_cycle:
  assumes "cycle cs" and "bij p"
  shows "p \<circ> (cycle_of_list cs) \<circ> (inv p) = cycle_of_list (map p cs)"
  using assms
proof (induction cs rule: cycle_of_list.induct)
  case (1 i j cs)
  have "p \<circ> cycle_of_list (i # j # cs) \<circ> inv p =
       (p \<circ> (Fun.swap i j id) \<circ> inv p) \<circ> (p \<circ> cycle_of_list (j # cs) \<circ> inv p)"
    by (simp add: assms(2) bij_is_inj fun.map_comp)
  also have " ... = (Fun.swap (p i) (p j) id) \<circ> (p \<circ> cycle_of_list (j # cs) \<circ> inv p)"
    by (simp add: "1.prems"(2) bij_is_inj bij_swap_comp comp_swap o_assoc)
  finally have "p \<circ> cycle_of_list (i # j # cs) \<circ> inv p =
               (Fun.swap (p i) (p j) id) \<circ> (cycle_of_list (map p (j # cs)))"
    using "1.IH" "1.prems"(1) assms(2) by fastforce
  thus ?case by (metis cycle_of_list.simps(1) list.simps(9))
next
  case "2_1" thus ?case
    by (metis bij_is_surj comp_id cycle_of_list.simps(2) list.simps(8) surj_iff)
next
  case "2_2" thus ?case
    by (metis bij_is_surj comp_id cycle_of_list.simps(3) list.simps(8) list.simps(9) surj_iff)
qed

subsection\<open>When Cycles Commute\<close>

lemma cycles_commute:
  assumes "cycle p" "cycle q" and "set p \<inter> set q = {}"
  shows "(cycle_of_list p) \<circ> (cycle_of_list q) = (cycle_of_list q) \<circ> (cycle_of_list p)"
proof
  { fix p :: "'a list" and q :: "'a list" and i :: "'a"
    assume A: "cycle p" "cycle q" "set p \<inter> set q = {}" "i \<in> set p" "i \<notin> set q"
    have "((cycle_of_list p) \<circ> (cycle_of_list q)) i =
          ((cycle_of_list q) \<circ> (cycle_of_list p)) i"
    proof -
      have "((cycle_of_list p) \<circ> (cycle_of_list q)) i = (cycle_of_list p) i"
        using id_outside_supp[OF A(5)] by simp
      also have " ... = ((cycle_of_list q) \<circ> (cycle_of_list p)) i"
        using id_outside_supp[of "(cycle_of_list p) i"] cycle_is_surj[OF A(1)] A(3,4) by fastforce
      finally show ?thesis .
    qed } note aui_lemma = this

  fix i consider "i \<in> set p" "i \<notin> set q" | "i \<notin> set p" "i \<in> set q" | "i \<notin> set p" "i \<notin> set q"
    using \<open>set p \<inter> set q = {}\<close> by blast
  thus "((cycle_of_list p) \<circ> (cycle_of_list q)) i = ((cycle_of_list q) \<circ> (cycle_of_list p)) i"
  proof cases
    case 1 thus ?thesis
      using aui_lemma[OF assms] by simp
  next
    case 2 thus ?thesis
      using aui_lemma[OF assms(2,1)] assms(3) by (simp add: ac_simps(8))
  next
    case 3 thus ?thesis
      by (simp add: id_outside_supp)
  qed
qed

subsection \<open>Cycles from Permutations\<close>

subsubsection \<open>Exponentiation of permutations\<close>

text \<open>Some important properties of permutations before defining how to extract its cycles.\<close>

lemma permutation_funpow:
  assumes "permutation p" shows "permutation (p ^^ n)"
  using assms by (induct n) (simp_all add: permutation_compose)

lemma permutes_funpow:
  assumes "p permutes S" shows "(p ^^ n) permutes S"
  using assms by (induct n) (simp add: permutes_def, metis funpow_Suc_right permutes_compose)

lemma funpow_diff:
  assumes "inj p" and "i \<le> j" "(p ^^ i) a = (p ^^ j) a" shows "(p ^^ (j - i)) a = a"
proof -
  have "(p ^^ i) ((p ^^ (j - i)) a) = (p ^^ i) a"
    using assms(2-3) by (metis (no_types) add_diff_inverse_nat funpow_add not_le o_def)
  thus ?thesis
    unfolding inj_eq[OF inj_fn[OF assms(1)], of i] .
qed

lemma permutation_is_nilpotent:
  assumes "permutation p" obtains n where "(p ^^ n) = id" and "n > 0"
proof -
  obtain S where "finite S" and "p permutes S"
    using assms unfolding permutation_permutes by blast
  hence "\<exists>n. (p ^^ n) = id \<and> n > 0"
  proof (induct S arbitrary: p)
    case empty thus ?case
      using id_funpow[of 1] unfolding permutes_empty by blast
  next
    case (insert s S)
    have "(\<lambda>n. (p ^^ n) s) ` UNIV \<subseteq> (insert s S)"
      using permutes_in_image[OF permutes_funpow[OF insert(4)], of _ s] by auto
    hence "\<not> inj_on (\<lambda>n. (p ^^ n) s)  UNIV"
      using insert(1) infinite_iff_countable_subset unfolding sym[OF finite_insert, of S s] by metis
    then obtain i j where ij: "i < j" "(p ^^ i) s = (p ^^ j) s"
      unfolding inj_on_def by (metis nat_neq_iff)
    hence "(p ^^ (j - i)) s = s"
      using funpow_diff[OF permutes_inj[OF insert(4)]] le_eq_less_or_eq by blast
    hence "p ^^ (j - i) permutes S"
      using permutes_superset[OF permutes_funpow[OF insert(4), of "j - i"], of S] by auto
    then obtain n where n: "((p ^^ (j - i)) ^^ n) = id" "n > 0"
      using insert(3) by blast
    thus ?case
      using ij(1) nat_0_less_mult_iff zero_less_diff unfolding funpow_mult by metis
  qed
  thus thesis
    using that by blast
qed

lemma permutation_is_nilpotent':
  assumes "permutation p" obtains n where "(p ^^ n) = id" and "n > m"
proof -
  obtain n where "(p ^^ n) = id" and "n > 0"
    using permutation_is_nilpotent[OF assms] by blast
  then obtain k where "n * k > m"
    by (metis dividend_less_times_div mult_Suc_right)
  from \<open>(p ^^ n) = id\<close> have "p ^^ (n * k) = id"
    by (induct k) (simp, metis funpow_mult id_funpow)
  with \<open>n * k > m\<close> show thesis
    using that by blast
qed

subsubsection \<open>Extraction of cycles from permutations\<close>

definition least_power :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> nat"
  where "least_power f x = (LEAST n. (f ^^ n) x = x \<and> n > 0)"

abbreviation support :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a list"
  where "support p x \<equiv> map (\<lambda>i. (p ^^ i) x) [0..< (least_power p x)]"

lemma least_powerI:
  assumes "(f ^^ n) x = x" and "n > 0"
  shows "(f ^^ (least_power f x)) x = x" and "least_power f x > 0"
  using assms unfolding least_power_def by (metis (mono_tags, lifting) LeastI)+

lemma least_power_le:
  assumes "(f ^^ n) x = x" and "n > 0" shows "least_power f x \<le> n"
  using assms unfolding least_power_def by (simp add: Least_le)

lemma least_power_of_permutation:
  assumes "permutation p" shows "(p ^^ (least_power p a)) a = a" and "least_power p a > 0"
  using permutation_is_nilpotent[OF assms] least_powerI by (metis id_apply)+

lemma least_power_gt_one:
  assumes "permutation p" and "p a \<noteq> a" shows "least_power p a > Suc 0"
  using least_power_of_permutation[OF assms(1)] assms(2)
  by (metis Suc_lessI funpow.simps(2) funpow_simps_right(1) o_id)

lemma least_power_minimal:
  assumes "(p ^^ n) a = a" shows "(least_power p a) dvd n"
proof (cases "n = 0", simp)
  let ?lpow = "least_power p"

  assume "n \<noteq> 0" then have "n > 0" by simp
  hence "(p ^^ (?lpow a)) a = a" and "least_power p a > 0"
    using assms unfolding least_power_def by (metis (mono_tags, lifting) LeastI)+
  hence aux_lemma: "(p ^^ ((?lpow a) * k)) a = a" for k :: nat
    by (induct k) (simp_all add: funpow_add)

  have "(p ^^ (n mod ?lpow a)) ((p ^^ (n - (n mod ?lpow a))) a) = (p ^^ n) a"
    by (metis add_diff_inverse_nat funpow_add mod_less_eq_dividend not_less o_apply)
  with \<open>(p ^^ n) a = a\<close> have "(p ^^ (n mod ?lpow a)) a = a"
    using aux_lemma by (simp add: minus_mod_eq_mult_div)
  hence "?lpow a \<le> n mod ?lpow a" if "n mod ?lpow a > 0"
    using least_power_le[OF _ that, of p a] by simp
  with \<open>least_power p a > 0\<close> show "(least_power p a) dvd n"
    using mod_less_divisor not_le by blast
qed

lemma least_power_dvd:
  assumes "permutation p" shows "(least_power p a) dvd n \<longleftrightarrow> (p ^^ n) a = a"
proof
  show "(p ^^ n) a = a \<Longrightarrow> (least_power p a) dvd n"
    using least_power_minimal[of _ p] by simp
next
  have "(p ^^ ((least_power p a) * k)) a = a" for k :: nat
    using least_power_of_permutation(1)[OF assms(1)] by (induct k) (simp_all add: funpow_add)
  thus "(least_power p a) dvd n \<Longrightarrow> (p ^^ n) a = a" by blast
qed

theorem cycle_of_permutation:
  assumes "permutation p" shows "cycle (support p a)"
proof -
  have "(least_power p a) dvd (j - i)" if "i \<le> j" "j < least_power p a" and "(p ^^ i) a = (p ^^ j) a" for i j
    using funpow_diff[OF bij_is_inj that(1,3)] assms by (simp add: permutation least_power_dvd)
  moreover have "i = j" if "i \<le> j" "j < least_power p a" and "(least_power p a) dvd (j - i)" for i j
    using that le_eq_less_or_eq nat_dvd_not_less by auto
  ultimately have "inj_on (\<lambda>i. (p ^^ i) a) {..< (least_power p a)}"
    unfolding inj_on_def by (metis le_cases lessThan_iff)
  thus ?thesis
    by (simp add: atLeast_upt distinct_map)
qed

subsection \<open>Decomposition on Cycles\<close>

text \<open>We show that a permutation can be decomposed on cycles\<close>

subsubsection \<open>Preliminaries\<close>

lemma support_set:
  assumes "permutation p" shows "set (support p a) = range (\<lambda>i. (p ^^ i) a)"
proof
  show "set (support p a) \<subseteq> range (\<lambda>i. (p ^^ i) a)"
    by auto
next
  show "range (\<lambda>i. (p ^^ i) a) \<subseteq> set (support p a)"
  proof (auto)
    fix i
    have "(p ^^ i) a = (p ^^ (i mod (least_power p a))) ((p ^^ (i - (i mod (least_power p a)))) a)"
      by (metis add_diff_inverse_nat funpow_add mod_less_eq_dividend not_le o_apply)
    also have " ... = (p ^^ (i mod (least_power p a))) a"
      using least_power_dvd[OF assms] by (metis dvd_minus_mod)
    also have " ... \<in> (\<lambda>i. (p ^^ i) a) ` {0..< (least_power p a)}"
      using least_power_of_permutation(2)[OF assms] by fastforce
    finally show "(p ^^ i) a \<in> (\<lambda>i. (p ^^ i) a) ` {0..< (least_power p a)}" .
  qed
qed

lemma disjoint_support:
  assumes "permutation p" shows "disjoint (range (\<lambda>a. set (support p a)))" (is "disjoint ?A")
proof (rule disjointI)
  { fix i j a b
    assume "set (support p a) \<inter> set (support p b) \<noteq> {}" have "set (support p a) \<subseteq> set (support p b)"
      unfolding support_set[OF assms]
    proof (auto)
      from \<open>set (support p a) \<inter> set (support p b) \<noteq> {}\<close>
      obtain i j where ij: "(p ^^ i) a = (p ^^ j) b"
        by auto

      fix k
      have "(p ^^ k) a = (p ^^ (k + (least_power p a) * l)) a" for l
        using least_power_dvd[OF assms] by (induct l) (simp, metis dvd_triv_left funpow_add o_def)
      then obtain m where "m \<ge> i" and "(p ^^ m) a = (p ^^ k) a"
        using least_power_of_permutation(2)[OF assms]
        by (metis dividend_less_times_div le_eq_less_or_eq mult_Suc_right trans_less_add2)
      hence "(p ^^ m) a = (p ^^ (m - i)) ((p ^^ i) a)"
        by (metis Nat.le_imp_diff_is_add funpow_add o_apply)
      with \<open>(p ^^ m) a = (p ^^ k) a\<close> have "(p ^^ k) a = (p ^^ ((m - i) + j)) b"
        unfolding ij by (simp add: funpow_add)
      thus "(p ^^ k) a \<in> range (\<lambda>i. (p ^^ i) b)"
        by blast
    qed } note aux_lemma = this

  fix supp_a supp_b
  assume "supp_a \<in> ?A" and "supp_b \<in> ?A"
  then obtain a b where a: "supp_a = set (support p a)" and b: "supp_b = set (support p b)"
    by auto
  assume "supp_a \<noteq> supp_b" thus "supp_a \<inter> supp_b = {}"
    using aux_lemma unfolding a b by blast
qed

lemma disjoint_support':
  assumes "permutation p"
  shows "set (support p a) \<inter> set (support p b) = {} \<longleftrightarrow> a \<notin> set (support p b)"
proof -
  have "a \<in> set (support p a)"
    using least_power_of_permutation(2)[OF assms] by force
  show ?thesis
  proof
    assume "set (support p a) \<inter> set (support p b) = {}"
    with \<open>a \<in> set (support p a)\<close> show "a \<notin> set (support p b)"
      by blast
  next
    assume "a \<notin> set (support p b)" show "set (support p a) \<inter> set (support p b) = {}"
    proof (rule ccontr)
      assume "set (support p a) \<inter> set (support p b) \<noteq> {}"
      hence "set (support p a) = set (support p b)"
        using disjoint_support[OF assms] by (meson UNIV_I disjoint_def image_iff)
      with \<open>a \<in> set (support p a)\<close> and \<open>a \<notin> set (support p b)\<close> show False
        by simp
    qed
  qed
qed

lemma support_coverture:
  assumes "permutation p" shows "\<Union> { set (support p a) | a. p a \<noteq> a } = { a. p a \<noteq> a }"
proof
  show "{ a. p a \<noteq> a } \<subseteq> \<Union> { set (support p a) | a. p a \<noteq> a }"
  proof
    fix a assume "a \<in> { a. p a \<noteq> a }"
    have "a \<in> set (support p a)"
      using least_power_of_permutation(2)[OF assms, of a] by force
    with \<open>a \<in> { a. p a \<noteq> a }\<close> show "a \<in> \<Union> { set (support p a) | a. p a \<noteq> a }"
      by blast
  qed
next
  show "\<Union> { set (support p a) | a. p a \<noteq> a } \<subseteq> { a. p a \<noteq> a }"
  proof
    fix b assume "b \<in> \<Union> { set (support p a) | a. p a \<noteq> a }"
    then obtain a i where "p a \<noteq> a" and "(p ^^ i) a = b"
      by auto
    have "p a = a" if "(p ^^ i) a = (p ^^ Suc i) a"
      using funpow_diff[OF bij_is_inj _ that] assms unfolding permutation by simp
    with \<open>p a \<noteq> a\<close> and \<open>(p ^^ i) a = b\<close> show "b \<in> { a. p a \<noteq> a }"
      by auto
  qed
qed

theorem cycle_restrict:
  assumes "permutation p" and "b \<in> set (support p a)" shows "p b = (cycle_of_list (support p a)) b"
proof -
  note least_power_props [simp] = least_power_of_permutation[OF assms(1)]

  have "map (cycle_of_list (support p a)) (support p a) = rotate1 (support p a)"
    using cyclic_rotation[OF cycle_of_permutation[OF assms(1)], of 1 a] by simp
  hence "map (cycle_of_list (support p a)) (support p a) = tl (support p a) @ [ a ]"
    by (simp add: hd_map rotate1_hd_tl)
  also have " ... = map p (support p a)"
  proof (rule nth_equalityI, auto)
    fix i assume "i < least_power p a" show "(tl (support p a) @ [a]) ! i = p ((p ^^ i) a)"
    proof (cases)
      assume i: "i = least_power p a - 1"
      hence "(tl (support p a) @ [ a ]) ! i = a"
        by (metis (no_types, lifting) diff_zero length_map length_tl length_upt nth_append_length)
      also have " ... = p ((p ^^ i) a)"
        by (metis (mono_tags, hide_lams) least_power_props i Suc_diff_1 funpow_simps_right(2) funpow_swap1 o_apply)
      finally show ?thesis .
    next
      assume "i \<noteq> least_power p a - 1"
      with \<open>i < least_power p a\<close> have "i < least_power p a - 1"
        by simp
      hence "(tl (support p a) @ [ a ]) ! i = (p ^^ (Suc i)) a"
        by (metis One_nat_def Suc_eq_plus1 add.commute length_map length_upt map_tl nth_append nth_map_upt tl_upt)
      thus ?thesis
        by simp
    qed
  qed
  finally have "map (cycle_of_list (support p a)) (support p a) = map p (support p a)" .
  thus ?thesis
    using assms(2) by auto
qed

subsubsection\<open>Decomposition\<close>

inductive cycle_decomp :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where
    empty:  "cycle_decomp {} id"
  | comp: "\<lbrakk> cycle_decomp I p; cycle cs; set cs \<inter> I = {} \<rbrakk> \<Longrightarrow>
             cycle_decomp (set cs \<union> I) ((cycle_of_list cs) \<circ> p)"

lemma semidecomposition:
  assumes "p permutes S" and "finite S"
  shows "(\<lambda>y. if y \<in> (S - set (support p a)) then p y else y) permutes (S - set (support p a))"
proof (rule bij_imp_permutes)
  show "(if b \<in> (S - set (support p a)) then p b else b) = b" if "b \<notin> S - set (support p a)" for b
    using that by auto
next
  have is_permutation: "permutation p"
    using assms unfolding permutation_permutes by blast

  let ?q = "\<lambda>y. if y \<in> (S - set (support p a)) then p y else y"
  show "bij_betw ?q (S - set (support p a)) (S - set (support p a))"
  proof (rule bij_betw_imageI)
    show "inj_on ?q (S - set (support p a))"
      using permutes_inj[OF assms(1)] unfolding inj_on_def by auto
  next
    have aux_lemma: "set (support p s) \<subseteq> (S - set (support p a))" if "s \<in> S - set (support p a)" for s
    proof -
      have "(p ^^ i) s \<in> S" for i
        using that unfolding permutes_in_image[OF permutes_funpow[OF assms(1)]] by simp
      thus ?thesis
        using that disjoint_support'[OF is_permutation, of s a] by auto
    qed
    have "(p ^^ 1) s \<in> set (support p s)" for s
      unfolding support_set[OF is_permutation] by blast
    hence "p s \<in> set (support p s)" for s
      by simp
    hence "p ` (S - set (support p a)) \<subseteq> S - set (support p a)"
      using aux_lemma by blast
    moreover have "(p ^^ ((least_power p s) - 1)) s \<in> set (support p s)" for s
      unfolding support_set[OF is_permutation] by blast
    hence "\<exists>s' \<in> set (support p s). p s' = s" for s
      using least_power_of_permutation[OF is_permutation] by (metis Suc_diff_1 funpow.simps(2) o_apply)
    hence "S - set (support p a) \<subseteq> p ` (S - set (support p a))"
      using aux_lemma by (smt image_iff subsetCE subsetI)
    ultimately show "?q ` (S - set (support p a)) = (S - set (support p a))"
      by auto
  qed
qed

theorem cycle_decomposition:
  assumes "p permutes S" and "finite S" shows "cycle_decomp S p"
  using assms
proof(induct "card S" arbitrary: S p rule: less_induct)
  case less show ?case
  proof (cases)
    assume "S = {}" thus ?thesis
      using empty less(2) by auto
  next
    have is_permutation: "permutation p"
      using less(2-3) unfolding permutation_permutes by blast

    assume "S \<noteq> {}" then obtain s where "s \<in> S"
      by blast
    define q where "q = (\<lambda>y. if y \<in> (S - set (support p s)) then p y else y)"
    have "(cycle_of_list (support p s) \<circ> q) = p"
    proof
      fix a
      consider "a \<in> S - set (support p s)" | "a \<in> set (support p s)" | "a \<notin> S" "a \<notin> set (support p s)"
        by blast
      thus "((cycle_of_list (support p s) \<circ> q)) a = p a"
      proof cases
        case 1
        have "(p ^^ 1) a \<in> set (support p a)"
          unfolding support_set[OF is_permutation] by blast
        with \<open>a \<in> S - set (support p s)\<close> have "p a \<notin> set (support p s)"
          using disjoint_support'[OF is_permutation, of a s] by auto
        with \<open>a \<in> S - set (support p s)\<close> show ?thesis
          using id_outside_supp[of _ "support p s"] unfolding q_def by simp
      next
        case 2 thus ?thesis
          using cycle_restrict[OF is_permutation] unfolding q_def by simp
      next
        case 3 thus ?thesis
          using id_outside_supp[OF 3(2)] less(2) permutes_not_in unfolding q_def by fastforce
      qed
    qed

    moreover from \<open>s \<in> S\<close> have "(p ^^ i) s \<in> S" for i
      unfolding permutes_in_image[OF permutes_funpow[OF less(2)]] .
    hence "set (support p s) \<union> (S - set (support p s)) = S"
      by auto

    moreover have "s \<in> set (support p s)"
      using least_power_of_permutation[OF is_permutation] by force
    with \<open>s \<in> S\<close> have "card (S - set (support p s)) < card S"
      using less(3) by (metis DiffE card_seteq linorder_not_le subsetI)
    hence "cycle_decomp (S - set (support p s)) q"
      using less(1)[OF _ semidecomposition[OF less(2-3)], of s] less(3) unfolding q_def by blast

    moreover show ?thesis
      using comp[OF calculation(3) cycle_of_permutation[OF is_permutation], of s]
      unfolding calculation(1-2) by blast
  qed
qed

end


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
section \<open>Auxiliary Results\<close>

subsection \<open>Reflexive Transitive Closures of Orders\<close>

theory Transitive_Closure_More
  imports Main
begin

lemma (in order) rtranclp_less_eq [simp]:
  "(\<le>)\<^sup>*\<^sup>* = (\<le>)"
  by (intro ext) (auto elim: rtranclp_induct)

lemma (in order) tranclp_less [simp]:
  "(<)\<^sup>+\<^sup>+ = (<)"
  by (intro ext) (auto elim: tranclp_induct)

lemma (in order) rtranclp_greater_eq [simp]:
  "(\<ge>)\<^sup>*\<^sup>* = (\<ge>)"
  by (intro ext) (auto elim: rtranclp_induct)

lemma (in order) tranclp_greater [simp]:
  "(>)\<^sup>+\<^sup>+ = (>)"
  by (intro ext) (auto elim: tranclp_induct)

end