(*  Author:  Sébastien Gouëzel   sebastien.gouezel@univ-rennes1.fr
    License: BSD
*)

section \<open>Ergodicity\<close>

theory Ergodicity
  imports Invariants
begin

text \<open>A transformation is \emph{ergodic} if any invariant set has zero measure or full measure.
Ergodic transformations are, in a sense, extremal among measure preserving transformations.
Hence, any transformation can be seen as an average of ergodic ones. This can be made precise
by the notion of ergodic decomposition, only valid on standard measure spaces.

Many statements get nicer in the ergodic case, hence we will reformulate many
of the previous results in this setting.\<close>

subsection \<open>Ergodicity locales\<close>

locale ergodic_qmpt = qmpt +
  assumes ergodic: "\<And>A. A \<in> sets Invariants \<Longrightarrow> (A \<in> null_sets M \<or> space M - A \<in> null_sets M)"

locale ergodic_mpt = mpt + ergodic_qmpt

locale ergodic_fmpt = ergodic_qmpt + fmpt

locale ergodic_pmpt = ergodic_qmpt + pmpt

locale ergodic_conservative = ergodic_qmpt + conservative

locale ergodic_conservative_mpt = ergodic_qmpt + conservative_mpt

sublocale ergodic_fmpt \<subseteq> ergodic_mpt
  by unfold_locales

sublocale ergodic_pmpt \<subseteq> ergodic_fmpt
  by unfold_locales

sublocale ergodic_fmpt \<subseteq> ergodic_conservative_mpt
  by unfold_locales

sublocale ergodic_conservative_mpt \<subseteq> ergodic_conservative
  by unfold_locales

subsection \<open>Behavior of sets in ergodic transformations\<close>

text \<open>The main property of an ergodic transformation, essentially equivalent to the definition,
is that a set which is almost invariant under the dynamics is null or conull.\<close>

lemma (in ergodic_qmpt) AE_equal_preimage_then_null_or_conull:
  assumes [measurable]: "A \<in> sets M" and "A \<Delta> T--`A \<in> null_sets M"
  shows "A \<in> null_sets M \<or> space M - A \<in> null_sets M"
proof -
  obtain B where B: "B \<in> sets Invariants" "A \<Delta> B \<in> null_sets M"
    by (metis Un_commute Invariants_quasi_Invariants_sets[OF assms(1)] assms(2))
  have [measurable]: "B \<in> sets M" using B(1) using Invariants_in_sets by blast
  have *: "B \<in> null_sets M \<or> space M - B \<in> null_sets M" using ergodic B(1) by blast
  show ?thesis
  proof (cases)
    assume "B \<in> null_sets M"
    then have "A \<in> null_sets M" by (metis Un_commute B(2) Delta_null_of_null_is_null[OF assms(1), where ?A = B])
    then show ?thesis by simp
  next
    assume "\<not>(B \<in> null_sets M)"
    then have i: "space M - B \<in> null_sets M" using * by simp
    have "(space M - B) \<Delta> (space M - A) = A \<Delta> B"
      using sets.sets_into_space[OF \<open>A \<in> sets M\<close>] sets.sets_into_space[OF \<open>B \<in> sets M\<close>] by blast
    then have "(space M - B) \<Delta> (space M - A) \<in> null_sets M" using B(2) by auto
    then have "space M - A \<in> null_sets M"
      using Delta_null_of_null_is_null[where ?A = "space M - B" and ?B = "space M - A"] i by auto
    then show ?thesis by simp
  qed
qed

text \<open>The inverse of an ergodic transformation is also ergodic.\<close>

lemma (in ergodic_qmpt) ergodic_Tinv:
  assumes "invertible_qmpt"
  shows "ergodic_qmpt M Tinv"
unfolding ergodic_qmpt_def ergodic_qmpt_axioms_def
proof
  show "qmpt M Tinv" using Tinv_qmpt[OF assms] by simp
  show "\<forall>A. A \<in> sets (qmpt.Invariants M Tinv) \<longrightarrow> A \<in> null_sets M \<or> space M - A \<in> null_sets M"
  proof (intro allI impI)
    fix A assume "A \<in> sets (qmpt.Invariants M Tinv)"
    then have "A \<in> sets Invariants" using Invariants_Tinv[OF assms] by simp
    then show "A \<in> null_sets M \<or> space M - A \<in> null_sets M" using ergodic by auto
  qed
qed

text \<open>In the conservative case, instead of the almost invariance of a set, it suffices to
assume that the preimage is contained in the set, or contains the set, to deduce that it is null
or conull.\<close>

lemma (in ergodic_conservative) preimage_included_then_null_or_conull:
  assumes "A \<in> sets M" "T--`A \<subseteq> A"
  shows "A \<in> null_sets M \<or> space M - A \<in> null_sets M"
proof -
  have "A \<Delta> T--`A \<in> null_sets M" using preimage_included_then_almost_invariant[OF assms] by auto
  then show ?thesis using AE_equal_preimage_then_null_or_conull assms(1) by auto
qed

lemma (in ergodic_conservative) preimage_includes_then_null_or_conull:
  assumes "A \<in> sets M" "T--`A \<supseteq> A"
  shows "A \<in> null_sets M \<or> space M - A \<in> null_sets M"
proof -
  have "A \<Delta> T--`A \<in> null_sets M" using preimage_includes_then_almost_invariant[OF assms] by auto
  then show ?thesis using AE_equal_preimage_then_null_or_conull assms(1) by auto
qed

lemma (in ergodic_conservative) preimages_conull:
  assumes [measurable]: "A \<in> sets M" and "emeasure M A > 0"
  shows "space M - (\<Union>n. (T^^n)--`A) \<in> null_sets M"
        "space M \<Delta> (\<Union>n. (T^^n)--`A) \<in> null_sets M"
proof -
  define B where "B = (\<Union>n. (T^^n)--`A)"
  then have [measurable]: "B \<in> sets M" by auto
  have "T--`B = (\<Union>n. (T^^(n+1))--`A)" unfolding B_def using T_vrestr_composed(2) by auto
  then have "T--`B \<subseteq> B" using B_def by blast
  then have *: "B \<in> null_sets M \<or> space M - B \<in> null_sets M"
    using preimage_included_then_null_or_conull by auto
  have "A \<subseteq> B" unfolding B_def using T_vrestr_0 assms(1) by blast
  then have "emeasure M B > 0" using assms(2)
    by (metis \<open>B \<in> sets M\<close> emeasure_eq_0 zero_less_iff_neq_zero)
  then have "B \<notin> null_sets M" by auto
  then have i: "space M - B \<in> null_sets M" using * by auto
  then show "space M - (\<Union>n. (T^^n)--`A) \<in> null_sets M" using B_def by auto

  have "B \<subseteq> space M" using sets.sets_into_space[OF \<open>B \<in> sets M\<close>] by auto
  then have "space M \<Delta> B \<in> null_sets M" using i by (simp add: Diff_mono sup.absorb1)
  then show "space M \<Delta> (\<Union>n. (T^^n)--`A) \<in> null_sets M" using B_def by auto
qed

subsection \<open>Behavior of functions in ergodic transformations\<close>

text \<open>In the same way that invariant sets are null or conull, invariant functions are almost
everywhere constant in an ergodic transformation. For real functions, one can consider
the set where $\{f x \geq d \}$, it has measure $0$ or $1$ depending on $d$.
Then $f$ is almost surely equal to the maximal $d$ such that this set has measure $1$. For functions
taking values in a general space, the argument is essentially the same, replacing intervals by
a basis of the topology.\<close>

lemma (in ergodic_qmpt) Invariant_func_is_AE_constant:
  fixes f::"_\<Rightarrow> 'b::{second_countable_topology, t1_space}"
  assumes "f \<in> borel_measurable Invariants"
  shows "\<exists>y. AE x in M. f x = y"
proof (cases)
  assume "space M \<in> null_sets M"
  obtain y::'b where "True" by auto
  have "AE x in M. f x = y" using \<open>space M \<in> null_sets M\<close> AE_I' by blast
  then show ?thesis by auto
next
  assume *: "\<not>(space M \<in> null_sets M)"
  obtain B::"'b set set" where B: "countable B" "topological_basis B" using ex_countable_basis by auto
  define C where "C = {b \<in> B. space M - f-`b \<in> null_sets M}"
  then have "countable C" using \<open>countable B\<close> by auto
  define Y where "Y = \<Inter> C"
  have "space M - f-`Y = (\<Union> b\<in> C. space M - f-`b)" unfolding Y_def by auto
  moreover have "\<And>b. b \<in> C \<Longrightarrow> space M - f-`b \<in> null_sets M" unfolding C_def by blast
  ultimately have i: "space M - f-`Y \<in> null_sets M" using \<open>countable C\<close> by (metis null_sets_UN')
  then have "f-`Y \<noteq> {}" using * by auto
  then have "Y \<noteq> {}" by auto
  then obtain y where "y \<in> Y" by auto
  define D where "D = {b \<in> B. y\<notin>b \<and> f-`b \<inter> space M \<in> null_sets M}"
  have "countable D" using \<open>countable B\<close> D_def by auto
  {
    fix z assume "z \<noteq> y"
    obtain U where U: "open U" "z \<in> U" "y \<notin> U"
      using t1_space[OF \<open>z \<noteq> y\<close>] by blast
    obtain V where "V \<in> B" "V \<subseteq> U" "z \<in> V" by (rule topological_basisE[OF \<open>topological_basis B\<close> \<open>open U\<close> \<open>z \<in> U\<close>])
    then have "y \<notin> V" using U by blast
    then have "V \<notin> C" using \<open>y \<in> Y\<close> Y_def by auto
    then have "space M - f-`V \<inter> space M \<notin> null_sets M" unfolding C_def using \<open>V \<in> B\<close>
      by (metis (no_types, lifting) Diff_Int2 inf.idem mem_Collect_eq)
    moreover have "f-`V \<inter> space M \<in> sets Invariants"
      using measurable_sets[OF assms borel_open[OF topological_basis_open[OF B(2) \<open>V \<in> B\<close>]]] subalgebra_def Invariants_is_subalg by metis
    ultimately have "f-`V \<inter> space M \<in> null_sets M" using ergodic by auto
    then have "V \<in> D" unfolding D_def using \<open>V \<in> B\<close> \<open>y \<notin> V\<close> by auto
    then have "\<exists>b \<in> D. z \<in> b" using \<open>z \<in> V\<close> by auto
  }
  then have *: "\<Union>D = UNIV - {y}"
    apply auto unfolding D_def by auto
  have "space M - f-`{y} = f-`(UNIV -{y}) \<inter> space M" by blast
  also have "... = (\<Union>b\<in>D. f-`b \<inter> space M)" using * by auto
  also have "... \<in> null_sets M" using D_def \<open>countable D\<close>
    by (metis (no_types, lifting) mem_Collect_eq null_sets_UN')
  finally have "space M - f-`{y} \<in> null_sets M" by blast
  with AE_not_in[OF this] have "AE x in M. x \<in> f-`{y}" by auto
  then show ?thesis by auto
qed

text \<open>The same goes for functions which are only almost invariant, as they coindice almost
everywhere with genuine invariant functions.\<close>

lemma (in ergodic_qmpt) AE_Invariant_func_is_AE_constant:
  fixes f::"_ \<Rightarrow> 'b::{second_countable_topology, t2_space}"
  assumes "f \<in> borel_measurable M" "AE x in M. f(T x) = f x"
  shows "\<exists>y. AE x in M. f x = y"
proof -
  obtain g where g: "g \<in> borel_measurable Invariants" "AE x in M. f x = g x"
    using Invariants_quasi_Invariants_functions[OF assms(1)] assms(2) by auto
  then obtain y where y: "AE x in M. g x = y" using Invariant_func_is_AE_constant by auto
  have "AE x in M. f x = y" using g(2) y by auto
  then show ?thesis by auto
qed

text \<open>In conservative systems, it suffices to have an inequality between $f$ and $f \circ T$,
since such a function is almost invariant.\<close>

lemma (in ergodic_conservative) AE_decreasing_func_is_AE_constant:
  fixes f::"_ \<Rightarrow> 'b::{linorder_topology, second_countable_topology}"
  assumes "AE x in M. f(T x) \<le> f x"
    and [measurable]: "f \<in> borel_measurable M"
  shows "\<exists>y. AE x in M. f x = y"
proof -
  have "AE x in M. f(T x) = f x" using AE_decreasing_then_invariant[OF assms] by auto
  then show ?thesis using AE_Invariant_func_is_AE_constant[OF assms(2)] by auto
qed

lemma (in ergodic_conservative) AE_increasing_func_is_AE_constant:
  fixes f::"_ \<Rightarrow> 'b::{linorder_topology, second_countable_topology}"
  assumes "AE x in M. f(T x) \<ge> f x"
    and [measurable]: "f \<in> borel_measurable M"
  shows "\<exists>y. AE x in M. f x = y"
proof -
  have "AE x in M. f(T x) = f x" using AE_increasing_then_invariant[OF assms] by auto
  then show ?thesis using AE_Invariant_func_is_AE_constant[OF assms(2)] by auto
qed

text \<open>When the function takes values in a Banach space, the value of the invariant (hence constant)
function can be recovered by integrating the function.\<close>

lemma (in ergodic_fmpt) Invariant_func_integral:
  fixes f::"_ \<Rightarrow> 'b::{banach, second_countable_topology}"
  assumes [measurable]: "f \<in> borel_measurable Invariants"
  shows "integrable M f"
        "AE x in M. f x = (\<integral>x. f x \<partial>M)/\<^sub>R (measure M (space M))"
proof -
  have [measurable]: "f \<in> borel_measurable M" using assms Invariants_measurable_func by blast
  obtain y where y: "AE x in M. f x = y" using Invariant_func_is_AE_constant[OF assms] by auto
  moreover have "integrable M (\<lambda>x. y)" by auto
  ultimately show "integrable M f" by (subst integrable_cong_AE[where ?g = "\<lambda>x. y"], auto)

  have "(\<integral>x. f x \<partial>M) = (\<integral>x. y \<partial>M)" by (subst integral_cong_AE[where ?g = "\<lambda>x. y"], auto simp add: y)
  also have "... = measure M (space M) *\<^sub>R y" by auto
  finally have *: "(\<integral>x. f x \<partial>M) = measure M (space M) *\<^sub>R y" by simp
  show "AE x in M. f x = (\<integral>x. f x \<partial>M)/\<^sub>R (measure M (space M))"
  proof (cases)
    assume "emeasure M (space M) = 0"
    then have "space M \<in> null_sets M" by auto
    then show ?thesis using AE_I' by blast
  next
    assume "\<not>(emeasure M (space M) = 0)"
    then have "measure M (space M) > 0" using emeasure_eq_measure measure_le_0_iff by fastforce
    then have "y = (\<integral>x. f x \<partial>M)/\<^sub>R (measure M (space M))" using * by auto
    then show ?thesis using y by auto
  qed
qed

text \<open>As the conditional expectation of a function and the original function have the same
integral, it follows that the conditional expectation of a function with respect to the
invariant sigma algebra is given by the average of the function.\<close>

lemma (in ergodic_fmpt) Invariants_cond_exp_is_integral_fmpt:
  fixes f::"_ \<Rightarrow> real"
  assumes "integrable M f"
  shows "AE x in M. real_cond_exp M Invariants f x = (\<integral>x. f x \<partial>M) / measure M (space M)"
proof -
  have "AE x in M. real_cond_exp M Invariants f x = (\<integral>x. real_cond_exp M Invariants f x \<partial>M)/\<^sub>R (measure M (space M))"
    by (rule Invariant_func_integral(2), simp add: borel_measurable_cond_exp)
  moreover have "(\<integral>x. real_cond_exp M Invariants f x \<partial>M) = (\<integral>x. f x \<partial>M)"
    by (simp add: assms real_cond_exp_int(2))
  ultimately show ?thesis by (simp add: divide_real_def mult.commute)
qed

lemma (in ergodic_pmpt) Invariants_cond_exp_is_integral:
  fixes f::"_ \<Rightarrow> real"
  assumes "integrable M f"
  shows "AE x in M. real_cond_exp M Invariants f x = (\<integral>x. f x \<partial>M)"
by (metis div_by_1 prob_space Invariants_cond_exp_is_integral_fmpt[OF assms])

subsection \<open>Kac formula\<close>

text \<open>We reformulate the different versions of Kac formula. They simplify as, for any set $A$
with positive measure, the union $\bigcup T^{-n} A$ (which appears in all these statements)
almost coincides with the whole space.\<close>

lemma (in ergodic_conservative_mpt) local_time_unbounded:
  assumes [measurable]: "A \<in> sets M" "B \<in> sets M"
      and "emeasure M A < \<infinity>" "emeasure M B > 0"
  shows "(\<lambda>n. emeasure M {x \<in> (T^^n)--`A. local_time B n x < k}) \<longlonglongrightarrow> 0"
proof (rule local_time_unbounded3)
  have "A - (\<Union>i. (T ^^ i) --` B) \<in> sets M" by auto
  moreover have "A - (\<Union>i. (T ^^ i) --` B) \<subseteq> space M - (\<Union>i. (T ^^ i) --` B)" using sets.sets_into_space[OF assms(1)] by blast
  ultimately show "A - (\<Union>i. (T ^^ i) --` B) \<in> null_sets M" by (metis null_sets_subset preimages_conull(1)[OF assms(2) assms(4)])
  show "emeasure M A < \<infinity>" using assms(3) by simp
qed (simp_all add: assms)

theorem (in ergodic_conservative_mpt) kac_formula:
  assumes [measurable]: "A \<in> sets M" and "emeasure M A > 0"
  shows "(\<integral>\<^sup>+y. return_time_function A y \<partial>M) = emeasure M (space M)"
proof -
  have a [measurable]: "(\<Union>n. (T^^n)--`A) \<in> sets M" by auto
  then have "space M = (\<Union>n. (T^^n)--`A) \<union> (space M - (\<Union>n. (T^^n)--`A))" using sets.sets_into_space by blast
  then have "emeasure M (space M) = emeasure M (\<Union>n. (T^^n)--`A)"
    by (metis a preimages_conull(1)[OF assms] emeasure_Un_null_set)
  moreover have "(\<integral>\<^sup>+y. return_time_function A y \<partial>M) = emeasure M (\<Union>n. (T^^n)--`A)"
    using kac_formula_nonergodic[OF assms(1)] by simp
  ultimately show ?thesis by simp
qed

lemma (in ergodic_conservative_mpt) induced_function_integral:
  fixes f::"'a \<Rightarrow> real"
  assumes [measurable]: "A \<in> sets M" "integrable M f" and "emeasure M A > 0"
  shows "integrable M (induced_function A f)"
        "(\<integral>y. induced_function A f y \<partial>M) = (\<integral> x. f x \<partial>M)"
proof -
  show "integrable M (induced_function A f)"
    using induced_function_integral_nonergodic(1)[OF assms(1) assms(2)] by auto
  have "(\<integral>y. induced_function A f y \<partial>M) = (\<integral> x \<in> (\<Union>n. (T^^n)--`A). f x \<partial>M)"
    using induced_function_integral_nonergodic(2)[OF assms(1) assms(2)] by auto
  also have "... = (\<integral> x \<in> space M. f x \<partial>M)"
    using set_integral_null_delta[OF assms(2), where ?A = "space M" and ?B = "(\<Union>n. (T^^n)--`A)"]
    preimages_conull(2)[OF assms(1) assms(3)] by auto
  also have "... = (\<integral> x. f x \<partial>M)" using set_integral_space[OF assms(2)] by auto
  finally show "(\<integral>y. induced_function A f y \<partial>M) = (\<integral> x. f x \<partial>M)" by simp
qed

lemma (in ergodic_conservative_mpt) induced_function_integral_restr:
  fixes f::"'a \<Rightarrow> real"
  assumes [measurable]: "A \<in> sets M" "integrable M f" and "emeasure M A > 0"
  shows "integrable (restrict_space M A) (induced_function A f)"
        "(\<integral>y. induced_function A f y \<partial>(restrict_space M A)) = (\<integral> x. f x \<partial>M)"
proof -
  show "integrable (restrict_space M A) (induced_function A f)"
    using induced_function_integral_restr_nonergodic(1)[OF assms(1) assms(2)] by auto
  have "(\<integral>y. induced_function A f y \<partial>(restrict_space M A)) = (\<integral> x \<in> (\<Union>n. (T^^n)--`A). f x \<partial>M)"
    using induced_function_integral_restr_nonergodic(2)[OF assms(1) assms(2)] by auto
  also have "... = (\<integral> x \<in> space M. f x \<partial>M)"
    using set_integral_null_delta[OF assms(2), where ?A = "space M" and ?B = "(\<Union>n. (T^^n)--`A)"]
    preimages_conull(2)[OF assms(1) assms(3)] by auto
  also have "... = (\<integral> x. f x \<partial>M)" using set_integral_space[OF assms(2)] by auto
  finally show "(\<integral>y. induced_function A f y \<partial>(restrict_space M A)) = (\<integral> x. f x \<partial>M)" by simp
qed

subsection \<open>Birkhoff theorem\<close>

text \<open>The general versions of Birkhoff theorem are formulated in terms of conditional expectations.
In ergodic probability measure preserving transformations (the most common setting), they
reduce to simpler versions that we state now, as the conditional expectations are simply the
averages of the functions.\<close>

theorem (in ergodic_pmpt) birkhoff_theorem_AE:
  fixes f::"'a \<Rightarrow> real"
  assumes "integrable M f"
  shows "AE x in M. (\<lambda>n. birkhoff_sum f n x / n) \<longlonglongrightarrow> (\<integral> x. f x \<partial>M)"
proof -
  have "AE x in M. (\<lambda>n. birkhoff_sum f n x / n) \<longlonglongrightarrow> real_cond_exp M Invariants f x"
    using birkhoff_theorem_AE_nonergodic[OF assms] by simp
  moreover have "AE x in M. real_cond_exp M Invariants f x = (\<integral> x. f x \<partial>M)"
    using Invariants_cond_exp_is_integral[OF assms] by auto
  ultimately show ?thesis by auto
qed

theorem (in ergodic_pmpt) birkhoff_sum_small_asymp_pos:
  fixes f::"'a \<Rightarrow> real"
  assumes [measurable]: "integrable M f" and "e>0"
  shows "AE x in M. infinite {n. birkhoff_sum f n x \<in> {n * (\<integral>x. f x \<partial>M) .. n * (\<integral>x. f x \<partial>M) + e}}"
proof -
  have "AE x in M. infinite {n. birkhoff_sum f n x \<in> {n * real_cond_exp M Invariants f x .. n * real_cond_exp M Invariants f x + e}}"
    using birkhoff_sum_small_asymp_pos_nonergodic[OF assms] by simp
  moreover have "AE x in M. real_cond_exp M Invariants f x = (\<integral>x. f x \<partial>M)"
    using Invariants_cond_exp_is_integral[OF assms(1)] by auto
  ultimately show ?thesis by auto
qed

theorem (in ergodic_pmpt) birkhoff_sum_small_asymp_neg:
  fixes f::"'a \<Rightarrow> real"
  assumes [measurable]: "integrable M f" and "e>0"
  shows "AE x in M. infinite {n. birkhoff_sum f n x \<in> {n * (\<integral>x. f x \<partial>M) - e .. n * (\<integral>x. f x \<partial>M)}}"
proof -
  have "AE x in M. infinite {n. birkhoff_sum f n x \<in> {n * real_cond_exp M Invariants f x - e .. n * real_cond_exp M Invariants f x}}"
    using birkhoff_sum_small_asymp_neg_nonergodic[OF assms] by simp
  moreover have "AE x in M. real_cond_exp M Invariants f x = (\<integral>x. f x \<partial>M)"
    using Invariants_cond_exp_is_integral[OF assms(1)] by auto
  ultimately show ?thesis by auto
qed

lemma (in ergodic_pmpt) birkhoff_positive_average:
      fixes f::"'a \<Rightarrow> real"
  assumes [measurable]: "integrable M f" and "AE x in M. (\<lambda>n. birkhoff_sum f n x) \<longlonglongrightarrow> \<infinity>"
  shows "(\<integral> x. f x \<partial>M) > 0"
proof (rule ccontr)
  assume "\<not>((\<integral> x. f x \<partial>M) > 0)"
  then have *: "(\<integral> x. f x \<partial>M) \<le> 0" by simp

  have "AE x in M. (\<lambda>n. birkhoff_sum f n x) \<longlonglongrightarrow> \<infinity> \<and> infinite {n. birkhoff_sum f n x \<in> {n * (\<integral>x. f x \<partial>M) - 1 .. n* (\<integral>x. f x \<partial>M)}}"
    using assms(2) birkhoff_sum_small_asymp_neg[OF assms(1)] by auto
  then obtain x where x: "(\<lambda>n. birkhoff_sum f n x) \<longlonglongrightarrow> \<infinity>" "infinite {n. birkhoff_sum f n x \<in> {n * (\<integral>x. f x \<partial>M) - 1 .. n* (\<integral>x. f x \<partial>M)}}"
    using AE_False eventually_elim2 by blast
  {
    fix n assume "birkhoff_sum f n x \<in> {n * (\<integral>x. f x \<partial>M) - 1 .. n * (\<integral>x. f x \<partial>M)}"
    then have "birkhoff_sum f n x \<le> n * (\<integral>x. f x \<partial>M)" by simp
    also have "... \<le> 0" using * by (simp add: mult_nonneg_nonpos)
    finally have "birkhoff_sum f n x \<le> 0" by simp
  }
  then have "{n. birkhoff_sum f n x \<in> {n * (\<integral>x. f x \<partial>M) - 1 .. n* (\<integral>x. f x \<partial>M)}} \<subseteq> {n. birkhoff_sum f n x \<le> 0}" by auto
  then have inf: "infinite {n. birkhoff_sum f n x \<le> 0}" using x(2) finite_subset by blast

  have "0 < (\<infinity>::ereal)" by auto
  then have "eventually (\<lambda>n. birkhoff_sum f n x > (0::ereal)) sequentially" using x(1) order_tendsto_iff by metis
  then obtain N where "\<And>n. n \<ge> N \<Longrightarrow> birkhoff_sum f n x > (0::ereal)" by (meson eventually_at_top_linorder)
  then have "\<And>n. n \<ge> N \<Longrightarrow> birkhoff_sum f n x > 0" by auto
  then have "{n. birkhoff_sum f n x \<le> 0} \<subseteq> {..<N}" by (metis (mono_tags, lifting) lessThan_iff linorder_not_less mem_Collect_eq subsetI)
  then have "finite {n. birkhoff_sum f n x \<le> 0}" using finite_nat_iff_bounded by blast

  then show "False" using inf by simp
qed

lemma (in ergodic_pmpt) birkhoff_negative_average:
      fixes f::"'a \<Rightarrow> real"
  assumes [measurable]: "integrable M f" and "AE x in M. (\<lambda>n. birkhoff_sum f n x) \<longlonglongrightarrow> -\<infinity>"
  shows "(\<integral> x. f x \<partial>M) < 0"
proof (rule ccontr)
  assume "\<not>((\<integral> x. f x \<partial>M) < 0)"
  then have *: "(\<integral> x. f x \<partial>M) \<ge> 0" by simp

  have "AE x in M. (\<lambda>n. birkhoff_sum f n x) \<longlonglongrightarrow> -\<infinity> \<and> infinite {n. birkhoff_sum f n x \<in> {n * (\<integral>x. f x \<partial>M) .. n* (\<integral>x. f x \<partial>M) + 1}}"
    using assms(2) birkhoff_sum_small_asymp_pos[OF assms(1)] by auto
  then obtain x where x: "(\<lambda>n. birkhoff_sum f n x) \<longlonglongrightarrow> -\<infinity>" "infinite {n. birkhoff_sum f n x \<in> {n * (\<integral>x. f x \<partial>M) .. n* (\<integral>x. f x \<partial>M) + 1}}"
    using AE_False eventually_elim2 by blast
  {
    fix n assume "birkhoff_sum f n x \<in> {n * (\<integral>x. f x \<partial>M) .. n * (\<integral>x. f x \<partial>M) + 1}"
    then have "birkhoff_sum f n x \<ge> n * (\<integral>x. f x \<partial>M)" by simp
    moreover have "n * (\<integral>x. f x \<partial>M) \<ge> 0" using * by simp
    ultimately have "birkhoff_sum f n x \<ge> 0" by simp
  }
  then have "{n. birkhoff_sum f n x \<in> {n * (\<integral>x. f x \<partial>M) .. n* (\<integral>x. f x \<partial>M) + 1}} \<subseteq> {n. birkhoff_sum f n x \<ge> 0}" by auto
  then have inf: "infinite {n. birkhoff_sum f n x \<ge> 0}" using x(2) finite_subset by blast

  have "0 > (-\<infinity>::ereal)" by auto
  then have "eventually (\<lambda>n. birkhoff_sum f n x < (0::ereal)) sequentially" using x(1) order_tendsto_iff by metis
  then obtain N where "\<And>n. n \<ge> N \<Longrightarrow> birkhoff_sum f n x < (0::ereal)" by (meson eventually_at_top_linorder)
  then have "\<And>n. n \<ge> N \<Longrightarrow> birkhoff_sum f n x < 0" by auto
  then have "{n. birkhoff_sum f n x \<ge> 0} \<subseteq> {..<N}" by (metis (mono_tags, lifting) lessThan_iff linorder_not_less mem_Collect_eq subsetI)
  then have "finite {n. birkhoff_sum f n x \<ge> 0}" using finite_nat_iff_bounded by blast

  then show "False" using inf by simp
qed

lemma (in ergodic_pmpt) birkhoff_nonzero_average:
      fixes f::"'a \<Rightarrow> real"
  assumes [measurable]: "integrable M f" and "AE x in M. (\<lambda>n. abs(birkhoff_sum f n x)) \<longlonglongrightarrow> \<infinity>"
  shows "(\<integral> x. f x \<partial>M) \<noteq> 0"
proof (rule ccontr)
  assume "\<not>((\<integral> x. f x \<partial>M) \<noteq> 0)"
  then have *: "(\<integral> x. f x \<partial>M) = 0" by simp

  have "AE x in M. (\<lambda>n. abs(birkhoff_sum f n x)) \<longlonglongrightarrow> \<infinity> \<and> infinite {n. birkhoff_sum f n x \<in> {0 .. 1}}"
    using assms(2) birkhoff_sum_small_asymp_pos[OF assms(1)] * by auto
  then obtain x where x: "(\<lambda>n. abs(birkhoff_sum f n x)) \<longlonglongrightarrow> \<infinity>" "infinite {n. birkhoff_sum f n x \<in> {0 .. 1}}"
    using AE_False eventually_elim2 by blast

  have "1 < (\<infinity>::ereal)" by auto
  then have "eventually (\<lambda>n. abs(birkhoff_sum f n x) > (1::ereal)) sequentially" using x(1) order_tendsto_iff by metis
  then obtain N where "\<And>n. n \<ge> N \<Longrightarrow> abs(birkhoff_sum f n x) > (1::ereal)" by (meson eventually_at_top_linorder)
  then have *: "\<And>n. n \<ge> N \<Longrightarrow> abs(birkhoff_sum f n x) > 1" by auto
  have "{n. birkhoff_sum f n x \<in> {0..1}} \<subseteq> {..<N}" by (auto, metis (full_types) * abs_of_nonneg not_less)
  then have "finite {n. birkhoff_sum f n x \<in> {0..1}}" using finite_nat_iff_bounded by blast

  then show "False" using x(2) by simp
qed

end (*of Ergodicity.thy*)


(*  Title:      HOL/Datatype_Examples/TreeFsetI.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Finitely branching possibly infinite trees, with sets of children.
*)

section {* Finitely Branching Possibly Infinite Trees, with Sets of Children *}

theory TreeFsetI
imports "~~/src/HOL/Library/FSet"
begin

codatatype 'a treeFsetI = Tree (lab: 'a) (sub: "'a treeFsetI fset")

(* tree map (contrived example): *)
primcorec tmap where
"lab (tmap f t) = f (lab t)" |
"sub (tmap f t) = fimage (tmap f) (sub t)"

lemma "tmap (f o g) x = tmap f (tmap g x)"
  by (coinduction arbitrary: x) (auto simp: rel_fset_alt)

end


theory PointedSetFactorization
  imports Main
          PointedSet

begin

locale pointed_set_factorization =
  S: set_category S +
  F: "functor" C S F
  for S :: "'s comp"
  and C :: "'c comp"
  and F :: "'c \<Rightarrow> 's"
  and basepoint :: "'c \<Rightarrow> 's" +
assumes pointed_obj : "\<And>c. F.A.ide c \<Longrightarrow> pointed_set.Obj' ((basepoint c) , S.set (F c))"
  and pointed_arr : "\<And>c. F.A.arr c \<Longrightarrow> S.Fun (F c) (basepoint (F.A.dom c)) = basepoint (F.A.cod c)"
begin

interpretation P : pointed_set.
interpretation PC : category P.pointed_set_comp
  using P.is_category.

definition FOb where
  "FOb c = (basepoint c, S.set (F c))"

definition map where
  "map = MkFunctor C P.pointed_set_comp
         (\<lambda>c. Some (S.Fun (F c) , FOb (F.A.dom c) , FOb (F.A.cod c) ))"

lemma is_functor: "functor C P.pointed_set_comp map"
  unfolding functor_def
  apply (simp add: F.A.category_axioms P.is_category)
  unfolding functor_axioms_def
  apply auto
      apply (simp add: map_def)
proof-
  show arr: "\<And>f. F.A.arr f \<Longrightarrow> PC.arr (local.map f)"
    unfolding map_def apply simp
    unfolding P.arr_char apply simp
    unfolding P.Arr'_def apply auto
  proof-
    fix f
    assume arr_f : "F.A.arr f"
    show "setcat.Arr (S.Fun (F f), snd (FOb (F.A.dom f)), snd (FOb (F.A.cod f)))"
      unfolding FOb_def apply simp
      unfolding setcat.Arr_def
      using S.Fun_mapsto [OF F.preserves_arr [OF arr_f]]
      unfolding F.preserves_dom [OF arr_f]
      unfolding F.preserves_cod [OF arr_f]
      by simp
    show "P.Obj' (FOb (F.A.dom f))"
      unfolding FOb_def
      apply (rule_tac pointed_obj)
      using F.A.ide_dom [OF arr_f].
    show "P.Obj' (FOb (F.A.cod f))"
      unfolding FOb_def
      apply (rule_tac pointed_obj)
      using F.A.ide_cod [OF arr_f].
    show "S.Fun (F f) (fst (FOb (F.A.dom f))) = fst (FOb (F.A.cod f))"
      unfolding FOb_def apply simp
      using pointed_arr [OF arr_f].
  qed
  show dom : "\<And>f. F.A.arr f \<Longrightarrow> PC.dom (local.map f) = local.map (F.A.dom f)"
    unfolding P.dom_char [OF arr]
    unfolding map_def apply simp
    unfolding P.Id'_def apply simp
    unfolding FOb_def by simp
  show cod : "\<And>f. F.A.arr f \<Longrightarrow> PC.cod (local.map f) = local.map (F.A.cod f)"
    unfolding P.cod_char [OF arr]
    unfolding map_def apply simp
    unfolding P.Id'_def apply simp
    unfolding FOb_def by simp
  fix g f
  assume arr_gf : "F.A.seq g f"
  have arr_mgf : "PC.seq (map g) (map f)"
    apply (rule_tac F.A.seqE [OF arr_gf])
    apply (rule_tac PC.seqI)
    unfolding dom cod
    using arr by simp_all
  show "local.map (C g f) = P.pointed_set_comp (local.map g) (local.map f)"
    apply (rule_tac reverse_equality)
    apply (rule_tac P.comp_eq_char2)
        apply (rule_tac arr_mgf)
       apply (rule_tac arr [OF arr_gf])
      apply (subst dom)
    using arr_gf apply blast
      apply (subst dom [OF arr_gf])
    using F.A.dom_comp [OF arr_gf] apply simp
     apply (subst cod)
    using arr_gf apply blast
      apply (subst cod [OF arr_gf])
    using F.A.cod_comp [OF arr_gf] apply simp
  proof-
    fix x
    assume "x \<in> snd (fst (snd (the (local.map f))))"
    then have x_in_dom : "x \<in> S.set (F (F.A.dom f))"
      apply (rule_tac F.A.seqE [OF arr_gf])
      unfolding map_def
      apply simp
      unfolding FOb_def by simp
    show "fst (the (local.map g)) (fst (the (local.map f)) x) = fst (the (local.map (C g f))) x"
      apply (rule_tac F.A.seqE [OF arr_gf])
      unfolding map_def
      by (simp add: x_in_dom)
  qed
qed

end

end


theory Preliminaries
imports Datatype Main Typedef
begin

text{* This theory Constains the definition of a Link. A link is defined as Link diagrams upto
 equivalence moves. Link diagrams are defined in terms of the Constituent tangles*}

text{*each  block is a horizontal block built by putting basic link bricks next to each other.
(1) vert is the straight line
(2) cup is the up facing cup
(3) cap is the bottom facing
(4) over is the positive cross
(5) under is the negative cross*}

datatype brick = vert
                |cup
                |cap
                |over
                |under

text{*block is obtained by putting bricks next to each other*}

type_synonym block = "brick list"

text{*wall are link diagrams obtained by placing a horizontal blocks a top each other*}
(* Consistent number - datatype wall *)
datatype wall =  basic block
                |prod block  wall  (infixr "*" 66)

text{*Concatenate gives us the block obtained by putting two blocks next to each other*}

primrec concatenate :: "block => block => block" (infixr "\<otimes>" 65) where
concatenates_Nil: "[] \<otimes> ys = ys" |
concatenates_Cons: "((x#xs)\<otimes>ys) = x#(xs\<otimes>ys)"

lemma empty_concatenate: "xs \<otimes> Nil = xs"
 apply(induct_tac xs)
 apply(auto)
 done

text{*Associativity properties of Conscatenation*}
lemma leftright_associativity: "(x\<otimes>y)\<otimes>z = x\<otimes>(y\<otimes>z)"
apply(induct_tac x)
apply(auto)
done

lemma left_associativity: "(x\<otimes>y)\<otimes>z = x\<otimes>y\<otimes>z"
apply(induct_tac x)
apply(auto)
done

lemma right_associativity: "x\<otimes>(y\<otimes>z) =x \<otimes> y \<otimes>z"
apply(auto)
done

text{*Compose gives us the wall obtained by putting a wall above another, perhaps in an invalid way.
*}
primrec compose :: "wall => wall => wall" (infixr "\<circ>" 66) where
compose_Nil: "(basic x) \<circ>  ys = prod x ys" |
compose_Cons: "((prod x xs)\<circ>ys) = prod x (xs\<circ>ys)"

text{*Associativity properties of composition*}
lemma compose_leftassociativity: "(((x::wall) \<circ> y) \<circ> z) = (x\<circ>y \<circ>z)"
apply(induct_tac x)
apply(auto)
done

lemma compose_rightassociativity: "(x::wall) \<circ> (y \<circ> z) = (x\<circ>y \<circ>z)"
apply(induct_tac x)
apply(auto)
done

text{*block-length of a block is the number of bricks in a given block*}
primrec block_length::"block \<Rightarrow> nat"
where
"block_length [] = 0"|
"block_length (Cons x y) = 1 + (block_length y)"

(*domain tells us the number of incoming strands*)
 primrec domain::"brick \<Rightarrow> int"
 where
 "domain vert = 1"|
 "domain cup = 0"|
 "domain cap = 2"|
 "domain over = 2"|
 "domain under = 2"

lemma domain_non_negative:"\<forall>x.(domain x) \<ge> 0"

proof-
 have "\<forall>x.(x = vert)\<or>(x = over)\<or>(x=under)\<or>(x=cap)\<or>(x=cup)"
               by (metis brick.exhaust)
 moreover have "\<forall>x.(((x = vert)\<or>(x = over)\<or>(x=under)\<or>(x=cap)\<or>(x=cup)) \<longrightarrow> (domain x) \<ge> 0)"
              using domain.simps by (metis order_refl zero_le_numeral zero_le_one)
 ultimately show ?thesis by auto
qed
(*co-domain tells us the number of outgoing strands*)
 primrec codomain::"brick \<Rightarrow> int"
 where
 "codomain vert = 1"|
 "codomain cup = 2"|
 "codomain cap = 0"|
 "codomain over = 2"|
 "codomain under = 2"

(*domain-block tells us the number of incoming strands of a block*)
 primrec domain_block::"block \<Rightarrow> int "
 where
 "domain_block [] = 0"
 |"domain_block (Cons x y) = (domain x + (domain_block y))"

lemma domain_block_non_negative:"domain_block xs \<ge> 0"
      apply(induct_tac xs)
      apply(auto)
      apply(simp add:domain_non_negative)
      done
(*codomain-block tells us the number of outgoing strands of a block*)

 primrec codomain_block::"block \<Rightarrow> int "
 where
 "codomain_block [] = 0"
 |"codomain_block (Cons x y) = (codomain x + (codomain_block y))"

(*domain-wall tells us the number of incoming strands of a wall*)

primrec domain_wall:: "wall \<Rightarrow> int" where
"domain_wall (basic x) = domain_block x"
|"domain_wall (x*ys) = domain_block x"

(*domain-wall tells us the number of incoming strands of a wall*)

fun codomain_wall:: "wall \<Rightarrow> int" where
"codomain_wall (basic x) = codomain_block x"
|"codomain_wall (x*ys) = codomain_wall ys"

lemma domain_wall_compose: "domain_wall (xs\<circ>ys) = domain_wall xs"
    apply(induct_tac xs)
    apply(auto)
    done

lemma codomain_wall_compose: "codomain_wall (xs\<circ>ys) = codomain_wall ys"
    apply(induct_tac xs)
    apply(auto)
    done

text{*this lemma tells us the number of incoming and outgoing strands
of a composition of two wall*}

text{*absolute value*}
definition abs::"int \<Rightarrow> int" where
"abs x \<equiv> if (x\<ge>0) then x else (0-x)"

text{*theorems about abs*}
lemma abs_zero: assumes "abs x = 0" shows "x = 0"
 using abs_def assms eq_iff_diff_eq_0
 by metis

lemma abs_zero_equality: assumes "abs (x - y) = 0" shows "x = y"
 using assms abs_zero  eq_iff_diff_eq_0
 by auto

lemma abs_non_negative: " abs x \<ge> 0"
using abs_def diff_0 le_cases neg_0_le_iff_le
by auto

lemma abs_non_negative_sum:  assumes " abs x + abs y = 0"
shows "abs x= 0" and "abs y = 0"
 using abs_def diff_0 abs_non_negative  neg_0_le_iff_le
 add_nonneg_eq_0_iff assms
 apply metis
 by (metis abs_non_negative add_nonneg_eq_0_iff assms)

text{*The following lemmas tell us that the number of incoming and outgoing strands of every brick
is a non negative integer*}
lemma domain_nonnegative: "(domain x) \<ge> 0"
using domain.simps  brick.exhaust le_cases not_numeral_le_zero zero_le_one by (metis)

lemma codomain_nonnegative: "(codomain x) \<ge> 0"
      apply(case_tac x)
      apply(auto)
      done

text{*The following lemmas tell us that the number of incoming and outgoing strands of every block
is a non negative integer*}
lemma domain_block_nonnegative: "domain_block x \<ge> 0"
    apply(induct_tac x)
    apply(auto)
    apply(simp add:domain_nonnegative)
    done

lemma codomain_block_nonnegative: "(codomain_block x) \<ge> 0"
    apply(induct_tac x)
    apply(auto)
    apply(simp add:codomain_nonnegative)
    done

text{*The following lemmas tell us that if a block is appended to a block with incoming strands, then
the resultant block has incoming strands*}

lemma domain_positive: "((domain_block (x#Nil)) > 0) \<or> ((domain_block y) > 0)
\<Longrightarrow> (domain_block (x#y) > 0)"
proof-
 have "(domain_block (x#y)) =  (domain x) + (domain_block y)"  by auto
 also have " (domain x) = (domain_block (x#Nil))" by auto
 then have "(domain_block (x#Nil) > 0) = (domain x > 0)"  by auto
 then have "((domain x > 0) \<or> (domain_block y > 0)) \<Longrightarrow> (domain x + domain_block y)>0"
    using domain_nonnegative add_nonneg_pos add_pos_nonneg domain_block_nonnegative by metis
 from this
       show "((domain_block(x#Nil)) > 0) \<or> ((domain_block y) > 0) \<Longrightarrow> (domain_block (x#y) > 0)"
            by auto
qed

lemma domain_additive:  "(domain_block (x\<otimes>y))= (domain_block x) + (domain_block y)"
    apply(induct_tac x)
    apply(auto)
    done

lemma codomain_additive:   "(codomain_block (x\<otimes>y))= (codomain_block x) + (codomain_block y)"
    apply(induct_tac x)
    apply(auto)
    done

lemma domain_zero_sum: assumes "(domain_block x) + (domain_block y) = 0"
shows "domain_block x = 0" and "domain_block y = 0"
    using domain_block_nonnegative add_nonneg_eq_0_iff assms
    apply metis
    by (metis add_nonneg_eq_0_iff assms domain_block_nonnegative)

lemma domain_block_positive: assumes "domain_block y>0" or "domain_block y>0"
shows "(domain_block (x\<otimes>y)) > 0"
   apply (simp add: domain_additive)
   by (metis assms(1) domain_additive domain_block_nonnegative domain_zero_sum(2) less_le)

lemma codomain_block_positive: assumes "codomain_block y>0" or "codomain_block y>0"
shows "(codomain_block (x\<otimes>y)) > 0"
   apply (simp add: codomain_additive)
   using  assms(1) codomain_additive codomain_block_nonnegative eq_neg_iff_add_eq_0
          le_less_trans less_le neg_less_0_iff_less
   by (metis)

text{*We prove that if the first count of a block is zero, then it is composed of cups and empty bricks. In
order to do that we define the functions brick-is-cup and is-cup which check if a given block is
composed of cups or if the blocks are composed of blocks*}

primrec brick_is_cup::"brick \<Rightarrow> bool"
where
"brick_is_cup vert = False"|
"brick_is_cup cup = True"|
"brick_is_cup cap = False"|
"brick_is_cup over = False"|
"brick_is_cup under = False"

primrec is_cup::"block \<Rightarrow> bool"
where
"is_cup [] = True"|
"is_cup (x#y) = (if (x= cup) then (is_cup y) else False)"

lemma brickcount_zero_implies_cup:"(domain x= 0) \<Longrightarrow> (x = cup)"
   apply(case_tac x)
   apply(auto)
   done

lemma brickcount_zero_implies_brick_is_cup:"(domain x= 0) \<Longrightarrow> (brick_is_cup x)"
 apply(case_tac x)
 apply(auto)
 done

lemma domain_zero_implies_is_cup:"(domain_block x= 0) \<Longrightarrow> (is_cup x)"
proof(induction x)
 case Nil
  show ?case by auto
  next
 case (Cons a y)
   show ?case
   proof-
   have step1: "domain_block (a # y) =  (domain a) + (domain_block y)"
               by auto
   with domain_zero_sum have"domain_block y = 0"
               by (metis (full_types) Cons.prems domain_block_nonnegative domain_positive leD neq_iff)
   then have step2: "(is_cup y)"
               using Cons.IH by (auto)
   with step1 and domain_zero_sum
            have "domain a= 0"
              by (metis `domain_block y = 0` comm_monoid_add_class.add.right_neutral Cons.prems)
   then  have "brick_is_cup a"
               using brickcount_zero_implies_brick_is_cup by auto
   with assms have "a=cup"
        using brick_is_cup_def by (metis `domain a = 0` brickcount_zero_implies_cup)
   with step2 have "is_cup (a#y)"
        using is_cup_def by auto
   then show ?case by auto
 qed
qed

text{* We need a function that checks if a wall represents a knot diagram.*}

primrec is_tangle_diagram::"wall \<Rightarrow>  bool"
where
"is_tangle_diagram (basic x) = True"
|"is_tangle_diagram (x*xs) = (if is_tangle_diagram xs
                               then (codomain_block x = domain_wall xs)
                               else False)"

definition is_link_diagram::"wall \<Rightarrow>  bool"
where
"is_link_diagram x \<equiv> (if (is_tangle_diagram x)
                        then (abs (domain_wall x) + abs(codomain_wall x) = 0)
                         else False)"

end


(*  Title:      ZF/ex/Ramsey.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge

Ramsey's Theorem (finite exponent 2 version)

Based upon the article
    D Basin and M Kaufmann,
    The Boyer-Moore Prover and Nuprl: An Experimental Comparison.
    In G Huet and G Plotkin, editors, Logical Frameworks.
    (CUP, 1991), pages 89-119

See also
    M Kaufmann,
    An example in NQTHM: Ramsey's Theorem
    Internal Note, Computational Logic, Inc., Austin, Texas 78703
    Available from the author: kaufmann@cli.com

This function compute Ramsey numbers according to the proof given below
(which, does not constrain the base case values at all.

fun ram 0 j = 1
  | ram i 0 = 1
  | ram i j = ram (i-1) j + ram i (j-1)
*)

theory Ramsey imports ZF begin

definition
  Symmetric :: "i=>o" where
    "Symmetric(E) == (\<forall>x y. <x,y>:E \<longrightarrow> <y,x>:E)"

definition
  Atleast :: "[i,i]=>o" where \<comment> "not really necessary: ZF defines cardinality"
    "Atleast(n,S) == (\<exists>f. f \<in> inj(n,S))"

definition
  Clique  :: "[i,i,i]=>o" where
    "Clique(C,V,E) == (C \<subseteq> V) & (\<forall>x \<in> C. \<forall>y \<in> C. x\<noteq>y \<longrightarrow> <x,y> \<in> E)"

definition
  Indept  :: "[i,i,i]=>o" where
    "Indept(I,V,E) == (I \<subseteq> V) & (\<forall>x \<in> I. \<forall>y \<in> I. x\<noteq>y \<longrightarrow> <x,y> \<notin> E)"

definition
  Ramsey  :: "[i,i,i]=>o" where
    "Ramsey(n,i,j) == \<forall>V E. Symmetric(E) & Atleast(n,V) \<longrightarrow>
         (\<exists>C. Clique(C,V,E) & Atleast(i,C)) |
         (\<exists>I. Indept(I,V,E) & Atleast(j,I))"

(*** Cliques and Independent sets ***)

lemma Clique0 [intro]: "Clique(0,V,E)"
by (unfold Clique_def, blast)

lemma Clique_superset: "[| Clique(C,V',E);  V'<=V |] ==> Clique(C,V,E)"
by (unfold Clique_def, blast)

lemma Indept0 [intro]: "Indept(0,V,E)"
by (unfold Indept_def, blast)

lemma Indept_superset: "[| Indept(I,V',E);  V'<=V |] ==> Indept(I,V,E)"
by (unfold Indept_def, blast)

(*** Atleast ***)

lemma Atleast0 [intro]: "Atleast(0,A)"
by (unfold Atleast_def inj_def Pi_def function_def, blast)

lemma Atleast_succD:
    "Atleast(succ(m),A) ==> \<exists>x \<in> A. Atleast(m, A-{x})"
apply (unfold Atleast_def)
apply (blast dest: inj_is_fun [THEN apply_type] inj_succ_restrict)
done

lemma Atleast_superset:
    "[| Atleast(n,A);  A \<subseteq> B |] ==> Atleast(n,B)"
by (unfold Atleast_def, blast intro: inj_weaken_type)

lemma Atleast_succI:
    "[| Atleast(m,B);  b\<notin> B |] ==> Atleast(succ(m), cons(b,B))"
apply (unfold Atleast_def succ_def)
apply (blast intro: inj_extend elim: mem_irrefl)
done

lemma Atleast_Diff_succI:
     "[| Atleast(m, B-{x});  x \<in> B |] ==> Atleast(succ(m), B)"
by (blast intro: Atleast_succI [THEN Atleast_superset])

(*** Main Cardinality Lemma ***)

(*The #-succ(0) strengthens the original theorem statement, but precisely
  the same proof could be used!!*)
lemma pigeon2 [rule_format]:
     "m \<in> nat ==>
          \<forall>n \<in> nat. \<forall>A B. Atleast((m#+n) #- succ(0), A \<union> B) \<longrightarrow>
                           Atleast(m,A) | Atleast(n,B)"
apply (induct_tac "m")
apply (blast intro!: Atleast0, simp)
apply (rule ballI)
apply (rename_tac m' n) (*simplifier does NOT preserve bound names!*)
apply (induct_tac "n", auto)
apply (erule Atleast_succD [THEN bexE])
apply (rename_tac n' A B z)
apply (erule UnE)
(**case z \<in> B.  Instantiate the '\<forall>A B' induction hypothesis. **)
apply (drule_tac [2] x1 = A and x = "B-{z}" in spec [THEN spec])
apply (erule_tac [2] mp [THEN disjE])
(*cases Atleast(succ(m1),A) and Atleast(succ(k),B)*)
apply (erule_tac [3] asm_rl notE Atleast_Diff_succI)+
(*proving the condition*)
prefer 2 apply (blast intro: Atleast_superset)
(**case z \<in> A.  Instantiate the '\<forall>n \<in> nat. \<forall>A B' induction hypothesis. **)
apply (drule_tac x2="succ(n')" and x1="A-{z}" and x=B
       in bspec [THEN spec, THEN spec])
apply (erule nat_succI)
apply (erule mp [THEN disjE])
(*cases Atleast(succ(m1),A) and Atleast(succ(k),B)*)
apply (erule_tac [2] asm_rl Atleast_Diff_succI notE)+
(*proving the condition*)
apply simp
apply (blast intro: Atleast_superset)
done

(**** Ramsey's Theorem ****)

(** Base cases of induction; they now admit ANY Ramsey number **)

lemma Ramsey0j: "Ramsey(n,0,j)"
by (unfold Ramsey_def, blast)

lemma Ramseyi0: "Ramsey(n,i,0)"
by (unfold Ramsey_def, blast)

(** Lemmas for induction step **)

(*The use of succ(m) here, rather than #-succ(0), simplifies the proof of
  Ramsey_step_lemma.*)
lemma Atleast_partition: "[| Atleast(m #+ n, A);  m \<in> nat;  n \<in> nat |]
      ==> Atleast(succ(m), {x \<in> A. ~P(x)}) | Atleast(n, {x \<in> A. P(x)})"
apply (rule nat_succI [THEN pigeon2], assumption+)
apply (rule Atleast_superset, auto)
done

(*For the Atleast part, proves ~(a \<in> I) from the second premise!*)
lemma Indept_succ:
    "[| Indept(I, {z \<in> V-{a}. <a,z> \<notin> E}, E);  Symmetric(E);  a \<in> V;
        Atleast(j,I) |] ==>
     Indept(cons(a,I), V, E) & Atleast(succ(j), cons(a,I))"
apply (unfold Symmetric_def Indept_def)
apply (blast intro!: Atleast_succI)
done

lemma Clique_succ:
    "[| Clique(C, {z \<in> V-{a}. <a,z>:E}, E);  Symmetric(E);  a \<in> V;
        Atleast(j,C) |] ==>
     Clique(cons(a,C), V, E) & Atleast(succ(j), cons(a,C))"
apply (unfold Symmetric_def Clique_def)
apply (blast intro!: Atleast_succI)
done

(** Induction step **)

(*Published proofs gloss over the need for Ramsey numbers to be POSITIVE.*)
lemma Ramsey_step_lemma:
   "[| Ramsey(succ(m), succ(i), j);  Ramsey(n, i, succ(j));
       m \<in> nat;  n \<in> nat |] ==> Ramsey(succ(m#+n), succ(i), succ(j))"
apply (unfold Ramsey_def, clarify)
apply (erule Atleast_succD [THEN bexE])
apply (erule_tac P1 = "%z.<x,z>:E" in Atleast_partition [THEN disjE],
       assumption+)
(*case m*)
apply (fast dest!: Indept_succ elim: Clique_superset)
(*case n*)
apply (fast dest!: Clique_succ elim: Indept_superset)
done

(** The actual proof **)

(*Again, the induction requires Ramsey numbers to be positive.*)
lemma ramsey_lemma: "i \<in> nat ==> \<forall>j \<in> nat. \<exists>n \<in> nat. Ramsey(succ(n), i, j)"
apply (induct_tac "i")
apply (blast intro!: Ramsey0j)
apply (rule ballI)
apply (induct_tac "j")
apply (blast intro!: Ramseyi0)
apply (blast intro!: add_type Ramsey_step_lemma)
done

(*Final statement in a tidy form, without succ(...) *)

end


header {* IO Automaton *}

(*<*)
theory IO_Automaton
imports Trivia
begin
(*>*)

subsection{* Preliminaries *}

text {* Transitions *}

datatype ('state,'act,'out) trans =
Trans (srcOf: 'state) (actOf: 'act) (outOf: 'out) (tgtOf: 'state)

type_synonym ('state,'act,'out) trace = "('state,'act,'out) trans list"

locale IO_Automaton =
fixes istate :: "'state" (* initial step *)
  and step :: "'state \<Rightarrow> 'act \<Rightarrow> 'out * 'state"  (* transition function *)
begin

subsection{* Reachability and invariance *}

(* Reachable states: *)
inductive reach :: "'state \<Rightarrow> bool" where
Istate: "reach istate"
|
Step: "reach s \<Longrightarrow> reach (snd (step s a))"

lemma reach_PairI:
assumes "reach s" and "step s a = (ou, s')"
shows "reach s'"
by (metis Step assms assms snd_eqD)

(* holds at the initial state: *)
definition holdsIstate :: "('state \<Rightarrow> bool) \<Rightarrow> bool" where
"holdsIstate \<phi> \<equiv> \<phi> istate"

(* is invariant: *)
definition invar :: "('state \<Rightarrow> bool) \<Rightarrow> bool" where
"invar \<phi> \<equiv> \<forall> s a. reach s \<and> \<phi> s \<longrightarrow> \<phi> (snd (step s a))"

lemma holdsIstate_invar:
assumes h: "holdsIstate \<phi>" and i: "invar \<phi>" and a: "reach s"
shows "\<phi> s"
using a apply (induct rule: reach.induct)
using h i unfolding holdsIstate_def invar_def by auto

subsection{* System traces *}

(* The output and effect of an action on a state: *)
definition out :: "'state \<Rightarrow> 'act \<Rightarrow> 'out" where "out s a \<equiv> fst (step s a)"
definition eff :: "'state \<Rightarrow> 'act \<Rightarrow> 'state" where "eff s a \<equiv> snd (step s a)"

primrec validTrans :: "('state,'act,'out) trans \<Rightarrow> bool" where
"validTrans (Trans s a ou s') = (step s a = (ou, s'))"

lemma validTrans:
"validTrans trn =
 (step (srcOf trn) (actOf trn) = (outOf trn, tgtOf trn))"
by (cases trn) auto

(* Traces allowed by the system (starting in any given state) *)
(* Two alternative definitions: growing from the left and growing from the right: *)
inductive valid :: "('state,'act,'out) trace \<Rightarrow> bool" where
Singl[simp,intro!]:
"validTrans trn
 \<Longrightarrow>
 valid [trn]"
|
Cons[intro]:
"\<lbrakk>validTrans trn; tgtOf trn = srcOf (hd tr); valid tr\<rbrakk>
 \<Longrightarrow>
 valid (trn # tr)"

inductive_cases valid_SinglE[elim!]: "valid [trn]"
inductive_cases valid_ConsE[elim]: "valid (trn # tr)"

inductive valid2 :: "('state,'act,'out) trace \<Rightarrow> bool" where
Singl[simp,intro!]:
"validTrans trn
 \<Longrightarrow>
 valid2 [trn]"
|
Rcons[intro]:
"\<lbrakk>valid2 tr; tgtOf (last tr) = srcOf trn; validTrans trn\<rbrakk>
 \<Longrightarrow>
 valid2 (tr ## trn)"

inductive_cases valid2_SinglE[elim!]: "valid2 [trn]"
inductive_cases valid2_RconsE[elim]: "valid2 (tr ## trn)"

lemma Nil_not_valid[simp]: "\<not> valid []"
by (metis valid.simps neq_Nil_conv)

lemma Nil_not_valid2[simp]: "\<not> valid2 []"
by (metis valid2.cases append_Nil butlast.simps butlast_snoc not_Cons_self2)

lemma valid_Rcons:
assumes "valid tr" and "tgtOf (last tr) = srcOf trn" and "validTrans trn"
shows "valid (tr ## trn)"
using assms proof(induct arbitrary: trn)
  case (Cons trn tr trna)
  thus ?case by (cases tr) (auto intro: valid.Cons)
qed(auto intro: valid.intros)

lemma valid_hd_Rcons[simp]:
assumes "valid tr"
shows "hd (tr ## tran) = hd tr"
by (metis Nil_not_valid assms hd_append)

lemma valid2_hd_Rcons[simp]:
assumes "valid2 tr"
shows "hd (tr ## tran) = hd tr"
by (metis Nil_not_valid2 assms hd_append)

lemma valid2_last_Cons[simp]:
assumes "valid2 tr"
shows "last (tran # tr) = last tr"
by (metis Nil_not_valid2 assms last.simps)

lemma valid2_Cons:
assumes "valid2 tr" and "tgtOf trn = srcOf (hd tr)" and "validTrans trn"
shows "valid2 (trn # tr)"
using assms proof(induct arbitrary: trn)
  case Singl  show ?case
  unfolding two_singl_Rcons using Singl
  by (intro valid2.Rcons) (auto intro: valid2.Singl)
next
  case Rcons show ?case
  unfolding append.append_Cons[symmetric] using Rcons by (intro valid2.Rcons) auto
qed

lemma valid_valid2: "valid = valid2"
proof(rule ext, safe)
  fix tr assume "valid tr"  thus "valid2 tr"
  by (induct) (auto intro: valid2.Singl valid2_Cons)
next
  fix tr assume "valid2 tr"  thus "valid tr"
  by (induct) (auto intro: valid.Singl valid_Rcons)
qed

lemmas valid2_valid = valid_valid2[symmetric]

definition validFrom :: "'state \<Rightarrow> ('state,'act,'out) trace \<Rightarrow> bool" where
"validFrom s tr \<equiv> tr = [] \<or> (valid tr \<and> srcOf (hd tr) = s)"

lemma validFrom_Nil[simp,intro!]: "validFrom s []"
unfolding validFrom_def by auto

lemma validFrom_valid[simp,intro]: "valid tr \<and> srcOf (hd tr) = s \<Longrightarrow> validFrom s tr"
unfolding validFrom_def by auto

lemma validFrom_validTrans[intro]:
assumes "validTrans (Trans s a ou s')" and "validFrom s' tr"
shows "validFrom s (Trans s a ou s' # tr)"
using assms unfolding validFrom_def by auto

subsection {* Traces versus reachability *}

lemma valid_reach_src_tgt:
assumes "valid tr" and "reach (srcOf (hd tr))"
shows "reach (tgtOf (last tr))"
using assms by induct (auto intro: reach_PairI simp: validTrans)

lemma valid_init_reach:
assumes "valid tr" and "srcOf (hd tr) = istate"
shows "reach (tgtOf (last tr))"
using valid_reach_src_tgt assms reach.Istate by metis

lemma Trans_fst_sndI:
"valid [Trans s a (fst (step s a)) (snd (step s a))]"
by (metis valid.Singl surjective_pairing validTrans.simps)

lemma reach_init_valid:
assumes "reach s"
shows
"s = istate
 \<or>
 (\<exists> tr. valid tr \<and> srcOf (hd tr) = istate \<and> tgtOf (last tr) = s)"
using assms proof induction
  case (Step s a)
  thus ?case proof(elim disjE exE conjE)
    assume s: "s = istate"
    let ?ou = "fst (step s a)"  let ?s' = "snd (step s a)"
    show ?thesis using s
    by (intro disjI2 exI[of _ "[Trans s a ?ou ?s']"]) auto
  next
    fix tr assume v: "valid tr" and s: "srcOf (hd tr) = istate" and t: "tgtOf (last tr) = s"
    let ?ou = "fst (step s a)"  let ?s' = "snd (step s a)"
    show ?thesis using v t s
    by (intro disjI2 exI[of _ "tr ## Trans s a ?ou ?s'"]) (auto intro: valid_Rcons)
  qed
qed auto

lemma reach_validFrom:
assumes "reach s'"
shows "\<exists> s tr. s = istate \<and> (s = s' \<or> (validFrom s tr \<and> tgtOf (last tr) = s'))"
using reach_init_valid[OF assms] unfolding validFrom_def by auto

(*<*)

end (* locale IO_Automaton *)

end

(*>*)