(*
  File:    Pi_pmf.thy
  Authors: Manuel Eberl, Max W. Haslbeck
*)
section \<open>Theorems about the Geometric Distribution\<close>
theory Geometric_PMF
  imports
    "HOL-Probability.Probability"
    Pi_pmf
    "Monad_Normalisation.Monad_Normalisation"
begin

lemma geometric_sums_times_n:
  fixes c::"'a::{banach,real_normed_field}"
  assumes "norm c < 1"
  shows "(\<lambda>n. c^n * of_nat n) sums (c / (1 - c)\<^sup>2)"
proof -
  have "(\<lambda>n. c * z ^ n) sums (c / (1 - z))" if "norm z < 1" for z
    using geometric_sums sums_mult that by fastforce
  moreover have "((\<lambda>z. c / (1 - z)) has_field_derivative (c / (1 - c)\<^sup>2)) (at c)"
      using assms by (auto intro!: derivative_eq_intros simp add: semiring_normalization_rules)
  ultimately have "(\<lambda>n. diffs (\<lambda>n. c) n * c ^ n) sums (c / (1 - c)\<^sup>2)"
    using assms by (intro termdiffs_sums_strong)
  then have "(\<lambda>n. of_nat (Suc n) * c ^ (Suc n)) sums (c / (1 - c)\<^sup>2)"
    unfolding diffs_def by (simp add: power_eq_if mult.assoc)
  then show ?thesis
    by (subst (asm) sums_Suc_iff) (auto simp add: mult.commute)
qed

lemma geometric_sums_times_norm:
  fixes c::"'a::{banach,real_normed_field}"
  assumes "norm c < 1"
  shows "(\<lambda>n. norm (c^n * of_nat n)) sums (norm c / (1 - norm c)\<^sup>2)"
proof -
  have "norm (c^n * of_nat n) = (norm c) ^ n * of_nat n" for n::nat
    by (simp add: norm_power norm_mult)
  then show ?thesis
    using geometric_sums_times_n[of "norm c"] assms
    by force
qed

lemma integrable_real_geometric_pmf:
  assumes "p \<in> {0<..1}"
  shows   "integrable (geometric_pmf p) real"
proof -
  have "summable (\<lambda>x. p * ((1 - p) ^ x * real x))"
    using geometric_sums_times_norm[of "1 - p"] assms
    by (intro summable_mult) (auto simp: sums_iff)
  hence "summable (\<lambda>x. (1 - p) ^ x * real x)"
    by (rule summable_mult_D) (use assms in auto)
  thus ?thesis
    unfolding measure_pmf_eq_density using assms
    by (subst integrable_density)
       (auto simp: integrable_count_space_nat_iff mult_ac)
qed

lemma expectation_geometric_pmf:
  assumes "p \<in> {0<..1}"
  shows   "measure_pmf.expectation (geometric_pmf p) real = (1 - p) / p"
proof -
  have "(\<lambda>n. p * ((1 - p) ^ n * n)) sums (p * ((1 - p) / p^2))"
    using assms geometric_sums_times_n[of "1-p"] by (intro sums_mult) auto
  moreover have "(\<lambda>n. p * ((1 - p) ^ n * n)) = (\<lambda>n. (1 - p) ^ n * p  * real n)"
    by auto
  ultimately have *: "(\<lambda>n. (1 - p) ^ n * p  * real n) sums ((1 - p) / p)"
    using assms sums_subst by (auto simp add: power2_eq_square)
  have "measure_pmf.expectation (geometric_pmf p) real =
        (\<integral>n. pmf (geometric_pmf p) n * real n \<partial>count_space UNIV)"
    unfolding measure_pmf_eq_density by (subst integral_density) auto
  also have "integrable (count_space UNIV) (\<lambda>n. pmf (geometric_pmf p) n * real n)"
    using * assms unfolding integrable_count_space_nat_iff by (simp add: sums_iff)
  hence "(\<integral>n. pmf (geometric_pmf p) n * real n \<partial>count_space UNIV) = (1 - p) / p"
    using * assms by (subst integral_count_space_nat) (simp_all add: sums_iff)
  finally show ?thesis by auto
qed

lemma nn_integral_geometric_pmf:
  assumes "p \<in> {0<..1}"
  shows   "nn_integral (geometric_pmf p) real = (1 - p) / p"
 using assms expectation_geometric_pmf integrable_real_geometric_pmf
  by (subst nn_integral_eq_integral) auto

lemma geometric_bind_pmf_unfold:
  assumes "p \<in> {0<..1}"
  shows "geometric_pmf p =
     do {b \<leftarrow> bernoulli_pmf p;
         if b then return_pmf 0 else map_pmf Suc (geometric_pmf p)}"
proof -
  have *: "(Suc -` {i}) = (if i = 0 then {} else {i - 1})" for i
    by force
  have "pmf (geometric_pmf p) i =
        pmf (bernoulli_pmf p \<bind>
            (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf p)))
            i" for i
  proof -
    have "pmf (geometric_pmf p) i =
          (if i = 0 then p else (1 - p) * pmf (geometric_pmf p) (i - 1))"
      using assms by (simp add: power_eq_if)
    also have "\<dots> = (if i = 0  then p else (1 - p) * pmf (map_pmf Suc (geometric_pmf p)) i)"
      by (simp add: pmf_map indicator_def measure_pmf_single *)
    also have "\<dots> = measure_pmf.expectation (bernoulli_pmf p)
          (\<lambda>x. pmf (if x then return_pmf 0 else map_pmf Suc (geometric_pmf p)) i)"
      using assms by (auto simp add: pmf_map *)
    also have "\<dots> = pmf (bernoulli_pmf p \<bind>
                   (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf p)))
                   i"
      by (auto simp add: pmf_bind)
    finally show ?thesis .
  qed
  then show ?thesis
    using pmf_eqI by blast
qed

lemma "p \<in> {0<..<1} \<Longrightarrow> set_pmf (geometric_pmf p) = UNIV"
  by (auto simp add: measure_pmf_single set_pmf_def)

lemma "set_pmf (geometric_pmf 1) = 0"
  by (auto simp add: measure_pmf_single set_pmf_def)

lemma geometric_pmf_prob_atMost:
  assumes "p \<in> {0<..1}"
  shows  "measure_pmf.prob (geometric_pmf p) {..n} = (1 - (1 - p)^(n + 1))"
proof -
  have "(\<Sum>x\<le>n. (1 - p) ^ x * p) = 1 - (1 - p) * (1 - p) ^ n"
    by (induction n) (auto simp add: algebra_simps)
  then show ?thesis
  using assms by (auto simp add: measure_pmf_conv_infsetsum)
qed

lemma geometric_pmf_prob_lessThan:
  assumes "p \<in> {0<..1}"
  shows  "measure_pmf.prob (geometric_pmf p) {..<n} = 1 - (1 - p) ^ n"
proof -
  have "(\<Sum>x<n. (1 - p) ^ x * p) = 1 - (1 - p) ^ n"
    by (induction n) (auto simp add: algebra_simps)
  then show ?thesis
  using assms by (auto simp add: measure_pmf_conv_infsetsum)
qed

lemma geometric_pmf_prob_greaterThan:
  assumes "p \<in> {0<..1}"
  shows  "measure_pmf.prob (geometric_pmf p) {n<..} = (1 - p)^(n + 1)"
proof -
  have "(UNIV - {..n}) = {n<..}"
    by auto
  moreover have "measure_pmf.prob (geometric_pmf p) (UNIV - {..n}) = (1 - p) ^ (n + 1)"
    using assms by (subst measure_pmf.finite_measure_Diff)
                   (auto simp add: geometric_pmf_prob_atMost)
  ultimately show ?thesis
    by auto
qed

lemma geometric_pmf_prob_atLeast:
  assumes "p \<in> {0<..1}"
  shows  "measure_pmf.prob (geometric_pmf p) {n..} = (1 - p)^n"
proof -
  have "(UNIV - {..<n}) = {n..}"
    by auto
  moreover have "measure_pmf.prob (geometric_pmf p) (UNIV - {..<n}) = (1 - p) ^ n"
    using assms by (subst measure_pmf.finite_measure_Diff)
                   (auto simp add: geometric_pmf_prob_lessThan)
  ultimately show ?thesis
    by auto
qed

lemma bernoulli_pmf_of_set':
  assumes "finite A"
  shows "map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A P (\<lambda>_. bernoulli_pmf (1/2))) = pmf_of_set (Pow A)"
proof -
  have *: "Pi_pmf A P (\<lambda>_. pmf_of_set (UNIV :: bool set)) = pmf_of_set (PiE_dflt A P (\<lambda>_. UNIV :: bool set))"
    using assms by (intro Pi_pmf_of_set) auto
  have "map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A P (\<lambda>_. bernoulli_pmf (1 / 2))) =
        map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A P (\<lambda>_. pmf_of_set UNIV))"
    using bernoulli_pmf_half_conv_pmf_of_set by auto
  also have "\<dots> = map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (pmf_of_set (PiE_dflt A P (\<lambda>_. UNIV)))"
    using assms by (subst Pi_pmf_of_set) (auto)
  also have "\<dots> = pmf_of_set (Pow A)"
  proof -
    have "bij_betw (\<lambda>b. {x \<in> A. \<not> b x}) (PiE_dflt A P (\<lambda>_. UNIV)) (Pow A)"
      by (rule bij_betwI[of _ _ _ "\<lambda>B b. if b \<in> A then \<not> (b \<in> B) else P"]) (auto simp add: PiE_dflt_def)
    then show ?thesis
      using assms by (intro map_pmf_of_set_bij_betw) auto
  qed
  finally show ?thesis
    by simp
qed

lemma Pi_pmf_pmf_of_set_Suc:
  assumes "finite A"
  shows "Pi_pmf A 0 (\<lambda>_. geometric_pmf (1/2)) =
       do {
         B \<leftarrow> pmf_of_set (Pow A);
         Pi_pmf B 0 (\<lambda>_. map_pmf Suc (geometric_pmf (1/2))) }"
proof -
  have "Pi_pmf A 0 (\<lambda>_. geometric_pmf (1/2)) =
        Pi_pmf A 0 (\<lambda>_. bernoulli_pmf (1/2) \<bind>
        (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf (1/2))))"
    using assms by (subst geometric_bind_pmf_unfold) auto
  also have "\<dots> =
             Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2)) \<bind>
             (\<lambda>b. Pi_pmf A 0 (\<lambda>x. if b x then return_pmf 0 else map_pmf Suc (geometric_pmf (1/2))))"
    using assms by (subst Pi_pmf_bind[of _ _ _ _ False]) auto
  also have "\<dots> =
             do {b \<leftarrow> Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2));
                 Pi_pmf {x \<in> A. ~b x} 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1/2)))}"
    using assms by (subst Pi_pmf_if_set') auto
  also have "\<dots> =
             do {B \<leftarrow> map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2)));
                 Pi_pmf B 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1/2)))}"
    unfolding map_pmf_def apply(subst bind_assoc_pmf) apply(subst bind_return_pmf) by auto
  also have "\<dots> = pmf_of_set (Pow A) \<bind> (\<lambda>B. Pi_pmf B 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1 / 2))))"
    unfolding assms using assms by (subst bernoulli_pmf_of_set') auto
  finally show ?thesis
    by simp
qed

lemma Pi_pmf_pmf_of_set_Suc':
  assumes "finite A"
  shows "Pi_pmf A 0 (\<lambda>_. geometric_pmf (1/2)) =
       do {
         B \<leftarrow> pmf_of_set (Pow A);
         Pi_pmf B 0 (\<lambda>_. map_pmf Suc (geometric_pmf (1/2))) }"
proof -
  have "Pi_pmf A 0 (\<lambda>_. geometric_pmf (1/2)) =
        Pi_pmf A 0 (\<lambda>_. bernoulli_pmf (1/2) \<bind>
        (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf (1/2))))"
    using assms by (subst geometric_bind_pmf_unfold) auto
  also have "\<dots> =
             Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2)) \<bind>
             (\<lambda>b. Pi_pmf A 0 (\<lambda>x. if b x then return_pmf 0 else map_pmf Suc (geometric_pmf (1/2))))"
    using assms by (subst Pi_pmf_bind[of _ _ _ _ False]) auto
  also have "\<dots> =
             do {b \<leftarrow> Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2));
                 Pi_pmf {x \<in> A. ~b x} 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1/2)))}"
    using assms by (subst Pi_pmf_if_set') auto
  also have "\<dots> =
             do {B \<leftarrow> map_pmf (\<lambda>b. {x \<in> A. \<not> b x}) (Pi_pmf A False (\<lambda>_. bernoulli_pmf (1/2)));
                 Pi_pmf B 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1/2)))}"
    unfolding map_pmf_def by (auto simp add: bind_assoc_pmf bind_return_pmf)
  also have "\<dots> = pmf_of_set (Pow A) \<bind> (\<lambda>B. Pi_pmf B 0 (\<lambda>x. map_pmf Suc (geometric_pmf (1 / 2))))"
    unfolding assms using assms by (subst bernoulli_pmf_of_set') auto
  finally show ?thesis
    by simp
qed

lemma binomial_pmf_altdef':
  fixes A :: "'a set"
  assumes "finite A" and "card A = n" and p: "p \<in> {0..1}"
  shows   "binomial_pmf n p =
             map_pmf (\<lambda>f. card {x\<in>A. f x}) (Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p))" (is "?lhs = ?rhs")
proof -
  from assms have "?lhs = binomial_pmf (card A) p"
    by simp
  also have "\<dots> = ?rhs"
  using assms(1)
  proof (induction rule: finite_induct)
    case empty
    with p show ?case by (simp add: binomial_pmf_0)
  next
    case (insert x A)
    from insert.hyps have "card (insert x A) = Suc (card A)"
      by simp
    also have "binomial_pmf \<dots> p = do {
                                     b \<leftarrow> bernoulli_pmf p;
                                     f \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
                                     return_pmf ((if b then 1 else 0) + card {y \<in> A. f y})
                                   }"
      using p by (simp add: binomial_pmf_Suc insert.IH bind_map_pmf)
    also have "\<dots> = do {
                      b \<leftarrow> bernoulli_pmf p;
                      f \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
                      return_pmf (card {y \<in> insert x A. (f(x := b)) y})
                    }"
    proof (intro bind_pmf_cong refl, goal_cases)
      case (1 b f)
      have "(if b then 1 else 0) + card {y\<in>A. f y} = card ((if b then {x} else {}) \<union> {y\<in>A. f y})"
        using insert.hyps by auto
      also have "(if b then {x} else {}) \<union> {y\<in>A. f y} = {y\<in>insert x A. (f(x := b)) y}"
        using insert.hyps by auto
      finally show ?case by simp
    qed
    also have "\<dots> = map_pmf (\<lambda>f. card {y\<in>insert x A. f y})
                      (Pi_pmf (insert x A) dflt (\<lambda>_. bernoulli_pmf p))"
      using insert.hyps by (subst Pi_pmf_insert) (simp_all add: pair_pmf_def map_bind_pmf)
    finally show ?case .
  qed
  finally show ?thesis .
qed

lemma bernoulli_pmf_Not:
  assumes "p \<in> {0..1}"
  shows "bernoulli_pmf p = map_pmf Not (bernoulli_pmf (1 - p))"
proof -
  have *: "(Not -` {True}) = {False}" "(Not -` {False}) = {True}"
    by blast+
  have "pmf (bernoulli_pmf p) b = pmf (map_pmf Not (bernoulli_pmf (1 - p))) b" for b
    using assms by (cases b) (auto simp add: pmf_map * measure_pmf_single)
  then show ?thesis
    by (rule pmf_eqI)
qed

lemma binomial_pmf_altdef'':
  assumes p: "p \<in> {0..1}"
  shows   "binomial_pmf n p =
           map_pmf (\<lambda>f. card {x. x < n \<and> f x}) (Pi_pmf {..<n} dflt (\<lambda>_. bernoulli_pmf p))"
  using assms by (subst binomial_pmf_altdef'[of "{..<n}"]) (auto)

context includes monad_normalisation
begin

lemma Pi_pmf_geometric_filter:
  assumes "finite A" "p \<in> {0<..1}"
  shows "Pi_pmf A 0 (\<lambda>_. geometric_pmf p) =
       do {
         fb \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
         Pi_pmf {x \<in> A. \<not> fb x} 0 (\<lambda>_. map_pmf Suc (geometric_pmf p)) }"
proof -
  have "Pi_pmf A 0 (\<lambda>_. geometric_pmf p) =
        Pi_pmf A 0 (\<lambda>_. bernoulli_pmf p \<bind>
                   (\<lambda>b. if b then return_pmf 0 else map_pmf Suc (geometric_pmf p)))"
    using assms by (subst geometric_bind_pmf_unfold) auto
  also have "\<dots> =
             Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p) \<bind>
             (\<lambda>b. Pi_pmf A 0 (\<lambda>x. if b x then return_pmf 0 else map_pmf Suc (geometric_pmf p)))"
    using assms by (subst Pi_pmf_bind[of _ _ _ _ dflt]) auto
  also have "\<dots> =
             do {b \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf p);
                 Pi_pmf {x \<in> A. \<not> b x} 0 (\<lambda>x. map_pmf Suc (geometric_pmf p))}"
    using assms by (subst Pi_pmf_if_set') (auto)
  finally show ?thesis
    by simp
qed

lemma Pi_pmf_geometric_filter':
  assumes "finite A" "p \<in> {0<..1}"
  shows "Pi_pmf A 0 (\<lambda>_. geometric_pmf p) =
       do {
         fb \<leftarrow> Pi_pmf A dflt (\<lambda>_. bernoulli_pmf (1 - p));
         Pi_pmf {x \<in> A. fb x} 0 (\<lambda>_. map_pmf Suc (geometric_pmf p)) }"
  using assms by (auto simp add: Pi_pmf_geometric_filter[of _ _ "\<not> dflt"] bernoulli_pmf_Not[of p]
      Pi_pmf_map[of _ _ dflt] map_pmf_def[of "((\<circ>) Not)"])

end

end


theory separation
  imports "../TBAs/closure_algebra"
begin

(**Introduces a predicate for indicating that A and B are separated and proves some properties.*)
definition Sep ("Sep[_]") where "Sep[\<C>] A B \<equiv> Disj (\<C> A) B \<and> Disj (\<C> B) A"
lemma Sep_def2: "Sep[\<C>] A B = ((A \<^bold>\<and> \<C> B) \<^bold>\<or> (B \<^bold>\<and> \<C> A) \<approx> \<^bold>\<bottom>)" by (smt (verit, best) Disj_char Disj_def L7 Sep_def bottom_def join_def meet_def setequ_def subset_def)

lemma Sep_comm: "\<forall>A B. Sep[\<C>] A B \<longrightarrow> Sep[\<C>] B A" by (simp add: Sep_def)
lemma Sep_disj: "Cl_2 \<C> \<Longrightarrow> \<forall>A B. Sep[\<C>] A B \<longrightarrow> Disj A B" by (smt (verit, best) Disj_def EXPN_def Sep_def meet_def setequ_char subset_def)
lemma Sep_I: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4' \<C> \<Longrightarrow> \<forall>A. Sep[\<C>] (\<I>[\<C>] A) (\<I>[\<C>] (\<^bold>\<midarrow>A))" by (smt (verit, del_insts) BA_dn CI_Disj_rel_b Disj_I Disj_def Sep_def)
lemma Sep_sub: "MONO \<C> \<Longrightarrow> \<forall>A B C D. Sep[\<C>] A B \<and> C \<preceq> A \<and> D \<preceq> B \<longrightarrow> Sep[\<C>] C D" using MONO_def unfolding Sep_def Disj_def conn by (smt (verit, best) setequ_char subset_def)
lemma Sep_Cl_diff: "MONO \<C>  \<Longrightarrow> \<forall>A B. Cl[\<C>](A) \<and> Cl[\<C>](B) \<longrightarrow> Sep[\<C>] (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" unfolding Disj_def MONO_def Sep_def fixpoint_pred_def setequ_char subset_def conn by (smt (z3))
lemma Sep_Op_diff: "MONO \<C> \<Longrightarrow> \<forall>A B. Op[\<C>](A) \<and> Op[\<C>](B) \<longrightarrow> Sep[\<C>] (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" proof -
  assume mono:"MONO \<C>"
  { fix A B
    from mono have aux: "let M=\<^bold>\<midarrow>A ; N=\<^bold>\<midarrow>B in (Cl[\<C>](M) \<and> Cl[\<C>](N) \<longrightarrow> Sep[\<C>] (M \<^bold>\<leftharpoonup> N) (N \<^bold>\<leftharpoonup> M))" using Sep_Cl_diff by fastforce
    { assume "Op[\<C>](A) \<and> Op[\<C>](B)"
      hence "Cl[\<C>](\<^bold>\<midarrow>A) \<and> Cl[\<C>](\<^bold>\<midarrow>B)" using fp_d by blast
      hence "Sep[\<C>] (\<^bold>\<midarrow>A \<^bold>\<leftharpoonup> \<^bold>\<midarrow>B) (\<^bold>\<midarrow>B \<^bold>\<leftharpoonup> \<^bold>\<midarrow>A)" using mono aux unfolding conn by simp
      moreover have "(\<^bold>\<midarrow>A \<^bold>\<leftharpoonup> \<^bold>\<midarrow>B) \<approx> (B \<^bold>\<leftharpoonup> A)" unfolding conn setequ_char by blast
      moreover have "(\<^bold>\<midarrow>B \<^bold>\<leftharpoonup> \<^bold>\<midarrow>A) \<approx> (A \<^bold>\<leftharpoonup> B)" unfolding conn setequ_char by blast
      ultimately have "Sep[\<C>] (B \<^bold>\<leftharpoonup> A) (A \<^bold>\<leftharpoonup> B)" unfolding conn setequ_char by simp
      hence "Sep[\<C>] (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" using Sep_comm by blast
    } hence "Op[\<C>](A) \<and> Op[\<C>](B) \<longrightarrow> Sep[\<C>] (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" by (rule impI)
  } thus ?thesis by simp
qed
lemma Sep_Union: "Cl_1' \<C> \<Longrightarrow> \<forall>A B C. Sep[\<C>] A B \<and> Sep[\<C>] A C \<longrightarrow> Sep[\<C>] A (B \<^bold>\<or> C)" by (smt (verit, ccfv_threshold) ADDI_a_def Disj_def Sep_def join_def subset_def)

(**A stronger separation condition: the given sets are open, resp. closed, and disjoint*)
definition OpenDisj ("OpenDisj[_]")
  where "OpenDisj[\<C>] A B \<equiv>  Op[\<C>] A \<and> Op[\<C>] B \<and> Disj A B"
definition ClosedDisj ("ClosedDisj[_]")
  where "ClosedDisj[\<C>] A B \<equiv>  Cl[\<C>] A \<and> Cl[\<C>] B \<and> Disj A B"

lemma ClDisj_implies_Sep: "\<forall>A B. ClosedDisj[\<C>] A B \<longrightarrow> Sep[\<C>] A B" by (simp add: ClosedDisj_def Disj_symm Sep_def fixpoint_pred_def setequ_equ)
lemma OpDisj_implies_Sep: "MONO \<C> \<Longrightarrow> \<forall>A B. OpenDisj[\<C>] A B \<longrightarrow> Sep[\<C>] A B" by (smt (verit, best) CI_Disj_rel Disj_def OpenDisj_def Sep_def fixpoint_pred_def setequ_char)
(*proof -

  assume mono:"MONO \<C>"
  { fix A B
    from mono have aux: "Op[\<C>](A) \<and> Op[\<C>](B) \<longrightarrow> Sep[\<C>] (A \<^bold>\<leftharpoonup> B) (B \<^bold>\<leftharpoonup> A)" using Sep_Op_diff by blast
    { assume op: "Op[\<C>](A) \<and> Op[\<C>](B)" and disj: "Disj A B"
      hence "(A \<^bold>\<leftharpoonup> B) \<approx> A \<and> (B \<^bold>\<leftharpoonup> A) \<approx> B" unfolding conn by (smt (verit, best) Disj_def bottom_def meet_def setequ_char)
      hence "Sep[\<C>] A B" using op aux by (simp add: setequ_equ)
    } hence "OpenDisj[\<C>] A B \<longrightarrow> Sep[\<C>] A B" by (simp add: OpenDisj_def)
  } thus ?thesis by blast
qed *)

(**Another condition: separation by open sets (aka. "by open neighborhoods")*)
definition SepByOpens ("SepByOpens[_]")
  where "SepByOpens[\<C>] A B \<equiv> (\<exists>G H. OpenDisj[\<C>] G H \<and> A \<preceq> G \<and> B \<preceq> H)"

lemma SepByOpens_implies_Sep: "MONO \<C> \<Longrightarrow> SepByOpens[\<C>] A B \<longrightarrow> Sep[\<C>] A B" using SepByOpens_def OpDisj_implies_Sep Sep_sub by blast
lemma "\<CC> \<C> \<Longrightarrow> Sep[\<C>] A B \<longrightarrow> SepByOpens[\<C>] A B" nitpick oops (*countermodel*)

(**T0 (Kolmogorov): for any two distinct points there exists an open set containing one point but not the other.*)
definition "T0 \<C> \<equiv> \<forall>p q. p \<noteq> q \<longrightarrow> (\<exists>G. Op[\<C>] G \<and> \<not>(G p \<longleftrightarrow> G q))"
(**T1 (Fréchet): for any two distinct points there exist two (not necessarily disjoint) open sets, each containing one point but not the other.*)
definition "T1 \<C> \<equiv> \<forall>p q. p \<noteq> q \<longrightarrow> (\<exists>G H. Op[\<C>] G \<and> Op[\<C>] H \<and> G p \<and> \<not>G q \<and> H q \<and> \<not>H p)"
(**T2 (Hausdorff): any two distinct points are separated by open sets*)
definition "T2 \<C> \<equiv> \<forall>p q. p \<noteq> q \<longrightarrow> SepByOpens[\<C>] {p} {q}"
(**Regular: closed sets and their non-contained points are separated by open sets*)
definition "Regular \<C> \<equiv> \<forall>p Q. Cl[\<C>] Q \<and> \<not>Q p \<longrightarrow> SepByOpens[\<C>] {p} Q"
(**Normal: disjoint closed sets are separated by open sets*)
definition "Normal \<C> \<equiv> \<forall>P Q. ClosedDisj[\<C>] P Q \<longrightarrow> SepByOpens[\<C>] P Q"
(**T3 (regular Hausdorff): *)
definition "T3 \<C> \<equiv> T0 \<C> \<and> Regular \<C>"
(**T4 (normal Hausdorff): *)
definition "T4 \<C> \<equiv> T1 \<C> \<and> Normal \<C>"

(**T0 and T1 can be given similar definitions with closed sets*)
lemma T0_def2: "T0 \<C> = (\<forall>p q. p \<noteq> q \<longrightarrow> (\<exists>G. Cl[\<C>] G \<and> \<not>(G p \<longleftrightarrow> G q)))" by (metis (mono_tags) BA_dn T0_def compl_def fp_d)
lemma T1_def2: "T1 \<C> = (\<forall>p q. p \<noteq> q \<longrightarrow> (\<exists>G H. Cl[\<C>] G \<and> Cl[\<C>] H \<and> G p \<and> \<not>G q \<and> H q \<and> \<not>H p))" by (smt (verit, del_insts) BA_dn T1_def compl_def fp_d)

(**Another alternative definition for T0: the closures of distinct points are distinct.*)
lemma T0_def3: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4' \<C>
          \<Longrightarrow> T0 \<C> = (\<forall>p q. p \<noteq> q \<longrightarrow> \<not>(\<C> {p} \<approx> \<C> {q}))"
proof -
  assume mono: "MONO \<C>" and cl2: "Cl_2 \<C>" and cl4: "Cl_4' \<C>"
  from mono cl2 cl4 have l2r: "T0 \<C> \<longrightarrow> (\<forall>p q. p \<noteq> q \<longrightarrow> \<not>(\<C> {p} \<approx> \<C> {q}))"
    unfolding T0_def2 by (smt (z3) C_fp_def singleton_def inf_char setequ_equ subset_def)
  have r2l: "(\<forall>p q. p \<noteq> q \<longrightarrow> \<not>(\<C> {p} \<approx> \<C> {q})) \<longrightarrow> T0 \<C>"
    proof -
      { assume def3: "\<forall>p q. p \<noteq> q \<longrightarrow> \<not>(\<C> {p} \<approx> \<C> {q})"
        { fix p::'a and q::'a
          { assume pqdiff: "p \<noteq> q"
            from this def3 have "\<not>(\<C> {p} \<approx> \<C> {q})" by simp
            from this mono cl2 cl4 have "(\<exists>G. Cl[\<C>] G \<and> \<not>(G p \<longleftrightarrow> G q))" using C_fp_def inf_char by (smt (z3) singleton_def  setequ_def setequ_equ subset_def)
          }} hence "T0 \<C>" by (simp add: T0_def2)
        } thus ?thesis by blast
      qed
  from l2r r2l show ?thesis by blast
qed

(**Another alternative definition for T1: singleton sets are all closed.*)
lemma T1_def3a: "(\<forall>p. Cl[\<C>] {p}) \<longrightarrow> T1 \<C>" by (metis T1_def2 singleton_def)
lemma T1_def3b: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> T1 \<C> \<longrightarrow> (\<forall>p. Cl[\<C>] {p})" proof -
  assume mono: "MONO \<C>" and cl2: "Cl_2 \<C>"
  { assume t1: "T1 \<C>"
    have "\<forall>p. Cl[\<C>] {p}" proof (rule ccontr)
      assume "\<not>(\<forall>p. Cl[\<C>] {p})"
      hence "\<exists>p. \<not>Cl[\<C>] {p}" by simp
      from this obtain p where "\<not>Cl[\<C>] {p}" ..
      hence "\<exists>q. p \<noteq> q \<and> \<C>{p} q" by (smt (verit, ccfv_threshold) EXPN_def singleton_def cl2 fixpoint_pred_def setequ_char subset_def)
      from this obtain q where 1: "p \<noteq> q \<and> \<C>{p} q" ..
      from this t1 have "\<exists>G H. Cl[\<C>] G \<and> Cl[\<C>] H \<and> G p \<and> \<not>G q \<and> H q \<and> \<not>H p" by (simp add: T1_def2)
      from this obtain G H where 2: "Cl[\<C>] G \<and> Cl[\<C>] H \<and> G p \<and> \<not>G q \<and> H q \<and> \<not>H p" by blast
      from 1 2 mono show False by (metis (no_types, lifting) MONO_def singleton_def fixpoint_pred_def setequ_equ subset_def)
    qed
  } thus ?thesis by blast
qed
lemma T1_def3: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> T1 \<C> = (\<forall>p. Cl[\<C>] {p})" using T1_def3a T1_def3b by auto

(**As expected, our encoding does not (a priori) assume any separation property.*)
lemma "\<CC> \<C> \<Longrightarrow> Normal \<C>" nitpick oops (**countermodel to NORM *)
lemma "\<CC> \<C> \<Longrightarrow> Regular \<C>" nitpick oops (**countermodel to REG *)
lemma "\<CC> \<C> \<Longrightarrow> T2 \<C>" nitpick oops (**countermodel to T2 *)
lemma "\<CC> \<C> \<Longrightarrow> T1 \<C>" nitpick oops (**countermodel to T1 *)
lemma "\<CC> \<C> \<Longrightarrow> T0 \<C>" nitpick oops (**countermodel to T0 *)

lemma T1_implies_T0: "T1 \<C> \<longrightarrow> T0 \<C>" using T0_def T1_def by metis
lemma "\<CC> \<C> \<Longrightarrow> T0 \<C> \<longrightarrow> T1 \<C>" nitpick oops (**(finite) countermodel*)

lemma T2_implies_T1: "T2 \<C> \<longrightarrow> T1 \<C>" unfolding T2_def T1_def SepByOpens_def by (smt (verit, best) Disj_def OpenDisj_def singleton_def bottom_def meet_def setequ_equ subset_def)
lemma "\<CC> \<C> \<Longrightarrow> T1 \<C> \<longrightarrow> T2 \<C>" oops (**expect infinite countermodel*)

lemma RegularCollapsesT0andT1: "Regular \<C> \<longrightarrow> (T0 \<C> = T1 \<C>)" proof -
  have l2r: "Regular \<C> \<longrightarrow> (T0 \<C> \<longrightarrow> T1 \<C>)"
    unfolding T0_def T1_def Regular_def OpenDisj_def Disj_def SepByOpens_def singleton_def by (smt (verit, ccfv_threshold) bottom_def compl_def fp_d meet_def setequ_equ subset_def)
  from l2r T1_implies_T0 show ?thesis by blast
qed
lemma RegularCollapsesT1andT2: "Regular \<C> \<longrightarrow> (T1 \<C> = T2 \<C>)" proof -
  have l2r: "Regular \<C> \<longrightarrow> (T1 \<C> \<longrightarrow> T2 \<C>)" unfolding T1_def T2_def Regular_def subset_def SepByOpens_def by (metis singleton_def fp_d compl_def)
  from l2r T2_implies_T1 show ?thesis by blast
qed
lemma T1_Normal_implies_Regular: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> T1 \<C> \<longrightarrow> (Normal \<C> \<longrightarrow> Regular \<C>)" proof -
  assume mono: "MONO \<C>" and cl2: "Cl_2 \<C>"
  { assume T1: "T1 \<C>" and NORM: "Normal \<C>"
    { fix p and Q
      { assume clQ: "Cl[\<C>](Q)" and nQp: "\<not>Q(p)"
        from T1 cl2 mono have "Cl[\<C>]({p})" by (simp add: T1_def3)
        moreover have "Disj {p} Q" by (simp add: singleton_def Disj_def bottom_def meet_def nQp setequ_char)
        ultimately have "SepByOpens[\<C>] {p} Q" using ClosedDisj_def NORM Normal_def clQ by blast
      } hence "Cl[\<C>](Q) \<and> \<not>Q(p) \<longrightarrow> SepByOpens[\<C>] {p} Q" by simp
    } hence "Regular \<C>" by (simp add: Regular_def)
  } thus ?thesis by simp
qed

lemma T3_implies_T2: "T3 \<C> \<longrightarrow> T2 \<C>" using RegularCollapsesT0andT1 RegularCollapsesT1andT2 T3_def by blast
lemma "\<CC> \<C> \<Longrightarrow> T3 \<C> \<longrightarrow> T2 \<C>" oops (** expect infinite countermodel*)

lemma T4_implies_T3: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> T4 \<C> \<longrightarrow> T3 \<C>" by (simp add: T1_Normal_implies_Regular T1_implies_T0 T3_def T4_def)
lemma "\<CC> \<C> \<Longrightarrow> T4 \<C> \<longrightarrow> T3 \<C>" oops (** expect infinite countermodel*)

(**We can also generate countermodels to some well-known non-theorems (assuming all conditions).*)
lemma "\<CC> \<C> \<Longrightarrow> Regular \<C> \<longrightarrow> T1 \<C>" nitpick oops (**(finite) countermodel*)
lemma "\<CC> \<C> \<Longrightarrow> Normal \<C> \<longrightarrow> T1 \<C>" nitpick oops (**(finite) countermodel*)
lemma "\<CC> \<C> \<Longrightarrow> Regular \<C> \<longrightarrow> T2 \<C>" nitpick oops (**(finite) countermodel*)
lemma "\<CC> \<C> \<Longrightarrow> Normal \<C> \<longrightarrow> T2 \<C>" nitpick oops (**(finite) countermodel*)
lemma "\<CC> \<C> \<Longrightarrow> T2 \<C> \<longrightarrow> Regular \<C>" oops (**expect infinite countermodel*)
lemma "\<CC> \<C> \<Longrightarrow> T2 \<C> \<longrightarrow> Normal \<C>" oops (**expect infinite countermodel*)
lemma "\<CC> \<C> \<Longrightarrow> Regular \<C> \<longrightarrow> Normal \<C>" oops (**expect infinite countermodel*)
lemma "\<CC> \<C> \<Longrightarrow> Normal \<C> \<longrightarrow> Regular \<C>" nitpick oops (**expect infinite countermodels*)

(**Just for fun: here is another (pseudo-interactive) proof that is actually subsumed under "T2_implies_T1" above.
This is a 'textbook' proof. Observe that it employs additional assumptions than the one above. *)
lemma "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> T2 \<C> \<longrightarrow> T1 \<C>" proof -
  assume mono: "MONO \<C>" and cl2: "Cl_2 \<C>"
  { assume T2: "T2 \<C>"
    fix p::'a
    let ?np= "\<lambda>q. q \<noteq> p"
    let ?Prop= "\<lambda>G.  Op[\<C>](G) \<and> \<not>G(p)"
    have aux: "Op[\<C>](\<^bold>\<Or>?Prop)" by (metis (no_types, lifting) Int_sup_closed cl2 mono supremum_closed_def)
    from T2 have "\<forall>x. ?np x \<longrightarrow> (\<exists>G. ?Prop(G) \<and> G(x))" unfolding singleton_def SepByOpens_def OpenDisj_def T2_def Disj_def by (smt (verit, best) bottom_def meet_def setequ_char subset_def)
    hence "?np \<approx> \<^bold>\<Or>?Prop" by (smt (verit) setequ_char supremum_def)
    hence "Op[\<C>](?np)" using aux setequ_equ by force
    hence "Cl[\<C>]{p}" by (simp add: singleton_def ClOpdual compl_def)
  } thus ?thesis unfolding singleton_def using T1_def2 by blast
qed

end


(*  Title:      HOL/Transitive_Closure.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section {* Reflexive and Transitive closure of a relation *}

theory Transitive_Closure
imports Relation
begin

ML_file "~~/src/Provers/trancl.ML"

text {*
  @{text rtrancl} is reflexive/transitive closure,
  @{text trancl} is transitive closure,
  @{text reflcl} is reflexive closure.

  These postfix operators have \emph{maximum priority}, forcing their
  operands to be atomic.
*}

inductive_set
  rtrancl :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"   ("(_^*)" [1000] 999)
  for r :: "('a \<times> 'a) set"
where
    rtrancl_refl [intro!, Pure.intro!, simp]: "(a, a) : r^*"
  | rtrancl_into_rtrancl [Pure.intro]: "(a, b) : r^* ==> (b, c) : r ==> (a, c) : r^*"

inductive_set
  trancl :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"  ("(_^+)" [1000] 999)
  for r :: "('a \<times> 'a) set"
where
    r_into_trancl [intro, Pure.intro]: "(a, b) : r ==> (a, b) : r^+"
  | trancl_into_trancl [Pure.intro]: "(a, b) : r^+ ==> (b, c) : r ==> (a, c) : r^+"

declare rtrancl_def [nitpick_unfold del]
        rtranclp_def [nitpick_unfold del]
        trancl_def [nitpick_unfold del]
        tranclp_def [nitpick_unfold del]

notation
  rtranclp  ("(_^**)" [1000] 1000) and
  tranclp  ("(_^++)" [1000] 1000)

abbreviation
  reflclp :: "('a => 'a => bool) => 'a => 'a => bool"  ("(_^==)" [1000] 1000) where
  "r^== \<equiv> sup r op ="

abbreviation
  reflcl :: "('a \<times> 'a) set => ('a \<times> 'a) set"  ("(_^=)" [1000] 999) where
  "r^= \<equiv> r \<union> Id"

notation (xsymbols)
  rtranclp  ("(_\<^sup>*\<^sup>*)" [1000] 1000) and
  tranclp  ("(_\<^sup>+\<^sup>+)" [1000] 1000) and
  reflclp  ("(_\<^sup>=\<^sup>=)" [1000] 1000) and
  rtrancl  ("(_\<^sup>*)" [1000] 999) and
  trancl  ("(_\<^sup>+)" [1000] 999) and
  reflcl  ("(_\<^sup>=)" [1000] 999)

notation (HTML output)
  rtranclp  ("(_\<^sup>*\<^sup>*)" [1000] 1000) and
  tranclp  ("(_\<^sup>+\<^sup>+)" [1000] 1000) and
  reflclp  ("(_\<^sup>=\<^sup>=)" [1000] 1000) and
  rtrancl  ("(_\<^sup>*)" [1000] 999) and
  trancl  ("(_\<^sup>+)" [1000] 999) and
  reflcl  ("(_\<^sup>=)" [1000] 999)

subsection {* Reflexive closure *}

lemma refl_reflcl[simp]: "refl(r^=)"
by(simp add:refl_on_def)

lemma antisym_reflcl[simp]: "antisym(r^=) = antisym r"
by(simp add:antisym_def)

lemma trans_reflclI[simp]: "trans r \<Longrightarrow> trans(r^=)"
unfolding trans_def by blast

lemma reflclp_idemp [simp]: "(P^==)^==  =  P^=="
by blast

subsection {* Reflexive-transitive closure *}

lemma reflcl_set_eq [pred_set_conv]: "(sup (\<lambda>x y. (x, y) \<in> r) op =) = (\<lambda>x y. (x, y) \<in> r \<union> Id)"
  by (auto simp add: fun_eq_iff)

lemma r_into_rtrancl [intro]: "!!p. p \<in> r ==> p \<in> r^*"
  -- {* @{text rtrancl} of @{text r} contains @{text r} *}
  apply (simp only: split_tupled_all)
  apply (erule rtrancl_refl [THEN rtrancl_into_rtrancl])
  done

lemma r_into_rtranclp [intro]: "r x y ==> r^** x y"
  -- {* @{text rtrancl} of @{text r} contains @{text r} *}
  by (erule rtranclp.rtrancl_refl [THEN rtranclp.rtrancl_into_rtrancl])

lemma rtranclp_mono: "r \<le> s ==> r^** \<le> s^**"
  -- {* monotonicity of @{text rtrancl} *}
  apply (rule predicate2I)
  apply (erule rtranclp.induct)
   apply (rule_tac [2] rtranclp.rtrancl_into_rtrancl, blast+)
  done

lemmas rtrancl_mono = rtranclp_mono [to_set]

theorem rtranclp_induct [consumes 1, case_names base step, induct set: rtranclp]:
  assumes a: "r^** a b"
    and cases: "P a" "!!y z. [| r^** a y; r y z; P y |] ==> P z"
  shows "P b" using a
  by (induct x\<equiv>a b) (rule cases)+

lemmas rtrancl_induct [induct set: rtrancl] = rtranclp_induct [to_set]

lemmas rtranclp_induct2 =
  rtranclp_induct[of _ "(ax,ay)" "(bx,by)", split_rule,
                 consumes 1, case_names refl step]

lemmas rtrancl_induct2 =
  rtrancl_induct[of "(ax,ay)" "(bx,by)", split_format (complete),
                 consumes 1, case_names refl step]

lemma refl_rtrancl: "refl (r^*)"
by (unfold refl_on_def) fast

text {* Transitivity of transitive closure. *}
lemma trans_rtrancl: "trans (r^*)"
proof (rule transI)
  fix x y z
  assume "(x, y) \<in> r\<^sup>*"
  assume "(y, z) \<in> r\<^sup>*"
  then show "(x, z) \<in> r\<^sup>*"
  proof induct
    case base
    show "(x, y) \<in> r\<^sup>*" by fact
  next
    case (step u v)
    from `(x, u) \<in> r\<^sup>*` and `(u, v) \<in> r`
    show "(x, v) \<in> r\<^sup>*" ..
  qed
qed

lemmas rtrancl_trans = trans_rtrancl [THEN transD]

lemma rtranclp_trans:
  assumes xy: "r^** x y"
  and yz: "r^** y z"
  shows "r^** x z" using yz xy
  by induct iprover+

lemma rtranclE [cases set: rtrancl]:
  assumes major: "(a::'a, b) : r^*"
  obtains
    (base) "a = b"
  | (step) y where "(a, y) : r^*" and "(y, b) : r"
  -- {* elimination of @{text rtrancl} -- by induction on a special formula *}
  apply (subgoal_tac "(a::'a) = b | (EX y. (a,y) : r^* & (y,b) : r)")
   apply (rule_tac [2] major [THEN rtrancl_induct])
    prefer 2 apply blast
   prefer 2 apply blast
  apply (erule asm_rl exE disjE conjE base step)+
  done

lemma rtrancl_Int_subset: "[| Id \<subseteq> s; (r^* \<inter> s) O r \<subseteq> s|] ==> r^* \<subseteq> s"
  apply (rule subsetI)
  apply (rule_tac p="x" in PairE, clarify)
  apply (erule rtrancl_induct, auto)
  done

lemma converse_rtranclp_into_rtranclp:
  "r a b \<Longrightarrow> r\<^sup>*\<^sup>* b c \<Longrightarrow> r\<^sup>*\<^sup>* a c"
  by (rule rtranclp_trans) iprover+

lemmas converse_rtrancl_into_rtrancl = converse_rtranclp_into_rtranclp [to_set]

text {*
  \medskip More @{term "r^*"} equations and inclusions.
*}

lemma rtranclp_idemp [simp]: "(r^**)^** = r^**"
  apply (auto intro!: order_antisym)
  apply (erule rtranclp_induct)
   apply (rule rtranclp.rtrancl_refl)
  apply (blast intro: rtranclp_trans)
  done

lemmas rtrancl_idemp [simp] = rtranclp_idemp [to_set]

lemma rtrancl_idemp_self_comp [simp]: "R^* O R^* = R^*"
  apply (rule set_eqI)
  apply (simp only: split_tupled_all)
  apply (blast intro: rtrancl_trans)
  done

lemma rtrancl_subset_rtrancl: "r \<subseteq> s^* ==> r^* \<subseteq> s^*"
  apply (drule rtrancl_mono)
  apply simp
  done

lemma rtranclp_subset: "R \<le> S ==> S \<le> R^** ==> S^** = R^**"
  apply (drule rtranclp_mono)
  apply (drule rtranclp_mono)
  apply simp
  done

lemmas rtrancl_subset = rtranclp_subset [to_set]

lemma rtranclp_sup_rtranclp: "(sup (R^**) (S^**))^** = (sup R S)^**"
by (blast intro!: rtranclp_subset intro: rtranclp_mono [THEN predicate2D])

lemmas rtrancl_Un_rtrancl = rtranclp_sup_rtranclp [to_set]

lemma rtranclp_reflclp [simp]: "(R^==)^** = R^**"
by (blast intro!: rtranclp_subset)

lemmas rtrancl_reflcl [simp] = rtranclp_reflclp [to_set]

lemma rtrancl_r_diff_Id: "(r - Id)^* = r^*"
  apply (rule sym)
  apply (rule rtrancl_subset, blast, clarify)
  apply (rename_tac a b)
  apply (case_tac "a = b")
   apply blast
  apply blast
  done

lemma rtranclp_r_diff_Id: "(inf r op ~=)^** = r^**"
  apply (rule sym)
  apply (rule rtranclp_subset)
   apply blast+
  done

theorem rtranclp_converseD:
  assumes r: "(r^--1)^** x y"
  shows "r^** y x"
proof -
  from r show ?thesis
    by induct (iprover intro: rtranclp_trans dest!: conversepD)+
qed

lemmas rtrancl_converseD = rtranclp_converseD [to_set]

theorem rtranclp_converseI:
  assumes "r^** y x"
  shows "(r^--1)^** x y"
  using assms
  by induct (iprover intro: rtranclp_trans conversepI)+

lemmas rtrancl_converseI = rtranclp_converseI [to_set]

lemma rtrancl_converse: "(r^-1)^* = (r^*)^-1"
  by (fast dest!: rtrancl_converseD intro!: rtrancl_converseI)

lemma sym_rtrancl: "sym r ==> sym (r^*)"
  by (simp only: sym_conv_converse_eq rtrancl_converse [symmetric])

theorem converse_rtranclp_induct [consumes 1, case_names base step]:
  assumes major: "r^** a b"
    and cases: "P b" "!!y z. [| r y z; r^** z b; P z |] ==> P y"
  shows "P a"
  using rtranclp_converseI [OF major]
  by induct (iprover intro: cases dest!: conversepD rtranclp_converseD)+

lemmas converse_rtrancl_induct = converse_rtranclp_induct [to_set]

lemmas converse_rtranclp_induct2 =
  converse_rtranclp_induct [of _ "(ax,ay)" "(bx,by)", split_rule,
                 consumes 1, case_names refl step]

lemmas converse_rtrancl_induct2 =
  converse_rtrancl_induct [of "(ax,ay)" "(bx,by)", split_format (complete),
                 consumes 1, case_names refl step]

lemma converse_rtranclpE [consumes 1, case_names base step]:
  assumes major: "r^** x z"
    and cases: "x=z ==> P"
      "!!y. [| r x y; r^** y z |] ==> P"
  shows P
  apply (subgoal_tac "x = z | (EX y. r x y & r^** y z)")
   apply (rule_tac [2] major [THEN converse_rtranclp_induct])
    prefer 2 apply iprover
   prefer 2 apply iprover
  apply (erule asm_rl exE disjE conjE cases)+
  done

lemmas converse_rtranclE = converse_rtranclpE [to_set]

lemmas converse_rtranclpE2 = converse_rtranclpE [of _ "(xa,xb)" "(za,zb)", split_rule]

lemmas converse_rtranclE2 = converse_rtranclE [of "(xa,xb)" "(za,zb)", split_rule]

lemma r_comp_rtrancl_eq: "r O r^* = r^* O r"
  by (blast elim: rtranclE converse_rtranclE
    intro: rtrancl_into_rtrancl converse_rtrancl_into_rtrancl)

lemma rtrancl_unfold: "r^* = Id Un r^* O r"
  by (auto intro: rtrancl_into_rtrancl elim: rtranclE)

lemma rtrancl_Un_separatorE:
  "(a,b) : (P \<union> Q)^* \<Longrightarrow> \<forall>x y. (a,x) : P^* \<longrightarrow> (x,y) : Q \<longrightarrow> x=y \<Longrightarrow> (a,b) : P^*"
apply (induct rule:rtrancl.induct)
 apply blast
apply (blast intro:rtrancl_trans)
done

lemma rtrancl_Un_separator_converseE:
  "(a,b) : (P \<union> Q)^* \<Longrightarrow> \<forall>x y. (x,b) : P^* \<longrightarrow> (y,x) : Q \<longrightarrow> y=x \<Longrightarrow> (a,b) : P^*"
apply (induct rule:converse_rtrancl_induct)
 apply blast
apply (blast intro:rtrancl_trans)
done

lemma Image_closed_trancl:
  assumes "r `` X \<subseteq> X" shows "r\<^sup>* `` X = X"
proof -
  from assms have **: "{y. \<exists>x\<in>X. (x, y) \<in> r} \<subseteq> X" by auto
  have "\<And>x y. (y, x) \<in> r\<^sup>* \<Longrightarrow> y \<in> X \<Longrightarrow> x \<in> X"
  proof -
    fix x y
    assume *: "y \<in> X"
    assume "(y, x) \<in> r\<^sup>*"
    then show "x \<in> X"
    proof induct
      case base show ?case by (fact *)
    next
      case step with ** show ?case by auto
    qed
  qed
  then show ?thesis by auto
qed

subsection {* Transitive closure *}

lemma trancl_mono: "!!p. p \<in> r^+ ==> r \<subseteq> s ==> p \<in> s^+"
  apply (simp add: split_tupled_all)
  apply (erule trancl.induct)
   apply (iprover dest: subsetD)+
  done

lemma r_into_trancl': "!!p. p : r ==> p : r^+"
  by (simp only: split_tupled_all) (erule r_into_trancl)

text {*
  \medskip Conversions between @{text trancl} and @{text rtrancl}.
*}

lemma tranclp_into_rtranclp: "r^++ a b ==> r^** a b"
  by (erule tranclp.induct) iprover+

lemmas trancl_into_rtrancl = tranclp_into_rtranclp [to_set]

lemma rtranclp_into_tranclp1: assumes r: "r^** a b"
  shows "!!c. r b c ==> r^++ a c" using r
  by induct iprover+

lemmas rtrancl_into_trancl1 = rtranclp_into_tranclp1 [to_set]

lemma rtranclp_into_tranclp2: "[| r a b; r^** b c |] ==> r^++ a c"
  -- {* intro rule from @{text r} and @{text rtrancl} *}
  apply (erule rtranclp.cases)
   apply iprover
  apply (rule rtranclp_trans [THEN rtranclp_into_tranclp1])
    apply (simp | rule r_into_rtranclp)+
  done

lemmas rtrancl_into_trancl2 = rtranclp_into_tranclp2 [to_set]

text {* Nice induction rule for @{text trancl} *}
lemma tranclp_induct [consumes 1, case_names base step, induct pred: tranclp]:
  assumes a: "r^++ a b"
  and cases: "!!y. r a y ==> P y"
    "!!y z. r^++ a y ==> r y z ==> P y ==> P z"
  shows "P b" using a
  by (induct x\<equiv>a b) (iprover intro: cases)+

lemmas trancl_induct [induct set: trancl] = tranclp_induct [to_set]

lemmas tranclp_induct2 =
  tranclp_induct [of _ "(ax,ay)" "(bx,by)", split_rule,
    consumes 1, case_names base step]

lemmas trancl_induct2 =
  trancl_induct [of "(ax,ay)" "(bx,by)", split_format (complete),
    consumes 1, case_names base step]

lemma tranclp_trans_induct:
  assumes major: "r^++ x y"
    and cases: "!!x y. r x y ==> P x y"
      "!!x y z. [| r^++ x y; P x y; r^++ y z; P y z |] ==> P x z"
  shows "P x y"
  -- {* Another induction rule for trancl, incorporating transitivity *}
  by (iprover intro: major [THEN tranclp_induct] cases)

lemmas trancl_trans_induct = tranclp_trans_induct [to_set]

lemma tranclE [cases set: trancl]:
  assumes "(a, b) : r^+"
  obtains
    (base) "(a, b) : r"
  | (step) c where "(a, c) : r^+" and "(c, b) : r"
  using assms by cases simp_all

lemma trancl_Int_subset: "[| r \<subseteq> s; (r^+ \<inter> s) O r \<subseteq> s|] ==> r^+ \<subseteq> s"
  apply (rule subsetI)
  apply (rule_tac p = x in PairE)
  apply clarify
  apply (erule trancl_induct)
   apply auto
  done

lemma trancl_unfold: "r^+ = r Un r^+ O r"
  by (auto intro: trancl_into_trancl elim: tranclE)

text {* Transitivity of @{term "r^+"} *}
lemma trans_trancl [simp]: "trans (r^+)"
proof (rule transI)
  fix x y z
  assume "(x, y) \<in> r^+"
  assume "(y, z) \<in> r^+"
  then show "(x, z) \<in> r^+"
  proof induct
    case (base u)
    from `(x, y) \<in> r^+` and `(y, u) \<in> r`
    show "(x, u) \<in> r^+" ..
  next
    case (step u v)
    from `(x, u) \<in> r^+` and `(u, v) \<in> r`
    show "(x, v) \<in> r^+" ..
  qed
qed

lemmas trancl_trans = trans_trancl [THEN transD]

lemma tranclp_trans:
  assumes xy: "r^++ x y"
  and yz: "r^++ y z"
  shows "r^++ x z" using yz xy
  by induct iprover+

lemma trancl_id [simp]: "trans r \<Longrightarrow> r^+ = r"
  apply auto
  apply (erule trancl_induct)
   apply assumption
  apply (unfold trans_def)
  apply blast
  done

lemma rtranclp_tranclp_tranclp:
  assumes "r^** x y"
  shows "!!z. r^++ y z ==> r^++ x z" using assms
  by induct (iprover intro: tranclp_trans)+

lemmas rtrancl_trancl_trancl = rtranclp_tranclp_tranclp [to_set]

lemma tranclp_into_tranclp2: "r a b ==> r^++ b c ==> r^++ a c"
  by (erule tranclp_trans [OF tranclp.r_into_trancl])

lemmas trancl_into_trancl2 = tranclp_into_tranclp2 [to_set]

lemma tranclp_converseI: "(r^++)^--1 x y ==> (r^--1)^++ x y"
  apply (drule conversepD)
  apply (erule tranclp_induct)
  apply (iprover intro: conversepI tranclp_trans)+
  done

lemmas trancl_converseI = tranclp_converseI [to_set]

lemma tranclp_converseD: "(r^--1)^++ x y ==> (r^++)^--1 x y"
  apply (rule conversepI)
  apply (erule tranclp_induct)
  apply (iprover dest: conversepD intro: tranclp_trans)+
  done

lemmas trancl_converseD = tranclp_converseD [to_set]

lemma tranclp_converse: "(r^--1)^++ = (r^++)^--1"
  by (fastforce simp add: fun_eq_iff
    intro!: tranclp_converseI dest!: tranclp_converseD)

lemmas trancl_converse = tranclp_converse [to_set]

lemma sym_trancl: "sym r ==> sym (r^+)"
  by (simp only: sym_conv_converse_eq trancl_converse [symmetric])

lemma converse_tranclp_induct [consumes 1, case_names base step]:
  assumes major: "r^++ a b"
    and cases: "!!y. r y b ==> P(y)"
      "!!y z.[| r y z;  r^++ z b;  P(z) |] ==> P(y)"
  shows "P a"
  apply (rule tranclp_induct [OF tranclp_converseI, OF conversepI, OF major])
   apply (rule cases)
   apply (erule conversepD)
  apply (blast intro: assms dest!: tranclp_converseD)
  done

lemmas converse_trancl_induct = converse_tranclp_induct [to_set]

lemma tranclpD: "R^++ x y ==> EX z. R x z \<and> R^** z y"
  apply (erule converse_tranclp_induct)
   apply auto
  apply (blast intro: rtranclp_trans)
  done

lemmas tranclD = tranclpD [to_set]

lemma converse_tranclpE:
  assumes major: "tranclp r x z"
  assumes base: "r x z ==> P"
  assumes step: "\<And> y. [| r x y; tranclp r y z |] ==> P"
  shows P
proof -
  from tranclpD[OF major]
  obtain y where "r x y" and "rtranclp r y z" by iprover
  from this(2) show P
  proof (cases rule: rtranclp.cases)
    case rtrancl_refl
    with `r x y` base show P by iprover
  next
    case rtrancl_into_rtrancl
    from this have "tranclp r y z"
      by (iprover intro: rtranclp_into_tranclp1)
    with `r x y` step show P by iprover
  qed
qed

lemmas converse_tranclE = converse_tranclpE [to_set]

lemma tranclD2:
  "(x, y) \<in> R\<^sup>+ \<Longrightarrow> \<exists>z. (x, z) \<in> R\<^sup>* \<and> (z, y) \<in> R"
  by (blast elim: tranclE intro: trancl_into_rtrancl)

lemma irrefl_tranclI: "r^-1 \<inter> r^* = {} ==> (x, x) \<notin> r^+"
  by (blast elim: tranclE dest: trancl_into_rtrancl)

lemma irrefl_trancl_rD: "!!X. ALL x. (x, x) \<notin> r^+ ==> (x, y) \<in> r ==> x \<noteq> y"
  by (blast dest: r_into_trancl)

lemma trancl_subset_Sigma_aux:
    "(a, b) \<in> r^* ==> r \<subseteq> A \<times> A ==> a = b \<or> a \<in> A"
  by (induct rule: rtrancl_induct) auto

lemma trancl_subset_Sigma: "r \<subseteq> A \<times> A ==> r^+ \<subseteq> A \<times> A"
  apply (rule subsetI)
  apply (simp only: split_tupled_all)
  apply (erule tranclE)
   apply (blast dest!: trancl_into_rtrancl trancl_subset_Sigma_aux)+
  done

lemma reflclp_tranclp [simp]: "(r^++)^== = r^**"
  apply (safe intro!: order_antisym)
   apply (erule tranclp_into_rtranclp)
  apply (blast elim: rtranclp.cases dest: rtranclp_into_tranclp1)
  done

lemmas reflcl_trancl [simp] = reflclp_tranclp [to_set]

lemma trancl_reflcl [simp]: "(r^=)^+ = r^*"
  apply safe
   apply (drule trancl_into_rtrancl, simp)
  apply (erule rtranclE, safe)
   apply (rule r_into_trancl, simp)
  apply (rule rtrancl_into_trancl1)
   apply (erule rtrancl_reflcl [THEN equalityD2, THEN subsetD], fast)
  done

lemma rtrancl_trancl_reflcl [code]: "r^* = (r^+)^="
  by simp

lemma trancl_empty [simp]: "{}^+ = {}"
  by (auto elim: trancl_induct)

lemma rtrancl_empty [simp]: "{}^* = Id"
  by (rule subst [OF reflcl_trancl]) simp

lemma rtranclpD: "R^** a b ==> a = b \<or> a \<noteq> b \<and> R^++ a b"
by (force simp add: reflclp_tranclp [symmetric] simp del: reflclp_tranclp)

lemmas rtranclD = rtranclpD [to_set]

lemma rtrancl_eq_or_trancl:
  "(x,y) \<in> R\<^sup>* = (x=y \<or> x\<noteq>y \<and> (x,y) \<in> R\<^sup>+)"
  by (fast elim: trancl_into_rtrancl dest: rtranclD)

lemma trancl_unfold_right: "r^+ = r^* O r"
by (auto dest: tranclD2 intro: rtrancl_into_trancl1)

lemma trancl_unfold_left: "r^+ = r O r^*"
by (auto dest: tranclD intro: rtrancl_into_trancl2)

lemma trancl_insert:
  "(insert (y, x) r)^+ = r^+ \<union> {(a, b). (a, y) \<in> r^* \<and> (x, b) \<in> r^*}"
  -- {* primitive recursion for @{text trancl} over finite relations *}
  apply (rule equalityI)
   apply (rule subsetI)
   apply (simp only: split_tupled_all)
   apply (erule trancl_induct, blast)
   apply (blast intro: rtrancl_into_trancl1 trancl_into_rtrancl trancl_trans)
  apply (rule subsetI)
  apply (blast intro: trancl_mono rtrancl_mono
    [THEN [2] rev_subsetD] rtrancl_trancl_trancl rtrancl_into_trancl2)
  done

lemma trancl_insert2:
  "(insert (a,b) r)^+ = r^+ \<union> {(x,y). ((x,a) : r^+ \<or> x=a) \<and> ((b,y) \<in> r^+ \<or> y=b)}"
by(auto simp add: trancl_insert rtrancl_eq_or_trancl)

lemma rtrancl_insert:
  "(insert (a,b) r)^* = r^* \<union> {(x,y). (x,a) : r^* \<and> (b,y) \<in> r^*}"
using trancl_insert[of a b r]
by(simp add: rtrancl_trancl_reflcl del: reflcl_trancl) blast

text {* Simplifying nested closures *}

lemma rtrancl_trancl_absorb[simp]: "(R^*)^+ = R^*"
by (simp add: trans_rtrancl)

lemma trancl_rtrancl_absorb[simp]: "(R^+)^* = R^*"
by (subst reflcl_trancl[symmetric]) simp

lemma rtrancl_reflcl_absorb[simp]: "(R^*)^= = R^*"
by auto

text {* @{text Domain} and @{text Range} *}

lemma Domain_rtrancl [simp]: "Domain (R^*) = UNIV"
  by blast

lemma Range_rtrancl [simp]: "Range (R^*) = UNIV"
  by blast

lemma rtrancl_Un_subset: "(R^* \<union> S^*) \<subseteq> (R Un S)^*"
  by (rule rtrancl_Un_rtrancl [THEN subst]) fast

lemma in_rtrancl_UnI: "x \<in> R^* \<or> x \<in> S^* ==> x \<in> (R \<union> S)^*"
  by (blast intro: subsetD [OF rtrancl_Un_subset])

lemma trancl_domain [simp]: "Domain (r^+) = Domain r"
  by (unfold Domain_unfold) (blast dest: tranclD)

lemma trancl_range [simp]: "Range (r^+) = Range r"
  unfolding Domain_converse [symmetric] by (simp add: trancl_converse [symmetric])

lemma Not_Domain_rtrancl:
    "x ~: Domain R ==> ((x, y) : R^*) = (x = y)"
  apply auto
  apply (erule rev_mp)
  apply (erule rtrancl_induct)
   apply auto
  done

lemma trancl_subset_Field2: "r^+ <= Field r \<times> Field r"
  apply clarify
  apply (erule trancl_induct)
   apply (auto simp add: Field_def)
  done

lemma finite_trancl[simp]: "finite (r^+) = finite r"
  apply auto
   prefer 2
   apply (rule trancl_subset_Field2 [THEN finite_subset])
   apply (rule finite_SigmaI)
    prefer 3
    apply (blast intro: r_into_trancl' finite_subset)
   apply (auto simp add: finite_Field)
  done

text {* More about converse @{text rtrancl} and @{text trancl}, should
  be merged with main body. *}

lemma single_valued_confluent:
  "\<lbrakk> single_valued r; (x,y) \<in> r^*; (x,z) \<in> r^* \<rbrakk>
  \<Longrightarrow> (y,z) \<in> r^* \<or> (z,y) \<in> r^*"
  apply (erule rtrancl_induct)
  apply simp
  apply (erule disjE)
   apply (blast elim:converse_rtranclE dest:single_valuedD)
  apply(blast intro:rtrancl_trans)
  done

lemma r_r_into_trancl: "(a, b) \<in> R ==> (b, c) \<in> R ==> (a, c) \<in> R^+"
  by (fast intro: trancl_trans)

lemma trancl_into_trancl [rule_format]:
    "(a, b) \<in> r\<^sup>+ ==> (b, c) \<in> r --> (a,c) \<in> r\<^sup>+"
  apply (erule trancl_induct)
   apply (fast intro: r_r_into_trancl)
  apply (fast intro: r_r_into_trancl trancl_trans)
  done

lemma tranclp_rtranclp_tranclp:
    "r\<^sup>+\<^sup>+ a b ==> r\<^sup>*\<^sup>* b c ==> r\<^sup>+\<^sup>+ a c"
  apply (drule tranclpD)
  apply (elim exE conjE)
  apply (drule rtranclp_trans, assumption)
  apply (drule rtranclp_into_tranclp2, assumption, assumption)
  done

lemmas trancl_rtrancl_trancl = tranclp_rtranclp_tranclp [to_set]

lemmas transitive_closure_trans [trans] =
  r_r_into_trancl trancl_trans rtrancl_trans
  trancl.trancl_into_trancl trancl_into_trancl2
  rtrancl.rtrancl_into_rtrancl converse_rtrancl_into_rtrancl
  rtrancl_trancl_trancl trancl_rtrancl_trancl

lemmas transitive_closurep_trans' [trans] =
  tranclp_trans rtranclp_trans
  tranclp.trancl_into_trancl tranclp_into_tranclp2
  rtranclp.rtrancl_into_rtrancl converse_rtranclp_into_rtranclp
  rtranclp_tranclp_tranclp tranclp_rtranclp_tranclp

declare trancl_into_rtrancl [elim]

subsection {* The power operation on relations *}

text {* @{text "R ^^ n = R O ... O R"}, the n-fold composition of @{text R} *}

overloading
  relpow == "compow :: nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
  relpowp == "compow :: nat \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
begin

primrec relpow :: "nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" where
    "relpow 0 R = Id"
  | "relpow (Suc n) R = (R ^^ n) O R"

primrec relpowp :: "nat \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)" where
    "relpowp 0 R = HOL.eq"
  | "relpowp (Suc n) R = (R ^^ n) OO R"

end

lemma relpowp_relpow_eq [pred_set_conv]:
  fixes R :: "'a rel"
  shows "(\<lambda>x y. (x, y) \<in> R) ^^ n = (\<lambda>x y. (x, y) \<in> R ^^ n)"
  by (induct n) (simp_all add: relcompp_relcomp_eq)

text {* for code generation *}

definition relpow :: "nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" where
  relpow_code_def [code_abbrev]: "relpow = compow"

definition relpowp :: "nat \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)" where
  relpowp_code_def [code_abbrev]: "relpowp = compow"

lemma [code]:
  "relpowp (Suc n) R = (R ^^ n) OO R"
  "relpowp 0 R = HOL.eq"
  by (simp_all add: relpowp_code_def)

hide_const (open) relpow
hide_const (open) relpowp

lemma relpow_1 [simp]:
  fixes R :: "('a \<times> 'a) set"
  shows "R ^^ 1 = R"
  by simp

lemma relpowp_1 [simp]:
  fixes P :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  shows "P ^^ 1 = P"
  by (fact relpow_1 [to_pred])

lemma relpow_0_I:
  "(x, x) \<in> R ^^ 0"
  by simp

lemma relpowp_0_I:
  "(P ^^ 0) x x"
  by (fact relpow_0_I [to_pred])

lemma relpow_Suc_I:
  "(x, y) \<in>  R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
  by auto

lemma relpowp_Suc_I:
  "(P ^^ n) x y \<Longrightarrow> P y z \<Longrightarrow> (P ^^ Suc n) x z"
  by (fact relpow_Suc_I [to_pred])

lemma relpow_Suc_I2:
  "(x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
  by (induct n arbitrary: z) (simp, fastforce)

lemma relpowp_Suc_I2:
  "P x y \<Longrightarrow> (P ^^ n) y z \<Longrightarrow> (P ^^ Suc n) x z"
  by (fact relpow_Suc_I2 [to_pred])

lemma relpow_0_E:
  "(x, y) \<in> R ^^ 0 \<Longrightarrow> (x = y \<Longrightarrow> P) \<Longrightarrow> P"
  by simp

lemma relpowp_0_E:
  "(P ^^ 0) x y \<Longrightarrow> (x = y \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (fact relpow_0_E [to_pred])

lemma relpow_Suc_E:
  "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P) \<Longrightarrow> P"
  by auto

lemma relpowp_Suc_E:
  "(P ^^ Suc n) x z \<Longrightarrow> (\<And>y. (P ^^ n) x y \<Longrightarrow> P y z \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (fact relpow_Suc_E [to_pred])

lemma relpow_E:
  "(x, z) \<in>  R ^^ n \<Longrightarrow>  (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
   \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in>  R ^^ m \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P)
   \<Longrightarrow> P"
  by (cases n) auto

lemma relpowp_E:
  "(P ^^ n) x z \<Longrightarrow> (n = 0 \<Longrightarrow> x = z \<Longrightarrow> Q)
  \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (P ^^ m) x y \<Longrightarrow> P y z \<Longrightarrow> Q)
  \<Longrightarrow> Q"
  by (fact relpow_E [to_pred])

lemma relpow_Suc_D2:
  "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<exists>y. (x, y) \<in> R \<and> (y, z) \<in> R ^^ n)"
  apply (induct n arbitrary: x z)
   apply (blast intro: relpow_0_I elim: relpow_0_E relpow_Suc_E)
  apply (blast intro: relpow_Suc_I elim: relpow_0_E relpow_Suc_E)
  done

lemma relpowp_Suc_D2:
  "(P ^^ Suc n) x z \<Longrightarrow> \<exists>y. P x y \<and> (P ^^ n) y z"
  by (fact relpow_Suc_D2 [to_pred])

lemma relpow_Suc_E2:
  "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> P) \<Longrightarrow> P"
  by (blast dest: relpow_Suc_D2)

lemma relpowp_Suc_E2:
  "(P ^^ Suc n) x z \<Longrightarrow> (\<And>y. P x y \<Longrightarrow> (P ^^ n) y z \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (fact relpow_Suc_E2 [to_pred])

lemma relpow_Suc_D2':
  "\<forall>x y z. (x, y) \<in> R ^^ n \<and> (y, z) \<in> R \<longrightarrow> (\<exists>w. (x, w) \<in> R \<and> (w, z) \<in> R ^^ n)"
  by (induct n) (simp_all, blast)

lemma relpowp_Suc_D2':
  "\<forall>x y z. (P ^^ n) x y \<and> P y z \<longrightarrow> (\<exists>w. P x w \<and> (P ^^ n) w z)"
  by (fact relpow_Suc_D2' [to_pred])

lemma relpow_E2:
  "(x, z) \<in> R ^^ n \<Longrightarrow>  (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P)
     \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ m \<Longrightarrow> P)
   \<Longrightarrow> P"
  apply (cases n, simp)
  apply (rename_tac nat)
  apply (cut_tac n=nat and R=R in relpow_Suc_D2', simp, blast)
  done

lemma relpowp_E2:
  "(P ^^ n) x z \<Longrightarrow> (n = 0 \<Longrightarrow> x = z \<Longrightarrow> Q)
    \<Longrightarrow> (\<And>y m. n = Suc m \<Longrightarrow> P x y \<Longrightarrow> (P ^^ m) y z \<Longrightarrow> Q)
  \<Longrightarrow> Q"
  by (fact relpow_E2 [to_pred])

lemma relpow_add: "R ^^ (m+n) = R^^m O R^^n"
  by (induct n) auto

lemma relpowp_add: "P ^^ (m + n) = P ^^ m OO P ^^ n"
  by (fact relpow_add [to_pred])

lemma relpow_commute: "R O R ^^ n = R ^^ n O R"
  by (induct n) (simp, simp add: O_assoc [symmetric])

lemma relpowp_commute: "P OO P ^^ n = P ^^ n OO P"
  by (fact relpow_commute [to_pred])

lemma relpow_empty:
  "0 < n \<Longrightarrow> ({} :: ('a \<times> 'a) set) ^^ n = {}"
  by (cases n) auto

lemma relpowp_bot:
  "0 < n \<Longrightarrow> (\<bottom> :: 'a \<Rightarrow> 'a \<Rightarrow> bool) ^^ n = \<bottom>"
  by (fact relpow_empty [to_pred])

lemma rtrancl_imp_UN_relpow:
  assumes "p \<in> R^*"
  shows "p \<in> (\<Union>n. R ^^ n)"
proof (cases p)
  case (Pair x y)
  with assms have "(x, y) \<in> R^*" by simp
  then have "(x, y) \<in> (\<Union>n. R ^^ n)" proof induct
    case base show ?case by (blast intro: relpow_0_I)
  next
    case step then show ?case by (blast intro: relpow_Suc_I)
  qed
  with Pair show ?thesis by simp
qed

lemma rtranclp_imp_Sup_relpowp:
  assumes "(P^**) x y"
  shows "(\<Squnion>n. P ^^ n) x y"
  using assms and rtrancl_imp_UN_relpow [to_pred] by blast

lemma relpow_imp_rtrancl:
  assumes "p \<in> R ^^ n"
  shows "p \<in> R^*"
proof (cases p)
  case (Pair x y)
  with assms have "(x, y) \<in> R ^^ n" by simp
  then have "(x, y) \<in> R^*" proof (induct n arbitrary: x y)
    case 0 then show ?case by simp
  next
    case Suc then show ?case
      by (blast elim: relpow_Suc_E intro: rtrancl_into_rtrancl)
  qed
  with Pair show ?thesis by simp
qed

lemma relpowp_imp_rtranclp:
  assumes "(P ^^ n) x y"
  shows "(P^**) x y"
  using assms and relpow_imp_rtrancl [to_pred] by blast

lemma rtrancl_is_UN_relpow:
  "R^* = (\<Union>n. R ^^ n)"
  by (blast intro: rtrancl_imp_UN_relpow relpow_imp_rtrancl)

lemma rtranclp_is_Sup_relpowp:
  "P^** = (\<Squnion>n. P ^^ n)"
  using rtrancl_is_UN_relpow [to_pred, of P] by auto

lemma rtrancl_power:
  "p \<in> R^* \<longleftrightarrow> (\<exists>n. p \<in> R ^^ n)"
  by (simp add: rtrancl_is_UN_relpow)

lemma rtranclp_power:
  "(P^**) x y \<longleftrightarrow> (\<exists>n. (P ^^ n) x y)"
  by (simp add: rtranclp_is_Sup_relpowp)

lemma trancl_power:
  "p \<in> R^+ \<longleftrightarrow> (\<exists>n > 0. p \<in> R ^^ n)"
  apply (cases p)
  apply simp
  apply (rule iffI)
   apply (drule tranclD2)
   apply (clarsimp simp: rtrancl_is_UN_relpow)
   apply (rule_tac x="Suc n" in exI)
   apply (clarsimp simp: relcomp_unfold)
   apply fastforce
  apply clarsimp
  apply (case_tac n, simp)
  apply clarsimp
  apply (drule relpow_imp_rtrancl)
  apply (drule rtrancl_into_trancl1) apply auto
  done

lemma tranclp_power:
  "(P^++) x y \<longleftrightarrow> (\<exists>n > 0. (P ^^ n) x y)"
  using trancl_power [to_pred, of P "(x, y)"] by simp

lemma rtrancl_imp_relpow:
  "p \<in> R^* \<Longrightarrow> \<exists>n. p \<in> R ^^ n"
  by (auto dest: rtrancl_imp_UN_relpow)

lemma rtranclp_imp_relpowp:
  "(P^**) x y \<Longrightarrow> \<exists>n. (P ^^ n) x y"
  by (auto dest: rtranclp_imp_Sup_relpowp)

text{* By Sternagel/Thiemann: *}
lemma relpow_fun_conv:
  "((a,b) \<in> R ^^ n) = (\<exists>f. f 0 = a \<and> f n = b \<and> (\<forall>i<n. (f i, f(Suc i)) \<in> R))"
proof (induct n arbitrary: b)
  case 0 show ?case by auto
next
  case (Suc n)
  show ?case
  proof (simp add: relcomp_unfold Suc)
    show "(\<exists>y. (\<exists>f. f 0 = a \<and> f n = y \<and> (\<forall>i<n. (f i,f(Suc i)) \<in> R)) \<and> (y,b) \<in> R)
     = (\<exists>f. f 0 = a \<and> f(Suc n) = b \<and> (\<forall>i<Suc n. (f i, f (Suc i)) \<in> R))"
    (is "?l = ?r")
    proof
      assume ?l
      then obtain c f where 1: "f 0 = a"  "f n = c"  "\<And>i. i < n \<Longrightarrow> (f i, f (Suc i)) \<in> R"  "(c,b) \<in> R" by auto
      let ?g = "\<lambda> m. if m = Suc n then b else f m"
      show ?r by (rule exI[of _ ?g], simp add: 1)
    next
      assume ?r
      then obtain f where 1: "f 0 = a"  "b = f (Suc n)"  "\<And>i. i < Suc n \<Longrightarrow> (f i, f (Suc i)) \<in> R" by auto
      show ?l by (rule exI[of _ "f n"], rule conjI, rule exI[of _ f], insert 1, auto)
    qed
  qed
qed

lemma relpowp_fun_conv:
  "(P ^^ n) x y \<longleftrightarrow> (\<exists>f. f 0 = x \<and> f n = y \<and> (\<forall>i<n. P (f i) (f (Suc i))))"
  by (fact relpow_fun_conv [to_pred])

lemma relpow_finite_bounded1:
assumes "finite(R :: ('a*'a)set)" and "k>0"
shows "R^^k \<subseteq> (UN n:{n. 0<n & n <= card R}. R^^n)" (is "_ \<subseteq> ?r")
proof-
  { fix a b k
    have "(a,b) : R^^(Suc k) \<Longrightarrow> EX n. 0<n & n <= card R & (a,b) : R^^n"
    proof(induct k arbitrary: b)
      case 0
      hence "R \<noteq> {}" by auto
      with card_0_eq[OF `finite R`] have "card R >= Suc 0" by auto
      thus ?case using 0 by force
    next
      case (Suc k)
      then obtain a' where "(a,a') : R^^(Suc k)" and "(a',b) : R" by auto
      from Suc(1)[OF `(a,a') : R^^(Suc k)`]
      obtain n where "n \<le> card R" and "(a,a') \<in> R ^^ n" by auto
      have "(a,b) : R^^(Suc n)" using `(a,a') \<in> R^^n` and `(a',b)\<in> R` by auto
      { assume "n < card R"
        hence ?case using `(a,b): R^^(Suc n)` Suc_leI[OF `n < card R`] by blast
      } moreover
      { assume "n = card R"
        from `(a,b) \<in> R ^^ (Suc n)`[unfolded relpow_fun_conv]
        obtain f where "f 0 = a" and "f(Suc n) = b"
          and steps: "\<And>i. i <= n \<Longrightarrow> (f i, f (Suc i)) \<in> R" by auto
        let ?p = "%i. (f i, f(Suc i))"
        let ?N = "{i. i \<le> n}"
        have "?p ` ?N <= R" using steps by auto
        from card_mono[OF assms(1) this]
        have "card(?p ` ?N) <= card R" .
        also have "\<dots> < card ?N" using `n = card R` by simp
        finally have "~ inj_on ?p ?N" by(rule pigeonhole)
        then obtain i j where i: "i <= n" and j: "j <= n" and ij: "i \<noteq> j" and
          pij: "?p i = ?p j" by(auto simp: inj_on_def)
        let ?i = "min i j" let ?j = "max i j"
        have i: "?i <= n" and j: "?j <= n" and pij: "?p ?i = ?p ?j"
          and ij: "?i < ?j"
          using i j ij pij unfolding min_def max_def by auto
        from i j pij ij obtain i j where i: "i<=n" and j: "j<=n" and ij: "i<j"
          and pij: "?p i = ?p j" by blast
        let ?g = "\<lambda> l. if l \<le> i then f l else f (l + (j - i))"
        let ?n = "Suc(n - (j - i))"
        have abl: "(a,b) \<in> R ^^ ?n" unfolding relpow_fun_conv
        proof (rule exI[of _ ?g], intro conjI impI allI)
          show "?g ?n = b" using `f(Suc n) = b` j ij by auto
        next
          fix k assume "k < ?n"
          show "(?g k, ?g (Suc k)) \<in> R"
          proof (cases "k < i")
            case True
            with i have "k <= n" by auto
            from steps[OF this] show ?thesis using True by simp
          next
            case False
            hence "i \<le> k" by auto
            show ?thesis
            proof (cases "k = i")
              case True
              thus ?thesis using ij pij steps[OF i] by simp
            next
              case False
              with `i \<le> k` have "i < k" by auto
              hence small: "k + (j - i) <= n" using `k<?n` by arith
              show ?thesis using steps[OF small] `i<k` by auto
            qed
          qed
        qed (simp add: `f 0 = a`)
        moreover have "?n <= n" using i j ij by arith
        ultimately have ?case using `n = card R` by blast
      }
      ultimately show ?case using `n \<le> card R` by force
    qed
  }
  thus ?thesis using gr0_implies_Suc[OF `k>0`] by auto
qed

lemma relpow_finite_bounded:
assumes "finite(R :: ('a*'a)set)"
shows "R^^k \<subseteq> (UN n:{n. n <= card R}. R^^n)"
apply(cases k)
 apply force
using relpow_finite_bounded1[OF assms, of k] by auto

lemma rtrancl_finite_eq_relpow:
  "finite R \<Longrightarrow> R^* = (UN n : {n. n <= card R}. R^^n)"
by(fastforce simp: rtrancl_power dest: relpow_finite_bounded)

lemma trancl_finite_eq_relpow:
  "finite R \<Longrightarrow> R^+ = (UN n : {n. 0 < n & n <= card R}. R^^n)"
apply(auto simp add: trancl_power)
apply(auto dest: relpow_finite_bounded1)
done

lemma finite_relcomp[simp,intro]:
assumes "finite R" and "finite S"
shows "finite(R O S)"
proof-
  have "R O S = (UN (x,y) : R. \<Union>((%(u,v). if u=y then {(x,v)} else {}) ` S))"
    by(force simp add: split_def)
  thus ?thesis using assms by(clarsimp)
qed

lemma finite_relpow[simp,intro]:
  assumes "finite(R :: ('a*'a)set)" shows "n>0 \<Longrightarrow> finite(R^^n)"
apply(induct n)
 apply simp
apply(case_tac n)
 apply(simp_all add: assms)
done

lemma single_valued_relpow:
  fixes R :: "('a * 'a) set"
  shows "single_valued R \<Longrightarrow> single_valued (R ^^ n)"
apply (induct n arbitrary: R)
apply simp_all
apply (rule single_valuedI)
apply (fast dest: single_valuedD elim: relpow_Suc_E)
done

subsection {* Bounded transitive closure *}

definition ntrancl :: "nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
where
  "ntrancl n R = (\<Union>i\<in>{i. 0 < i \<and> i \<le> Suc n}. R ^^ i)"

lemma ntrancl_Zero [simp, code]:
  "ntrancl 0 R = R"
proof
  show "R \<subseteq> ntrancl 0 R"
    unfolding ntrancl_def by fastforce
next
  {
    fix i have "0 < i \<and> i \<le> Suc 0 \<longleftrightarrow> i = 1" by auto
  }
  from this show "ntrancl 0 R \<le> R"
    unfolding ntrancl_def by auto
qed

lemma ntrancl_Suc [simp]:
  "ntrancl (Suc n) R = ntrancl n R O (Id \<union> R)"
proof
  {
    fix a b
    assume "(a, b) \<in> ntrancl (Suc n) R"
    from this obtain i where "0 < i" "i \<le> Suc (Suc n)" "(a, b) \<in> R ^^ i"
      unfolding ntrancl_def by auto
    have "(a, b) \<in> ntrancl n R O (Id \<union> R)"
    proof (cases "i = 1")
      case True
      from this `(a, b) \<in> R ^^ i` show ?thesis
        unfolding ntrancl_def by auto
    next
      case False
      from this `0 < i` obtain j where j: "i = Suc j" "0 < j"
        by (cases i) auto
      from this `(a, b) \<in> R ^^ i` obtain c where c1: "(a, c) \<in> R ^^ j" and c2:"(c, b) \<in> R"
        by auto
      from c1 j `i \<le> Suc (Suc n)` have "(a, c) \<in> ntrancl n R"
        unfolding ntrancl_def by fastforce
      from this c2 show ?thesis by fastforce
    qed
  }
  from this show "ntrancl (Suc n) R \<subseteq> ntrancl n R O (Id \<union> R)"
    by auto
next
  show "ntrancl n R O (Id \<union> R) \<subseteq> ntrancl (Suc n) R"
    unfolding ntrancl_def by fastforce
qed

lemma [code]:
  "ntrancl (Suc n) r = (let r' = ntrancl n r in r' Un r' O r)"
unfolding Let_def by auto

lemma finite_trancl_ntranl:
  "finite R \<Longrightarrow> trancl R = ntrancl (card R - 1) R"
  by (cases "card R") (auto simp add: trancl_finite_eq_relpow relpow_empty ntrancl_def)

subsection {* Acyclic relations *}

definition acyclic :: "('a * 'a) set => bool" where
  "acyclic r \<longleftrightarrow> (!x. (x,x) ~: r^+)"

abbreviation acyclicP :: "('a => 'a => bool) => bool" where
  "acyclicP r \<equiv> acyclic {(x, y). r x y}"

lemma acyclic_irrefl [code]:
  "acyclic r \<longleftrightarrow> irrefl (r^+)"
  by (simp add: acyclic_def irrefl_def)

lemma acyclicI: "ALL x. (x, x) ~: r^+ ==> acyclic r"
  by (simp add: acyclic_def)

lemma (in order) acyclicI_order:
  assumes *: "\<And>a b. (a, b) \<in> r \<Longrightarrow> f b < f a"
  shows "acyclic r"
proof -
  { fix a b assume "(a, b) \<in> r\<^sup>+"
    then have "f b < f a"
      by induct (auto intro: * less_trans) }
  then show ?thesis
    by (auto intro!: acyclicI)
qed

lemma acyclic_insert [iff]:
     "acyclic(insert (y,x) r) = (acyclic r & (x,y) ~: r^*)"
apply (simp add: acyclic_def trancl_insert)
apply (blast intro: rtrancl_trans)
done

lemma acyclic_converse [iff]: "acyclic(r^-1) = acyclic r"
by (simp add: acyclic_def trancl_converse)

lemmas acyclicP_converse [iff] = acyclic_converse [to_pred]

lemma acyclic_impl_antisym_rtrancl: "acyclic r ==> antisym(r^*)"
apply (simp add: acyclic_def antisym_def)
apply (blast elim: rtranclE intro: rtrancl_into_trancl1 rtrancl_trancl_trancl)
done

(* Other direction:
acyclic = no loops
antisym = only self loops
Goalw [acyclic_def,antisym_def] "antisym( r^* ) ==> acyclic(r - Id)
==> antisym( r^* ) = acyclic(r - Id)";
*)

lemma acyclic_subset: "[| acyclic s; r <= s |] ==> acyclic r"
apply (simp add: acyclic_def)
apply (blast intro: trancl_mono)
done

subsection {* Setup of transitivity reasoner *}

ML {*

structure Trancl_Tac = Trancl_Tac
(
  val r_into_trancl = @{thm trancl.r_into_trancl};
  val trancl_trans  = @{thm trancl_trans};
  val rtrancl_refl = @{thm rtrancl.rtrancl_refl};
  val r_into_rtrancl = @{thm r_into_rtrancl};
  val trancl_into_rtrancl = @{thm trancl_into_rtrancl};
  val rtrancl_trancl_trancl = @{thm rtrancl_trancl_trancl};
  val trancl_rtrancl_trancl = @{thm trancl_rtrancl_trancl};
  val rtrancl_trans = @{thm rtrancl_trans};

  fun decomp (@{const Trueprop} $ t) =
    let fun dec (Const (@{const_name Set.member}, _) $ (Const (@{const_name Pair}, _) $ a $ b) $ rel ) =
        let fun decr (Const (@{const_name rtrancl}, _ ) $ r) = (r,"r*")
              | decr (Const (@{const_name trancl}, _ ) $ r)  = (r,"r+")
              | decr r = (r,"r");
            val (rel,r) = decr (Envir.beta_eta_contract rel);
        in SOME (a,b,rel,r) end
      | dec _ =  NONE
    in dec t end
    | decomp _ = NONE;
);

structure Tranclp_Tac = Trancl_Tac
(
  val r_into_trancl = @{thm tranclp.r_into_trancl};
  val trancl_trans  = @{thm tranclp_trans};
  val rtrancl_refl = @{thm rtranclp.rtrancl_refl};
  val r_into_rtrancl = @{thm r_into_rtranclp};
  val trancl_into_rtrancl = @{thm tranclp_into_rtranclp};
  val rtrancl_trancl_trancl = @{thm rtranclp_tranclp_tranclp};
  val trancl_rtrancl_trancl = @{thm tranclp_rtranclp_tranclp};
  val rtrancl_trans = @{thm rtranclp_trans};

  fun decomp (@{const Trueprop} $ t) =
    let fun dec (rel $ a $ b) =
        let fun decr (Const (@{const_name rtranclp}, _ ) $ r) = (r,"r*")
              | decr (Const (@{const_name tranclp}, _ ) $ r)  = (r,"r+")
              | decr r = (r,"r");
            val (rel,r) = decr rel;
        in SOME (a, b, rel, r) end
      | dec _ =  NONE
    in dec t end
    | decomp _ = NONE;
);
*}

setup {*
  map_theory_simpset (fn ctxt => ctxt
    addSolver (mk_solver "Trancl" Trancl_Tac.trancl_tac)
    addSolver (mk_solver "Rtrancl" Trancl_Tac.rtrancl_tac)
    addSolver (mk_solver "Tranclp" Tranclp_Tac.trancl_tac)
    addSolver (mk_solver "Rtranclp" Tranclp_Tac.rtrancl_tac))
*}

text {* Optional methods. *}

method_setup trancl =
  {* Scan.succeed (SIMPLE_METHOD' o Trancl_Tac.trancl_tac) *}
  {* simple transitivity reasoner *}
method_setup rtrancl =
  {* Scan.succeed (SIMPLE_METHOD' o Trancl_Tac.rtrancl_tac) *}
  {* simple transitivity reasoner *}
method_setup tranclp =
  {* Scan.succeed (SIMPLE_METHOD' o Tranclp_Tac.trancl_tac) *}
  {* simple transitivity reasoner (predicate version) *}
method_setup rtranclp =
  {* Scan.succeed (SIMPLE_METHOD' o Tranclp_Tac.rtrancl_tac) *}
  {* simple transitivity reasoner (predicate version) *}

end


section\<open>Finite Strings\<close>
text\<open>Finite-String.thy implements a type of strings whose lengths are bounded by a constant defined
    at "proof-time", by taking a sub-type of the built-in string type. A finite length bound is
    important for applications in real analysis, specifically the Differential-Dynamic-Logic (dL)
    entry, because finite-string identifiers are used as the index of a real vector, only forming a
    Euclidean space if identifiers are finite.

    We include finite strings in this AFP entry both to promote using it as the basis of future
    versions of the dL entry and simply in case the typeclass instances herein are useful. One could
    imagine using this type in file formats with fixed-length fields.\<close>
(*  Author:     Rose Bohrer*)

theory "Finite_String"
  imports
    Main
    "HOL-Library.Code_Target_Int"
begin

text\<open>This theory uses induction on pairs of lists often: give names to the cases\<close>
lemmas list_induct2'[case_names BothNil LeftCons RightCons BothCons] = List.list_induct2'

text\<open>Set a hard-coded global maximum string length\<close>
definition max_str:"MAX_STR = 20"

text\<open>Finite strings are strings whose size is within the maximum\<close>
typedef fin_string = "{s::string. size s \<le> MAX_STR}"
  morphisms Rep_fin_string Abs_fin_string
  apply(auto)
  apply(rule exI[where x=Nil])
  by(auto simp add: max_str)

text\<open>Lift definition of string length\<close>
setup_lifting  Finite_String.fin_string.type_definition_fin_string
lift_definition ilength::"fin_string \<Rightarrow> nat" is length done

text\<open>Product of types never decreases cardinality\<close>
lemma card_prod_finite:
  fixes C:: "char set" and S::"string set"
  assumes C:"card C \<ge> 1" and S:"card S \<ge> 0"
  shows "card C * card S \<ge> card S"
  using C S by auto

fun cons :: "('a * 'a list) \<Rightarrow> 'a list"
  where "cons (x,y) = x # y"

text\<open>Finite strings are finite\<close>
instantiation fin_string :: finite begin
instance proof
  have any:"\<forall>i::nat. card {s::string. length s \<le> i} > 0"
    apply(auto)
    subgoal for i
  proof (induct i)
    case 0
    then show ?case by auto
  next
    case (Suc k)
    assume IH:"card {s::string. length s \<le> k} > 0"
    let ?c = "(UNIV::char set)"
    let ?ih = "{s::string. length s \<le> k}"
    let ?prod = "(?c \<times> ?ih)"
    let ?b = "(cons ` ?prod)"
    let ?A = "{s::string. length s \<le> Suc k}"
    let ?B = "insert [] ?b"
    have IHfin:"finite ?ih" using IH card_ge_0_finite by blast
    have finChar:"finite ?c" using card_ge_0_finite finite_code by blast
    have finiteProd:"finite ?prod"
      using Groups_Big.card_cartesian_product IHfin finChar by auto
    have cardCons:"card ?b = card ?prod"
      apply(rule Finite_Set.card_image)
      by(auto simp add: inj_on_def)
    have finiteCons:"finite ?b" using cardCons finiteProd card_ge_0_finite by blast
    have finiteB:"finite ?B" using finite_insert finiteCons by auto
    have lr:"\<And>x. x \<in> ?A \<Longrightarrow> x \<in> ?B" subgoal for x
      apply(auto) apply(cases x) apply auto
      by (metis UNIV_I cons.simps image_eqI mem_Collect_eq mem_Sigma_iff) done
    have rl:"\<And>x. x \<in> ?B \<Longrightarrow> x \<in> ?A" subgoal for x
      by(auto) done
    have isCons:"?A = ?B"
      using lr rl by auto
  show ?case
      using finiteB isCons IH by (simp add: card.insert_remove)
  qed
  done
  note finMax = card_ge_0_finite[OF spec[OF any, of MAX_STR]]
  have fin:"finite {x | x y . x = Abs_fin_string y \<and> y \<in> {s. length s \<le> MAX_STR}}"
    using Abs_fin_string_cases finMax by auto
  have univEq:"UNIV = {x | x y . x = Abs_fin_string y \<and> y \<in> {s. length s \<le> MAX_STR}}"
    using Abs_fin_string_cases
    by (metis (mono_tags, lifting) Collect_cong UNIV_I top_empty_eq top_set_def)
  then have "finite (UNIV :: fin_string set)" using univEq fin by auto
  then show "finite (UNIV::fin_string set)" by auto
qed
end

text\<open>Characters are linearly ordered by their code value\<close>
instantiation char :: linorder begin
definition less_eq_char where
less_eq_char[code]:"less_eq_char x  y \<equiv> int_of_char x \<le> int_of_char y"
definition less_char where
less_char[code]:"less_char x y \<equiv> int_of_char x < int_of_char y"
instance
  by(standard, auto simp add: less_char less_eq_char int_of_char_def)+
end

text\<open>Finite strings are linearly ordered, lexicographically\<close>
instantiation fin_string :: linorder begin
fun lleq_charlist :: "char list \<Rightarrow> char list \<Rightarrow> bool"
  where
  "lleq_charlist Nil Nil = True"
| "lleq_charlist Nil _ = True"
| "lleq_charlist _ Nil = False"
| "lleq_charlist (x # xs)(y # ys) =
   (if x = y then lleq_charlist xs ys else x < y)"

fun less_charlist :: "char list \<Rightarrow> char list \<Rightarrow> bool"
  where
  "less_charlist Nil Nil = False"
| "less_charlist Nil _ = True"
| "less_charlist _ Nil = False"
| "less_charlist (x # xs)(y # ys) =
   (if x = y then less_charlist xs ys else x < y)"

lift_definition less_eq_fin_string::"fin_string \<Rightarrow> fin_string \<Rightarrow> bool" is lleq_charlist done
lift_definition less_fin_string::"fin_string \<Rightarrow> fin_string \<Rightarrow> bool" is less_charlist done

lemma lleq_head:
  fixes L1 L2 x
  assumes a:
  "(\<And>z. lleq_charlist L2 z \<Longrightarrow> lleq_charlist L1 z)"
  "lleq_charlist L1 L2"
  "lleq_charlist (x # L2) w"
  shows "lleq_charlist (x # L1) w"
  using a by(induction arbitrary: x rule: List.list_induct2', auto)

lemma lleq_less:
  fixes x y
  shows "(less_charlist x y) = (lleq_charlist x y \<and> \<not> lleq_charlist y  x)"
  by(induction rule: List.list_induct2', auto)

lemma lleq_refl:
  fixes x
  shows "lleq_charlist x x"
  by(induction x, auto)

lemma lleq_trans:
  fixes x y z
  shows "lleq_charlist x y \<Longrightarrow> lleq_charlist y z \<Longrightarrow> lleq_charlist x z"
proof(induction arbitrary: z rule: list_induct2')
  case BothNil
  then show ?case  by auto
next
  case (LeftCons x xs)
  then show ?case
    apply(induction y)
    using lleq_charlist.elims(2) lleq_charlist.simps(2) by blast+
next
  case (RightCons y ys)
  then show ?case by auto
next
  case (BothCons x xs y ys z)
  then show ?case
    using lleq_head[of xs ys x z] apply(cases "x = y", auto)
    apply(cases z, auto)
    subgoal for a list
    by(cases "x = a", auto)
    done
qed

lemma lleq_antisym:
  fixes x y
  shows "lleq_charlist x y \<Longrightarrow> lleq_charlist y x \<Longrightarrow> x = y"
proof(induction rule: list_induct2')
     case (LeftCons x xs)      then show ?case by(cases "xs=y",auto)
next case (RightCons y ys)     then show ?case by(cases "x=ys",auto)
next case (BothCons x xs y ys) then show ?case by(cases "x=y", auto)
qed (auto)

lemma lleq_dichotomy:
  fixes x y
  shows "lleq_charlist x y \<or> lleq_charlist y x"
  by(induction rule: List.list_induct2',auto)

instance
  apply(standard)
      unfolding less_eq_fin_string_def less_fin_string_def
      apply (auto simp add: lleq_less lleq_refl lleq_trans lleq_dichotomy)
  using lleq_antisym less_eq_fin_string_def less_fin_string_def Rep_fin_string_inject by blast
end

fun string_expose::"string \<Rightarrow> (unit + (char * string))"
  where "string_expose Nil = Inl ()"
  | "string_expose (c#cs) = Inr(c,cs)"

fun string_cons::"char \<Rightarrow> string \<Rightarrow> string"
  where "string_cons c s = (if length s \<ge> MAX_STR then s else c # s)"

lift_definition fin_string_empty::fin_string is "''''" by(auto simp add: max_str)
lift_definition fin_string_cons::"char \<Rightarrow> fin_string \<Rightarrow> fin_string" is "string_cons" by auto
lift_definition fin_string_expose::"fin_string \<Rightarrow> (unit + (char*fin_string))" is string_expose
  apply(auto simp add: dual_order.trans less_imp_le pred_sum.simps string_expose.elims)
  by (metis dual_order.trans impossible_Cons le_cases string_expose.elims)

text\<open>Helper functions for enum typeclass instance\<close>
fun fin_string_upto :: "nat \<Rightarrow> fin_string list"
  where
  "fin_string_upto 0 = [fin_string_empty]"
| "fin_string_upto (Suc k) =
 (let r = fin_string_upto k in
  let ab =  (enum_class.enum::char list) in
  fin_string_empty # concat (map (\<lambda> c. map (\<lambda>s. fin_string_cons c  s) r) ab))"

lemma mem_appL:"List.member L1 x \<Longrightarrow> List.member (L1 @ L2) x"
  apply(induction L1 arbitrary: L2)
  by(auto simp add: member_rec)

lemma mem_appR:"List.member L2 x \<Longrightarrow> List.member (L1 @ L2) x"
  apply(induction L1 arbitrary: L2)
  by(auto simp add: member_rec)

lemma mem_app_or:"List.member (L1 @ L2) x = List.member L1 x \<or> List.member L2 x"
  unfolding member_def by auto

lemma fin_string_nil:
  fixes n
  shows "List.member (fin_string_upto n) fin_string_empty"
  by(induction n, auto simp add: member_rec Let_def fin_string_empty_def)

text\<open>List of every string. Not practical for code generation but used to show strings are an enum\<close>
definition vals_def[code]:"vals \<equiv> fin_string_upto MAX_STR"

definition fin_string_enum :: "fin_string list"
  where "fin_string_enum = vals"
definition fin_string_enum_all :: "(fin_string \<Rightarrow> bool) \<Rightarrow> bool"
  where "fin_string_enum_all = (\<lambda> f. list_all f vals)"
definition fin_string_enum_ex :: "(fin_string \<Rightarrow> bool) \<Rightarrow> bool"
  where "fin_string_enum_ex = (\<lambda> f. list_ex f vals)"

text\<open>Induct on the length of a bounded list, with access to index of element\<close>
lemma length_induct:
  fixes P
  assumes len:"length L \<le> MAX_STR"
  assumes BC:"P [] 0"
  assumes IS:"(\<And>k x xs.  P xs k \<Longrightarrow> P ((x # xs)) (Suc k))"
  shows "P L (length L)"
  proof -
    have "\<And>k.  length L = k \<Longrightarrow> k \<le> MAX_STR \<Longrightarrow> P L (length L)"
    proof (induction L)
      case Nil then show ?case using BC by auto
    next
      case (Cons a L)
      then have it:"P (L) (length L)" using less_imp_le by fastforce
      then show ?case  using IS[OF it, of a] by (auto)
    qed
  then show ?thesis using BC IS len by auto
  qed

text\<open>Induct on length of fin-string\<close>
lemma ilength_induct:
  fixes P
  assumes BC:"P fin_string_empty 0"
  assumes IS:"(\<And>k x xs.  P xs k \<Longrightarrow> P (Abs_fin_string (x # Rep_fin_string xs)) (Suc k))"
  shows  "P L (ilength L)"
  apply(cases L)
  apply(unfold ilength_def)
  apply(auto simp add: Abs_fin_string_inverse)
  subgoal for y
  proof -
    assume a1:"L = Abs_fin_string y"
    assume a2:" length y \<le> MAX_STR "
    have main:"\<And>k. L = Abs_fin_string y \<Longrightarrow> length y = k \<Longrightarrow> k \<le> MAX_STR
        \<Longrightarrow> P (Abs_fin_string y) (length y)"
      subgoal for k
        apply(induction y arbitrary: k L)
        subgoal for k using BC unfolding fin_string_empty_def by auto
        subgoal for a y k L
        proof -
          assume IH:"(\<And>k L. L = Abs_fin_string y \<Longrightarrow> length y = k \<Longrightarrow> k \<le> MAX_STR
            \<Longrightarrow> P (Abs_fin_string y) (length y))"
          assume L:"L = Abs_fin_string (a # y)"
          assume l:"length (a # y) = k"
          assume str:"k \<le> MAX_STR"
          have yLen:"length y < MAX_STR" using l str by auto
          have it:"P (Abs_fin_string y) (length y)"
            using IH[of "Abs_fin_string y" "k-1", OF refl] using L l str by auto
          show  "P (Abs_fin_string (a # y)) (length (a # y))"
            using IS[OF it, of a] apply (auto simp add: fin_string_cons_def Abs_fin_string_inverse)
            apply(cases "MAX_STR \<le> length (Rep_fin_string (Abs_fin_string y))")
            using yLen by(auto simp add: l yLen Abs_fin_string_inverse)
        qed
        done
      done
    show ?thesis
      apply(rule main)
      using BC IS a1 a2 by auto
  qed
  done

lemma enum_chars:"set (enum_class.enum::char list)= UNIV"
  using Enum.enum_class.enum_UNIV by auto

lemma member_concat:"List.member (concat LL) x = (\<exists>L. List.member LL L \<and> List.member L x)"
  by(auto simp add: member_def)

text\<open>fin-string-upto k enumerates all strings up to length $min(k,MAX\_STR)$\<close>
lemma fin_string_length:
  fixes L::string
  assumes len:"length L \<le> k"
  assumes Len:"length L \<le> MAX_STR"
  shows "List.member (fin_string_upto k) (Abs_fin_string L)"
proof -
  have BC:"\<forall>j\<ge>0. 0 \<le> MAX_STR \<longrightarrow> length [] = 0 \<longrightarrow>
    List.member (fin_string_upto j) (Abs_fin_string [])"
    apply(auto)
    subgoal for j
      apply(cases j)
      by (auto simp add: fin_string_empty_def member_rec)
    done
  have IS:"(\<And>k x xs.
      \<forall>j\<ge>k. k\<le>MAX_STR \<longrightarrow> length xs=k \<longrightarrow> List.member (fin_string_upto j) (Abs_fin_string xs)\<Longrightarrow>
      \<forall>j\<ge>Suc k. Suc k \<le> MAX_STR \<longrightarrow> length (x # xs) = Suc k
        \<longrightarrow> List.member (fin_string_upto j) (Abs_fin_string (x # xs)))"
    subgoal for k x xs
    proof -
      assume "\<forall>j\<ge>k. k \<le> MAX_STR \<longrightarrow> length xs = k
        \<longrightarrow> List.member (fin_string_upto j) (Abs_fin_string xs)"
      then have IH:"\<And>j. j\<ge> k \<Longrightarrow> k \<le> MAX_STR \<Longrightarrow> length xs = k
        \<Longrightarrow> List.member (fin_string_upto j) (Abs_fin_string xs)"
        by auto
      show ?thesis
        apply(auto)
        subgoal for j
        proof -
          assume kj:"Suc (length xs) \<le> j"
          assume sucMax:"Suc (length xs) \<le> MAX_STR"
          assume ilen:" k = length xs"
          obtain jj where jj[simp]:"j = Suc jj" using kj Suc_le_D by auto
          then have kMax:"k < MAX_STR" using jj kj Suc_le_D ilen
            by (simp add: less_eq_Suc_le sucMax)
           have res:"List.member (fin_string_upto (jj)) (Abs_fin_string xs)"
            using IH[of "jj"] kj jj ilen  Suc_leD sucMax by blast
          have neq:"Abs_fin_string [] \<noteq> Abs_fin_string (x # xs)"
            using Abs_fin_string_inverse fin_string_empty.abs_eq fin_string_empty.rep_eq
              len length_Cons list.distinct(1) mem_Collect_eq
            by (metis ilen sucMax)
          have univ:" set enum_class.enum  = (UNIV::char set)" using enum_chars by auto
          have "List.member (fin_string_upto j) (Abs_fin_string (x # xs))"
            apply(auto simp add: member_rec(2) fin_string_empty_def)
            using len sucMax
            apply(auto simp add: member_rec fin_string_empty_def fin_string_cons_def
                Abs_fin_string_inverse Rep_fin_string_inverse neq)
          proof -
            let ?witLL = "(\<lambda> x. map (map_fun Rep_fin_string Abs_fin_string (string_cons x))
                            (fin_string_upto jj))"
            have f1: "Abs_fin_string xs \<in> set (fin_string_upto jj)"
                by (metis member_def res)
            have f2:"Abs_fin_string (x # xs) = Abs_fin_string
                      (if MAX_STR \<le> length (Rep_fin_string (Abs_fin_string xs))
                       then Rep_fin_string (Abs_fin_string xs)
                       else x # Rep_fin_string (Abs_fin_string xs))"
                using Abs_fin_string_inverse ilen kMax by auto
            have ex:"\<exists> LL. (List.member (map ?witLL enum_class.enum) LL)
                          \<and> List.member LL (Abs_fin_string (x # xs))"
              apply(rule exI[where x="?witLL x"])
              apply(auto simp add: member_def univ)
              using f1 f2 by blast
            show "List.member (concat (map ?witLL enum_class.enum))
                    (Abs_fin_string (x # xs))"
              using member_concat ex by fastforce
          qed
          then show "List.member (fin_string_upto j) (Abs_fin_string (x # xs))"  by auto
        qed
        done
    qed
    done
  have impl:"length L \<le> k \<Longrightarrow> List.member (fin_string_upto k) (Abs_fin_string L)"
    using len Len
    length_induct[where P = "(\<lambda> L k. \<forall> j \<ge> k. k \<le> MAX_STR \<longrightarrow> length L = k
        \<longrightarrow> List.member (fin_string_upto j) (Abs_fin_string L))"
      , OF Len BC IS]
      by auto
    show ?thesis
    using impl len by auto
qed

lemma fin_string_upto_length:
  shows "List.member (fin_string_upto n) L \<Longrightarrow> ilength L \<le> n"
  apply(induction n arbitrary: L)
   apply(auto simp add: fin_string_empty_def Let_def ilength_def fin_string_cons_def
     Rep_fin_string_inverse Abs_fin_string_inverse member_rec)
proof -
  fix n L
  let ?witLL = "(\<lambda>x. map(map_fun Rep_fin_string Abs_fin_string(string_cons x))(fin_string_upto n))"
  assume len:"(\<And>L. List.member (fin_string_upto n) L \<Longrightarrow> length (Rep_fin_string L) \<le> n)"
  assume mem:"List.member (concat (map ?witLL enum_class.enum)) L"
  have L:"List.member (fin_string_upto n) L \<Longrightarrow> length (Rep_fin_string L) \<le> Suc n"
    using len[of L] by auto
  assume a:"List.member (concat (map ?witLL enum_class.enum)) L"
  obtain LL where conc:"List.member (map ?witLL enum_class.enum) LL"
    and concmem:"List.member LL L"
    using member_concat a by metis
  obtain c cs where c:"L = fin_string_cons c cs" and cs:"List.member (fin_string_upto n) cs"
    using a conc unfolding member_def apply(auto)
    subgoal for c d cs
      apply(cases "MAX_STR \<le> length (Rep_fin_string cs)")
      apply(auto simp add: Rep_fin_string_inverse)
      by (metis (full_types) Rep_fin_string_inverse fin_string_cons.rep_eq string_cons.simps)+
    done
  then have "ilength (fin_string_cons c cs) \<le> (Suc n)"
    using len[of cs] unfolding ilength_def fin_string_cons_def
    apply (auto simp add: Rep_fin_string_inverse)
    using c fin_string_cons.rep_eq by force
  then show "length (Rep_fin_string L) \<le> Suc n"
    using c ilength.rep_eq by auto
qed

text\<open>fin-string-upto produces no duplicate identifiers\<close>
lemma distinct_upto:
  shows "i \<le> MAX_STR \<Longrightarrow> distinct (fin_string_upto i)"
proof (induction i)
  case 0
  then show ?case by(auto)
next
  case (Suc j) then
  have jLen:"Suc j \<le> MAX_STR"
    and IH:"distinct (fin_string_upto j)" by auto
  have distinct_char:"distinct (enum_class.enum:: char list)"
    by (auto simp add: distinct_map enum_char_unfold)
  have diseq:"\<And> x y. y \<in> set (fin_string_upto j) \<Longrightarrow>  fin_string_empty \<noteq> fin_string_cons x y"
    using Rep_fin_string_inverse jLen apply(auto simp add: fin_string_empty_def fin_string_cons_def)
    using fin_string_empty.rep_eq le_zero_eq list.size not_less_eq_eq zero_le Abs_fin_string_inject
    by (metis,auto)
  show ?case
    apply(auto simp add: Let_def)
    subgoal for x xa using diseq by auto
    apply(rule distinct_concat)
    subgoal
      apply(auto simp add: distinct_map)
       apply(rule distinct_char)
      apply(rule subset_inj_on[where B=UNIV])
       apply(rule injI)
       apply(auto simp add: fin_string_cons_def)
    proof -
      fix x y
      let ?l = "(\<lambda>xa x. Abs_fin_string
        (if MAX_STR \<le> length (Rep_fin_string xa)
         then Rep_fin_string xa
         else x # Rep_fin_string xa))"
      assume a1:"\<forall>xa\<in>set (fin_string_upto j). ?l xa x = ?l xa y"
      then have a2:"\<And>xa. (List.member (fin_string_upto j) xa) \<Longrightarrow> ?l xa x = ?l xa y"
        using  member_def by force
      then have "Abs_fin_string [x] = Abs_fin_string [y] \<or> (MAX_STR::nat) = 0"
        using a2 fin_string_empty.rep_eq fin_string_nil by force
      then show "x = y"
        by (metis Abs_fin_string_inverse jLen le_zero_eq length_Cons list.inject list.size(3)
            mem_Collect_eq nat.distinct(1) not_less_eq_eq)
    qed
    subgoal for ys
      apply(auto simp add: fin_string_cons_def)
    proof -
      fix c :: char
      assume c:"c \<in> set enum_class.enum"
      assume ys:"ys=map(map_fun Rep_fin_string Abs_fin_string (string_cons c)) (fin_string_upto j)"
      show"distinct(map(map_fun Rep_fin_string Abs_fin_string (string_cons c)) (fin_string_upto j))"
        unfolding distinct_map apply(rule conjI)
         apply(rule IH)
        apply(rule inj_onI)
        apply(auto)
        subgoal for x y
          using jLen fin_string_upto_length[of j x] fin_string_upto_length[of j y]
          unfolding List.member_def ilength_def apply auto
          by (metis (mono_tags, opaque_lifting) Rep_fin_string_inverse fin_string_cons.rep_eq le_trans
              list.inject not_less_eq_eq string_cons.simps)
          done
      qed
      apply(auto simp add: fin_string_cons_def)
      subgoal for c ca xa xb xc
        apply(cases "MAX_STR \<le> length (Rep_fin_string xa)")
         apply (metis fin_string_upto_length jLen ilength.rep_eq le_trans member_def not_less_eq_eq)
        apply(cases "MAX_STR \<le> length (Rep_fin_string xb)")
         apply(metis fin_string_upto_length jLen ilength.rep_eq le_trans member_def not_less_eq_eq)
        apply(cases "MAX_STR \<le> length (Rep_fin_string xc)")
         by(auto,metis Rep_fin_string_inverse fin_string_cons.rep_eq list.inject string_cons.simps)
      done
  qed

text\<open>Finite strings are an enumeration type\<close>
instantiation fin_string :: enum begin
definition enum_fin_string
  where enum_fin_string_def[code]:"enum_fin_string \<equiv> fin_string_enum"
definition enum_all_fin_string
  where enum_all_fin_string[code]:"enum_all_fin_string \<equiv> fin_string_enum_all"
definition enum_ex_fin_string
  where enum_ex_fin_string[code]:"enum_ex_fin_string \<equiv> fin_string_enum_ex"
lemma enum_ALL:"(UNIV::fin_string set) = set enum_class.enum"
  apply(auto simp add:enum_fin_string_def fin_string_enum_def vals_def)
  by(metis fin_string_length List.member_def mem_Collect_eq Abs_fin_string_cases)

lemma vals_ALL:"set (vals::fin_string list) = UNIV"
  using enum_ALL vals_def Rep_fin_string fin_string_length ilength.rep_eq member_def
  by(metis (mono_tags) Rep_fin_string_inverse UNIV_eq_I mem_Collect_eq)

lemma setA:
  assumes set:"\<And>y. y \<in> set L \<Longrightarrow> P y"
  shows "list_all P L"
  using set  by (simp add: list.pred_set)

lemma setE:
  assumes set:" y \<in> set L"
  assumes P:"P y"
  shows "list_ex P L"
  using set P  list_ex_iff by auto

instance
  apply(standard)
  apply(rule enum_ALL)
  by (auto simp add: fin_string_enum_all_def list_all_iff vals_ALL setA setE enum_all_fin_string
      enum_ALL fin_string_enum_def vals_def enum_fin_string_def distinct_upto list_ex_iff
      enum_ex_fin_string fin_string_enum_ex_def)
end

instantiation fin_string :: equal begin
definition equal_fin_string :: "fin_string \<Rightarrow> fin_string \<Rightarrow> bool"
  where [code]:"equal_fin_string X Y = (X \<le> Y \<and> Y \<le> X)"
instance
  apply(standard)
  by(auto simp add: equal_fin_string_def)
end
end