(*  Title:      HOL/Library/Countable_Set.thy
    Author:     Johannes Hölzl
    Author:     Andrei Popescu
*)

section \<open>Countable sets\<close>

theory Countable_Set
imports Countable Infinite_Set
begin

subsection \<open>Predicate for countable sets\<close>

definition countable :: "'a set \<Rightarrow> bool" where
  "countable S \<longleftrightarrow> (\<exists>f::'a \<Rightarrow> nat. inj_on f S)"

lemma countableE:
  assumes S: "countable S" obtains f :: "'a \<Rightarrow> nat" where "inj_on f S"
  using S by (auto simp: countable_def)

lemma countableI: "inj_on (f::'a \<Rightarrow> nat) S \<Longrightarrow> countable S"
  by (auto simp: countable_def)

lemma countableI': "inj_on (f::'a \<Rightarrow> 'b::countable) S \<Longrightarrow> countable S"
  using comp_inj_on[of f S to_nat] by (auto intro: countableI)

lemma countableE_bij:
  assumes S: "countable S" obtains f :: "nat \<Rightarrow> 'a" and C :: "nat set" where "bij_betw f C S"
  using S by (blast elim: countableE dest: inj_on_imp_bij_betw bij_betw_inv)

lemma countableI_bij: "bij_betw f (C::nat set) S \<Longrightarrow> countable S"
  by (blast intro: countableI bij_betw_inv_into bij_betw_imp_inj_on)

lemma countable_finite: "finite S \<Longrightarrow> countable S"
  by (blast dest: finite_imp_inj_to_nat_seg countableI)

lemma countableI_bij1: "bij_betw f A B \<Longrightarrow> countable A \<Longrightarrow> countable B"
  by (blast elim: countableE_bij intro: bij_betw_trans countableI_bij)

lemma countableI_bij2: "bij_betw f B A \<Longrightarrow> countable A \<Longrightarrow> countable B"
  by (blast elim: countableE_bij intro: bij_betw_trans bij_betw_inv_into countableI_bij)

lemma countable_iff_bij[simp]: "bij_betw f A B \<Longrightarrow> countable A \<longleftrightarrow> countable B"
  by (blast intro: countableI_bij1 countableI_bij2)

lemma countable_subset: "A \<subseteq> B \<Longrightarrow> countable B \<Longrightarrow> countable A"
  by (auto simp: countable_def intro: subset_inj_on)

lemma countableI_type[intro, simp]: "countable (A:: 'a :: countable set)"
  using countableI[of to_nat A] by auto

subsection \<open>Enumerate a countable set\<close>

lemma countableE_infinite:
  assumes "countable S" "infinite S"
  obtains e :: "'a \<Rightarrow> nat" where "bij_betw e S UNIV"
proof -
  obtain f :: "'a \<Rightarrow> nat" where "inj_on f S"
    using \<open>countable S\<close> by (rule countableE)
  then have "bij_betw f S (f`S)"
    unfolding bij_betw_def by simp
  moreover
  from \<open>inj_on f S\<close> \<open>infinite S\<close> have inf_fS: "infinite (f`S)"
    by (auto dest: finite_imageD)
  then have "bij_betw (the_inv_into UNIV (enumerate (f`S))) (f`S) UNIV"
    by (intro bij_betw_the_inv_into bij_enumerate)
  ultimately have "bij_betw (the_inv_into UNIV (enumerate (f`S)) \<circ> f) S UNIV"
    by (rule bij_betw_trans)
  then show thesis ..
qed

lemma countable_infiniteE':
  assumes "countable A" "infinite A"
  obtains g where "bij_betw g (UNIV :: nat set) A"
  by (meson assms bij_betw_inv countableE_infinite)

lemma countable_enum_cases:
  assumes "countable S"
  obtains (finite) f :: "'a \<Rightarrow> nat" where "finite S" "bij_betw f S {..<card S}"
        | (infinite) f :: "'a \<Rightarrow> nat" where "infinite S" "bij_betw f S UNIV"
  using ex_bij_betw_finite_nat[of S] countableE_infinite \<open>countable S\<close>
  by (cases "finite S") (auto simp add: atLeast0LessThan)

definition to_nat_on :: "'a set \<Rightarrow> 'a \<Rightarrow> nat" where
  "to_nat_on S = (SOME f. if finite S then bij_betw f S {..< card S} else bij_betw f S UNIV)"

definition from_nat_into :: "'a set \<Rightarrow> nat \<Rightarrow> 'a" where
  "from_nat_into S n = (if n \<in> to_nat_on S ` S then inv_into S (to_nat_on S) n else SOME s. s\<in>S)"

lemma to_nat_on_finite: "finite S \<Longrightarrow> bij_betw (to_nat_on S) S {..< card S}"
  using ex_bij_betw_finite_nat unfolding to_nat_on_def
  by (intro someI2_ex[where Q="\<lambda>f. bij_betw f S {..<card S}"]) (auto simp add: atLeast0LessThan)

lemma to_nat_on_infinite: "countable S \<Longrightarrow> infinite S \<Longrightarrow> bij_betw (to_nat_on S) S UNIV"
  using countableE_infinite unfolding to_nat_on_def
  by (intro someI2_ex[where Q="\<lambda>f. bij_betw f S UNIV"]) auto

lemma bij_betw_from_nat_into_finite: "finite S \<Longrightarrow> bij_betw (from_nat_into S) {..< card S} S"
  unfolding from_nat_into_def[abs_def]
  using to_nat_on_finite[of S]
  apply (subst bij_betw_cong)
  apply (split if_split)
  apply (simp add: bij_betw_def)
  apply (auto cong: bij_betw_cong
              intro: bij_betw_inv_into to_nat_on_finite)
  done

lemma bij_betw_from_nat_into: "countable S \<Longrightarrow> infinite S \<Longrightarrow> bij_betw (from_nat_into S) UNIV S"
  unfolding from_nat_into_def[abs_def]
  using to_nat_on_infinite[of S, unfolded bij_betw_def]
  by (auto cong: bij_betw_cong intro: bij_betw_inv_into to_nat_on_infinite)

text \<open>
  The sum/product over the enumeration of a finite set equals simply the sum/product over the set
\<close>
context comm_monoid_set
begin

lemma card_from_nat_into:
  "F (\<lambda>i. h (from_nat_into A i)) {..<card A} = F h A"
proof (cases "finite A")
  case True
  have "F (\<lambda>i. h (from_nat_into A i)) {..<card A} = F h (from_nat_into A ` {..<card A})"
    by (metis True bij_betw_def bij_betw_from_nat_into_finite reindex_cong)
  also have "... = F h A"
    by (metis True bij_betw_def bij_betw_from_nat_into_finite)
  finally show ?thesis .
qed auto

end

lemma countable_as_injective_image:
  assumes "countable A" "infinite A"
  obtains f :: "nat \<Rightarrow> 'a" where "A = range f" "inj f"
by (metis bij_betw_def bij_betw_from_nat_into [OF assms])

lemma inj_on_to_nat_on[intro]: "countable A \<Longrightarrow> inj_on (to_nat_on A) A"
  using to_nat_on_infinite[of A] to_nat_on_finite[of A]
  by (cases "finite A") (auto simp: bij_betw_def)

lemma to_nat_on_inj[simp]:
  "countable A \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> to_nat_on A a = to_nat_on A b \<longleftrightarrow> a = b"
  using inj_on_to_nat_on[of A] by (auto dest: inj_onD)

lemma from_nat_into_to_nat_on[simp]: "countable A \<Longrightarrow> a \<in> A \<Longrightarrow> from_nat_into A (to_nat_on A a) = a"
  by (auto simp: from_nat_into_def intro!: inv_into_f_f)

lemma subset_range_from_nat_into: "countable A \<Longrightarrow> A \<subseteq> range (from_nat_into A)"
  by (auto intro: from_nat_into_to_nat_on[symmetric])

lemma from_nat_into: "A \<noteq> {} \<Longrightarrow> from_nat_into A n \<in> A"
  unfolding from_nat_into_def by (metis equals0I inv_into_into someI_ex)

lemma range_from_nat_into_subset: "A \<noteq> {} \<Longrightarrow> range (from_nat_into A) \<subseteq> A"
  using from_nat_into[of A] by auto

lemma range_from_nat_into[simp]: "A \<noteq> {} \<Longrightarrow> countable A \<Longrightarrow> range (from_nat_into A) = A"
  by (metis equalityI range_from_nat_into_subset subset_range_from_nat_into)

lemma image_to_nat_on: "countable A \<Longrightarrow> infinite A \<Longrightarrow> to_nat_on A ` A = UNIV"
  using to_nat_on_infinite[of A] by (simp add: bij_betw_def)

lemma to_nat_on_surj: "countable A \<Longrightarrow> infinite A \<Longrightarrow> \<exists>a\<in>A. to_nat_on A a = n"
  by (metis (no_types) image_iff iso_tuple_UNIV_I image_to_nat_on)

lemma to_nat_on_from_nat_into[simp]: "n \<in> to_nat_on A ` A \<Longrightarrow> to_nat_on A (from_nat_into A n) = n"
  by (simp add: f_inv_into_f from_nat_into_def)

lemma to_nat_on_from_nat_into_infinite[simp]:
  "countable A \<Longrightarrow> infinite A \<Longrightarrow> to_nat_on A (from_nat_into A n) = n"
  by (metis image_iff to_nat_on_surj to_nat_on_from_nat_into)

lemma from_nat_into_inj:
  "countable A \<Longrightarrow> m \<in> to_nat_on A ` A \<Longrightarrow> n \<in> to_nat_on A ` A \<Longrightarrow>
    from_nat_into A m = from_nat_into A n \<longleftrightarrow> m = n"
  by (subst to_nat_on_inj[symmetric, of A]) auto

lemma from_nat_into_inj_infinite[simp]:
  "countable A \<Longrightarrow> infinite A \<Longrightarrow> from_nat_into A m = from_nat_into A n \<longleftrightarrow> m = n"
  using image_to_nat_on[of A] from_nat_into_inj[of A m n] by simp

lemma eq_from_nat_into_iff:
  "countable A \<Longrightarrow> x \<in> A \<Longrightarrow> i \<in> to_nat_on A ` A \<Longrightarrow> x = from_nat_into A i \<longleftrightarrow> i = to_nat_on A x"
  by auto

lemma from_nat_into_surj: "countable A \<Longrightarrow> a \<in> A \<Longrightarrow> \<exists>n. from_nat_into A n = a"
  by (rule exI[of _ "to_nat_on A a"]) simp

lemma from_nat_into_inject[simp]:
  "A \<noteq> {} \<Longrightarrow> countable A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> countable B \<Longrightarrow> from_nat_into A = from_nat_into B \<longleftrightarrow> A = B"
  by (metis range_from_nat_into)

lemma inj_on_from_nat_into: "inj_on from_nat_into ({A. A \<noteq> {} \<and> countable A})"
  unfolding inj_on_def by auto

subsection \<open>Closure properties of countability\<close>

lemma countable_SIGMA[intro, simp]:
  "countable I \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> countable (A i)) \<Longrightarrow> countable (SIGMA i : I. A i)"
  by (intro countableI'[of "\<lambda>(i, a). (to_nat_on I i, to_nat_on (A i) a)"]) (auto simp: inj_on_def)

lemma countable_image[intro, simp]:
  assumes "countable A"
  shows "countable (f`A)"
proof -
  obtain g :: "'a \<Rightarrow> nat" where "inj_on g A"
    using assms by (rule countableE)
  moreover have "inj_on (inv_into A f) (f`A)" "inv_into A f ` f ` A \<subseteq> A"
    by (auto intro: inj_on_inv_into inv_into_into)
  ultimately show ?thesis
    by (blast dest: comp_inj_on subset_inj_on intro: countableI)
qed

lemma countable_image_inj_on: "countable (f ` A) \<Longrightarrow> inj_on f A \<Longrightarrow> countable A"
  by (metis countable_image the_inv_into_onto)

lemma countable_image_inj_Int_vimage:
   "\<lbrakk>inj_on f S; countable A\<rbrakk> \<Longrightarrow> countable (S \<inter> f -` A)"
  by (meson countable_image_inj_on countable_subset image_subset_iff_subset_vimage inf_le2 inj_on_Int)

lemma countable_image_inj_gen:
   "\<lbrakk>inj_on f S; countable A\<rbrakk> \<Longrightarrow> countable {x \<in> S. f x \<in> A}"
  using countable_image_inj_Int_vimage
  by (auto simp: vimage_def Collect_conj_eq)

lemma countable_image_inj_eq:
   "inj_on f S \<Longrightarrow> countable(f ` S) \<longleftrightarrow> countable S"
  using countable_image_inj_on by blast

lemma countable_image_inj:
   "\<lbrakk>countable A; inj f\<rbrakk> \<Longrightarrow> countable {x. f x \<in> A}"
  by (metis (mono_tags, lifting) countable_image_inj_eq countable_subset image_Collect_subsetI inj_on_inverseI the_inv_f_f)

lemma countable_UN[intro, simp]:
  fixes I :: "'i set" and A :: "'i => 'a set"
  assumes I: "countable I"
  assumes A: "\<And>i. i \<in> I \<Longrightarrow> countable (A i)"
  shows "countable (\<Union>i\<in>I. A i)"
proof -
  have "(\<Union>i\<in>I. A i) = snd ` (SIGMA i : I. A i)" by (auto simp: image_iff)
  then show ?thesis by (simp add: assms)
qed

lemma countable_Un[intro]: "countable A \<Longrightarrow> countable B \<Longrightarrow> countable (A \<union> B)"
  by (rule countable_UN[of "{True, False}" "\<lambda>True \<Rightarrow> A | False \<Rightarrow> B", simplified])
     (simp split: bool.split)

lemma countable_Un_iff[simp]: "countable (A \<union> B) \<longleftrightarrow> countable A \<and> countable B"
  by (metis countable_Un countable_subset inf_sup_ord(3,4))

lemma countable_Plus[intro, simp]:
  "countable A \<Longrightarrow> countable B \<Longrightarrow> countable (A <+> B)"
  by (simp add: Plus_def)

lemma countable_empty[intro, simp]: "countable {}"
  by (blast intro: countable_finite)

lemma countable_insert[intro, simp]: "countable A \<Longrightarrow> countable (insert a A)"
  using countable_Un[of "{a}" A] by (auto simp: countable_finite)

lemma countable_Int1[intro, simp]: "countable A \<Longrightarrow> countable (A \<inter> B)"
  by (force intro: countable_subset)

lemma countable_Int2[intro, simp]: "countable B \<Longrightarrow> countable (A \<inter> B)"
  by (blast intro: countable_subset)

lemma countable_INT[intro, simp]: "i \<in> I \<Longrightarrow> countable (A i) \<Longrightarrow> countable (\<Inter>i\<in>I. A i)"
  by (blast intro: countable_subset)

lemma countable_Diff[intro, simp]: "countable A \<Longrightarrow> countable (A - B)"
  by (blast intro: countable_subset)

lemma countable_insert_eq [simp]: "countable (insert x A) = countable A"
    by auto (metis Diff_insert_absorb countable_Diff insert_absorb)

lemma countable_vimage: "B \<subseteq> range f \<Longrightarrow> countable (f -` B) \<Longrightarrow> countable B"
  by (metis Int_absorb2 countable_image image_vimage_eq)

lemma surj_countable_vimage: "surj f \<Longrightarrow> countable (f -` B) \<Longrightarrow> countable B"
  by (metis countable_vimage top_greatest)

lemma countable_Collect[simp]: "countable A \<Longrightarrow> countable {a \<in> A. \<phi> a}"
  by (metis Collect_conj_eq Int_absorb Int_commute Int_def countable_Int1)

lemma countable_Image:
  assumes "\<And>y. y \<in> Y \<Longrightarrow> countable (X `` {y})"
  assumes "countable Y"
  shows "countable (X `` Y)"
proof -
  have "countable (X `` (\<Union>y\<in>Y. {y}))"
    unfolding Image_UN by (intro countable_UN assms)
  then show ?thesis by simp
qed

lemma countable_relpow:
  fixes X :: "'a rel"
  assumes Image_X: "\<And>Y. countable Y \<Longrightarrow> countable (X `` Y)"
  assumes Y: "countable Y"
  shows "countable ((X ^^ i) `` Y)"
  using Y by (induct i arbitrary: Y) (auto simp: relcomp_Image Image_X)

lemma countable_funpow:
  fixes f :: "'a set \<Rightarrow> 'a set"
  assumes "\<And>A. countable A \<Longrightarrow> countable (f A)"
  and "countable A"
  shows "countable ((f ^^ n) A)"
by(induction n)(simp_all add: assms)

lemma countable_rtrancl:
  "(\<And>Y. countable Y \<Longrightarrow> countable (X `` Y)) \<Longrightarrow> countable Y \<Longrightarrow> countable (X\<^sup>* `` Y)"
  unfolding rtrancl_is_UN_relpow UN_Image by (intro countable_UN countableI_type countable_relpow)

lemma countable_lists[intro, simp]:
  assumes A: "countable A" shows "countable (lists A)"
proof -
  have "countable (lists (range (from_nat_into A)))"
    by (auto simp: lists_image)
  with A show ?thesis
    by (auto dest: subset_range_from_nat_into countable_subset lists_mono)
qed

lemma Collect_finite_eq_lists: "Collect finite = set ` lists UNIV"
  using finite_list by auto

lemma countable_Collect_finite: "countable (Collect (finite::'a::countable set\<Rightarrow>bool))"
  by (simp add: Collect_finite_eq_lists)

lemma countable_int: "countable \<int>"
  unfolding Ints_def by auto

lemma countable_rat: "countable \<rat>"
  unfolding Rats_def by auto

lemma Collect_finite_subset_eq_lists: "{A. finite A \<and> A \<subseteq> T} = set ` lists T"
  using finite_list by (auto simp: lists_eq_set)

lemma countable_Collect_finite_subset:
  "countable T \<Longrightarrow> countable {A. finite A \<and> A \<subseteq> T}"
  unfolding Collect_finite_subset_eq_lists by auto

lemma countable_Fpow: "countable S \<Longrightarrow> countable (Fpow S)"
  using countable_Collect_finite_subset
  by (force simp add: Fpow_def conj_commute)

lemma countable_set_option [simp]: "countable (set_option x)"
  by (cases x) auto

subsection \<open>Misc lemmas\<close>

lemma countable_subset_image:
   "countable B \<and> B \<subseteq> (f ` A) \<longleftrightarrow> (\<exists>A'. countable A' \<and> A' \<subseteq> A \<and> (B = f ` A'))"
   (is "?lhs = ?rhs")
proof
  assume ?lhs
  show ?rhs
    by (rule exI [where x="inv_into A f ` B"])
      (use \<open>?lhs\<close> in \<open>auto simp: f_inv_into_f subset_iff image_inv_into_cancel inv_into_into\<close>)
next
  assume ?rhs
  then show ?lhs by force
qed

lemma ex_subset_image_inj:
   "(\<exists>T. T \<subseteq> f ` S \<and> P T) \<longleftrightarrow> (\<exists>T. T \<subseteq> S \<and> inj_on f T \<and> P (f ` T))"
  by (auto simp: subset_image_inj)

lemma all_subset_image_inj:
   "(\<forall>T. T \<subseteq> f ` S \<longrightarrow> P T) \<longleftrightarrow> (\<forall>T. T \<subseteq> S \<and> inj_on f T \<longrightarrow> P(f ` T))"
  by (metis subset_image_inj)

lemma ex_countable_subset_image_inj:
   "(\<exists>T. countable T \<and> T \<subseteq> f ` S \<and> P T) \<longleftrightarrow>
    (\<exists>T. countable T \<and> T \<subseteq> S \<and> inj_on f T \<and> P (f ` T))"
  by (metis countable_image_inj_eq subset_image_inj)

lemma all_countable_subset_image_inj:
   "(\<forall>T. countable T \<and> T \<subseteq> f ` S \<longrightarrow> P T) \<longleftrightarrow> (\<forall>T. countable T \<and> T \<subseteq> S \<and> inj_on f T \<longrightarrow>P(f ` T))"
  by (metis countable_image_inj_eq subset_image_inj)

lemma ex_countable_subset_image:
   "(\<exists>T. countable T \<and> T \<subseteq> f ` S \<and> P T) \<longleftrightarrow> (\<exists>T. countable T \<and> T \<subseteq> S \<and> P (f ` T))"
  by (metis countable_subset_image)

lemma all_countable_subset_image:
   "(\<forall>T. countable T \<and> T \<subseteq> f ` S \<longrightarrow> P T) \<longleftrightarrow> (\<forall>T. countable T \<and> T \<subseteq> S \<longrightarrow> P(f ` T))"
  by (metis countable_subset_image)

lemma countable_image_eq:
   "countable(f ` S) \<longleftrightarrow> (\<exists>T. countable T \<and> T \<subseteq> S \<and> f ` S = f ` T)"
  by (metis countable_image countable_image_inj_eq order_refl subset_image_inj)

lemma countable_image_eq_inj:
   "countable(f ` S) \<longleftrightarrow> (\<exists>T. countable T \<and> T \<subseteq> S \<and> f ` S = f ` T \<and> inj_on f T)"
  by (metis countable_image_inj_eq order_refl subset_image_inj)

lemma infinite_countable_subset':
  assumes X: "infinite X" shows "\<exists>C\<subseteq>X. countable C \<and> infinite C"
proof -
  obtain f :: "nat \<Rightarrow> 'a" where "inj f" "range f \<subseteq> X"
    using infinite_countable_subset [OF X] by blast
  then show ?thesis
    by (intro exI[of _ "range f"]) (auto simp: range_inj_infinite)
qed

lemma countable_all:
  assumes S: "countable S"
  shows "(\<forall>s\<in>S. P s) \<longleftrightarrow> (\<forall>n::nat. from_nat_into S n \<in> S \<longrightarrow> P (from_nat_into S n))"
  using S[THEN subset_range_from_nat_into] by auto

lemma finite_sequence_to_countable_set:
  assumes "countable X"
  obtains F where "\<And>i. F i \<subseteq> X" "\<And>i. F i \<subseteq> F (Suc i)" "\<And>i. finite (F i)" "(\<Union>i. F i) = X"
proof -
  show thesis
    apply (rule that[of "\<lambda>i. if X = {} then {} else from_nat_into X ` {..i}"])
       apply (auto simp add: image_iff intro: from_nat_into split: if_splits)
    using assms from_nat_into_surj by (fastforce cong: image_cong)
qed

lemma transfer_countable[transfer_rule]:
  "bi_unique R \<Longrightarrow> rel_fun (rel_set R) (=) countable countable"
  by (rule rel_funI, erule (1) bi_unique_rel_set_lemma)
     (auto dest: countable_image_inj_on)

subsection \<open>Uncountable\<close>

abbreviation uncountable where
  "uncountable A \<equiv> \<not> countable A"

lemma uncountable_def: "uncountable A \<longleftrightarrow> A \<noteq> {} \<and> \<not> (\<exists>f::(nat \<Rightarrow> 'a). range f = A)"
  by (auto intro: inj_on_inv_into simp: countable_def)
     (metis all_not_in_conv inj_on_iff_surj subset_UNIV)

lemma uncountable_bij_betw: "bij_betw f A B \<Longrightarrow> uncountable B \<Longrightarrow> uncountable A"
  unfolding bij_betw_def by (metis countable_image)

lemma uncountable_infinite: "uncountable A \<Longrightarrow> infinite A"
  by (metis countable_finite)

lemma uncountable_minus_countable:
  "uncountable A \<Longrightarrow> countable B \<Longrightarrow> uncountable (A - B)"
  using countable_Un[of B "A - B"] by auto

lemma countable_Diff_eq [simp]: "countable (A - {x}) = countable A"
  by (meson countable_Diff countable_empty countable_insert uncountable_minus_countable)

text \<open>Every infinite set can be covered by a pairwise disjoint family of infinite sets.
      This version doesn't achieve equality, as it only covers a countable subset\<close>
lemma infinite_infinite_partition:
  assumes "infinite A"
  obtains C :: "nat \<Rightarrow> 'a set"
    where "pairwise (\<lambda>i j. disjnt (C i) (C j)) UNIV" "(\<Union>i. C i) \<subseteq> A" "\<And>i. infinite (C i)"
proof -
  obtain f :: "nat\<Rightarrow>'a" where "range f \<subseteq> A" "inj f"
    using assms infinite_countable_subset by blast
  let ?C = "\<lambda>i. range (\<lambda>j. f (prod_encode (i,j)))"
  show thesis
  proof
    show "pairwise (\<lambda>i j. disjnt (?C i) (?C j)) UNIV"
      by (auto simp: pairwise_def disjnt_def inj_on_eq_iff [OF \<open>inj f\<close>] inj_on_eq_iff [OF inj_prod_encode, of _ UNIV])
    show "(\<Union>i. ?C i) \<subseteq> A"
      using \<open>range f \<subseteq> A\<close> by blast
    have "infinite (range (\<lambda>j. f (prod_encode (i, j))))" for i
      by (rule range_inj_infinite) (meson Pair_inject \<open>inj f\<close> inj_def prod_encode_eq)
    then show "\<And>i. infinite (?C i)"
      using that by auto
  qed
qed

end


(*<*)
theory sol03
imports "~~/src/HOL/IMP/BExp" "~~/src/HOL/IMP/ASM"
begin
(*>*)
text {* \ExerciseSheet{3}{29.~10.~2013} *}

text {* \Exercise{Relational @{text "aval"}}

  Theory @{text AExp} defines an evaluation function
  @{text "aval :: aexp \<Rightarrow> state \<Rightarrow> val"} for arithmetic expressions.
  Define a corresponding evaluation relation
  @{text "is_aval :: aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool"} as an inductive predicate:
*}

inductive is_aval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" (*<*)where
  "is_aval (N n) s n" |
  "s x = v \<Longrightarrow> is_aval (V x) s v" |
  "\<lbrakk>is_aval a1 s v1; is_aval a2 s v2; v'=v1+v2\<rbrakk> \<Longrightarrow> is_aval (Plus a1 a2) s v'"
(*>*)

text {* Use the introduction rules @{text is_aval.intros} to prove
  this example lemma. *}

lemma "is_aval (Plus (N 2) (Plus (V x) (N 3))) s (2 + (s x + 3))"
(*<*) by (auto intro!: is_aval.intros) (*>*)

text {* Prove that the evaluation relation @{text is_aval} agrees with
  the evaluation function @{text aval}. Show implications in both
  directions, and then prove the if-and-only-if form.
*}

lemma aval1: "is_aval a s v \<Longrightarrow> aval a s = v"
(*<*) by (induction rule: is_aval.induct) auto (*>*)

lemma aval2: "aval a s = v \<Longrightarrow> is_aval a s v"
(*<*) by (induction a arbitrary: v) (auto intro: is_aval.intros) (*>*)

theorem "is_aval a s v \<longleftrightarrow> aval a s = v"
(*<*)
proof
  assume "is_aval a s v" thus "aval a s = v" by (rule aval1)
next
  assume "aval a s = v" thus "is_aval a s v" by (rule aval2)
qed
(*>*)

(*<*)
(*The version without equality assumptions also works.*)
inductive is_aval' :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
  "is_aval' (N n) s n" |
  "is_aval' (V x) s (s x)" |
  "\<lbrakk>is_aval' a1 s v1; is_aval' a2 s v2\<rbrakk> \<Longrightarrow> is_aval' (Plus a1 a2) s (v1 + v2)"

lemma "is_aval' (Plus (V x) (Plus (V y) (N 3))) s (s x + (s y + 3))"
by (auto intro!: is_aval'.intros)

theorem "is_aval' a s v \<longleftrightarrow> aval a s = v"
  apply (rule iffI)
  apply (induction rule: is_aval'.induct)
  apply auto
  apply (induction a arbitrary: v)
  apply (auto intro: is_aval'.intros)
  done
(*>*)

text {* \Exercise{Avoiding Stack Underflow}*}

text {* A \emph{stack underflow} occurs when executing an instruction
  on a stack containing too few values -- e.g., executing an @{text ADD}
  instruction on an stack of size less than two. A well-formed sequence of
  instructions (e.g., one generated by @{text comp}) should never
  cause a stack underflow. *}

(* Alternative: functional solution: *)

text {*
  In this exercise, you will define a semantics for the
  stack-machine that throws an exception if the program underflows the stack.
*}

text {* Modify the @{text "exec1"} and @{text "exec"} - functions, such
  that they return an option value, @{text "None"} indicating a
  stack-underflow. *}
fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option"
(*<*)
where
"exec1 (LOADI n) _ stk  =  Some (n # stk)" |
"exec1 (LOAD x) s stk  =  Some (s(x) # stk)" |
"exec1  ADD _ stk  =  (
  if length (stk)\<ge>2 then
    Some ((hd2 stk + hd stk) # tl2 stk)
  else None)"
(*>*)

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option"
(*<*)
 where
"exec [] _ stk = Some stk" |
"exec (i#is) s stk = (case exec1 i s stk of
    Some stk \<Rightarrow> exec is s stk
  | None \<Rightarrow> None)"
(*>*)

text {*
  Now adjust the proof of theorem @{text "exec_comp"} to show that programs
  output by the compiler never underflow the stack:
*}
(*<*)
lemma exec_append[simp]:
  "exec (is1@is2) s stk = (case exec is1 s stk of
    Some stk \<Rightarrow> exec is2 s stk
  | None \<Rightarrow> None)"
apply(induction is1 arbitrary: stk)
apply (auto split: option.split)
done
(*>*)
theorem exec_comp: "exec (comp a) s stk = Some (aval a s # stk)"
(*<*)
apply(induction a arbitrary: stk)
apply (auto)
done
(*>*)

(*<*)
(* Alternative: Relational solution *)
text {*
  In this exercise, you will define a relational semantics for the
  stack-machine. The relation does not contain elements for programs causing
  a stack underflow.
*}

inductive execi1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack \<Rightarrow> bool" where
  "execi1 (LOADI n) s stk (n#stk)"
| "execi1 (LOAD x) s stk (s x#stk)"
| "execi1 (ADD) _ (v1#v2#stk) ((v1+v2)#stk)"

lemma
  assumes "execi1 i s stk stk'"
  shows "ASM.exec1 i s stk = stk'"
  using assms
  by induction auto

lemma
  assumes "ASM.exec1 i s stk = stk'"
  shows "execi1 i s stk stk'"
  nitpick
  oops

inductive execi :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack \<Rightarrow> bool" where
  "execi [] s stk stk"
| "\<lbrakk> execi1 i s stk stk2; execi is s stk2 stk' \<rbrakk> \<Longrightarrow> execi (i#is) s stk stk'"

lemma execi_appendI:
  assumes E1: "execi is1 s stk stk2" and E2: "execi is2 s stk2 stk'"
  shows "execi (is1@is2) s stk stk'"
  using E1 E2
  by (induction) (auto intro: execi.intros)

lemma execi_appendE[elim]:
  assumes "execi (is1@is2) s stk stk'"
  obtains stk2 where "execi is1 s stk stk2" and "execi is2 s stk2 stk'"
  using assms
  apply (induction is1 arbitrary: stk)
  apply (auto intro: execi.intros) []
  apply (erule execi.cases)
  apply (auto intro: execi.intros)
  (*apply (force intro: execi.intros elim!: execi.cases)*)
  done

lemma execi_sound:
  shows "execi (comp a) s stk (aval a s # stk)"
  apply (induction a arbitrary: stk)
  apply (auto
    intro!: execi.intros execi1.intros execi_appendI
    simp: add.commute)
  done

inductive_cases [elim!]:
  "execi [LOADI i] s stk stk'"
  "execi [LOAD x] s stk stk'"
  "execi [ADD] s stk stk'"
  "execi [] s stk stk'"

lemma execi_complete:
  assumes "execi (comp a) s stk stk'"
  shows "stk' = aval a s#stk"
  using assms
  apply (induction a arbitrary: s stk stk')
  apply (auto elim: execi1.cases)  [2]
  apply (fastforce elim: execi1.cases)
  done

theorem execi_correct:
  "execi (comp a) s stk stk' \<longleftrightarrow> (stk' = aval a s # stk)"
  using execi_sound execi_complete
  by blast
(*>*)

text {* \Exercise{Boolean If expressions}

We consider an alternative definition of boolean expressions, which
  feature a conditional construct: *}

datatype ifexp = Bc' bool | If ifexp ifexp ifexp | Less' aexp aexp

text {*
\begin{enumerate}
\item Define a function @{text ifval} analogous to @{const bval},
  which evaluates @{typ ifexp} expressions.

\item
Define a function @{term translate},
which translates @{typ ifexp}s to @{typ bexp}s.
  State and prove a lemma showing that the translation is correct.
\end{enumerate}
*}
(*<*)
primrec ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
"ifval (Bc' b) _ = b" |
"ifval (If b1 b2 b3) st = (if ifval b1 st then ifval b2 st else ifval b3 st)" |
"ifval (Less' a1 a2) st = (aval a1 st < aval a2 st)"

fun Or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"Or b1 b2 = Not (And (Not b1) (Not b2))"

fun If_bexp :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"If_bexp b1 b2 b3 = Or (And b1 b2) (And (Not b1) b3)"

primrec translate :: "ifexp \<Rightarrow> bexp" where
"translate (Bc' b) = (Bc b)" |
"translate (If b1 b2 b3) =
  If_bexp (translate b1) (translate b2) (translate b3)" |
"translate (Less' a1 a2) = Less a1 a2"

lemma translate_sound: "bval (translate exp) s = ifval exp s"
by (induction exp) auto
(*>*)

(*<*)
end
(*>*)


theory FiniteGraph
imports Main
begin

(*Lots of this theory is based on a work by Benedikt Nordhoff and Peter Lammich*)

section \<open>Specification of a finite directed graph\<close>

text\<open>A graph \<open>G=(V,E)\<close> consits of a set of vertices \<open>V\<close>, also called nodes,
       and a set of edges \<open>E\<close>. The edges are tuples of vertices. Both,
       the set of vertices and edges is finite.\<close>

(* Inspired by
Title: Dijkstra's Shortest Path Algorithm
Author: Benedikt Nordhoff and Peter Lammich
http://isa-afp.org/entries/Dijkstra_Shortest_Path.shtml
*)

section \<open>Graph\<close>
subsection\<open>Definitions\<close>
  text \<open>A graph is represented by a record.\<close>
  record 'v graph =
    nodes :: "'v set"
    edges :: "('v \<times>'v) set"

  text \<open>In a well-formed graph, edges only go from nodes to nodes.\<close>
  locale wf_graph =
    fixes G :: "'v graph"
    \<comment> \<open>Edges only reference to existing nodes\<close>
    assumes E_wf: "fst ` (edges G) \<subseteq> (nodes G)"
                     "snd ` (edges G) \<subseteq> (nodes G)"
    and finiteE: "finite (edges G)" (*implied by finiteV*)
    and finiteV: "finite (nodes G)"
  begin
    abbreviation "V \<equiv> (nodes G)"
    abbreviation "E \<equiv> (edges G)"

    lemma E_wfD2: "\<forall>e \<in> E. fst e \<in> V \<and> snd e \<in> V"
    by (auto simp add: E_wfD)
  end

subsection \<open>Basic operations on Graphs\<close>
  text \<open>The empty graph.\<close>
  definition empty :: "'v graph" where
    "empty \<equiv> \<lparr> nodes = {}, edges = {} \<rparr>"

  text \<open>Adds a node to a graph.\<close>
  definition add_node :: "'v \<Rightarrow> 'v graph \<Rightarrow> 'v graph" where
    "add_node v G \<equiv> \<lparr> nodes = ({v} \<union> (nodes G)), edges=edges G \<rparr>"

  text \<open>Deletes a node from a graph. Also deletes all adjacent edges.\<close>
  definition delete_node where "delete_node v G \<equiv> \<lparr>
      nodes = (nodes G) - {v},
      edges = {(e1, e2). (e1, e2) \<in> edges G \<and> e1 \<noteq> v \<and> e2 \<noteq> v}
    \<rparr>"

  text \<open>Adds an edge to a graph.\<close>
  definition add_edge where
  "add_edge v v' G = \<lparr>nodes = nodes G \<union> {v,v'}, edges = {(v, v')} \<union> edges G \<rparr>"

  text \<open>Deletes an edge from a graph.\<close>
  definition delete_edge where "delete_edge v v' G \<equiv> \<lparr>
      nodes = nodes G,
      edges = {(e1,e2). (e1, e2) \<in> edges G \<and> (e1,e2) \<noteq> (v,v')}
    \<rparr>"

  definition delete_edges::"'v graph \<Rightarrow> ('v \<times> 'v) set \<Rightarrow> 'v graph" where
    "delete_edges G es \<equiv> \<lparr>
      nodes = nodes G,
      edges = {(e1,e2). (e1, e2) \<in> edges G \<and> (e1,e2) \<notin> es}
    \<rparr>"

  fun delete_edges_list::"'v graph \<Rightarrow> ('v \<times> 'v) list \<Rightarrow> 'v graph" where
    "delete_edges_list G [] = G"|
    "delete_edges_list G ((v,v')#es) = delete_edges_list (delete_edge v v' G) es"

  definition fully_connected :: "'v graph \<Rightarrow> 'v graph" where
    "fully_connected G \<equiv> \<lparr>nodes = nodes G, edges = nodes G \<times> nodes G \<rparr>"

text \<open>Extended graph operations\<close>
  text \<open>Reflexive transitive successors of a node. Or: All reachable nodes for \<open>v\<close> including \<open>v\<close>.\<close>
  definition succ_rtran :: "'v graph \<Rightarrow> 'v \<Rightarrow> 'v set" where
    "succ_rtran G v = {e2. (v,e2) \<in> (edges G)\<^sup>*}"

  text \<open>Transitive successors of a node. Or: All reachable nodes for \<open>v\<close>.\<close>
  definition succ_tran :: "'v graph \<Rightarrow> 'v \<Rightarrow> 'v set" where
    "succ_tran G v = {e2. (v,e2) \<in> (edges G)\<^sup>+}"

  \<comment> \<open>succ_tran is always finite\<close>
  lemma succ_tran_finite: "wf_graph G \<Longrightarrow> finite (succ_tran G v)"
  proof -
    assume "wf_graph G"
    from wf_graph.finiteE[OF this] have "finite ((edges G)\<^sup>+)" using finite_trancl[symmetric, of "edges G"] by metis
    from this have "finite {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+}" by simp
    from this have finite: "finite (snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+})" by (metis finite_imageI)
    have "{(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+ \<and> e1 = v} \<subseteq> {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+}" by blast
    have 1: "snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+ \<and> e1 = v} \<subseteq> snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+}" by blast
    have 2: "snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+ \<and> e1 = v} = {e2. (v,e2) \<in> (edges G)\<^sup>+}" by force
    from 1 2 have "{e2. (v,e2) \<in> (edges G)\<^sup>+} \<subseteq> snd ` {(e1,e2). (e1, e2) \<in> (edges G)\<^sup>+}" by blast
    from this finite have "finite {e2. (v, e2) \<in> (edges G)\<^sup>+}" by (metis finite_subset)
    thus "finite (succ_tran G v)" using succ_tran_def by metis
  qed

  text\<open>If there is no edge leaving from \<open>v\<close>, then \<open>v\<close> has no successors\<close>
  lemma succ_tran_empty: "\<lbrakk> wf_graph G; v \<notin> (fst ` edges G) \<rbrakk> \<Longrightarrow> succ_tran G v = {}"
    unfolding succ_tran_def using image_iff tranclD by fastforce

  text\<open>@{const succ_tran} is subset of nodes\<close>
  lemma succ_tran_subseteq_nodes: "\<lbrakk> wf_graph G \<rbrakk> \<Longrightarrow> succ_tran G v \<subseteq> nodes G"
    unfolding succ_tran_def using tranclD2 wf_graph.E_wfD(2) by fastforce

  text \<open>The number of reachable nodes from \<open>v\<close>\<close>
  definition num_reachable :: "'v graph \<Rightarrow> 'v \<Rightarrow> nat" where
    "num_reachable G v = card (succ_tran G v)"

  definition num_reachable_norefl :: "'v graph \<Rightarrow> 'v \<Rightarrow> nat" where
    "num_reachable_norefl G v = card (succ_tran G v - {v})"

  text\<open>@{const card} returns @{term 0} for infinite sets.
        Here, for a well-formed graph, if @{const num_reachable} is zero, there are actually no nodes reachable.\<close>
  lemma num_reachable_zero: "\<lbrakk>wf_graph G; num_reachable G v = 0\<rbrakk> \<Longrightarrow> succ_tran G v = {}"
  unfolding num_reachable_def
  apply(subgoal_tac "finite (succ_tran G v)")
   apply(simp)
  apply(blast intro: succ_tran_finite)
  done
  lemma num_succtran_zero: "\<lbrakk>succ_tran G v = {}\<rbrakk> \<Longrightarrow> num_reachable G v = 0"
    unfolding num_reachable_def by simp
  lemma num_reachable_zero_iff: "\<lbrakk>wf_graph G\<rbrakk> \<Longrightarrow> (num_reachable G v = 0) \<longleftrightarrow> (succ_tran G v = {})"
  by(metis num_succtran_zero num_reachable_zero)

section\<open>Undirected Graph\<close>

subsection\<open>undirected graph simulation\<close>
  text \<open>Create undirected graph from directed graph by adding backward links\<close>

  definition backflows :: "('v \<times> 'v) set \<Rightarrow> ('v \<times> 'v) set" where
    "backflows E \<equiv> {(r,s). (s,r) \<in> E}"

  definition undirected :: "'v graph \<Rightarrow> 'v graph"
    where "undirected G = \<lparr> nodes = nodes G, edges = (edges G) \<union> {(b,a). (a,b) \<in> edges G} \<rparr>"

section \<open>Graph Lemmas\<close>

  lemma graph_eq_intro: "(nodes (G::'a graph) = nodes G') \<Longrightarrow> (edges G = edges G') \<Longrightarrow> G = G'" by simp

  \<comment> \<open>finite\<close>
  lemma wf_graph_finite_filterE: "wf_graph G \<Longrightarrow> finite {(e1, e2). (e1, e2) \<in> edges G \<and> P e1 e2}"
  by(simp add: wf_graph.finiteE split_def)
  lemma wf_graph_finite_filterV: "wf_graph G \<Longrightarrow> finite {n. n \<in> nodes G \<and> P n}"
  by(simp add: wf_graph.finiteV)

  \<comment> \<open>empty\<close>
  lemma empty_wf[simp]: "wf_graph empty"
    unfolding empty_def by unfold_locales auto
  lemma nodes_empty[simp]: "nodes empty = {}" unfolding empty_def by simp
  lemma edges_empty[simp]: "edges empty = {}" unfolding empty_def by simp

  \<comment> \<open>add node\<close>
  lemma add_node_wf[simp]: "wf_graph g \<Longrightarrow> wf_graph (add_node v g)"
    unfolding add_node_def wf_graph_def by (auto)

  lemma delete_node_wf[simp]: "wf_graph G \<Longrightarrow> wf_graph (delete_node v G)"
    by(auto simp add: delete_node_def wf_graph_def wf_graph_finite_filterE)

  \<comment> \<open>add edgde\<close>
  lemma add_edge_wf[simp]: "wf_graph G \<Longrightarrow> wf_graph (add_edge v v' G)"
    by(auto simp add: add_edge_def add_node_def wf_graph_def)

  \<comment> \<open>delete edge\<close>
  lemma delete_edge_wf[simp]: "wf_graph G \<Longrightarrow> wf_graph (delete_edge v v' G)"
    by(auto simp add: delete_edge_def add_node_def wf_graph_def split_def)

  \<comment> \<open>delte edges\<close>
  lemma delete_edges_list_wf[simp]: "wf_graph G \<Longrightarrow> wf_graph (delete_edges_list G E)"
    by(induction E arbitrary: G, simp, force)
  lemma delete_edges_wf[simp]: "wf_graph G \<Longrightarrow> wf_graph (delete_edges G E)"
    by(auto simp add: delete_edges_def add_node_def wf_graph_def split_def)
  lemma delete_edges_list_set: "delete_edges_list G E = delete_edges G (set E)"
    proof(induction E arbitrary: G)
    case Nil thus ?case by (simp add: delete_edges_def)
    next
    case (Cons e E) thus ?case by(cases e)(simp add: delete_edge_def delete_edges_def)
    qed
  lemma delete_edges_list_union: "delete_edges_list G (ff @ keeps) = delete_edges G (set ff \<union> set keeps)"
   by(simp add: delete_edges_list_set)
  lemma add_edge_delete_edges_list:
    "(add_edge (fst a) (snd a) (delete_edges_list G (a # ff))) = (add_edge (fst a) (snd a) (delete_edges G (set ff)))"
   by(auto simp add: delete_edges_list_set delete_edges_def add_edge_def add_node_def)
  lemma delete_edges_empty[simp]: "delete_edges G {} = G"
   by(simp add: delete_edges_def)
  lemma delete_edges_simp2: "delete_edges G E = \<lparr> nodes = nodes G, edges = edges G - E\<rparr>"
   by(auto simp add: delete_edges_def)
  lemma delete_edges_set_nodes: "nodes (delete_edges G E) = nodes G"
   by(simp add: delete_edges_simp2)
  lemma delete_edges_edges_mono: "E' \<subseteq> E \<Longrightarrow> edges (delete_edges G E) \<subseteq> edges (delete_edges G E')"
    by(simp add: delete_edges_def, fast)
  lemma delete_edges_edges_empty: "(delete_edges G (edges G)) = G\<lparr>edges := {}\<rparr>"
    by(simp add: delete_edges_simp2)

 \<comment> \<open>add delete\<close>
  lemma add_delete_edge: "wf_graph (G::'a graph) \<Longrightarrow> (a,b) \<in> edges G \<Longrightarrow> add_edge a b (delete_edge a b G) = G"
   apply(simp add: delete_edge_def add_edge_def wf_graph_def)
   apply(intro graph_eq_intro)
    by auto

  lemma add_delete_edges: "wf_graph (G::'v graph) \<Longrightarrow> (a,b) \<in> edges G \<Longrightarrow> (a,b) \<notin> fs \<Longrightarrow>
    add_edge a b (delete_edges G (insert (a, b) fs)) = (delete_edges G fs)"
    by(auto simp add: delete_edges_simp2 add_edge_def wf_graph_def)

 \<comment> \<open>fully_connected\<close>
  lemma fully_connected_simp: "fully_connected \<lparr>nodes = N, edges = ignore \<rparr>\<equiv> \<lparr>nodes = N, edges = N \<times> N \<rparr>"
    by(simp add: fully_connected_def)
  lemma fully_connected_wf: "wf_graph G \<Longrightarrow> wf_graph (fully_connected G)"
    by(simp add: fully_connected_def wf_graph_def)

 \<comment> \<open>succ_tran\<close>
 lemma succ_tran_mono:
  "wf_graph \<lparr>nodes=N, edges=E\<rparr> \<Longrightarrow> E' \<subseteq> E \<Longrightarrow> succ_tran \<lparr>nodes=N, edges=E'\<rparr> v \<subseteq> succ_tran \<lparr>nodes=N, edges=E\<rparr> v"
   apply(drule wf_graph.finiteE)
   apply(frule_tac A="E'" in rev_finite_subset, simp)
   apply(simp add: num_reachable_def)
   apply(simp add: succ_tran_def)
   apply(metis (lifting, full_types) Collect_mono trancl_mono)
  done

  \<comment> \<open>num_reachable\<close>
  lemma num_reachable_mono:
  "wf_graph \<lparr>nodes=N, edges=E\<rparr> \<Longrightarrow> E' \<subseteq> E \<Longrightarrow> num_reachable \<lparr>nodes=N, edges=E'\<rparr> v \<le> num_reachable \<lparr>nodes=N, edges=E\<rparr> v"
   apply(simp add: num_reachable_def)
   apply(frule_tac E'="E'" and v="v" in succ_tran_mono, simp)
   apply(frule_tac v="v" in succ_tran_finite)
   apply(simp add: card_mono)
  done

  \<comment> \<open>num_reachable_norefl\<close>
  lemma num_reachable_norefl_mono:
  "wf_graph \<lparr>nodes=N, edges=E\<rparr> \<Longrightarrow> E' \<subseteq> E \<Longrightarrow> num_reachable_norefl \<lparr>nodes=N, edges=E'\<rparr> v \<le> num_reachable_norefl \<lparr>nodes=N, edges=E\<rparr> v"
   apply(simp add: num_reachable_norefl_def)
   apply(frule_tac E'="E'" and v="v" in succ_tran_mono, simp)
   apply(frule_tac v="v" in succ_tran_finite)
   using card_mono by (metis Diff_mono finite_Diff subset_refl)

  \<comment> \<open>backflows\<close>
  lemma backflows_wf:
    "wf_graph \<lparr>nodes=N, edges=E\<rparr> \<Longrightarrow> wf_graph \<lparr>nodes=N, edges=backflows E\<rparr>"
    using [[simproc add: finite_Collect]] by(auto simp add: wf_graph_def backflows_def)
  lemma undirected_backflows:
    "undirected G = \<lparr> nodes = nodes G, edges = (edges G) \<union> backflows (edges G) \<rparr>"
    by(simp add: backflows_def undirected_def)
  lemma backflows_id:
    "backflows (backflows E) = E"
    by(simp add: backflows_def)

lemmas graph_ops=add_node_def delete_node_def add_edge_def delete_edge_def delete_edges_simp2

  \<comment> \<open>wf_graph\<close>
  lemma wf_graph_remove_edges: "wf_graph \<lparr> nodes = V, edges = E \<rparr> \<Longrightarrow> wf_graph \<lparr> nodes = V, edges=E - X\<rparr>"
    by (metis delete_edges_simp2 delete_edges_wf select_convs(1) select_convs(2))

  lemma wf_graph_remove_edges_union:
    "wf_graph \<lparr> nodes = V, edges = E \<union> E' \<rparr> \<Longrightarrow> wf_graph \<lparr> nodes = V, edges=E\<rparr>"
    by(auto simp add: wf_graph_def)

  lemma wf_graph_union_edges: "\<lbrakk> wf_graph \<lparr> nodes = V, edges = E \<rparr>; wf_graph \<lparr> nodes = V, edges=E'\<rparr> \<rbrakk> \<Longrightarrow>
     wf_graph \<lparr> nodes = V, edges=E \<union> E'\<rparr>"
    by(auto simp add: wf_graph_def)

  lemma wf_graph_add_subset_edges: "\<lbrakk> wf_graph \<lparr> nodes = V, edges = E \<rparr>; E' \<subseteq> E \<rbrakk> \<Longrightarrow>
     wf_graph \<lparr> nodes = V, edges= E \<union> E'\<rparr>"
    by(auto simp add: wf_graph_def) (metis rev_finite_subset)

(*Inspired by
Benedikt Nordhoff and Peter Lammich
Dijkstra's Shortest Path Algorithm
http://isa-afp.org/entries/Dijkstra_Shortest_Path.shtml*)
(*more a literal copy of http://isa-afp.org/browser_info/current/AFP/Dijkstra_Shortest_Path/Graph.html*)

  text \<open>Successors of a node.\<close>
  definition succ :: "'v graph \<Rightarrow> 'v \<Rightarrow> 'v set"
    where "succ G v \<equiv> {v'. (v,v')\<in>edges G}"

  lemma succ_finite[simp, intro]: "finite (edges G) \<Longrightarrow> finite (succ G v)"
    unfolding succ_def
    by (rule finite_subset[where B="snd`edges G"]) force+

  lemma succ_empty: "succ empty v = {}" unfolding empty_def succ_def by auto

  lemma (in wf_graph) succ_subset: "succ G v \<subseteq> V"
    unfolding succ_def using E_wf
    by (force)

end


theory Natural
  imports Main "~~/src/HOL/Eisbach/Eisbach_Tools"
begin

lemma give: "P \<Longrightarrow> (P \<Longrightarrow> Q) \<Longrightarrow> Q" by simp
lemma take: "(P \<Longrightarrow> Q) \<Longrightarrow> P \<Longrightarrow> Q" by simp
method gives for t :: bool = rule give[of t]
method takes for t :: bool = rule take[of t]
method give for t :: bool methods how = (gives t, (how ; fail)[1])
method take for t :: bool methods how = (takes t, (how ; fail)[1])

-- "Natural numbers, starting from 1"

datatype natural = one | succ natural

fun add_nat where
  "add_nat one n = succ n" |
  "add_nat (succ n) m = succ (add_nat n m)"

lemma add_nat_associative: "add_nat (add_nat a b) c = add_nat a (add_nat b c)"
  by (induction a b rule: add_nat.induct, auto)

instantiation natural :: one begin
definition "one_natural = one"
declare one_natural_def [simp]
instance by standard end

instantiation natural :: semigroup_add begin
definition "plus_natural = add_nat"
declare plus_natural_def [simp]
instance
  apply standard
  apply simp
  using add_nat_associative apply assumption
  done
end

instantiation natural :: numeral begin
instance by standard end

instantiation natural :: ord begin

fun less_natural where
  "less_natural one (succ _) = True" |
  "less_natural (succ a) (succ b) = less_natural a b" |
  "less_natural _ _ = False"

fun less_eq_natural where
  "less_eq_natural one _ = True" |
  "less_eq_natural (succ a) (succ b) = less_eq_natural a b" |
  "less_eq_natural _ _ = False"

instance by standard end

instantiation natural :: linorder begin
instance proof
  fix x y z :: natural
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (induction x y rule: less_natural.induct, auto)
  show "x \<le> x"
    by (induction x, auto)
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    apply (induction x y arbitrary: z rule: less_eq_natural.induct, auto)
    apply (metis Natural.natural.distinct(1) Natural.natural.inject less_eq_natural.elims(2) less_eq_natural.elims(3))
    done
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    apply (induction x y arbitrary: z rule: less_eq_natural.induct, auto)
    using less_eq_natural.elims(2) apply blast
    done
  show "x \<le> y \<or> y \<le> x"
    by (induction x y arbitrary: z rule: less_eq_natural.induct, auto)
qed
end

fun to_builtin_nat where
  "to_builtin_nat one = Suc 0" |
  "to_builtin_nat (succ n) = Suc (to_builtin_nat n)"

fun mul_nat where
  "mul_nat one n = n" |
  "mul_nat (succ n) m = add_nat m (mul_nat n m)"

fun succ_abs_diff_nat where
  "succ_abs_diff_nat one one = one" |
  "succ_abs_diff_nat one (succ b) = succ b" |
  "succ_abs_diff_nat (succ a) one = succ a" |
  "succ_abs_diff_nat (succ a) (succ b) = succ_abs_diff_nat a b"

lemma diff_commute: "succ_abs_diff_nat a b = succ_abs_diff_nat b a"
  by (induction a b rule: succ_abs_diff_nat.induct, auto)

lemma less_succ_self [simp]: "a < succ a"
  by (induction a "succ a" rule: less_natural.induct, auto)

lemma less_succ: "a < b \<Longrightarrow> a < succ b"
  by (induction a b rule: less_natural.induct, auto)

lemma diff_inc: "succ_abs_diff_nat a b = succ_abs_diff_nat (succ a) (succ b)"
  by simp

lemma le_inc: "a < b \<Longrightarrow> a < succ b"
  by (induction a b rule: less_natural.induct, auto)

lemma "a < b \<Longrightarrow> succ_abs_diff_nat a b = succ c \<Longrightarrow> c < b"
proof (induction a b arbitrary: c rule: succ_abs_diff_nat.induct)
  fix a b c
  assume IH: "\<And>c. a < b \<Longrightarrow> succ_abs_diff_nat a b = succ c \<Longrightarrow> c < b"
  assume "succ a < succ b"
  then have "a < b" by simp
  then have "succ_abs_diff_nat a b = succ c \<Longrightarrow> c < b" using IH by blast
  then show "succ_abs_diff_nat (succ a) (succ b) = succ c \<Longrightarrow> c < succ b"
    using diff_inc le_inc by simp
qed simp+

lemma add_nat_commutative: "add_nat a b = add_nat b a"
proof (induction a b rule: add_nat.induct)
  fix n
  show "add_nat one n = add_nat n one"
  proof (simp, induction n one rule: add_nat.induct)
    show "succ one = add_nat one one" by simp
    fix n
    assume "succ n = add_nat n one"
    then have "succ (succ n) = succ (add_nat n one)" by simp
    then show "succ (succ n) = add_nat (succ n) one"
      by (simp add: \<open>succ (succ n) = succ (add_nat n one)\<close>)
  qed
next
  fix n m
  assume IH: "add_nat n m = add_nat m n"
  have "succ (add_nat m n) = add_nat m (succ n)"
    by (induction m n rule: add_nat.induct, auto)
  then show "add_nat (succ n) m = add_nat m (succ n)" using IH by simp
qed

lemma diff_res2: "succ_abs_diff_nat a b = c \<Longrightarrow> add_nat c a = succ b \<or> add_nat c b = succ a"
  apply (induction a b rule: succ_abs_diff_nat.induct)
  apply (auto simp add: add_nat_commutative)
  done

fun leftover_nat where
  "leftover_nat one one _ _ = undefined" |
  "leftover_nat (succ a) one _ d = leftover_nat a d a d" |
  "leftover_nat one (succ a) c _ = c" |
  "leftover_nat (succ a) (succ b) c d = leftover_nat a b c d"

definition "uncurry f ab = f (fst ab, snd ab)"
declare uncurry_def [simp]

lemma max_cod: "max a b = c \<Longrightarrow> a = c \<or> b = c"
  by (metis max_def)

lemma lt_imp_le_nat: "(a :: natural) < b \<Longrightarrow> a \<le> b"
  by (induction a b rule: less_natural.induct, auto)

lemma max_res: "(a :: natural) < b \<Longrightarrow> max a b = b"
  by (simp add: lt_imp_le_nat max_absorb2)

lemma to_builtin_nat_zero [simp]: "0 < to_builtin_nat a"
  by (cases a; auto)

lemma lt_nats: "a < b \<Longrightarrow> to_builtin_nat a < to_builtin_nat b"
  by (induction a b rule: less_natural.induct; auto)

lemma diff_eq [simp]: "succ_abs_diff_nat a a = one"
  by (induction a, auto)

lemma diff_res [simp]:
  "a < b \<Longrightarrow> succ_abs_diff_nat a b = c \<Longrightarrow> add_nat a c = succ b"
  by (induction a b arbitrary: c rule: succ_abs_diff_nat.induct, auto)

lemma diff_one [simp]: "succ_abs_diff_nat one a = a"
  by (induction a, auto)

lemma "or_split": "(C \<Longrightarrow> P) \<Longrightarrow> (\<not>C \<Longrightarrow> Q) \<Longrightarrow> P \<or> Q" by auto

lemma lt_eq_gt_complete_nat:
  "((a :: natural) < b \<Longrightarrow> P) \<Longrightarrow> (a = b \<Longrightarrow> P) \<Longrightarrow> (a > b \<Longrightarrow> P) \<Longrightarrow> P"
  using not_less_iff_gr_or_eq by blast

lemma add_nat_res_gt: "add_nat a b = c \<Longrightarrow> a < c &&& b < c"
  by (induction a b arbitrary: c rule: add_nat.induct, auto simp add: less_succ)

function (sequential) gcd_nat where
  "gcd_nat one b = one" |
  "gcd_nat a one = one" |
  "gcd_nat a b = (case succ_abs_diff_nat a b of
    one \<Rightarrow> a |
    succ c \<Rightarrow> if a < b then gcd_nat a c else gcd_nat b c)"
by (pat_completeness, auto)
termination
proof (relation "measure (\<lambda>(a,b). to_builtin_nat (max a b))", auto)
  fix a b c :: natural
  assume diff: "succ_abs_diff_nat a b = succ c"
  assume alt: "a < b"
  from diff alt have clt: "c < b"
    apply (induction a b arbitrary: c rule: succ_abs_diff_nat.induct)
    apply (auto simp add: less_succ) done
  from alt clt have l: "max (succ a) c < succ b"
    by (metis less_natural.simps(2) less_succ max_cod)
  from alt have "succ a < succ b" by simp
  then have r: "max (succ a) (succ b) = succ b" by (rule max_res)
  show "to_builtin_nat (max (succ a) c) < to_builtin_nat (max (succ a) (succ b))"
    using l r lt_nats by fastforce
next
  fix a b c :: natural
  assume c: "succ_abs_diff_nat a b = succ c"
  assume ge: "\<not>(a < b)"
  have "max (succ b) c < max (succ a) (succ b)"
  proof (rule lt_eq_gt_complete_nat[of a b])
    assume "a < b"
    then have "False" using ge by simp
    then show ?thesis by simp
  next
    assume "a = b"
    then show ?thesis using c by simp
  next
    assume gt: "a > b"
    then have sum: "add_nat b c = a"
      by (metis diff_commute natural.inject add_nat.simps(2) add_nat_commutative c diff_res)
    from gt have nle: "\<not>(a \<le> b)" by simp
    have r: "max (succ a) (succ b) = succ a"
      by (subst max_def, auto simp add: nle)
    from sum have "c < succ a" using add_nat_res_gt less_succ by blast
    show ?thesis by (subst r, auto simp add: gt \<open>c < succ a\<close>)
  qed
  then show "to_builtin_nat (max (succ b) c)
             < to_builtin_nat (max (succ a) (succ b))"
    using lt_nats by force
qed

value "gcd_nat 3 2"
value "succ_abs_diff_nat 3 2"

fun succ_diff_nat where
  "succ_diff_nat a one = a" |
  "succ_diff_nat one b = one" |
  "succ_diff_nat (succ a) (succ b) = succ_diff_nat a b"

lemma add_one_nat [simp]: "add_nat a one = succ a"
  by (simp add: add_nat_commutative)

lemma add_succ_nat [simp]: "add_nat a (succ b) = succ (add_nat a b)"
  by (induction a "succ b" rule: add_nat.induct, auto)

lemma diff_sum: "(succ_diff_nat a b = succ c) = (c + b = a)"
  by (induction a b arbitrary: c rule: succ_diff_nat.induct; simp; blast)

lemma diff_lt: "(succ_diff_nat a b = succ c) \<Longrightarrow> c < a"
  by (induction a b arbitrary: c rule: succ_diff_nat.induct, auto simp add: less_succ)

definition pred_nat :: "(natural \<times> natural) set" where
  "pred_nat = {(m, n). n = succ m}"

definition less_than :: "(natural \<times> natural) set"
  where "less_than = pred_nat\<^sup>+"

definition measure :: "('a \<Rightarrow> natural) \<Rightarrow> ('a \<times> 'a) set"
  where "measure = inv_image less_than"

lemma wf_pred_nat: "wf pred_nat"
  apply (unfold wf_def pred_nat_def)
  apply clarify
  apply (induct_tac x)
   apply blast+
  done

lemma wf_less_than [iff]: "wf less_than"
  by (simp add: less_than_def wf_pred_nat [THEN wf_trancl])

lemma wf_measure [iff]: "wf (measure f)"
  unfolding measure_def
  by (rule wf_less_than [THEN wf_inv_image])

function div_nat where
  "div_nat a b = (case succ_diff_nat a b of
    one \<Rightarrow> one |
    succ c \<Rightarrow> succ (div_nat c b))"
  by auto
termination
proof (relation "measure (\<lambda>(a, _) \<Rightarrow> a)")
  show "wf (Natural.measure (\<lambda>x. case x of (a, x) \<Rightarrow> a))"
    by blast
  fix a b c
  assume diff: "succ_diff_nat a b = succ c"
  then have "c < a"
    by (induction a b arbitrary: c rule: succ_diff_nat.induct, auto simp: less_succ)
  from diff have "((\<lambda>x xa. xa = succ x) ^^ to_builtin_nat b) c a"
  proof (induction b arbitrary: a)
    fix a
    assume "succ_diff_nat a one = succ c"
    then show "((\<lambda>x xa. xa = succ x) ^^ to_builtin_nat one) c a" by auto
  next
    fix b a
    assume IH: "(\<And>a. succ_diff_nat a b = succ c \<Longrightarrow>
                ((\<lambda>x xa. xa = succ x) ^^ to_builtin_nat b) c a)"
    assume assm: "succ_diff_nat a (succ b) = succ c"
    then obtain d where d: "a = succ d" by (cases a, auto)
    from d assm have "succ_diff_nat d b = succ c" by force
    then have "((\<lambda>x xa. xa = succ x) ^^ to_builtin_nat b) c d" using IH by blast
    then show "((\<lambda>x xa. xa = succ x) ^^ to_builtin_nat (succ b)) c a"
      by (auto simp: funpow_Suc_right d)
  qed
  then show "((c, b), a, b) \<in> measure (\<lambda>x. case x of (a, x) \<Rightarrow> a)"
    apply (simp add: measure_def less_than_def pred_nat_def trancl_def)
    apply (subst tranclp_power)
    apply (rule exI[of _ "to_builtin_nat b"])
    apply (simp)
    done
qed

lemma div_one [simp]: "div_nat_h a one one = a"
  apply (induction a one one rule: div_nat.induct, auto)

lemma mul_one [simp]: "mul_nat a one = a"
  by (induction a, auto)

lemma mul_succ [simp]: "mul_nat a (succ b) = add_nat a (mul_nat a b)"
  apply (induction a "succ b" rule: mul_nat.induct)
   apply (auto)
  using add_nat_associative add_nat_commutative apply auto
  done

lemma mul_commute_nat: "mul_nat a b = mul_nat b a"
  by (induction a b rule: mul_nat.induct, auto)

definition "divides_nat a b = (\<exists>c. mul_nat a c = b)"

lemma mul_div_nat: "divides_nat a b \<Longrightarrow> mul_nat a (div_nat b a) = b"
proof (induction a "div_nat a b" arbitrary: b rule: mul_nat.induct, auto)
  show base: "mul_nat one (div_nat b one) = b" by simp
  fix a
  assume IH: "divides_nat a b \<Longrightarrow> mul_nat a (div_nat b a) = b"

lemma mul_div_commute_nat:
  "divides_nat c b \<Longrightarrow> mul_nat a (div_nat b c) = div_nat (mul_nat a b) c" (is "_ \<Longrightarrow> ?a = ?b")
proof -
  assume hyp: "divides_nat c b"

(*
lemma "gcd_nat a b = c \<Longrightarrow> mul_nat a (div_nat b c) = mul_nat (div_nat a c) b"
proof (induction a b arbitrary: c rule: gcd_nat.induct, simp, simp)
  fix a b c
  assume IH:
    "\<And>d e. succ_abs_diff_nat (succ a)
            (succ b) =
           succ d \<Longrightarrow>
           succ a < succ b \<Longrightarrow>
           gcd_nat (succ a) d = e \<Longrightarrow>
           mul_nat (succ a) (div_nat d e) =
           mul_nat (div_nat (succ a) e) d"
    "\<And>d e. succ_abs_diff_nat (succ a)
            (succ b) =
           succ d \<Longrightarrow>
           \<not> succ a < succ b \<Longrightarrow>
           gcd_nat (succ b) d = e \<Longrightarrow>
           mul_nat (succ b) (div_nat d e) =
           mul_nat (div_nat (succ b) e) d"
  assume c: "gcd_nat (succ a) (succ b) = c"
  obtain sd where sd: "succ_abs_diff_nat (succ a) (succ b) = sd" by simp
  show "mul_nat (succ a) (div_nat (succ b) c) =
        mul_nat (div_nat (succ a) c) (succ b)" *)

end


(*
    $Id: ex.thy,v 1.2 2004/11/23 15:14:34 webertj Exp $
    Author: Gerwin Klein
*)

header {* Quantifying Lists *}

(*<*) theory ex imports Main begin (*>*)

text {* Define a universal and an existential quantifier on lists
using primitive recursion.  Expression @{term "alls P xs"} should
be true iff @{term "P x"} holds for every element @{term x} of
@{term xs}, and @{term "exs P xs"} should be true iff @{term "P x"}
holds for some element @{term x} of @{term xs}.
*}

consts
  alls :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
  exs  :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"

text {*
Prove or disprove (by counterexample) the following theorems.
You may have to prove some lemmas first.

Use the @{text "[simp]"}-attribute only if the equation is truly a
simplification and is necessary for some later proof.
*}

lemma "alls (\<lambda>x. P x \<and> Q x) xs = (alls P xs \<and> alls Q xs)"
(*<*)oops(*>*)

lemma "alls P (rev xs) = alls P xs"
(*<*)oops(*>*)

lemma "exs (\<lambda>x. P x \<and> Q x) xs = (exs P xs \<and> exs Q xs)"
(*<*)oops(*>*)

lemma "exs P (map f xs) = exs (P o f) xs"
(*<*)oops(*>*)

lemma "exs P (rev xs) = exs P xs"
(*<*)oops(*>*)

text {* Find a (non-trivial) term @{text Z} such that the following equation holds: *}

lemma "exs (\<lambda>x. P x \<or> Q x) xs = Z"
(*<*)oops(*>*)

text {* Express the existential via the universal quantifier --
@{text exs} should not occur on the right-hand side: *}

lemma "exs P xs = Z"
(*<*)oops(*>*)

text {*
Define a primitive-recursive function @{term "is_in x xs"} that
checks if @{term x} occurs in @{term xs}. Now express
@{text is_in} via @{term exs}:
*}

lemma "is_in a xs = Z"
(*<*)oops(*>*)

text {* Define a primitive-recursive function @{term "nodups xs"}
that is true iff @{term xs} does not contain duplicates, and a
function @{term "deldups xs"} that removes all duplicates.  Note
that @{term "deldups[x,y,x]"} (where @{term x} and @{term y} are
distinct) can be either @{term "[x,y]"} or @{term "[y,x]"}.

Prove or disprove (by counterexample) the following theorems.
*}

lemma "length (deldups xs) <= length xs"
(*<*)oops(*>*)

lemma "nodups (deldups xs)"
(*<*)oops(*>*)

lemma "deldups (rev xs) = rev (deldups xs)"
(*<*)oops(*>*)

(*<*) end (*>*)


theory MyTree

  imports Main

begin

  (* declare [[names_short]] *)

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

  (*
Exercise 2.6.
Starting from the type 'a tree defined in the text, define a function
contents :: 'a tree \<Rightarrow> 'a list that collects all values in a tree in a list,
in any order, without removing duplicates.
Then define a function
treesum :: nat tree \<Rightarrow> nat
that sums up all values in a tree of natural numbers and prove
treesum t = listsum (contents t)
  *)

fun contents :: "'a tree \<Rightarrow> 'a list" where
  "contents Tip = Nil" |
  "contents (Node l x r) = (contents l) @ (x # (contents r))"

fun treesum :: "nat tree \<Rightarrow> nat" where
  "treesum Tip = 0" |
  "treesum (Node l x r) = (treesum l) + x + (treesum r)"

fun listsum :: "nat list \<Rightarrow> nat" where
  "listsum [] = 0" |
  "listsum (x # xs) = x + (listsum xs)"

lemma l0 [simp] : "listsum(xs @ ys) = (listsum xs) + (listsum ys)"
  apply(induction xs)
   apply(auto)
  done

theorem treesum_is_listsum_of_contents: "treesum t = listsum (contents t)"
  apply(induction t)
   apply(auto)
  done


section "General VS Proofs"
subsection "Univariate Atoms"
theory UniAtoms
  imports Debruijn
begin

datatype atomUni = LessUni "real * real * real" | EqUni "real * real * real" | LeqUni "real * real * real" | NeqUni "real * real * real"
datatype (atoms: 'a) fmUni =
  TrueFUni | FalseFUni | AtomUni 'a | AndUni "'a fmUni" "'a fmUni" | OrUni "'a fmUni" "'a fmUni"

fun aEvalUni :: "atomUni \<Rightarrow> real \<Rightarrow> bool" where
  "aEvalUni (EqUni (a,b,c)) x = (a*x^2+b*x+c = 0)" |
  "aEvalUni (LessUni (a,b,c)) x = (a*x^2+b*x+c < 0)" |
  "aEvalUni (LeqUni (a,b,c)) x = (a*x^2+b*x+c \<le> 0)" |
  "aEvalUni (NeqUni (a,b,c)) x = (a*x^2+b*x+c \<noteq> 0)"

fun aNegUni :: "atomUni \<Rightarrow> atomUni" where
  "aNegUni (LessUni (a,b,c)) = LeqUni (-a,-b,-c)" |
  "aNegUni (EqUni p) = NeqUni p" |
  "aNegUni (LeqUni (a,b,c)) = LessUni (-a,-b,-c)" |
  "aNegUni (NeqUni p) = EqUni p"

fun evalUni :: "atomUni fmUni \<Rightarrow> real \<Rightarrow> bool" where
  "evalUni (AtomUni a) x = aEvalUni a x" |
  "evalUni (TrueFUni) _ = True" |
  "evalUni (FalseFUni) _ = False" |
  "evalUni (AndUni \<phi> \<psi>) x = ((evalUni \<phi> x) \<and> (evalUni \<psi> x))" |
  "evalUni (OrUni \<phi> \<psi>) x = ((evalUni \<phi> x) \<or> (evalUni \<psi> x))"

fun negUni :: "atomUni fmUni \<Rightarrow> atomUni fmUni" where
  "negUni (AtomUni a) = AtomUni(aNegUni a)" |
  "negUni (TrueFUni) = FalseFUni" |
  "negUni (FalseFUni) = TrueFUni" |
  "negUni (AndUni \<phi> \<psi>) = (OrUni (negUni \<phi>) (negUni \<psi>))" |
  "negUni (OrUni \<phi> \<psi>) = (AndUni (negUni \<phi>) (negUni \<psi>))"

fun convert_poly :: "nat \<Rightarrow> real mpoly \<Rightarrow> real list \<Rightarrow> (real * real * real) option" where
  "convert_poly var p xs = (
  if MPoly_Type.degree p var < 3
  then let (A,B,C) = get_coeffs var p in Some(insertion (nth_default 0 (xs)) A,insertion (nth_default 0 (xs)) B,insertion (nth_default 0 (xs)) C)
 else None)"

fun convert_atom :: "nat \<Rightarrow> atom \<Rightarrow> real list \<Rightarrow> atomUni option" where
  "convert_atom var (Less p) xs = map_option LessUni (convert_poly var p xs)"|
  "convert_atom var (Eq p) xs = map_option EqUni (convert_poly var p xs)"|
  "convert_atom var (Leq p) xs = map_option LeqUni (convert_poly var p xs)"|
  "convert_atom var (Neq p) xs = map_option NeqUni (convert_poly var p xs)"

lemma convert_atom_change :
  assumes "length xs' = var"
  shows "convert_atom var At (xs' @ x # \<Gamma>) = convert_atom var At (xs' @ x' # \<Gamma>)"
  apply(cases At)using assms apply simp_all
  by (metis insertion_lowerPoly1 not_in_isovarspar)+

lemma degree_convert_eq :
  assumes "convert_poly var p xs = Some(a)"
  shows "MPoly_Type.degree p var < 3"
  using assms apply(cases "MPoly_Type.degree p var < 3") by auto

lemma poly_to_univar :
  assumes "MPoly_Type.degree p var < 3"
  assumes "get_coeffs var p = (A,B,C)"
  assumes "a = insertion (nth_default 0 (xs'@y#xs)) A"
  assumes "b = insertion (nth_default 0 (xs'@y#xs)) B"
  assumes "c = insertion (nth_default 0 (xs'@y#xs)) C"
  assumes "length xs' = var"
  shows "insertion (nth_default 0 (xs'@x#xs)) p = (a*x^2)+(b*x)+c"
proof-
  have ha: "\<And>x. a = insertion (nth_default 0 (xs'@x # xs)) A" using assms(2) apply auto
    by (metis assms(3) assms(6) insertion_lowerPoly1 not_in_isovarspar)
  have hb: "\<And>x. b = insertion (nth_default 0 (xs'@x # xs)) B" using assms(2) apply auto
    by (metis assms(4) assms(6) insertion_lowerPoly1 not_in_isovarspar)
  have hc: "\<And>x. c = insertion (nth_default 0 (xs'@x # xs)) C" using assms(2) apply auto
    by (metis assms(5) assms(6) insertion_lowerPoly1 not_in_isovarspar)
  show ?thesis
  proof(cases "MPoly_Type.degree p var = 0")
    case True
    have h1 : "var < length (xs'@x#xs)" using assms by auto
    show ?thesis using assms ha hb hc sum_over_degree_insertion[OF h1 True, of y] apply(simp add: isovar_greater_degree[of p ] True)
      using True degree0isovarspar by force
  next
    case False
    then have notzero : "MPoly_Type.degree p var \<noteq> 0" by auto
    show ?thesis proof(cases "MPoly_Type.degree p var = 1" )
      case True
      have h1 : "var < length (xs'@x#xs)" using assms by auto
      show ?thesis using  sum_over_degree_insertion[OF h1 True, of x,  symmetric] unfolding assms(6)[symmetric] list_update_length unfolding assms(6) apply simp using ha hb hc assms apply auto
        by (smt (verit, ccfv_threshold) One_nat_def True express_poly h1 insertion_add insertion_mult insertion_pow insertion_var list_update_length)
    next
      case False
      then have deg2 : "MPoly_Type.degree p var = 2" using notzero assms by auto
      have h1 : "var < length (xs'@x#xs)" using assms by auto
      have two : "2 = Suc(Suc 0)" by auto
      show ?thesis
        using  sum_over_degree_insertion[OF h1 deg2, of x,  symmetric] unfolding assms(6)[symmetric] list_update_length unfolding assms(6) two apply simp using ha hb hc assms apply auto
        using deg2 express_poly h1 insertion_add insertion_mult insertion_pow insertion_var list_update_length
        by (smt (verit, best) numeral_2_eq_2)
    qed
  qed
qed

lemma "aEval_aEvalUni":
  assumes "convert_atom var a (xs'@x#xs) = Some a'"
  assumes "length xs' = var"
  shows "aEval a (xs'@x#xs) = aEvalUni a' x"
proof(cases a)
  case (Less x)
  then show ?thesis
  proof(cases "MPoly_Type.degree x var < 3")
    case True
    then show ?thesis
      using assms apply(simp add:Less)
      using poly_to_univar[OF True]
      by (metis One_nat_def aEvalUni.simps(2) get_coeffs.elims)
  next
    case False
    then show ?thesis using assms Less by auto
  qed
next
  case (Eq x)
  then show ?thesis
  proof(cases "MPoly_Type.degree x var < 3")
    case True
    then show ?thesis
      using assms apply(simp add:Eq)
      using poly_to_univar[OF True]
      by (metis One_nat_def aEvalUni.simps(1) get_coeffs.elims)
  next
    case False
    then show ?thesis using assms Eq by auto
  qed
next
  case (Leq x)
  then show ?thesis
  proof(cases "MPoly_Type.degree x var < 3")
    case True
    then show ?thesis
      using assms apply(simp add:Leq)
      using poly_to_univar[OF True]
      by (metis One_nat_def aEvalUni.simps(3) get_coeffs.elims)
  next
    case False
    then show ?thesis using assms Leq by auto
  qed
next
  case (Neq x)
  then show ?thesis
  proof(cases "MPoly_Type.degree x var < 3")
    case True
    then show ?thesis
      using assms apply(simp add:Neq)
      using poly_to_univar[OF True]
      by (metis One_nat_def aEvalUni.simps(4) get_coeffs.elims)
  next
    case False
    then show ?thesis using assms Neq by auto
  qed
qed

fun convert_fm :: "nat \<Rightarrow> atom fm \<Rightarrow> real list \<Rightarrow> (atomUni fmUni) option" where
  "convert_fm var (Atom a) \<Gamma> = map_option (AtomUni) (convert_atom var a \<Gamma>)" |
  "convert_fm var (TrueF) _ = Some TrueFUni" |
  "convert_fm var (FalseF) _ = Some FalseFUni" |
  "convert_fm var (And \<phi> \<psi>) \<Gamma> = (case ((convert_fm var \<phi> \<Gamma>),(convert_fm var \<psi> \<Gamma>)) of (Some a, Some b) \<Rightarrow> Some (AndUni a b) | _ \<Rightarrow> None)" |
  "convert_fm var (Or \<phi> \<psi>) \<Gamma> = (case ((convert_fm var \<phi> \<Gamma>),(convert_fm var \<psi> \<Gamma>)) of (Some a, Some b) \<Rightarrow> Some (OrUni a b) | _ \<Rightarrow> None)" |
  "convert_fm var (Neg \<phi>) \<Gamma> = None " |
  "convert_fm var (ExQ \<phi>) \<Gamma> = None" |
  "convert_fm var (AllQ \<phi>) \<Gamma> = None"|
  "convert_fm var (AllN i \<phi>) \<Gamma> = None"|
  "convert_fm var (ExN i \<phi>) \<Gamma> = None"

lemma "eval_evalUni":
  assumes "convert_fm var F (xs'@x#xs) = Some F'"
  assumes "length xs' = var"
  shows "eval F (xs'@x#xs) = evalUni F' x"
  using assms
proof(induction F arbitrary: F')
  case TrueF
  then show ?case by auto
next
  case FalseF
  then show ?case by auto
next
  case (Atom x)
  then show ?case using aEval_aEvalUni by auto
next
  case (And F1 F2)
  then show ?case apply(cases "convert_fm var F1 (xs'@x#xs)") apply simp apply(cases "convert_fm var F2 (xs'@x#xs)") by auto
next
  case (Or F1 F2)
  then show ?case apply(cases "convert_fm var F1 (xs'@x#xs)") apply simp apply(cases "convert_fm var F2 (xs'@x#xs)") by auto
next
  case (Neg F)
  then show ?case by auto
next
  case (ExQ F)
  then show ?case by auto
next
  case (AllQ F)
  then show ?case by auto
next
  case (ExN x1 \<phi>)
  then show ?case by auto
next
  case (AllN x1 \<phi>)
  then show ?case by auto
qed

fun grab_atoms :: "nat \<Rightarrow> atom fm \<Rightarrow> atom list option" where
  "grab_atoms var TrueF = Some([])" |
  "grab_atoms var FalseF = Some([])" |
  "grab_atoms var (Atom(Eq p)) = (if MPoly_Type.degree p var < 3 then (if MPoly_Type.degree p var > 0 then Some([Eq p]) else Some([])) else None)"|
  "grab_atoms var (Atom(Less p)) = (if MPoly_Type.degree p var < 3 then (if MPoly_Type.degree p var > 0 then Some([Less p]) else Some([])) else None)"|
  "grab_atoms var (Atom(Leq p)) = (if MPoly_Type.degree p var < 3 then (if MPoly_Type.degree p var > 0 then Some([Leq p]) else Some([])) else None)"|
  "grab_atoms var (Atom(Neq p)) = (if MPoly_Type.degree p var < 3 then (if MPoly_Type.degree p var > 0 then Some([Neq p]) else Some([])) else None)"|
  "grab_atoms var (And a b) = (
case grab_atoms var a of
  Some(al) \<Rightarrow> (
    case grab_atoms var b of
      Some(bl) \<Rightarrow> Some(al@bl)
    | None \<Rightarrow> None
  )
| None \<Rightarrow> None
)"|
  "grab_atoms var (Or a b) = (
case grab_atoms var a of
  Some(al) \<Rightarrow> (
    case grab_atoms var b of
      Some(bl) \<Rightarrow> Some(al@bl)
    | None \<Rightarrow> None
  )
| None \<Rightarrow> None
)"|

"grab_atoms var (Neg _) = None"|
"grab_atoms var (ExQ _) = None"|
"grab_atoms var (AllQ _) = None"|
"grab_atoms var (AllN i _) = None"|
"grab_atoms var (ExN i _) = None"

lemma nil_grab : "(grab_atoms var F = Some []) \<Longrightarrow> (freeIn var F)"
proof(induction F)
  case TrueF
  then show ?case by auto
next
  case FalseF
  then show ?case by auto
next
  case (Atom x)
  then show ?case proof(cases x)
    case (Less p)
    then show ?thesis using Atom apply(cases "MPoly_Type.degree p var < 3") apply auto apply(cases "MPoly_Type.degree p var > 0") apply auto
      using degree0isovarspar not_in_isovarspar by blast
  next
    case (Eq p)
    then show ?thesis using Atom apply(cases "MPoly_Type.degree p var < 3") apply auto apply(cases "MPoly_Type.degree p var > 0") apply auto
      using degree0isovarspar not_in_isovarspar by blast
  next
    case (Leq p)
    then show ?thesis using Atom apply(cases "MPoly_Type.degree p var < 3") apply auto apply(cases "MPoly_Type.degree p var > 0") apply auto
      using degree0isovarspar not_in_isovarspar by blast
  next
    case (Neq p)
    then show ?thesis using Atom apply(cases "MPoly_Type.degree p var < 3") apply auto apply(cases "MPoly_Type.degree p var > 0") apply auto
      using degree0isovarspar not_in_isovarspar by blast
  qed
next
  case (And F1 F2)
  then show ?case apply(cases "grab_atoms var F1")
    apply(cases "grab_atoms var F2") apply(auto)
    apply(cases "grab_atoms var F2") apply(auto)
    apply(cases "grab_atoms var F2") by(auto)
next
  case (Or F1 F2)
  then show ?case apply(cases "grab_atoms var F1")
    apply(cases "grab_atoms var F2") apply(auto)
    apply(cases "grab_atoms var F2") apply(auto)
    apply(cases "grab_atoms var F2") by(auto)
next
  case (Neg F)
  then show ?case by auto
next
  case (ExQ F)
  then show ?case by auto
next
  case (AllQ F)
  then show ?case by auto
next
  case (ExN x1 F)
  then show ?case by auto
next
  case (AllN x1 F)
  then show ?case by auto
qed

fun isSome :: "'a option \<Rightarrow> bool" where
  "isSome (Some _) = True" |
  "isSome None = False"

lemma "grab_atoms_convert" : "(isSome (grab_atoms var F)) = (isSome (convert_fm var F xs))"
proof(induction F)
  case TrueF
  then show ?case by auto
next
  case FalseF
  then show ?case by auto
next
  case (Atom a)
  then show ?case apply(cases a) by auto
next
  case (And F1 F2)
  then show ?case
    by (smt convert_fm.simps(4) grab_atoms.simps(7) isSome.elims(2) isSome.elims(3) option.distinct(1) option.simps(5) option.split_sel_asm prod.simps(2))
next
  case (Or F1 F2)
  then show ?case
    by (smt convert_fm.simps(5) grab_atoms.simps(8) isSome.elims(2) isSome.elims(3) option.distinct(1) option.simps(5) option.split_sel_asm prod.simps(2))
next
  case (Neg F)
  then show ?case by auto
next
  case (ExQ F)
  then show ?case by auto
next
  case (AllQ F)
  then show ?case by auto
next
  case (ExN x1 F)
  then show ?case by auto
next
  case (AllN x1 F)
  then show ?case by auto
qed

lemma convert_aNeg :
  assumes "convert_atom var A (xs'@x#xs) = Some(A')"
  assumes "length xs' = var"
  shows "aEval (aNeg A) (xs'@x#xs) = aEvalUni (aNegUni A') x"
proof-
  have "aEval (aNeg A) (xs'@x#xs) = (\<not> aEval A (xs'@x#xs))"
    using aNeg_aEval[of A "(xs'@x#xs)"] by auto
  also have "... = (\<not> aEvalUni A' x)"
    using assms aEval_aEvalUni by auto
  also have "... = aEvalUni (aNegUni A') x"
    by(cases A')(auto)
  finally show ?thesis .
qed

lemma convert_neg :
  assumes "convert_fm var F (xs'@x#xs) = Some(F')"
  assumes "length xs' = var"
  shows "eval (Neg F) (xs'@x#xs) = evalUni (negUni F') x"
  using assms
proof(induction F arbitrary:F')
  case TrueF
  then show ?case by auto
next
  case FalseF
  then show ?case by auto
next
  case (Atom p)
  then show ?case
    using convert_aNeg[of _ p]
    by (smt aNeg_aEval convert_fm.simps(1) evalUni.simps(1) eval.simps(1) eval.simps(6) map_option_eq_Some negUni.simps(1))
next
  case (And F1 F2)
  then show ?case apply auto
    apply (metis (no_types, lifting) evalUni.simps(5) negUni.simps(4) option.case_eq_if option.collapse option.distinct(1) option.sel)
    apply (smt (verit, del_insts) evalUni.simps(5) isSome.elims(1) negUni.simps(4) option.inject option.simps(4) option.simps(5))
    by (smt (verit, del_insts) evalUni.simps(5) isSome.elims(1) negUni.simps(4) option.inject option.simps(4) option.simps(5))
next
  case (Or F1 F2)
  then show ?case apply auto
    apply (smt (verit, del_insts) evalUni.simps(4) isSome.elims(1) negUni.simps(5) option.inject option.simps(4) option.simps(5))
    apply (smt (verit, del_insts) evalUni.simps(4) isSome.elims(1) negUni.simps(5) option.inject option.simps(4) option.simps(5))
    by (smt (verit, del_insts) evalUni.simps(4) isSome.elims(1) negUni.simps(5) option.inject option.simps(4) option.simps(5))
next
  case (Neg F)
  then show ?case by auto
next
  case (ExQ F)
  then show ?case by auto
next
  case (AllQ F)
  then show ?case by auto
next
  case (ExN x1 F)
  then show ?case by auto
next
  case (AllN x1 F)
  then show ?case by auto
qed

fun list_disj_Uni :: "'a fmUni list \<Rightarrow> 'a fmUni" where
  "list_disj_Uni [] = FalseFUni"|
  "list_disj_Uni (x#xs) = OrUni x (list_disj_Uni xs)"

fun list_conj_Uni :: "'a fmUni list \<Rightarrow> 'a fmUni" where
  "list_conj_Uni [] = TrueFUni"|
  "list_conj_Uni (x#xs) = AndUni x (list_conj_Uni xs)"

lemma eval_list_disj_Uni : "evalUni (list_disj_Uni L) x = (\<exists>l\<in>set(L). evalUni l x)"
  by(induction L)(auto)

lemma eval_list_conj_Uni : "evalUni (list_conj_Uni A) x = (\<forall>l\<in>set A. evalUni l x)"
  apply(induction A)by auto

lemma eval_list_conj_Uni_append : "evalUni (list_conj_Uni (A @ B)) x = (evalUni (list_conj_Uni (A)) x \<and> evalUni (list_conj_Uni (B)) x)"
  apply(induction A)by auto

fun map_atomUni :: "('a \<Rightarrow> 'a fmUni) \<Rightarrow> 'a fmUni \<Rightarrow> 'a fmUni" where
  "map_atomUni f (AtomUni a) = f a" |
  "map_atomUni f (TrueFUni) = TrueFUni" |
  "map_atomUni f (FalseFUni) = FalseFUni" |
  "map_atomUni f (AndUni \<phi> \<psi>) = (AndUni (map_atomUni f \<phi>) (map_atomUni f \<psi>))" |
  "map_atomUni f (OrUni \<phi> \<psi>) = (OrUni (map_atomUni f \<phi>) (map_atomUni f \<psi>))"

fun map_atom :: "(atom \<Rightarrow> atom fm) \<Rightarrow> atom fm \<Rightarrow> atom fm" where
  "map_atom f TrueF = TrueF"|
  "map_atom f FalseF = FalseF"|
  "map_atom f (Atom a) = f a"|
  "map_atom f (And \<phi> \<psi>) = And (map_atom f \<phi>) (map_atom f \<psi>)"|
  "map_atom f (Or \<phi> \<psi>) = Or (map_atom f \<phi>) (map_atom f \<psi>)"|
  "map_atom f (Neg \<phi>) = TrueF"|
  "map_atom f (ExQ \<phi>) = TrueF"|
  "map_atom f (AllQ \<phi>) = TrueF"|
  "map_atom f (ExN i \<phi>) = TrueF"|
  "map_atom f (AllN i \<phi>) = TrueF"

fun getPoly :: "atomUni => real * real * real" where
  "getPoly (EqUni p) = p"|
  "getPoly (LeqUni p) = p"|
  "getPoly (NeqUni p) = p"|
  "getPoly (LessUni p) = p"

lemma liftatom_map_atom :
  assumes "\<exists>F'. convert_fm var F xs = Some F'"
  shows "liftmap f F 0 = map_atom (f 0) F"
  using assms
  apply(induction F)
  apply(auto)
  apply fastforce
  apply (metis (no_types, lifting) isSome.elims(2) isSome.elims(3) option.case_eq_if)
  apply fastforce
  by (metis (no_types, lifting) isSome.elims(2) isSome.elims(3) option.case_eq_if)

lemma eval_map : "(\<exists>l\<in>set(map f L). evalUni l x) = (\<exists>l\<in>set(L). evalUni (f l) x)"
  by auto

lemma eval_map_all : "(\<forall>l\<in>set(map f L). evalUni l x) = (\<forall>l\<in>set(L). evalUni (f l) x)"
  by auto

lemma eval_append : "(\<exists>l\<in>set (A#B).evalUni l x) = (evalUni A x \<or> (\<exists>l\<in>set (B).evalUni l x))"
  by auto

lemma eval_conj_atom : "evalUni (list_conj_Uni (map AtomUni L)) x = (\<forall>l\<in>set(L). aEvalUni l x)"
  unfolding eval_list_conj_Uni
  by auto
end


theory SList
imports Main
begin

fun valid_set :: "'a::linorder list \<Rightarrow> bool" where
  "valid_set x = (List.distinct x \<and> List.sorted x)"

definition empty :: "'a::linorder list" where
  "empty = Nil"

lemma valid_empty : "valid_set empty"
  by (simp add:SList.empty_def)

fun insert :: "'a::linorder \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "insert a Nil = Cons a Nil" |
  "insert a (Cons x z) =
    (if a < x
     then (Cons a (Cons x z))
     else (if a > x
           then (Cons x (insert a z))
           else (Cons x z)))"

lemma insert_in_middle : "x < a \<Longrightarrow> valid_set (a # z)
                            \<Longrightarrow> valid_set (x # a # z)"
  by auto

lemma remove_from_middle : "valid_set (x # a # z) \<Longrightarrow> x < a"
  by auto

lemma sublist_valid : "valid_set (x # c) \<Longrightarrow>
                       valid_set c"
  by simp

lemma insert_valid_aux :
  "x < a \<Longrightarrow>
   valid_set (x # c) \<Longrightarrow>
   valid_set (SList.insert a c) \<Longrightarrow>
   valid_set (x # SList.insert a c)"
  apply (induction c arbitrary: a x)
  apply auto[1]
  by (metis insert.simps(2) insert_in_middle remove_from_middle)

lemma insert_valid_aux2 :
  "(\<And>a. valid_set c \<Longrightarrow> valid_set (SList.insert a c)) \<Longrightarrow>
    valid_set (x # c) \<Longrightarrow>
    x < a \<Longrightarrow>
    valid_set (x # SList.insert a c)"
  using insert_valid_aux sublist_valid by blast

lemma insert_valid_aux3 :
  "(\<And>a. valid_set c \<Longrightarrow> valid_set (SList.insert a c)) \<Longrightarrow>
   valid_set (x # c) \<Longrightarrow> valid_set (SList.insert a (x # c))"
  apply (simp only:insert.simps)
  apply (cases "a < x")
  apply auto[1]
  apply (cases "x < a")
  apply (smt insert_valid_aux2)
  by auto

theorem insert_valid : "valid_set c \<Longrightarrow> valid_set (SList.insert a c)"
  apply (induction c arbitrary:a)
  apply simp
  using insert_valid_aux3 by blast

fun delete :: "'a::linorder \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "delete a Nil = Nil" |
  "delete a (Cons x z) =
    (if a = x
     then z
     else (if a > x
           then (Cons x (delete a z))
           else (Cons x z)))"

lemma delete_valid_aux :
  "valid_set (a # c) \<Longrightarrow> valid_set (a # delete b c)"
  apply (induction c arbitrary: a b)
  apply simp
  by fastforce

lemma delete_valid_aux2 :
  "(\<And>a. valid_set c \<Longrightarrow> valid_set (delete a c)) \<Longrightarrow>
   valid_set (b # c) \<Longrightarrow> valid_set (delete a (b # c))"
  using delete_valid_aux by auto

theorem delete_valid : "valid_set c \<Longrightarrow> valid_set (SList.delete a c)"
  apply (induction c arbitrary: a)
  apply auto[1]
  using delete_valid_aux2 by blast

fun element :: "'a::linorder \<Rightarrow> 'a list \<Rightarrow> bool" where
  "element a Nil = False" |
  "element a (Cons x z) =
    (if a = x
     then True
     else (if a > x
           then element a z
           else False))"

lemma delete_lookup_None_aux :
  "valid_set (c # b) \<Longrightarrow> element c b = False"
  by (metis element.elims(2) not_less_iff_gr_or_eq remove_from_middle)

lemma delete_lookup_None_aux2 :
  "(valid_set b \<Longrightarrow> element a (delete a b) = False) \<Longrightarrow>
   valid_set (c # b) \<Longrightarrow> element a (delete a (c # b)) = False"
  using delete_lookup_None_aux by auto

theorem delete_lookup_None : "valid_set b \<Longrightarrow>
                              SList.element a (SList.delete a b) = False"
  apply (induction b)
  apply simp
  using delete_lookup_None_aux2 by fastforce

theorem insert_lookup_Some : "valid_set c \<Longrightarrow>
                              SList.element a (SList.insert a c) = True"
  apply (induction c)
  apply simp
  by force

lemma different_delete_lookup_aux :
  "(valid_set c \<Longrightarrow> a \<noteq> b \<Longrightarrow> element a (delete b c) = element a c) \<Longrightarrow>
   valid_set (x # c) \<Longrightarrow>
   a \<noteq> b \<Longrightarrow> element a (delete b (x # c)) = element a (x # c)"
  by (metis (full_types) delete.simps(2) delete_lookup_None_aux
      delete_valid_aux element.simps(2) insert_in_middle
      not_less_iff_gr_or_eq sublist_valid)

theorem different_delete_lookup :
  "valid_set c \<Longrightarrow> a \<noteq> b \<Longrightarrow>
   SList.element a (SList.delete b c) = SList.element a c"
  apply (induction c)
  apply simp
  using different_delete_lookup_aux by blast

end


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

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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

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

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(Nat list) list => (Nat list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu2 :: "(Nat list) list => Nat list" where
  "mergingbu2 (nil2) = nil2"
| "mergingbu2 (cons2 xs (nil2)) = xs"
| "mergingbu2 (cons2 xs (cons2 z x2)) =
     mergingbu2 (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun risers :: "Nat list => (Nat list) list" where
  "risers (nil2) = nil2"
| "risers (cons2 y (nil2)) = cons2 (cons2 y (nil2)) (nil2)"
| "risers (cons2 y (cons2 y2 xs)) =
     (if le y y2 then
        (case risers (cons2 y2 xs) of
           nil2 => nil2
           | cons2 ys yss => cons2 (cons2 y ys) yss)
        else
        cons2 (cons2 y (nil2)) (risers (cons2 y2 xs)))"

fun msortbu2 :: "Nat list => Nat list" where
  "msortbu2 x = mergingbu2 (risers x)"

fun count :: "'a => 'a list => Nat" where
  "count x (nil2) = Z"
| "count x (cons2 z ys) =
     (if (x = z) then plus (S Z) (count x ys) else count x ys)"

theorem property0 :
  "((count x (msortbu2 xs)) = (count x xs))"
  oops

end


theory ex_2_6
  imports Main
begin
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun contents::"'a tree \<Rightarrow> 'a list" where
"contents Tip = []" |
"contents (Node l a r) = a # (contents(l) @ contents(r))"

fun sum_tree::"nat tree \<Rightarrow> nat" where
"sum_tree Tip = 0" |
"sum_tree (Node l a r) = a + sum_tree(l) + sum_tree(r)"

theorem contents_equiv:"sum_tree t = sum_list(contents t)"
  apply (induction t)
  by (auto)
end


(*  Title:      HOL/Number_Theory/Eratosthenes.thy
    Author:     Florian Haftmann, TU Muenchen
*)

section \<open>The sieve of Eratosthenes\<close>

theory Eratosthenes
  imports MainRLT "HOL-Computational_Algebra.Primes"
begin

subsection \<open>Preliminary: strict divisibility\<close>

context dvd
begin

abbreviation dvd_strict :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "dvd'_strict" 50)
where
  "b dvd_strict a \<equiv> b dvd a \<and> \<not> a dvd b"

end

subsection \<open>Main corpus\<close>

text \<open>The sieve is modelled as a list of booleans, where \<^const>\<open>False\<close> means \emph{marked out}.\<close>

type_synonym marks = "bool list"

definition numbers_of_marks :: "nat \<Rightarrow> marks \<Rightarrow> nat set"
where
  "numbers_of_marks n bs = fst ` {x \<in> set (enumerate n bs). snd x}"

lemma numbers_of_marks_simps [simp, code]:
  "numbers_of_marks n [] = {}"
  "numbers_of_marks n (True # bs) = insert n (numbers_of_marks (Suc n) bs)"
  "numbers_of_marks n (False # bs) = numbers_of_marks (Suc n) bs"
  by (auto simp add: numbers_of_marks_def intro!: image_eqI)

lemma numbers_of_marks_Suc:
  "numbers_of_marks (Suc n) bs = Suc ` numbers_of_marks n bs"
  by (auto simp add: numbers_of_marks_def enumerate_Suc_eq image_iff Bex_def)

lemma numbers_of_marks_replicate_False [simp]:
  "numbers_of_marks n (replicate m False) = {}"
  by (auto simp add: numbers_of_marks_def enumerate_replicate_eq)

lemma numbers_of_marks_replicate_True [simp]:
  "numbers_of_marks n (replicate m True) = {n..<n+m}"
  by (auto simp add: numbers_of_marks_def enumerate_replicate_eq image_def)

lemma in_numbers_of_marks_eq:
  "m \<in> numbers_of_marks n bs \<longleftrightarrow> m \<in> {n..<n + length bs} \<and> bs ! (m - n)"
  by (simp add: numbers_of_marks_def in_set_enumerate_eq image_iff add.commute)

lemma sorted_list_of_set_numbers_of_marks:
  "sorted_list_of_set (numbers_of_marks n bs) = map fst (filter snd (enumerate n bs))"
  by (auto simp add: numbers_of_marks_def distinct_map
    intro!: sorted_filter distinct_filter inj_onI sorted_distinct_set_unique)

text \<open>Marking out multiples in a sieve\<close>

definition mark_out :: "nat \<Rightarrow> marks \<Rightarrow> marks"
where
  "mark_out n bs = map (\<lambda>(q, b). b \<and> \<not> Suc n dvd Suc (Suc q)) (enumerate n bs)"

lemma mark_out_Nil [simp]: "mark_out n [] = []"
  by (simp add: mark_out_def)

lemma length_mark_out [simp]: "length (mark_out n bs) = length bs"
  by (simp add: mark_out_def)

lemma numbers_of_marks_mark_out:
    "numbers_of_marks n (mark_out m bs) = {q \<in> numbers_of_marks n bs. \<not> Suc m dvd Suc q - n}"
  by (auto simp add: numbers_of_marks_def mark_out_def in_set_enumerate_eq image_iff
    nth_enumerate_eq less_eq_dvd_minus)

text \<open>Auxiliary operation for efficient implementation\<close>

definition mark_out_aux :: "nat \<Rightarrow> nat \<Rightarrow> marks \<Rightarrow> marks"
where
  "mark_out_aux n m bs =
    map (\<lambda>(q, b). b \<and> (q < m + n \<or> \<not> Suc n dvd Suc (Suc q) + (n - m mod Suc n))) (enumerate n bs)"

lemma mark_out_code [code]: "mark_out n bs = mark_out_aux n n bs"
proof -
  have aux: False
    if A: "Suc n dvd Suc (Suc a)"
    and B: "a < n + n"
    and C: "n \<le> a"
    for a
  proof (cases "n = 0")
    case True
    with A B C show ?thesis by simp
  next
    case False
    define m where "m = Suc n"
    then have "m > 0" by simp
    from False have "n > 0" by simp
    from A obtain q where q: "Suc (Suc a) = Suc n * q" by (rule dvdE)
    have "q > 0"
    proof (rule ccontr)
      assume "\<not> q > 0"
      with q show False by simp
    qed
    with \<open>n > 0\<close> have "Suc n * q \<ge> 2" by (auto simp add: gr0_conv_Suc)
    with q have a: "a = Suc n * q - 2" by simp
    with B have "q + n * q < n + n + 2" by auto
    then have "m * q < m * 2" by (simp add: m_def)
    with \<open>m > 0\<close> have "q < 2" by simp
    with \<open>q > 0\<close> have "q = 1" by simp
    with a have "a = n - 1" by simp
    with \<open>n > 0\<close> C show False by simp
  qed
  show ?thesis
    by (auto simp add: mark_out_def mark_out_aux_def in_set_enumerate_eq intro: aux)
qed

lemma mark_out_aux_simps [simp, code]:
  "mark_out_aux n m [] = []"
  "mark_out_aux n 0 (b # bs) = False # mark_out_aux n n bs"
  "mark_out_aux n (Suc m) (b # bs) = b # mark_out_aux n m bs"
proof goal_cases
  case 1
  show ?case
    by (simp add: mark_out_aux_def)
next
  case 2
  show ?case
    by (auto simp add: mark_out_code [symmetric] mark_out_aux_def mark_out_def
      enumerate_Suc_eq in_set_enumerate_eq less_eq_dvd_minus)
next
  case 3
  { define v where "v = Suc m"
    define w where "w = Suc n"
    fix q
    assume "m + n \<le> q"
    then obtain r where q: "q = m + n + r" by (auto simp add: le_iff_add)
    { fix u
      from w_def have "u mod w < w" by simp
      then have "u + (w - u mod w) = w + (u - u mod w)"
        by simp
      then have "u + (w - u mod w) = w + u div w * w"
        by (simp add: minus_mod_eq_div_mult)
    }
    then have "w dvd v + w + r + (w - v mod w) \<longleftrightarrow> w dvd m + w + r + (w - m mod w)"
      by (simp add: add.assoc add.left_commute [of m] add.left_commute [of v]
        dvd_add_left_iff dvd_add_right_iff)
    moreover from q have "Suc q = m + w + r" by (simp add: w_def)
    moreover from q have "Suc (Suc q) = v + w + r" by (simp add: v_def w_def)
    ultimately have "w dvd Suc (Suc (q + (w - v mod w))) \<longleftrightarrow> w dvd Suc (q + (w - m mod w))"
      by (simp only: add_Suc [symmetric])
    then have "Suc n dvd Suc (Suc (Suc (q + n) - Suc m mod Suc n)) \<longleftrightarrow>
      Suc n dvd Suc (Suc (q + n - m mod Suc n))"
      by (simp add: v_def w_def Suc_diff_le trans_le_add2)
  }
  then show ?case
    by (auto simp add: mark_out_aux_def
      enumerate_Suc_eq in_set_enumerate_eq not_less)
qed

text \<open>Main entry point to sieve\<close>

fun sieve :: "nat \<Rightarrow> marks \<Rightarrow> marks"
where
  "sieve n [] = []"
| "sieve n (False # bs) = False # sieve (Suc n) bs"
| "sieve n (True # bs) = True # sieve (Suc n) (mark_out n bs)"

text \<open>
  There are the following possible optimisations here:

  \begin{itemize}

    \item \<^const>\<open>sieve\<close> can abort as soon as \<^term>\<open>n\<close> is too big to let
      \<^const>\<open>mark_out\<close> have any effect.

    \item Search for further primes can be given up as soon as the search
      position exceeds the square root of the maximum candidate.

  \end{itemize}

  This is left as an constructive exercise to the reader.
\<close>

lemma numbers_of_marks_sieve:
  "numbers_of_marks (Suc n) (sieve n bs) =
    {q \<in> numbers_of_marks (Suc n) bs. \<forall>m \<in> numbers_of_marks (Suc n) bs. \<not> m dvd_strict q}"
proof (induct n bs rule: sieve.induct)
  case 1
  show ?case by simp
next
  case 2
  then show ?case by simp
next
  case (3 n bs)
  have aux: "n \<in> Suc ` M \<longleftrightarrow> n > 0 \<and> n - 1 \<in> M" (is "?lhs \<longleftrightarrow> ?rhs") for M n
  proof
    show ?rhs if ?lhs using that by auto
    show ?lhs if ?rhs
    proof -
      from that have "n > 0" and "n - 1 \<in> M" by auto
      then have "Suc (n - 1) \<in> Suc ` M" by blast
      with \<open>n > 0\<close> show "n \<in> Suc ` M" by simp
    qed
  qed
  have aux1: False if "Suc (Suc n) \<le> m" and "m dvd Suc n" for m :: nat
  proof -
    from \<open>m dvd Suc n\<close> obtain q where "Suc n = m * q" ..
    with \<open>Suc (Suc n) \<le> m\<close> have "Suc (m * q) \<le> m" by simp
    then have "m * q < m" by arith
    then have "q = 0" by simp
    with \<open>Suc n = m * q\<close> show ?thesis by simp
  qed
  have aux2: "m dvd q"
    if 1: "\<forall>q>0. 1 < q \<longrightarrow> Suc n < q \<longrightarrow> q \<le> Suc (n + length bs) \<longrightarrow>
      bs ! (q - Suc (Suc n)) \<longrightarrow> \<not> Suc n dvd q \<longrightarrow> q dvd m \<longrightarrow> m dvd q"
    and 2: "\<not> Suc n dvd m" "q dvd m"
    and 3: "Suc n < q" "q \<le> Suc (n + length bs)" "bs ! (q - Suc (Suc n))"
    for m q :: nat
  proof -
    from 1 have *: "\<And>q. Suc n < q \<Longrightarrow> q \<le> Suc (n + length bs) \<Longrightarrow>
      bs ! (q - Suc (Suc n)) \<Longrightarrow> \<not> Suc n dvd q \<Longrightarrow> q dvd m \<Longrightarrow> m dvd q"
      by auto
    from 2 have "\<not> Suc n dvd q" by (auto elim: dvdE)
    moreover note 3
    moreover note \<open>q dvd m\<close>
    ultimately show ?thesis by (auto intro: *)
  qed
  from 3 show ?case
    apply (simp_all add: numbers_of_marks_mark_out numbers_of_marks_Suc Compr_image_eq
      inj_image_eq_iff in_numbers_of_marks_eq Ball_def imp_conjL aux)
    apply safe
    apply (simp_all add: less_diff_conv2 le_diff_conv2 dvd_minus_self not_less)
    apply (clarsimp dest!: aux1)
    apply (simp add: Suc_le_eq less_Suc_eq_le)
    apply (rule aux2)
    apply (clarsimp dest!: aux1)+
    done
qed

text \<open>Relation of the sieve algorithm to actual primes\<close>

definition primes_upto :: "nat \<Rightarrow> nat list"
where
  "primes_upto n = sorted_list_of_set {m. m \<le> n \<and> prime m}"

lemma set_primes_upto: "set (primes_upto n) = {m. m \<le> n \<and> prime m}"
  by (simp add: primes_upto_def)

lemma sorted_primes_upto [iff]: "sorted (primes_upto n)"
  by (simp add: primes_upto_def)

lemma distinct_primes_upto [iff]: "distinct (primes_upto n)"
  by (simp add: primes_upto_def)

lemma set_primes_upto_sieve:
  "set (primes_upto n) = numbers_of_marks 2 (sieve 1 (replicate (n - 1) True))"
proof -
  consider "n = 0 \<or> n = 1" | "n > 1" by arith
  then show ?thesis
  proof cases
    case 1
    then show ?thesis
      by (auto simp add: numbers_of_marks_sieve numeral_2_eq_2 set_primes_upto
        dest: prime_gt_Suc_0_nat)
  next
    case 2
    {
      fix m q
      assume "Suc (Suc 0) \<le> q"
        and "q < Suc n"
        and "m dvd q"
      then have "m < Suc n" by (auto dest: dvd_imp_le)
      assume *: "\<forall>m\<in>{Suc (Suc 0)..<Suc n}. m dvd q \<longrightarrow> q dvd m"
        and "m dvd q" and "m \<noteq> 1"
      have "m = q"
      proof (cases "m = 0")
        case True with \<open>m dvd q\<close> show ?thesis by simp
      next
        case False with \<open>m \<noteq> 1\<close> have "Suc (Suc 0) \<le> m" by arith
        with \<open>m < Suc n\<close> * \<open>m dvd q\<close> have "q dvd m" by simp
        with \<open>m dvd q\<close> show ?thesis by (simp add: dvd_antisym)
      qed
    }
    then have aux: "\<And>m q. Suc (Suc 0) \<le> q \<Longrightarrow>
      q < Suc n \<Longrightarrow>
      m dvd q \<Longrightarrow>
      \<forall>m\<in>{Suc (Suc 0)..<Suc n}. m dvd q \<longrightarrow> q dvd m \<Longrightarrow>
      m dvd q \<Longrightarrow> m \<noteq> q \<Longrightarrow> m = 1" by auto
    from 2 show ?thesis
      apply (auto simp add: numbers_of_marks_sieve numeral_2_eq_2 set_primes_upto
        dest: prime_gt_Suc_0_nat)
      apply (metis One_nat_def Suc_le_eq less_not_refl prime_nat_iff)
      apply (metis One_nat_def Suc_le_eq aux prime_nat_iff)
      done
  qed
qed

lemma primes_upto_sieve [code]:
  "primes_upto n = map fst (filter snd (enumerate 2 (sieve 1 (replicate (n - 1) True))))"
proof -
  have "primes_upto n = sorted_list_of_set (numbers_of_marks 2 (sieve 1 (replicate (n - 1) True)))"
    apply (rule sorted_distinct_set_unique)
    apply (simp_all only: set_primes_upto_sieve numbers_of_marks_def)
    apply auto
    done
  then show ?thesis
    by (simp add: sorted_list_of_set_numbers_of_marks)
qed

lemma prime_in_primes_upto: "prime n \<longleftrightarrow> n \<in> set (primes_upto n)"
  by (simp add: set_primes_upto)

subsection \<open>Application: smallest prime beyond a certain number\<close>

definition smallest_prime_beyond :: "nat \<Rightarrow> nat"
where
  "smallest_prime_beyond n = (LEAST p. prime p \<and> p \<ge> n)"

lemma prime_smallest_prime_beyond [iff]: "prime (smallest_prime_beyond n)" (is ?P)
  and smallest_prime_beyond_le [iff]: "smallest_prime_beyond n \<ge> n" (is ?Q)
proof -
  let ?least = "LEAST p. prime p \<and> p \<ge> n"
  from primes_infinite obtain q where "prime q \<and> q \<ge> n"
    by (metis finite_nat_set_iff_bounded_le mem_Collect_eq nat_le_linear)
  then have "prime ?least \<and> ?least \<ge> n"
    by (rule LeastI)
  then show ?P and ?Q
    by (simp_all add: smallest_prime_beyond_def)
qed

lemma smallest_prime_beyond_smallest: "prime p \<Longrightarrow> p \<ge> n \<Longrightarrow> smallest_prime_beyond n \<le> p"
  by (simp only: smallest_prime_beyond_def) (auto intro: Least_le)

lemma smallest_prime_beyond_eq:
  "prime p \<Longrightarrow> p \<ge> n \<Longrightarrow> (\<And>q. prime q \<Longrightarrow> q \<ge> n \<Longrightarrow> q \<ge> p) \<Longrightarrow> smallest_prime_beyond n = p"
  by (simp only: smallest_prime_beyond_def) (auto intro: Least_equality)

definition smallest_prime_between :: "nat \<Rightarrow> nat \<Rightarrow> nat option"
where
  "smallest_prime_between m n =
    (if (\<exists>p. prime p \<and> m \<le> p \<and> p \<le> n) then Some (smallest_prime_beyond m) else None)"

lemma smallest_prime_between_None:
  "smallest_prime_between m n = None \<longleftrightarrow> (\<forall>q. m \<le> q \<and> q \<le> n \<longrightarrow> \<not> prime q)"
  by (auto simp add: smallest_prime_between_def)

lemma smallest_prime_betwen_Some:
  "smallest_prime_between m n = Some p \<longleftrightarrow> smallest_prime_beyond m = p \<and> p \<le> n"
  by (auto simp add: smallest_prime_between_def dest: smallest_prime_beyond_smallest [of _ m])

definition smallest_prime_beyond_aux :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "smallest_prime_beyond_aux k n = smallest_prime_beyond n"

lemma [code]:
  "smallest_prime_beyond_aux k n =
    (case smallest_prime_between n (k * n) of
      Some p \<Rightarrow> p
    | None \<Rightarrow> smallest_prime_beyond_aux (Suc k) n)"
  by (simp add: smallest_prime_beyond_aux_def smallest_prime_betwen_Some split: option.split)

lemma [code]: "smallest_prime_beyond n = smallest_prime_beyond_aux 2 n"
  by (simp add: smallest_prime_beyond_aux_def)

end