(*  Title:   QuasiBorel.thy
    Author:  Yasuhiko Minamide, Michikazu Hirata, Tokyo Institute of Technology
*)

section \<open>Quasi-Borel Spaces\<close>
theory QuasiBorel
imports "StandardBorel"
begin

subsection \<open> Definitions \<close>

text \<open> We formalize quasi-Borel spaces introduced by Heunen et al.~\cite{Heunen_2017}.\<close>

subsubsection \<open> Quasi-Borel Spaces\<close>
definition qbs_closed1 :: "(real \<Rightarrow> 'a) set \<Rightarrow> bool"
  where "qbs_closed1 Mx \<equiv> (\<forall>a \<in> Mx. \<forall>f \<in> real_borel \<rightarrow>\<^sub>M real_borel. a \<circ> f \<in> Mx)"

definition qbs_closed2 :: "['a set, (real \<Rightarrow> 'a) set] \<Rightarrow> bool"
 where "qbs_closed2 X Mx \<equiv> (\<forall>x \<in> X. (\<lambda>r. x) \<in> Mx)"

definition qbs_closed3 :: "(real \<Rightarrow> 'a) set \<Rightarrow> bool"
 where "qbs_closed3 Mx \<equiv> (\<forall>P::real \<Rightarrow> nat. \<forall>Fi::nat \<Rightarrow> real \<Rightarrow> 'a.
                          (\<forall>i. P -` {i} \<in> sets real_borel)
                           \<longrightarrow> (\<forall>i. Fi i \<in> Mx)
                           \<longrightarrow> (\<lambda>r. Fi (P r) r) \<in> Mx)"

lemma separate_measurable:
  fixes P :: "real \<Rightarrow> nat"
  assumes "\<And>i. P -` {i} \<in> sets real_borel"
  shows "P \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
proof -
  have "P \<in> real_borel \<rightarrow>\<^sub>M count_space UNIV"
    by (auto simp add: assms measurable_count_space_eq_countable)
  thus ?thesis
    using measurable_cong_sets sets_borel_eq_count_space by blast
qed

lemma measurable_separate:
  fixes P :: "real \<Rightarrow> nat"
  assumes "P \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
  shows "P -` {i} \<in> sets real_borel"
  by(rule measurable_sets_borel[OF assms borel_singleton[OF sets.empty_sets,of i]])

definition "is_quasi_borel X Mx \<longleftrightarrow> Mx \<subseteq> UNIV \<rightarrow> X \<and> qbs_closed1 Mx \<and> qbs_closed2 X Mx \<and> qbs_closed3 Mx"

lemma is_quasi_borel_intro[simp]:
  assumes "Mx \<subseteq> UNIV \<rightarrow> X"
      and "qbs_closed1 Mx" "qbs_closed2 X Mx" "qbs_closed3 Mx"
    shows "is_quasi_borel X Mx"
  using assms by(simp add: is_quasi_borel_def)

typedef 'a quasi_borel = "{(X::'a set, Mx). is_quasi_borel X Mx}"
proof
  show "(UNIV, UNIV) \<in> {(X::'a set, Mx). is_quasi_borel X Mx}"
    by (simp add: is_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def)
qed

definition qbs_space :: "'a quasi_borel \<Rightarrow> 'a set" where
  "qbs_space X \<equiv> fst (Rep_quasi_borel X)"

definition qbs_Mx :: "'a quasi_borel \<Rightarrow> (real \<Rightarrow> 'a) set" where
  "qbs_Mx X \<equiv> snd (Rep_quasi_borel X)"

lemma qbs_decomp :
"(qbs_space X,qbs_Mx X) \<in> {(X::'a set, Mx). is_quasi_borel X Mx}"
  by (simp add: qbs_space_def qbs_Mx_def Rep_quasi_borel[simplified])

lemma qbs_Mx_to_X[dest]:
  assumes "\<alpha> \<in> qbs_Mx X"
  shows "\<alpha> \<in> UNIV \<rightarrow> qbs_space X"
        "\<alpha> r \<in> qbs_space X"
  using qbs_decomp assms by(auto simp: is_quasi_borel_def)

lemma qbs_closed1I:
  assumes "\<And>\<alpha> f. \<alpha> \<in> Mx \<Longrightarrow> f \<in> real_borel \<rightarrow>\<^sub>M real_borel \<Longrightarrow> \<alpha> \<circ> f \<in> Mx"
  shows "qbs_closed1 Mx"
  using assms by(simp add: qbs_closed1_def)

lemma qbs_closed1_dest[simp]:
  assumes "\<alpha> \<in> qbs_Mx X"
      and "f \<in> real_borel \<rightarrow>\<^sub>M real_borel"
    shows "\<alpha> \<circ> f \<in> qbs_Mx X"
  using assms qbs_decomp by (auto simp add: is_quasi_borel_def qbs_closed1_def)

lemma qbs_closed2I:
  assumes "\<And>x. x \<in> X \<Longrightarrow> (\<lambda>r. x) \<in> Mx"
  shows "qbs_closed2 X Mx"
  using assms by(simp add: qbs_closed2_def)

lemma qbs_closed2_dest[simp]:
  assumes "x \<in> qbs_space X"
  shows "(\<lambda>r. x) \<in> qbs_Mx X"
  using assms qbs_decomp[of X] by (auto simp add: is_quasi_borel_def qbs_closed2_def)

lemma qbs_closed3I:
  assumes "\<And>(P :: real \<Rightarrow> nat) Fi. (\<And>i. P -` {i} \<in> sets real_borel) \<Longrightarrow> (\<And>i. Fi i \<in> Mx)
                  \<Longrightarrow> (\<lambda>r. Fi (P r) r) \<in> Mx"
  shows "qbs_closed3 Mx"
  using assms by(auto simp: qbs_closed3_def)

lemma qbs_closed3I':
  assumes "\<And>(P :: real \<Rightarrow> nat) Fi. P \<in> real_borel \<rightarrow>\<^sub>M nat_borel \<Longrightarrow> (\<And>i. Fi i \<in> Mx)
                  \<Longrightarrow> (\<lambda>r. Fi (P r) r) \<in> Mx"
  shows "qbs_closed3 Mx"
  using assms by(auto intro!: qbs_closed3I simp: separate_measurable)

lemma qbs_closed3_dest[simp]:
  fixes P::"real \<Rightarrow> nat" and Fi :: "nat \<Rightarrow> real \<Rightarrow> _"
  assumes "\<And>i. P -` {i} \<in> sets real_borel"
      and "\<And>i. Fi i \<in> qbs_Mx X"
    shows "(\<lambda>r. Fi (P r) r) \<in> qbs_Mx X"
  using assms qbs_decomp[of X] by (auto simp add: is_quasi_borel_def qbs_closed3_def)

lemma qbs_closed3_dest':
  fixes P::"real \<Rightarrow> nat" and Fi :: "nat \<Rightarrow> real \<Rightarrow> _"
  assumes "P \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
      and "\<And>i. Fi i \<in> qbs_Mx X"
    shows "(\<lambda>r. Fi (P r) r) \<in> qbs_Mx X"
  using qbs_closed3_dest[OF measurable_separate[OF assms(1)] assms(2)] .

lemma qbs_closed3_dest2:
  assumes "countable I"
 and [measurable]: "P \<in> real_borel \<rightarrow>\<^sub>M count_space I"
      and "\<And>i. i \<in> I \<Longrightarrow> Fi i \<in> qbs_Mx X"
    shows "(\<lambda>r. Fi (P r) r) \<in> qbs_Mx X"
proof -
  have 0:"I \<noteq> {}"
    using measurable_empty_iff[of "count_space I" P real_borel] assms(2)
    by fastforce
  define P' where "P' \<equiv> to_nat_on I \<circ> P"
  define Fi' where "Fi' \<equiv> Fi \<circ> (from_nat_into I)"
  have 1:"P' \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
    by(simp add: P'_def)
  have 2:"\<And>i. Fi' i \<in> qbs_Mx X"
    using assms(3) from_nat_into[OF 0] by(simp add: Fi'_def)
  have "(\<lambda>r. Fi' (P' r) r) \<in> qbs_Mx X"
    using 1 2 measurable_separate by auto
  thus ?thesis
    using from_nat_into_to_nat_on[OF assms(1)] measurable_space[OF assms(2)]
    by(auto simp: Fi'_def P'_def)
qed

lemma qbs_closed3_dest2':
  assumes "countable I"
 and [measurable]: "P \<in> real_borel \<rightarrow>\<^sub>M count_space I"
      and "\<And>i. i \<in> range P \<Longrightarrow> Fi i \<in> qbs_Mx X"
    shows "(\<lambda>r. Fi (P r) r) \<in> qbs_Mx X"
proof -
  have 0:"range P \<inter> I = range P"
    using measurable_space[OF assms(2)] by auto
  have 1:"P \<in> real_borel \<rightarrow>\<^sub>M count_space (range P)"
    using restrict_count_space[of I "range P"] measurable_restrict_space2[OF _ assms(2),of "range P"]
    by(simp add: 0)
  have 2:"countable (range P)"
    using countable_Int2[OF assms(1),of "range P"]
    by(simp add: 0)
  show ?thesis
    by(auto intro!: qbs_closed3_dest2[OF 2 1 assms(3)])
qed

lemma qbs_space_Mx:
 "qbs_space X = {\<alpha> x |x \<alpha>. \<alpha> \<in> qbs_Mx X}"
proof auto
  fix x
  assume 1:"x \<in> qbs_space X"
  show "\<exists>xa \<alpha>. x = \<alpha> xa \<and> \<alpha> \<in> qbs_Mx X"
    by(auto intro!: exI[where x=0] exI[where x="(\<lambda>r. x)"] simp: 1)
qed

lemma qbs_space_eq_Mx:
  assumes "qbs_Mx X = qbs_Mx Y"
  shows "qbs_space X = qbs_space Y"
  by(simp add: qbs_space_Mx assms)

lemma qbs_eqI:
  assumes "qbs_Mx X = qbs_Mx Y"
  shows "X = Y"
  by (metis Rep_quasi_borel_inverse prod.exhaust_sel qbs_Mx_def qbs_space_def assms qbs_space_eq_Mx[OF assms])

subsubsection \<open> Morphism of Quasi-Borel Spaces \<close>
definition qbs_morphism :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> ('a \<Rightarrow> 'b) set" (infixr "\<rightarrow>\<^sub>Q" 60) where
  "X \<rightarrow>\<^sub>Q Y \<equiv> {f \<in> qbs_space X \<rightarrow> qbs_space Y. \<forall>\<alpha> \<in> qbs_Mx X. f \<circ> \<alpha> \<in> qbs_Mx Y}"

lemma qbs_morphismI:
  assumes "\<And>\<alpha>. \<alpha> \<in> qbs_Mx X \<Longrightarrow> f \<circ> \<alpha> \<in> qbs_Mx Y"
  shows "f \<in> X \<rightarrow>\<^sub>Q Y"
proof -
  have "f \<in> qbs_space X \<rightarrow> qbs_space Y"
  proof
    fix x
    assume "x \<in> qbs_space X "
    then have "(\<lambda>r. x) \<in> qbs_Mx X"
      by simp
    hence "f \<circ> (\<lambda>r. x) \<in> qbs_Mx Y"
      using assms by blast
    thus "f x \<in> qbs_space Y"
      by auto
  qed
  thus ?thesis
    using assms by(simp add: qbs_morphism_def)
qed

lemma qbs_morphismE[dest]:
  assumes "f \<in> X \<rightarrow>\<^sub>Q Y"
  shows "f \<in> qbs_space X \<rightarrow> qbs_space Y"
        "\<And>x. x \<in> qbs_space X \<Longrightarrow> f x \<in> qbs_space Y"
        "\<And>\<alpha>. \<alpha> \<in> qbs_Mx X \<Longrightarrow> f \<circ> \<alpha> \<in> qbs_Mx Y"
  using assms by(auto simp add: qbs_morphism_def)

lemma qbs_morphism_ident[simp]:
   "id \<in> X \<rightarrow>\<^sub>Q X"
  by(auto intro: qbs_morphismI)

lemma qbs_morphism_ident'[simp]:
   "(\<lambda>x. x) \<in> X \<rightarrow>\<^sub>Q X"
  using qbs_morphism_ident by(simp add: id_def)

lemma qbs_morphism_comp:
  assumes "f \<in> X \<rightarrow>\<^sub>Q Y" "g \<in> Y \<rightarrow>\<^sub>Q Z"
  shows "g \<circ> f \<in> X \<rightarrow>\<^sub>Q Z"
  using assms by (simp add: comp_assoc Pi_def qbs_morphism_def)

lemma qbs_morphism_cong:
  assumes "\<And>x. x \<in> qbs_space X \<Longrightarrow> f x = g x"
      and "f \<in> X \<rightarrow>\<^sub>Q Y"
    shows "g \<in> X \<rightarrow>\<^sub>Q Y"
proof(rule qbs_morphismI)
  fix \<alpha>
  assume 1:"\<alpha> \<in> qbs_Mx X"
  have "g \<circ> \<alpha> = f \<circ> \<alpha>"
  proof
    fix x
    have "\<alpha> x \<in> qbs_space X"
      using 1 qbs_decomp[of X] by auto
    thus "(g \<circ> \<alpha>) x = (f \<circ> \<alpha>) x"
      using assms(1) by simp
  qed
  thus "g \<circ> \<alpha> \<in> qbs_Mx Y"
    using 1 assms(2) by(simp add: qbs_morphism_def)
qed

lemma qbs_morphism_const:
  assumes "y \<in> qbs_space Y"
  shows "(\<lambda>_. y) \<in> X \<rightarrow>\<^sub>Q Y"
  using assms by (auto intro: qbs_morphismI)

subsubsection \<open> Empty Space \<close>
definition empty_quasi_borel  :: "'a quasi_borel" where
"empty_quasi_borel \<equiv> Abs_quasi_borel ({},{})"

lemma eqb_correct: "Rep_quasi_borel empty_quasi_borel = ({}, {})"
  using Abs_quasi_borel_inverse
  by(auto simp add: Abs_quasi_borel_inverse empty_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)

lemma eqb_space[simp]: "qbs_space empty_quasi_borel = {}"
  by(simp add: qbs_space_def eqb_correct)

lemma eqb_Mx[simp]: "qbs_Mx empty_quasi_borel = {}"
  by(simp add: qbs_Mx_def eqb_correct)

lemma qbs_empty_equiv :"qbs_space X = {} \<longleftrightarrow> qbs_Mx X = {}"
proof(auto)
  fix x
  assume "qbs_Mx X = {}"
     and h:"x \<in> qbs_space X"
  have "(\<lambda>r. x) \<in> qbs_Mx X"
    using h by simp
  thus "False" using \<open>qbs_Mx X = {}\<close> by simp
qed

lemma empty_quasi_borel_iff:
  "qbs_space X = {} \<longleftrightarrow> X = empty_quasi_borel"
  by(auto intro!: qbs_eqI)

subsubsection \<open> Unit Space \<close>
definition unit_quasi_borel :: "unit quasi_borel" ("1\<^sub>Q") where
"unit_quasi_borel \<equiv> Abs_quasi_borel (UNIV,UNIV)"

lemma uqb_correct: "Rep_quasi_borel unit_quasi_borel = (UNIV,UNIV)"
  using Abs_quasi_borel_inverse
  by(auto simp add: unit_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)

lemma uqb_space[simp]: "qbs_space unit_quasi_borel = {()}"
  by(simp add: qbs_space_def UNIV_unit uqb_correct)

lemma uqb_Mx[simp]: "qbs_Mx unit_quasi_borel = {\<lambda>r. ()}"
  by(auto simp add: qbs_Mx_def uqb_correct)

lemma unit_quasi_borel_terminal:
 "\<exists>! f. f \<in> X \<rightarrow>\<^sub>Q unit_quasi_borel"
  by(fastforce simp: qbs_morphism_def)

definition to_unit_quasi_borel :: "'a \<Rightarrow> unit" ("!\<^sub>Q") where
"to_unit_quasi_borel \<equiv> (\<lambda>_.())"

lemma to_unit_quasi_borel_morphism :
 "!\<^sub>Q \<in> X \<rightarrow>\<^sub>Q unit_quasi_borel"
  by(auto simp add: to_unit_quasi_borel_def qbs_morphism_def)

subsubsection \<open> Subspaces \<close>
definition sub_qbs :: "['a quasi_borel, 'a set] \<Rightarrow> 'a quasi_borel" where
"sub_qbs X U \<equiv> Abs_quasi_borel (qbs_space X \<inter> U,{f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X})"

lemma sub_qbs_closed:
  "qbs_closed1 {f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X}"
  "qbs_closed2 (qbs_space X \<inter> U) {f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X}"
  "qbs_closed3 {f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X}"
  unfolding qbs_closed1_def qbs_closed2_def qbs_closed3_def by auto

lemma sub_qbs_correct[simp]: "Rep_quasi_borel (sub_qbs X U) = (qbs_space X \<inter> U,{f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X})"
  by(simp add: Abs_quasi_borel_inverse sub_qbs_def sub_qbs_closed)

lemma sub_qbs_space[simp]: "qbs_space (sub_qbs X U) = qbs_space X \<inter> U"
  by(simp add: qbs_space_def)

lemma sub_qbs_Mx[simp]: "qbs_Mx (sub_qbs X U) = {f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X}"
  by(simp add: qbs_Mx_def)

lemma sub_qbs:
  assumes "U \<subseteq> qbs_space X"
  shows "(qbs_space (sub_qbs X U), qbs_Mx (sub_qbs X U)) = (U, {f \<in> UNIV \<rightarrow> U. f \<in> qbs_Mx X})"
  using assms by auto

subsubsection \<open> Image Spaces \<close>
definition map_qbs :: "['a \<Rightarrow> 'b] \<Rightarrow> 'a quasi_borel \<Rightarrow> 'b quasi_borel" where
"map_qbs f X = Abs_quasi_borel (f ` (qbs_space X),{\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>})"

lemma map_qbs_f:
 "{\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>} \<subseteq> UNIV \<rightarrow> f ` (qbs_space X)"
  by fastforce

lemma map_qbs_closed1:
 "qbs_closed1 {\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>}"
  unfolding qbs_closed1_def
  using qbs_closed1_dest by(fastforce simp: comp_def)

lemma map_qbs_closed2:
 "qbs_closed2 (f ` (qbs_space X)) {\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>}"
  unfolding qbs_closed2_def by fastforce

lemma map_qbs_closed3:
 "qbs_closed3 {\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>}"
proof(auto simp add: qbs_closed3_def)
  fix P Fi
  assume h:"\<forall>i::nat. P -` {i} \<in> sets real_borel"
           "\<forall>i::nat. \<exists>\<alpha>\<in>qbs_Mx X. Fi i = f \<circ> \<alpha>"
  then obtain \<alpha>i
    where ha: "\<forall>i::nat. \<alpha>i i \<in> qbs_Mx X \<and>  Fi i = f \<circ> (\<alpha>i i)"
    by metis
  hence 1:"(\<lambda>r. \<alpha>i (P r) r) \<in> qbs_Mx X"
    using h(1) by fastforce
  show "\<exists>\<alpha>\<in>qbs_Mx X. (\<lambda>r. Fi (P r) r) = f \<circ> \<alpha>"
    by(auto intro!: bexI[where x="(\<lambda>r. \<alpha>i (P r) r)"] simp add: 1 ha comp_def)
qed

lemma map_qbs_correct[simp]:
 "Rep_quasi_borel (map_qbs f X) = (f ` (qbs_space X),{\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>})"
  unfolding map_qbs_def
  by(simp add: Abs_quasi_borel_inverse map_qbs_f map_qbs_closed1 map_qbs_closed2 map_qbs_closed3)

lemma map_qbs_space[simp]:
 "qbs_space (map_qbs f X) = f ` (qbs_space X)"
  by(simp add: qbs_space_def)

lemma map_qbs_Mx[simp]:
 "qbs_Mx (map_qbs f X) = {\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>}"
  by(simp add: qbs_Mx_def)

lemma map_qbs_morphism_f: "f \<in> X \<rightarrow>\<^sub>Q map_qbs f X"
  by(auto intro!: qbs_morphismI)

lemma map_qbs_morphism_inverse_f:
  assumes "\<And>x. x \<in> qbs_space X \<Longrightarrow> g (f x) = x"
  shows "g \<in> map_qbs f X \<rightarrow>\<^sub>Q X"
proof(auto intro!: qbs_morphismI)
  fix \<alpha>
  assume h:"\<alpha> \<in> qbs_Mx X"
  from qbs_Mx_to_X(2)[OF this] assms have "g \<circ> (f \<circ> \<alpha>) = \<alpha>"
    by auto
  with  h show "g \<circ> (f \<circ> \<alpha>) \<in> qbs_Mx X" by simp
qed

inductive_set generating_Mx :: "'a set \<Rightarrow> (real \<Rightarrow> 'a) set \<Rightarrow> (real \<Rightarrow> 'a) set"
  for X :: "'a set" and Mx :: "(real \<Rightarrow> 'a) set"
  where
    Basic: "\<alpha> \<in> Mx \<Longrightarrow> \<alpha> \<in> generating_Mx X Mx"
  | Const: "x \<in> X \<Longrightarrow> (\<lambda>r. x) \<in> generating_Mx X Mx"
  | Comp : "f \<in> real_borel \<rightarrow>\<^sub>M real_borel \<Longrightarrow> \<alpha> \<in> generating_Mx X Mx \<Longrightarrow> \<alpha> \<circ> f \<in> generating_Mx X Mx"
  | Part : "(\<And>i. Fi i \<in> generating_Mx X Mx) \<Longrightarrow> P \<in> real_borel \<rightarrow>\<^sub>M nat_borel \<Longrightarrow> (\<lambda>r. Fi (P r) r) \<in> generating_Mx X Mx"

lemma generating_Mx_to_space:
  assumes "Mx \<subseteq> UNIV \<rightarrow> X"
  shows "generating_Mx X Mx \<subseteq> UNIV \<rightarrow> X"
proof
  fix \<alpha>
  assume "\<alpha> \<in> generating_Mx X Mx"
  then show "\<alpha> \<in> UNIV \<rightarrow> X"
   by(induct rule: generating_Mx.induct) (use assms in auto)
qed

lemma generating_Mx_closed1:
 "qbs_closed1 (generating_Mx X Mx)"
  by (simp add: generating_Mx.Comp qbs_closed1I)

lemma generating_Mx_closed2:
 "qbs_closed2 X (generating_Mx X Mx)"
  by (simp add: generating_Mx.Const qbs_closed2I)

lemma generating_Mx_closed3:
 "qbs_closed3 (generating_Mx X Mx)"
  by(simp add: qbs_closed3I' generating_Mx.Part)

lemma generating_Mx_Mx:
 "generating_Mx (qbs_space X) (qbs_Mx X) = qbs_Mx X"
proof auto
  fix \<alpha>
  assume "\<alpha> \<in> generating_Mx (qbs_space X) (qbs_Mx X)"
  then show "\<alpha> \<in> qbs_Mx X"
    by(rule generating_Mx.induct) (auto intro!: qbs_closed1_dest[simplified comp_def] simp: qbs_closed3_dest')
next
  fix \<alpha>
  assume "\<alpha> \<in> qbs_Mx X"
  then show "\<alpha> \<in> generating_Mx (qbs_space X) (qbs_Mx X)" ..
qed

subsubsection \<open> Ordering of Quasi-Borel Spaces \<close>

instantiation quasi_borel :: (type) order_bot
begin

inductive less_eq_quasi_borel :: "'a quasi_borel \<Rightarrow> 'a quasi_borel \<Rightarrow> bool" where
  "qbs_space X \<subset> qbs_space Y \<Longrightarrow> less_eq_quasi_borel X Y"
| "qbs_space X = qbs_space Y \<Longrightarrow> qbs_Mx Y \<subseteq> qbs_Mx X \<Longrightarrow> less_eq_quasi_borel X Y"

lemma le_quasi_borel_iff:
 "X \<le> Y \<longleftrightarrow> (if qbs_space X = qbs_space Y then qbs_Mx Y \<subseteq> qbs_Mx X else qbs_space X \<subset> qbs_space Y)"
  by(auto elim: less_eq_quasi_borel.cases intro: less_eq_quasi_borel.intros)

definition less_quasi_borel :: "'a quasi_borel \<Rightarrow> 'a quasi_borel \<Rightarrow> bool" where
 "less_quasi_borel X Y \<longleftrightarrow> (X \<le> Y \<and> \<not> Y \<le> X)"

definition bot_quasi_borel :: "'a quasi_borel" where
 "bot_quasi_borel = empty_quasi_borel"

instance
proof
  show "bot \<le> a" for a :: "'a quasi_borel"
    using qbs_empty_equiv
    by(auto simp add: le_quasi_borel_iff bot_quasi_borel_def)
qed (auto simp: le_quasi_borel_iff less_quasi_borel_def split: if_split_asm intro: qbs_eqI)
end

definition inf_quasi_borel :: "['a quasi_borel, 'a quasi_borel] \<Rightarrow> 'a quasi_borel" where
"inf_quasi_borel X X' = Abs_quasi_borel (qbs_space X \<inter> qbs_space X', qbs_Mx X \<inter> qbs_Mx X')"

lemma inf_quasi_borel_correct: "Rep_quasi_borel (inf_quasi_borel X X') = (qbs_space X \<inter> qbs_space X', qbs_Mx X \<inter> qbs_Mx X')"
  by(fastforce intro!: Abs_quasi_borel_inverse
     simp: inf_quasi_borel_def is_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def)

lemma inf_qbs_space[simp]: "qbs_space (inf_quasi_borel X X') = qbs_space X \<inter> qbs_space X'"
  by (simp add: qbs_space_def inf_quasi_borel_correct)

lemma inf_qbs_Mx[simp]: "qbs_Mx (inf_quasi_borel X X') = qbs_Mx X \<inter> qbs_Mx X'"
  by(simp add: qbs_Mx_def inf_quasi_borel_correct)

definition max_quasi_borel :: "'a set \<Rightarrow> 'a quasi_borel" where
"max_quasi_borel X = Abs_quasi_borel (X, UNIV \<rightarrow> X)"

lemma max_quasi_borel_correct: "Rep_quasi_borel (max_quasi_borel X) = (X, UNIV \<rightarrow> X)"
  by(fastforce intro!: Abs_quasi_borel_inverse
   simp: max_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)

lemma max_qbs_space[simp]: "qbs_space (max_quasi_borel X) = X"
  by(simp add: qbs_space_def max_quasi_borel_correct)

lemma max_qbs_Mx[simp]: "qbs_Mx (max_quasi_borel X) = UNIV \<rightarrow> X"
  by(simp add: qbs_Mx_def max_quasi_borel_correct)

instantiation quasi_borel :: (type) semilattice_sup
begin

definition sup_quasi_borel :: "'a quasi_borel \<Rightarrow> 'a quasi_borel \<Rightarrow> 'a quasi_borel" where
"sup_quasi_borel X Y \<equiv> (if qbs_space X = qbs_space Y      then inf_quasi_borel X Y
                        else if qbs_space X \<subset> qbs_space Y then Y
                        else if qbs_space Y \<subset> qbs_space X then X
                        else max_quasi_borel (qbs_space X \<union> qbs_space Y))"

instance
proof
  fix X Y :: "'a quasi_borel"
  let ?X = "qbs_space X"
  let ?Y = "qbs_space Y"
  consider "?X = ?Y" | "?X \<subset> ?Y" | "?Y \<subset> ?X" | "?X \<subset> ?X \<union> ?Y \<and> ?Y \<subset> ?X \<union> ?Y"
    by auto
  then show "X \<le> X \<squnion> Y"
  proof(cases)
    case 1
    show ?thesis
      unfolding sup_quasi_borel_def
      by(rule less_eq_quasi_borel.intros(2),simp_all add: 1)
  next
    case 2
    then show ?thesis
      unfolding sup_quasi_borel_def
      by (simp add: less_eq_quasi_borel.intros(1))
  next
    case 3
    then show ?thesis
      unfolding sup_quasi_borel_def
      by auto
  next
    case 4
    then show ?thesis
      unfolding sup_quasi_borel_def
      by(auto simp: less_eq_quasi_borel.intros(1))
  qed
next
  fix X Y :: "'a quasi_borel"
  let ?X = "qbs_space X"
  let ?Y = "qbs_space Y"
  consider "?X = ?Y" | "?X \<subset> ?Y" | "?Y \<subset> ?X" | "?X \<subset> ?X \<union> ?Y \<and> ?Y \<subset> ?X \<union> ?Y"
    by auto
  then show "Y \<le> X \<squnion> Y"
  proof(cases)
    case 1
    show ?thesis
      unfolding sup_quasi_borel_def
      by(rule less_eq_quasi_borel.intros(2)) (simp_all add: 1)
  next
    case 2
    then show ?thesis
      unfolding sup_quasi_borel_def
      by auto
  next
    case 3
    then show ?thesis
      unfolding sup_quasi_borel_def
      by (auto simp add: less_eq_quasi_borel.intros(1))
  next
    case 4
    then show ?thesis
      unfolding sup_quasi_borel_def
      by(auto simp: less_eq_quasi_borel.intros(1))
  qed
next
  fix X Y Z :: "'a quasi_borel"
  assume h:"X \<le> Z" "Y \<le> Z"
  let ?X = "qbs_space X"
  let ?Y = "qbs_space Y"
  let ?Z = "qbs_space Z"
  consider "?X = ?Y" | "?X \<subset> ?Y" | "?Y \<subset> ?X" | "?X \<subset> ?X \<union> ?Y \<and> ?Y \<subset> ?X \<union> ?Y"
    by auto
  then show "sup X Y \<le> Z"
  proof cases
    case 1
    show ?thesis
      unfolding sup_quasi_borel_def
      apply(simp add: 1,rule less_eq_quasi_borel.cases[OF h(1)])
       apply(rule less_eq_quasi_borel.intros(1))
       apply auto[1]
      apply auto
      apply(rule less_eq_quasi_borel.intros(2))
       apply(simp add: 1)
      by(rule less_eq_quasi_borel.cases[OF h(2)]) (auto simp: 1)
  next
    case 2
    then show ?thesis
      unfolding sup_quasi_borel_def
      using h(2) by auto
  next
    case 3
    then show ?thesis
      unfolding sup_quasi_borel_def
      using h(1) by auto
  next
    case 4
    then have [simp]:"?X \<noteq> ?Y" "~ (?X \<subset> ?Y)" "~ (?Y \<subset> ?X)"
      by auto
    have [simp]:"?X \<subseteq> ?Z" "?Y \<subseteq> ?Z"
      by (metis h(1) dual_order.order_iff_strict less_eq_quasi_borel.cases)
         (metis h(2) dual_order.order_iff_strict less_eq_quasi_borel.cases)
    then consider "?X \<union> ?Y = ?Z" | "?X \<union> ?Y \<subset> ?Z"
      by blast
    then show ?thesis
      unfolding sup_quasi_borel_def
      apply cases
       apply simp
       apply(rule less_eq_quasi_borel.intros(2))
        apply simp
       apply auto[1]
      by(simp add: less_eq_quasi_borel.intros(1))
  qed
qed
end

end


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

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

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

context begin interpretation autoref_syn .

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

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

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

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

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

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

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

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

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

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

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

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

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

end

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

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

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

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

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

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

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

end


\<^marker>\<open>creator "Bohua Zhan"\<close>
\<^marker>\<open>contributor "Kevin Kappelmann"\<close>
section \<open>Set Proof Steps\<close>
theory Proof_Steps_Sets
imports
  Auto2_HOTG
  HOTG.Empty_Set
  HOTG.Set_Difference
begin
paragraph \<open>Summary\<close>
text \<open>Setup for proof steps related to sets. Adapted from \<open>Auto2/HOL/Set_Thms.thy\<close>.\<close>

subsection \<open>Set\<close>

(*subsubsection \<open>Injective Functions\<close>

setup \<open>add_backward_prfstep @{thm injI}\<close>*)

subsubsection \<open>AC property of intersection and union\<close>

setup \<open>fold Auto2_HOTG_Extra_Setup.ACUtil.add_ac_data [
  {cfhead = @{cterm bin_inter}, unit = NONE,
    assoc_th = @{thm bin_inter_assoc}, comm_th = @{thm bin_inter_comm},
    unitl_th = Auto2_HOTG_UtilBase.true_th, unitr_th = Auto2_HOTG_UtilBase.true_th},

  {cfhead = @{cterm bin_union}, unit = SOME @{cterm emptyset},
   assoc_th = @{thm bin_union_assoc}, comm_th = @{thm bin_union_comm},
   unitl_th = @{thm empty_bin_union_eq}, unitr_th = @{thm bin_union_empty_eq}}]
\<close>

subsubsection \<open>Collection and bounded quantification\<close>

setup \<open>add_rewrite_rule @{thm Comprehension.mem_collect_iff}\<close>
lemma ball_singleton [rewrite]: "(\<forall>x \<in> {x}. P x) = P x" by auto

subsubsection \<open>Membership\<close>

setup \<open>add_rewrite_rule @{thm Finite_Sets.singleton_mem_iff_eq}\<close>
setup \<open>add_resolve_prfstep @{thm Basic.not_mem_emptyset}\<close>
lemma ne_if_not_mem_if_mem [forward]: "x \<in> s \<Longrightarrow> y \<notin> s \<Longrightarrow> x \<noteq> y" by auto
setup \<open>add_backward_prfstep @{thm Empty_Set.ex_mem_if_ne_empty}\<close>
setup \<open>add_resolve_prfstep @{thm Axioms.mem_univ}\<close>

subsubsection \<open>Insert\<close>

setup \<open>add_backward_prfstep_cond (equiv_backward_th @{thm Unordered_Pairs.mem_insert_iff})
  [with_cond "?A \<noteq> {}"]\<close>
setup \<open>add_forward_prfstep_cond (equiv_forward_th @{thm Unordered_Pairs.mem_insert_iff})
  [with_score 500, with_cond "?A \<noteq> {}"]\<close>

setup \<open>add_forward_prfstep_cond (equiv_forward_th @{thm Unordered_Pairs.insert_subset_iff_mem_subset})
  [with_cond "?A \<noteq> {}"]\<close>
setup \<open>add_backward_prfstep_cond (equiv_backward_th @{thm Unordered_Pairs.insert_subset_iff_mem_subset})
  [with_score 500, with_cond "?A \<noteq> {}"]\<close>

subsubsection \<open>Extensionality\<close>

lemma set_eq_if_mem_iff [forward]: "\<forall>a. a \<in> S \<longleftrightarrow> a \<in> T \<Longrightarrow> S = T" using eqI' by simp
setup \<open>add_backward_prfstep_cond @{thm set_eq_if_mem_iff}
  [with_score 500, with_filt (order_filter "S" "T")]\<close>

(*lemma set_pair_ext [forward]: "\<forall>a b. \<langle>a, b\<rangle> \<in> S \<longleftrightarrow> \<langle>a, b\<rangle> \<in> T \<Longrightarrow> S = T" by auto*)

subsubsection \<open>Union\<close>

setup \<open>add_forward_prfstep_cond (equiv_forward_th @{thm Union_Intersection.mem_bin_union_iff})
  [with_score 500]\<close>
setup \<open>add_backward_prfstep (equiv_backward_th @{thm Union_Intersection.mem_bin_union_iff})\<close>

lemma bin_unionD1 [forward]: "c \<in> A \<union> B \<Longrightarrow> c \<notin> A \<Longrightarrow> c \<in> B" by auto
lemma bin_unionD2 [forward]: "c \<in> A \<union> B \<Longrightarrow> c \<notin> B \<Longrightarrow> c \<in> A" by auto
lemma bin_union_singleD1 [forward]: "c \<in> {a} \<union> B \<Longrightarrow> c \<noteq> a \<Longrightarrow> c \<in> B" by auto
lemma bin_union_singleD2 [forward]: "c \<in> A \<union> {b} \<Longrightarrow> c \<noteq> b \<Longrightarrow> c \<in> A" by auto
setup \<open>add_forward_prfstep_cond @{thm mem_bin_union_if_mem_left} [with_term "?A \<union> ?B"]\<close>
setup \<open>add_forward_prfstep_cond @{thm mem_bin_union_if_mem_right} [with_term "?A \<union> ?B"]\<close>
setup \<open>add_forward_prfstep_cond @{thm mem_singleton_bin_union} [with_term "{?a} \<union> ?B"]\<close>
setup \<open>add_forward_prfstep_cond @{thm mem_bin_union_singleton} [with_term "?A \<union> {?b}"]\<close>

setup \<open>add_rewrite_rule @{thm singleton_bin_union_absorb}\<close>
setup \<open>add_backward_prfstep @{thm singleton_bin_union_absorb}\<close>

subsubsection \<open>Intersection\<close>

setup \<open>add_forward_prfstep (equiv_forward_th @{thm mem_bin_inter_iff})\<close>
setup \<open>add_backward_prfstep_cond (equiv_backward_th @{thm mem_bin_inter_iff})
  [with_score 500]\<close>

setup \<open>add_rewrite_rule @{thm Union_Intersection.empty_bin_inter_eq_empty}\<close>
setup \<open>add_rewrite_rule @{thm Union_Intersection.bin_inter_empty_eq_empty}\<close>
setup \<open>add_rewrite_rule @{thm Union_Intersection.bin_inter_absorb}\<close>
lemma not_mem_if_mem_if_bin_inter_eq_empty [forward, backward2]:
  "A \<inter> B = {} \<Longrightarrow> p \<in> A \<Longrightarrow> p \<notin> B"
  by auto
lemma singleton_bin_inter_eq_empty_iff [rewrite]: "{x} \<inter> B = {} \<longleftrightarrow> x \<notin> B" by auto

subsubsection \<open>Subset\<close>

setup \<open>add_forward_prfstep @{thm subsetI}\<close>
setup \<open>add_backward_prfstep_cond @{thm subsetI} [with_score 500]\<close>

setup \<open>add_resolve_prfstep @{thm empty_subset}\<close>
setup \<open>add_forward_prfstep @{thm subsetD}\<close>
setup \<open>add_rewrite_rule @{thm singleton_subset_iff_mem}\<close>
setup \<open>add_resolve_prfstep @{thm subset_self}\<close>
setup \<open>add_resolve_prfstep @{thm subset_bin_union_left}\<close>
setup \<open>add_resolve_prfstep @{thm subset_bin_union_right}\<close>
lemma subset_subset_if_bin_union_subset [forward]: "A \<union> B \<subseteq> C \<Longrightarrow> A \<subseteq> C \<and> B \<subseteq> C" by auto
setup \<open>add_backward1_prfstep @{thm bin_union_subset_if_subset_if_subset}\<close>
setup \<open>add_backward2_prfstep @{thm bin_union_subset_if_subset_if_subset}\<close>
setup \<open>add_backward_prfstep @{thm bin_union_subset_bin_union_if_subset}\<close>
setup \<open>add_backward_prfstep @{thm bin_union_subset_bin_union_if_subset'}\<close>

subsubsection \<open>Diff\<close>

setup \<open>add_forward_prfstep (equiv_forward_th @{thm mem_diff_iff})\<close>
setup \<open>add_backward_prfstep_cond (equiv_backward_th @{thm mem_diff_iff})
  [with_score 500]\<close>
setup \<open>add_rewrite_rule @{thm mem_diff_iff}\<close>

setup \<open>add_rewrite_rule @{thm diff_empty_eq}\<close>
setup \<open>add_rewrite_rule @{thm Set_Difference.bin_union_diff_eq_diff_left}\<close>
setup \<open>add_rewrite_rule @{thm Set_Difference.bin_union_diff_eq_diff_right}\<close>
lemma singleton_bin_union_diff_eq_if_ne [rewrite]: "a \<noteq> c \<Longrightarrow> {a} \<union> (B \<setminus> {c}) = {a} \<union> B \<setminus> {c}"
  by (rule eq_if_subset_if_subset) auto
setup \<open>add_forward_prfstep_cond @{thm Set_Difference.diff_subset} [with_term "?A \<setminus> ?B"]\<close>
lemma singleton_bin_union_diff_singleton_eq_if_not_mem [rewrite]:
  "x \<notin> B \<Longrightarrow> ({x} \<union> B) \<setminus> {x} = B"
  by (rule eq_if_subset_if_subset) auto
lemma bin_union_singleton_diff_singleton_eq_if_not_mem [rewrite]:
  "x \<notin> B \<Longrightarrow> (B \<union> {x}) \<setminus> {x} = B"
  by (rule eq_if_subset_if_subset) auto
(* lemma subset_sub1 [backward]: "x \<in> A \<Longrightarrow> A \<setminus> {x} \<subset> A" by auto *)
lemma ne_if_mem_diff_singleton [forward]: "x \<in> S \<setminus> {y} \<Longrightarrow> x \<noteq> y" by simp
lemma member_notin_contra: "x \<in> S \<Longrightarrow> x \<noteq> y \<Longrightarrow> x \<in> S \<setminus> {y}" by simp
setup \<open>add_forward_prfstep_cond @{thm member_notin_contra} [with_term "?S \<setminus> {?y}"]\<close>

(*subsubsection \<open>Results on finite sets\<close>

setup \<open>add_resolve_prfstep @{thm Finite_Set.finite.emptyI}\<close>
lemma set_finite_single [resolve]: "finite {x}" by simp
setup \<open>add_rewrite_rule @{thm Finite_Set.finite_Un}\<close>
lemma Max_ge' [forward]: "finite A \<Longrightarrow> x > Max A \<Longrightarrow> \<not>(x \<in> A)" using Max_ge leD by auto
setup \<open>add_backward_prfstep @{thm finite_image_set}\<close>
setup \<open>add_forward_prfstep @{thm finite_atLeastAtMost}\<close>
setup \<open>add_forward_prfstep @{thm rev_finite_subset}\<close>
setup \<open>add_backward1_prfstep @{thm rev_finite_subset}\<close>

subsubsection \<open>Cardinality\<close>

setup \<open>add_rewrite_rule @{thm card_empty}\<close>
lemma card_emptyD [rewrite]: "finite S \<Longrightarrow> card S = 0 \<Longrightarrow> S = {}" by simp
lemma card_minus1 [rewrite]: "x \<in> S \<Longrightarrow> card (S - {x}) = card S - 1" by (simp add: card_Diff_subset)
setup \<open>add_forward_prfstep @{thm finite_Diff}\<close>
setup \<open>add_resolve_prfstep @{thm card_mono}\<close>*)

(*subsubsection \<open>Image set\<close>

setup \<open>add_rewrite_rule @{thm Set.image_Un}\<close>
setup \<open>add_rewrite_rule @{thm image_set_diff}\<close>*)

(*subsection \<open>Multiset\<close>

subsubsection \<open>Basic properties\<close>

lemma mset_member_empty [resolve]: "\<not>p \<in># {#}" by simp
lemma mem_multiset_single [rewrite]: "x \<in># {#y#} \<longleftrightarrow> x = y" by simp
setup \<open>add_backward2_prfstep @{thm subset_mset.antisym}\<close>
setup \<open>add_resolve_prfstep @{thm Multiset.empty_le}\<close>
setup \<open>add_forward_prfstep @{thm mset_subsetD}\<close>

lemma multi_contain_add_self1 [resolve]: "A \<subset># {#x#} + A" by simp
lemma multi_contain_add_self2 [resolve]: "A \<subset># A + {#x#}" by simp
setup \<open>add_forward_prfstep_cond @{thm Multiset.multi_member_this} [with_term "{#?x#} + ?XS"]\<close>
lemma multi_member_this2: "x \<in># XS + {#x#}" by simp
setup \<open>add_forward_prfstep_cond @{thm multi_member_this2} [with_term "?XS + {#?x#}"]\<close>
setup \<open>add_backward_prfstep @{thm Multiset.subset_mset.add_left_mono}\<close>
setup \<open>add_backward_prfstep @{thm Multiset.subset_mset.add_right_mono}\<close>

subsubsection \<open>Case checking and induction\<close>

lemma multi_nonempty_split' [resolve]: "M \<noteq> {#} \<Longrightarrow> \<exists>M' m. M = M' + {#m#}"
  using multi_nonempty_split by auto

lemma multi_member_split' [backward]: "x \<in># M \<Longrightarrow> \<exists>M'. M = M' + {#x#}"
  by (metis insert_DiffM2)

setup \<open>add_strong_induct_rule @{thm full_multiset_induct}\<close>

subsubsection \<open>Results on mset\<close>

setup \<open>add_rewrite_rule @{thm set_mset_empty}\<close>
setup \<open>add_rewrite_rule @{thm set_mset_single}\<close>
setup \<open>add_rewrite_rule @{thm set_mset_union}\<close>

setup \<open>add_rewrite_rule @{thm image_mset_empty}\<close>
setup \<open>add_rewrite_rule @{thm image_mset_single}\<close>
setup \<open>add_rewrite_rule @{thm image_mset_union}\<close>

setup \<open>add_rewrite_rule @{thm prod_mset_empty}\<close>
setup \<open>add_rewrite_rule @{thm prod_mset_singleton}\<close>
setup \<open>add_rewrite_rule @{thm prod_mset_Un}\<close>

subsubsection \<open>Set interval\<close>

setup \<open>add_rewrite_rule @{thm Set_Interval.ord_class.lessThan_iff}\<close>
setup \<open>add_rewrite_rule @{thm Set_Interval.ord_class.atLeastAtMost_iff}\<close>*)

end


(*  Title:      ZF/ArithSimp.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2000  University of Cambridge
*)

section\<open>Arithmetic with simplification\<close>

theory ArithSimp
imports Arith
begin

ML_file \<open>~~/src/Provers/Arith/cancel_numerals.ML\<close>
ML_file \<open>~~/src/Provers/Arith/combine_numerals.ML\<close>
ML_file \<open>arith_data.ML\<close>

subsection\<open>Difference\<close>

lemma diff_self_eq_0 [simp]: "m #- m = 0"
apply (subgoal_tac "natify (m) #- natify (m) = 0")
apply (rule_tac [2] natify_in_nat [THEN nat_induct], auto)
done

(**Addition is the inverse of subtraction**)

(*We need m:nat even if we replace the RHS by natify(m), for consider e.g.
  n=2, m=omega; then n + (m-n) = 2 + (0-2) = 2 \<noteq> 0 = natify(m).*)
lemma add_diff_inverse: "\<lbrakk>n \<le> m;  m:nat\<rbrakk> \<Longrightarrow> n #+ (m#-n) = m"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (erule rev_mp)
apply (rule_tac m = m and n = n in diff_induct, auto)
done

lemma add_diff_inverse2: "\<lbrakk>n \<le> m;  m:nat\<rbrakk> \<Longrightarrow> (m#-n) #+ n = m"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (simp (no_asm_simp) add: add_commute add_diff_inverse)
done

(*Proof is IDENTICAL to that of add_diff_inverse*)
lemma diff_succ: "\<lbrakk>n \<le> m;  m:nat\<rbrakk> \<Longrightarrow> succ(m) #- n = succ(m#-n)"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (erule rev_mp)
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all (no_asm_simp))
done

lemma zero_less_diff [simp]:
     "\<lbrakk>m: nat; n: nat\<rbrakk> \<Longrightarrow> 0 < (n #- m)   \<longleftrightarrow>   m<n"
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all (no_asm_simp))
done

(** Difference distributes over multiplication **)

lemma diff_mult_distrib: "(m #- n) #* k = (m #* k) #- (n #* k)"
apply (subgoal_tac " (natify (m) #- natify (n)) #* natify (k) = (natify (m) #* natify (k)) #- (natify (n) #* natify (k))")
apply (rule_tac [2] m = "natify (m) " and n = "natify (n) " in diff_induct)
apply (simp_all add: diff_cancel)
done

lemma diff_mult_distrib2: "k #* (m #- n) = (k #* m) #- (k #* n)"
apply (simp (no_asm) add: mult_commute [of k] diff_mult_distrib)
done

subsection\<open>Remainder\<close>

(*We need m:nat even with natify*)
lemma div_termination: "\<lbrakk>0<n;  n \<le> m;  m:nat\<rbrakk> \<Longrightarrow> m #- n < m"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (erule rev_mp)
apply (erule rev_mp)
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all (no_asm_simp) add: diff_le_self)
done

(*for mod and div*)
lemmas div_rls =
    nat_typechecks Ord_transrec_type apply_funtype
    div_termination [THEN ltD]
    nat_into_Ord not_lt_iff_le [THEN iffD1]

lemma raw_mod_type: "\<lbrakk>m:nat;  n:nat\<rbrakk> \<Longrightarrow> raw_mod (m, n) \<in> nat"
  unfolding raw_mod_def
apply (rule Ord_transrec_type)
apply (auto simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (blast intro: div_rls)
done

lemma mod_type [TC,iff]: "m mod n \<in> nat"
  unfolding mod_def
apply (simp (no_asm) add: mod_def raw_mod_type)
done

(** Aribtrary definitions for division by zero.  Useful to simplify
    certain equations **)

lemma DIVISION_BY_ZERO_DIV: "a div 0 = 0"
  unfolding div_def
apply (rule raw_div_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp))
done  (*NOT for adding to default simpset*)

lemma DIVISION_BY_ZERO_MOD: "a mod 0 = natify(a)"
  unfolding mod_def
apply (rule raw_mod_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp))
done  (*NOT for adding to default simpset*)

lemma raw_mod_less: "m<n \<Longrightarrow> raw_mod (m,n) = m"
apply (rule raw_mod_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD])
done

lemma mod_less [simp]: "\<lbrakk>m<n; n \<in> nat\<rbrakk> \<Longrightarrow> m mod n = m"
apply (frule lt_nat_in_nat, assumption)
apply (simp (no_asm_simp) add: mod_def raw_mod_less)
done

lemma raw_mod_geq:
     "\<lbrakk>0<n; n \<le> m;  m:nat\<rbrakk> \<Longrightarrow> raw_mod (m, n) = raw_mod (m#-n, n)"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (rule raw_mod_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD] not_lt_iff_le [THEN iffD2], blast)
done

lemma mod_geq: "\<lbrakk>n \<le> m;  m:nat\<rbrakk> \<Longrightarrow> m mod n = (m#-n) mod n"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (case_tac "n=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (simp add: mod_def raw_mod_geq nat_into_Ord [THEN Ord_0_lt_iff])
done

subsection\<open>Division\<close>

lemma raw_div_type: "\<lbrakk>m:nat;  n:nat\<rbrakk> \<Longrightarrow> raw_div (m, n) \<in> nat"
  unfolding raw_div_def
apply (rule Ord_transrec_type)
apply (auto simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (blast intro: div_rls)
done

lemma div_type [TC,iff]: "m div n \<in> nat"
  unfolding div_def
apply (simp (no_asm) add: div_def raw_div_type)
done

lemma raw_div_less: "m<n \<Longrightarrow> raw_div (m,n) = 0"
apply (rule raw_div_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD])
done

lemma div_less [simp]: "\<lbrakk>m<n; n \<in> nat\<rbrakk> \<Longrightarrow> m div n = 0"
apply (frule lt_nat_in_nat, assumption)
apply (simp (no_asm_simp) add: div_def raw_div_less)
done

lemma raw_div_geq: "\<lbrakk>0<n;  n \<le> m;  m:nat\<rbrakk> \<Longrightarrow> raw_div(m,n) = succ(raw_div(m#-n, n))"
apply (subgoal_tac "n \<noteq> 0")
prefer 2 apply blast
apply (frule lt_nat_in_nat, erule nat_succI)
apply (rule raw_div_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD] not_lt_iff_le [THEN iffD2] )
done

lemma div_geq [simp]:
     "\<lbrakk>0<n;  n \<le> m;  m:nat\<rbrakk> \<Longrightarrow> m div n = succ ((m#-n) div n)"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (simp (no_asm_simp) add: div_def raw_div_geq)
done

declare div_less [simp] div_geq [simp]

(*A key result*)
lemma mod_div_lemma: "\<lbrakk>m: nat;  n: nat\<rbrakk> \<Longrightarrow> (m div n)#*n #+ m mod n = m"
apply (case_tac "n=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (erule complete_induct)
apply (case_tac "x<n")
txt\<open>case x<n\<close>
apply (simp (no_asm_simp))
txt\<open>case \<^term>\<open>n \<le> x\<close>\<close>
apply (simp add: not_lt_iff_le add_assoc mod_geq div_termination [THEN ltD] add_diff_inverse)
done

lemma mod_div_equality_natify: "(m div n)#*n #+ m mod n = natify(m)"
apply (subgoal_tac " (natify (m) div natify (n))#*natify (n) #+ natify (m) mod natify (n) = natify (m) ")
apply force
apply (subst mod_div_lemma, auto)
done

lemma mod_div_equality: "m: nat \<Longrightarrow> (m div n)#*n #+ m mod n = m"
apply (simp (no_asm_simp) add: mod_div_equality_natify)
done

subsection\<open>Further Facts about Remainder\<close>

text\<open>(mainly for mutilated chess board)\<close>

lemma mod_succ_lemma:
     "\<lbrakk>0<n;  m:nat;  n:nat\<rbrakk>
      \<Longrightarrow> succ(m) mod n = (if succ(m mod n) = n then 0 else succ(m mod n))"
apply (erule complete_induct)
apply (case_tac "succ (x) <n")
txt\<open>case succ(x) < n\<close>
 apply (simp (no_asm_simp) add: nat_le_refl [THEN lt_trans] succ_neq_self)
 apply (simp add: ltD [THEN mem_imp_not_eq])
txt\<open>case \<^term>\<open>n \<le> succ(x)\<close>\<close>
apply (simp add: mod_geq not_lt_iff_le)
apply (erule leE)
 apply (simp (no_asm_simp) add: mod_geq div_termination [THEN ltD] diff_succ)
txt\<open>equality case\<close>
apply (simp add: diff_self_eq_0)
done

lemma mod_succ:
  "n:nat \<Longrightarrow> succ(m) mod n = (if succ(m mod n) = n then 0 else succ(m mod n))"
apply (case_tac "n=0")
 apply (simp (no_asm_simp) add: natify_succ DIVISION_BY_ZERO_MOD)
apply (subgoal_tac "natify (succ (m)) mod n = (if succ (natify (m) mod n) = n then 0 else succ (natify (m) mod n))")
 prefer 2
 apply (subst natify_succ)
 apply (rule mod_succ_lemma)
  apply (auto simp del: natify_succ simp add: nat_into_Ord [THEN Ord_0_lt_iff])
done

lemma mod_less_divisor: "\<lbrakk>0<n;  n:nat\<rbrakk> \<Longrightarrow> m mod n < n"
apply (subgoal_tac "natify (m) mod n < n")
apply (rule_tac [2] i = "natify (m) " in complete_induct)
apply (case_tac [3] "x<n", auto)
txt\<open>case \<^term>\<open>n \<le> x\<close>\<close>
apply (simp add: mod_geq not_lt_iff_le div_termination [THEN ltD])
done

lemma mod_1_eq [simp]: "m mod 1 = 0"
by (cut_tac n = 1 in mod_less_divisor, auto)

lemma mod2_cases: "b<2 \<Longrightarrow> k mod 2 = b | k mod 2 = (if b=1 then 0 else 1)"
apply (subgoal_tac "k mod 2: 2")
 prefer 2 apply (simp add: mod_less_divisor [THEN ltD])
apply (drule ltD, auto)
done

lemma mod2_succ_succ [simp]: "succ(succ(m)) mod 2 = m mod 2"
apply (subgoal_tac "m mod 2: 2")
 prefer 2 apply (simp add: mod_less_divisor [THEN ltD])
apply (auto simp add: mod_succ)
done

lemma mod2_add_more [simp]: "(m#+m#+n) mod 2 = n mod 2"
apply (subgoal_tac " (natify (m) #+natify (m) #+n) mod 2 = n mod 2")
apply (rule_tac [2] n = "natify (m) " in nat_induct)
apply auto
done

lemma mod2_add_self [simp]: "(m#+m) mod 2 = 0"
by (cut_tac n = 0 in mod2_add_more, auto)

subsection\<open>Additional theorems about \<open>\<le>\<close>\<close>

lemma add_le_self: "m:nat \<Longrightarrow> m \<le> (m #+ n)"
apply (simp (no_asm_simp))
done

lemma add_le_self2: "m:nat \<Longrightarrow> m \<le> (n #+ m)"
apply (simp (no_asm_simp))
done

(*** Monotonicity of Multiplication ***)

lemma mult_le_mono1: "\<lbrakk>i \<le> j; j:nat\<rbrakk> \<Longrightarrow> (i#*k) \<le> (j#*k)"
apply (subgoal_tac "natify (i) #*natify (k) \<le> j#*natify (k) ")
apply (frule_tac [2] lt_nat_in_nat)
apply (rule_tac [3] n = "natify (k) " in nat_induct)
apply (simp_all add: add_le_mono)
done

(* @{text"\<le>"} monotonicity, BOTH arguments*)
lemma mult_le_mono: "\<lbrakk>i \<le> j; k \<le> l; j:nat; l:nat\<rbrakk> \<Longrightarrow> i#*k \<le> j#*l"
apply (rule mult_le_mono1 [THEN le_trans], assumption+)
apply (subst mult_commute, subst mult_commute, rule mult_le_mono1, assumption+)
done

(*strict, in 1st argument; proof is by induction on k>0.
  I can't see how to relax the typing conditions.*)
lemma mult_lt_mono2: "\<lbrakk>i<j; 0<k; j:nat; k:nat\<rbrakk> \<Longrightarrow> k#*i < k#*j"
apply (erule zero_lt_natE)
apply (frule_tac [2] lt_nat_in_nat)
apply (simp_all (no_asm_simp))
apply (induct_tac "x")
apply (simp_all (no_asm_simp) add: add_lt_mono)
done

lemma mult_lt_mono1: "\<lbrakk>i<j; 0<k; j:nat; k:nat\<rbrakk> \<Longrightarrow> i#*k < j#*k"
apply (simp (no_asm_simp) add: mult_lt_mono2 mult_commute [of _ k])
done

lemma add_eq_0_iff [iff]: "m#+n = 0 \<longleftrightarrow> natify(m)=0 \<and> natify(n)=0"
apply (subgoal_tac "natify (m) #+ natify (n) = 0 \<longleftrightarrow> natify (m) =0 \<and> natify (n) =0")
apply (rule_tac [2] n = "natify (m) " in natE)
 apply (rule_tac [4] n = "natify (n) " in natE)
apply auto
done

lemma zero_lt_mult_iff [iff]: "0 < m#*n \<longleftrightarrow> 0 < natify(m) \<and> 0 < natify(n)"
apply (subgoal_tac "0 < natify (m) #*natify (n) \<longleftrightarrow> 0 < natify (m) \<and> 0 < natify (n) ")
apply (rule_tac [2] n = "natify (m) " in natE)
 apply (rule_tac [4] n = "natify (n) " in natE)
  apply (rule_tac [3] n = "natify (n) " in natE)
apply auto
done

lemma mult_eq_1_iff [iff]: "m#*n = 1 \<longleftrightarrow> natify(m)=1 \<and> natify(n)=1"
apply (subgoal_tac "natify (m) #* natify (n) = 1 \<longleftrightarrow> natify (m) =1 \<and> natify (n) =1")
apply (rule_tac [2] n = "natify (m) " in natE)
 apply (rule_tac [4] n = "natify (n) " in natE)
apply auto
done

lemma mult_is_zero: "\<lbrakk>m: nat; n: nat\<rbrakk> \<Longrightarrow> (m #* n = 0) \<longleftrightarrow> (m = 0 | n = 0)"
apply auto
apply (erule natE)
apply (erule_tac [2] natE, auto)
done

lemma mult_is_zero_natify [iff]:
     "(m #* n = 0) \<longleftrightarrow> (natify(m) = 0 | natify(n) = 0)"
apply (cut_tac m = "natify (m) " and n = "natify (n) " in mult_is_zero)
apply auto
done

subsection\<open>Cancellation Laws for Common Factors in Comparisons\<close>

lemma mult_less_cancel_lemma:
     "\<lbrakk>k: nat; m: nat; n: nat\<rbrakk> \<Longrightarrow> (m#*k < n#*k) \<longleftrightarrow> (0<k \<and> m<n)"
apply (safe intro!: mult_lt_mono1)
apply (erule natE, auto)
apply (rule not_le_iff_lt [THEN iffD1])
apply (drule_tac [3] not_le_iff_lt [THEN [2] rev_iffD2])
prefer 5 apply (blast intro: mult_le_mono1, auto)
done

lemma mult_less_cancel2 [simp]:
     "(m#*k < n#*k) \<longleftrightarrow> (0 < natify(k) \<and> natify(m) < natify(n))"
apply (rule iff_trans)
apply (rule_tac [2] mult_less_cancel_lemma, auto)
done

lemma mult_less_cancel1 [simp]:
     "(k#*m < k#*n) \<longleftrightarrow> (0 < natify(k) \<and> natify(m) < natify(n))"
apply (simp (no_asm) add: mult_less_cancel2 mult_commute [of k])
done

lemma mult_le_cancel2 [simp]: "(m#*k \<le> n#*k) \<longleftrightarrow> (0 < natify(k) \<longrightarrow> natify(m) \<le> natify(n))"
apply (simp (no_asm_simp) add: not_lt_iff_le [THEN iff_sym])
apply auto
done

lemma mult_le_cancel1 [simp]: "(k#*m \<le> k#*n) \<longleftrightarrow> (0 < natify(k) \<longrightarrow> natify(m) \<le> natify(n))"
apply (simp (no_asm_simp) add: not_lt_iff_le [THEN iff_sym])
apply auto
done

lemma mult_le_cancel_le1: "k \<in> nat \<Longrightarrow> k #* m \<le> k \<longleftrightarrow> (0 < k \<longrightarrow> natify(m) \<le> 1)"
by (cut_tac k = k and m = m and n = 1 in mult_le_cancel1, auto)

lemma Ord_eq_iff_le: "\<lbrakk>Ord(m); Ord(n)\<rbrakk> \<Longrightarrow> m=n \<longleftrightarrow> (m \<le> n \<and> n \<le> m)"
by (blast intro: le_anti_sym)

lemma mult_cancel2_lemma:
     "\<lbrakk>k: nat; m: nat; n: nat\<rbrakk> \<Longrightarrow> (m#*k = n#*k) \<longleftrightarrow> (m=n | k=0)"
apply (simp (no_asm_simp) add: Ord_eq_iff_le [of "m#*k"] Ord_eq_iff_le [of m])
apply (auto simp add: Ord_0_lt_iff)
done

lemma mult_cancel2 [simp]:
     "(m#*k = n#*k) \<longleftrightarrow> (natify(m) = natify(n) | natify(k) = 0)"
apply (rule iff_trans)
apply (rule_tac [2] mult_cancel2_lemma, auto)
done

lemma mult_cancel1 [simp]:
     "(k#*m = k#*n) \<longleftrightarrow> (natify(m) = natify(n) | natify(k) = 0)"
apply (simp (no_asm) add: mult_cancel2 mult_commute [of k])
done

(** Cancellation law for division **)

lemma div_cancel_raw:
     "\<lbrakk>0<n; 0<k; k:nat; m:nat; n:nat\<rbrakk> \<Longrightarrow> (k#*m) div (k#*n) = m div n"
apply (erule_tac i = m in complete_induct)
apply (case_tac "x<n")
 apply (simp add: div_less zero_lt_mult_iff mult_lt_mono2)
apply (simp add: not_lt_iff_le zero_lt_mult_iff le_refl [THEN mult_le_mono]
          div_geq diff_mult_distrib2 [symmetric] div_termination [THEN ltD])
done

lemma div_cancel:
     "\<lbrakk>0 < natify(n);  0 < natify(k)\<rbrakk> \<Longrightarrow> (k#*m) div (k#*n) = m div n"
apply (cut_tac k = "natify (k) " and m = "natify (m)" and n = "natify (n)"
       in div_cancel_raw)
apply auto
done

subsection\<open>More Lemmas about Remainder\<close>

lemma mult_mod_distrib_raw:
     "\<lbrakk>k:nat; m:nat; n:nat\<rbrakk> \<Longrightarrow> (k#*m) mod (k#*n) = k #* (m mod n)"
apply (case_tac "k=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (case_tac "n=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (erule_tac i = m in complete_induct)
apply (case_tac "x<n")
 apply (simp (no_asm_simp) add: mod_less zero_lt_mult_iff mult_lt_mono2)
apply (simp add: not_lt_iff_le zero_lt_mult_iff le_refl [THEN mult_le_mono]
         mod_geq diff_mult_distrib2 [symmetric] div_termination [THEN ltD])
done

lemma mod_mult_distrib2: "k #* (m mod n) = (k#*m) mod (k#*n)"
apply (cut_tac k = "natify (k) " and m = "natify (m)" and n = "natify (n)"
       in mult_mod_distrib_raw)
apply auto
done

lemma mult_mod_distrib: "(m mod n) #* k = (m#*k) mod (n#*k)"
apply (simp (no_asm) add: mult_commute mod_mult_distrib2)
done

lemma mod_add_self2_raw: "n \<in> nat \<Longrightarrow> (m #+ n) mod n = m mod n"
apply (subgoal_tac " (n #+ m) mod n = (n #+ m #- n) mod n")
apply (simp add: add_commute)
apply (subst mod_geq [symmetric], auto)
done

lemma mod_add_self2 [simp]: "(m #+ n) mod n = m mod n"
apply (cut_tac n = "natify (n) " in mod_add_self2_raw)
apply auto
done

lemma mod_add_self1 [simp]: "(n#+m) mod n = m mod n"
apply (simp (no_asm_simp) add: add_commute mod_add_self2)
done

lemma mod_mult_self1_raw: "k \<in> nat \<Longrightarrow> (m #+ k#*n) mod n = m mod n"
apply (erule nat_induct)
apply (simp_all (no_asm_simp) add: add_left_commute [of _ n])
done

lemma mod_mult_self1 [simp]: "(m #+ k#*n) mod n = m mod n"
apply (cut_tac k = "natify (k) " in mod_mult_self1_raw)
apply auto
done

lemma mod_mult_self2 [simp]: "(m #+ n#*k) mod n = m mod n"
apply (simp (no_asm) add: mult_commute mod_mult_self1)
done

(*Lemma for gcd*)
lemma mult_eq_self_implies_10: "m = m#*n \<Longrightarrow> natify(n)=1 | m=0"
apply (subgoal_tac "m: nat")
 prefer 2
 apply (erule ssubst)
 apply simp
apply (rule disjCI)
apply (drule sym)
apply (rule Ord_linear_lt [of "natify(n)" 1])
apply simp_all
 apply (subgoal_tac "m #* n = 0", simp)
 apply (subst mult_natify2 [symmetric])
 apply (simp del: mult_natify2)
apply (drule nat_into_Ord [THEN Ord_0_lt, THEN [2] mult_lt_mono2], auto)
done

lemma less_imp_succ_add [rule_format]:
     "\<lbrakk>m<n; n: nat\<rbrakk> \<Longrightarrow> \<exists>k\<in>nat. n = succ(m#+k)"
apply (frule lt_nat_in_nat, assumption)
apply (erule rev_mp)
apply (induct_tac "n")
apply (simp_all (no_asm) add: le_iff)
apply (blast elim!: leE intro!: add_0_right [symmetric] add_succ_right [symmetric])
done

lemma less_iff_succ_add:
     "\<lbrakk>m: nat; n: nat\<rbrakk> \<Longrightarrow> (m<n) \<longleftrightarrow> (\<exists>k\<in>nat. n = succ(m#+k))"
by (auto intro: less_imp_succ_add)

lemma add_lt_elim2:
     "\<lbrakk>a #+ d = b #+ c; a < b; b \<in> nat; c \<in> nat; d \<in> nat\<rbrakk> \<Longrightarrow> c < d"
by (drule less_imp_succ_add, auto)

lemma add_le_elim2:
     "\<lbrakk>a #+ d = b #+ c; a \<le> b; b \<in> nat; c \<in> nat; d \<in> nat\<rbrakk> \<Longrightarrow> c \<le> d"
by (drule less_imp_succ_add, auto)

subsubsection\<open>More Lemmas About Difference\<close>

lemma diff_is_0_lemma:
     "\<lbrakk>m: nat; n: nat\<rbrakk> \<Longrightarrow> m #- n = 0 \<longleftrightarrow> m \<le> n"
apply (rule_tac m = m and n = n in diff_induct, simp_all)
done

lemma diff_is_0_iff: "m #- n = 0 \<longleftrightarrow> natify(m) \<le> natify(n)"
by (simp add: diff_is_0_lemma [symmetric])

lemma nat_lt_imp_diff_eq_0:
     "\<lbrakk>a:nat; b:nat; a<b\<rbrakk> \<Longrightarrow> a #- b = 0"
by (simp add: diff_is_0_iff le_iff)

lemma raw_nat_diff_split:
     "\<lbrakk>a:nat; b:nat\<rbrakk> \<Longrightarrow>
      (P(a #- b)) \<longleftrightarrow> ((a < b \<longrightarrow>P(0)) \<and> (\<forall>d\<in>nat. a = b #+ d \<longrightarrow> P(d)))"
apply (case_tac "a < b")
 apply (force simp add: nat_lt_imp_diff_eq_0)
apply (rule iffI, force, simp)
apply (drule_tac x="a#-b" in bspec)
apply (simp_all add: Ordinal.not_lt_iff_le add_diff_inverse)
done

lemma nat_diff_split:
   "(P(a #- b)) \<longleftrightarrow>
    (natify(a) < natify(b) \<longrightarrow>P(0)) \<and> (\<forall>d\<in>nat. natify(a) = b #+ d \<longrightarrow> P(d))"
apply (cut_tac P=P and a="natify(a)" and b="natify(b)" in raw_nat_diff_split)
apply simp_all
done

text\<open>Difference and less-than\<close>

lemma diff_lt_imp_lt: "\<lbrakk>(k#-i) < (k#-j); i\<in>nat; j\<in>nat; k\<in>nat\<rbrakk> \<Longrightarrow> j<i"
apply (erule rev_mp)
apply (simp split: nat_diff_split, auto)
 apply (blast intro: add_le_self lt_trans1)
apply (rule not_le_iff_lt [THEN iffD1], auto)
apply (subgoal_tac "i #+ da < j #+ d", force)
apply (blast intro: add_le_lt_mono)
done

lemma lt_imp_diff_lt: "\<lbrakk>j<i; i\<le>k; k\<in>nat\<rbrakk> \<Longrightarrow> (k#-i) < (k#-j)"
apply (frule le_in_nat, assumption)
apply (frule lt_nat_in_nat, assumption)
apply (simp split: nat_diff_split, auto)
  apply (blast intro: lt_asym lt_trans2)
 apply (blast intro: lt_irrefl lt_trans2)
apply (rule not_le_iff_lt [THEN iffD1], auto)
apply (subgoal_tac "j #+ d < i #+ da", force)
apply (blast intro: add_lt_le_mono)
done

lemma diff_lt_iff_lt: "\<lbrakk>i\<le>k; j\<in>nat; k\<in>nat\<rbrakk> \<Longrightarrow> (k#-i) < (k#-j) \<longleftrightarrow> j<i"
apply (frule le_in_nat, assumption)
apply (blast intro: lt_imp_diff_lt diff_lt_imp_lt)
done

end