(*  Author:     Johannes Hölzl, TU München
*)

section \<open>Partitions and Disjoint Sets\<close>

theory Disjoint_Sets
  imports Main
begin

lemma range_subsetD: "range f \<subseteq> B \<Longrightarrow> f i \<in> B"
  by blast

lemma Int_Diff_disjoint: "A \<inter> B \<inter> (A - B) = {}"
  by blast

lemma Int_Diff_Un: "A \<inter> B \<union> (A - B) = A"
  by blast

lemma mono_Un: "mono A \<Longrightarrow> (\<Union>i\<le>n. A i) = A n"
  unfolding mono_def by auto

lemma disjnt_equiv_class: "equiv A r \<Longrightarrow> disjnt (r``{a}) (r``{b}) \<longleftrightarrow> (a, b) \<notin> r"
  by (auto dest: equiv_class_self simp: equiv_class_eq_iff disjnt_def)

subsection \<open>Set of Disjoint Sets\<close>

abbreviation disjoint :: "'a set set \<Rightarrow> bool" where "disjoint \<equiv> pairwise disjnt"

lemma disjoint_def: "disjoint A \<longleftrightarrow> (\<forall>a\<in>A. \<forall>b\<in>A. a \<noteq> b \<longrightarrow> a \<inter> b = {})"
  unfolding pairwise_def disjnt_def by auto

lemma disjointI:
  "(\<And>a b. a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> a \<noteq> b \<Longrightarrow> a \<inter> b = {}) \<Longrightarrow> disjoint A"
  unfolding disjoint_def by auto

lemma disjointD:
  "disjoint A \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> a \<noteq> b \<Longrightarrow> a \<inter> b = {}"
  unfolding disjoint_def by auto

lemma disjoint_image: "inj_on f (\<Union>A) \<Longrightarrow> disjoint A \<Longrightarrow> disjoint ((`) f ` A)"
  unfolding inj_on_def disjoint_def by blast

lemma assumes "disjoint (A \<union> B)"
      shows   disjoint_unionD1: "disjoint A" and disjoint_unionD2: "disjoint B"
  using assms by (simp_all add: disjoint_def)

lemma disjoint_INT:
  assumes *: "\<And>i. i \<in> I \<Longrightarrow> disjoint (F i)"
  shows "disjoint {\<Inter>i\<in>I. X i | X. \<forall>i\<in>I. X i \<in> F i}"
proof (safe intro!: disjointI del: equalityI)
  fix A B :: "'a \<Rightarrow> 'b set" assume "(\<Inter>i\<in>I. A i) \<noteq> (\<Inter>i\<in>I. B i)"
  then obtain i where "A i \<noteq> B i" "i \<in> I"
    by auto
  moreover assume "\<forall>i\<in>I. A i \<in> F i" "\<forall>i\<in>I. B i \<in> F i"
  ultimately show "(\<Inter>i\<in>I. A i) \<inter> (\<Inter>i\<in>I. B i) = {}"
    using *[OF \<open>i\<in>I\<close>, THEN disjointD, of "A i" "B i"]
    by (auto simp flip: INT_Int_distrib)
qed

lemma diff_Union_pairwise_disjoint:
  assumes "pairwise disjnt \<A>" "\<B> \<subseteq> \<A>"
  shows "\<Union>\<A> - \<Union>\<B> = \<Union>(\<A> - \<B>)"
proof -
  have "False"
    if x: "x \<in> A" "x \<in> B" and AB: "A \<in> \<A>" "A \<notin> \<B>" "B \<in> \<B>" for x A B
  proof -
    have "A \<inter> B = {}"
      using assms disjointD AB by blast
  with x show ?thesis
    by blast
  qed
  then show ?thesis by auto
qed

lemma Int_Union_pairwise_disjoint:
  assumes "pairwise disjnt (\<A> \<union> \<B>)"
  shows "\<Union>\<A> \<inter> \<Union>\<B> = \<Union>(\<A> \<inter> \<B>)"
proof -
  have "False"
    if x: "x \<in> A" "x \<in> B" and AB: "A \<in> \<A>" "A \<notin> \<B>" "B \<in> \<B>" for x A B
  proof -
    have "A \<inter> B = {}"
      using assms disjointD AB by blast
  with x show ?thesis
    by blast
  qed
  then show ?thesis by auto
qed

lemma psubset_Union_pairwise_disjoint:
  assumes \<B>: "pairwise disjnt \<B>" and "\<A> \<subset> \<B> - {{}}"
  shows "\<Union>\<A> \<subset> \<Union>\<B>"
  unfolding psubset_eq
proof
  show "\<Union>\<A> \<subseteq> \<Union>\<B>"
    using assms by blast
  have "\<A> \<subseteq> \<B>" "\<Union>(\<B> - \<A> \<inter> (\<B> - {{}})) \<noteq> {}"
    using assms by blast+
  then show "\<Union>\<A> \<noteq> \<Union>\<B>"
    using diff_Union_pairwise_disjoint [OF \<B>] by blast
qed

subsubsection "Family of Disjoint Sets"

definition disjoint_family_on :: "('i \<Rightarrow> 'a set) \<Rightarrow> 'i set \<Rightarrow> bool" where
  "disjoint_family_on A S \<longleftrightarrow> (\<forall>m\<in>S. \<forall>n\<in>S. m \<noteq> n \<longrightarrow> A m \<inter> A n = {})"

abbreviation "disjoint_family A \<equiv> disjoint_family_on A UNIV"

lemma disjoint_family_elem_disjnt:
  assumes "infinite A" "finite C"
      and df: "disjoint_family_on B A"
  obtains x where "x \<in> A" "disjnt C (B x)"
proof -
  have "False" if *: "\<forall>x \<in> A. \<exists>y. y \<in> C \<and> y \<in> B x"
  proof -
    obtain g where g: "\<forall>x \<in> A. g x \<in> C \<and> g x \<in> B x"
      using * by metis
    with df have "inj_on g A"
      by (fastforce simp add: inj_on_def disjoint_family_on_def)
    then have "infinite (g ` A)"
      using \<open>infinite A\<close> finite_image_iff by blast
    then show False
      by (meson \<open>finite C\<close> finite_subset g image_subset_iff)
  qed
  then show ?thesis
    by (force simp: disjnt_iff intro: that)
qed

lemma disjoint_family_onD:
  "disjoint_family_on A I \<Longrightarrow> i \<in> I \<Longrightarrow> j \<in> I \<Longrightarrow> i \<noteq> j \<Longrightarrow> A i \<inter> A j = {}"
  by (auto simp: disjoint_family_on_def)

lemma disjoint_family_subset: "disjoint_family A \<Longrightarrow> (\<And>x. B x \<subseteq> A x) \<Longrightarrow> disjoint_family B"
  by (force simp add: disjoint_family_on_def)

lemma disjoint_family_on_bisimulation:
  assumes "disjoint_family_on f S"
  and "\<And>n m. n \<in> S \<Longrightarrow> m \<in> S \<Longrightarrow> n \<noteq> m \<Longrightarrow> f n \<inter> f m = {} \<Longrightarrow> g n \<inter> g m = {}"
  shows "disjoint_family_on g S"
  using assms unfolding disjoint_family_on_def by auto

lemma disjoint_family_on_mono:
  "A \<subseteq> B \<Longrightarrow> disjoint_family_on f B \<Longrightarrow> disjoint_family_on f A"
  unfolding disjoint_family_on_def by auto

lemma disjoint_family_Suc:
  "(\<And>n. A n \<subseteq> A (Suc n)) \<Longrightarrow> disjoint_family (\<lambda>i. A (Suc i) - A i)"
  using lift_Suc_mono_le[of A]
  by (auto simp add: disjoint_family_on_def)
     (metis insert_absorb insert_subset le_SucE le_antisym not_le_imp_less less_imp_le)

lemma disjoint_family_on_disjoint_image:
  "disjoint_family_on A I \<Longrightarrow> disjoint (A ` I)"
  unfolding disjoint_family_on_def disjoint_def by force

lemma disjoint_family_on_vimageI: "disjoint_family_on F I \<Longrightarrow> disjoint_family_on (\<lambda>i. f -` F i) I"
  by (auto simp: disjoint_family_on_def)

lemma disjoint_image_disjoint_family_on:
  assumes d: "disjoint (A ` I)" and i: "inj_on A I"
  shows "disjoint_family_on A I"
  unfolding disjoint_family_on_def
proof (intro ballI impI)
  fix n m assume nm: "m \<in> I" "n \<in> I" and "n \<noteq> m"
  with i[THEN inj_onD, of n m] show "A n \<inter> A m = {}"
    by (intro disjointD[OF d]) auto
qed

lemma disjoint_UN:
  assumes F: "\<And>i. i \<in> I \<Longrightarrow> disjoint (F i)" and *: "disjoint_family_on (\<lambda>i. \<Union>(F i)) I"
  shows "disjoint (\<Union>i\<in>I. F i)"
proof (safe intro!: disjointI del: equalityI)
  fix A B i j assume "A \<noteq> B" "A \<in> F i" "i \<in> I" "B \<in> F j" "j \<in> I"
  show "A \<inter> B = {}"
  proof cases
    assume "i = j" with F[of i] \<open>i \<in> I\<close> \<open>A \<in> F i\<close> \<open>B \<in> F j\<close> \<open>A \<noteq> B\<close> show "A \<inter> B = {}"
      by (auto dest: disjointD)
  next
    assume "i \<noteq> j"
    with * \<open>i\<in>I\<close> \<open>j\<in>I\<close> have "(\<Union>(F i)) \<inter> (\<Union>(F j)) = {}"
      by (rule disjoint_family_onD)
    with \<open>A\<in>F i\<close> \<open>i\<in>I\<close> \<open>B\<in>F j\<close> \<open>j\<in>I\<close>
    show "A \<inter> B = {}"
      by auto
  qed
qed

lemma distinct_list_bind:
  assumes "distinct xs" "\<And>x. x \<in> set xs \<Longrightarrow> distinct (f x)"
          "disjoint_family_on (set \<circ> f) (set xs)"
  shows   "distinct (List.bind xs f)"
  using assms
  by (induction xs)
     (auto simp: disjoint_family_on_def distinct_map inj_on_def set_list_bind)

lemma bij_betw_UNION_disjoint:
  assumes disj: "disjoint_family_on A' I"
  assumes bij: "\<And>i. i \<in> I \<Longrightarrow> bij_betw f (A i) (A' i)"
  shows   "bij_betw f (\<Union>i\<in>I. A i) (\<Union>i\<in>I. A' i)"
unfolding bij_betw_def
proof
  from bij show eq: "f ` \<Union>(A ` I) = \<Union>(A' ` I)"
    by (auto simp: bij_betw_def image_UN)
  show "inj_on f (\<Union>(A ` I))"
  proof (rule inj_onI, clarify)
    fix i j x y assume A: "i \<in> I" "j \<in> I" "x \<in> A i" "y \<in> A j" and B: "f x = f y"
    from A bij[of i] bij[of j] have "f x \<in> A' i" "f y \<in> A' j"
      by (auto simp: bij_betw_def)
    with B have "A' i \<inter> A' j \<noteq> {}" by auto
    with disj A have "i = j" unfolding disjoint_family_on_def by blast
    with A B bij[of i] show "x = y" by (auto simp: bij_betw_def dest: inj_onD)
  qed
qed

lemma disjoint_union: "disjoint C \<Longrightarrow> disjoint B \<Longrightarrow> \<Union>C \<inter> \<Union>B = {} \<Longrightarrow> disjoint (C \<union> B)"
  using disjoint_UN[of "{C, B}" "\<lambda>x. x"] by (auto simp add: disjoint_family_on_def)

text \<open>
  The union of an infinite disjoint family of non-empty sets is infinite.
\<close>
lemma infinite_disjoint_family_imp_infinite_UNION:
  assumes "\<not>finite A" "\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> {}" "disjoint_family_on f A"
  shows   "\<not>finite (\<Union>(f ` A))"
proof -
  define g where "g x = (SOME y. y \<in> f x)" for x
  have g: "g x \<in> f x" if "x \<in> A" for x
    unfolding g_def by (rule someI_ex, insert assms(2) that) blast
  have inj_on_g: "inj_on g A"
  proof (rule inj_onI, rule ccontr)
    fix x y assume A: "x \<in> A" "y \<in> A" "g x = g y" "x \<noteq> y"
    with g[of x] g[of y] have "g x \<in> f x" "g x \<in> f y" by auto
    with A \<open>x \<noteq> y\<close> assms show False
      by (auto simp: disjoint_family_on_def inj_on_def)
  qed
  from g have "g ` A \<subseteq> \<Union>(f ` A)" by blast
  moreover from inj_on_g \<open>\<not>finite A\<close> have "\<not>finite (g ` A)"
    using finite_imageD by blast
  ultimately show ?thesis using finite_subset by blast
qed

subsection \<open>Construct Disjoint Sequences\<close>

definition disjointed :: "(nat \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> 'a set" where
  "disjointed A n = A n - (\<Union>i\<in>{0..<n}. A i)"

lemma finite_UN_disjointed_eq: "(\<Union>i\<in>{0..<n}. disjointed A i) = (\<Union>i\<in>{0..<n}. A i)"
proof (induct n)
  case 0 show ?case by simp
next
  case (Suc n)
  thus ?case by (simp add: atLeastLessThanSuc disjointed_def)
qed

lemma UN_disjointed_eq: "(\<Union>i. disjointed A i) = (\<Union>i. A i)"
  by (rule UN_finite2_eq [where k=0])
     (simp add: finite_UN_disjointed_eq)

lemma less_disjoint_disjointed: "m < n \<Longrightarrow> disjointed A m \<inter> disjointed A n = {}"
  by (auto simp add: disjointed_def)

lemma disjoint_family_disjointed: "disjoint_family (disjointed A)"
  by (simp add: disjoint_family_on_def)
     (metis neq_iff Int_commute less_disjoint_disjointed)

lemma disjointed_subset: "disjointed A n \<subseteq> A n"
  by (auto simp add: disjointed_def)

lemma disjointed_0[simp]: "disjointed A 0 = A 0"
  by (simp add: disjointed_def)

lemma disjointed_mono: "mono A \<Longrightarrow> disjointed A (Suc n) = A (Suc n) - A n"
  using mono_Un[of A] by (simp add: disjointed_def atLeastLessThanSuc_atLeastAtMost atLeast0AtMost)

subsection \<open>Partitions\<close>

text \<open>
  Partitions \<^term>\<open>P\<close> of a set \<^term>\<open>A\<close>. We explicitly disallow empty sets.
\<close>

definition partition_on :: "'a set \<Rightarrow> 'a set set \<Rightarrow> bool"
where
  "partition_on A P \<longleftrightarrow> \<Union>P = A \<and> disjoint P \<and> {} \<notin> P"

lemma partition_onI:
  "\<Union>P = A \<Longrightarrow> (\<And>p q. p \<in> P \<Longrightarrow> q \<in> P \<Longrightarrow> p \<noteq> q \<Longrightarrow> disjnt p q) \<Longrightarrow> {} \<notin> P \<Longrightarrow> partition_on A P"
  by (auto simp: partition_on_def pairwise_def)

lemma partition_onD1: "partition_on A P \<Longrightarrow> A = \<Union>P"
  by (auto simp: partition_on_def)

lemma partition_onD2: "partition_on A P \<Longrightarrow> disjoint P"
  by (auto simp: partition_on_def)

lemma partition_onD3: "partition_on A P \<Longrightarrow> {} \<notin> P"
  by (auto simp: partition_on_def)

subsection \<open>Constructions of partitions\<close>

lemma partition_on_empty: "partition_on {} P \<longleftrightarrow> P = {}"
  unfolding partition_on_def by fastforce

lemma partition_on_space: "A \<noteq> {} \<Longrightarrow> partition_on A {A}"
  by (auto simp: partition_on_def disjoint_def)

lemma partition_on_singletons: "partition_on A ((\<lambda>x. {x}) ` A)"
  by (auto simp: partition_on_def disjoint_def)

lemma partition_on_transform:
  assumes P: "partition_on A P"
  assumes F_UN: "\<Union>(F ` P) = F (\<Union>P)" and F_disjnt: "\<And>p q. p \<in> P \<Longrightarrow> q \<in> P \<Longrightarrow> disjnt p q \<Longrightarrow> disjnt (F p) (F q)"
  shows "partition_on (F A) (F ` P - {{}})"
proof -
  have "\<Union>(F ` P - {{}}) = F A"
    unfolding P[THEN partition_onD1] F_UN[symmetric] by auto
  with P show ?thesis
    by (auto simp add: partition_on_def pairwise_def intro!: F_disjnt)
qed

lemma partition_on_restrict: "partition_on A P \<Longrightarrow> partition_on (B \<inter> A) ((\<inter>) B ` P - {{}})"
  by (intro partition_on_transform) (auto simp: disjnt_def)

lemma partition_on_vimage: "partition_on A P \<Longrightarrow> partition_on (f -` A) ((-`) f ` P - {{}})"
  by (intro partition_on_transform) (auto simp: disjnt_def)

lemma partition_on_inj_image:
  assumes P: "partition_on A P" and f: "inj_on f A"
  shows "partition_on (f ` A) ((`) f ` P - {{}})"
proof (rule partition_on_transform[OF P])
  show "p \<in> P \<Longrightarrow> q \<in> P \<Longrightarrow> disjnt p q \<Longrightarrow> disjnt (f ` p) (f ` q)" for p q
    using f[THEN inj_onD] P[THEN partition_onD1] by (auto simp: disjnt_def)
qed auto

subsection \<open>Finiteness of partitions\<close>

lemma finitely_many_partition_on:
  assumes "finite A"
  shows "finite {P. partition_on A P}"
proof (rule finite_subset)
  show "{P. partition_on A P} \<subseteq> Pow (Pow A)"
    unfolding partition_on_def by auto
  show "finite (Pow (Pow A))"
    using assms by simp
qed

lemma finite_elements: "finite A \<Longrightarrow> partition_on A P \<Longrightarrow> finite P"
  using partition_onD1[of A P] by (simp add: finite_UnionD)

subsection \<open>Equivalence of partitions and equivalence classes\<close>

lemma partition_on_quotient:
  assumes r: "equiv A r"
  shows "partition_on A (A // r)"
proof (rule partition_onI)
  from r have "refl_on A r"
    by (auto elim: equivE)
  then show "\<Union>(A // r) = A" "{} \<notin> A // r"
    by (auto simp: refl_on_def quotient_def)

  fix p q assume "p \<in> A // r" "q \<in> A // r" "p \<noteq> q"
  then obtain x y where "x \<in> A" "y \<in> A" "p = r `` {x}" "q = r `` {y}"
    by (auto simp: quotient_def)
  with r equiv_class_eq_iff[OF r, of x y] \<open>p \<noteq> q\<close> show "disjnt p q"
    by (auto simp: disjnt_equiv_class)
qed

lemma equiv_partition_on:
  assumes P: "partition_on A P"
  shows "equiv A {(x, y). \<exists>p \<in> P. x \<in> p \<and> y \<in> p}"
proof (rule equivI)
  have "A = \<Union>P" "disjoint P" "{} \<notin> P"
    using P by (auto simp: partition_on_def)
  then show "refl_on A {(x, y). \<exists>p\<in>P. x \<in> p \<and> y \<in> p}"
    unfolding refl_on_def by auto
  show "trans {(x, y). \<exists>p\<in>P. x \<in> p \<and> y \<in> p}"
    using \<open>disjoint P\<close> by (auto simp: trans_def disjoint_def)
qed (auto simp: sym_def)

lemma partition_on_eq_quotient:
  assumes P: "partition_on A P"
  shows "A // {(x, y). \<exists>p \<in> P. x \<in> p \<and> y \<in> p} = P"
  unfolding quotient_def
proof safe
  fix x assume "x \<in> A"
  then obtain p where "p \<in> P" "x \<in> p" "\<And>q. q \<in> P \<Longrightarrow> x \<in> q \<Longrightarrow> p = q"
    using P by (auto simp: partition_on_def disjoint_def)
  then have "{y. \<exists>p\<in>P. x \<in> p \<and> y \<in> p} = p"
    by (safe intro!: bexI[of _ p]) simp
  then show "{(x, y). \<exists>p\<in>P. x \<in> p \<and> y \<in> p} `` {x} \<in> P"
    by (simp add: \<open>p \<in> P\<close>)
next
  fix p assume "p \<in> P"
  then have "p \<noteq> {}"
    using P by (auto simp: partition_on_def)
  then obtain x where "x \<in> p"
    by auto
  then have "x \<in> A" "\<And>q. q \<in> P \<Longrightarrow> x \<in> q \<Longrightarrow> p = q"
    using P \<open>p \<in> P\<close> by (auto simp: partition_on_def disjoint_def)
  with \<open>p\<in>P\<close> \<open>x \<in> p\<close> have "{y. \<exists>p\<in>P. x \<in> p \<and> y \<in> p} = p"
    by (safe intro!: bexI[of _ p]) simp
  then show "p \<in> (\<Union>x\<in>A. {{(x, y). \<exists>p\<in>P. x \<in> p \<and> y \<in> p} `` {x}})"
    by (auto intro: \<open>x \<in> A\<close>)
qed

lemma partition_on_alt: "partition_on A P \<longleftrightarrow> (\<exists>r. equiv A r \<and> P = A // r)"
  by (auto simp: partition_on_eq_quotient intro!: partition_on_quotient intro: equiv_partition_on)

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_67
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun len :: "'a list => Nat" where
  "len (nil2) = Z"
| "len (cons2 y xs) = S (len xs)"

fun butlast :: "'a list => 'a list" where
  "butlast (nil2) = nil2"
| "butlast (cons2 y (nil2)) = nil2"
| "butlast (cons2 y (cons2 x2 x3)) =
     cons2 y (butlast (cons2 x2 x3))"

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

theorem property0 :
  "((len (butlast xs)) = (t2 (len xs) (S Z)))"
  oops

end


theory Ranges imports Main
begin

(* representation of (disjunctions of) ranges of natural numbers, inclusive *)
type_synonym ranges' = "(nat * nat) list"

fun ranges'_valid_sub :: "nat \<Rightarrow> ranges' \<Rightarrow> bool" where
"ranges'_valid_sub _ [] = True"
| "ranges'_valid_sub x ((n1, n2)#t) =
   (x \<le> n1 \<and> n1 < n2 \<and> ranges'_valid_sub n2 t)"

(*
fun ranges'_valid :: "ranges' \<Rightarrow> bool" where
"ranges'_valid [] = True"
| "ranges'_valid [(n1, n2)] = (n1 < n2)"
| "ranges'_valid ((n1, n2)#(m1, m2)#t) =
   (n1 < n2 \<and> n1 \<le> m1 \<and> ranges'_valid ((m1, m2)#t))"
*)

fun ranges'_valid :: "ranges' \<Rightarrow> bool" where
"ranges'_valid rg = (ranges'_valid_sub 0 rg)"

typedef ranges =
  "{l :: ranges' . ranges'_valid l}"
proof
  show "[] \<in> {l. ranges'_valid l}" by auto
qed
setup_lifting type_definition_ranges

lift_definition rg_empty :: ranges is "[]" by auto

fun range_ranges' :: "nat \<Rightarrow> nat \<Rightarrow> ranges'" where
"range_ranges' n1 n2 =
  (if n1 < n2 then [(n1, n2)] else [])"

fun mk_ranges'_sub :: "nat \<Rightarrow> ranges' \<Rightarrow> ranges'" where
"mk_ranges'_sub _ [] = []"
| "mk_ranges'_sub x ((n1, n2)#t) =
   (if (x \<le> n1) then
    (if (n1 < n2) then (n1, n2)#mk_ranges'_sub n2 t
     else mk_ranges'_sub x t)
    else mk_ranges'_sub x t)"

fun mk_ranges' :: "ranges' \<Rightarrow> ranges'" where
"mk_ranges' l = mk_ranges'_sub 0 l"

(*
lemma mk_ranges'_tl :
  assumes H : "ranges'_valid (h#t)"
  shows "ranges'_valid t" using assms
proof(induction t arbitrary: h)
  case Nil
  then show ?case by auto
next
  case (Cons n t)
  obtain h1 h2 where Hh : "h = (h1, h2)" by(cases h; auto)
  obtain n1 n2 where N : "n = (n1, n2)" by(cases n; auto)
  then show ?case  using Cons Hh
    by(auto)
qed
*)
lemma ranges'_sub_valid_tl :
  assumes H : "ranges'_valid_sub x ((n1, n2)#t)"
  shows "ranges'_valid_sub n2 t" using H
  by(auto)

lemma mk_ranges'_sub_valid :
  "ranges'_valid_sub x (mk_ranges'_sub x l)"
proof(induction l arbitrary: x)
case Nil
then show ?case by auto
next
  case (Cons n t)
  obtain n1 n2 where N: "n = (n1, n2)" by (cases n; auto)
  show ?case
  proof(cases t)
  case Nil' : Nil
    then show ?thesis using Cons Nil' N by auto
  next
    case Cons' : (Cons m t')
    obtain m1 m2 where M : "m = (m1, m2)" by(cases m; auto)
    show ?thesis using Cons Cons' N M by(auto)
  qed
qed

lemma mk_ranges'_valid : "ranges'_valid (mk_ranges' l)"
  using mk_ranges'_sub_valid by auto

lift_definition mk_ranges :: "ranges' \<Rightarrow> ranges" is mk_ranges'
  using mk_ranges'_valid by auto

fun set_of_ranges' :: "ranges' \<Rightarrow> nat set" where
"set_of_ranges' [] = {}"
| "set_of_ranges' ((n1, n2)#m) =
   {n1..<n2} \<union> set_of_ranges' m"

(* TODO: are we handling the no overlap cases correctly? *)
fun union_ranges' :: "ranges' \<Rightarrow> ranges' \<Rightarrow> ranges'"
  where
"union_ranges' [] [] = []"
| "union_ranges' ((l1, l2)#lt) [] = ((l1, l2)#lt)"
| "union_ranges' [] ((r1, r2)#rt) = ((r1, r2)#rt)"
| "union_ranges' ((l1, l2)#lt) ((r1, r2)#rt) =
   (if l1 < r1
    then
      (if l2 < r1
       then \<comment> \<open>no overlap, l2 < r1\<close>
         (l1, l2) # union_ranges' lt ((r1, r2)#rt)
       else (if l2 < r2
             then \<comment> \<open>merge, l2 < r2\<close>
               union_ranges' lt ((l1, r2) # rt)
             else \<comment> \<open>l subsumes r\<close>
               union_ranges' ((l1, l2)#lt) rt))
    else
      (if r2 < l1
       then \<comment> \<open>no overlap, r2 < l1\<close>
         (r1, r2) # union_ranges' ((l1, l2)#lt) rt
       else (if r2 < l2
             then \<comment> \<open>merge, r2 < l2\<close>
               union_ranges' ((r1, l2)#lt) rt
             else \<comment> \<open>r subsumes l\<close>
               union_ranges' lt ((r1, r2)#rt))))"

(* TODO: make sure we are handling edge cases correctly. *)

fun diff_ranges' :: "ranges' \<Rightarrow> ranges' \<Rightarrow> ranges'" where
"diff_ranges' [] _ = []"
| "diff_ranges' ((l1, l2)#lt) [] = ((l1, l2)#lt)"
| "diff_ranges' ((l1, l2)#lt) ((r1, r2)#rt) =
   (if l1 < r1
    then
      (if l2 < r1
       then \<comment> \<open>no overlap, l2 < r1\<close>
         (l1, l2) # diff_ranges' lt ((r1, r2)#rt)
       else (if l2 < r2
             then \<comment> \<open>clip between r1 and l2\<close>
               (l1, r1) # diff_ranges' lt ((r1, r2) # rt)
             else \<comment> \<open>l subsumes r, clip between r1 and r2\<close>
               (if l2 > r2 then (l1, r1) # diff_ranges' ((r2, l2)#lt) rt
                           else (l1, r1) # diff_ranges' lt rt)))
    else
      (if r2 < l1
       then \<comment> \<open>no overlap, r2 < l1\<close>
         diff_ranges' ((l1, l2)#lt) rt
       else (if r2 < l2
             then \<comment> \<open>clip between, l1 and r2\<close>
                diff_ranges' ((r2, l2)#lt) (rt)
             else \<comment> \<open>r subsumes l, complete deletion\<close>
                diff_ranges' lt ((r1, r2)#rt))))
    "

lift_definition set_of_ranges :: "ranges \<Rightarrow> nat set" is set_of_ranges' .

fun member_ranges' :: "nat \<Rightarrow> ranges' \<Rightarrow> bool" where
"member_ranges' x [] = False"
| "member_ranges' x ((n1, n2)#t) =
   (if x < n2
    then
      (if x < n1 then False else True)
    else
      member_ranges' x t)"

lift_definition member_ranges :: "nat \<Rightarrow> ranges \<Rightarrow> bool" is member_ranges' .

lemma member_ranges'_spec :
  assumes H : "ranges'_valid r"
  shows "member_ranges' x r = ( x \<in> set_of_ranges' r)" using assms
proof(induction r arbitrary: x)
  case Nil
  then show ?case by auto
next
  case (Cons n r)
  obtain n1 n2 where N: "n = (n1, n2)" by(cases n; auto)
  show ?case
  proof(cases r)
    case Nil' : Nil
    then show ?thesis using Cons N
      by(auto)
    next
      case Cons' : (Cons m r')
      obtain m1 m2 where M: "m = (m1, m2)" by(cases m; auto)
      show ?thesis  using Cons.prems Cons.IH[of x] Cons' N M
        by(auto)
    qed
qed

lemma member_ranges_spec :
  "member_ranges x r = (x \<in> set_of_ranges r)"
proof(transfer)
  show "\<And>x r. ranges'_valid r \<Longrightarrow> member_ranges' x r = (x \<in> set_of_ranges' r)"
    using member_ranges'_spec by auto
qed
(*
lemma ranges'_valid_sub_alt1 :
  "ranges'_valid_sub x r \<Longrightarrow>
   (\<exists>!
*)

(*
lemma union_ranges'_valid'  :
  assumes H1 : "ranges'_valid_sub x l"
  assumes H2 : "ranges'_valid_sub x' r"
  assumes H3 : "u = union_ranges' l r"
  shows "ranges'_valid_sub (min x x') u" using assms
proof(induction u arbitrary: x x' l r)
  case Nil
  then show ?case
    by(auto)
next
  case (Cons ua u)
  obtain ua1 ua2 where Ua : "ua = (ua1, ua2)" by(cases ua; auto)
  show ?case
  proof(cases l)
    case Nil_l : Nil
    then show ?thesis
    proof(cases r)
      case Nil_r : Nil
      then show ?thesis
        using Cons Nil_l by(auto)
    next
      case Cons_r : (Cons ra r')
      obtain ra1 ra2 where Ra : "ra = (ra1, ra2)" by(cases ra; auto)
      show ?thesis using Cons Nil_l Cons_r Ra by(auto)
    qed
  next
    case Cons_l : (Cons la l')
    obtain la1 la2 where La : "la = (la1, la2)" by(cases la; auto)
    show ?thesis
    proof(cases r)
      case Nil_r : Nil
      then show ?thesis
        using Cons Cons_l La by auto
    next
      case Cons_r : (Cons ra r')
      obtain ra1 ra2 where Ra : "ra = (ra1, ra2)" by(cases ra; auto)
      show ?thesis
      proof(cases "la1 < ra1")
        case T : True
        then show ?thesis
        proof(cases "la2 < ra1")
          case TT : True
          then show ?thesis
            using Cons.prems Cons_l Cons_r La Ra T TT Cons.IH[of la2 l' ra1 "(ra1, ra2) # r'"]
            by(auto simp add: min_def)
        next
          case TF : False
          then show ?thesis
          proof(cases "la2 < ra2")
            case TFT : True
            then show ?thesis using Cons.prems  Ua Cons_l Cons_r La Ra T TF
                 Cons.IH
              apply(auto)
          next
            case TFF : False
            then show ?thesis using Cons.prems Cons' La Ra T TF Cons.IH
              apply(auto)
          qed
        qed
      next
        case F : False
        then show ?thesis
        proof(cases "ra2 < la1")
          case FT : True
          then show ?thesis sorry
        next
          case FF : False
          then show ?thesis
          proof(cases "ra2 < la2")
          case FFT : True
            then show ?thesis sorry
          next
            case FFF : False
            then show ?thesis
            using Cons.prems  Cons' La Ra F FF Cons.IH[OF Vl, of "min x x'" r]
              by(auto simp add: min_def)
          qed
        qed
      qed
    qed

    qed

  qed

  show ?case using Cons
    apply(cases l; auto)

qed
*)

(*
lemma either_list_induct :
  assumes N : "P [] []"
  assumes C1 : "\<And> v l r . P l r \<Longrightarrow> P (v#l) r"
  assumes C2 : "\<And> v l r . P l r \<Longrightarrow> P l (v#r)"
  assumes C3 : "\<And> vl vr l r . P l r \<Longrightarrow> P (vl#l) (vr#r)"
  shows "P l1 l2" using assms
proof(induction l1 arbitrary: P l2)
  case Nil1 : Nil
  then show ?case
  proof(induction x )
    case Nil2 : Nil
    then show ?case by auto
  next
    case Cons2 : (Cons a2 l2)
    then show ?case using Nil1
      by(auto)
  qed
next
  case Cons1 : (Cons a1 l1)
  show ?case using Cons1.prems
  proof(induction x )
    case Nil2 : Nil
    show ?case using Cons1.IH[of P] Cons1.prems
      by(auto)
  next
    case Cons2 : (Cons a2 l2)
    then show ?case by(auto)
  qed
qed
*)
(*
lemma either_list_induct :
  assumes N : "P [] []"
  assumes C1 : "\<And> vl vr l r . P l r \<Longrightarrow> P (vl#l) r \<and> P l (vr#r) \<and> P (vl#l) (vr#r)"
  shows "P l1 l2" using assms
proof(induction l1 arbitrary: P l2)
  case Nil1 : Nil
  then show ?case
  proof(induction x )
    case Nil2 : Nil
    then show ?case by auto
  next
    case Cons2 : (Cons vr r)
    then show ?case using Nil1
      by(auto)
  qed
next
  case Cons1 : (Cons a1 l1)
  show ?case using Cons1.prems
  proof(induction x )
    case Nil2 : Nil
    show ?case using Cons1.IH[of P] Cons1.prems
      by(auto)
  next
    case Cons2 : (Cons a2 l2)
    then show ?case by(auto)
  qed
qed

lemma union_ranges'_valid :
  assumes H1 : "ranges'_valid_sub x l"
  assumes H2 : "ranges'_valid_sub x' r"
  shows "ranges'_valid_sub (min x x') (union_ranges' l r)" using assms
proof(induction l r arbitrary: x x'  rule: either_list_induct)
  case 1
  then show ?case by auto
next
  case (2 la ra l r)
  obtain la1 la2 where La : "la = (la1, la2)" by(cases la; auto)
  obtain ra1 ra2 where Ra : "ra = (ra1, ra2)" by(cases ra; auto)
  show ?case
  proof(cases "la1 < ra1")
    case T : True
    show ?thesis
    proof(cases "la2 < ra1")
      case TT : True
      show ?thesis
      proof(step+)
        fix x xa
        assume Vl : "ranges'_valid_sub x (la # l)"
        assume Vr : "ranges'_valid_sub xa r"
        show "ranges'_valid_sub (min x xa) (union_ranges' (la # l) r)"
          using Vl Vr T TT La Ra "2.prems" "2.IH"[of la2 xa]
          apply(auto)
      next
        case TF : False
        then show ?thesis
        proof(cases "la2 < ra2")
          case TFT : True
          then show ?thesis sorry
        next
          case TFF : False
          then show ?thesis using "2.prems" Cons La Ra T TF "2.IH"[of la2]
            apply(auto)
        qed
      qed
    next
      case F : False
      then show ?thesis
      proof(cases "ra2 < la1")
        case FT : True
        then show ?thesis sorry
      next
        case FF : False
        then show ?thesis
        proof(cases "ra2 < la2")
        case FFT : True
          then show ?thesis sorry
        next
          case FFF : False
          then show ?thesis
          using Cons.prems  Cons' La Ra F FF Cons.IH[OF Vl, of "min x x'" r]
            by(auto simp add: min_def)
        qed
      qed
    qed
  qed
qed

  proof(cases r)
    case Nil
    then show ?thesis using 2 La by(auto)
  next
    case (Cons ra ra')
    obtain ra1 ra2 where Ra : "ra = (ra1, ra2)" by(cases ra; auto)
    show ?thesis
    proof(cases "la1 < ra1")
      case T : True
      then show ?thesis
      proof(cases "la2 < ra1")
        case TT : True
        show ?thesis
          using "2.prems" Cons La Ra T TT "2.IH"[of la2 ra1]
          by(auto simp add: min_def)
      next
        case TF : False
        then show ?thesis
        proof(cases "la2 < ra2")
          case TFT : True
          then show ?thesis sorry
        next
          case TFF : False
          then show ?thesis using "2.prems" Cons La Ra T TF "2.IH"[of la2]
            apply(auto)
        qed
      qed
    next
      case F : False
      then show ?thesis
      proof(cases "ra2 < la1")
        case FT : True
        then show ?thesis sorry
      next
        case FF : False
        then show ?thesis
        proof(cases "ra2 < la2")
        case FFT : True
          then show ?thesis sorry
        next
          case FFF : False
          then show ?thesis
          using Cons.prems  Cons' La Ra F FF Cons.IH[OF Vl, of "min x x'" r]
            by(auto simp add: min_def)
        qed
      qed
    qed
  qed
qed

    qed
    apply(auto)
next
  case (3 ra r)
  obtain ra1 ra2 where Ra : "ra = (ra1, ra2)" by(cases ra; auto)
  then show ?case using 3 Ra by auto
next
  case (4 la l ra r)
  obtain la1 la2 where La : "la = (la1, la2)" by(cases la; auto)
  obtain ra1 ra2 where Ra : "ra = (ra1, ra2)" by(cases ra; auto)

  then show ?case using 4
  qed
*)

(*
ranges'_valid_sub z (union_ranges' l r)
ranges'_valid_sub (min x x') (union_ranges' ((la1, la2) # l) r')
*)

(*
lemma union_ranges'_valid :
  assumes H1 : "ranges'_valid_sub x (l)"
  assumes H2 : "ranges'_valid_sub x' r"
  shows "ranges'_valid_sub (min x x') (union_ranges' (lp@l) r)" using assms
proof(induction l arbitrary: lp r x x')
*)

lemma ranges'_valid_sub_weaken :
  assumes H : "ranges'_valid_sub x l"
  assumes Hleq : "x' \<le> x"
  shows "ranges'_valid_sub x' l" using assms
proof(induction l arbitrary: x x')
  case Nil
  then show ?case by auto
next
  case (Cons a l)
  obtain a1 a2 where A: "a = (a1, a2)" by (cases a; auto)
  show ?case using Cons A
    by(auto)
qed

lemma union_ranges'_valid :
  assumes H1 : "ranges'_valid_sub x l"
  assumes H2 : "ranges'_valid_sub x' r"
  shows "ranges'_valid_sub (min x x') (union_ranges' l r)" using assms
proof(induction l r arbitrary: x x' rule: union_ranges'.induct)
  case 1
  then show ?case by auto
next
  case (2 l1 l2 lt)
  then show ?case
    by(auto)
next
  case (3 r1 r2 rt)
  then show ?case
    by(auto)
next
  case (4 l1 l2 lt r1 r2 rt)
  show ?case
  proof(cases "l1 < r1")
    case T : True
    then show ?thesis
    proof(cases "l2 < r1")
      case TT : True
      then show ?thesis
        using "4.prems" "4.IH"(1)[OF T TT, of l2 r1]
        by(auto simp add: min_def)
    next
      case TF : False
      then show ?thesis
      proof(cases "l2 < r2")
        case TFT : True
        show ?thesis using T TF TFT "4.prems" "4.IH"(2)[of l2 "min x x'"]
          by(auto simp add: min_def)
      next
        case TFF : False

        have "x' \<le> r2" using T TF TFF "4.prems" by auto
        hence "ranges'_valid_sub x' rt"
          using T TF TFF "4.prems" ranges'_valid_sub_weaken
          by(auto)

        then show ?thesis using T TF TFF "4.prems" "4.IH"(3)[of x x']
          by(auto)
      qed
    qed
  next
    case F : False
    then show ?thesis
    proof(cases "r2 < l1")
      case FT : True
      then show ?thesis using F FT "4.prems" "4.IH"(4)[of l1 r2]
        by(auto simp add: min_def )
    next
      case FF : False
      then show ?thesis
      proof(cases "r2 < l2")
      case FFT : True
        then show ?thesis
        using F FF "4.prems" "4.IH"(5)[of "min x x'" r2] by(auto simp add: min_def)
      next
        case FFF : False

        have "x \<le> l2" using F FF FFF "4.prems" by auto
        hence "ranges'_valid_sub x lt"
          using F FF FFF "4.prems" ranges'_valid_sub_weaken
          by(auto)

        then show ?thesis using F FF FFF "4.prems" "4.IH"(6)[of x x']
          by(auto)
      qed
    qed
  qed
qed

lift_definition union_ranges :: "ranges \<Rightarrow> ranges \<Rightarrow> ranges" is union_ranges'
  using union_ranges'_valid[of 0 _ 0] by auto

(* maybe we can do without induction? *)
lemma union_ranges'_spec :
  assumes Vl : "ranges'_valid_sub x l"
  assumes Vr : "ranges'_valid_sub x' r"
  shows "set_of_ranges' (union_ranges' l r) =
         set_of_ranges' l \<union> set_of_ranges' r" using assms
proof(induction l r arbitrary: x x' rule: union_ranges'.induct)
  case 1
  then show ?case by auto
next
  case (2 l1 l2 lt)
  then show ?case by auto
next
  case (3 r1 r2 rt)
  then show ?case by auto
next
  case (4 l1 l2 lt r1 r2 rt)
  then show ?case
    by(auto)
qed

lemma union_ranges_spec :
  "set_of_ranges (union_ranges l r) =
   set_of_ranges l \<union> set_of_ranges r"
  using union_ranges'_spec
  by(transfer; auto)

lemma ranges'_valid_sub_set :
  assumes H : "ranges'_valid_sub x r"
  assumes Helm : "n \<in> set_of_ranges' r"
  shows "x \<le> n" using assms
proof(induction r arbitrary: n x)
  case Nil
  then show ?case by auto
next
  case (Cons a r)
  obtain a1 a2 where A: "a = (a1, a2)" by(cases a; auto)
  then show ?case using Cons.prems Cons.IH[of a2 n]
    by(auto)
qed

lemma set_diff_fact1 :
  assumes H : "A \<inter> C = {}"
  shows "A \<union> (B - C) = (A \<union> B) - C" using assms
  by(blast)

lemma diff_ranges'_valid :
  assumes H1 : "ranges'_valid_sub x l"
  assumes H2 : "ranges'_valid_sub x' r"
  shows "ranges'_valid_sub x (diff_ranges' l r)" using assms
proof(induction l r arbitrary: x x' rule: diff_ranges'.induct)
  case (1 uu)
  then show ?case by auto
next
  case (2 l1 l2 lt)
  then show ?case by auto
next
  case (3 l1 l2 lt r1 r2 rt)
  then show ?case
  proof(cases "l1 < r1")
    case T : True
    show ?thesis
    proof(cases "l2 < r1")
      case TT : True
      show ?thesis using T TT "3.prems" "3.IH"(1)
        by(auto)
    next
      case TF : False
      show ?thesis
      proof(cases "l2 < r2")
        case TFT : True
        show ?thesis using T TF TFT "3.prems" "3.IH"(2)[of r1 x']
            ranges'_valid_sub_weaken
          by(auto)
      next
        case TFF : False
        show ?thesis
        proof(cases "l2 > r2")
          case TFFT : True
          then show ?thesis using T TF TFF TFFT
              "3.prems" "3.IH"(3) ranges'_valid_sub_weaken
            by(auto)
        next
          case TFFF: False
          show ?thesis using T TF TFF TFFF "3.prems" "3.IH"(4)
              ranges'_valid_sub_weaken
            by(auto)
        qed
      qed
    qed
  next
    case F :False
    show ?thesis
    proof(cases "r2 < l1")
      case FT : True
      show ?thesis using F FT "3.prems" "3.IH"(5)
        by(fastforce)
    next
      case FF : False
      then show ?thesis
      proof(cases "r2 < l2")
        case FFT : True
        show ?thesis using F FF FFT "3.prems" "3.IH"(6) ranges'_valid_sub_weaken
          by(auto)
      next
        case FFF: False
        show ?thesis using F FF FFF "3.prems" "3.IH"(7) ranges'_valid_sub_weaken
          by(auto)
      qed
    qed
  qed
qed

lift_definition diff_ranges :: "ranges \<Rightarrow> ranges \<Rightarrow> ranges" is diff_ranges'
  using diff_ranges'_valid ranges'_valid_sub_weaken[of _ _ 0]
  by auto

lemma diff_ranges'_spec :
  assumes Vl : "ranges'_valid_sub x l"
  assumes Vr : "ranges'_valid_sub x' r"
  shows "set_of_ranges' (diff_ranges' l r) =
         (set_of_ranges' l - set_of_ranges' r)" using assms
proof(induction l r arbitrary: x x' rule: diff_ranges'.induct)
  case 1
  then show ?case by auto
next
  case (2 l1 l2 lt)
  then show ?case by auto
next
  case (3 l1 l2 lt r1 r2 rt)
  show ?case
  proof(cases "l1 < r1")
    case T : True
    show ?thesis
    proof(cases "l2 < r1")
      case TT : True

      show ?thesis using T TT "3.prems" "3.IH"(1) ranges'_valid_sub_set[of r2 rt]
        by(fastforce)
    next
      case TF : False
      show ?thesis
      proof(cases "l2 < r2")
        case TFT : True
        show ?thesis using T TF TFT "3.prems" "3.IH"(2) ranges'_valid_sub_set[of r2 rt]
          by(fastforce)
      next
        case TFF : False
        show ?thesis
        proof(cases "l2 > r2")
          case TFFT : True
          then show ?thesis using T TF TFF TFFT
              "3.prems" "3.IH"(3) ranges'_valid_sub_set
            by(fastforce)
        next
          case TFFF: False
          show ?thesis using T TF TFF TFFF "3.prems" "3.IH"(4)
              ranges'_valid_sub_set[of r2 lt] ranges'_valid_sub_set[of r2 rt]
            by(fastforce)
        qed
      qed
    qed
  next
    case F :False
    show ?thesis
    proof(cases "r2 < l1")
      case FT : True
      show ?thesis using F FT "3.prems" "3.IH"(5) ranges'_valid_sub_set[of l2 lt]
        by(fastforce)
    next
      case FF : False
      then show ?thesis
      proof(cases "r2 < l2")
        case FFT : True
        show ?thesis using F FF FFT "3.prems" "3.IH"(6) ranges'_valid_sub_set
          by(fastforce)
      next
        case FFF: False
        show ?thesis using F FF FFF "3.prems" "3.IH"(7) ranges'_valid_sub_set
          by(fastforce)
      qed
    qed
  qed
qed

fun Union_ranges :: "ranges list \<Rightarrow> ranges" where
"Union_ranges [] = rg_empty"
| "Union_ranges (h#t) =
   union_ranges h (Union_ranges t)"

lemma set_of_ranges_empty :
  "set_of_ranges rg_empty = {}"
  by(transfer; auto)

lemma Union_ranges_spec :
  "set_of_ranges (Union_ranges R) =
  \<Union> (set (map set_of_ranges R))"
proof(induction R)
case Nil
  then show ?case by(auto simp add: set_of_ranges_empty)
next
  case (Cons a R)
  then show ?case using union_ranges_spec
    by(simp)
qed

lemma Union_ranges_cases :
  assumes H0 : "\<And> x r . r \<in> set rs \<Longrightarrow> member_ranges x r \<Longrightarrow> P x"
  assumes H : "member_ranges y (Union_ranges rs)"
  shows "P y"
proof-
  have H' : "y \<in> set_of_ranges (Union_ranges rs)"
    using H unfolding member_ranges_spec by auto

  have H'' : "y \<in> \<Union> (set (map set_of_ranges rs))"
    using H' unfolding Union_ranges_spec by auto

  show "P y" using UnionE[OF H''] H0
    unfolding member_ranges_spec
    by(auto)
qed

fun set_of_ranges_alt' :: "ranges' \<Rightarrow> nat set" where
"set_of_ranges_alt' [] = {}"
| "set_of_ranges_alt' ((n1, n2)#m) =
   set (List.upt n1 n2) \<union> set_of_ranges_alt' m"

lemma set_of_ranges_alt'_spec :
  "set_of_ranges' r = set_of_ranges_alt' r"
proof(induction r)
  case Nil
  then show ?case by auto
next
  case (Cons a r)
  then show ?case
    by(cases a; auto)
qed

lift_definition set_of_ranges_alt :: "ranges \<Rightarrow> nat set" is "set_of_ranges_alt'" .

lemma set_of_ranges_alt_spec :
"set_of_ranges r = set_of_ranges_alt r"
  by(transfer; auto simp add: set_of_ranges_alt'_spec)

(* isabelle's automation seems to be doing some annoying things with
integer ranges once we start taking unions... *)
(*
fun set_of_ranges_alt2 :: "ranges' \<Rightarrow> nat set"
*)

end


header {* $\AA$: the logic of All p are q --- Section2.thy*}

theory Section2
imports Main "~~/src/HOL/Library/Order_Relation"

begin

subsection {* Syntax and Semantics --- Types and Definitions in Isabelle *}

text {* In this section we are going to formalize the proofs of Section 2 of the Lecture Notes.
Therefore, we need to find a datatype of formulas of the kind
\pftext{All p are q} and in order to do this we even need to first define a datatype of atomic
propositions \pf{p,q,\ldots}. After we have done this, we can define the semantics of such formulas
in a model, we can implement the derivability relation and proof soundness and completeness.*}

text {*  The set of atomic propositions is formalized as a
  type.\footnote{ See \cite[p.173]{tutorial:isabellehol} for further explanations
  on \texttt{typedecl}.}
  % actually lots of questions when looking at p.119
  Roughly speaking types are sets as known from set theory,
  but there are some differences. Making good use of types is one of
  the things one has to learn using Isabelle/HOL. For example,
  formalizing atomic proposition as a type imposes a constraint
  on the set of propositions:

\specialbox{Types in Isabelle are non-empty.}

*}

typedecl atProp

text {* Next we use the \pf{\bf datatype} declaration to define formulas.
  \pftext{All} is called a constructor, which can be considered as
  a function that takes two arguments of type \pftext{atProp} and produces
  an element of type \pftext{formula}. The addition \pftext{\ep{All \_ are \_ }}
  is optional,
  but allows us to write, as in the   lecture notes,
  \pf{All p are q} instead of \pf{All p q}. *}

datatype formula = All atProp atProp ("All _ are _ ")
(* (* print theorems screws up (to some extent) the document preparation *)
print_theorems
*)

text {*  Inductively defined sets are best formalized using the datatype
  declaration, for example, because Isabelle then provides inbuilt
  support for induction. The \pf{\bf print-theorems} command is not necessary,
  but if you move your mouse over it in Isabelle you can see
  which theorems you get for free by using the datatype declaration.
  For example
{\footnotesize
\begin{verbatim}
  formula.eq.simps:
    equal_class.equal All ?atProp1 are ?atProp2 All ?atProp1' are ?atProp2'
    \<equiv> ?atProp1 = ?atProp1' \<and> ?atProp2 = ?atProp2'
\end{verbatim}
}
says that two formulas are equal iff their respective atomic propositions are
equal.\footnote{See \cite[Section 8.5.2]{tutorial:isabellehol}
(and in particular p.176) and
\cite[Section 2.4]{tutorial:datatypes} for more details.} *}

text {*  The next definition describes models over a carrier as models parametric
  in an an aribrary (non-empty) type
  called \pftext{\primea}. The arrow \pftext{$\Rightarrow$} and \pftext{set} are
  type constructors, where \pftext{set} is the type
  of all subsets of \pftext{\primea} and \pftext{$\Rightarrow$}
  constructs the type of all
  set-theoretic functions. To summarize, a model over \pf{\primea}
  is a function from atomic propositions to the powerset of \pf{\primea},
  that is, it is
  an element of the type \pftext{\ep{atProp $\Rightarrow$ \primea\  set}},
  for which we
  introduce the abbreviation\footnote{See \cite[p.24]{tutorial:isabellehol} for more
on \texttt{type\_synonym}.} *}

type_synonym 'a model = "(atProp \<Rightarrow>'a set)"

text {* In particular, the notion of model above cannot have empty carrier. Alternatively,
  we could have defined a model over \pf{$'a$} as a pair of a possible
  empty subset of \pf{$'$a} and a function
  \pftext{\ep{atProp $\Rightarrow$ \primea\  set}}
  but then we would need an extra condition to make sure that
  the image of the function lies inside that carrier.
  In other words, we  get the additional
  complication of
  specifying the well formed models among the premodels as in *}

type_synonym 'a pre_model = "'a set \<times> (atProp \<Rightarrow> 'a set)"
definition wf_model :: "'a pre_model \<Rightarrow> bool"
  where "wf_model M \<equiv> let (M,f) = M in (! p. f p \<subseteq> M)"

text {* In the following we will only use the first alternative and
  not make use of pre-model and wf-model. *}

text {* The lecture notes continue with the definition of satisfiability
  \begin{qcolor}
  $$\Model \models  \mbox{\sf All $p$ are $q$} \quadiff
    \semantics{p} \subseteq \semantics{q}
    $$
  \end{qcolor}
  which we formalize as follows.
*}

fun satisfies :: "'a model \<Rightarrow> formula \<Rightarrow> bool" ("_ \<Turnstile> _" )
where
  "satisfies M (All x are y) = (M x \<subseteq> M y)"

(* Do we want a discussion about fun and possible alternatives (see below)? *)

(*
definition satisfies :: "'a model \<Rightarrow> formula \<Rightarrow> bool" where
"satisfies M f \<equiv> case f of All x are y \<Rightarrow> (M x \<subseteq> M y)"
*)

(* definitions cant pattern match, because they are native HOL *)
(*
definition satisfies :: "'a model \<Rightarrow> formula \<Rightarrow> bool" where
"satisfies M (All x are y) \<equiv> (M x \<subseteq> M y)"
*)

text {* The lecture notes continue with the following example. *}

text{*
\begin{qcolor}
\textbf{Example.}
Let $\bP = \{n,p,q\}$. %(Hence $\AA$ has exactly nine sentences.)
Let $M = \{1,2, 3,4, 5\}$.
Let
$\semantics{n} = \emptyset$,
 $\semantics{p} = \{1,3, 4\}$,
 and $\semantics{q} = \{1,3\}$.
This specifies a model $\Model$.
The following sentences are
true in $\Model$:  {\sf All $n$ are $n$},
 {\sf All $n$ are $p$},
 {\sf All $n$ are $q$},    {\sf All $p$ are $p$}, {\sf All $q$ are $p$},
 and {\sf All $q$ are $q$}.
The other three sentences in $\AA$ are false in $\Model$.
\end{qcolor}
*}

text {*
The interesting   question is how to formalise the three ``let" statements above.
In particular, the ``let $M=\dots$'' is formalized differently than the other two.
The reason is that the carrier $M$ of the model is formalized as a
type parameter. Therefore we can instantiate it by defining a datatype: *}

datatype example_2_1 = e1 | e2 | e3 | e4 | e5

text {*The other two ``let" statements are translated as assumptions.
For the first one, note that \pftext{\ep{UNIV :: atProp set}} is the
Isabelle way of naming \pf{UNIV} as the largest set in \pf{atProp set},
that is, \pf{UNIV} is \pf{atProp} seen as a set. For the second note
that Isabelle infers the type of the carrier of $M$ upon reading
\pf{M p = \{e1,e3,e4\}}, the elements of which are elements of the
type \pf{example-2-1}. We can now formalize and prove the claims made
in the exercise.
*}

lemma example_2_1:
assumes "(UNIV :: atProp set) = {n,p,q} \<and> n\<noteq>p \<and> n\<noteq>q \<and> p\<noteq>q"
assumes "M n = {}  \<and>  M p = {e1,e3,e4}  \<and>  M q = {e1,e3}"
shows "M \<Turnstile> All n are n"
   and "M \<Turnstile>All n are p"
   and "M \<Turnstile>All n are q"
   and "M \<Turnstile> All p are p"
   and "M \<Turnstile> All q are p"
   and "M \<Turnstile> All q are q"
   and "\<not> (M \<Turnstile> All p are n)"
   and "\<not> (M \<Turnstile> All p are q)"
   and "\<not> (M \<Turnstile> All q are n)"
proof %invisible -
  show "M \<Turnstile> All n are n" by simp
  show "M \<Turnstile>All n are p" by (metis assms(2) empty_subsetI satisfies.simps)
  show "M \<Turnstile>All n are q" by (metis assms(2) bot.extremum satisfies.simps)
  show "M \<Turnstile> All p are p" by simp
  show "M \<Turnstile> All q are p" by (metis assms(2) insert_mono satisfies.simps subset_insertI)
  show "M \<Turnstile> All q are q" by simp
  show "\<not> (M \<Turnstile> All p are n)" by (metis assms(2) bot.extremum_unique insert_not_empty satisfies.simps)
  show "\<not> (M \<Turnstile> All p are q)" by (metis assms(2) empty_iff example_2_1.distinct(15) example_2_1.distinct(5) insert_iff insert_subset satisfies.simps)
  show "\<not> (M \<Turnstile> All q are n)" by (metis assms(2) insert_not_empty satisfies.simps subset_empty)
qed

text {* The proof of the 9 statements can be done
automatically using sledgehammer \cite{tutorial:sledgehammer}. Sledgehammer is an Isabelle command
that calls automatic
theorem provers, either locally installed or over the internet, in order to prove
the current goal. For us, sledgehammer is a crucial ingredient of Isabelle. It allows us to conduct
proofs close to the level of pen and paper mathematics. Whenever in these notes, or in the theory files,
 you see a \pf{{\bf by}\ep{metis \ldots}} this shows a proof found by sledgehammer.
Actually, for better readability of this document, we made most of these automatically found proofs invisible as can easily
be seen by comparing directly with the theory file.

\medskip We emphasize that the proofs \pf{{\bf by}\ep{metis \ldots}} are not meant to be readable
by humans. In our notes, they are usually proofs that are obvious on the mathematical level of
abstraction. On the other hand, if you know that such a proof depends on a particular fact
it is a good idea to check whether this fact is contained in the list of facts appearing in the
dots of a \pf{{\bf by}\ep{metis \ldots}}.
\marginpar[left text]{video}
*}

text {* The lecture notes continue with extending satisfiability to sets
  of formulas
\begin{qcolor}
\begin{center}
$\Model\models\Gamma$ iff $\Model\models \phi$ for every $\phi\in \Gamma$
\end{center}
\end{qcolor}

and to semantic entailment between sets of formulas and formulas
\begin{qcolor}
\begin{center}
$\Gamma\models \phi$ iff  for all $\Model$: if  $\Model\models \Gamma$,  then
also $\Model\models\phi$.
\end{center}
\end{qcolor}
which we formalize as follows.
\specialbox{Overloading names, although possible to a degree, is not
as easy in Isabelle as it is in pen and paper maths. For example,
comparing the definitions of \pf{satisfies} and \pf{M-satisfies-G}
one would think that, as they have different types, both could well
have the same name, or, at least, use the same notation $\models$.
But one problem here is that the parsing is done before the
type checking and ambiguous parse trees would result
(recommended experiment). So this is a point that requires
some compromise from the mathematician's perspective.}
 *}

definition M_satisfies_G :: "'a model \<Rightarrow> formula set \<Rightarrow> bool" ("_ \<Turnstile>M _")
where
  "M_satisfies_G M G  \<equiv> \<forall>f. f \<in> G \<longrightarrow> (M \<Turnstile> f)"

text {*
If we want to define semantic consequence or entailment, we want to say
that $G\models g$ iff $\forall M :: {'a} \textit{ model}.
M\models G \rightarrow M\models g$. Due to the free type variable
$'a$ we run into a slight technical difficulty. For reasons explained
in some detail in \cite{Arthan14}, every variable on the right of a
definition also needs to appear on the left.
So we could write, using a dummy term \pf{ty}, \ldots
*}

definition entails_b :: "formula set \<Rightarrow> formula \<Rightarrow> 'a \<Rightarrow> bool"
where
  "entails_b G f (ty::'a) \<equiv> \<forall> (M::'a model). (M \<Turnstile>M G) \<longrightarrow> (M \<Turnstile> f)"

text {* \dots but this definition has the disadvantage that it looks
as if the function \pf{entails} depended on values of type $'a$.
One way out is to use the ``type itself'' construction, which
provides a type depending on $'a$ with only element (this element is denoted by
TYPE($'a$) and we will encounter it later). More on the
itself type can be found in \cite{Wenzel97}.*}

definition entails :: "formula set \<Rightarrow> formula \<Rightarrow> 'a itself \<Rightarrow> bool" ("_ \<Turnstile>G _ _")
where
  "entails G f (ty::'a itself) \<equiv> \<forall> (M::'a model). (M \<Turnstile>M G) \<longrightarrow> (M \<Turnstile> f)"

(* can we show in Isabelle that an itself type has only one element? *)

(*
lemma itself_a:
shows "card( UNIV :: 'a itself set)=1"
oops
*)

(*
declare [[show_types]]

lemma itself_b:
fixes x y
assumes "x \<in> (UNIV :: 'a itself set)"
assumes "y \<in> (UNIV :: 'a itself set)"
shows "x=y"
find_theorems name:itself
using HOL.equal_itself_def
sorry

lemma itself_c:
assumes "x :: 'a itself set"
assumes "y :: 'a itself set"
shows "x=y"
*)

text {* \textbf{Further Reading. } For general background on Isabelle see Paulson's
original \cite{Paulson89} (in particular Section 1 and 2). \cite{Paulson89} also
gives a reason why types are assumed to be non-empty. In
 \cite[p.119]{tutorial:isabellehol} one can find a model checker as a worked out
example. *}

subsection {* Proof Theory --- Rules and Natural Deduction in Isabelle *}

text {*

The deductive system $\AA$ is given as

\begin{qcolor}
\begin{framed}
$$ \begin{array}{lcl}
\infer[\mbox{\sc Axiom}]{ \mbox{\sf  All  $p$  are  $p$ }}{}
& \qquad &
\infer[\mbox{\sc Barbara}]{ \mbox{\sf  All  $p$  are  $q$ }}{ \mbox{\sf  All  $p$  are  $n$}
&   \mbox{\sf  All  $n$ are  $q$ }}
\\
\end{array}
$$
\end{framed}
\end{qcolor}

which is formalized as follows. (The 0 in \pf{0\ $\vdash$\ -} is an
annotation to avoid overloading wrt to \pf{-\ $\vdash$\ -} in the
next definition.)
*}

inductive derivable :: "formula \<Rightarrow> bool" ("0\<turnstile> _")
where
  A_axiom: "0\<turnstile> (All X are X)"
| A_barbara: "\<lbrakk>0\<turnstile>(All X are Y); 0\<turnstile>(All Y are Z)\<rbrakk> \<Longrightarrow> 0\<turnstile>(All X are Z)"

text {*
\specialbox{
Isabelle implements natural deduction. The Isabelle notation for a rule of the
shape
$$\infer[\mbox{\it name}]{ \mbox{\sf  C}}{ \mbox{\sf  A}
&   \mbox{\sf  B}}$$
is $$\pftext{ name: $\semantics{A;B} \Longrightarrow$ \sf C}$$
as in the rules \pf{A-axiom} and \pf{A-barbara} above.
}
*}

text {* \specialbox{ Something about "inductive" } *}

text {* Let us look at how to reason in Isabelle using the natural
deduction rules. The following example is again from the lecture notes. *}

text {*
\begin{qcolor}
\textbf{Example. }
Let $\Gamma$ be
$$\set{ \mbox{\sf All $l$ are $m$},  \mbox{\sf All $q$ are $l$},
 \mbox{\sf All $m$ are $p$}, \mbox{\sf All $n$ are $p$},   \mbox{\sf All $l$ are $q$}}$$
Let $\phi$ be    {\sf All $q$ are $p$}.  Here is a proof tree showing that
$\Gamma\proves \phi$:
\begin{framed}
$$
\infer[\mbox{\sc Barbara}]{ \mbox{\sf All $q$ are $p$}}{  \mbox{\sf All $q$ are $l$} &
\infer[\mbox{\sc Barbara}]{ \mbox{\sf All $l$ are $p$}}{
\infer[\mbox{\sc Barbara}]{\mbox {\sf All $l$ are $m$}}{ \mbox{\sf All $l$ are $m$} &
\infer[\mbox{\sc Axiom}]{\mbox{\sf All $m$ are $m$}}{}}
&   \mbox{\sf All $m$ are $p$}}}
$$
\end{framed}
\end{qcolor}
The proof tree
can be implemented in Isabelle as follows.
*}

lemma example_2_5:
assumes "0\<turnstile>All l are m"
and "0\<turnstile>All q are l"
and "0\<turnstile>All m are p"
and "0\<turnstile>All n are p"
and "0\<turnstile>All l are q"
shows "0\<turnstile> All q are p"

apply (rule_tac Y=l in A_barbara)
 apply (rule assms(2))

 apply (rule_tac Y=m in A_barbara)
  apply (rule_tac Y=m in A_barbara)
   apply (rule assms(1))

   apply (rule A_axiom)
  apply (rule assms(3))
done

text {* Comparing the Isabelle proof with the paper proof, we see
that in Isabelle we reasoned backwards from the goal \pf{All q are p}.
The first \pf{{\bf apply} \ep{rule-tac Y=l in A-barbara}}, for example,
corresponds to the bottom application of the {\sc Barbara} rule.
\marginpar[left text]{video}
*}

text {* \specialbox{ here it would be good to have an
exercise for the reader } *}

text {* Later in the lecture notes we want to compare derivability from assumptions with
semantic entailment, so we define $\Gamma\vdash\phi$ as a variation of
the above $\vdash\phi$: *}

inductive derives :: "formula set \<Rightarrow> formula \<Rightarrow> bool" ("_ \<turnstile> _")
where
  A_assumption: "f \<in> hs \<Longrightarrow>  hs \<turnstile> f"
| A_axiom: "hs \<turnstile> (All X are X)"
| A_barbara: "\<lbrakk>hs \<turnstile>(All X are Y); hs \<turnstile>(All Y are Z)\<rbrakk> \<Longrightarrow> hs \<turnstile>(All X are Z)"

text {* Accordingly, we have the following variation of the above
example.
 *}

lemma example_2_5_b:
fixes l m n p q
defines "G_2_5  \<equiv> {All l are m,All q are l,All m are p,All n are p,All l are q}"
shows "G_2_5 \<turnstile> All q are p"
apply (rule_tac Y=l in A_barbara)
 apply (rule A_assumption) apply (simp add: G_2_5_def)
  apply (rule_tac Y=m in A_barbara)
    apply (rule_tac Y=m in A_barbara)
     apply (rule A_assumption) apply (simp add: G_2_5_def)

     apply (rule A_axiom)
    apply (rule A_assumption) apply (simp add: G_2_5_def)
done

text {* The proof is similar to the first one, but instead of referring
to an assumption of the lemma, we use now the rule \pf{A-assumption}.
After applying the rule \pf{A-assumption}, Isabelle leaves us with a
subgoal, namely
\pftext{ All q are l
    $\in$ G-2-5 }
which is obviously true and easy to discharge by
\pf{{\bf apply} \ep{simp add: G-2-5-def}}.
\footnote{A summary of rules is given in \cite[Section 5.7]{tutorial:isabellehol}.
Chapter 5 also contains a general introduction to the logic of Isabelle.}

\specialbox{ maybe a bit more about auto, simp, etc ... \cite[Section 3.1]{tutorial:isabellehol}}
*}

text {*
Next we come to our first mathematical result on the calculus, namely
that it is sound. Recall that \pf{TYPE\ep{atProp}} is the unique element
of the type \pf{atProp itself}, which appears in the definition of $\models{}G$.
*}

lemma prop_2_2_1:
  fixes G g
  assumes "G \<turnstile> g"
  shows  "G \<Turnstile>G g (TYPE(atProp))"
using assms
proof (induct rule: derives.induct)
  case (A_assumption)
  show ?case
by (metis A_assumption.hyps M_satisfies_G_def entails_def)
next
  case (A_axiom)
  show ?case by (metis entails_def order_refl satisfies.simps)
next
  case (A_barbara)
  show ?case by (metis A_barbara.hyps(2) A_barbara.hyps(4) entails_def satisfies.simps subset_trans)
qed

text {* To quote from the book:
\begin{qcolor}The soundness proofs of all the logical systems in this book are all pretty much the same.
They are always inductions, and the crux of the matter is usually a simple fact about sets.
(Above, the crux of the matter is that the inclusion relation $\subseteq$ on
 subsets of a given set is always a transitive relation.)
We almost never present the soundness proof in any detail.\end{qcolor}
The Isabelle proof gives another justification for skipping the details of the
mathematical soundness proof:
After telling Isabelle that we want to use induction and after
listing the cases, the details of the
proof are done automatically using sledgehammer, that is, the three lines above
\pf{{\bf by} \ep{metis \dots}} are provided
by an automatic theorem prover. For us, this essentially means that no
mathematical ideas are needed.
%
\footnote{Although it is clear that with automatic theorem proving
becoming more and more powerful it will happen more  and more often that automatic provers will find
proofs that would require ideas from a human point of view. On the other hand, for the proofs of
this section, there is an astonishingly good match between the details one would hide in a
pen and paper proof and the details that can be discharged by an automatic theorem prover.}
%

\medskip It may also be worth noting that the Isabelle proof is quite a bit shorter than the proof
in the book. Usually, such easy
proofs do not make it into the literature. Nowadays that can be done without sacrificing rigor by delegating
these proofs to a theorem prover.
Moreover, checking all the cases using the tool may well be faster then
checking the cases (carefully) by hand.
 *}

text {* \textbf{Further Reading. } Section 3 and 4 of \cite{Paulson89} contain
an exposition of Isabelle's meta-logic and an example of an object logic.
*}

subsection {* Completeness --- Proofs in Isabelle/Isar *}

text {* Isabelle supports two styles of proof, apply-style and Isar-style.
We have seen an example of both. The proof for Example 2.5 was given
apply-style. This is very convenient for that type of problem, which
consists in finding a derivation in a calculus, the rules of which
have been directly encoded using Isabelle rules.

\medskip But the proof of the soundness result in Proposition 2.2.1 was written
in a very different style. As an exercise you might want to
try and do the soundness proof apply-style, starting with
\begin{verbatim}
  apply (rule derives.induct)
  apply (rule assms)
\end{verbatim}
You will notice that you will need to know quite a bit about
how Isabelle proofs are implemented internally. Instead, the Isar proof language
\cite{isar} allows proofs to be written in a style much closer to informal proofs
and is much quicker to learn.
This section will present more examples and some exercises, for background and details
see the introduction \cite{tutorial:isar}. A useful resource is also the
Isabelle/Isar reference manual \cite{isar}, in particular Appendix A.
*}

text {* Coming back to the development of the syntax and semantics of our logic,
it is the next
definition which is the crucial one as it links up both syntax and semantics:
Given a theory $G$,
  derivability induces a preorder on atomic propositions, which is then
used to define the notion of canonical model below.  *}

definition less_equal_atprop :: "atProp \<Rightarrow> formula set \<Rightarrow> atProp \<Rightarrow> bool" ("_ \<lesssim>_ _")
where
  "less_equal_atprop u G v \<equiv> G \<turnstile> All u are v"

text {* We show that \isasymlesssim\ is a preorder. We would
hope that there is a theory about orders and preorders ready for us
to use and to find
it we write: *}

find_theorems name:preorder

text {* After which, in the output window, we find
\begin{verbatim}
  Order_Relation.preorder_on_empty: preorder_on {} {}
\end{verbatim}
Pressing the command key, hovering over the line above and clicking without delay
brings up the theory \verb+Order_Relation+
and the definition of \verb+preorder_on+, which takes two arguments,
a set $A$ and a relation, ie, a subset of $A\times A$. The relation
in question is $\{(x,y) \mid x\; {\lesssim}G\; y\}$. The set on which this
relation lives can be given by using \pf{UNIV}.
\marginpar[left text]{video}
*}

lemma prop_2_4_1:
  fixes G
  shows "preorder_on UNIV { (x,y). x \<lesssim>G y }"
proof (auto simp add: preorder_on_def)
   show "refl { (x,y). x \<lesssim>G y }"
    unfolding refl_on_def
    using A_axiom by (metis UNIV_Times_UNIV case_prodI iso_tuple_UNIV_I less_equal_atprop_def mem_Collect_eq subset_iff)
  show "trans { (x,y). x \<lesssim>G y }"
    unfolding trans_def
    using A_barbara by %invisible (metis (full_types) less_equal_atprop_def mem_Collect_eq split_conv)
qed

text {* As a side remark, the latex code of Proposition 2.4.1 and
its proof in the
book is only 10\% shorter, measured in number of characters, than the
Isabelle code (only part of which is shown above).
*}

text {* Next we give the definition of the canonical model of a theory $G$.
In words it says that in the canonical model
the interpretation of the atomic proposition $u$
is the set of all atomic propositions smaller or equal to $u$. *}

definition "canonical_model G u \<equiv> { v. v \<lesssim>G u }"

text {* The next lemma confirms that the canonical model of $G$
satisfies $G$: *}

lemma lemma_2_4_2:
  fixes G assumes "M = canonical_model G"
  shows "M \<Turnstile>M G"
proof (auto simp add: M_satisfies_G_def)
  fix g  assume "g \<in> G"
  then obtain p q where "(All p are q) = g" by %invisible (metis formula.exhaust)

  then have "p \<lesssim>G q" using A_assumption by %invisible (metis (full_types) `g \<in> G` less_equal_atprop_def)

  then have "M p \<subseteq> M q" using A_barbara by %invisible (metis assms canonical_model_def less_equal_atprop_def mem_Collect_eq subsetI)

  thus "M \<Turnstile> g" by %invisible (metis `(All p are q) = g` satisfies.simps)

qed

text{* Next comes the completeness theorem. *}

lemma thm_2_4_3:
  assumes "G \<Turnstile>G (All p are q) (TYPE(atProp))"
  shows "G \<turnstile> All p are q"
proof -
  def M \<equiv> "canonical_model G"
  have "M \<Turnstile> All p are q" using lemma_2_4_2 by %invisible (metis (full_types) M_def assms entails_def)

  then have "M p \<subseteq> M q" by %invisible auto

  have "p \<lesssim>G p" using A_axiom by %invisible (metis less_equal_atprop_def)

  then have "p \<in> M p" using canonical_model_def by %invisible (metis M_def mem_Collect_eq)

  have "p \<in> M q" using `M p \<subseteq> M q` by %invisible (metis `p \<in> M p`  set_rev_mp)

  then have "p \<lesssim>G q" using canonical_model_def by %invisible (metis M_def  mem_Collect_eq)

  thus ?thesis by %invisible (metis less_equal_atprop_def)

qed

end


(*  Title:      HOL/Library/Log_Nat.thy
    Author:     Johannes Hölzl, Fabian Immler
    Copyright   2012  TU München
*)

section \<open>Logarithm of Natural Numbers\<close>

theory Log_Nat
imports Complex_Main
begin

subsection \<open>Preliminaries\<close>

lemma divide_nat_diff_div_nat_less_one:
  "real x / real b - real (x div b) < 1" for x b :: nat
proof (cases "b = 0")
  case True
  then show ?thesis
    by simp
next
  case False
  then have "real (x div b) + real (x mod b) / real b - real (x div b) < 1"
    by (simp add: field_simps)
  then show ?thesis
    by (simp add: real_of_nat_div_aux [symmetric])
qed

subsection \<open>Floorlog\<close>

definition floorlog :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "floorlog b a = (if a > 0 \<and> b > 1 then nat \<lfloor>log b a\<rfloor> + 1 else 0)"

lemma floorlog_mono: "x \<le> y \<Longrightarrow> floorlog b x \<le> floorlog b y"
  by (auto simp: floorlog_def floor_mono nat_mono)

lemma floorlog_bounds:
  "b ^ (floorlog b x - 1) \<le> x \<and> x < b ^ (floorlog b x)" if "x > 0" "b > 1"
proof
  show "b ^ (floorlog b x - 1) \<le> x"
  proof -
    have "b ^ nat \<lfloor>log b x\<rfloor> = b powr \<lfloor>log b x\<rfloor>"
      using powr_realpow[symmetric, of b "nat \<lfloor>log b x\<rfloor>"] \<open>x > 0\<close> \<open>b > 1\<close>
      by simp
    also have "\<dots> \<le> b powr log b x" using \<open>b > 1\<close> by simp
    also have "\<dots> = real_of_int x" using \<open>0 < x\<close> \<open>b > 1\<close> by simp
    finally have "b ^ nat \<lfloor>log b x\<rfloor> \<le> real_of_int x" by simp
    then show ?thesis
      using \<open>0 < x\<close> \<open>b > 1\<close> of_nat_le_iff
      by (fastforce simp add: floorlog_def)
  qed
  show "x < b ^ (floorlog b x)"
  proof -
    have "x \<le> b powr (log b x)" using \<open>x > 0\<close> \<open>b > 1\<close> by simp
    also have "\<dots> < b powr (\<lfloor>log b x\<rfloor> + 1)"
      using that by (intro powr_less_mono) auto
    also have "\<dots> = b ^ nat (\<lfloor>log b (real_of_int x)\<rfloor> + 1)"
      using that by (simp flip: powr_realpow)
    finally
    have "x < b ^ nat (\<lfloor>log b (int x)\<rfloor> + 1)"
      by (rule of_nat_less_imp_less)
    then show ?thesis
      using \<open>x > 0\<close> \<open>b > 1\<close> by (simp add: floorlog_def nat_add_distrib)
  qed
qed

lemma floorlog_power [simp]:
  "floorlog b (a * b ^ c) = floorlog b a + c" if "a > 0" "b > 1"
proof -
  have "\<lfloor>log b a + real c\<rfloor> = \<lfloor>log b a\<rfloor> + c" by arith
  then show ?thesis using that
    by (auto simp: floorlog_def log_mult powr_realpow[symmetric] nat_add_distrib)
qed

lemma floor_log_add_eqI:
  "\<lfloor>log b (a + r)\<rfloor> = \<lfloor>log b a\<rfloor>" if "b > 1" "a \<ge> 1" "0 \<le> r" "r < 1"
    for a b :: nat and r :: real
proof (rule floor_eq2)
  have "log b a \<le> log b (a + r)" using that by force
  then show "\<lfloor>log b a\<rfloor> \<le> log b (a + r)" by arith
next
  define l::int where "l = int b ^ (nat \<lfloor>log b a\<rfloor> + 1)"
  have l_def_real: "l = b powr (\<lfloor>log b a\<rfloor> + 1)"
    using that by (simp add: l_def powr_add powr_real_of_int)
  have "a < l"
  proof -
    have "a = b powr (log b a)" using that by simp
    also have "\<dots> < b powr floor ((log b a) + 1)"
      using that(1) by auto
    also have "\<dots> = l"
      using that by (simp add: l_def powr_real_of_int powr_add)
    finally show ?thesis by simp
  qed
  then have "a + r < l" using that by simp
  then have "log b (a + r) < log b l" using that by simp
  also have "\<dots> = real_of_int \<lfloor>log b a\<rfloor> + 1"
    using that by (simp add: l_def_real)
  finally show "log b (a + r) < real_of_int \<lfloor>log b a\<rfloor> + 1" .
qed

lemma floor_log_div:
  "\<lfloor>log b x\<rfloor> = \<lfloor>log b (x div b)\<rfloor> + 1" if "b > 1" "x > 0" "x div b > 0"
    for b x :: nat
proof-
  have "\<lfloor>log b x\<rfloor> = \<lfloor>log b (x / b * b)\<rfloor>" using that by simp
  also have "\<dots> = \<lfloor>log b (x / b) + log b b\<rfloor>"
    using that by (subst log_mult) auto
  also have "\<dots> = \<lfloor>log b (x / b)\<rfloor> + 1" using that by simp
  also have "\<lfloor>log b (x / b)\<rfloor> = \<lfloor>log b (x div b + (x / b - x div b))\<rfloor>" by simp
  also have "\<dots> = \<lfloor>log b (x div b)\<rfloor>"
    using that real_of_nat_div4 divide_nat_diff_div_nat_less_one
    by (intro floor_log_add_eqI) auto
  finally show ?thesis .
qed

lemma compute_floorlog [code]:
  "floorlog b x = (if x > 0 \<and> b > 1 then floorlog b (x div b) + 1 else 0)"
  by (auto simp: floorlog_def floor_log_div[of b x] div_eq_0_iff nat_add_distrib
    intro!: floor_eq2)

lemma floor_log_eq_if:
  "\<lfloor>log b x\<rfloor> = \<lfloor>log b y\<rfloor>" if "x div b = y div b" "b > 1" "x > 0" "x div b \<ge> 1"
    for b x y :: nat
proof -
  have "y > 0" using that by (auto intro: ccontr)
  thus ?thesis using that by (simp add: floor_log_div)
qed

lemma floorlog_eq_if:
  "floorlog b x = floorlog b y" if "x div b = y div b" "b > 1" "x > 0" "x div b \<ge> 1"
    for b x y :: nat
proof -
  have "y > 0" using that by (auto intro: ccontr)
  then show ?thesis using that
    by (auto simp add: floorlog_def eq_nat_nat_iff intro: floor_log_eq_if)
qed

lemma floorlog_leD:
  "floorlog b x \<le> w \<Longrightarrow> b > 1 \<Longrightarrow> x < b ^ w"
  by (metis floorlog_bounds leD linorder_neqE_nat order.strict_trans power_strict_increasing_iff
      zero_less_one zero_less_power)

lemma floorlog_leI:
  "x < b ^ w \<Longrightarrow> 0 \<le> w \<Longrightarrow> b > 1 \<Longrightarrow> floorlog b x \<le> w"
  by (drule less_imp_of_nat_less[where 'a=real])
    (auto simp: floorlog_def Suc_le_eq nat_less_iff floor_less_iff log_of_power_less)

lemma floorlog_eq_zero_iff:
  "floorlog b x = 0 \<longleftrightarrow> b \<le> 1 \<or> x \<le> 0"
  by (auto simp: floorlog_def)

lemma floorlog_le_iff:
  "floorlog b x \<le> w \<longleftrightarrow> b \<le> 1 \<or> b > 1 \<and> 0 \<le> w \<and> x < b ^ w"
  using floorlog_leD[of b x w] floorlog_leI[of x b w]
  by (auto simp: floorlog_eq_zero_iff[THEN iffD2])

lemma floorlog_ge_SucI:
  "Suc w \<le> floorlog b x" if "b ^ w \<le> x" "b > 1"
  using that le_log_of_power[of b w x] power_not_zero
  by (force simp: floorlog_def Suc_le_eq powr_realpow not_less Suc_nat_eq_nat_zadd1
      zless_nat_eq_int_zless int_add_floor less_floor_iff
      simp del: floor_add2)

lemma floorlog_geI:
  "w \<le> floorlog b x" if "b ^ (w - 1) \<le> x" "b > 1"
  using floorlog_ge_SucI[of b "w - 1" x] that
  by auto

lemma floorlog_geD:
  "b ^ (w - 1) \<le> x" if "w \<le> floorlog b x" "w > 0"
proof -
  have "b > 1" "0 < x"
    using that by (auto simp: floorlog_def split: if_splits)
  have "b ^ (w - 1) \<le> x" if "b ^ w \<le> x"
  proof -
    have "b ^ (w - 1) \<le> b ^ w"
      using \<open>b > 1\<close>
      by (auto intro!: power_increasing)
    also note that
    finally show ?thesis .
  qed
  moreover have "b ^ nat \<lfloor>log (real b) (real x)\<rfloor> \<le> x" (is "?l \<le> _")
  proof -
    have "0 \<le> log (real b) (real x)"
      using \<open>b > 1\<close> \<open>0 < x\<close>
      by auto
    then have "?l \<le> b powr log (real b) (real x)"
      using \<open>b > 1\<close>
      by (auto simp flip: powr_realpow intro!: powr_mono of_nat_floor)
    also have "\<dots> = x" using \<open>b > 1\<close> \<open>0 < x\<close>
      by auto
    finally show ?thesis
      unfolding of_nat_le_iff .
  qed
  ultimately show ?thesis
    using that
    by (auto simp: floorlog_def le_nat_iff le_floor_iff le_log_iff powr_realpow
        split: if_splits elim!: le_SucE)
qed

subsection \<open>Bitlen\<close>

definition bitlen :: "int \<Rightarrow> int"
  where "bitlen a = floorlog 2 (nat a)"

lemma bitlen_alt_def:
  "bitlen a = (if a > 0 then \<lfloor>log 2 a\<rfloor> + 1 else 0)"
  by (simp add: bitlen_def floorlog_def)

lemma bitlen_zero [simp]:
  "bitlen 0 = 0"
  by (auto simp: bitlen_def floorlog_def)

lemma bitlen_nonneg:
  "0 \<le> bitlen x"
  by (simp add: bitlen_def)

lemma bitlen_bounds:
  "2 ^ nat (bitlen x - 1) \<le> x \<and> x < 2 ^ nat (bitlen x)" if "x > 0"
proof -
  from that have "bitlen x \<ge> 1" by (auto simp: bitlen_alt_def)
  with that floorlog_bounds[of "nat x" 2] show ?thesis
    by (auto simp add: bitlen_def le_nat_iff nat_less_iff nat_diff_distrib)
qed

lemma bitlen_pow2 [simp]:
  "bitlen (b * 2 ^ c) = bitlen b + c" if "b > 0"
  using that by (simp add: bitlen_def nat_mult_distrib nat_power_eq)

lemma compute_bitlen [code]:
  "bitlen x = (if x > 0 then bitlen (x div 2) + 1 else 0)"
  by (simp add: bitlen_def nat_div_distrib compute_floorlog)

lemma bitlen_eq_zero_iff:
  "bitlen x = 0 \<longleftrightarrow> x \<le> 0"
  by (auto simp add: bitlen_alt_def)
   (metis compute_bitlen add.commute bitlen_alt_def bitlen_nonneg less_add_same_cancel2
      not_less zero_less_one)

lemma bitlen_div:
  "1 \<le> real_of_int m / 2^nat (bitlen m - 1)"
    and "real_of_int m / 2^nat (bitlen m - 1) < 2" if "0 < m"
proof -
  let ?B = "2^nat (bitlen m - 1)"

  have "?B \<le> m" using bitlen_bounds[OF \<open>0 <m\<close>] ..
  then have "1 * ?B \<le> real_of_int m"
    unfolding of_int_le_iff[symmetric] by auto
  then show "1 \<le> real_of_int m / ?B" by auto

  from that have "0 \<le> bitlen m - 1" by (auto simp: bitlen_alt_def)

  have "m < 2^nat(bitlen m)" using bitlen_bounds[OF that] ..
  also from that have "\<dots> = 2^nat(bitlen m - 1 + 1)"
    by (auto simp: bitlen_def)
  also have "\<dots> = ?B * 2"
    unfolding nat_add_distrib[OF \<open>0 \<le> bitlen m - 1\<close> zero_le_one] by auto
  finally have "real_of_int m < 2 * ?B"
    by (metis (full_types) mult.commute power.simps(2) of_int_less_numeral_power_cancel_iff)
  then have "real_of_int m / ?B < 2 * ?B / ?B"
    by (rule divide_strict_right_mono) auto
  then show "real_of_int m / ?B < 2" by auto
qed

lemma bitlen_le_iff_floorlog:
  "bitlen x \<le> w \<longleftrightarrow> w \<ge> 0 \<and> floorlog 2 (nat x) \<le> nat w"
  by (auto simp: bitlen_def)

lemma bitlen_le_iff_power:
  "bitlen x \<le> w \<longleftrightarrow> w \<ge> 0 \<and> x < 2 ^ nat w"
  by (auto simp: bitlen_le_iff_floorlog floorlog_le_iff)

lemma less_power_nat_iff_bitlen:
  "x < 2 ^ w \<longleftrightarrow> bitlen (int x) \<le> w"
  using bitlen_le_iff_power[of x w]
  by auto

lemma bitlen_ge_iff_power:
  "w \<le> bitlen x \<longleftrightarrow> w \<le> 0 \<or> 2 ^ (nat w - 1) \<le> x"
  unfolding bitlen_def
  by (auto simp flip: nat_le_iff intro: floorlog_geI dest: floorlog_geD)

lemma bitlen_twopow_add_eq:
  "bitlen (2 ^ w + b) = w + 1" if "0 \<le> b" "b < 2 ^ w"
  by (auto simp: that nat_add_distrib bitlen_le_iff_power bitlen_ge_iff_power intro!: antisym)

end


(*  Title:      HOL/Nonstandard_Analysis/CLim.thy
    Author:     Jacques D. Fleuriot
    Copyright:  2001 University of Edinburgh
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
*)

section \<open>Limits, Continuity and Differentiation for Complex Functions\<close>

theory CLim
  imports CStar
begin

(*not in simpset?*)
declare epsilon_not_zero [simp]

(*??generalize*)
lemma lemma_complex_mult_inverse_squared [simp]: "x \<noteq> 0 \<Longrightarrow> x * (inverse x)\<^sup>2 = inverse x"
  for x :: complex
  by (simp add: numeral_2_eq_2)

text \<open>Changing the quantified variable. Install earlier?\<close>
lemma all_shift: "(\<forall>x::'a::comm_ring_1. P x) \<longleftrightarrow> (\<forall>x. P (x - a))"
  by (metis add_diff_cancel)

subsection \<open>Limit of Complex to Complex Function\<close>

lemma NSLIM_Re: "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L \<Longrightarrow> (\<lambda>x. Re (f x)) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S Re L"
  by (simp add: NSLIM_def starfunC_approx_Re_Im_iff hRe_hcomplex_of_complex)

lemma NSLIM_Im: "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L \<Longrightarrow> (\<lambda>x. Im (f x)) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S Im L"
  by (simp add: NSLIM_def starfunC_approx_Re_Im_iff hIm_hcomplex_of_complex)

lemma LIM_Re: "f \<midarrow>a\<rightarrow> L \<Longrightarrow> (\<lambda>x. Re (f x)) \<midarrow>a\<rightarrow> Re L"
  for f :: "'a::real_normed_vector \<Rightarrow> complex"
  by (simp add: LIM_NSLIM_iff NSLIM_Re)

lemma LIM_Im: "f \<midarrow>a\<rightarrow> L \<Longrightarrow> (\<lambda>x. Im (f x)) \<midarrow>a\<rightarrow> Im L"
  for f :: "'a::real_normed_vector \<Rightarrow> complex"
  by (simp add: LIM_NSLIM_iff NSLIM_Im)

lemma LIM_cnj: "f \<midarrow>a\<rightarrow> L \<Longrightarrow> (\<lambda>x. cnj (f x)) \<midarrow>a\<rightarrow> cnj L"
  for f :: "'a::real_normed_vector \<Rightarrow> complex"
  by (simp add: LIM_eq complex_cnj_diff [symmetric] del: complex_cnj_diff)

lemma LIM_cnj_iff: "((\<lambda>x. cnj (f x)) \<midarrow>a\<rightarrow> cnj L) \<longleftrightarrow> f \<midarrow>a\<rightarrow> L"
  for f :: "'a::real_normed_vector \<Rightarrow> complex"
  by (simp add: LIM_eq complex_cnj_diff [symmetric] del: complex_cnj_diff)

lemma starfun_norm: "( *f* (\<lambda>x. norm (f x))) = (\<lambda>x. hnorm (( *f* f) x))"
  by transfer (rule refl)

lemma star_of_Re [simp]: "star_of (Re x) = hRe (star_of x)"
  by transfer (rule refl)

lemma star_of_Im [simp]: "star_of (Im x) = hIm (star_of x)"
  by transfer (rule refl)

text \<open>Another equivalence result.\<close>
lemma NSCLIM_NSCRLIM_iff: "f \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S L \<longleftrightarrow> (\<lambda>y. cmod (f y - L)) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S 0"
  by (simp add: NSLIM_def starfun_norm
      approx_approx_zero_iff [symmetric] approx_minus_iff [symmetric])

text \<open>Much, much easier standard proof.\<close>
lemma CLIM_CRLIM_iff: "f \<midarrow>x\<rightarrow> L \<longleftrightarrow> (\<lambda>y. cmod (f y - L)) \<midarrow>x\<rightarrow> 0"
  for f :: "'a::real_normed_vector \<Rightarrow> complex"
  by (simp add: LIM_eq)

text \<open>So this is nicer nonstandard proof.\<close>
lemma NSCLIM_NSCRLIM_iff2: "f \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S L \<longleftrightarrow> (\<lambda>y. cmod (f y - L)) \<midarrow>x\<rightarrow>\<^sub>N\<^sub>S 0"
  by (simp add: LIM_NSLIM_iff [symmetric] CLIM_CRLIM_iff)

lemma NSLIM_NSCRLIM_Re_Im_iff:
  "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S L \<longleftrightarrow> (\<lambda>x. Re (f x)) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S Re L \<and> (\<lambda>x. Im (f x)) \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S Im L"
  apply (auto intro: NSLIM_Re NSLIM_Im)
  apply (auto simp add: NSLIM_def starfun_Re starfun_Im)
  apply (auto dest!: spec)
  apply (simp add: hcomplex_approx_iff)
  done

lemma LIM_CRLIM_Re_Im_iff: "f \<midarrow>a\<rightarrow> L \<longleftrightarrow> (\<lambda>x. Re (f x)) \<midarrow>a\<rightarrow> Re L \<and> (\<lambda>x. Im (f x)) \<midarrow>a\<rightarrow> Im L"
  for f :: "'a::real_normed_vector \<Rightarrow> complex"
  by (simp add: LIM_NSLIM_iff NSLIM_NSCRLIM_Re_Im_iff)

subsection \<open>Continuity\<close>

lemma NSLIM_isContc_iff: "f \<midarrow>a\<rightarrow>\<^sub>N\<^sub>S f a \<longleftrightarrow> (\<lambda>h. f (a + h)) \<midarrow>0\<rightarrow>\<^sub>N\<^sub>S f a"
  by (rule NSLIM_at0_iff)

subsection \<open>Functions from Complex to Reals\<close>

lemma isNSContCR_cmod [simp]: "isNSCont cmod a"
  by (auto intro: approx_hnorm
      simp: starfunCR_cmod hcmod_hcomplex_of_complex [symmetric] isNSCont_def)

lemma isContCR_cmod [simp]: "isCont cmod a"
  by (simp add: isNSCont_isCont_iff [symmetric])

lemma isCont_Re: "isCont f a \<Longrightarrow> isCont (\<lambda>x. Re (f x)) a"
  for f :: "'a::real_normed_vector \<Rightarrow> complex"
  by (simp add: isCont_def LIM_Re)

lemma isCont_Im: "isCont f a \<Longrightarrow> isCont (\<lambda>x. Im (f x)) a"
  for f :: "'a::real_normed_vector \<Rightarrow> complex"
  by (simp add: isCont_def LIM_Im)

subsection \<open>Differentiation of Natural Number Powers\<close>

lemma CDERIV_pow [simp]: "DERIV (\<lambda>x. x ^ n) x :> complex_of_real (real n) * (x ^ (n - Suc 0))"
  apply (induct n)
   apply (drule_tac [2] DERIV_ident [THEN DERIV_mult])
   apply (auto simp add: distrib_right of_nat_Suc)
  apply (case_tac "n")
   apply (auto simp add: ac_simps)
  done

text \<open>Nonstandard version.\<close>
lemma NSCDERIV_pow: "NSDERIV (\<lambda>x. x ^ n) x :> complex_of_real (real n) * (x ^ (n - 1))"
  by (metis CDERIV_pow NSDERIV_DERIV_iff One_nat_def)

text \<open>Can't relax the premise \<^term>\<open>x \<noteq> 0\<close>: it isn't continuous at zero.\<close>
lemma NSCDERIV_inverse: "x \<noteq> 0 \<Longrightarrow> NSDERIV (\<lambda>x. inverse x) x :> - (inverse x)\<^sup>2"
  for x :: complex
  unfolding numeral_2_eq_2 by (rule NSDERIV_inverse)

lemma CDERIV_inverse: "x \<noteq> 0 \<Longrightarrow> DERIV (\<lambda>x. inverse x) x :> - (inverse x)\<^sup>2"
  for x :: complex
  unfolding numeral_2_eq_2 by (rule DERIV_inverse)

subsection \<open>Derivative of Reciprocals (Function \<^term>\<open>inverse\<close>)\<close>

lemma CDERIV_inverse_fun:
  "DERIV f x :> d \<Longrightarrow> f x \<noteq> 0 \<Longrightarrow> DERIV (\<lambda>x. inverse (f x)) x :> - (d * inverse ((f x)\<^sup>2))"
  for x :: complex
  unfolding numeral_2_eq_2 by (rule DERIV_inverse_fun)

lemma NSCDERIV_inverse_fun:
  "NSDERIV f x :> d \<Longrightarrow> f x \<noteq> 0 \<Longrightarrow> NSDERIV (\<lambda>x. inverse (f x)) x :> - (d * inverse ((f x)\<^sup>2))"
  for x :: complex
  unfolding numeral_2_eq_2 by (rule NSDERIV_inverse_fun)

subsection \<open>Derivative of Quotient\<close>

lemma CDERIV_quotient:
  "DERIV f x :> d \<Longrightarrow> DERIV g x :> e \<Longrightarrow> g(x) \<noteq> 0 \<Longrightarrow>
    DERIV (\<lambda>y. f y / g y) x :> (d * g x - (e * f x)) / (g x)\<^sup>2"
  for x :: complex
  unfolding numeral_2_eq_2 by (rule DERIV_quotient)

lemma NSCDERIV_quotient:
  "NSDERIV f x :> d \<Longrightarrow> NSDERIV g x :> e \<Longrightarrow> g x \<noteq> (0::complex) \<Longrightarrow>
    NSDERIV (\<lambda>y. f y / g y) x :> (d * g x - (e * f x)) / (g x)\<^sup>2"
  unfolding numeral_2_eq_2 by (rule NSDERIV_quotient)

subsection \<open>Caratheodory Formulation of Derivative at a Point: Standard Proof\<close>

lemma CARAT_CDERIVD:
  "(\<forall>z. f z - f x = g z * (z - x)) \<and> isNSCont g x \<and> g x = l \<Longrightarrow> NSDERIV f x :> l"
  by clarify (rule CARAT_DERIVD)

end


(* Title:      Algebras for Aggregation and Minimisation
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Algebras for Aggregation and Minimisation\<close>

text \<open>
This theory gives algebras with operations for aggregation and minimisation.
In the weighted-graph model of matrices over (extended) numbers, the operations have the following meaning.
The binary operation $+$ adds the weights of corresponding edges of two graphs.
Addition does not have to be the standard addition on numbers, but can be any aggregation satisfying certain basic properties as demonstrated by various models of the algebras in another theory.
The unary operation \<open>sum\<close> adds the weights of all edges of a graph.
The result is a single aggregated weight using the same aggregation as $+$ but applied internally to the edges of a single graph.
The unary operation \<open>minarc\<close> finds an edge with a minimal weight in a graph.
It yields the position of such an edge as a regular element of a Stone relation algebra.

We give axioms for these operations which are sufficient to prove the correctness of Prim's and Kruskal's minimum spanning tree algorithms.
The operations have been proposed and axiomatised first in \cite{Guttmann2016c} with simplified axioms given in \cite{Guttmann2018a}.
The present version adds two axioms to prove total correctness of the spanning tree algorithms as discussed in \cite{Guttmann2018b}.
\<close>

theory Aggregation_Algebras

imports Stone_Kleene_Relation_Algebras.Kleene_Relation_Algebras

begin

context sup
begin

no_notation
  sup (infixl "+" 65)

end

context plus
begin

notation
  plus (infixl "+" 65)

end

text \<open>
We first introduce s-algebras as a class with the operations $+$ and \<open>sum\<close>.
Axiom \<open>sum_plus_right_isotone\<close> states that for non-empty graphs, the operation $+$ is $\leq$-isotone in its second argument on the image of the aggregation operation \<open>sum\<close>.
Axiom \<open>sum_bot\<close> expresses that the empty graph contributes no weight.
Axiom \<open>sum_plus\<close> generalises the inclusion-exclusion principle to sets of weights.
Axiom \<open>sum_conv\<close> specifies that reversing edge directions does not change the aggregated weight.
In instances of \<open>s_algebra\<close>, aggregated weights can be partially ordered.
\<close>

class sum =
  fixes sum :: "'a \<Rightarrow> 'a"

class s_algebra = stone_relation_algebra + plus + sum +
  assumes sum_plus_right_isotone: "x \<noteq> bot \<and> sum x \<le> sum y \<longrightarrow> sum z + sum x \<le> sum z + sum y"
  assumes sum_bot: "sum x + sum bot = sum x"
  assumes sum_plus: "sum x + sum y = sum (x \<squnion> y) + sum (x \<sqinter> y)"
  assumes sum_conv: "sum (x\<^sup>T) = sum x"
begin

lemma sum_disjoint:
  assumes "x \<sqinter> y = bot"
    shows "sum ((x \<squnion> y) \<sqinter> z) = sum (x \<sqinter> z) + sum (y \<sqinter> z)"
  by (subst sum_plus) (metis assms inf.sup_monoid.add_assoc inf.sup_monoid.add_commute inf_bot_left inf_sup_distrib2 sum_bot)

lemma sum_disjoint_3:
  assumes "w \<sqinter> x = bot"
      and "w \<sqinter> y = bot"
      and "x \<sqinter> y = bot"
    shows "sum ((w \<squnion> x \<squnion> y) \<sqinter> z) = sum (w \<sqinter> z) + sum (x \<sqinter> z) + sum (y \<sqinter> z)"
  by (metis assms inf_sup_distrib2 sup_idem sum_disjoint)

lemma sum_symmetric:
  assumes "y = y\<^sup>T"
    shows "sum (x\<^sup>T \<sqinter> y) = sum (x \<sqinter> y)"
  by (metis assms sum_conv conv_dist_inf)

lemma sum_commute:
  "sum x + sum y = sum y + sum x"
  by (metis inf_commute sum_plus sup_commute)

end

text \<open>
We next introduce the operation \<open>minarc\<close>.
Axiom \<open>minarc_below\<close> expresses that the result of \<open>minarc\<close> is contained in the graph ignoring the weights.
Axiom \<open>minarc_arc\<close> states that the result of \<open>minarc\<close> is a single unweighted edge if the graph is not empty.
Axiom \<open>minarc_min\<close> specifies that any edge in the graph weighs at least as much as the edge at the position indicated by the result of \<open>minarc\<close>, where weights of edges between different nodes are compared by applying the operation \<open>sum\<close> to single-edge graphs.
Axiom \<open>sum_linear\<close> requires that aggregated weights are linearly ordered, which is necessary for both Prim's and Kruskal's minimum spanning tree algorithms.
Axiom \<open>finite_regular\<close> ensures that there are only finitely many unweighted graphs, and therefore only finitely many edges and nodes in a graph; again this is necessary for the minimum spanning tree algorithms we consider.
\<close>

class minarc =
  fixes minarc :: "'a \<Rightarrow> 'a"

class m_algebra = s_algebra + minarc +
  assumes minarc_below: "minarc x \<le> --x"
  assumes minarc_arc: "x \<noteq> bot \<longrightarrow> arc (minarc x)"
  assumes minarc_min: "arc y \<and> y \<sqinter> x \<noteq> bot \<longrightarrow> sum (minarc x \<sqinter> x) \<le> sum (y \<sqinter> x)"
  assumes sum_linear: "sum x \<le> sum y \<or> sum y \<le> sum x"
  assumes finite_regular: "finite { x . regular x }"
begin

text \<open>
Axioms \<open>minarc_below\<close> and \<open>minarc_arc\<close> suffice to derive the Tarski rule in Stone relation algebras.
\<close>

subclass stone_relation_algebra_tarski
proof unfold_locales
  fix x
  let ?a = "minarc x"
  assume 1: "regular x"
  assume "x \<noteq> bot"
  hence "arc ?a"
    by (simp add: minarc_arc)
  hence "top = top * ?a * top"
    by (simp add: comp_associative)
  also have "... \<le> top * --x * top"
    by (simp add: minarc_below mult_isotone)
  finally show "top * x * top = top"
    using 1 antisym by simp
qed

lemma minarc_bot:
  "minarc bot = bot"
  by (metis bot_unique minarc_below regular_closed_bot)

lemma minarc_bot_iff:
  "minarc x = bot \<longleftrightarrow> x = bot"
  using covector_bot_closed inf_bot_right minarc_arc vector_bot_closed minarc_bot by fastforce

lemma minarc_meet_bot:
  assumes "minarc x \<sqinter> x = bot"
    shows "minarc x = bot"
proof -
  have "minarc x \<le> -x"
    using assms pseudo_complement by auto
  thus ?thesis
    by (metis minarc_below inf_absorb1 inf_import_p inf_p)
qed

lemma minarc_meet_bot_iff:
  "minarc x \<sqinter> x = bot \<longleftrightarrow> x = bot"
  using inf_bot_right minarc_bot_iff minarc_meet_bot by blast

lemma minarc_regular:
  "regular (minarc x)"
proof (cases "x = bot")
  assume "x = bot"
  thus ?thesis
    by (simp add: minarc_bot)
next
  assume "x \<noteq> bot"
  thus ?thesis
    by (simp add: arc_regular minarc_arc)
qed

lemma minarc_selection:
  "selection (minarc x \<sqinter> y) y"
  using inf_assoc minarc_regular selection_closed_id by auto

(*
lemma sum_bot: "sum bot = bot" nitpick [expect=genuine] oops
lemma plus_bot: "x + bot = x" nitpick [expect=genuine] oops
lemma "sum x = bot \<longrightarrow> x = bot" nitpick [expect=genuine] oops
*)

end

class m_kleene_algebra = m_algebra + stone_kleene_relation_algebra

end


section \<open>Preliminaries\<close>

subsection \<open>Some Utilities for Finite Partial Orders\<close>

text \<open>For some reason there seems to be no Isaeblle support for maximal elements in finite regions
  of incomplete partial orders (such as the transitive step relation in cycle-compressed transition
  systems ;).)\<close>

theory Finite_Partial_Order
  imports Main
begin

context preorder
begin

lemma foldl_max_inflation:
  \<open>foldl max x0 xs \<le> foldl max x0 (xs @ [x])\<close>
  unfolding foldl_append foldl.simps
  by (simp add: ord.max_def)

lemma foldl_max_soundness:
  shows
    \<open>foldl max x0 (x0 # xs) \<in> set (x0 # xs)\<close>
proof (induct xs rule: rev_induct)
  case Nil
  then show ?case by (auto simp add: max_def)
next
  case (snoc x xs)
  then show ?case  unfolding foldl_append max_def by auto
qed

lemma foldl_max_maximal:
  shows
    \<open>\<forall> y \<in> set (x0 # xs). foldl max x0 (x0 # xs) \<le> y \<longrightarrow> y \<le> foldl max x0 (x0 # xs)\<close>
proof (induct xs rule: rev_induct)
  case Nil
  then show ?case by (auto simp add: max_def)
next
  case (snoc x xs)
  then show ?case unfolding foldl.simps foldl_append
    by (metis Un_insert_right append_Nil2 foldl_Cons insert_iff list.simps(15) local.order_refl
        local.order_trans ord.max_def set_append snoc.hyps)
qed
end

context order \<comment>\<open>that is: partial order\<close>
begin

lemma finite_max:
  fixes q
  defines \<open>above_q \<equiv> {q'. q \<le> q'}\<close>
  assumes
    \<open>finite above_q\<close>
  shows
    \<open>\<exists> q_max. q_max \<in> above_q \<and> (\<forall> q''\<in> above_q. q_max \<le> q'' \<longrightarrow> q'' = q_max)\<close>
proof -
  have \<open>q \<in> above_q\<close> unfolding above_q_def by blast
  then obtain above_list where above_list_spec: \<open>set (q#above_list) = above_q\<close>
    using \<open>finite above_q\<close> finite_list by auto
  define q_max where \<open>q_max \<equiv> foldl max q (q#above_list)\<close>
  have \<open>q_max \<in> above_q\<close>
    unfolding q_max_def above_list_spec[symmetric] using foldl_max_soundness .
  moreover have \<open>\<forall> q'' \<in> above_q. q_max \<le> q'' \<longrightarrow> q'' = q_max\<close>
    unfolding q_max_def above_list_spec[symmetric] using foldl_max_maximal antisym
    using local.order.eq_iff by presburger
  ultimately show ?thesis by blast
qed

end

end