(*  Title:       Countable Ordinals

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

section \<open>Fixed-points\<close>

theory OrdinalFix
imports OrdinalInverse
begin

primrec iter :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
where
  "iter 0       F x = x"
| "iter (Suc n) F x = F (iter n F x)"

definition
  oFix :: "(ordinal \<Rightarrow> ordinal) \<Rightarrow> ordinal \<Rightarrow> ordinal" where
  "oFix F a = oLimit (\<lambda>n. iter n F a)"

lemma oFix_fixed:
"\<lbrakk>continuous F; a \<le> F a\<rbrakk> \<Longrightarrow> F (oFix F a) = oFix F a"
 apply (unfold oFix_def)
 apply (simp only: continuousD)
 apply (rule order_antisym)
  apply (rule oLimit_leI, clarify)
  apply (rule_tac n="Suc n" in le_oLimitI, simp)
 apply (rule oLimit_leI, clarify)
 apply (rule_tac n=n in le_oLimitI)
 apply (induct_tac n, simp)
 apply (simp add: continuous.monoD)
done

lemma oFix_least:
"\<lbrakk>mono F; F x = x; a \<le> x\<rbrakk> \<Longrightarrow> oFix F a \<le> x"
 apply (unfold oFix_def)
 apply (rule oLimit_leI, clarify)
 apply (induct_tac n, simp_all)
 apply (erule subst)
 apply (erule monoD, assumption)
done

lemma mono_oFix: "mono F \<Longrightarrow> mono (oFix F)"
 apply (rule monoI, unfold oFix_def)
 apply (subgoal_tac "\<forall>n. iter n F x \<le> iter n F y")
  apply (rule oLimit_leI, clarify)
  apply (rule_tac n=n in le_oLimitI, erule spec)
 apply (rule allI, induct_tac n)
  apply simp
 apply (simp add: monoD)
done

lemma less_oFixD:
"\<lbrakk>x < oFix F a; mono F; F x = x\<rbrakk> \<Longrightarrow> x < a"
 apply (simp add: linorder_not_le[symmetric])
 apply (erule contrapos_nn)
by (rule oFix_least)

lemma less_oFixI: "a < F a \<Longrightarrow> a < oFix F a"
 apply (unfold oFix_def)
 apply (erule order_less_le_trans)
 apply (rule_tac n=1 in le_oLimitI)
 apply simp
done

lemma le_oFix: "a \<le> oFix F a"
 apply (unfold oFix_def)
 apply (rule_tac n=0 in le_oLimitI)
 apply simp
done

lemma le_oFix1: "F a \<le> oFix F a"
 apply (unfold oFix_def)
 apply (rule_tac n=1 in le_oLimitI)
 apply simp
done

lemma less_oFix_0D:
"\<lbrakk>x < oFix F 0; mono F\<rbrakk> \<Longrightarrow> x < F x"
 apply (unfold oFix_def, drule less_oLimitD, clarify)
 apply (erule_tac P="x < iter n F 0" in rev_mp)
 apply (induct_tac n, auto simp add: linorder_not_less)
 apply (erule order_less_le_trans)
 apply (erule monoD, assumption)
done

lemma zero_less_oFix_eq: "(0 < oFix F 0) = (0 < F 0)"
 apply (safe)
  apply (erule contrapos_pp)
  apply (simp only: linorder_not_less oFix_def)
  apply (rule oLimit_leI[rule_format])
  apply (induct_tac n, simp, simp)
 apply (erule less_oFixI)
done

lemma oFix_eq_self: "F a = a \<Longrightarrow> oFix F a = a"
 apply (unfold oFix_def)
 apply (subgoal_tac "\<forall>n. iter n F a = a", simp)
 apply (rule allI, induct_tac n, simp_all)
done

subsection \<open>Derivatives of ordinal functions\<close>

text "The derivative of F enumerates all the fixed-points of F"

definition
  oDeriv :: "(ordinal \<Rightarrow> ordinal) \<Rightarrow> ordinal \<Rightarrow> ordinal" where
  "oDeriv F = ordinal_rec (oFix F 0) (\<lambda>p x. oFix F (oSuc x))"

lemma oDeriv_0 [simp]:
"oDeriv F 0 = oFix F 0"
by (simp add: oDeriv_def)

lemma oDeriv_oSuc [simp]:
"oDeriv F (oSuc x) = oFix F (oSuc (oDeriv F x))"
by (simp add: oDeriv_def)

lemma oDeriv_oLimit [simp]:
"oDeriv F (oLimit f) = oLimit (\<lambda>n. oDeriv F (f n))"
 apply (unfold oDeriv_def)
 apply (rule ordinal_rec_oLimit, clarify)
 apply (rule order_trans[OF order_less_imp_le[OF less_oSuc]])
 apply (rule le_oFix)
done

lemma oDeriv_fixed:
"normal F \<Longrightarrow> F (oDeriv F n) = oDeriv F n"
 apply (rule_tac a=n in oLimit_induct, simp_all)
   apply (rule oFix_fixed)
    apply (erule normal.continuous)
   apply simp
  apply (rule oFix_fixed)
   apply (erule normal.continuous)
  apply (erule normal.increasing)
 apply (simp add: normal.oLimit)
done

lemma oDeriv_fixedD:
"\<lbrakk>oDeriv F x = x; normal F\<rbrakk> \<Longrightarrow> F x = x"
by (erule subst, erule oDeriv_fixed)

lemma normal_oDeriv:
"normal (oDeriv F)"
 apply (rule normalI, simp_all)
 apply (rule order_less_le_trans[OF less_oSuc])
 apply (rule le_oFix)
done

lemma oDeriv_increasing:
"continuous F \<Longrightarrow> F x \<le> oDeriv F x"
 apply (rule_tac a=x in oLimit_induct)
   apply (simp add: le_oFix1)
  apply simp
  apply (rule order_trans[OF _ le_oFix1])
  apply (erule continuous.monoD)
  apply simp
  apply (rule normal.increasing)
  apply (rule normal_oDeriv)
 apply (simp add: continuousD)
 apply (rule oLimit_leI[rule_format])
 apply (rule_tac n=n in le_oLimitI)
 apply (erule spec)
done

lemma oDeriv_total:
"\<lbrakk>normal F; F x = x\<rbrakk> \<Longrightarrow> \<exists>n. x = oDeriv F n"
 apply (subgoal_tac "\<exists>n. oDeriv F n \<le> x \<and> x < oDeriv F (oSuc n)")
  apply clarsimp
  apply (drule less_oFixD)
    apply (erule normal.mono)
   apply assumption
  apply (rule_tac x=n in exI, simp add: less_oSuc_eq_le)
 apply (rule normal.oInv_ex[OF normal_oDeriv])
 apply (simp add: oFix_least normal.mono)
done

lemma range_oDeriv:
"normal F \<Longrightarrow> range (oDeriv F) = {x. F x = x}"
by (auto intro: oDeriv_fixed dest: oDeriv_total)

end


theory Gronwall
imports Vector_Derivative_On
begin

subsection \<open>Gronwall\<close>

lemma derivative_quotient_bound:
  assumes g_deriv_on: "(g has_vderiv_on g') {a .. b}"
  assumes frac_le: "\<And>t. t \<in> {a .. b} \<Longrightarrow> g' t / g t \<le> K"
  assumes g'_cont: "continuous_on {a .. b} g'"
  assumes g_pos: "\<And>t. t \<in> {a .. b} \<Longrightarrow> g t > 0"
  assumes t_in: "t \<in> {a .. b}"
  shows "g t \<le> g a * exp (K * (t - a))"
proof -
  have g_deriv: "\<And>t. t \<in> {a .. b} \<Longrightarrow> (g has_real_derivative g' t) (at t within {a .. b})"
    using g_deriv_on
    by (auto simp: has_vderiv_on_def has_field_derivative_iff_has_vector_derivative[symmetric])
  from assms have g_nonzero: "\<And>t. t \<in> {a .. b} \<Longrightarrow> g t \<noteq> 0"
    by fastforce
  have frac_integrable: "\<And>t. t \<in> {a .. b} \<Longrightarrow> (\<lambda>t. g' t / g t) integrable_on {a..t}"
    by (force simp: g_nonzero intro: assms has_field_derivative_subset[OF g_deriv]
      continuous_on_subset[OF g'_cont] continuous_intros integrable_continuous_real
      continuous_on_subset[OF vderiv_on_continuous_on[OF g_deriv_on]])
  have "\<And>t. t \<in> {a..b} \<Longrightarrow> ((\<lambda>t. g' t / g t) has_integral ln (g t) - ln (g a)) {a .. t}"
    by (rule fundamental_theorem_of_calculus)
      (auto intro!: derivative_eq_intros assms has_field_derivative_subset[OF g_deriv]
        simp: has_field_derivative_iff_has_vector_derivative[symmetric])
  hence *: "\<And>t. t \<in> {a .. b} \<Longrightarrow> ln (g t) - ln (g a) = integral {a .. t} (\<lambda>t. g' t / g t)"
    using integrable_integral[OF frac_integrable]
    by (rule has_integral_unique[where f = "\<lambda>t. g' t / g t"])
  from * t_in have "ln (g t) - ln (g a) = integral {a .. t} (\<lambda>t. g' t / g t)" .
  also have "\<dots> \<le> integral {a .. t} (\<lambda>_. K)"
    using \<open>t \<in> {a .. b}\<close>
    by (intro integral_le) (auto intro!: frac_integrable frac_le integral_le)
  also have "\<dots> = K * (t - a)" using \<open>t \<in> {a .. b}\<close>
    by simp
  finally have "ln (g t) \<le> K * (t - a) + ln (g a)" (is "?lhs \<le> ?rhs")
    by simp
  hence "exp ?lhs \<le> exp ?rhs"
    by simp
  thus ?thesis
    using \<open>t \<in> {a .. b}\<close> g_pos
    by (simp add: ac_simps exp_add del: exp_le_cancel_iff)
qed

lemma derivative_quotient_bound_left:
  assumes g_deriv_on: "(g has_vderiv_on g') {a .. b}"
  assumes frac_ge: "\<And>t. t \<in> {a .. b} \<Longrightarrow> K \<le> g' t / g t"
  assumes g'_cont: "continuous_on {a .. b} g'"
  assumes g_pos: "\<And>t. t \<in> {a .. b} \<Longrightarrow> g t > 0"
  assumes t_in: "t \<in> {a..b}"
  shows "g t \<le> g b * exp (K * (t - b))"
proof -
  have g_deriv: "\<And>t. t \<in> {a .. b} \<Longrightarrow> (g has_real_derivative g' t) (at t within {a .. b})"
    using g_deriv_on
    by (auto simp: has_vderiv_on_def has_field_derivative_iff_has_vector_derivative[symmetric])
  from assms have g_nonzero: "\<And>t. t \<in> {a..b} \<Longrightarrow> g t \<noteq> 0"
    by fastforce
  have frac_integrable: "\<And>t. t \<in> {a .. b} \<Longrightarrow> (\<lambda>t. g' t / g t) integrable_on {t..b}"
    by (force simp: g_nonzero intro: assms has_field_derivative_subset[OF g_deriv]
      continuous_on_subset[OF g'_cont] continuous_intros integrable_continuous_real
      continuous_on_subset[OF vderiv_on_continuous_on[OF g_deriv_on]])
  have "\<And>t. t \<in> {a..b} \<Longrightarrow> ((\<lambda>t. g' t / g t) has_integral ln (g b) - ln (g t)) {t..b}"
    by (rule fundamental_theorem_of_calculus)
      (auto intro!: derivative_eq_intros assms has_field_derivative_subset[OF g_deriv]
        simp: has_field_derivative_iff_has_vector_derivative[symmetric])
  hence *: "\<And>t. t \<in> {a..b} \<Longrightarrow> ln (g b) - ln (g t) = integral {t..b} (\<lambda>t. g' t / g t)"
    using integrable_integral[OF frac_integrable]
    by (rule has_integral_unique[where f = "\<lambda>t. g' t / g t"])
  have "K * (b - t) = integral {t..b} (\<lambda>_. K)"
    using \<open>t \<in> {a..b}\<close>
    by simp
  also have "... \<le> integral {t..b} (\<lambda>t. g' t / g t)"
    using \<open>t \<in> {a..b}\<close>
    by (intro integral_le) (auto intro!: frac_integrable frac_ge integral_le)
  also have "... = ln (g b) - ln (g t)"
    using * t_in by simp
  finally have "K * (b - t) + ln (g t) \<le> ln (g b)" (is "?lhs \<le> ?rhs")
    by simp
  hence "exp ?lhs \<le> exp ?rhs"
    by simp
  hence "g t * exp (K * (b - t)) \<le> g b"
    using \<open>t \<in> {a..b}\<close> g_pos
    by (simp add: ac_simps exp_add del: exp_le_cancel_iff)
  hence "g t / exp (K * (t - b)) \<le> g b"
    by (simp add: algebra_simps exp_diff)
  thus ?thesis
    by (simp add: field_simps)
qed

lemma gronwall_general:
  fixes g K C a b and t::real
  defines "G \<equiv> \<lambda>t. C + K * integral {a..t} (\<lambda>s. g s)"
  assumes g_le_G: "\<And>t. t \<in> {a..b} \<Longrightarrow> g t \<le> G t"
  assumes g_cont: "continuous_on {a..b} g"
  assumes g_nonneg: "\<And>t. t \<in> {a..b} \<Longrightarrow> 0 \<le> g t"
  assumes pos: "0 < C" "K > 0"
  assumes "t \<in> {a..b}"
  shows "g t \<le> C * exp (K * (t - a))"
proof -
  have G_pos: "\<And>t. t \<in> {a..b} \<Longrightarrow> 0 < G t"
    by (auto simp: G_def intro!: add_pos_nonneg mult_nonneg_nonneg Henstock_Kurzweil_Integration.integral_nonneg
      integrable_continuous_real assms intro: less_imp_le continuous_on_subset)
  have "g t \<le> G t" using assms by auto
  also
  {
    have "(G has_vderiv_on (\<lambda>t. K * g t)) {a..b}"
      by (auto intro!: derivative_eq_intros integral_has_vector_derivative g_cont
        simp add: G_def has_vderiv_on_def)
    moreover
    {
      fix t assume "t \<in> {a..b}"
      hence "K * g t / G t \<le> K * G t / G t"
        using pos g_le_G G_pos
        by (intro divide_right_mono mult_left_mono) (auto intro!: less_imp_le)
      also have "\<dots> = K"
        using G_pos[of t] \<open>t \<in> {a .. b}\<close> by simp
      finally have "K * g t / G t \<le> K" .
    }
    ultimately have "G t \<le> G a * exp (K * (t - a))"
      apply (rule derivative_quotient_bound)
      using \<open>t \<in> {a..b}\<close>
      by (auto intro!: continuous_intros g_cont G_pos simp: field_simps pos)
  }
  also have "G a = C"
    by (simp add: G_def)
  finally show ?thesis
    by simp
qed

lemma gronwall_general_left:
  fixes g K C a b and t::real
  defines "G \<equiv> \<lambda>t. C + K * integral {t..b} (\<lambda>s. g s)"
  assumes g_le_G: "\<And>t. t \<in> {a..b} \<Longrightarrow> g t \<le> G t"
  assumes g_cont: "continuous_on {a..b} g"
  assumes g_nonneg: "\<And>t. t \<in> {a..b} \<Longrightarrow> 0 \<le> g t"
  assumes pos: "0 < C" "K > 0"
  assumes "t \<in> {a..b}"
  shows "g t \<le> C * exp (-K * (t - b))"
proof -
  have G_pos: "\<And>t. t \<in> {a..b} \<Longrightarrow> 0 < G t"
    by (auto simp: G_def intro!: add_pos_nonneg mult_nonneg_nonneg Henstock_Kurzweil_Integration.integral_nonneg
      integrable_continuous_real assms intro: less_imp_le continuous_on_subset)
  have "g t \<le> G t" using assms by auto
  also
  {
    have "(G has_vderiv_on (\<lambda>t. -K * g t)) {a..b}"
      by (auto intro!: derivative_eq_intros g_cont integral_has_vector_derivative'
          simp add: G_def has_vderiv_on_def)
    moreover
    {
      fix t assume "t \<in> {a..b}"
      hence "K * g t / G t \<le> K * G t / G t"
        using pos g_le_G G_pos
        by (intro divide_right_mono mult_left_mono) (auto intro!: less_imp_le)
      also have "\<dots> = K"
        using G_pos[of t] \<open>t \<in> {a .. b}\<close> by simp
      finally have "K * g t / G t \<le> K" .
      hence "-K \<le> -K * g t / G t"
        by simp
    }
    ultimately
    have "G t \<le> G b * exp (-K * (t - b))"
      apply (rule derivative_quotient_bound_left)
      using \<open>t \<in> {a..b}\<close>
      by (auto intro!: continuous_intros g_cont G_pos simp: field_simps pos)
  }
  also have "G b = C"
    by (simp add: G_def)
  finally show ?thesis
    by simp
qed

lemma gronwall_general_segment:
  fixes a b::real
  assumes "\<And>t. t \<in> closed_segment a b \<Longrightarrow> g t \<le> C + K * integral (closed_segment a t) g"
    and "continuous_on (closed_segment a b) g"
    and "\<And>t. t \<in> closed_segment a b \<Longrightarrow> 0 \<le> g t"
    and "0 < C"
    and "0 < K"
    and "t \<in> closed_segment a b"
  shows "g t \<le> C * exp (K * abs (t - a))"
proof cases
  assume "a \<le> b"
  then have *: "abs (t - a) = t -a" using assms by (auto simp: closed_segment_eq_real_ivl)
  show ?thesis
    unfolding *
    using assms
    by (intro gronwall_general[where b=b]) (auto intro!: simp: closed_segment_eq_real_ivl \<open>a \<le> b\<close>)
next
  assume "\<not>a \<le> b"
  then have *: "K * abs (t - a) = - K * (t - a)" using assms by (auto simp: closed_segment_eq_real_ivl algebra_simps)
  {
    fix s :: real
    assume a1: "b \<le> s"
    assume a2: "s \<le> a"
    assume a3: "\<And>t. b \<le> t \<and> t \<le> a \<Longrightarrow> g t \<le> C + K * integral (if a \<le> t then {a..t} else {t..a}) g"
    have "s = a \<or> s < a"
      using a2 by (meson less_eq_real_def)
    then have "g s \<le> C + K * integral {s..a} g"
      using a3 a1 by fastforce
  } then show ?thesis
    unfolding *
    using assms  \<open>\<not>a \<le> b\<close>
    by (intro gronwall_general_left)
      (auto intro!: simp: closed_segment_eq_real_ivl)
qed

lemma gronwall_more_general_segment:
  fixes a b c::real
  assumes "\<And>t. t \<in> closed_segment a b \<Longrightarrow> g t \<le> C + K * integral (closed_segment c t) g"
    and cont: "continuous_on (closed_segment a b) g"
    and "\<And>t. t \<in> closed_segment a b \<Longrightarrow> 0 \<le> g t"
    and "0 < C"
    and "0 < K"
    and t: "t \<in> closed_segment a b"
    and c: "c \<in> closed_segment a b"
  shows "g t \<le> C * exp (K * abs (t - c))"
proof -
  from t c have "t \<in> closed_segment c a \<or> t \<in> closed_segment c b"
    by (auto simp: closed_segment_eq_real_ivl split_ifs)
  then show ?thesis
  proof
    assume "t \<in> closed_segment c a"
    moreover
    have subs: "closed_segment c a \<subseteq> closed_segment a b" using t c
      by (auto simp: closed_segment_eq_real_ivl split_ifs)
    ultimately show ?thesis
      by (intro gronwall_general_segment[where b=a])
        (auto intro!: assms intro: continuous_on_subset)
  next
    assume "t \<in> closed_segment c b"
    moreover
    have subs: "closed_segment c b \<subseteq> closed_segment a b" using t c
      by (auto simp: closed_segment_eq_real_ivl)
    ultimately show ?thesis
      by (intro gronwall_general_segment[where b=b])
        (auto intro!: assms intro: continuous_on_subset)
  qed
qed

lemma gronwall:
  fixes g K C and t::real
  defines "G \<equiv> \<lambda>t. C + K * integral {0..t} (\<lambda>s. g s)"
  assumes g_le_G: "\<And>t. 0 \<le> t \<Longrightarrow> t \<le> a \<Longrightarrow> g t \<le> G t"
  assumes g_cont: "continuous_on {0..a} g"
  assumes g_nonneg: "\<And>t. 0 \<le> t \<Longrightarrow> t \<le> a \<Longrightarrow> 0 \<le> g t"
  assumes pos: "0 < C" "0 < K"
  assumes "0 \<le> t" "t \<le> a"
  shows "g t \<le> C * exp (K * t)"
  apply(rule gronwall_general[where a=0, simplified, OF assms(2-6)[unfolded G_def]])
  using assms(7,8)
  by simp_all

lemma gronwall_left:
  fixes g K C and t::real
  defines "G \<equiv> \<lambda>t. C + K * integral {t..0} (\<lambda>s. g s)"
  assumes g_le_G: "\<And>t. a \<le> t \<Longrightarrow> t \<le> 0 \<Longrightarrow> g t \<le> G t"
  assumes g_cont: "continuous_on {a..0} g"
  assumes g_nonneg: "\<And>t. a \<le> t \<Longrightarrow> t \<le> 0 \<Longrightarrow> 0 \<le> g t"
  assumes pos: "0 < C" "0 < K"
  assumes "a \<le> t" "t \<le> 0"
  shows "g t \<le> C * exp (-K * t)"
  apply(simp, rule gronwall_general_left[where b=0, simplified, OF assms(2-6)[unfolded G_def]])
  using assms(7,8)
  by simp_all

end


theory InductRules
imports Main
begin

lemma disjCases2[consumes 1, case_names 1 2]:
  assumes AB: "A \<or> B"
  and AP: "A \<Longrightarrow> P"
  and BP: "B \<Longrightarrow> P"
  shows "P"
proof -
  from AB AP BP show ?thesis by blast
qed

lemma disjCases3[consumes 1, case_names 1 2 3]:
  assumes AB: "A \<or> B \<or> C"
  and AP: "A \<Longrightarrow> P"
  and BP: "B \<Longrightarrow> P"
  and CP: "C \<Longrightarrow> P"
  shows "P"
proof -
  from AB AP BP CP show ?thesis by blast
qed

lemma disjCases4[consumes 1, case_names 1 2 3 4]:
  assumes AB: "A \<or> B \<or> C \<or> D"
  and AP: "A \<Longrightarrow> P"
  and BP: "B \<Longrightarrow> P"
  and CP: "C \<Longrightarrow> P"
  and DP: "D \<Longrightarrow> P"
  shows "P"
proof -
  from AB AP BP CP DP show ?thesis by blast
qed

lemma disjCases5[consumes 1, case_names 1 2 3 4 5]:
  assumes AB: "A \<or> B \<or> C \<or> D \<or> E"
  and AP: "A \<Longrightarrow> P"
  and BP: "B \<Longrightarrow> P"
  and CP: "C \<Longrightarrow> P"
  and DP: "D \<Longrightarrow> P"
  and EP: "E \<Longrightarrow> P"
  shows "P"
proof -
  from AB AP BP CP DP EP show ?thesis by blast
qed

lemma minimal_witness_ex:
  assumes k: "P (k::nat)"
  shows "\<exists> k0. k0 \<le> k \<and> P k0 \<and> (\<forall> k. k < k0 \<longrightarrow> \<not> (P k))"
proof -
  let ?K = "{ h. h \<le> k \<and> P h }"
  have finite_K: "finite ?K" by auto
  have "k \<in> ?K" by (simp add: k)
  then have nonempty_K: "?K \<noteq> {}" by auto
  let ?k = "Min ?K"
  have witness: "?k \<le> k \<and> P ?k"
    by (metis (mono_tags, lifting) Min_in finite_K mem_Collect_eq nonempty_K)
  have minimal: "\<forall> h. h < ?k \<longrightarrow> \<not> (P h)"
    by (metis Min_le witness dual_order.strict_implies_order
        dual_order.trans finite_K leD mem_Collect_eq)
  from witness minimal show ?thesis by metis
qed

lemma minimal_witness[consumes 1, case_names Minimal]:
  assumes "P (k::nat)"
  and "\<And> K. K \<le> k \<Longrightarrow> P K \<Longrightarrow> (\<And> k. k < K \<Longrightarrow> \<not> (P k)) \<Longrightarrow> Q"
  shows "Q"
proof -
  from assms minimal_witness_ex show ?thesis by metis
qed

lemma ex_minimal_witness[consumes 1, case_names Minimal]:
  assumes "\<exists> k. P (k::nat)"
  and "\<And> K. P K \<Longrightarrow> (\<And> k. k < K \<Longrightarrow> \<not> (P k)) \<Longrightarrow> Q"
  shows "Q"
proof -
  from assms minimal_witness_ex show ?thesis by metis
qed

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Lexicographic order on functions\<close>

theory Fun_Lexorder
imports MainRLT
begin

definition less_fun :: "('a::linorder \<Rightarrow> 'b::linorder) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
where
  "less_fun f g \<longleftrightarrow> (\<exists>k. f k < g k \<and> (\<forall>k' < k. f k' = g k'))"

lemma less_funI:
  assumes "\<exists>k. f k < g k \<and> (\<forall>k' < k. f k' = g k')"
  shows "less_fun f g"
  using assms by (simp add: less_fun_def)

lemma less_funE:
  assumes "less_fun f g"
  obtains k where "f k < g k" and "\<And>k'. k' < k \<Longrightarrow> f k' = g k'"
  using assms unfolding less_fun_def by blast

lemma less_fun_asym:
  assumes "less_fun f g"
  shows "\<not> less_fun g f"
proof
  from assms obtain k1 where k1: "f k1 < g k1" "k' < k1 \<Longrightarrow> f k' = g k'" for k'
    by (blast elim!: less_funE)
  assume "less_fun g f" then obtain k2 where k2: "g k2 < f k2" "k' < k2 \<Longrightarrow> g k' = f k'" for k'
    by (blast elim!: less_funE)
  show False proof (cases k1 k2 rule: linorder_cases)
    case equal with k1 k2 show False by simp
  next
    case less with k2 have "g k1 = f k1" by simp
    with k1 show False by simp
  next
    case greater with k1 have "f k2 = g k2" by simp
    with k2 show False by simp
  qed
qed

lemma less_fun_irrefl:
  "\<not> less_fun f f"
proof
  assume "less_fun f f"
  then obtain k where k: "f k < f k"
    by (blast elim!: less_funE)
  then show False by simp
qed

lemma less_fun_trans:
  assumes "less_fun f g" and "less_fun g h"
  shows "less_fun f h"
proof (rule less_funI)
  from \<open>less_fun f g\<close> obtain k1 where k1: "f k1 < g k1" "k' < k1 \<Longrightarrow> f k' = g k'" for k'
    by (blast elim!: less_funE)
  from \<open>less_fun g h\<close> obtain k2 where k2: "g k2 < h k2" "k' < k2 \<Longrightarrow> g k' = h k'" for k'
    by (blast elim!: less_funE)
  show "\<exists>k. f k < h k \<and> (\<forall>k'<k. f k' = h k')"
  proof (cases k1 k2 rule: linorder_cases)
    case equal with k1 k2 show ?thesis by (auto simp add: exI [of _ k2])
  next
    case less with k2 have "g k1 = h k1" "\<And>k'. k' < k1 \<Longrightarrow> g k' = h k'" by simp_all
    with k1 show ?thesis by (auto intro: exI [of _ k1])
  next
    case greater with k1 have "f k2 = g k2" "\<And>k'. k' < k2 \<Longrightarrow> f k' = g k'" by simp_all
    with k2 show ?thesis by (auto intro: exI [of _ k2])
  qed
qed

lemma order_less_fun:
  "class.order (\<lambda>f g. less_fun f g \<or> f = g) less_fun"
  by (rule order_strictI) (auto intro: less_fun_trans intro!: less_fun_irrefl less_fun_asym)

lemma less_fun_trichotomy:
  assumes "finite {k. f k \<noteq> g k}"
  shows "less_fun f g \<or> f = g \<or> less_fun g f"
proof -
  { define K where "K = {k. f k \<noteq> g k}"
    assume "f \<noteq> g"
    then obtain k' where "f k' \<noteq> g k'" by auto
    then have [simp]: "K \<noteq> {}" by (auto simp add: K_def)
    with assms have [simp]: "finite K" by (simp add: K_def)
    define q where "q = Min K"
    then have "q \<in> K" and "\<And>k. k \<in> K \<Longrightarrow> k \<ge> q" by auto
    then have "\<And>k. \<not> k \<ge> q \<Longrightarrow> k \<notin> K" by blast
    then have *: "\<And>k. k < q \<Longrightarrow> f k = g k" by (simp add: K_def)
    from \<open>q \<in> K\<close> have "f q \<noteq> g q" by (simp add: K_def)
    then have "f q < g q \<or> f q > g q" by auto
    with * have "less_fun f g \<or> less_fun g f"
      by (auto intro!: less_funI)
  } then show ?thesis by blast
qed

end


(*
  File: Connectivity.thy
  Author: Bohua Zhan
*)

section \<open>Connectedness for a set of undirected edges.\<close>

theory Connectivity
  imports Union_Find
begin

text \<open>A simple application of union-find for graph connectivity.\<close>

fun is_path :: "nat \<Rightarrow> (nat \<times> nat) set \<Rightarrow> nat list \<Rightarrow> bool" where
  "is_path n S [] = False"
| "is_path n S (x # xs) =
   (if xs = [] then x < n else ((x, hd xs) \<in> S \<or> (hd xs, x) \<in> S) \<and> is_path n S xs)"
setup \<open>fold add_rewrite_rule @{thms is_path.simps}\<close>

definition has_path :: "nat \<Rightarrow> (nat \<times> nat) set \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where [rewrite]:
  "has_path n S i j \<longleftrightarrow> (\<exists>p. is_path n S p \<and> hd p = i \<and> last p = j)"

lemma is_path_nonempty [forward]: "is_path n S p \<Longrightarrow> p \<noteq> []" by auto2
lemma nonempty_is_not_path [resolve]: "\<not>is_path n S []" by auto2

lemma is_path_extend [forward]:
  "is_path n S p \<Longrightarrow> S \<subseteq> T \<Longrightarrow> is_path n T p"
@proof @induct p @qed

lemma has_path_extend [forward]:
  "has_path n S i j \<Longrightarrow> S \<subseteq> T \<Longrightarrow> has_path n T i j" by auto2

definition joinable :: "nat list \<Rightarrow> nat list \<Rightarrow> bool" where [rewrite]:
  "joinable p q \<longleftrightarrow> (last p = hd q)"

definition path_join :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list" where [rewrite]:
  "path_join p q = p @ tl q"
setup \<open>register_wellform_data ("path_join p q", ["joinable p q"])\<close>
setup \<open>add_prfstep_check_req ("path_join p q", "joinable p q")\<close>

lemma path_join_hd [rewrite]: "p \<noteq> [] \<Longrightarrow> hd (path_join p q) = hd p" by auto2

lemma path_join_last [rewrite]: "joinable p q \<Longrightarrow> q \<noteq> [] \<Longrightarrow> last (path_join p q) = last q"
@proof @have "q = hd q # tl q" @case "tl q = []" @qed

lemma path_join_is_path [backward]:
  "joinable p q \<Longrightarrow> is_path n S p \<Longrightarrow> is_path n S q \<Longrightarrow> is_path n S (path_join p q)"
@proof @induct p @qed

lemma has_path_trans [forward]:
  "has_path n S i j \<Longrightarrow> has_path n S j k \<Longrightarrow> has_path n S i k"
@proof
  @obtain p where "is_path n S p" "hd p = i" "last p = j"
  @obtain q where "is_path n S q" "hd q = j" "last q = k"
  @have "is_path n S (path_join p q)"
@qed

definition is_valid_graph :: "nat \<Rightarrow> (nat \<times> nat) set \<Rightarrow> bool" where [rewrite]:
  "is_valid_graph n S \<longleftrightarrow> (\<forall>p\<in>S. fst p < n \<and> snd p < n)"

lemma has_path_single1 [backward1]:
  "is_valid_graph n S \<Longrightarrow> (a, b) \<in> S \<Longrightarrow> has_path n S a b"
@proof @have "is_path n S [a, b]" @qed

lemma has_path_single2 [backward1]:
  "is_valid_graph n S \<Longrightarrow> (a, b) \<in> S \<Longrightarrow> has_path n S b a"
@proof @have "is_path n S [b, a]" @qed

lemma has_path_refl [backward2]:
  "is_valid_graph n S \<Longrightarrow> a < n \<Longrightarrow> has_path n S a a"
@proof @have "is_path n S [a]" @qed

definition connected_rel :: "nat \<Rightarrow> (nat \<times> nat) set \<Rightarrow> (nat \<times> nat) set" where
  "connected_rel n S = {(a,b). has_path n S a b}"

lemma connected_rel_iff [rewrite]:
  "(a, b) \<in> connected_rel n S \<longleftrightarrow> has_path n S a b" using connected_rel_def by simp

lemma connected_rel_trans [forward]:
  "trans (connected_rel n S)" by auto2

lemma connected_rel_refl [backward2]:
  "is_valid_graph n S \<Longrightarrow> a < n \<Longrightarrow> (a, a) \<in> connected_rel n S" by auto2

lemma is_path_per_union [rewrite]:
  "is_valid_graph n (S \<union> {(a, b)}) \<Longrightarrow>
   has_path n (S \<union> {(a, b)}) i j \<longleftrightarrow> (i, j) \<in> per_union (connected_rel n S) a b"
@proof
  @let "R = connected_rel n S"
  @let "S' = S \<union> {(a, b)}" @have "S \<subseteq> S'"
  @case "(i, j) \<in> per_union R a b" @with
    @case "(i, a) \<in> R \<and> (b, j) \<in> R" @with
      @have "has_path n S' i a" @have "has_path n S' a b" @have "has_path n S' b j"
    @end
    @case "(i, b) \<in> R \<and> (a, j) \<in> R" @with
      @have "has_path n S' i b" @have "has_path n S' b a" @have "has_path n S' a j"
    @end
  @end
  @case "has_path n S' i j" @with
    @have (@rule) "\<forall>p. is_path n S' p \<longrightarrow> (hd p, last p) \<in> per_union R a b" @with
      @induct p @with
      @subgoal "p = x # xs" @case "xs = []"
        @have "(x, hd xs) \<in> per_union R a b" @with
          @have "is_valid_graph n S"
          @case "(x, hd xs) \<in> S'" @with @case "(x, hd xs) \<in> S" @end
          @case "(hd xs, x) \<in> S'" @with @case "(hd xs, x) \<in> S" @end
        @end
      @endgoal @end
    @end
    @obtain p where "is_path n S' p" "hd p = i" "last p = j"
  @end
@qed

lemma connected_rel_union [rewrite]:
  "is_valid_graph n (S \<union> {(a, b)}) \<Longrightarrow>
   connected_rel n (S \<union> {(a, b)}) = per_union (connected_rel n S) a b" by auto2

lemma connected_rel_init [rewrite]:
  "connected_rel n {} = uf_init_rel n"
@proof
  @have "is_valid_graph n {}"
  @have "\<forall>i j. has_path n {} i j \<longleftrightarrow> (i, j) \<in> uf_init_rel n" @with
    @case "has_path n {} i j" @with
      @obtain p where "is_path n {} p" "hd p = i" "last p = j"
      @have "p = hd p # tl p"
    @end
  @end
@qed

fun connected_rel_ind :: "nat \<Rightarrow> (nat \<times> nat) list \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) set" where
  "connected_rel_ind n es 0 = uf_init_rel n"
| "connected_rel_ind n es (Suc k) =
   (let R = connected_rel_ind n es k; p = es ! k in
      per_union R (fst p) (snd p))"
setup \<open>fold add_rewrite_rule @{thms connected_rel_ind.simps}\<close>

lemma connected_rel_ind_rule [rewrite]:
  "is_valid_graph n (set es) \<Longrightarrow> k \<le> length es \<Longrightarrow>
   connected_rel_ind n es k = connected_rel n (set (take k es))"
@proof @induct k @with
  @subgoal "k = Suc m"
    @have "is_valid_graph n (set (take (Suc m) es))"
  @endgoal @end
@qed

text \<open>Correctness of the functional algorithm.\<close>
theorem connected_rel_ind_compute [rewrite]:
  "is_valid_graph n (set es) \<Longrightarrow>
   connected_rel_ind n es (length es) = connected_rel n (set es)" by auto2

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_SSortSorts
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((le y y2) & (ordered (cons2 y2 xs)))"

fun ssortminimum1 :: "Nat => Nat list => Nat" where
  "ssortminimum1 x (nil2) = x"
| "ssortminimum1 x (cons2 y1 ys1) =
     (if le y1 x then ssortminimum1 y1 ys1 else ssortminimum1 x ys1)"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

(*fun did not finish the proof*)
function ssort :: "Nat list => Nat list" where
  "ssort (nil2) = nil2"
| "ssort (cons2 y ys) =
     (let m :: Nat = ssortminimum1 y ys
     in cons2
          m
          (ssort
             (deleteBy
                (% (z :: Nat) => % (x2 :: Nat) => (z = x2)) m (cons2 y ys))))"
  by pat_completeness auto

theorem property0 :
  "ordered (ssort xs)"
  oops

end


section "Tries via Search Trees"

theory Trie_Map
imports
  Tree_Map
  Trie_Fun
begin

text \<open>An implementation of tries for an arbitrary alphabet \<open>'a\<close> where
the mapping from an element of type \<open>'a\<close> to the sub-trie is implemented by a binary search tree.
Although this implementation uses maps implemented by red-black trees it works for any
implementation of maps.

This is an implementation of the ``ternary search trees'' by Bentley and Sedgewick
[SODA 1997, Dr. Dobbs 1998]. The name derives from the fact that a node in the BST can now
be drawn to have 3 children, where the middle child is the sub-trie that the node maps
its key to. Hence the name \<open>trie3\<close>.

Example from @{url "https://en.wikipedia.org/wiki/Ternary_search_tree#Description"}:

          c
        / | \
       a  u  h
       |  |  | \
       t. t  e. u
     /  / |   / |
    s. p. e. i. s.

Characters with a dot are final.
Thus the tree represents the set of strings "cute","cup","at","as","he","us" and "i".
\<close>

datatype 'a trie3 = Nd3 bool "('a * 'a trie3) tree"

text \<open>In principle one should be able to given an implementation of tries
once and for all for any map implementation and not just for a specific one (unbalanced trees) as done here.
But because the map (@{type tree}) is used in a datatype, the HOL type system does not support this.

However, the development below works verbatim for any map implementation, eg \<open>RBT_Map\<close>,
and not just \<open>Tree_Map\<close>, except for the termination lemma \<open>lookup_size\<close>.\<close>

term size_tree
lemma lookup_size[termination_simp]:
  fixes t :: "('a::linorder * 'a trie3) tree"
  shows "lookup t a = Some b \<Longrightarrow> size b < Suc (size_tree (\<lambda>ab. Suc (size (snd( ab)))) t)"
apply(induction t a rule: lookup.induct)
apply(auto split: if_splits)
done

definition empty3 :: "'a trie3" where
[simp]: "empty3 = Nd3 False Leaf"

fun isin3 :: "('a::linorder) trie3 \<Rightarrow> 'a list \<Rightarrow> bool" where
"isin3 (Nd3 b m) [] = b" |
"isin3 (Nd3 b m) (x # xs) = (case lookup m x of None \<Rightarrow> False | Some t \<Rightarrow> isin3 t xs)"

fun insert3 :: "('a::linorder) list \<Rightarrow> 'a trie3 \<Rightarrow> 'a trie3" where
"insert3 [] (Nd3 b m) = Nd3 True m" |
"insert3 (x#xs) (Nd3 b m) =
  Nd3 b (update x (insert3 xs (case lookup m x of None \<Rightarrow> empty3 | Some t \<Rightarrow> t)) m)"

fun delete3 :: "('a::linorder) list \<Rightarrow> 'a trie3 \<Rightarrow> 'a trie3" where
"delete3 [] (Nd3 b m) = Nd3 False m" |
"delete3 (x#xs) (Nd3 b m) = Nd3 b
   (case lookup m x of
      None \<Rightarrow> m |
      Some t \<Rightarrow> update x (delete3 xs t) m)"

subsection "Correctness"

text \<open>Proof by stepwise refinement. First abs3tract to type @{typ "'a trie"}.\<close>

fun abs3 :: "'a::linorder trie3 \<Rightarrow> 'a trie" where
"abs3 (Nd3 b t) = Nd b (\<lambda>a. map_option abs3 (lookup t a))"

fun invar3 :: "('a::linorder)trie3 \<Rightarrow> bool" where
"invar3 (Nd3 b m) = (M.invar m \<and> (\<forall>a t. lookup m a = Some t \<longrightarrow> invar3 t))"

lemma isin_abs3: "isin3 t xs = isin (abs3 t) xs"
apply(induction t xs rule: isin3.induct)
apply(auto split: option.split)
done

lemma abs3_insert3: "invar3 t \<Longrightarrow> abs3(insert3 xs t) = insert xs (abs3 t)"
apply(induction xs t rule: insert3.induct)
apply(auto simp: M.map_specs Tree_Set.empty_def[symmetric] split: option.split)
done

lemma abs3_delete3: "invar3 t \<Longrightarrow> abs3(delete3 xs t) = delete xs (abs3 t)"
apply(induction xs t rule: delete3.induct)
apply(auto simp: M.map_specs split: option.split)
done

lemma invar3_insert3: "invar3 t \<Longrightarrow> invar3 (insert3 xs t)"
apply(induction xs t rule: insert3.induct)
apply(auto simp: M.map_specs Tree_Set.empty_def[symmetric] split: option.split)
done

lemma invar3_delete3: "invar3 t \<Longrightarrow> invar3 (delete3 xs t)"
apply(induction xs t rule: delete3.induct)
apply(auto simp: M.map_specs split: option.split)
done

text \<open>Overall correctness w.r.t. the \<open>Set\<close> ADT:\<close>

interpretation S2: Set
where empty = empty3 and isin = isin3 and insert = insert3 and delete = delete3
and set = "set o abs3" and invar = invar3
proof (standard, goal_cases)
  case 1 show ?case by (simp add: isin_case split: list.split)
next
  case 2 thus ?case by (simp add: isin_abs3)
next
  case 3 thus ?case by (simp add: set_insert abs3_insert3 del: set_def)
next
  case 4 thus ?case by (simp add: set_delete abs3_delete3 del: set_def)
next
  case 5 thus ?case by (simp add: M.map_specs Tree_Set.empty_def[symmetric])
next
  case 6 thus ?case by (simp add: invar3_insert3)
next
  case 7 thus ?case by (simp add: invar3_delete3)
qed

end


theory Tutorial3
imports Main
begin

  (*
    A labeled transition system (LTS) is a directed graph where the edges
    are annotated with labels.

    A word from node q to node v is a list of labels, corresponding
    to the edges on a path from q to v.

    For example, the well known concept of finite automata, is usually
    represented as an LTS with an initial state and a set of final states.
  *)

  type_synonym ('q,'a) lts = "'q \<Rightarrow> 'a \<Rightarrow> 'q \<Rightarrow> bool"

  inductive word :: "('q,'a) lts \<Rightarrow> 'q \<Rightarrow> 'a list \<Rightarrow> 'q \<Rightarrow> bool" where
    empty: "word L q [] q"
  | step: "\<lbrakk> L q a r; word L r as s \<rbrakk> \<Longrightarrow> word L q (a#as) s"

  lemma word_append: "\<lbrakk>word L p as q; word L q bs r\<rbrakk> \<Longrightarrow> word L p (as@bs) r"
    apply (induction rule: word.induct)
     apply simp
    apply simp
    apply (rule step)
     apply assumption
      by assumption

  lemma "\<lbrakk>word L p as q; word L q bs r\<rbrakk> \<Longrightarrow> word L p (as@bs) r"
    apply (induction rule: word.induct)
    apply (auto intro: word.intros)
    done

  lemma word_split: "word L p (as@bs) r \<Longrightarrow> (\<exists>q. word L p as q \<and> word L q bs r)"
    (* Try to instantiate induction rule *)
    apply (induction L p "as@bs" r arbitrary: as rule: word.induct)
     apply (auto intro: word.intros simp: Cons_eq_append_conv)
    by (fastforce intro: word.intros)

  (* Sometimes, induction over a different structure, and case analysis, may be simpler:

    To add case-distinctions over an inductive predicate to the rules that auto/blast/force/...
    try automatically, use the elim: modifier. The rule is called <name>.cases
  *)
  thm word.cases
  lemma "word L p (as@bs) r \<Longrightarrow> (\<exists>q. word L p as q \<and> word L q bs r)"
    apply (induction as arbitrary: p)
     apply (auto intro: empty)
     thm word.cases
     apply (erule word.cases)
      apply simp
     apply (force intro: word.intros )
     done

  (* Combining both lemmas *)
  lemma word_append_conv: "word L p (as@bs) r \<longleftrightarrow> (\<exists>q. word L p as q \<and> word L q bs r)"
    by (auto simp: word_append word_split)

  (* Sometimes, we can also write an inductive predicate as a function.
    For example, the empty and append equations hint at function equations
    that recurse over the list!
  *)

  thm empty word_append_conv

  (* We can refine them a bit *)
  (* In the proofs, we only need to do a case distinction over word ...
    no induction is required.

  *)
  lemma word_Nil_conv: "word L p [] q \<longleftrightarrow> p=q"
    by (auto intro: empty elim: word.cases)

  lemma word_Cons_conv: "word L p (a#bs) r \<longleftrightarrow> (\<exists>q. L p a q \<and> word L q bs r)"
    apply auto
     apply (erule word.cases)
      apply simp
     apply auto
    apply (auto intro: intro: word.intros)
    done

  lemma "word L p (a#bs) r \<longleftrightarrow> (\<exists>q. L p a q \<and> word L q bs r)"
    by (force intro: word.intros elim: word.cases)

  (* Once we have proven the above rules, we can directly encode them as a function *)
  fun fword :: "('q,'a) lts \<Rightarrow> 'q \<Rightarrow> 'a list \<Rightarrow> 'q \<Rightarrow> bool"
    where
    "fword L p [] q \<longleftrightarrow> p=q"
  | "fword L p (a#bs) r \<longleftrightarrow> (\<exists>q. L p a q \<and> fword L q bs r)"

  (* Proving equality to the inductive predicate is then straightforward,
    by induction on the function / structural induction *)
lemma "fword L p w q \<longleftrightarrow> word L p w q"
  apply (induction L p w q rule: fword.induct)
   apply (auto simp: word_Nil_conv word_Cons_conv)
   done

lemma "fword L p w q \<longleftrightarrow> word L p w q"
  apply (induction w arbitrary: p)
   apply (auto simp: word_Nil_conv word_Cons_conv)
   done

end


(*<*)
theory T6CFinitoIngles
imports T5CCerradaIngles
begin
(*>*)

subsection \<open> Propiedad de carácter finito \<close>

text \<open>
  \label{caracter-finitoP}
  La demostración del teorema de existencia de models está basada en
  poder extender una propiedad de consistencia a otra propiedad de
  consistencia que sea cerrada por subconjuntos y de \emph{carácter
  finito}.

  \begin{definicion}\label{cfinito}
  Una colección de conjuntos @{text "\<C>"} es de \textbf{carácter finito}
  si para cada conjunto @{text "S"} se tiene que, @{text "S"}
  pertenece a @{text "\<C>"} si y sólo si cada subconjunto finito de
  @{text "S"} pertenece a @{text "\<C>"}.
  \end{definicion}

  \noindent Su formalización es:
\<close>

definition caracter_finito :: "'a set set \<Rightarrow> bool" where
  "caracter_finito \<C> = (\<forall>S. S \<in> \<C> = (\<forall>S'. finite S' \<longrightarrow> S' \<subseteq> S \<longrightarrow> S' \<in> \<C>))"

text \<open>
  \begin{teorema}\label{CaracterFinitoCerradaP}
  Toda colección de conjuntos de carácter finito @{text "\<C>"} es cerrada
  por subconjuntos.
  \end{teorema}

  \begin{demostracion}
  Supongamos que @{text "\<C>"} es de carácter finito;
  sea @{text "S \<in> \<C>"} y @{text "T \<subseteq> S"}, por la definición de
  colección cerrada por subconjuntos, hay que demostrar que
  @{text "T \<in> \<C>"}. Para esto, por hipotésis, basta con demostrar que
  cada subconjunto finito @{text "U"} de @{text "T"} pertenece a
  @{text "\<C>"}. Sea @{text "U"} un conjunto finito tal que
  @{text "U \<subseteq> T"}. Puesto que @{text "T \<subseteq> S"} se tiene que
  @{text "U \<subseteq> S"}. Así, puesto que @{text "S \<in> \<C>"} y @{text "C"} es
  de carácter finito se tiene que @{text "U \<in> \<C>"}.
  \end{demostracion}

  La siguiente es la formalización del teorema anterior.
\<close>

theorem caracter_finito_cerrado:
  assumes "caracter_finito \<C>"
  shows "subconj_cerrada \<C>"
proof -
  { fix S T
    assume "S \<in> \<C>" and  "T \<subseteq> S"
    have "T \<in> \<C>" using "caracter_finito_def"
    proof -
      { fix U
        assume "finite U" and "U \<subseteq> T"
        have "U \<in> \<C>"
        proof -
          have "U \<subseteq> S" using `U \<subseteq> T` and `T \<subseteq> S` by simp
          thus "U \<in> \<C>" using `S \<in> \<C>` and `finite U` and assms
            by (unfold caracter_finito_def) blast
        qed}
      thus ?thesis using assms by( unfold caracter_finito_def) blast
    qed }
  thus ?thesis  by(unfold  subconj_cerrada_def) blast
qed

(*<*)
text \<open>
  Otra estilo de demostrar el mismo teorema:
\<close>

theorem caracter_finito_cerrado1:
  assumes "caracter_finito \<C>"
  shows "subconj_cerrada \<C>"
proof (unfold subconj_cerrada_def)
  show "\<forall> S \<in> \<C>. \<forall> T. T \<subseteq> S \<longrightarrow> T \<in> \<C>"
  proof
    fix S
    assume "S \<in> \<C>"
    show "\<forall>T\<subseteq>S. T \<in> \<C>"
    proof (rule allI)
      fix T
      show "T \<subseteq> S \<longrightarrow> T \<in> \<C>"
      proof
        assume "T \<subseteq> S"
        show "T \<in> \<C>"
        proof -
          have "\<forall>U. finite U \<longrightarrow> U \<subseteq> T \<longrightarrow> U \<in> \<C>"
          proof (rule allI)
            fix U
            show "finite U \<longrightarrow> U \<subseteq> T \<longrightarrow> U \<in> \<C>"
            proof
              assume "finite U"
              show "U \<subseteq> T \<longrightarrow> U \<in> \<C>"
              proof
                assume "U \<subseteq> T"
                hence "U \<subseteq> S" using `T \<subseteq> S` by simp
                thus "U \<in> \<C>" using `S \<in> \<C>` and `finite U` and assms
                  by (unfold caracter_finito_def) blast
              qed
            qed
          qed
          thus ?thesis using assms by( unfold caracter_finito_def) blast
        qed
      qed
    qed
  qed
qed

(*>*)
subsection \<open> Extensión a una propiedad de carácter finito \<close>

text \<open>
  \label{altercarfinito}
  En la sección \ref{cerraduraP} se demostró que toda propiedad de
  consistencia proposicional @{text "\<C>"} puede extenderse a una
  propiedad de consistencia @{text "\<C>\<^sup>+"} que es cerrada por
  subconjuntos. En esta sección demostraremoss que toda propiedad de
  consistencia proposicional @{text "\<C>"} que sea cerrada por
  subconjuntos puede extenderse a una propiedad de consistencia
  @{text "\<C>⁻"} que es de carácter finito. Para la demostración,
  basta con considerar @{text "\<C>⁻"} igual a la colección de todos
  los conjuntos tales que sus subconjuntos finitos están en
  @{text "\<C>"}: @{text "\<C>⁻ = {S | \<forall>S'\<subseteq> S (S' finito \<longrightarrow> S' \<in> \<C>)}"}.

  La definición en Isabelle de @{text "\<C>⁻"} es,
\<close>

definition clausura_cfinito :: "'a set set \<Rightarrow> 'a set set" ("_⁻" [1000] 999) where
  "\<C>⁻ = {S. \<forall>S'. S' \<subseteq> S \<longrightarrow> finite S' \<longrightarrow> S' \<in> \<C>}"

text \<open>
  \begin{teorema}\label{AlternativaCfinitoP}
  Sea @{text "\<C>"} una colección de conjuntos. Se verifican las
  siguientes propiedades:
  \begin{itemize}
  \item[(a)] Si @{text "\<C>"} es cerrada por subconjuntos, entonces
    @{text "\<C> \<subseteq> \<C>⁻"}.
  \item[(b)] @{text "\<C>⁻"} es de carácter finito.
  \item[(c)] Si @{text "\<C>"} es una propiedad de consistencia
    proposicional que es cerrada por subconjuntos entonces,
    @{text "\<C>⁻"} es una propiedad de consistencia proposicional.
  \end{itemize}
  \end{teorema}
\<close>

text \<open>
  \begin{demostracion}

  \textbf{Apartado (a)} Supongamos que @{text "\<C>"} es cerrada por
  subconjuntos y sea @{text "S \<in> \<C>"}. Mostra\-mos que @{text "S \<in> \<C>⁻"}
  usando la definición de @{text "\<C>⁻"}: sea @{text "S'\<subseteq> S"} y
  @{text "S'"} finito. Puesto que @{text "S \<in> \<C>"} y @{text "S'\<subseteq> S"},
  entonces @{text "S' \<in> \<C>"}, ya que por hipótesis @{text "\<C>"} es cerrada
  por subconjuntos.

  \textbf{Apartado (b)} Sea @{text "S"} un conjunto. Por la definición
  de propiedad de carácter finito hay que demostrar que, @{text "S\<in> \<C>⁻"}
  si y sólo si cada subconjunto finito de @{text "S"} pertenece a @{text
  "\<C>⁻"}:

  Si @{text "S\<in> \<C>⁻"}, por la definición de @{text "\<C>⁻"}, se tiene que
  cada subconjunto finito de @{text "S"} pertenece a @{text "\<C>⁻"} y
  recíprocamente si cada subconjunto finito de @{text "S"} pertenece a
  @{text "\<C>⁻"} entonces, por la definición de @{text "\<C>⁻"},
  @{text "S\<in> \<C>⁻"}.

  \textbf{Apartado (c)} Supongamos que @{text "\<C>"} es una propiedad de
  consistencia proposicional que es cerrada por subconjuntos. Sea
  @{text "S \<in> \<C>⁻"}. Entonces, por la definición de @{text "\<C>⁻"}, se
  tiene que cada subconjunto finito de @{text "S"} pertenece a @{text
  "\<C>"}. A continuación mostramos que se cumplen las condiciones para que
  @{text "\<C>⁻"} sea una propiedad de consistencia.

  \textbf{Condición 1} Sea @{text "P"} una fórmula atómica, demostramos
  por contradicción que @{text "P \<notin> S"} o @{text "\<not>P \<notin> S"}. Supongamos que
  @{text "P \<in> S"} y @{text "\<not>P \<in> S"}, entonces
  @{text "{P,\<not>P} \<subseteq> S"}. Por tanto @{text "{P,\<not>P}\<in> \<C>"}, por ser
  @{text "\<C>"} cerrada por subconjuntos.  Luego @{text "P \<notin> {P,\<not>P}"} o
  @{text "\<not>P \<notin> {P,\<not>P}"}, ya que @{text "\<C>"} es una propiedad de
  consistencia. De esta forma obtenemos una contradicción.

  \textbf{Condición 2} La demostración de @{text "\<bottom> \<notin> S"} es por
  contradicción. Supongamos que @{text " \<bottom>\<in> S"}, entonces
  @{text "{\<bottom>} \<subseteq> S"}. Por lo tanto @{text "{\<bottom>} \<in> \<C>"}, por ser
  @{text "\<C>"} cerrada pos subconjuntos. Luego @{text "\<bottom> \<notin> {\<bottom>}"}, ya que
  @{text "\<C>"} es una propiedad de consistencia. De esta forma obtenemos
  una contradicción.

  De la misma forma @{text "\<not>\<top> \<notin> S"}, de lo contrario @{text "{\<not>\<top>} \<subseteq> S"}
  y por lo tanto @{text "{\<not>\<top>} \<in> \<C>"}, por ser @{text "\<C>"} cerrada por
  subconjuntos. Así, puesto que @{text "\<C>"} es una propiedad de
  consistencia, se tendría que @{text "\<not>\<top> \<notin> {\<not>\<top>}"}, lo cual es imposible.

  \textbf{Condición 3} Supongamos que @{text "\<not>\<not>F \<in> S"}. Demostramos que
  @{text "S\<union>{F} \<in> \<C>⁻"} usando la definición de @{text "\<C>⁻"}:
  consideremos @{text "S'"} subconjunto finito de @{text "S\<union>{F}"}, y
  mostremos que @{text "S' \<in> \<C>"}.

  Puesto que @{text "\<not>\<not>F \<in> S"} y @{text "S' \<subseteq> S\<union>{F}"} tenemos que
  @{text "S'−{F}\<union> {\<not>\<not>F}\<subseteq> S"}; también tene\-mos que @{text "S'−{F}\<union>{\<not>\<not>F}"}
  es finito ya que @{text "S'"} es finito. Así, @{text "S'−{F}\<union>{\<not>\<not>F} \<in> \<C>"}
  por la definición de @{text "\<C>\<^sup>-"}, y como
  @{text "{\<not>\<not>F} \<in> S'−{F}\<union>{\<not>\<not>F}"} entonces
  @{text "(S'−{F}\<union>{\<not>\<not>F})\<union>{F} \<in> \<C>"} por ser @{text "\<C>"} una propiedad de
  consistencia. Además, puesto que
  @{text "S' −{F}\<union>{\<not>\<not>F})\<union>{F} = S'\<union>{\<not>\<not>F}\<union>{F}"}, se tiene que
  @{text "S'\<union>{\<not>\<not>F})\<union>{F} \<in> \<C>"}.  De esto último y como
  @{text "S'\<subseteq> S'\<union> {\<not>\<not>F}\<union>{F}"} se tiene que @{text "S' \<in> \<C>"} ya que por
  hipótesis @{text "\<C>"} es cerrada por subconjuntos.

  \textbf{Condición 4} Supongamos que @{text "\<alpha> \<in> S"}. Demostramos que
  @{text "S\<union>{\<alpha>\<^sub>1,\<alpha>\<^sub>2} \<in> \<C>⁻"} usando la definición de @{text "\<C>⁻"}:
  consideremos @{text "S'"} subconjunto finito de @{text "S\<union>{\<alpha>\<^sub>1, \<alpha>\<^sub>2}"},
  y mostremos que @{text "S' \<in> \<C>"}.

  Puesto que @{text "\<alpha> \<in> S"} y @{text "S'\<subseteq> S\<union>{\<alpha>\<^sub>1,\<alpha>\<^sub>2}"} tenemos que
  @{text "S'−{\<alpha>\<^sub>1,\<alpha>\<^sub>2}\<union>{\<alpha> } \<subseteq> S"}; también tenemos que
  @{text "S'−{\<alpha>\<^sub>1,\<alpha>\<^sub>2}\<union>{\<alpha>}"} es finito ya que @{text "S'"} es finito.

  Así, @{text "S'−{\<alpha>\<^sub>1, \<alpha>\<^sub>2}\<union>{\<alpha> } \<in> \<C>"} por la definición de @{text "\<C>\<^sup>-"},
  y como @{text "\<alpha> \<in> S'−{\<alpha>\<^sub>1,\<alpha>\<^sub>2}\<union>{\<alpha>}"} entonces
  @{text "S'−{\<alpha>\<^sub>1,\<alpha>\<^sub>2}\<union>{\<alpha>})\<union>{\<alpha>\<^sub>1,\<alpha>\<^sub>2} \<in> \<C>"} por ser @{text "\<C>"} una propiedad de consistencia.

  Además, puesto que
     @{text "S'−{\<alpha>\<^sub>1,\<alpha>\<^sub>2} \<union> {\<alpha>}) \<union> {\<alpha>\<^sub>1,\<alpha>\<^sub>2} = S' \<union> {\<alpha>}\<union> {\<alpha>\<^sub>1,\<alpha>\<^sub>2}"}
  se tiene que
     @{text "S'\<union>{\<alpha>}\<union>{\<alpha>\<^sub>1,\<alpha>\<^sub>2} \<in> \<C>"}.
  De esto último, y como @{text "S'\<subseteq> S'\<union>{\<alpha>}\<union>{\<alpha>\<^sub>1,\<alpha>\<^sub>2}"}, se tiene que
  @{text "S' \<in> \<C>"} ya que por hipótesis @{text "\<C>"} es cerrada por
  subconjuntos.

  \textbf{Condición 5} Supongamos que @{text "\<beta> \<in> S"}. Demostramos que
  @{text "S\<union>{\<beta>\<^sub>1} \<in> \<C>⁻"} o @{text "S\<union>{\<beta>\<^sub>2} \<in> \<C>⁻"} por contradicción.

  Supongamos que @{text "S\<union>{\<beta>\<^sub>1} \<notin> \<C>⁻"} y @{text "S\<union>{\<beta>\<^sub>2} \<notin> \<C>⁻"}.
  Entonces, existe @{text "S\<^sub>1"} subconjunto finito de @{text "S\<union>{\<beta>\<^sub>1}"}
  tal que @{text "S\<^sub>1 \<notin> \<C>"}, y existe @{text "S\<^sub>2"} subconjunto finito de
  @{text "S\<union>{\<beta>\<^sub>2}"} tal que @{text "S\<^sub>2 \<notin> \<C>"}. Puesto que @{text "\<beta> \<in> S"},
  @{text "S\<^sub>1 \<subseteq> S\<union>{\<beta>\<^sub>1}"} y @{text "S\<^sub>2 \<subseteq> S\<union>{\<beta>\<^sub>2}"} tenemos que,
  @{text "(S\<^sub>1−{\<beta>\<^sub>1})\<union>(S\<^sub>2−{\<beta>\<^sub>2})\<union>{\<beta>} \<subseteq> S"}.

  También tenemos que @{text "(S\<^sub>1−{\<beta>\<^sub>1})\<union>(S\<^sub>2−{\<beta>\<^sub>2})\<union>{\<beta>}"} es finito ya que
  @{text "S\<^sub>1"} y @{text "S\<^sub>2"} son finitos. Así,
  @{text "(S\<^sub>1−{\<beta>\<^sub>1})\<union>(S\<^sub>2−{\<beta>\<^sub>2})\<union>{\<beta>} \<in> \<C>"} por la definición de @{text "\<C>\<^sup>-"},
  y como
     \newline \hspace*{1cm}
     @{text "\<beta> \<in> (S\<^sub>1−{\<beta>\<^sub>1})\<union>(S\<^sub>2−{\<beta>\<^sub>2})\<union>{\<beta>}"}
  \newline entonces, por ser @{text "\<C>"} una propiedad de consistencia,
  se tiene que
     \newline \hspace*{1cm}
     @{text "((S\<^sub>1−{\<beta>\<^sub>1})\<union>(S\<^sub>2−{\<beta>\<^sub>2})\<union>{\<beta>})\<union>{\<beta>\<^sub>1} \<in> \<C>"}
     \newline \hspace*{1cm}
     @{text "((S\<^sub>1−{\<beta>\<^sub>1})\<union>(S\<^sub>2−{\<beta>\<^sub>2})\<union>{\<beta>})\<union> {\<beta>\<^sub>2} \<in> \<C>"}.

  De esto último tenemos que @{text "S\<^sub>1 \<in> \<C>"} o @{text "S\<^sub>2 \<in> \<C>"}:

  Si @{text "((S\<^sub>1−{\<beta>\<^sub>1})\<union>(S\<^sub>2−{\<beta>\<^sub>2})\<union>{\<beta>})\<union>{\<beta>\<^sub>1}\<in> \<C>"} entonces, puesto que
     \newline \hspace*{1cm}
     @{text "S\<^sub>1 \<subseteq> ((S\<^sub>1−{\<beta>\<^sub>1})\<union>(S\<^sub>2−{\<beta>\<^sub>2})\<union>{\<beta>})\<union>{\<beta>\<^sub>1}"},
  \newline tenemos que @{text "S\<^sub>1\<in> \<C>"} por ser @{text "\<C>"} cerrada por
  subconjuntos.

  De igual forma, si @{text "((S\<^sub>1−{\<beta>\<^sub>1})\<union> (S\<^sub>2−{\<beta>\<^sub>2})\<union>{\<beta>})\<union>{\<beta>\<^sub>2} \<in> \<C>"}
  entonces, puesto que
     \newline \hspace*{1cm}
     @{text "S\<^sub>2 \<subseteq> ((S\<^sub>1−{\<beta>\<^sub>1})\<union>(S\<^sub>2−{\<beta>\<^sub>2})\<union>{\<beta>})\<union>{\<beta>\<^sub>2}"},
  \newline tenemos que @{text "S\<^sub>2 \<in> \<C>"} por ser @{text "\<C>"} cerrada por
  subconjuntos.

  Esto contradice la hipótesis inicial: @{text "S\<^sub>1\<notin> \<C>"} y @{text "S\<^sub>2\<notin> \<C>"}.
  \end{demostracion}

  A continuación formalizamos cada parte de la prueba del teorema anterior.
  La formalización de la parte (a) es la siguiente:
\<close>

lemma caracter_finito_subset:
  assumes "subconj_cerrada \<C>"
  shows "\<C> \<subseteq> \<C>⁻"
proof -
  { fix S
    assume "S \<in> \<C>"
    have "S \<in> \<C>⁻"
    proof -
      { fix S'
        assume "S' \<subseteq> S" and "finite S'"
        hence "S' \<in> \<C>" using  `subconj_cerrada \<C>` and `S \<in> \<C>`
          by (simp add: subconj_cerrada_def)}
      thus ?thesis by (simp add: clausura_cfinito_def)
    qed}
  thus ?thesis by auto
qed

text \<open>
  El siguiente lema formaliza la parte (b) del teorema
  \ref{AlternativaCfinitoP}
\<close>

lemma caracter_finito: "caracter_finito (\<C>⁻)"
proof (unfold caracter_finito_def)
  show "\<forall>S. (S \<in> \<C>⁻) = (\<forall>S'. finite S' \<longrightarrow> S' \<subseteq> S \<longrightarrow> S' \<in> \<C>⁻)"
  proof
    fix  S
    { assume  "S \<in> \<C>⁻"
      hence "\<forall>S'. finite S' \<longrightarrow> S' \<subseteq> S \<longrightarrow> S' \<in> \<C>⁻"
        by(simp add: clausura_cfinito_def)}
    moreover
    { assume "\<forall>S'. finite S' \<longrightarrow> S' \<subseteq> S \<longrightarrow> S' \<in> \<C>⁻"
      hence  "S \<in> \<C>⁻" by(simp add: clausura_cfinito_def)}
    ultimately
    show "(S \<in> \<C>⁻) = (\<forall>S'. finite S' \<longrightarrow> S' \<subseteq> S \<longrightarrow> S' \<in> \<C>⁻)"
      by blast
  qed
qed

text \<open>
  Los siguientes lemas corresponden a la formalización de los 5 casos de
  la parte (c) del teorema \ref{AlternativaCfinitoP}.
\<close>

lemma condicaracterP1:
  assumes "consistenceP \<C>"
  and "subconj_cerrada \<C>"
  and hip: "\<forall>S'\<subseteq>S. finite S' \<longrightarrow> S' \<in> \<C>"
  shows "(\<forall>P. \<not>(atom P \<in> S \<and> (\<not>.atom P) \<in> S))"
(*<*)
proof (rule allI)+
  fix P t
  show "\<not>(atom P  \<in> S \<and> (\<not>.atom P) \<in> S)"
  proof (rule notI)
    assume "atom P \<in> S \<and> (\<not>.atom P) \<in> S"
    hence "{atom P , \<not>.atom P} \<subseteq> S" by simp
    hence "{atom P, \<not>.atom P} \<in> \<C>" using hip by simp
    moreover
    have "\<forall>S. S \<in> \<C> \<longrightarrow> (\<forall>P ts. \<not>(atom P \<in> S \<and> (\<not>.atom P) \<in> S))"
      using `consistenceP \<C>`
      by (simp add: consistenceP_def)
    ultimately
    have "\<not>(atom P \<in> {atom P , \<not>.atom P} \<and>
          (\<not>.atom P) \<in> {atom P, \<not>.atom P})"
      by auto
    thus False by simp
  qed
qed
(*>*)
text\<open> \<close>
lemma condicaracterP2:
  assumes "consistenceP \<C>"
  and "subconj_cerrada \<C>"
  and hip: "\<forall>S'\<subseteq>S. finite S' \<longrightarrow> S' \<in> \<C>"
  shows "FF \<notin> S \<and> (\<not>.TT)\<notin> S"
(*<*)
proof -
  have "FF \<notin> S"
  proof(rule notI)
    assume "FF \<in> S"
    hence "{FF} \<subseteq> S" by simp
    hence "{FF}\<in> \<C>" using hip by simp
    moreover
    have "\<forall>S. S \<in> \<C> \<longrightarrow> FF \<notin> S" using `consistenceP \<C>`
      by (simp add: consistenceP_def)
    ultimately
    have "FF \<notin> {FF}" by auto
    thus False by simp
  qed
  moreover
  have "(\<not>.TT)\<notin> S"
  proof(rule notI)
    assume "(\<not>.TT) \<in> S"
    hence "{\<not>.TT} \<subseteq> S" by simp
    hence "{\<not>.TT}\<in> \<C>" using hip by simp
    moreover
    have "\<forall>S. S \<in> \<C> \<longrightarrow> (\<not>.TT) \<notin> S" using `consistenceP \<C>`
      by (simp add: consistenceP_def)
    ultimately
    have "(\<not>.TT) \<notin> {(\<not>.TT)}" by auto
    thus False by simp
  qed
  ultimately show ?thesis by simp
qed
(*>*)
text\<open> \<close>
lemma condicaracterP3:
  assumes "consistenceP \<C>"
  and "subconj_cerrada \<C>"
  and hip: "\<forall>S'\<subseteq>S. finite S' \<longrightarrow> S' \<in> \<C>"
  shows "\<forall>F. (\<not>.\<not>.F) \<in> S \<longrightarrow>  S \<union> {F} \<in> \<C>⁻"
(*<*)
proof (rule allI)
  fix F
  show "(\<not>.\<not>.F) \<in> S \<longrightarrow>  S \<union> {F} \<in> \<C>⁻"
  proof (rule impI)
    assume "(\<not>.\<not>.F) \<in> S"
    show "S \<union> {F} \<in> \<C>⁻"
    proof (unfold clausura_cfinito_def)
      show "S \<union> {F} \<in> {S. \<forall>S'\<subseteq>S. finite S' \<longrightarrow> S' \<in> \<C>}"
      proof (rule allI impI CollectI)+
        fix S'
        assume "S' \<subseteq> S \<union> {F}" and "finite S'"
        show "S' \<in> \<C>"
        proof -
          have "S' - {F} \<union> {\<not>.\<not>.F}  \<subseteq> S"
            using `(\<not>.\<not>.F) \<in> S` and  `S'\<subseteq> S \<union> {F}` by auto
          moreover
          have "finite (S' - {F} \<union> {\<not>.\<not>.F})" using `finite S'` by auto
          ultimately
          have "(S' - {F} \<union> {\<not>.\<not>.F}) \<in> \<C>" using hip  by simp
          moreover
          have "(\<not>.\<not>.F) \<in> (S' - {F} \<union> {\<not>.\<not>.F})" by simp
          ultimately
          have "(S' - {F} \<union> {\<not>.\<not>.F})\<union> {F} \<in> \<C>"
            using `consistenceP \<C>` by (simp add: consistenceP_def)
          moreover
          have "(S' - {F} \<union> {\<not>.\<not>.F})\<union> {F} = (S' \<union> {\<not>.\<not>.F})\<union> {F}"
            by auto
          ultimately
          have "(S' \<union> {\<not>.\<not>.F})\<union> {F} \<in> \<C>" by simp
          moreover
          have  "S' \<subseteq> (S' \<union> {\<not>.\<not>.F})\<union> {F}" by auto
          ultimately
          show "S'\<in> \<C>" using `subconj_cerrada \<C>`
            by (simp add: subconj_cerrada_def)
        qed
      qed
    qed
  qed
qed
(*>*)
text\<open> \<close>
lemma condicaracterP4:
  assumes "consistenceP \<C>"
  and "subconj_cerrada \<C>"
  and hip: "\<forall>S'\<subseteq>S. finite S' \<longrightarrow> S' \<in> \<C>"
  shows "(\<forall>F. ((FormulaAlfa F) \<and> F \<in> S) \<longrightarrow> (S \<union> {Comp1 F, Comp2 F}) \<in> \<C>⁻)"
(*<*)
proof (rule allI)
  fix F
  show "((FormulaAlfa F) \<and> F \<in> S) \<longrightarrow> S \<union> {Comp1 F, Comp2 F} \<in> \<C>⁻"
  proof (rule impI)
    assume "(FormulaAlfa F) \<and> F \<in> S"
    hence "(FormulaAlfa F)" and "F \<in> S" by auto
    show "S \<union> {Comp1 F, Comp2 F} \<in> \<C>⁻"
    proof (unfold clausura_cfinito_def)
      show "S \<union> {Comp1 F, Comp2 F} \<in> {S. \<forall>S'\<subseteq>S. finite S' \<longrightarrow> S' \<in> \<C>}"
      proof (rule allI impI CollectI)+
        fix S'
        assume "S' \<subseteq> S \<union> {Comp1 F, Comp2 F}"  and  "finite S'"
        show "S' \<in> \<C>"
        proof -
          have "S' - {Comp1 F, Comp2 F} \<union> {F}  \<subseteq> S"
            using `F \<in> S` and  `S'\<subseteq> S \<union> {Comp1 F, Comp2 F}` by auto
          moreover
          have "finite (S' - {Comp1 F, Comp2 F} \<union> {F})"
            using `finite S'` by auto
          ultimately
          have "(S' - {Comp1 F, Comp2 F} \<union> {F}) \<in> \<C>" using hip  by simp
          moreover
          have "F \<in> (S' - {Comp1 F, Comp2 F} \<union> {F})" by simp
          ultimately
          have "(S' - {Comp1 F, Comp2 F} \<union> {F}) \<union> {Comp1 F, Comp2 F} \<in> \<C>"
            using `consistenceP \<C>` `FormulaAlfa F`
            by (simp add: consistenceP_def)
          moreover
          have "(S' - {Comp1 F, Comp2 F} \<union> {F}) \<union> {Comp1 F, Comp2 F} =
                (S' \<union> {F}) \<union> {Comp1 F, Comp2 F}"
            by auto
          ultimately
          have "(S' \<union> {F}) \<union> {Comp1 F, Comp2 F} \<in> \<C>" by simp
          moreover
          have "S' \<subseteq> (S' \<union> {F}) \<union> {Comp1 F, Comp2 F}" by auto
          ultimately
          show "S'\<in> \<C>" using `subconj_cerrada \<C>`
            by (simp add: subconj_cerrada_def)
        qed
      qed
    qed
  qed
qed
(*>*)
text\<open> \<close>
lemma condicaracterP5:
  assumes "consistenceP \<C>"
  and "subconj_cerrada \<C>"
  and hip: "\<forall>S'\<subseteq>S. finite S' \<longrightarrow> S' \<in> \<C>"
  shows "\<forall>F. FormulaBeta F \<and> F \<in> S \<longrightarrow> S \<union> {Comp1 F} \<in> \<C>⁻ \<or> S \<union> {Comp2 F} \<in> \<C>⁻"
(*<*)
proof (rule allI)
  fix F
  show "FormulaBeta F \<and> F \<in> S \<longrightarrow> S \<union> {Comp1 F} \<in> \<C>⁻ \<or> S \<union> {Comp2 F} \<in> \<C>⁻"
  proof (rule impI)
    assume "(FormulaBeta F) \<and> F \<in> S"
    hence "FormulaBeta F" and "F \<in> S" by auto
    show "S \<union> {Comp1 F} \<in> \<C>⁻ \<or> S \<union> {Comp2 F} \<in> \<C>⁻"
    proof (rule ccontr)
      assume "\<not>(S \<union> {Comp1 F} \<in> \<C>⁻ \<or> S \<union> {Comp2 F} \<in> \<C>⁻)"
      hence "S \<union> {Comp1 F} \<notin> \<C>⁻ \<and> S \<union> {Comp2 F} \<notin> \<C>⁻" by simp
      hence 1: "\<exists> S1. (S1 \<subseteq> S \<union> {Comp1 F} \<and> finite S1 \<and> S1 \<notin> \<C>)"
        and 2: "\<exists> S2. (S2 \<subseteq> S \<union> {Comp2 F} \<and> finite S2 \<and> S2 \<notin> \<C>)"
        by (auto simp add: clausura_cfinito_def)
      obtain S1  where S1: "S1 \<subseteq> S \<union> {Comp1 F} \<and> finite S1 \<and> S1 \<notin> \<C>"
        using 1 by auto
      obtain S2 where  S2: "S2 \<subseteq> S \<union> {Comp2 F} \<and> finite S2 \<and> S2 \<notin> \<C>"
        using 2 by auto
      have "(S1-{Comp1 F}) \<union> (S2-{Comp2 F}) \<union> {F} \<subseteq> S"
        using `F \<in> S` S1 S2 by auto
      moreover
      have "finite ((S1-{Comp1 F}) \<union> (S2-{Comp2 F}) \<union> {F})"
        using S1 and S2 by simp
      ultimately
      have "(S1-{Comp1 F}) \<union> (S2-{Comp2 F}) \<union> {F} \<in> \<C>" using hip by simp
      moreover
      have "F \<in> (S1-{Comp1 F}) \<union> (S2-{Comp2 F}) \<union> {F}" by simp
      ultimately
      have 3: "((S1-{Comp1 F}) \<union> (S2-{Comp2 F}) \<union> {F} \<union> {Comp1 F}) \<in> \<C> \<or>
               ((S1-{Comp1 F}) \<union> (S2-{Comp2 F}) \<union> {F} \<union> {Comp2 F}) \<in> \<C>"
        using `consistenceP \<C>` `FormulaBeta F`
        by (simp add: consistenceP_def)
      hence "S1 \<in> \<C> \<or> S2 \<in> \<C>"
      proof (cases)
        assume "((S1-{Comp1 F}) \<union> (S2-{Comp2 F}) \<union> {F} \<union> {Comp1 F}) \<in> \<C>"
        moreover
        have "S1 \<subseteq> ((S1-{Comp1 F}) \<union> (S2-{Comp2 F}) \<union> {F} \<union> {Comp1 F})"
          by auto
        ultimately
        have "S1 \<in> \<C>"  using `subconj_cerrada \<C>`
          by (simp add: subconj_cerrada_def)
        thus ?thesis by simp
      next
        assume "\<not>((S1-{Comp1 F}) \<union> (S2-{Comp2 F}) \<union> {F} \<union> {Comp1 F}) \<in> \<C>"
        hence "((S1-{Comp1 F}) \<union> (S2-{Comp2 F}) \<union> {F} \<union> {Comp2 F}) \<in> \<C>"
          using 3 by simp
        moreover
        have "S2 \<subseteq> ((S1-{Comp1 F}) \<union> (S2-{Comp2 F}) \<union> {F} \<union> {Comp2 F})"
          by auto
        ultimately
        have "S2 \<in> \<C>"  using `subconj_cerrada \<C>`
          by (simp add: subconj_cerrada_def)
        thus ?thesis by simp
      qed
      thus False using S1 and S2 by simp
    qed
  qed
qed
(*>*)

text \<open>
  Por último, se demuestra que si @{text "\<C>"} es una propiedad de
  consistencia proposicional que es cerrada por subconjuntos entonces
  @{text "\<C>⁻"} es de carácter finito.
\<close>

theorem cfinito_consistenceP:
  assumes hip1: "consistenceP \<C>" and hip2: "subconj_cerrada \<C>"
  shows "consistenceP (\<C>⁻)"
proof -
  { fix S
    assume "S \<in> \<C>⁻"
    hence hip3: "\<forall>S'\<subseteq>S. finite S' \<longrightarrow> S' \<in> \<C>"
      by (simp add: clausura_cfinito_def)
    have "(\<forall>P.  \<not>(atom P \<in> S \<and> (\<not>.atom P) \<in> S)) \<and>
          FF \<notin> S \<and> (\<not>.TT) \<notin> S \<and>
          (\<forall>F. (\<not>.\<not>.F) \<in> S \<longrightarrow> S \<union> {F} \<in> \<C>⁻) \<and>
          (\<forall>F. ((FormulaAlfa F) \<and> F \<in> S) \<longrightarrow> (S \<union> {Comp1 F, Comp2 F}) \<in> \<C>⁻) \<and>
          (\<forall>F. ((FormulaBeta F) \<and> F \<in> S) \<longrightarrow>
               (S \<union> {Comp1 F} \<in> \<C>⁻) \<or> (S \<union> {Comp2 F} \<in> \<C>⁻))"
      using
        condicaracterP1[OF hip1 hip2 hip3]  condicaracterP2[OF hip1 hip2 hip3]
        condicaracterP3[OF hip1 hip2 hip3]  condicaracterP4[OF hip1 hip2 hip3]
        condicaracterP5[OF hip1 hip2 hip3]  by auto }
  thus ?thesis by (simp add: consistenceP_def)
qed

(*<*)
end
(*>*)


section \<open> List Reversal -- Different Approaches \<close>

theory List_Reversal
  imports "ITree_VCG.ITree_VCG"
begin

zstore state =
  xs :: "int list"
  ys :: "int list"
  i :: nat

procedure reverse0 "XS :: int list" over state =
"ys := []; i := 0;
 while i < length XS inv ys = rev (take i XS) var length XS - i
 do
    ys := XS!i # ys;
    i := i + 1
 od"

procedure reverse1 "XS :: int list" over state =
"ys := [];
 for x in XS inv j. ys = rev (take j XS) do ys := x # ys od"

procedure reverse2 "XS :: int list" over state =
"xs := XS; ys := [];
 while xs \<noteq> []
 inv ys = rev (take (length XS - length xs) XS) \<and> xs = drop (length XS - length xs) XS
 var length xs
 do
    ys := hd xs # ys;
    xs := tl xs
 od"

procedure reverse2a "XS :: int list" over state =
"xs := XS; ys := [];
 while xs \<noteq> []
 inv XS = rev ys @ xs var length xs
 do
    ys := hd xs # ys;
    xs := tl xs
 od"

procedure reverse2b "XS :: int list" over state =
"xs := XS; ys := [];
 while xs \<noteq> []
 inv length XS = length xs + length ys \<and> (\<forall> i < length ys. XS!i = ys ! (length ys - Suc i)) \<and> (\<forall> i\<in>{length ys..<length XS}. XS!i = xs ! (i - length ys))
 var length xs
 do
    ys := hd xs # ys;
    xs := tl xs
 od"

execute "reverse0 [1,2,3,4]"
execute "reverse1 [1,2,3,4]"
execute "reverse2 [1,2,3,4]"

lemma reverse0_correct: "H[True] reverse0 XS [ys = rev XS]"
  by (vcg, simp add: take_Suc_conv_app_nth)

lemma reverse1_correct: "H[True] reverse1 XS [ys = rev XS]"
  by (vcg, simp add: take_Suc_conv_app_nth)

lemma reverse2_correct: "H[True] reverse2 XS [ys = rev XS]"
proof vcg
  fix xs :: "\<int> list"
  assume
    "xs = drop (length XS - length xs) XS" and
    "xs \<noteq> []"
  thus "hd xs # rev (take (length XS - length xs) XS) = rev (take (length XS - (length xs - Suc 0)) XS)"
    by (smt (verit, del_insts) Cons_nth_drop_Suc Suc_pred diff_le_self diff_less drop_all drop_rev hd_drop_conv_nth leD length_drop length_greater_0_conv length_rev not_less_eq rev_nth)

next
  fix xs :: "\<int> list"
  assume
    "xs = drop (length XS - length xs) XS" and
    "xs \<noteq> []"
  thus "tl xs = drop (length XS - (length xs - Suc 0)) XS"
    by (metis (no_types, lifting) Cons_nth_drop_Suc One_nat_def Suc_diff_eq_diff_pred Suc_diff_le diff_le_self diff_less drop_Nil length_drop length_greater_0_conv list.exhaust_sel list.inject)
qed

lemma reverse2a_correct: "H[True] reverse2a XS [ys = rev XS]"
  by vcg

lemma reverse2b_correct: "H[True] reverse2b XS [ys = rev XS]"
  apply vcg
  apply (metis add_diff_cancel_right atLeastLessThan_iff diff_self_eq_0 hd_conv_nth le_add_diff_inverse2 length_greater_0_conv less_Suc_eq less_Suc_eq_le less_add_same_cancel2 nth_Cons_0 nth_Cons_pos plus_1_eq_Suc)
  apply (metis Suc_diff_Suc Suc_le_lessD list.exhaust_sel nth_Cons_Suc)
  apply (simp add: list_eq_iff_nth_eq)
  apply (simp add: rev_nth)
  done

end


(*  Title:      HOL/Isar_Examples/Cantor.thy
    Author:     Makarius
*)

section \<open>Cantor's Theorem\<close>

theory Cantor
  imports Main
begin

subsection \<open>Mathematical statement and proof\<close>

text \<open>
  Cantor's Theorem states that there is no surjection from
  a set to its powerset.  The proof works by diagonalization.  E.g.\ see
  \<^item> \<^url>\<open>http://mathworld.wolfram.com/CantorDiagonalMethod.html\<close>
  \<^item> \<^url>\<open>https://en.wikipedia.org/wiki/Cantor's_diagonal_argument\<close>
\<close>

theorem Cantor: "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. A = f x"
proof
  assume "\<exists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. A = f x"
  then obtain f :: "'a \<Rightarrow> 'a set" where *: "\<forall>A. \<exists>x. A = f x" ..
  let ?notin = "{x. x \<notin> f x}"
  from * obtain a where mem: "?notin = f a" by blast
  thus False
  proof (cases "a \<in> ?notin")
    case True
    then show ?thesis using mem by blast
  next
    case False
    then show ?thesis using mem by blast
  qed
qed

subsection \<open>Automated proofs\<close>

text \<open>
  These automated proofs are much shorter, but lack information why and how it
  works.
\<close>

theorem "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. f x = A"
  by best

theorem "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. f x = A"
  by force

theorem "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. f x = A"
  by bestsimp

subsection \<open>Elementary version in higher-order predicate logic\<close>

text \<open>
  The subsequent formulation bypasses set notation of HOL; it uses elementary
  \<open>\<lambda>\<close>-calculus and predicate logic, with standard introduction and elimination
  rules. This also shows that the proof does not require classical reasoning.
\<close>

lemma iff_contradiction:
  assumes *: "\<not> A \<longleftrightarrow> A"
  shows False
proof (rule notE)
  show "\<not>A"
  proof
    assume A
    with * have "\<not>A" ..
    thus False using \<open>A\<close> ..
  qed
  with * show A ..
qed

theorem Cantor': "\<nexists>f :: 'a \<Rightarrow> 'a \<Rightarrow> bool. \<forall>A. \<exists>x. A = f x"
proof
  assume "\<exists>f :: 'a \<Rightarrow> 'a \<Rightarrow> bool. \<forall>A. \<exists>x. A = f x"
  then obtain f :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where *: "\<forall>A. \<exists>x. A = f x" ..
  let ?notin_f = "\<lambda>x. \<not>f x x"
  from * have "\<exists>x. ?notin_f = f x" ..
  then obtain a where "?notin_f = f a" ..
  then have "\<not> f a a \<longleftrightarrow> f a a" by (rule arg_cong)
  thus False by (rule iff_contradiction)
qed

subsection \<open>Classic Isabelle/HOL example\<close>

text \<open>
  The following treatment of Cantor's Theorem follows the classic example from
  the early 1990s, e.g.\ see the file @{verbatim "92/HOL/ex/set.ML"} in
  Isabelle92 or @{cite \<open>\S18.7\<close> "paulson-isa-book"}. The old tactic scripts
  synthesize key information of the proof by refinement of schematic goal
  states. In contrast, the Isar proof needs to say explicitly what is proven.

  \<^bigskip>
  Cantor's Theorem states that every set has more subsets than it has
  elements. It has become a favourite basic example in pure higher-order logic
  since it is so easily expressed:

  @{text [display]
  \<open>\<forall>f::\<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool. \<exists>S::\<alpha> \<Rightarrow> bool. \<forall>x::\<alpha>. f x \<noteq> S\<close>}

  Viewing types as sets, \<open>\<alpha> \<Rightarrow> bool\<close> represents the powerset of \<open>\<alpha>\<close>. This
  version of the theorem states that for every function from \<open>\<alpha>\<close> to its
  powerset, some subset is outside its range. The Isabelle/Isar proofs below
  uses HOL's set theory, with the type \<open>\<alpha> set\<close> and the operator \<open>range :: (\<alpha> \<Rightarrow>
  \<beta>) \<Rightarrow> \<beta> set\<close>.
\<close>

theorem "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
proof
  let ?S = "{x. x \<notin> f x}"
  show "?S \<notin> range f"
  proof
    assume "?S \<in> range f"
    then obtain y where "?S = f y" ..
    thus False
    proof (rule equalityCE)
      assume c1: "y \<in> f y"
      assume "y \<in> ?S"
      hence "y \<notin> f y" ..
      with c1 show False by contradiction
    next
      assume c2: "y \<notin> ?S"
      assume "y \<notin> f y"
      hence "y \<in> ?S" ..
      with c2 show False by contradiction
    qed
  qed
qed

text \<open>
  How much creativity is required? As it happens, Isabelle can prove this
  theorem automatically using best-first search. Depth-first search would
  diverge, but best-first search successfully navigates through the large
  search space. The context of Isabelle's classical prover contains rules for
  the relevant constructs of HOL's set theory.
\<close>

theorem "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
  by best

end


(* Title:  Rtrancl_On.thy
   Author: Lars Noschinski, TU München
   Author: René Neumann, TU München
*)

theory Rtrancl_On
imports Main
begin

section {* Reflexive-Transitive Closure on a Domain *}

text {*
  In this section we introduce a variant of the reflexive-transitive closure
  of a relation which is useful to formalize the reachability relation on
  digraphs.
*}

inductive_set
  rtrancl_on :: "'a set \<Rightarrow> 'a rel \<Rightarrow> 'a rel"
  for F :: "'a set" and r :: "'a rel"
where
    rtrancl_on_refl [intro!, Pure.intro!, simp]: "a \<in> F \<Longrightarrow> (a, a) \<in> rtrancl_on F r"
  | rtrancl_on_into_rtrancl_on [Pure.intro]:
      "(a, b) \<in> rtrancl_on F r  \<Longrightarrow> (b, c) \<in> r \<Longrightarrow> c \<in> F
      \<Longrightarrow> (a, c) \<in> rtrancl_on F r"

definition symcl :: "'a rel \<Rightarrow> 'a rel" ("(_\<^sup>s)" [1000] 999) where
  "symcl R = R \<union> (\<lambda>(a,b). (b,a)) ` R"

lemma in_rtrancl_on_in_F:
  assumes "(a,b) \<in> rtrancl_on F r" shows "a \<in> F" "b \<in> F"
  using assms by induct auto

lemma rtrancl_on_induct[consumes 1, case_names base step, induct set: rtrancl_on]:
  assumes "(a, b) \<in> rtrancl_on F r"
    and "a \<in> F \<Longrightarrow> P a"
        "\<And>y z. \<lbrakk>(a, y) \<in> rtrancl_on F r; (y,z) \<in> r; y \<in> F; z \<in> F; P y\<rbrakk> \<Longrightarrow> P z"
  shows "P b"
  using assms by (induct a b) (auto dest: in_rtrancl_on_in_F)

lemma rtrancl_on_trans:
  assumes "(a,b) \<in> rtrancl_on F r" "(b,c) \<in> rtrancl_on F r" shows "(a,c) \<in> rtrancl_on F r"
  using assms(2,1)
  by induct (auto intro: rtrancl_on_into_rtrancl_on)

lemma converse_rtrancl_on_into_rtrancl_on:
  assumes "(a,b) \<in> r" "(b, c) \<in> rtrancl_on F r" "a \<in> F"
  shows "(a, c) \<in> rtrancl_on F r"
proof -
  have "b \<in> F" using \<open>(b,c) \<in> _\<close> by (rule in_rtrancl_on_in_F)
  show ?thesis
    apply (rule rtrancl_on_trans)
    apply (rule rtrancl_on_into_rtrancl_on)
    apply (rule rtrancl_on_refl)
    by fact+
qed

lemma rtrancl_on_converseI:
  assumes "(y, x) \<in> rtrancl_on F r" shows "(x, y) \<in> rtrancl_on F (r\<inverse>)"
  using assms
proof induct
  case (step a b)
  then have "(b,b) \<in> rtrancl_on F (r\<inverse>)" "(b,a) \<in> r\<inverse>" by auto
  then show ?case using step
    by (metis rtrancl_on_trans rtrancl_on_into_rtrancl_on)
qed auto

theorem rtrancl_on_converseD:
  assumes "(y, x) \<in> rtrancl_on F (r\<inverse>)" shows "(x, y) \<in> rtrancl_on F r"
  using assms by - (drule rtrancl_on_converseI, simp)

lemma converse_rtrancl_on_induct[consumes 1, case_names base step, induct set: rtrancl_on]:
  assumes major: "(a, b) \<in> rtrancl_on F r"
    and cases: "b \<in> F \<Longrightarrow> P b"
       "\<And>x y. \<lbrakk>(x,y) \<in> r; (y,b) \<in> rtrancl_on F r; x \<in> F; y \<in> F; P y\<rbrakk> \<Longrightarrow> P x"
  shows "P a"
  using rtrancl_on_converseI[OF major] cases
  by induct (auto intro: rtrancl_on_converseD)

lemma converse_rtrancl_on_cases:
  assumes "(a, b) \<in> rtrancl_on F r"
  obtains (base) "a = b" "b \<in> F"
    | (step) c where "(a,c) \<in> r" "(c,b) \<in> rtrancl_on F r"
  using assms by induct auto

lemma rtrancl_on_sym:
  assumes "sym r" shows "sym (rtrancl_on F r)"
using assms by (auto simp: sym_conv_converse_eq intro: symI dest: rtrancl_on_converseI)

lemma rtrancl_on_mono:
  assumes "s \<subseteq> r" "F \<subseteq> G" "(a,b) \<in> rtrancl_on F s" shows "(a,b) \<in> rtrancl_on G r"
  using assms(3,1,2)
proof induct
  case (step x y) show ?case
    using step assms by (intro converse_rtrancl_on_into_rtrancl_on[OF _ step(5)]) auto
qed auto

lemma rtrancl_consistent_rtrancl_on:
  assumes "(a,b) \<in> r\<^sup>*"
  and "a \<in> F" "b \<in> F"
  and consistent: "\<And>a b. \<lbrakk> a \<in> F; (a,b) \<in> r \<rbrakk> \<Longrightarrow> b \<in> F"
  shows "(a,b) \<in> rtrancl_on F r"
  using assms(1-3)
proof (induction rule: converse_rtrancl_induct)
  case (step y z) then have "z \<in> F" by (rule_tac consistent) simp
  with step have "(z,b) \<in> rtrancl_on F r" by simp
  with step.prems `(y,z) \<in> r` `z \<in> F` show ?case
    using converse_rtrancl_on_into_rtrancl_on
    by metis
qed simp

lemma rtrancl_on_rtranclI:
  "(a,b) \<in> rtrancl_on F r \<Longrightarrow> (a,b) \<in> r\<^sup>*"
  by (induct rule: rtrancl_on_induct) simp_all

lemma rtrancl_on_sub_rtrancl:
  "rtrancl_on F r \<subseteq> r^*"
  using rtrancl_on_rtranclI
  by auto

end


(* Title: Geometric.thy
   Author: Andreas Lochbihler, ETH Zurich *)

subsection \<open>The geometric distribution\<close>

theory Geometric imports
  Bernoulli
  While_SPMF
begin

text \<open>
  We define the geometric distribution as a least fixpoint, which is more elegant than
  as a loop. To prove probabilistic termination, we prove it equivalent to a loop and use
  the proof rules for probabilistic termination.
\<close>

context notes [[function_internals]] begin
partial_function (spmf) geometric_spmf :: "real \<Rightarrow> nat spmf" where
  "geometric_spmf p = do {
     b \<leftarrow> bernoulli p;
     if b then return_spmf 0 else map_spmf ((+) 1) (geometric_spmf p)
  }"
end

lemma geometric_spmf_fixp_induct [case_names adm bottom step]:
  assumes "spmf.admissible P"
    and "P (\<lambda>geometric_spmf. return_pmf None)"
    and "\<And>geometric_spmf'. P geometric_spmf' \<Longrightarrow> P (\<lambda>p. bernoulli p \<bind> (\<lambda>b. if b then return_spmf 0 else map_spmf ((+) 1) (geometric_spmf' p)))"
  shows "P geometric_spmf"
  using assms by(rule geometric_spmf.fixp_induct)

lemma spmf_geometric_nonpos: "p \<le> 0 \<Longrightarrow> geometric_spmf p = return_pmf None"
  by(induction rule: geometric_spmf_fixp_induct) simp_all

lemma spmf_geometric_ge_1: "1 \<le> p \<Longrightarrow> geometric_spmf p = return_spmf 0"
  by(simp add: geometric_spmf.simps)

context
  fixes p :: real
  and body :: "bool \<times> nat \<Rightarrow> (bool \<times> nat) spmf"
  defines [simp]: "body \<equiv> \<lambda>(b, x). map_spmf (\<lambda>b'. (\<not> b', x + (if b' then 0 else 1))) (bernoulli p)"
begin

interpretation loop_spmf fst body
  rewrites "body \<equiv> \<lambda>(b, x). map_spmf (\<lambda>b'. (\<not> b', x + (if b' then 0 else 1))) (bernoulli p)"
  by(fact body_def)

lemma geometric_spmf_conv_while:
  shows "geometric_spmf p = map_spmf snd (while (True, 0))"
proof -
  have "map_spmf ((+) x) (geometric_spmf p) = map_spmf snd (while (True, x))" (is "?lhs = ?rhs") for x
  proof(rule spmf.leq_antisym)
    show "ord_spmf (=) ?lhs ?rhs"
    proof(induction arbitrary: x rule: geometric_spmf_fixp_induct)
      case adm show ?case by simp
      case bottom show ?case by simp
      case (step geometric')
      show ?case using step.IH[of "Suc x"]
        apply(rewrite while.simps)
        apply(clarsimp simp add: map_spmf_bind_spmf bind_map_spmf intro!: ord_spmf_bind_reflI)
        apply(rewrite while.simps)
        apply(clarsimp simp add: spmf.map_comp o_def)
        done
    qed
    have "ord_spmf (=) ?rhs ?lhs"
      and "ord_spmf (=) (map_spmf snd (while (False, x))) (return_spmf x)"
    proof(induction arbitrary: x and x rule: while_fixp_induct)
      case adm show ?case by simp
      case bottom case 1 show ?case by simp
      case bottom case 2 show ?case by simp
    next
      case (step while')
      case 1 show ?case using step.IH(1)[of "Suc x"] step.IH(2)[of x]
        by(rewrite geometric_spmf.simps)(clarsimp simp add: map_spmf_bind_spmf bind_map_spmf spmf.map_comp o_def intro!: ord_spmf_bind_reflI)
      case 2 show ?case by simp
    qed
    then show "ord_spmf (=) ?rhs ?lhs" by -
  qed
  from this[of 0] show ?thesis by(simp cong: map_spmf_cong)
qed

lemma lossless_geometric [simp]: "lossless_spmf (geometric_spmf p) \<longleftrightarrow> p > 0"
proof(cases "0 < p \<and> p < 1")
  case True
  let ?body = "\<lambda>(b, x :: nat). map_spmf (\<lambda>b'. (\<not> b', x + (if b' then 0 else 1))) (bernoulli p)"
  have "lossless_spmf (while (True, 0))"
  proof(rule termination_0_1_immediate)
    have "{x. x} = {True}" by auto
    then show "p \<le> spmf (map_spmf fst (?body s)) False" for s :: "bool \<times> nat" using True
      by(cases s)(simp add: spmf.map_comp o_def spmf_map vimage_def spmf_conv_measure_spmf[symmetric])
    show "0 < p" using True by simp
  qed(clarsimp)
  with True show ?thesis by(simp add: geometric_spmf_conv_while)
qed(auto simp add: spmf_geometric_nonpos spmf_geometric_ge_1)

end

lemma spmf_geometric:
  assumes p: "0 < p" "p < 1"
  shows "spmf (geometric_spmf p) n = (1 - p) ^ n * p" (is "?lhs n = ?rhs n")
proof(rule spmf_ub_tight)
  fix n
  have "ennreal (?lhs n) \<le> ennreal (?rhs n)" using p
  proof(induction arbitrary: n rule: geometric_spmf_fixp_induct)
    case adm show ?case by(rule cont_intro)+
    case bottom show ?case by simp
    case (step geometric_spmf')
    then show ?case
      by(cases n)(simp_all add: ennreal_spmf_bind nn_integral_measure_spmf UNIV_bool nn_integral_count_space_finite ennreal_mult spmf_map vimage_def mult.assoc spmf_conv_measure_spmf[symmetric] mult_mono split: split_indicator)
  qed
  then show "?lhs n \<le> ?rhs n" using p by(simp)
next
  have "(\<Sum>i. ennreal (p * (1 - p) ^ i)) = ennreal (p * (1 / (1 - (1 - p))))" using p
    by (intro suminf_ennreal_eq sums_mult geometric_sums) auto
  then show "(\<Sum>\<^sup>+ x. ennreal ((1 - p) ^ x * p)) = weight_spmf (geometric_spmf p)"
    using lossless_geometric[of p] p unfolding lossless_spmf_def
    by (simp add: nn_integral_count_space_nat field_simps)
qed

end