(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Direct Proofs for Cardinality of Bijections\<close>

theory Card_Bijections_Direct
imports
  Equiv_Relations_on_Functions
  Twelvefold_Way_Core
begin

subsection \<open>Bijections from A to B up to a Permutation on A\<close>

subsubsection \<open>Equivalence Class\<close>

lemma bijections_in_domain_permutation:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B"
proof -
  from assms obtain f where f: "f \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}"
    by (metis finite_same_card_bij_on_ext_funcset mem_Collect_eq)
  moreover have proj_f: "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = domain_permutation A B `` {f}"
  proof
    from f show "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} \<subseteq> domain_permutation A B `` {f}"
      unfolding domain_permutation_def
      by (auto elim: obtain_domain_permutation_for_two_bijections)
  next
    show "domain_permutation A B `` {f} \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}"
    proof
      fix f'
      assume "f' \<in> domain_permutation A B `` {f}"
      have "(f', f) \<in> domain_permutation A B"
        using \<open>f' \<in> domain_permutation A B `` {f}\<close> equiv_domain_permutation[of A B]
        by (simp add: equiv_class_eq_iff)
      from this obtain p where "p permutes A" "\<forall>x\<in>A. f' x = f (p x)"
        unfolding domain_permutation_def by auto
      from this have "bij_betw (f \<circ> p) A B"
        using bij_betw_comp_iff f permutes_imp_bij by fastforce
      from this have "bij_betw f' A B"
        using \<open>\<forall>x\<in>A. f' x = f (p x)\<close>
        by (metis (mono_tags, lifting) bij_betw_cong comp_apply)
      moreover have "f' \<in> A \<rightarrow>\<^sub>E B"
        using \<open>f' \<in> domain_permutation A B `` {f}\<close>
        unfolding domain_permutation_def by auto
      ultimately show "f' \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}" by simp
    qed
  qed
  ultimately show ?thesis by (simp add: quotientI)
qed

lemma bij_betw_quotient_domain_permutation_eq:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B = {{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}}"
proof
  show "{{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}} \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B"
    by (simp add: bijections_in_domain_permutation[OF assms])
next
  show "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B \<subseteq> {{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}}"
  proof
    fix F
    assume F_in: "F \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B"
    have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B = {F \<in> ((A \<rightarrow>\<^sub>E B) // domain_permutation A B). univ (\<lambda>f. bij_betw f A B) F}"
      using equiv_domain_permutation[of A B] bij_betw_respects_domain_permutation[of A B] by (simp only: univ_preserves_predicate)
    from F_in this have "F \<in> (A \<rightarrow>\<^sub>E B) // domain_permutation A B"
      and "univ (\<lambda>f. bij_betw f A B) F"
      by blast+
    have "F = {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}"
    proof
      have "\<forall>f \<in> F. f \<in> A \<rightarrow>\<^sub>E B"
        using \<open>F \<in> (A \<rightarrow>\<^sub>E B) // domain_permutation A B\<close>
        by (metis ImageE equiv_class_eq_iff equiv_domain_permutation quotientE)
      moreover have "\<forall>f \<in> F. bij_betw f A B"
        using univ_predicate_impl_forall[OF equiv_domain_permutation bij_betw_respects_domain_permutation]
        using \<open>F \<in> (A \<rightarrow>\<^sub>E B) // domain_permutation A B\<close> \<open>univ (\<lambda>f. bij_betw f A B) F\<close>
        by auto
      ultimately show "F \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}" by auto
    next
      show "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} \<subseteq> F"
      proof
        fix f'
        assume "f' \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}"
        from this have "f' \<in> A \<rightarrow>\<^sub>E B" "bij_betw f' A B" by auto
          obtain f where "f \<in> A \<rightarrow>\<^sub>E B" and "F = domain_permutation A B `` {f}"
          using \<open>F \<in> (A \<rightarrow>\<^sub>E B) // domain_permutation A B\<close> by (auto elim: quotientE)
        have "bij_betw f A B"
          using univ_commute'[OF equiv_domain_permutation bij_betw_respects_domain_permutation]
          using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>F = domain_permutation A B `` {f}\<close> \<open>univ (\<lambda>f. bij_betw f A B) F\<close>
          by auto
        obtain p where "p permutes A" "\<forall>x\<in>A. f x = f' (p x)"
          using obtain_domain_permutation_for_two_bijections
          using \<open>bij_betw f A B\<close> \<open>bij_betw f' A B\<close> by blast
        from this \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close>
        have "(f, f') \<in> domain_permutation A B"
          unfolding domain_permutation_def by auto
        from this show "f' \<in> F"
          using \<open>F = domain_permutation A B `` {f}\<close> by simp
      qed
    qed
    from this show "F \<in> {{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}}" by simp
  qed
qed

subsubsection \<open>Cardinality\<close>

lemma
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_permutation A B) = 1"
using bij_betw_quotient_domain_permutation_eq[OF assms] by auto

subsection \<open>Bijections from A to B up to a Permutation on B\<close>

subsubsection \<open>Equivalence Class\<close>

lemma bijections_in_range_permutation:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B"
proof -
  from assms obtain f where f: "f \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}"
    by (metis finite_same_card_bij_on_ext_funcset mem_Collect_eq)
  moreover have proj_f: "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = range_permutation A B `` {f}"
  proof
    from f show "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} \<subseteq> range_permutation A B `` {f}"
      unfolding range_permutation_def
      by (auto elim: obtain_range_permutation_for_two_bijections)
  next
    show "range_permutation A B `` {f} \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}"
    proof
      fix f'
      assume "f' \<in> range_permutation A B `` {f}"
      have "(f', f) \<in> range_permutation A B"
        using \<open>f' \<in> range_permutation A B `` {f}\<close> equiv_range_permutation[of A B]
        by (simp add: equiv_class_eq_iff)
      from this obtain p where "p permutes B" "\<forall>x\<in>A. f' x = p (f x)"
        unfolding range_permutation_def by auto
      from this have "bij_betw (p \<circ> f) A B"
        using bij_betw_comp_iff f permutes_imp_bij by fastforce
      from this have "bij_betw f' A B"
        using \<open>\<forall>x\<in>A. f' x = p (f x)\<close>
        by (metis (mono_tags, lifting) bij_betw_cong comp_apply)
      moreover have "f' \<in> A \<rightarrow>\<^sub>E B"
        using \<open>f' \<in> range_permutation A B `` {f}\<close>
        unfolding range_permutation_def by auto
      ultimately show "f' \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}" by simp
    qed
  qed
  ultimately show ?thesis by (simp add: quotientI)
qed

lemma bij_betw_quotient_range_permutation_eq:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B = {{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}}"
proof
  show "{{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}} \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B"
    by (simp add: bijections_in_range_permutation[OF assms])
next
  show "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B \<subseteq> {{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}}"
  proof
    fix F
    assume F_in: "F \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B"
    have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B = {F \<in> ((A \<rightarrow>\<^sub>E B) // range_permutation A B). univ (\<lambda>f. bij_betw f A B) F}"
      using equiv_range_permutation[of A B] bij_betw_respects_range_permutation[of A B] by (simp only: univ_preserves_predicate)
    from this F_in have "F \<in> (A \<rightarrow>\<^sub>E B) // range_permutation A B"
      and "univ (\<lambda>f. bij_betw f A B) F" by blast+
    have "F = {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}"
    proof
      have "\<forall>f \<in> F. f \<in> A \<rightarrow>\<^sub>E B"
        using \<open>F \<in> (A \<rightarrow>\<^sub>E B) // range_permutation A B\<close>
        by (metis ImageE equiv_class_eq_iff equiv_range_permutation quotientE)
      moreover have "\<forall>f \<in> F. bij_betw f A B"
        using univ_predicate_impl_forall[OF equiv_range_permutation bij_betw_respects_range_permutation]
        using \<open>F \<in> (A \<rightarrow>\<^sub>E B) // range_permutation A B\<close> \<open>univ (\<lambda>f. bij_betw f A B) F\<close>
        by auto
      ultimately show "F \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}" by auto
    next
      show "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} \<subseteq> F"
      proof
        fix f'
        assume "f' \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}"
        from this have "f' \<in> A \<rightarrow>\<^sub>E B" "bij_betw f' A B" by auto
          obtain f where "f \<in> A \<rightarrow>\<^sub>E B" and "F = range_permutation A B `` {f}"
          using \<open>F \<in> (A \<rightarrow>\<^sub>E B) // range_permutation A B\<close> by (auto elim: quotientE)
        have "bij_betw f A B"
          using univ_commute'[OF equiv_range_permutation bij_betw_respects_range_permutation]
          using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>F = range_permutation A B `` {f}\<close> \<open>univ (\<lambda>f. bij_betw f A B) F\<close>
          by auto
        obtain p where "p permutes B" "\<forall>x\<in>A. f x = p (f' x)"
          using obtain_range_permutation_for_two_bijections
          using \<open>bij_betw f A B\<close> \<open>bij_betw f' A B\<close> by blast
        from this \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close>
        have "(f, f') \<in> range_permutation A B"
          unfolding range_permutation_def by auto
        from this show "f' \<in> F"
          using \<open>F = range_permutation A B `` {f}\<close> by simp
      qed
    qed
    from this show "F \<in> {{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}}" by simp
  qed
qed

subsubsection \<open>Cardinality\<close>

lemma card_bijections_range_permutation_eq_1:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // range_permutation A B) = 1"
using bij_betw_quotient_range_permutation_eq[OF assms] by auto

subsection \<open>Bijections from A to B up to a Permutation on A and B\<close>

subsubsection \<open>Equivalence Class\<close>

lemma bijections_in_domain_and_range_permutation:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B"
proof -
  from assms obtain f where f: "f \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}"
    by (metis finite_same_card_bij_on_ext_funcset mem_Collect_eq)
  moreover have proj_f: "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} = domain_and_range_permutation A B `` {f}"
  proof
    have "id permutes A" by (simp add: permutes_id)
    from f this show "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} \<subseteq> domain_and_range_permutation A B `` {f}"
      unfolding domain_and_range_permutation_def
      by (fastforce elim: obtain_range_permutation_for_two_bijections)
  next
    show "domain_and_range_permutation A B `` {f} \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}"
    proof
      fix f'
      assume "f' \<in> domain_and_range_permutation A B `` {f}"
      have "(f', f) \<in> domain_and_range_permutation A B"
        using \<open>f' \<in> domain_and_range_permutation A B `` {f}\<close> equiv_domain_and_range_permutation[of A B]
        by (simp add: equiv_class_eq_iff)
      from this obtain p\<^sub>A p\<^sub>B where "p\<^sub>A permutes A" "p\<^sub>B permutes B"
        and "\<forall>x\<in>A. f' x = p\<^sub>B (f (p\<^sub>A x))"
        unfolding domain_and_range_permutation_def by auto
      from this have "bij_betw (p\<^sub>B \<circ> f \<circ> p\<^sub>A) A B"
        using bij_betw_comp_iff f permutes_imp_bij
        by (metis (no_types, lifting) mem_Collect_eq)
      from this have "bij_betw f' A B"
        using \<open>\<forall>x\<in>A. f' x = p\<^sub>B (f (p\<^sub>A x))\<close>
        by (auto intro: bij_betw_congI)
      moreover have "f' \<in> A \<rightarrow>\<^sub>E B"
        using \<open>f' \<in> domain_and_range_permutation A B `` {f}\<close>
        unfolding domain_and_range_permutation_def by auto
      ultimately show "f' \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}" by simp
    qed
  qed
  ultimately show ?thesis by (simp add: quotientI)
qed

lemma bij_betw_quotient_domain_and_range_permutation_eq:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B = {{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}}"
proof
  show "{{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}}
    \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B"
    using bijections_in_domain_and_range_permutation[OF assms] by auto
next
  show "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B \<subseteq> {{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}}"
  proof
    fix F
    assume F_in: "F \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B"
    have "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B = {F \<in> ((A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B). univ (\<lambda>f. bij_betw f A B) F}"
      using equiv_domain_and_range_permutation[of A B] bij_betw_respects_domain_and_range_permutation[of A B] by (simp only: univ_preserves_predicate)
    from F_in this have "F \<in> (A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B"
      and "univ (\<lambda>f. bij_betw f A B) F" by blast+
    have "F = {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}"
    proof
      have "\<forall>f \<in> F. f \<in> A \<rightarrow>\<^sub>E B"
        using \<open>F \<in> (A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B\<close>
        by (metis ImageE equiv_class_eq_iff equiv_domain_and_range_permutation quotientE)
      moreover have "\<forall>f \<in> F. bij_betw f A B"
        using univ_predicate_impl_forall[OF equiv_domain_and_range_permutation bij_betw_respects_domain_and_range_permutation]
        using \<open>F \<in> (A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B\<close> \<open>univ (\<lambda>f. bij_betw f A B) F\<close>
        by auto
      ultimately show "F \<subseteq> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}" by auto
    next
      show "{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} \<subseteq> F"
      proof
        fix f'
        assume "f' \<in> {f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}"
        from this have "f' \<in> A \<rightarrow>\<^sub>E B" "bij_betw f' A B" by auto
          obtain f where "f \<in> A \<rightarrow>\<^sub>E B" and "F = domain_and_range_permutation A B `` {f}"
          using \<open>F \<in> (A \<rightarrow>\<^sub>E B) // domain_and_range_permutation A B\<close> by (auto elim: quotientE)
        have "bij_betw f A B"
          using univ_commute'[OF equiv_domain_and_range_permutation bij_betw_respects_domain_and_range_permutation]
          using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>F = domain_and_range_permutation A B `` {f}\<close> \<open>univ (\<lambda>f. bij_betw f A B) F\<close>
          by auto
        obtain p where "p permutes A" "\<forall>x\<in>A. f x = f' (p x)"
          using obtain_domain_permutation_for_two_bijections
          using \<open>bij_betw f A B\<close> \<open>bij_betw f' A B\<close> by blast
        moreover have "id permutes B" by (simp add: permutes_id)
        moreover note \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close>
        ultimately have "(f, f') \<in> domain_and_range_permutation A B"
          unfolding domain_and_range_permutation_def id_def by auto
        from this show "f' \<in> F"
          using \<open>F = domain_and_range_permutation A B `` {f}\<close> by simp
      qed
    qed
    from this show "F \<in> {{f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B}}" by simp
  qed
qed

subsubsection \<open>Cardinality\<close>

lemma card_bijections_domain_and_range_permutation_eq_1:
  assumes "finite A" "finite B"
  assumes "card A = card B"
  shows "card ({f \<in> A \<rightarrow>\<^sub>E B. bij_betw f A B} // domain_and_range_permutation A B) = 1"
using bij_betw_quotient_domain_and_range_permutation_eq[OF assms] by auto

end


theory Extended_Reals_Sums_Compl imports
  "HOL-Analysis.Analysis"
begin

lemma real_ereal_leq:
  fixes a::ereal and b::real
  assumes "real_of_ereal a \<le> b"
    and "a \<noteq> \<infinity>"
  shows "a \<le> ereal b"
  by (metis (mono_tags, opaque_lifting) MInfty_eq_minfinity assms eq_iff ereal_eq_0(2) ereal_le_real_iff
      ereal_less_eq(2) le_cases real_of_ereal.elims real_of_ereal.simps(1) zero_ereal_def)

lemma ereal_sums_Pinfty:
  fixes f::"nat \<Rightarrow> ereal"
  assumes "f sums \<infinity>"
    and "\<And>n. \<bar>f n\<bar> \<noteq> \<infinity>"
  shows "(\<lambda>n. - f n) sums -\<infinity>"
proof -
  define rf where "rf = (\<lambda>n. real_of_ereal (f n))"
  have "\<And>n. f n = ereal (rf n)" unfolding rf_def using assms by (simp add: ereal_real')
  define g where "g = (\<lambda>n. (\<Sum>i \<in> {..< n}. rf i))"
  define gm where "gm = (\<lambda>n. (\<Sum>i \<in> {..< n}. - rf i))"
  have "\<And>n. gm n = - g n" unfolding g_def gm_def by (simp add: sum_negf)
  hence "\<And>n. ereal (gm n) = (\<Sum>i \<in> {..< n}.- f i)" using \<open>\<And>n. f n = ereal (rf n)\<close>
    using gm_def by auto
  have "(\<lambda>n. ereal (g n)) \<longlonglongrightarrow> \<infinity>" using assms \<open>\<And>n. f n = ereal (rf n)\<close> unfolding sums_def g_def
    by simp
  have "\<forall>M. \<exists>N. \<forall>n\<ge> N. (gm n) \<le> M"
  proof
    fix M
    have "\<exists>N. \<forall>n\<ge> N. ereal (-M) \<le> g n" using \<open>g \<longlonglongrightarrow> \<infinity>\<close>  Lim_PInfty by simp
    from this obtain N where "\<forall>n\<ge> N. ereal (-M) \<le> g n" by auto
    hence "\<forall>n \<ge> N. - (g n) \<le> M" by auto
    hence "\<forall>n \<ge> N. gm n \<le> M" using \<open>\<And>n. gm n = - g n\<close> by simp
    thus "\<exists>N. \<forall>n \<ge> N. gm n \<le> M" by auto
  qed
  hence "(\<lambda>n. ereal (gm n)) \<longlonglongrightarrow> -\<infinity>" by (simp add: Lim_MInfty)
  thus ?thesis  using \<open>\<And>n. ereal (gm n) = (\<Sum>i \<in> {..< n}.- f i)\<close> unfolding sums_def by simp
qed

lemma ereal_sums_Minfty:
  fixes f::"nat \<Rightarrow> ereal"
  assumes "f sums -\<infinity>"
    and "\<And>n. \<bar>f n\<bar> \<noteq> \<infinity>"
  shows "(\<lambda>n. - f n) sums \<infinity>"
proof -
  define rf where "rf = (\<lambda>n. real_of_ereal (f n))"
  have "\<And>n. f n = ereal (rf n)" unfolding rf_def using assms by (simp add: ereal_real')
  define g where "g = (\<lambda>n. (\<Sum>i \<in> {..< n}. rf i))"
  define gm where "gm = (\<lambda>n. (\<Sum>i \<in> {..< n}. - rf i))"
  have "\<And>n. gm n = - g n" unfolding g_def gm_def by (simp add: sum_negf)
  hence "\<And>n. ereal (gm n) = (\<Sum>i \<in> {..< n}.- f i)" using \<open>\<And>n. f n = ereal (rf n)\<close>
    using gm_def by auto
  have "(\<lambda>n. ereal (g n)) \<longlonglongrightarrow> -\<infinity>" using assms \<open>\<And>n. f n = ereal (rf n)\<close> unfolding sums_def g_def
    by simp
  have "\<forall>M. \<exists>N. \<forall>n\<ge> N. M \<le> (gm n)"
  proof
    fix M
    have "\<exists>N. \<forall>n\<ge> N. g n \<le> ereal (-M)" using \<open>g \<longlonglongrightarrow> -\<infinity>\<close>  Lim_MInfty by simp
    from this obtain N where "\<forall>n\<ge> N. g n \<le> ereal (-M)" by auto
    hence "\<forall>n \<ge> N. M \<le> - (g n)" by auto
    hence "\<forall>n \<ge> N. M \<le> gm n" using \<open>\<And>n. gm n = - g n\<close> by simp
    thus "\<exists>N. \<forall>n \<ge> N. M \<le> gm n" by auto
  qed
  hence "(\<lambda>n. ereal (gm n)) \<longlonglongrightarrow> \<infinity>" by (simp add: Lim_PInfty)
  thus ?thesis  using \<open>\<And>n. ereal (gm n) = (\<Sum>i \<in> {..< n}.- f i)\<close> unfolding sums_def by simp
qed

lemma mem_sums_Pinfty:
  assumes "((f i)::ereal) = \<infinity>"
  shows "f sums \<infinity>"
proof -
  define g where "g = (\<lambda>n. (\<Sum>i \<in> {..< n}. f i))"
  have ginf: "\<forall> j \<ge> Suc i. g j = \<infinity>"
  proof (intro allI impI)
    fix j
    assume "Suc i \<le> j"
    hence "i < j" by simp
    hence "i \<in> {..< j}" by auto
    thus "g j = \<infinity>" unfolding g_def using sum_Pinfty[of f "{..< j}"] assms by blast
  qed
  have "\<forall>M. \<exists>N. \<forall>n\<ge> N. M \<le> (g n)"
  proof
    fix M
    show "\<exists>N. \<forall>n\<ge> N. M \<le> g n" using ginf by force
  qed
  hence "g \<longlonglongrightarrow> \<infinity>" by (simp add: Lim_PInfty)
  thus ?thesis   unfolding sums_def g_def by simp
qed

lemma sum_Minfty:
  fixes f :: "nat \<Rightarrow> ereal"
  shows "\<And>i. finite P \<Longrightarrow> i \<in> P \<Longrightarrow> f i = - \<infinity> \<Longrightarrow> \<infinity> \<notin> range f \<Longrightarrow> sum f P = -\<infinity>"
proof -
  fix i
  assume "finite P"
    and "i \<in> P"
    and "f i = -\<infinity>"
    and "\<infinity> \<notin> range f"
  thus "sum f P = -\<infinity>"
  proof induct
    case empty
    then show ?case by simp
  next
    case (insert x F)
    then show ?case
      by (metis ereal_plus_eq_MInfty insert_iff rangeI sum.insert sum_Pinfty)
  qed
qed

lemma mem_sums_Minfty:
  assumes "((f i)::ereal) = -\<infinity>"
    and "\<infinity> \<notin> range f"
  shows "f sums -\<infinity>"
proof -
  define g where "g = (\<lambda>n. (\<Sum>i \<in> {..< n}. f i))"
  have ginf: "\<forall> j \<ge> Suc i. g j = -\<infinity>"
  proof (intro allI impI)
    fix j
    assume "Suc i \<le> j"
    hence "i < j" by simp
    hence "i \<in> {..< j}" by auto
    thus "g j = -\<infinity>" unfolding g_def using sum_Minfty[of  "{..< j}"] assms by simp
  qed
  have "\<forall>M. \<exists>N. \<forall>n\<ge> N. (g n) \<le> M"
  proof
    fix M
    show "\<exists>N. \<forall>n\<ge> N. g n \<le> M" using ginf by force
  qed
  hence "g \<longlonglongrightarrow> -\<infinity>" by (simp add: Lim_MInfty)
  thus ?thesis   unfolding sums_def g_def by simp
qed

lemma ereal_sums_not_infty:
  assumes "f sums (a::ereal)"
    and "\<bar>a\<bar> \<noteq> \<infinity>"
  shows "\<And>n. \<bar>f n\<bar> \<noteq> \<infinity>"
proof (rule ccontr)
  fix n
  assume "\<not>\<bar>f n\<bar> \<noteq> \<infinity>"
  hence "\<bar>f n\<bar> = \<infinity>" by simp
  show False
  proof (cases "f n = \<infinity>")
    case True
    hence "f sums \<infinity>" using mem_sums_Pinfty by simp
    thus False using assms sums_unique2 by force
  next
    case False
    hence "f n = -\<infinity>" using \<open>\<bar>f n\<bar> = \<infinity>\<close> by blast
    show False
    proof (cases "\<exists>i. f i = \<infinity>")
      case True
      from this obtain i where "f i = \<infinity>" by auto
      hence "f sums \<infinity>" using mem_sums_Pinfty by simp
      thus False using assms sums_unique2 by force
    next
      case False
      hence "\<forall>i. f i \<noteq> \<infinity>" by simp
      hence "f sums -\<infinity>" using mem_sums_Minfty \<open>f n = -\<infinity>\<close>
        by (metis MInfty_eq_minfinity image_iff)
      thus False using assms sums_unique2 by force
    qed
  qed
qed

lemma ereal_sums_not_infty_minus:
  assumes "f sums (a::ereal)"
    and "\<bar>a\<bar> \<noteq> \<infinity>"
  shows "(\<lambda>n. - f n) sums -a"
proof -
  have "\<And>n. \<bar>f n\<bar> \<noteq> \<infinity>" using assms  ereal_sums_not_infty by simp
  define g where "g = (\<lambda>n. real_of_ereal (f n))"
  have "\<And>n. f n = ereal (g n)" using  \<open>\<And>n. \<bar>f n\<bar> \<noteq> \<infinity>\<close> by (simp add: ereal_real' g_def)
  hence "\<And>n. - f n = ereal (-g n)" by simp
  have "\<exists>r. a = ereal (r)" using assms by auto
  from this obtain r where "a = ereal r" by auto
  hence "f sums (ereal r)" using assms by simp
  hence "(\<lambda>n. ereal (g n)) sums (ereal r)" using \<open>\<And>n. f n = ereal (g n)\<close>
      sums_cong[of f "\<lambda>n. ereal (g n)"] by simp
  hence "g sums r" by (simp add: sums_ereal)
  hence "(\<lambda>n. -g n) sums -r" using sums_minus[of g] by simp
  hence "(\<lambda>n. ereal (- g n)) sums ereal (-r)" by (simp add: sums_ereal)
  hence "(\<lambda>n. - f n) sums (ereal (-r))" using \<open>\<And>n. - f n = ereal (-g n)\<close>
      sums_cong[of f "\<lambda>n. ereal (g n)"] by simp
  thus ?thesis using \<open>a = ereal r\<close> by simp
qed

lemma ereal_sums_minus:
  fixes f::"nat \<Rightarrow> ereal"
  assumes "f sums a"
    and "\<And>n. \<bar>f n\<bar> \<noteq> \<infinity>"
  shows "(\<lambda>n. - f n) sums -a"
proof (cases "\<bar>a\<bar> = \<infinity>")
  case False
  thus ?thesis using assms ereal_sums_not_infty_minus by simp
next
  case True
  hence "a = \<infinity> \<or> a = - \<infinity>" by auto
  thus ?thesis using assms ereal_sums_Pinfty ereal_sums_Minfty by auto
qed

lemma sums_minus':
  fixes f::"nat \<Rightarrow> ereal"
  assumes "-\<infinity> \<notin> range f \<or> \<infinity> \<notin> range f"
    and "f sums a"
  shows "(\<lambda>n. - f n) sums (- a)"
proof (cases "\<forall>n. \<bar>f n\<bar> \<noteq> \<infinity>")
  case True
  thus ?thesis using ereal_sums_minus assms by simp
next
  case False
  have "\<exists>n. \<bar>f n\<bar> = \<infinity>" using False by simp
  from this obtain n where "\<bar>f n\<bar> = \<infinity>" by meson
  show ?thesis
  proof (cases "\<infinity> \<in> range f")
    case True
    hence "\<exists>j. f j = \<infinity>" by (metis image_iff)
    from this obtain j where "f j = \<infinity>" by auto
    hence "a = \<infinity>" using mem_sums_Pinfty assms(2) sums_unique2 by blast
    moreover have "-\<infinity> \<notin> range f" using assms True by simp
    ultimately show ?thesis using mem_sums_Minfty[of "\<lambda>n. - f n"] assms \<open>f j = \<infinity>\<close>
      using ereal_uminus_eq_reorder by fastforce
  next
    case False
    hence "f n = -\<infinity>" using \<open>\<bar>f n\<bar> = \<infinity>\<close> by (metis ereal_infinity_cases range_eqI)
    hence "a = -\<infinity>" using mem_sums_Minfty False sums_unique2 assms(2) by blast
    thus ?thesis using mem_sums_Pinfty[of "\<lambda>n. - f n"] assms
      by (metis MInfty_eq_minfinity \<open>f n = - \<infinity>\<close> ereal_uminus_uminus uminus_ereal.simps(3))
  qed
qed

end


(*  Title:      HOL/UNITY/Simple/Reach.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Reachability in Directed Graphs.  From Chandy and Misra, section 6.4.
[this example took only four days!]
*)

theory Reach imports "../UNITY_Main" begin

typedecl vertex

type_synonym state = "vertex=>bool"

consts
  init ::  "vertex"

  edges :: "(vertex*vertex) set"

definition asgt :: "[vertex,vertex] => (state*state) set"
  where "asgt u v = {(s,s'). s' = s(v:= s u | s v)}"

definition Rprg :: "state program"
  where "Rprg = mk_total_program ({%v. v=init}, \<Union>(u,v)\<in>edges. {asgt u v}, UNIV)"

definition reach_invariant :: "state set"
  where "reach_invariant = {s. (\<forall>v. s v --> (init, v) \<in> edges\<^sup>*) & s init}"

definition fixedpoint :: "state set"
  where "fixedpoint = {s. \<forall>(u,v)\<in>edges. s u --> s v}"

definition metric :: "state => nat"
  where "metric s = card {v. ~ s v}"

text\<open>*We assume that the set of vertices is finite\<close>
axiomatization where
  finite_graph:  "finite (UNIV :: vertex set)"

(*TO SIMPDATA.ML??  FOR CLASET??  *)
lemma ifE [elim!]:
    "[| if P then Q else R;
        [| P;   Q |] ==> S;
        [| ~ P; R |] ==> S |] ==> S"
by (simp split: if_split_asm)

declare Rprg_def [THEN def_prg_Init, simp]

declare asgt_def [THEN def_act_simp,simp]

text\<open>All vertex sets are finite\<close>
declare finite_subset [OF subset_UNIV finite_graph, iff]

declare reach_invariant_def [THEN def_set_simp, simp]

lemma reach_invariant: "Rprg \<in> Always reach_invariant"
apply (rule AlwaysI, force)
apply (unfold Rprg_def, safety)
apply (blast intro: rtrancl_trans)
done

(*** Fixedpoint ***)

(*If it reaches a fixedpoint, it has found a solution*)
lemma fixedpoint_invariant_correct:
     "fixedpoint \<inter> reach_invariant = { %v. (init, v) \<in> edges\<^sup>* }"
apply (unfold fixedpoint_def)
apply (rule equalityI)
apply (auto intro!: ext)
apply (erule rtrancl_induct, auto)
done

lemma lemma1:
     "FP Rprg \<subseteq> fixedpoint"
apply (simp add: FP_def fixedpoint_def Rprg_def mk_total_program_def)
apply (auto simp add: stable_def constrains_def)
apply (drule bspec, assumption)
apply (simp add: Image_singleton image_iff)
apply (drule fun_cong, auto)
done

lemma lemma2:
     "fixedpoint \<subseteq> FP Rprg"
apply (simp add: FP_def fixedpoint_def Rprg_def mk_total_program_def)
apply (auto intro!: ext simp add: stable_def constrains_def)
done

lemma FP_fixedpoint: "FP Rprg = fixedpoint"
by (rule equalityI [OF lemma1 lemma2])

(*If we haven't reached a fixedpoint then there is some edge for which u but
  not v holds.  Progress will be proved via an ENSURES assertion that the
  metric will decrease for each suitable edge.  A union over all edges proves
  a LEADSTO assertion that the metric decreases if we are not at a fixedpoint.
  *)

lemma Compl_fixedpoint: "- fixedpoint = (\<Union>(u,v)\<in>edges. {s. s u & ~ s v})"
apply (simp add: FP_fixedpoint [symmetric] Rprg_def mk_total_program_def)
apply (rule subset_antisym)
apply (auto simp add: Compl_FP UN_UN_flatten)
 apply (rule fun_upd_idem, force)
apply (force intro!: rev_bexI simp add: fun_upd_idem_iff)
done

lemma Diff_fixedpoint:
     "A - fixedpoint = (\<Union>(u,v)\<in>edges. A \<inter> {s. s u & ~ s v})"
by (simp add: Diff_eq Compl_fixedpoint, blast)

(*** Progress ***)

lemma Suc_metric: "~ s x ==> Suc (metric (s(x:=True))) = metric s"
apply (unfold metric_def)
apply (subgoal_tac "{v. ~ (s (x:=True)) v} = {v. ~ s v} - {x}")
 prefer 2 apply force
apply (simp add: card_Suc_Diff1 del:card_Diff_insert)
done

lemma metric_less [intro!]: "~ s x ==> metric (s(x:=True)) < metric s"
by (erule Suc_metric [THEN subst], blast)

lemma metric_le: "metric (s(y:=s x | s y)) \<le> metric s"
  by (cases "s x --> s y") (auto intro: less_imp_le simp add: fun_upd_idem)

lemma LeadsTo_Diff_fixedpoint:
     "Rprg \<in> ((metric-`{m}) - fixedpoint) LeadsTo (metric-`(lessThan m))"
apply (simp (no_asm) add: Diff_fixedpoint Rprg_def)
apply (rule LeadsTo_UN, auto)
apply (ensures_tac "asgt a b")
 prefer 2 apply blast
apply (simp (no_asm_use) add: linorder_not_less)
apply (drule metric_le [THEN order_antisym])
apply (auto elim: less_not_refl3 [THEN [2] rev_notE])
done

lemma LeadsTo_Un_fixedpoint:
     "Rprg \<in> (metric-`{m}) LeadsTo (metric-`(lessThan m) \<union> fixedpoint)"
apply (rule LeadsTo_Diff [OF LeadsTo_Diff_fixedpoint [THEN LeadsTo_weaken_R]
                             subset_imp_LeadsTo], auto)
done

(*Execution in any state leads to a fixedpoint (i.e. can terminate)*)
lemma LeadsTo_fixedpoint: "Rprg \<in> UNIV LeadsTo fixedpoint"
apply (rule LessThan_induct, auto)
apply (rule LeadsTo_Un_fixedpoint)
done

lemma LeadsTo_correct: "Rprg \<in> UNIV LeadsTo { %v. (init, v) \<in> edges\<^sup>* }"
apply (subst fixedpoint_invariant_correct [symmetric])
apply (rule Always_LeadsTo_weaken [OF reach_invariant LeadsTo_fixedpoint], auto)
done

end


section \<open>The Free Group\<close>

theory "FreeGroups"
imports
   "HOL-Algebra.Group"
   Cancelation
   Generators
begin

text \<open>
Based on the work in @{theory "Free-Groups.Cancelation"}, the free group is now easily defined
over the set of fully canceled words with the corresponding operations.
\<close>

subsection \<open>Inversion\<close>

text \<open>
To define the inverse of a word, we first create a helper function that inverts
a single generator, and show that it is self-inverse.
\<close>

definition inv1 :: "'a g_i \<Rightarrow> 'a g_i"
 where "inv1 = apfst Not"

lemma inv1_inv1: "inv1 \<circ> inv1 = id"
  by (simp add: fun_eq_iff comp_def inv1_def)

lemmas inv1_inv1_simp [simp] = inv1_inv1[unfolded id_def]

lemma snd_inv1: "snd \<circ> inv1 = snd"
  by(simp add: fun_eq_iff comp_def inv1_def)

text \<open>
The inverse of a word is obtained by reversing the order of the generators and
inverting each generator using @{term inv1}. Some properties of @{term inv_fg}
are noted.
\<close>

definition inv_fg :: "'a word_g_i \<Rightarrow> 'a word_g_i"
 where "inv_fg l = rev (map inv1 l)"

lemma inv_idemp: "inv_fg (inv_fg l) = l"
  by (auto simp add:inv_fg_def rev_map)

lemma inv_fg_cancel: "normalize (l @ inv_fg l) = []"
proof(induct l rule:rev_induct)
  case Nil thus ?case
    by (auto simp add: inv_fg_def)
next
  case (snoc x xs)
  have "canceling x (inv1 x)" by (simp add:inv1_def canceling_def)
  moreover
  let ?i = "length xs"
  have "Suc ?i < length xs + 1 + 1 + length xs"
    by auto
  moreover
  have "inv_fg (xs @ [x]) = [inv1 x] @ inv_fg xs"
    by (auto simp add:inv_fg_def)
  ultimately
  have "cancels_to_1_at ?i (xs @ [x] @ (inv_fg (xs @ [x]))) (xs @ inv_fg xs)"
    by (auto simp add:cancels_to_1_at_def cancel_at_def nth_append)
  hence "cancels_to_1 (xs @ [x] @ (inv_fg (xs @ [x]))) (xs @ inv_fg xs)"
    by (auto simp add: cancels_to_1_def)
  hence "cancels_to (xs @ [x] @ (inv_fg (xs @ [x]))) (xs @ inv_fg xs)"
    by (auto simp add:cancels_to_def)
  with \<open>normalize (xs @ (inv_fg xs)) = []\<close>
  show "normalize ((xs @ [x]) @ (inv_fg (xs @ [x]))) = []"
    by auto
qed

lemma inv_fg_cancel2: "normalize (inv_fg l @ l) = []"
proof-
  have "normalize (inv_fg l @ inv_fg (inv_fg l)) = []" by (rule inv_fg_cancel)
  thus "normalize (inv_fg l @ l) = []" by (simp add: inv_idemp)
qed

lemma canceled_rev:
  assumes "canceled l"
  shows "canceled (rev l)"
proof(rule ccontr)
  assume "\<not>canceled (rev l)"
  hence "Domainp cancels_to_1 (rev l)" by (simp add: canceled_def)
  then obtain l' where "cancels_to_1 (rev l) l'" by auto
  then obtain i where "cancels_to_1_at i (rev l) l'" by (auto simp add:cancels_to_1_def)
  hence "Suc i < length (rev l)"
    and "canceling (rev l ! i) (rev l ! Suc i)"
    by (auto simp add:cancels_to_1_at_def)
  let ?x = "length l - i - 2"
  from \<open>Suc i < length (rev l)\<close>
  have "Suc ?x < length l" by auto
  moreover
  from \<open>Suc i < length (rev l)\<close>
  have "i < length l" and "length l - Suc i = Suc(length l - Suc (Suc i))" by auto
  hence "rev l ! i = l ! Suc ?x" and "rev l ! Suc i = l ! ?x"
    by (auto simp add: rev_nth map_nth)
  with \<open>canceling (rev l ! i) (rev l ! Suc i)\<close>
  have "canceling (l ! Suc ?x) (l ! ?x)" by auto
  hence "canceling (l ! ?x) (l ! Suc ?x)" by (rule cancel_sym)
  hence "canceling (l ! ?x) (l ! Suc ?x)" by simp
  ultimately
  have "cancels_to_1_at ?x l (cancel_at ?x l)"
    by (auto simp add:cancels_to_1_at_def)
  hence "cancels_to_1 l (cancel_at ?x l)"
    by (auto simp add:cancels_to_1_def)
  hence "\<not>canceled l"
    by (auto simp add:canceled_def)
  with \<open>canceled l\<close> show False by contradiction
qed

lemma inv_fg_closure1:
  assumes "canceled l"
  shows "canceled (inv_fg l)"
unfolding inv_fg_def and inv1_def and apfst_def
proof-
  have "inj Not" by (auto intro:injI)
  moreover
  have "inj_on id (snd ` set l)" by auto
  ultimately
  have "canceled (map (map_prod Not id) l)"
    using \<open>canceled l\<close>
    by -(rule rename_gens_canceled)
  thus "canceled (rev (map (map_prod Not id) l))" by (rule canceled_rev)
qed

subsection \<open>The definition\<close>

text \<open>
Finally, we can define the Free Group over a set of generators, and show that it
is indeed a group.
\<close>

definition free_group :: "'a set => ((bool * 'a) list) monoid" ("\<F>\<index>")
where
  "\<F>\<^bsub>gens\<^esub> \<equiv> \<lparr>
     carrier = {l\<in>lists (UNIV \<times> gens). canceled l },
     mult = \<lambda> x y. normalize (x @ y),
     one = []
  \<rparr>"

lemma occuring_gens_in_element:
  "x \<in> carrier \<F>\<^bsub>gens\<^esub> \<Longrightarrow> x \<in> lists (UNIV \<times> gens)"
by(auto simp add:free_group_def)

theorem free_group_is_group: "group \<F>\<^bsub>gens\<^esub>"
proof
  fix x y
  assume "x \<in> carrier \<F>\<^bsub>gens\<^esub>" hence x: "x \<in> lists (UNIV \<times> gens)" by
    (rule occuring_gens_in_element)
  assume "y \<in> carrier \<F>\<^bsub>gens\<^esub>" hence y: "y \<in> lists (UNIV \<times> gens)" by
    (rule occuring_gens_in_element)
  from x and y
  have "x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> y \<in> lists (UNIV \<times> gens)"
    by (auto intro!: normalize_preserves_generators simp add:free_group_def append_in_lists_conv)
  thus "x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> y \<in> carrier \<F>\<^bsub>gens\<^esub>"
    by (auto simp add:free_group_def)
next
  fix x y z
  have "cancels_to (x @ y) (normalize (x @ (y::'a word_g_i)))"
   and "cancels_to z (z::'a word_g_i)"
    by auto
  hence "normalize (normalize (x @ y) @ z) = normalize ((x @ y) @ z)"
    by (rule normalize_append_cancel_to[THEN sym])
  also
  have "\<dots> = normalize (x @ (y @ z))" by auto
  also
  have "cancels_to (y @ z) (normalize (y @ (z::'a word_g_i)))"
   and "cancels_to x (x::'a word_g_i)"
    by auto
  hence "normalize (x @ (y @ z)) = normalize (x @ normalize (y @ z))"
    by -(rule normalize_append_cancel_to)
  finally
  show "x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> y \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> z =
        x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> (y \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> z)"
    by (auto simp add:free_group_def)
next
  show "\<one>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> \<in> carrier \<F>\<^bsub>gens\<^esub>"
    by (auto simp add:free_group_def)
next
  fix x
  assume "x \<in> carrier \<F>\<^bsub>gens\<^esub>"
  thus "\<one>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> x = x"
    by (auto simp add:free_group_def)
next
  fix x
  assume "x \<in> carrier \<F>\<^bsub>gens\<^esub>"
  thus "x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> \<one>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> = x"
    by (auto simp add:free_group_def)
next
  show "carrier \<F>\<^bsub>gens\<^esub> \<subseteq> Units \<F>\<^bsub>gens\<^esub>"
  proof (simp add:free_group_def Units_def, rule subsetI)
    fix x :: "'a word_g_i"
    let ?x' = "inv_fg x"
    assume "x \<in> {y\<in>lists(UNIV\<times>gens). canceled y}"
    hence "?x' \<in> lists(UNIV\<times>gens) \<and> canceled ?x'"
      by (auto elim:inv_fg_closure1 simp add:inv_fg_closure2)
    moreover
    have "normalize (?x' @ x) = []"
     and "normalize (x @ ?x') = []"
      by (auto simp add:inv_fg_cancel inv_fg_cancel2)
    ultimately
    have "\<exists>y. y \<in> lists (UNIV \<times> gens) \<and>
                  canceled y \<and>
                  normalize (y @ x) = [] \<and> normalize (x @ y) = []"
      by auto
    with \<open>x \<in> {y\<in>lists(UNIV\<times>gens). canceled y}\<close>
    show "x \<in> {y \<in> lists (UNIV \<times> gens).  canceled y  \<and>
          (\<exists>x. x \<in> lists (UNIV \<times> gens) \<and>
                  canceled x \<and>
                  normalize (x @ y) = [] \<and> normalize (y @ x) = [])}"
      by auto
  qed
qed

lemma inv_is_inv_fg[simp]:
  "x \<in> carrier \<F>\<^bsub>gens\<^esub> \<Longrightarrow> inv\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> x = inv_fg x"
by (rule group.inv_equality,auto simp add:free_group_is_group,auto simp add: free_group_def inv_fg_cancel inv_fg_cancel2 inv_fg_closure1 inv_fg_closure2)

subsection \<open>The universal property\<close>

text \<open>Free Groups are important due to their universal property: Every map of
the set of generators to another group can be extended uniquely to an
homomorphism from the Free Group.\<close>

definition insert ("\<iota>")
  where "\<iota> g = [(False, g)]"

lemma insert_closed:
  "g \<in> gens \<Longrightarrow> \<iota> g \<in> carrier \<F>\<^bsub>gens\<^esub>"
  by (auto simp add:insert_def free_group_def)

definition (in group) lift_gi
  where "lift_gi f gi = (if fst gi then inv (f (snd gi)) else f (snd gi))"

lemma (in group) lift_gi_closed:
  assumes cl: "f \<in> gens \<rightarrow> carrier G"
      and "snd gi \<in> gens"
  shows "lift_gi f gi \<in> carrier G"
using assms by (auto simp add:lift_gi_def)

definition (in group) lift
  where "lift f w = m_concat (map (lift_gi f) w)"

lemma (in group) lift_nil[simp]: "lift f [] = \<one>"
 by (auto simp add:lift_def)

lemma (in group) lift_closed[simp]:
  assumes cl: "f \<in> gens \<rightarrow> carrier G"
      and "x \<in> lists (UNIV \<times> gens)"
  shows "lift f x \<in> carrier G"
proof-
  have "set (map (lift_gi f) x) \<subseteq> carrier G"
    using \<open>x \<in> lists (UNIV \<times> gens)\<close>
    by (auto simp add:lift_gi_closed[OF cl])
  thus "lift f x \<in> carrier G"
    by (auto simp add:lift_def)
qed

lemma (in group) lift_append[simp]:
  assumes cl: "f \<in> gens \<rightarrow> carrier G"
      and "x \<in> lists (UNIV \<times> gens)"
      and "y \<in> lists (UNIV \<times> gens)"
  shows "lift f (x @ y) = lift f x \<otimes> lift f y"
proof-
  from \<open>x \<in> lists (UNIV \<times> gens)\<close>
  have "set (map snd x) \<subseteq> gens" by auto
  hence "set (map (lift_gi f) x) \<subseteq> carrier G"
    by (induct x)(auto simp add:lift_gi_closed[OF cl])
  moreover
  from \<open>y \<in> lists (UNIV \<times> gens)\<close>
  have "set (map snd y) \<subseteq> gens" by auto
  hence "set (map (lift_gi f) y) \<subseteq> carrier G"
    by (induct y)(auto simp add:lift_gi_closed[OF cl])
  ultimately
  show "lift f (x @ y) = lift f x \<otimes> lift f y"
    by (auto simp add:lift_def m_assoc simp del:set_map foldr_append)
qed

lemma (in group) lift_cancels_to:
  assumes "cancels_to x y"
      and "x \<in> lists (UNIV \<times> gens)"
      and cl: "f \<in> gens \<rightarrow> carrier G"
  shows "lift f x = lift f y"
using assms
unfolding cancels_to_def
proof(induct rule:rtranclp_induct)
  case (step y z)
    from \<open>cancels_to_1\<^sup>*\<^sup>* x y\<close>
    and \<open>x \<in> lists (UNIV \<times> gens)\<close>
    have "y \<in> lists (UNIV \<times> gens)"
      by -(rule cancels_to_preserves_generators, simp add:cancels_to_def)
    hence "lift f x = lift f y"
      using step by auto
    also
    from \<open>cancels_to_1 y z\<close>
    obtain ys1 y1 y2 ys2
      where y: "y = ys1 @ y1 # y2 # ys2"
      and "z = ys1 @ ys2"
      and "canceling y1 y2"
    by (rule cancels_to_1_unfold)
    have "lift f y  = lift f (ys1 @ [y1] @ [y2] @ ys2)"
      using y by simp
    also
    from y and cl and \<open>y \<in> lists (UNIV \<times> gens)\<close>
    have "lift f (ys1 @ [y1] @ [y2] @ ys2)
        = lift f ys1 \<otimes> (lift f [y1] \<otimes> lift f [y2]) \<otimes> lift f ys2"
      by (auto intro:lift_append[OF cl] simp del: append_Cons simp add:m_assoc iff:lists_eq_set)
    also
    from cl[THEN funcset_image]
     and y and \<open>y \<in> lists (UNIV \<times> gens)\<close>
     and \<open>canceling y1 y2\<close>
    have "(lift f [y1] \<otimes> lift f [y2]) = \<one>"
      by (auto simp add:lift_def lift_gi_def canceling_def iff:lists_eq_set)
    hence "lift f ys1 \<otimes> (lift f [y1] \<otimes> lift f [y2]) \<otimes> lift f ys2
           = lift f ys1 \<otimes> \<one> \<otimes> lift f ys2"
      by simp
    also
    from y and \<open>y \<in> lists (UNIV \<times> gens)\<close>
     and cl
     have "lift f ys1 \<otimes> \<one> \<otimes> lift f ys2 = lift f (ys1 @ ys2)"
      by (auto intro:lift_append iff:lists_eq_set)
    also
    from \<open>z = ys1 @ ys2\<close>
    have "lift f (ys1 @ ys2) = lift f z" by simp
    finally show "lift f x = lift f z" .
qed auto

lemma (in group) lift_is_hom:
  assumes cl: "f \<in> gens \<rightarrow> carrier G"
  shows "lift f \<in> hom \<F>\<^bsub>gens\<^esub> G"
proof-
  {
    fix x
    assume "x \<in> carrier \<F>\<^bsub>gens\<^esub>"
    hence "x \<in> lists (UNIV \<times> gens)"
      unfolding free_group_def by simp
    hence "lift f x \<in> carrier G"
     by (induct x, auto simp add:lift_def lift_gi_closed[OF cl])
  }
  moreover
  { fix x
    assume "x \<in> carrier \<F>\<^bsub>gens\<^esub>"
    fix y
    assume "y \<in> carrier \<F>\<^bsub>gens\<^esub>"

    from \<open>x \<in> carrier \<F>\<^bsub>gens\<^esub>\<close> and \<open>y \<in> carrier \<F>\<^bsub>gens\<^esub>\<close>
    have "x \<in> lists (UNIV \<times> gens)" and "y \<in> lists (UNIV \<times> gens)"
      by (auto simp add:free_group_def)

    have "cancels_to (x @ y) (normalize (x @ y))" by simp
    from \<open>x \<in> lists (UNIV \<times> gens)\<close> and \<open>y \<in> lists (UNIV \<times> gens)\<close>
     and lift_cancels_to[THEN sym, OF \<open>cancels_to (x @ y) (normalize (x @ y))\<close>] and cl
    have "lift f (x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> y) = lift f (x @ y)"
      by (auto simp add:free_group_def iff:lists_eq_set)
    also
    from \<open>x \<in> lists (UNIV \<times> gens)\<close> and \<open>y \<in> lists (UNIV \<times> gens)\<close> and cl
    have "lift f (x @ y) = lift f x \<otimes> lift f y"
      by simp
    finally
    have "lift f (x \<otimes>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> y) = lift f x \<otimes> lift f y" .
  }
  ultimately
  show "lift f \<in> hom \<F>\<^bsub>gens\<^esub> G"
    by auto
qed

lemma gens_span_free_group:
shows "\<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> = carrier \<F>\<^bsub>gens\<^esub>"
proof
  interpret group "\<F>\<^bsub>gens\<^esub>" by (rule free_group_is_group)
  show "\<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> \<subseteq> carrier \<F>\<^bsub>gens\<^esub>"
  by(rule gen_span_closed, auto simp add:insert_def free_group_def)

  show "carrier \<F>\<^bsub>gens\<^esub>  \<subseteq> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
  proof
    fix x
    show "x \<in> carrier \<F>\<^bsub>gens\<^esub> \<Longrightarrow> x \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
    proof(induct x)
    case Nil
      have "one \<F>\<^bsub>gens\<^esub> \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
        by simp
      thus "[] \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
        by (simp add:free_group_def)
    next
    case (Cons a x)
      from \<open>a # x \<in> carrier \<F>\<^bsub>gens\<^esub>\<close>
      have "x \<in> carrier \<F>\<^bsub>gens\<^esub>"
        by (auto intro:cons_canceled simp add:free_group_def)
      hence "x \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
        using Cons by simp
      moreover

      from \<open>a # x \<in> carrier \<F>\<^bsub>gens\<^esub>\<close>
      have "snd a \<in> gens"
        by (auto simp add:free_group_def)
      hence isa: "\<iota> (snd a) \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
        by (auto simp add:insert_def intro:gen_gens)
      have "[a] \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
      proof(cases "fst a")
        case False
          hence "[a] = \<iota> (snd a)" by (cases a, auto simp add:insert_def)
           with isa show "[a] \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>" by simp
       next
        case True
          from \<open>snd a \<in> gens\<close>
          have "\<iota> (snd a) \<in> carrier \<F>\<^bsub>gens\<^esub>"
            by (auto simp add:free_group_def insert_def)
          with True
          have "[a] = inv\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> (\<iota> (snd a))"
            by (cases a, auto simp add:insert_def inv_fg_def inv1_def)
          moreover
          from isa
          have "inv\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub> (\<iota> (snd a)) \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
            by (auto intro:gen_inv)
          ultimately
          show "[a] \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
            by simp
      qed
      ultimately
      have "mult \<F>\<^bsub>gens\<^esub> [a] x \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>"
        by (auto intro:gen_mult)
      with
      \<open>a # x \<in> carrier \<F>\<^bsub>gens\<^esub>\<close>
      show "a # x \<in> \<langle>\<iota> ` gens\<rangle>\<^bsub>\<F>\<^bsub>gens\<^esub>\<^esub>" by (simp add:free_group_def)
    qed
  qed
qed

lemma (in group) lift_is_unique:
  assumes "group G"
  and cl: "f \<in> gens \<rightarrow> carrier G"
  and "h \<in> hom \<F>\<^bsub>gens\<^esub> G"
  and "\<forall> g \<in> gens. h (\<iota> g) = f g"
  shows "\<forall>x \<in> carrier \<F>\<^bsub>gens\<^esub>. h x = lift f x"
unfolding gens_span_free_group[THEN sym]
proof(rule hom_unique_on_span[of "\<F>\<^bsub>gens\<^esub>" G])
  show "group \<F>\<^bsub>gens\<^esub>" by (rule free_group_is_group)
next
  show "group G" by fact
next
  show "\<iota> ` gens \<subseteq> carrier \<F>\<^bsub>gens\<^esub>"
    by(auto intro:insert_closed)
next
  show "h \<in> hom \<F>\<^bsub>gens\<^esub> G" by fact
next
  show "lift f \<in> hom \<F>\<^bsub>gens\<^esub> G" by (rule lift_is_hom[OF cl])
next
  from \<open>\<forall>g\<in> gens. h (\<iota> g) = f g\<close> and cl[THEN funcset_image]
  show "\<forall>g\<in> \<iota> ` gens. h g = lift f g"
    by(auto simp add:insert_def lift_def lift_gi_def)
qed

end


(*  Title:       Invariants.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Reachability and Invariance"

theory Invariants
imports Lib TransitionSystems
begin

subsection Reachability

text \<open>
  A state is `reachable' under @{term I} if either it is the initial state, or it is the
  destination of a transition whose action satisfies @{term I} from a reachable state.
  The `standard' definition of reachability is recovered by setting @{term I} to @{term TT}.
\<close>

inductive_set reachable
  for A :: "('s, 'a) automaton"
  and I :: "'a \<Rightarrow> bool"
where
    reachable_init: "s \<in> init A \<Longrightarrow> s \<in> reachable A I"
  | reachable_step: "\<lbrakk> s \<in> reachable A I; (s, a, s') \<in> trans A; I a \<rbrakk> \<Longrightarrow> s' \<in> reachable A I"

inductive_cases reachable_icases: "s \<in> reachable A I"

lemma reachable_pair_induct [consumes, case_names init step]:
  assumes "(\<xi>, p) \<in> reachable A I"
      and "\<And>\<xi> p. (\<xi>, p) \<in> init A \<Longrightarrow> P \<xi> p"
      and "(\<And>\<xi> p \<xi>' p' a. \<lbrakk> (\<xi>, p) \<in> reachable A I; P \<xi> p;
                            ((\<xi>, p), a, (\<xi>', p')) \<in> trans A; I a \<rbrakk> \<Longrightarrow> P \<xi>' p')"
    shows "P \<xi> p"
  using assms(1) proof (induction "(\<xi>, p)" arbitrary: \<xi> p)
    fix \<xi> p
    assume "(\<xi>, p) \<in> init A"
    with assms(2) show "P \<xi> p" .
  next
    fix s a \<xi>' p'
    assume "s \<in> reachable A I"
       and tr: "(s, a, (\<xi>', p')) \<in> trans A"
       and "I a"
       and IH: "\<And>\<xi> p. s = (\<xi>, p) \<Longrightarrow> P \<xi> p"
    from this(1) obtain \<xi> p where "s = (\<xi>, p)"
                              and "(\<xi>, p) \<in> reachable A I"
      by (metis prod.collapse)
    note this(2)
    moreover from IH and \<open>s = (\<xi>, p)\<close> have "P \<xi> p" .
    moreover from tr and \<open>s = (\<xi>, p)\<close> have "((\<xi>, p), a, (\<xi>', p')) \<in> trans A" by simp
    ultimately show "P \<xi>' p'"
      using \<open>I a\<close> by (rule assms(3))
  qed

lemma reachable_weakenE [elim]:
  assumes "s \<in> reachable A P"
      and PQ: "\<And>a. P a \<Longrightarrow> Q a"
    shows "s \<in> reachable A Q"
  using assms(1)
  proof (induction)
    fix s assume "s \<in> init A"
    thus "s \<in> reachable A Q" ..
  next
    fix s a s'
    assume "s \<in> reachable A P"
       and "s \<in> reachable A Q"
       and "(s, a, s') \<in> trans A"
       and "P a"
    from \<open>P a\<close> have "Q a" by (rule PQ)
    with \<open>s \<in> reachable A Q\<close> and \<open>(s, a, s') \<in> trans A\<close> show "s' \<in> reachable A Q" ..
  qed

lemma reachable_weaken_TT [elim]:
  assumes "s \<in> reachable A I"
    shows "s \<in> reachable A TT"
  using assms by rule simp

lemma init_empty_reachable_empty:
  assumes "init A = {}"
    shows "reachable A I = {}"
  proof (rule ccontr)
    assume "reachable A I \<noteq> {}"
    then obtain s where "s \<in> reachable A I" by auto
    thus False
    proof (induction rule: reachable.induct)
      fix s
      assume "s \<in> init A"
      with \<open>init A = {}\<close> show False by simp
    qed
  qed

subsection Invariance

definition invariant
  :: "('s, 'a) automaton \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool"
  ("_ \<TTurnstile> (1'(_ \<rightarrow>')/ _)" [100, 0, 9] 8)
where
  "(A \<TTurnstile> (I \<rightarrow>) P) = (\<forall>s\<in>reachable A I. P s)"

abbreviation
  any_invariant
  :: "('s, 'a) automaton \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool"
  ("_ \<TTurnstile> _" [100, 9] 8)
where
  "(A \<TTurnstile> P) \<equiv> (A \<TTurnstile> (TT \<rightarrow>) P)"

lemma invariantI [intro]:
  assumes init: "\<And>s. s \<in> init A \<Longrightarrow> P s"
      and step: "\<And>s a s'. \<lbrakk> s \<in> reachable A I; P s; (s, a, s') \<in> trans A; I a \<rbrakk> \<Longrightarrow> P s'"
    shows "A \<TTurnstile> (I \<rightarrow>) P"
  unfolding invariant_def
  proof
       fix s
    assume "s \<in> reachable A I"
      thus "P s"
    proof induction
      fix s assume "s \<in> init A"
      thus "P s" by (rule init)
    next
      fix s a s'
      assume "s \<in> reachable A I"
         and "P s"
         and "(s, a, s') \<in> trans A"
         and "I a"
        thus "P s'" by (rule step)
    qed
  qed

lemma invariant_pairI [intro]:
  assumes init: "\<And>\<xi> p. (\<xi>, p) \<in> init A \<Longrightarrow> P (\<xi>, p)"
      and step: "\<And>\<xi> p \<xi>' p' a.
                   \<lbrakk> (\<xi>, p) \<in> reachable A I; P (\<xi>, p); ((\<xi>, p), a, (\<xi>', p')) \<in> trans A; I a \<rbrakk>
                   \<Longrightarrow> P (\<xi>', p')"
    shows "A \<TTurnstile> (I \<rightarrow>) P"
  using assms by auto

lemma invariant_arbitraryI:
  assumes "\<And>s. s \<in> reachable A I \<Longrightarrow> P s"
    shows "A \<TTurnstile> (I \<rightarrow>) P"
  using assms unfolding invariant_def by simp

lemma invariantD [dest]:
  assumes "A \<TTurnstile> (I \<rightarrow>) P"
      and "s \<in> reachable A I"
    shows "P s"
  using assms unfolding invariant_def by blast

lemma invariant_initE [elim]:
  assumes invP: "A \<TTurnstile> (I \<rightarrow>) P"
      and init: "s \<in> init A"
    shows "P s"
  proof -
    from init have "s \<in> reachable A I" ..
    with invP show ?thesis ..
  qed

lemma invariant_weakenE [elim]:
  fixes T \<sigma> P Q
  assumes invP: "A \<TTurnstile> (PI \<rightarrow>) P"
      and PQ:   "\<And>s. P s \<Longrightarrow> Q s"
      and QIPI: "\<And>a. QI a \<Longrightarrow> PI a"
    shows       "A \<TTurnstile> (QI \<rightarrow>) Q"
  proof
    fix s
    assume "s \<in> init A"
    with invP have "P s" ..
    thus "Q s" by (rule PQ)
  next
    fix s a s'
    assume "s \<in> reachable A QI"
       and "(s, a, s') \<in> trans A"
       and "QI a"
    from \<open>QI a\<close> have "PI a" by (rule QIPI)
    from \<open>s \<in> reachable A QI\<close> and QIPI have "s \<in> reachable A PI" ..
    hence "s' \<in> reachable A PI" using \<open>(s, a, s') \<in> trans A\<close> and \<open>PI a\<close> ..
    with invP have "P s'" ..
    thus "Q s'" by (rule PQ)
  qed

definition
  step_invariant
  :: "('s, 'a) automaton \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> (('s, 'a) transition \<Rightarrow> bool) \<Rightarrow> bool"
  ("_ \<TTurnstile>\<^sub>A (1'(_ \<rightarrow>')/ _)" [100, 0, 0] 8)
where
  "(A \<TTurnstile>\<^sub>A (I \<rightarrow>) P) = (\<forall>a. I a \<longrightarrow> (\<forall>s\<in>reachable A I. (\<forall>s'.(s, a, s') \<in> trans A \<longrightarrow> P (s, a, s'))))"

lemma invariant_restrict_inD [dest]:
  assumes "A \<TTurnstile> (TT \<rightarrow>) P"
    shows "A \<TTurnstile> (QI \<rightarrow>) P"
  using assms by auto

abbreviation
  any_step_invariant
  :: "('s, 'a) automaton \<Rightarrow> (('s, 'a) transition \<Rightarrow> bool) \<Rightarrow> bool"
  ("_ \<TTurnstile>\<^sub>A _" [100, 9] 8)
where
  "(A \<TTurnstile>\<^sub>A P) \<equiv> (A \<TTurnstile>\<^sub>A (TT \<rightarrow>) P)"

lemma step_invariant_true:
  "p \<TTurnstile>\<^sub>A (\<lambda>(s, a, s'). True)"
  unfolding step_invariant_def by simp

lemma step_invariantI [intro]:
  assumes *: "\<And>s a s'. \<lbrakk> s\<in>reachable A I; (s, a, s')\<in>trans A; I a \<rbrakk> \<Longrightarrow> P (s, a, s')"
    shows "A \<TTurnstile>\<^sub>A (I \<rightarrow>) P"
  unfolding step_invariant_def
  using assms by auto

lemma step_invariantD [dest]:
  assumes "A \<TTurnstile>\<^sub>A (I \<rightarrow>) P"
      and "s\<in>reachable A I"
      and "(s, a, s') \<in> trans A"
      and "I a"
    shows "P (s, a, s')"
  using assms unfolding step_invariant_def by blast

lemma step_invariantE [elim]:
    fixes T \<sigma> P I s a s'
  assumes "A \<TTurnstile>\<^sub>A (I \<rightarrow>) P"
      and "s\<in>reachable A I"
      and "(s, a, s') \<in> trans A"
      and "I a"
      and "P (s, a, s') \<Longrightarrow> Q"
    shows "Q"
  using assms by auto

lemma step_invariant_pairI [intro]:
  assumes *: "\<And>\<xi> p \<xi>' p' a.
              \<lbrakk> (\<xi>, p) \<in> reachable A I; ((\<xi>, p), a, (\<xi>', p')) \<in> trans A; I a \<rbrakk>
                                                       \<Longrightarrow> P ((\<xi>, p), a, (\<xi>', p'))"
    shows "A \<TTurnstile>\<^sub>A (I \<rightarrow>) P"
  using assms by auto

lemma step_invariant_arbitraryI:
  assumes "\<And>\<xi> p a \<xi>' p'. \<lbrakk> (\<xi>, p) \<in> reachable A I; ((\<xi>, p), a, (\<xi>', p')) \<in> trans A; I a \<rbrakk>
           \<Longrightarrow> P ((\<xi>, p), a, (\<xi>', p'))"
    shows "A \<TTurnstile>\<^sub>A (I \<rightarrow>) P"
  using assms by auto

lemma step_invariant_weakenE [elim!]:
  fixes T \<sigma> P Q
  assumes invP: "A \<TTurnstile>\<^sub>A (PI \<rightarrow>) P"
      and PQ:   "\<And>t. P t \<Longrightarrow> Q t"
      and QIPI: "\<And>a. QI a \<Longrightarrow> PI a"
    shows       "A \<TTurnstile>\<^sub>A (QI \<rightarrow>) Q"
  proof
    fix s a s'
    assume "s \<in> reachable A QI"
       and "(s, a, s') \<in> trans A"
       and "QI a"
    from \<open>QI a\<close> have "PI a" by (rule QIPI)
    from \<open>s \<in> reachable A QI\<close> have "s \<in> reachable A PI" using QIPI ..
    with invP have "P (s, a, s')" using \<open>(s, a, s') \<in> trans A\<close> \<open>PI a\<close> ..
    thus "Q (s, a, s')" by (rule PQ)
  qed

lemma step_invariant_weaken_with_invariantE [elim]:
  assumes pinv: "A \<TTurnstile> (I \<rightarrow>) P"
      and qinv: "A \<TTurnstile>\<^sub>A (I \<rightarrow>) Q"
      and wr: "\<And>s a s'. \<lbrakk> P s; P s'; Q (s, a, s'); I a \<rbrakk> \<Longrightarrow> R (s, a, s')"
    shows "A \<TTurnstile>\<^sub>A (I \<rightarrow>) R"
  proof
    fix s a s'
    assume sr: "s \<in> reachable A I"
       and tr: "(s, a, s') \<in> trans A"
       and "I a"
    hence "s' \<in> reachable A I" ..
    with pinv have "P s'" ..
    from pinv and sr have "P s" ..
    from qinv sr tr \<open>I a\<close> have "Q (s, a, s')" ..
    with \<open>P s\<close> and \<open>P s'\<close> show "R (s, a, s')" using \<open>I a\<close> by (rule wr)
  qed

lemma step_to_invariantI:
  assumes sinv: "A \<TTurnstile>\<^sub>A (I \<rightarrow>) Q"
      and init: "\<And>s. s \<in> init A \<Longrightarrow> P s"
      and step: "\<And>s s' a.
                   \<lbrakk> s \<in> reachable A I;
                     P s;
                     Q (s, a, s');
                     I a \<rbrakk> \<Longrightarrow> P s'"
    shows "A \<TTurnstile> (I \<rightarrow>) P"
  proof
    fix s assume "s \<in> init A" thus "P s" by (rule init)
  next
    fix s s' a
    assume "s \<in> reachable A I"
       and "P s"
       and "(s, a, s') \<in> trans A"
       and "I a"
      show "P s'"
    proof -
      from sinv and \<open>s\<in>reachable A I\<close> and \<open>(s, a, s')\<in>trans A\<close> and \<open>I a\<close> have "Q (s, a, s')" ..
      with \<open>s\<in>reachable A I\<close> and \<open>P s\<close> show "P s'" using \<open>I a\<close> by (rule step)
    qed
  qed

end


section {* \isaheader{Set Interface} *}
theory Intf_Set
imports "../../../Refine_Monadic/Refine_Monadic"
begin
consts i_set :: "interface \<Rightarrow> interface"
lemmas [autoref_rel_intf] = REL_INTFI[of set_rel i_set]

definition [simp]: "op_set_delete x s \<equiv> s - {x}"
definition [simp]: "op_set_isEmpty s \<equiv> s = {}"
definition [simp]: "op_set_isSng s \<equiv> card s = 1"
definition [simp]: "op_set_size_abort m s \<equiv> min m (card s)"
definition [simp]: "op_set_disjoint a b \<equiv> a\<inter>b={}"
definition [simp]: "op_set_filter P s \<equiv> {x\<in>s. P x}"
definition [simp]: "op_set_sel P s \<equiv> SPEC (\<lambda>x. x\<in>s \<and> P x)"
definition [simp]: "op_set_pick s \<equiv> SPEC (\<lambda>x. x\<in>s)"
definition [simp]: "op_set_to_sorted_list ordR s
  \<equiv> SPEC (\<lambda>l. set l = s \<and> distinct l \<and> sorted_by_rel ordR l)"
definition [simp]: "op_set_to_list s \<equiv> SPEC (\<lambda>l. set l = s \<and> distinct l)"
definition [simp]: "op_set_cart x y \<equiv> x \<times> y"

(* TODO: Do op_set_pick_remove (like op_map_pick_remove) *)

context begin interpretation autoref_syn .

  "s = {} \<equiv> op_set_isEmpty$s"
  "{}=s \<equiv> op_set_isEmpty$s"

  "card s = 1 \<equiv> op_set_isSng$s"
  "\<exists>x. s={x} \<equiv> op_set_isSng$s"
  "\<exists>x. {x}=s \<equiv> op_set_isSng$s"

  "min m (card s) \<equiv> op_set_size_abort$m$s"
  "min (card s) m \<equiv> op_set_size_abort$m$s"

  "a\<inter>b={} \<equiv> op_set_disjoint$a$b"

  "{x\<in>s. P x} \<equiv> op_set_filter$P$s"

  "SPEC (\<lambda>x. x\<in>s \<and> P x) \<equiv> op_set_sel$P$s"
  "SPEC (\<lambda>x. P x \<and> x\<in>s) \<equiv> op_set_sel$P$s"

  "SPEC (\<lambda>x. x\<in>s) \<equiv> op_set_pick$s"
  by (auto intro!: eq_reflection simp: card_Suc_eq)

lemma [autoref_op_pat]:
  "a \<times> b \<equiv> op_set_cart a b"
  by (auto intro!: eq_reflection simp: card_Suc_eq)

lemma [autoref_op_pat]:
  "SPEC (\<lambda>(u,v). (u,v)\<in>s) \<equiv> op_set_pick$s"
  "SPEC (\<lambda>(u,v). P u v \<and> (u,v)\<in>s) \<equiv> op_set_sel$(case_prod P)$s"
  "SPEC (\<lambda>(u,v). (u,v)\<in>s \<and> P u v) \<equiv> op_set_sel$(case_prod P)$s"
  by (auto intro!: eq_reflection)

  lemma [autoref_op_pat]:
    "SPEC (\<lambda>l. set l = s \<and> distinct l \<and> sorted_by_rel ordR l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. set l = s \<and> sorted_by_rel ordR l \<and> distinct l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. distinct l \<and> set l = s \<and> sorted_by_rel ordR l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. distinct l \<and> sorted_by_rel ordR l \<and> set l = s)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. sorted_by_rel ordR l \<and> distinct l \<and> set l = s)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. sorted_by_rel ordR l \<and> set l = s \<and> distinct l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"

    "SPEC (\<lambda>l. s = set l \<and> distinct l \<and> sorted_by_rel ordR l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. s = set l \<and> sorted_by_rel ordR l \<and> distinct l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. distinct l \<and> s = set l \<and> sorted_by_rel ordR l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. distinct l \<and> sorted_by_rel ordR l \<and> s = set l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. sorted_by_rel ordR l \<and> distinct l \<and> s = set l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. sorted_by_rel ordR l \<and> s = set l \<and> distinct l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"

    "SPEC (\<lambda>l. set l = s \<and> distinct l) \<equiv> op_set_to_list$s"
    "SPEC (\<lambda>l. distinct l \<and> set l = s) \<equiv> op_set_to_list$s"

    "SPEC (\<lambda>l. s = set l \<and> distinct l) \<equiv> op_set_to_list$s"
    "SPEC (\<lambda>l. distinct l \<and> s = set l) \<equiv> op_set_to_list$s"
    by (auto intro!: eq_reflection)

end

lemma [autoref_itype]:
  "{} ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "insert ::\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "op_set_delete ::\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "op \<in> ::\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "op_set_isEmpty ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "op_set_isSng ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "op \<union> ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "op \<inter> ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "(op - :: 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "(op = :: 'a set \<Rightarrow> 'a set \<Rightarrow> bool) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "op \<subseteq> ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "op_set_disjoint ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "Ball ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i (I \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i i_bool"
  "Bex ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i (I \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i i_bool"
  "op_set_filter ::\<^sub>i (I \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "card ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_nat"
  "op_set_size_abort ::\<^sub>i i_nat \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_nat"
  "set ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "op_set_sel ::\<^sub>i (I \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_nres"
  "op_set_pick ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_nres"
  "Sigma ::\<^sub>i \<langle>Ia\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i (Ia \<rightarrow>\<^sub>i \<langle>Ib\<rangle>\<^sub>ii_set) \<rightarrow>\<^sub>i \<langle>\<langle>Ia,Ib\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_set"
  "op ` ::\<^sub>i (Ia\<rightarrow>\<^sub>iIb) \<rightarrow>\<^sub>i \<langle>Ia\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>Ib\<rangle>\<^sub>ii_set"
  "op_set_cart ::\<^sub>i \<langle>Ix\<rangle>\<^sub>iIsx \<rightarrow>\<^sub>i \<langle>Iy\<rangle>\<^sub>iIsy \<rightarrow>\<^sub>i \<langle>\<langle>Ix, Iy\<rangle>\<^sub>ii_prod\<rangle>\<^sub>iIsp"
  "Union ::\<^sub>i \<langle>\<langle>I\<rangle>\<^sub>ii_set\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "atLeastLessThan ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_nat \<rightarrow>\<^sub>i \<langle>i_nat\<rangle>\<^sub>ii_set"
  by simp_all

lemma hom_set1[autoref_hom]:
  "CONSTRAINT {} (\<langle>R\<rangle>Rs)"
  "CONSTRAINT insert (R\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT op \<in> (R\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op \<union> (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT op \<inter> (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT op - (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT op = (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op \<subseteq> (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT Ball (\<langle>R\<rangle>Rs\<rightarrow>(R\<rightarrow>Id)\<rightarrow>Id)"
  "CONSTRAINT Bex (\<langle>R\<rangle>Rs\<rightarrow>(R\<rightarrow>Id)\<rightarrow>Id)"
  "CONSTRAINT card (\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT set (\<langle>R\<rangle>Rl\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT op ` ((Ra\<rightarrow>Rb) \<rightarrow> \<langle>Ra\<rangle>Rs\<rightarrow>\<langle>Rb\<rangle>Rs)"
  "CONSTRAINT Union (\<langle>\<langle>R\<rangle>Ri\<rangle>Ro \<rightarrow> \<langle>R\<rangle>Ri)"
  by simp_all

lemma hom_set2[autoref_hom]:
  "CONSTRAINT op_set_delete (R\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT op_set_isEmpty (\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op_set_isSng (\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op_set_size_abort (Id\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op_set_disjoint (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op_set_filter ((R\<rightarrow>Id)\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT op_set_sel ((R \<rightarrow> Id)\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rn)"
  "CONSTRAINT op_set_pick (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rn)"
  by simp_all

lemma hom_set_Sigma[autoref_hom]:
  "CONSTRAINT Sigma (\<langle>Ra\<rangle>Rs \<rightarrow> (Ra \<rightarrow> \<langle>Rb\<rangle>Rs) \<rightarrow> \<langle>\<langle>Ra,Rb\<rangle>prod_rel\<rangle>Rs2)"
  by simp_all

definition "finite_set_rel R \<equiv> Range R \<subseteq> Collect (finite)"

lemma finite_set_rel_trigger: "finite_set_rel R \<Longrightarrow> finite_set_rel R" .

declaration {* Tagged_Solver.add_triggers
  "Relators.relator_props_solver" @{thms finite_set_rel_trigger} *}

end


theory ex03
  imports "BST_Demo"
begin

thm isin.simps

fun isin2 :: "('a::linorder) tree \<Rightarrow> 'a option \<Rightarrow> 'a \<Rightarrow> bool" where
"isin2 Leaf z x = (case z of None \<Rightarrow> False | Some y \<Rightarrow> x = y)" |
"isin2 (Node l a r) z x =
  (if x < a then isin2 l z x
   else isin2 r (Some a) x)"

lemma isin2_Some:
"\<lbrakk>bst t; \<forall>x\<in>set_tree t. a < x\<rbrakk> \<Longrightarrow>
   isin2 t (Some a) x = (isin t x \<or> a = x)"
  apply(induction t arbitrary: a)
  apply auto
  done

lemma isin2_None:
"bst t \<Longrightarrow> isin2 t None x = isin t x"
  apply(induction t)
   apply (auto simp add: isin2_Some)
  done

fun join :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "join t \<langle>\<rangle> = t" |
  "join \<langle>\<rangle> t = t" |
  "join (Node l1 a1 r1) (Node l2 a2 r2) =
     (case join r1 l2 of \<langle>\<rangle> \<Rightarrow> Node l1 a1 (Node \<langle>\<rangle> a2 r2)
                  | Node l a r \<Rightarrow> Node (Node l1 a1 l) a (Node r a2 r2))"

value "join (Node (Node \<langle>\<rangle> (1::nat) \<langle>\<rangle>) 2 (Node \<langle>\<rangle> (3::nat) \<langle>\<rangle>)) (Node (Node \<langle>\<rangle> (4::nat) \<langle>\<rangle>) 5 (Node \<langle>\<rangle> (6::nat) \<langle>\<rangle>))"

thm tree.splits

lemma join_inorder: "inorder (join t1 t2 ) = inorder t1 @ inorder t2"
  apply(induction t1 t2 rule: join.induct)
    apply (auto split: tree.splits)
  done

lemma "height(join t1 t2 ) \<le> max (height t1 ) (height t2 ) + 1"
  apply(induction t1 t2 rule: join.induct)
    apply (auto split: tree.splits)
  done

thm set_inorder[symmetric]

thm set_append

lemma set_tree_join: "set_tree (join t1 t2 ) = set_tree t1 \<union> set_tree t2"
  by (auto simp del: set_inorder simp: set_inorder[symmetric] join_inorder)

thm bst_iff_sorted_wrt_less
thm sorted_wrt_append

lemma bst_join: "bst (Node l (x ::'a::linorder ) r ) \<Longrightarrow> bst (join l r )"
  apply(auto simp del: bst_wrt.simps
             simp: bst_iff_sorted_wrt_less join_inorder sorted_wrt_append)
  done

fun delete:: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "delete x \<langle>\<rangle> = \<langle>\<rangle>" |
  "delete x (Node l a r) =
   (if x = a then join l r else
    if x < a then Node (delete x l) a r else
    Node l a (delete x r))"

declare join.simps [simp del]

lemma "bst t \<Longrightarrow> bst (delete x t)"
  apply (induction t)
  apply(auto simp: bst_join)
  done

end


section "Splay Tree"

theory Splay_Tree
imports
  "HOL-Library.Tree"
  "HOL-Data_Structures.Set_Specs"
  "HOL-Data_Structures.Cmp"
begin

declare sorted_wrt.simps(2)[simp del]

text\<open>Splay trees were invented by Sleator and Tarjan~\cite{SleatorT-JACM85}.\<close>

subsection "Function \<open>splay\<close>"

function splay :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"splay x Leaf = Leaf" |
"splay x (Node AB x CD) = Node AB x CD" |
"x<b \<Longrightarrow> splay x (Node (Node A x B) b CD) = Node A x (Node B b CD)" |
"x<b \<Longrightarrow> splay x (Node Leaf b CD) = Node Leaf b CD" |
"x<a \<Longrightarrow> x<b \<Longrightarrow> splay x (Node (Node Leaf a B) b CD) = Node Leaf a (Node B b CD)" |
"x<a \<Longrightarrow> x<b \<Longrightarrow> A \<noteq> Leaf \<Longrightarrow>
 splay x (Node (Node A a B) b CD) =
 (case splay x A of Node A1 a' A2 \<Rightarrow> Node A1 a' (Node A2 a (Node B b CD)))" |
"a<x \<Longrightarrow> x<b \<Longrightarrow> splay x (Node (Node A a Leaf) b CD) = Node A a (Node Leaf b CD)" |
"a<x \<Longrightarrow> x<b \<Longrightarrow> B \<noteq> Leaf \<Longrightarrow>
 splay x (Node (Node A a B) b CD) =
 (case splay x B of Node B1 b' B2 \<Rightarrow> Node (Node A a B1) b' (Node B2 b CD))" |
"b<x \<Longrightarrow> splay x (Node AB b (Node C x D)) = Node (Node AB b C) x D" |
"b<x \<Longrightarrow> splay x (Node AB b Leaf) = Node AB b Leaf" |
"b<x \<Longrightarrow> x<c \<Longrightarrow> C \<noteq> Leaf \<Longrightarrow>
 splay x (Node AB b (Node C c D)) =
 (case splay x C of Node C1 c' C \<Rightarrow> Node (Node AB b C1) c' (Node C c D))" |
"b<x \<Longrightarrow> x<c \<Longrightarrow> splay x (Node AB b (Node Leaf c D)) = Node (Node AB b Leaf) c D" |
"b<x \<Longrightarrow> c<x \<Longrightarrow> splay x (Node AB b (Node C c Leaf)) = Node (Node AB b C) c Leaf" |
"a<x \<Longrightarrow> c<x \<Longrightarrow> D \<noteq> Leaf \<Longrightarrow>
 splay x (Node AB a (Node C c D)) =
 (case splay x D of Node D1 d' D2 \<Rightarrow> Node (Node (Node AB a C) c D1) d' D2)"
apply(atomize_elim)
apply(auto)
(* 1 subgoal *)
apply (subst (asm) neq_Leaf_iff)
apply(auto)
apply (metis tree.exhaust le_less_linear less_linear)+
done

termination splay
by lexicographic_order

lemma splay_code: "splay x (Node AB b CD) =
  (case cmp x b of
   EQ \<Rightarrow> Node AB b CD |
   LT \<Rightarrow> (case AB of
          Leaf \<Rightarrow> Node AB b CD |
          Node A a B \<Rightarrow>
            (case cmp x a of EQ \<Rightarrow> Node A a (Node B b CD) |
             LT \<Rightarrow>  if A = Leaf then Node A a (Node B b CD)
                       else case splay x A of
                         Node A\<^sub>1 a' A\<^sub>2 \<Rightarrow> Node A\<^sub>1 a' (Node A\<^sub>2 a (Node B b CD)) |
             GT \<Rightarrow> if B = Leaf then Node A a (Node B b CD)
                       else case splay x B of
                         Node B\<^sub>1 b' B\<^sub>2 \<Rightarrow> Node (Node A a B\<^sub>1) b' (Node B\<^sub>2 b CD))) |
   GT \<Rightarrow> (case CD of
          Leaf \<Rightarrow> Node AB b CD |
          Node C c D \<Rightarrow>
            (case cmp x c of EQ \<Rightarrow> Node (Node AB b C) c D |
             LT \<Rightarrow> if C = Leaf then Node (Node AB b C) c D
                       else case splay x C of
                         Node C\<^sub>1 c' C\<^sub>2 \<Rightarrow> Node (Node AB b C\<^sub>1) c' (Node C\<^sub>2 c D) |
             GT \<Rightarrow> if D=Leaf then Node (Node AB b C) c D
                       else case splay x D of
                         Node D\<^sub>1 d D\<^sub>2 \<Rightarrow> Node (Node (Node AB b C) c D\<^sub>1) d D\<^sub>2)))"
by(auto split!: tree.split)

definition is_root :: "'a \<Rightarrow> 'a tree \<Rightarrow> bool" where
"is_root x t = (case t of Leaf \<Rightarrow> False | Node l a r \<Rightarrow> x = a)"

definition "isin t x = is_root x (splay x t)"

definition empty :: "'a tree" where
"empty = Leaf"

hide_const (open) insert

fun insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert x t =
  (if t = Leaf then Node Leaf x Leaf
   else case splay x t of
     Node l a r \<Rightarrow>
      case cmp x a of
        EQ \<Rightarrow> Node l a r |
        LT \<Rightarrow> Node l x (Node Leaf a r) |
        GT \<Rightarrow> Node (Node l a Leaf) x r)"

fun splay_max :: "'a tree \<Rightarrow> 'a tree" where
"splay_max Leaf = Leaf" |
"splay_max (Node A a Leaf) = Node A a Leaf" |
"splay_max (Node A a (Node B b CD)) =
  (if CD = Leaf then Node (Node A a B) b Leaf
   else case splay_max CD of
     Node C c D \<Rightarrow> Node (Node (Node A a B) b C) c D)"

lemma splay_max_code: "splay_max t = (case t of
  Leaf \<Rightarrow> t |
  Node la a ra \<Rightarrow> (case ra of
    Leaf \<Rightarrow> t |
    Node lb b rb \<Rightarrow>
      (if rb=Leaf then Node (Node la a lb) b rb
       else case splay_max rb of
              Node lc c rc \<Rightarrow> Node (Node (Node la a lb) b lc) c rc)))"
by(auto simp: neq_Leaf_iff split: tree.split)

definition delete :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"delete x t =
  (if t = Leaf then Leaf
   else case splay x t of Node l a r \<Rightarrow>
     if x \<noteq> a then Node l a r
     else if l = Leaf then r else case splay_max l of Node l' m r' \<Rightarrow> Node l' m r)"

subsection "Functional Correctness Proofs I"

text \<open>This subsection follows the automated method by Nipkow \cite{Nipkow-ITP16}.\<close>

lemma splay_Leaf_iff[simp]: "(splay a t = Leaf) = (t = Leaf)"
by(induction a t rule: splay.induct) (auto split: tree.splits)

lemma splay_max_Leaf_iff[simp]: "(splay_max t = Leaf) = (t = Leaf)"
by(induction t rule: splay_max.induct)(auto split: tree.splits)

subsubsection "Verification of @{const isin}"

lemma splay_elemsD:
  "splay x t = Node l a r \<Longrightarrow> sorted(inorder t) \<Longrightarrow>
  x \<in> set (inorder t) \<longleftrightarrow> x=a"
by(induction x t arbitrary: l a r rule: splay.induct)
  (auto simp: isin_simps ball_Un split: tree.splits)

lemma isin_set: "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> set (inorder t))"
by (auto simp: isin_def is_root_def dest: splay_elemsD split: tree.splits)

subsubsection "Verification of @{const insert}"

lemma inorder_splay: "inorder(splay x t) = inorder t"
by(induction x t rule: splay.induct)
  (auto simp: neq_Leaf_iff split: tree.split)

lemma sorted_splay:
  "sorted(inorder t) \<Longrightarrow> splay x t = Node l a r \<Longrightarrow>
  sorted(inorder l @ x # inorder r)"
unfolding inorder_splay[of x t, symmetric]
by(induction x t arbitrary: l a r rule: splay.induct)
  (auto simp: sorted_lems sorted_Cons_le sorted_snoc_le split: tree.splits)

lemma inorder_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert x t) = ins_list x (inorder t)"
using inorder_splay[of x t, symmetric] sorted_splay[of t x]
by(auto simp: ins_list_simps ins_list_Cons ins_list_snoc neq_Leaf_iff split: tree.split)

subsubsection "Verification of @{const delete}"

lemma inorder_splay_maxD:
  "splay_max t = Node l a r \<Longrightarrow> sorted(inorder t) \<Longrightarrow>
  inorder l @ [a] = inorder t \<and> r = Leaf"
by(induction t arbitrary: l a r rule: splay_max.induct)
  (auto simp: sorted_lems split: tree.splits if_splits)

lemma inorder_delete:
  "sorted(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
using inorder_splay[of x t, symmetric] sorted_splay[of t x]
by (auto simp: del_list_simps del_list_sorted_app delete_def
  del_list_notin_Cons inorder_splay_maxD split: tree.splits)

subsubsection "Overall Correctness"

interpretation splay: Set_by_Ordered
where empty = empty and isin = isin and insert = insert
and delete = delete and inorder = inorder and inv = "\<lambda>_. True"
proof (standard, goal_cases)
  case 2 thus ?case by(simp add: isin_set)
next
  case 3 thus ?case by(simp add: inorder_insert del: insert.simps)
next
  case 4 thus ?case by(simp add: inorder_delete)
qed (auto simp: empty_def)

text \<open>Corollaries:\<close>

lemma bst_splay: "bst t \<Longrightarrow> bst (splay x t)"
by (simp add: bst_iff_sorted_wrt_less inorder_splay)

lemma bst_insert: "bst t \<Longrightarrow> bst(insert x t)"
using splay.invar_insert[of t x] by (simp add: bst_iff_sorted_wrt_less splay.invar_def)

lemma bst_delete: "bst t \<Longrightarrow> bst(delete x t)"
using splay.invar_delete[of t x] by (simp add: bst_iff_sorted_wrt_less splay.invar_def)

lemma splay_bstL: "bst t \<Longrightarrow> splay a t = Node l e r \<Longrightarrow> x \<in> set_tree l \<Longrightarrow> x < a"
by (metis bst_iff_sorted_wrt_less list.set_intros(1) set_inorder sorted_splay sorted_wrt_append)

lemma splay_bstR: "bst t \<Longrightarrow> splay a t = Node l e r \<Longrightarrow> x \<in> set_tree r \<Longrightarrow> a < x"
by (metis bst_iff_sorted_wrt_less sorted_Cons_iff set_inorder sorted_splay sorted_wrt_append)

subsubsection "Size lemmas"

lemma size_splay[simp]: "size (splay a t) = size t"
apply(induction a t rule: splay.induct)
apply auto
 apply(force split: tree.split)+
done

lemma size_if_splay: "splay a t = Node l u r \<Longrightarrow> size t = size l + size r + 1"
by (metis One_nat_def size_splay tree.size(4))

lemma splay_not_Leaf: "t \<noteq> Leaf \<Longrightarrow> \<exists>l x r. splay a t = Node l x r"
by (metis neq_Leaf_iff splay_Leaf_iff)

lemma size_splay_max: "size(splay_max t) = size t"
apply(induction t rule: splay_max.induct)
  apply(simp)
 apply(simp)
apply(clarsimp split: tree.split)
done

(*
subsection "Functional Correctness Proofs II"

text \<open>This subsection follows the traditional approach, is less automated
and is retained more for historic reasons.\<close>

lemma set_splay: "set_tree(splay a t) = set_tree t"
proof(induction a t rule: splay.induct)
  case (6 a)
  with splay_not_Leaf[OF 6(3), of a] show ?case by(fastforce)
next
  case (8 _ a)
  with splay_not_Leaf[OF 8(3), of a] show ?case by(fastforce)
next
  case (11 _ a)
  with splay_not_Leaf[OF 11(3), of a] show ?case by(fastforce)
next
  case (14 _ a)
  with splay_not_Leaf[OF 14(3), of a] show ?case by(fastforce)
qed auto

lemma splay_bstL: "bst t \<Longrightarrow> splay a t = Node l e r \<Longrightarrow> x \<in> set_tree l \<Longrightarrow> x < a"
apply(induction a t arbitrary: l x r rule: splay.induct)
apply (auto split: tree.splits)
apply auto
done

lemma splay_bstR: "bst t \<Longrightarrow> splay a t = Node l e r \<Longrightarrow> x \<in> set_tree r \<Longrightarrow> a < x"
apply(induction a t arbitrary: l e x r rule: splay.induct)
apply auto
apply (fastforce split!: tree.splits)+
done

lemma bst_splay: "bst t \<Longrightarrow> bst(splay a t)"
proof(induction a t rule: splay.induct)
  case (6 a _ _ ll)
  with splay_not_Leaf[OF 6(3), of a] set_splay[of a ll,symmetric]
  show ?case by (fastforce)
next
  case (8 _ a _ t)
  with splay_not_Leaf[OF 8(3), of a] set_splay[of a t,symmetric]
  show ?case by fastforce
next
  case (11 _ a _ t)
  with splay_not_Leaf[OF 11(3), of a] set_splay[of a t,symmetric]
  show ?case by fastforce
next
  case (14 _ a _ t)
  with splay_not_Leaf[OF 14(3), of a] set_splay[of a t,symmetric]
  show ?case by fastforce
qed auto

subsubsection "Verification of Is-in Test"

text\<open>To test if an element \<open>a\<close> is in \<open>t\<close>, first perform
@{term"splay a t"}, then check if the root is \<open>a\<close>. One could
put this into one function that returns both a new tree and the test result.\<close>

lemma is_root_splay: "bst t \<Longrightarrow> is_root a (splay a t) \<longleftrightarrow> a \<in> set_tree t"
by(auto simp add: is_root_def splay_to_root split: tree.split)

subsubsection "Verification of @{const insert}"

lemma set_insert: "set_tree(insert a t) = Set.insert a (set_tree t)"
apply(cases t)
 apply simp
using set_splay[of a t]
by(simp split: tree.split) fastforce

lemma bst_insert: "bst t \<Longrightarrow> bst(insert a t)"
apply(cases t)
 apply simp
using bst_splay[of t a] splay_bstL[of t a] splay_bstR[of t a]
by(auto simp: ball_Un split: tree.split)

subsubsection "Verification of \<open>splay_max\<close>"

lemma set_splay_max: "set_tree(splay_max t) = set_tree t"
apply(induction t rule: splay_max.induct)
   apply(simp)
  apply(simp)
apply(force split: tree.split)
done

lemma bst_splay_max: "bst t \<Longrightarrow> bst (splay_max t)"
proof(induction t rule: splay_max.induct)
  case (3 l b rl c rr)
  { fix rrl' d' rrr'
    have "splay_max rr = Node rrl' d' rrr'
       \<Longrightarrow> \<forall>x \<in> set_tree(Node rrl' d' rrr'). c < x"
      using "3.prems" set_splay_max[of rr]
      by (clarsimp split: tree.split simp: ball_Un)
  }
  with 3 show ?case by (fastforce split: tree.split simp: ball_Un)
qed auto

lemma splay_max_Leaf: "splay_max t = Node l a r \<Longrightarrow> r = Leaf"
by(induction t arbitrary: l rule: splay_max.induct)
  (auto split: tree.splits if_splits)

text\<open>For sanity purposes only:\<close>

lemma splay_max_eq_splay:
  "bst t \<Longrightarrow> \<forall>x \<in> set_tree t. x \<le> a \<Longrightarrow> splay_max t = splay a t"
proof(induction a t rule: splay.induct)
  case (2 a l r)
  show ?case
  proof (cases r)
    case Leaf with 2 show ?thesis by simp
  next
    case Node with 2 show ?thesis by(auto)
  qed
qed (auto simp: neq_Leaf_iff)

lemma splay_max_eq_splay_ex: assumes "bst t" shows "\<exists>a. splay_max t = splay a t"
proof(cases t)
  case Leaf thus ?thesis by simp
next
  case Node
  hence "splay_max t = splay (Max(set_tree t)) t"
    using assms by (auto simp: splay_max_eq_splay)
  thus ?thesis by auto
qed

subsubsection "Verification of @{const delete}"

lemma set_delete: assumes "bst t"
shows "set_tree (delete a t) = set_tree t - {a}"
proof(cases t)
  case Leaf thus ?thesis by(simp add: delete_def)
next
  case (Node l x r)
  obtain l' x' r' where sp[simp]: "splay a (Node l x r) = Node l' x' r'"
    by (metis neq_Leaf_iff splay_Leaf_iff)
  show ?thesis
  proof cases
    assume [simp]: "x' = a"
    show ?thesis
    proof cases
      assume "l' = Leaf"
      thus ?thesis
        using Node assms set_splay[of a "Node l x r"] bst_splay[of "Node l x r" a]
        by(simp add: delete_def split: tree.split prod.split)(fastforce)
    next
      assume "l' \<noteq> Leaf"
      moreover then obtain l'' m r'' where "splay_max l' = Node l'' m r''"
        using splay_max_Leaf_iff tree.exhaust by blast
      moreover have "a \<notin> set_tree l'"
        by (metis (no_types) Node assms less_irrefl sp splay_bstL)
      ultimately show ?thesis
        using Node assms set_splay[of a "Node l x r"] bst_splay[of "Node l x r" a]
          splay_max_Leaf[of l' l'' m r''] set_splay_max[of l']
        by(clarsimp simp: delete_def split: tree.split) auto
    qed
  next
    assume "x' \<noteq> a"
    thus ?thesis using Node assms set_splay[of a "Node l x r"] splay_to_root[OF _ sp]
      by (simp add: delete_def)
  qed
qed

lemma bst_delete: assumes "bst t" shows "bst (delete a t)"
proof(cases t)
  case Leaf thus ?thesis by(simp add: delete_def)
next
  case (Node l x r)
  obtain l' x' r' where sp[simp]: "splay a (Node l x r) = Node l' x' r'"
    by (metis neq_Leaf_iff splay_Leaf_iff)
  show ?thesis
  proof cases
    assume [simp]: "x' = a"
    show ?thesis
    proof cases
      assume "l' = Leaf"
      thus ?thesis using Node assms bst_splay[of "Node l x r" a]
        by(simp add: delete_def split: tree.split prod.split)
    next
      assume "l' \<noteq> Leaf"
      thus ?thesis
        using Node assms set_splay[of a "Node l x r"] bst_splay[of "Node l x r" a]
          bst_splay_max[of l'] set_splay_max[of l']
        by(clarsimp simp: delete_def split: tree.split)
          (metis (no_types) insertI1 less_trans)
    qed
  next
    assume "x' \<noteq> a"
    thus ?thesis using Node assms bst_splay[of "Node l x r" a]
      by(auto simp: delete_def split: tree.split prod.split)
  qed
qed
*)

end


(*
  Author: Fred Kurz
*)
theory CNF_Supplement
  imports "Propositional_Proof_Systems.CNF_Formulas_Sema"
begin

(* TODO fix warnings *)

fun is_literal_formula
  where "is_literal_formula (Atom _) = True"
  | "is_literal_formula (\<^bold>\<not>(Atom _)) = True"
  | "is_literal_formula _ = False"

fun literal_formula_to_literal :: "'a formula \<Rightarrow> 'a literal"
  where "literal_formula_to_literal (Atom a) = a\<^sup>+"
  | "literal_formula_to_literal (\<^bold>\<not>(Atom a)) = a\<inverse>"

lemma is_literal_formula_then_cnf_is_singleton_clause:
  assumes "is_literal_formula f"
  obtains C where "cnf f = { C }"
proof -
  consider (f_is_positive_literal) "\<exists>a. f = Atom a"
    | (f_is_negative_literal) "\<exists>a. f = \<^bold>\<not>(Atom a)"
    using assms is_literal_formula.elims(2)[of f]
    by meson
  then have "\<exists>C. cnf f = { C }"
    proof (cases)
      case f_is_positive_literal
      then obtain a where "f = Atom a"
        by force
      then have "cnf f = {{ a\<^sup>+ }}"
        by force
      thus ?thesis
        by simp
    next
      case f_is_negative_literal
      then obtain a where "f = \<^bold>\<not>(Atom a)"
        by force
      then have "cnf f = {{ a\<inverse> }}"
        by force
      thus ?thesis
        by simp
    qed
  thus ?thesis
    using that
    by presburger
qed

lemma literal_formula_to_literal_is_inverse_of_form_of_lit:
  "literal_formula_to_literal (form_of_lit L) = L"
  by (cases L, simp+)

lemma is_nnf_cnf:
  assumes "is_cnf F"
    shows "is_nnf F"
  using assms
proof (induction F)
  case (Or F1 F2)
  have "is_disj (F1 \<^bold>\<or> F2)"
    using Or.prems is_cnf.simps(5)
    by simp
  thus ?case
    using disj_is_nnf
    by blast
qed simp+

lemma cnf_of_literal_formula:
  assumes "is_literal_formula f"
  shows "cnf f = {{ literal_formula_to_literal f }}"
proof -
  consider (f_is_positive_literal) "\<exists>a. f = Atom a"
    | (f_is_negative_literal) "\<exists>a. f = (\<^bold>\<not>(Atom a))"
    using assms is_literal_formula.elims(2)[of f "\<exists>a. f = Atom a"]
       is_literal_formula.elims(2)[of f "\<exists>a. f = (\<^bold>\<not>(Atom a))"]
    by blast
  thus ?thesis
    by(cases, force+)
qed

lemma is_cnf_foldr_and_if:
  assumes "\<forall>f \<in> set fs. is_cnf f"
  shows "is_cnf (foldr (\<^bold>\<and>) fs (\<^bold>\<not>\<bottom>))"
  using assms
proof (induction fs)
  case (Cons f fs)
  have "foldr (\<^bold>\<and>) (f # fs) (\<^bold>\<not>\<bottom>) = f \<^bold>\<and> (foldr (\<^bold>\<and>) fs (\<^bold>\<not>\<bottom>))"
    by simp
  moreover {
    have "\<forall>f \<in> set fs. is_cnf f"
      using Cons.prems
      by force
    hence "is_cnf (foldr (\<^bold>\<and>) fs (\<^bold>\<not>\<bottom>))"
      using Cons.IH
      by blast
  }
  moreover have "is_cnf f"
    using Cons.prems
    by simp
  ultimately show ?case
    by simp
qed simp

end