(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

header {* Almost-Full Relations *}

theory Almost_Full_Relations
imports
  "~~/src/HOL/Library/Sublist"
  "~~/src/HOL/Library/Ramsey"
  "../Regular-Sets/Regexp_Method"
  "../Abstract-Rewriting/Seq"
  Least_Enum
  Minimal_Bad_Sequences
begin

subsection {* Basic Definitions and Facts *}

definition almost_full_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "almost_full_on P A \<longleftrightarrow> (\<forall>f \<in> SEQ A. good P f)"

lemma almost_full_on_UNIV:
  "almost_full_on (\<lambda>_ _. True) UNIV"
  by (auto simp: almost_full_on_def good_def)

lemma (in mbs) mbs':
  assumes "\<not> almost_full_on P A"
  shows "\<exists>m \<in> BAD P. \<forall>g. (m, g) \<in> gseq \<longrightarrow> good P g"
  using assms and mbs
  unfolding almost_full_on_def by blast

lemma almost_full_onD:
  fixes f :: "nat \<Rightarrow> 'a" and A :: "'a set"
  assumes "almost_full_on P A" and "\<And>i. f i \<in> A"
  obtains i j where "i < j" and "P (f i) (f j)"
  using assms unfolding almost_full_on_def by blast

lemma almost_full_onI [Pure.intro]:
  "(\<And>f. \<forall>i. f i \<in> A \<Longrightarrow> good P f) \<Longrightarrow> almost_full_on P A"
  unfolding almost_full_on_def by blast

lemma almost_full_on_imp_reflp_on:
  assumes "almost_full_on P A"
  shows "reflp_on P A"
  using assms by (auto simp: almost_full_on_def reflp_on_def)

lemma almost_full_on_subset:
  "A \<subseteq> B \<Longrightarrow> almost_full_on P B \<Longrightarrow> almost_full_on P A"
  by (auto simp: almost_full_on_def)

lemma almost_full_on_mono:
  assumes "A \<subseteq> B" and "\<And>x y. Q x y \<Longrightarrow> P x y"
    and "almost_full_on Q B"
  shows "almost_full_on P A"
  using assms by (metis almost_full_on_def almost_full_on_subset good_def)

text {*
  Every sequence over elements of an almost-full set has a homogeneous subsequence.
*}
lemma almost_full_on_imp_homogeneous_subseq:
  assumes "almost_full_on P A"
    and "\<forall>i::nat. f i \<in> A"
  shows "\<exists>\<phi>::nat \<Rightarrow> nat. \<forall>i j. i < j \<longrightarrow> \<phi> i < \<phi> j \<and> P (f (\<phi> i)) (f (\<phi> j))"
proof -
  def X \<equiv> "{{i, j} | i j::nat. i < j \<and> P (f i) (f j)}"
  def Y \<equiv> "- X"
  def h \<equiv> "\<lambda>Z. if Z \<in> X then 0 else Suc 0"

  have [iff]: "\<And>x y. h {x, y} = 0 \<longleftrightarrow> {x, y} \<in> X" by (auto simp: h_def)
  have [iff]: "\<And>x y. h {x, y} = Suc 0 \<longleftrightarrow> {x, y} \<in> Y" by (auto simp: h_def Y_def)

  have "\<forall>x\<in>UNIV. \<forall>y\<in>UNIV. x \<noteq> y \<longrightarrow> h {x, y} < 2" by (simp add: h_def)
  from Ramsey2 [OF infinite_UNIV_nat this] obtain I c
    where "infinite I" and "c < 2"
    and *: "\<forall>x\<in>I. \<forall>y\<in>I. x \<noteq> y \<longrightarrow> h {x, y} = c" by blast
  then interpret infinitely_many1 "\<lambda>i. i \<in> I"
    by (unfold_locales) (simp add: infinite_nat_iff_unbounded)

  have "c = 0 \<or> c = 1" using `c < 2` by arith
  then show ?thesis
  proof
    assume [simp]: "c = 0"
    have "\<forall>i j. i < j \<longrightarrow> P (f (enum i)) (f (enum j))"
    proof (intro allI impI)
      fix i j :: nat
      assume "i < j"
      from * and enum_P and enum_less [OF `i < j`] have "{enum i, enum j} \<in> X" by auto
      with enum_less [OF `i < j`]
        show "P (f (enum i)) (f (enum j))" by (auto simp: X_def doubleton_eq_iff)
    qed
    then show ?thesis using enum_less by blast
  next
    assume [simp]: "c = 1"
    have "\<forall>i j. i < j \<longrightarrow> \<not> P (f (enum i)) (f (enum j))"
    proof (intro allI impI)
      fix i j :: nat
      assume "i < j"
      from * and enum_P and enum_less [OF `i < j`] have "{enum i, enum j} \<in> Y" by auto
      with enum_less [OF `i < j`]
        show "\<not> P (f (enum i)) (f (enum j))" by (auto simp: Y_def X_def doubleton_eq_iff)
    qed
    then have "\<not> good P (f \<circ> enum)" by auto
    moreover have "\<forall>i. f (enum i) \<in> A" using assms by auto
    ultimately show ?thesis using `almost_full_on P A` by (simp add: almost_full_on_def)
  qed
qed

text {*
  Almost full relations do not admit infinite antichains.
*}
lemma almost_full_on_imp_no_antichain_on:
  assumes "almost_full_on P A"
  shows "\<not> antichain_on P f A"
proof
  assume *: "antichain_on P f A"
  then have "\<forall>i. f i \<in> A" by simp
  with assms have "good P f" by (auto simp: almost_full_on_def)
  then obtain i j where "i < j" and "P (f i) (f j)"
    unfolding good_def by auto
  moreover with * have "incomparable P (f i) (f j)" by auto
  ultimately show False by blast
qed

text {*
  If the image of a function is almost-full then also its preimage is almost-full.
*}
lemma almost_full_on_map:
  assumes "almost_full_on Q B"
    and "h ` A \<subseteq> B"
  shows "almost_full_on (\<lambda>x y. Q (h x) (h y)) A" (is "almost_full_on ?P A")
proof
  fix f
  assume "\<forall>i::nat. f i \<in> A"
  then have "\<And>i. h (f i) \<in> B" using \<open>h ` A \<subseteq> B\<close> by auto
  with `almost_full_on Q B` [unfolded almost_full_on_def, THEN bspec, of "h \<circ> f"]
    show "good ?P f" unfolding good_def comp_def by blast
qed

text {*
  The homomorphic image of an almost-full set is almost-full.
*}
lemma almost_full_on_hom:
  fixes h :: "'a \<Rightarrow> 'b"
  assumes hom: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A; P x y\<rbrakk> \<Longrightarrow> Q (h x) (h y)"
    and af: "almost_full_on P A"
  shows "almost_full_on Q (h ` A)"
proof
  fix f :: "nat \<Rightarrow> 'b"
  assume "\<forall>i. f i \<in> h ` A"
  then have "\<forall>i. \<exists>x. x \<in> A \<and> f i = h x" by (auto simp: image_def)
  from choice [OF this] obtain g
    where *: "\<forall>i. g i \<in> A \<and> f i = h (g i)" by blast
  show "good Q f"
  proof (rule ccontr)
    assume bad: "bad Q f"
    { fix i j :: nat
      assume "i < j"
      from bad have "\<not> Q (f i) (f j)" using `i < j` by (auto simp: good_def)
      with hom have "\<not> P (g i) (g j)" using * by auto }
    then have "bad P g" by (auto simp: good_def)
    with af and * show False by (auto simp: good_def almost_full_on_def)
  qed
qed

text {*
  The monomorphic preimage of an almost-full set is almost-full.
*}
lemma almost_full_on_mon:
  assumes mon: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> P x y = Q (h x) (h y)" "bij_betw h A B"
    and af: "almost_full_on Q B"
  shows "almost_full_on P A"
proof
  fix f :: "nat \<Rightarrow> 'a"
  assume *: "\<forall>i. f i \<in> A"
  then have **: "\<forall>i. (h \<circ> f) i \<in> B" using mon by (auto simp: bij_betw_def)
  show "good P f"
  proof (rule ccontr)
    assume bad: "bad P f"
    { fix i j :: nat
      assume "i < j"
      from bad have "\<not> P (f i) (f j)" using `i < j` by (auto simp: good_def)
      with mon have "\<not> Q (h (f i)) (h (f j))"
        using * by (auto simp: bij_betw_def inj_on_def) }
    then have "bad Q (h \<circ> f)" by (auto simp: good_def)
    with af and ** show False by (auto simp: good_def almost_full_on_def)
  qed
qed

text {*
  Every total and well-founded relation is almost-full.
*}
lemma total_on_and_wfp_on_imp_almost_full_on:
  assumes "total_on P A" and "wfp_on P A"
  shows "almost_full_on P\<^sup>=\<^sup>= A"
proof (rule ccontr)
  assume "\<not> almost_full_on P\<^sup>=\<^sup>= A"
  then obtain f :: "nat \<Rightarrow> 'a" where *: "\<And>i. f i \<in> A"
    and "\<forall>i j. i < j \<longrightarrow> \<not> P\<^sup>=\<^sup>= (f i) (f j)"
    unfolding almost_full_on_def by (auto dest: badE)
  with `total_on P A` have "\<forall>i j. i < j \<longrightarrow> P (f j) (f i)"
    unfolding total_on_def by blast
  then have "\<And>i. P (f (Suc i)) (f i)" by auto
  with `wfp_on P A` and * show False
    unfolding wfp_on_def by blast
qed

(*TODO: move to Option.thy of Isabelle/HOL?*)
subsection {* Adding a Bottom Element to a Set *}

definition with_bot :: "'a set \<Rightarrow> 'a option set" ("_\<^sub>\<bottom>" [1000] 1000)
where
  "A\<^sub>\<bottom> = {None} \<union> Some ` A"

lemma with_bot_iff [iff]:
  "Some x \<in> A\<^sub>\<bottom> \<longleftrightarrow> x \<in> A"
  by (auto simp: with_bot_def)

lemma NoneI [simp, intro]:
  "None \<in> A\<^sub>\<bottom>"
  by (simp add: with_bot_def)

lemma not_None_the_mem [simp]:
  "x \<noteq> None \<Longrightarrow> the x \<in> A \<longleftrightarrow> x \<in> A\<^sub>\<bottom>"
  by auto

lemma with_bot_cases:
  "u \<in> A\<^sub>\<bottom> \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> u = Some x \<Longrightarrow> P) \<Longrightarrow> (u = None \<Longrightarrow> P) \<Longrightarrow> P"
  by auto

lemma with_bot_empty_conv [iff]:
  "A\<^sub>\<bottom> = {None} \<longleftrightarrow> A = {}"
  by (auto elim: with_bot_cases)

lemma with_bot_UNIV [simp]:
  "UNIV\<^sub>\<bottom> = UNIV"
proof (rule set_eqI)
  fix x :: "'a option"
  show "x \<in> UNIV\<^sub>\<bottom> \<longleftrightarrow> x \<in> UNIV" by (cases x) auto
qed

subsection {* Adding a Bottom Element to an Almost-Full Set *}

fun
  option_le :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a option \<Rightarrow> 'a option \<Rightarrow> bool"
where
  "option_le P None y = True" |
  "option_le P (Some x) None = False" |
  "option_le P (Some x) (Some y) = P x y"

lemma None_imp_good_option_le [simp]:
  assumes "f i = None"
  shows "good (option_le P) f"
  by (rule goodI [of i "Suc i"]) (auto simp: assms)

lemma almost_full_on_with_bot:
  assumes "almost_full_on P A"
  shows "almost_full_on (option_le P) A\<^sub>\<bottom>" (is "almost_full_on ?P ?A")
proof
  fix f :: "nat \<Rightarrow> 'a option"
  assume *: "\<forall>i. f i \<in> ?A"
  show "good ?P f"
  proof (cases "\<forall>i. f i \<noteq> None")
    case True
    then have **: "\<And>i. Some (the (f i)) = f i"
      and "\<And>i. the (f i) \<in> A" using * by auto
    with almost_full_onD [OF assms, of "the \<circ> f"] obtain i j where "i < j"
      and "P (the (f i)) (the (f j))" by auto
    then have "?P (Some (the (f i))) (Some (the (f j)))" by simp
    then have "?P (f i) (f j)" unfolding ** .
    with `i < j` show "good ?P f" by (auto simp: good_def)
  qed auto
qed

subsection {* Disjoint Union of Almost-Full Sets *}

fun
  sum_le :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a + 'b \<Rightarrow> 'a + 'b \<Rightarrow> bool"
where
  "sum_le P Q (Inl x) (Inl y) = P x y" |
  "sum_le P Q (Inr x) (Inr y) = Q x y" |
  "sum_le P Q x y = False"

lemma not_sum_le_cases:
  assumes "\<not> sum_le P Q a b"
    and "\<And>x y. \<lbrakk>a = Inl x; b = Inl y; \<not> P x y\<rbrakk> \<Longrightarrow> thesis"
    and "\<And>x y. \<lbrakk>a = Inr x; b = Inr y; \<not> Q x y\<rbrakk> \<Longrightarrow> thesis"
    and "\<And>x y. \<lbrakk>a = Inl x; b = Inr y\<rbrakk> \<Longrightarrow> thesis"
    and "\<And>x y. \<lbrakk>a = Inr x; b = Inl y\<rbrakk> \<Longrightarrow> thesis"
  shows thesis
  using assms by (cases a b rule: sum.exhaust [case_product sum.exhaust]) auto

text {*
  When two sets are almost-full, then their disjoint sum is almost-full.
*}
lemma almost_full_on_Plus:
  assumes "almost_full_on P A" and "almost_full_on Q B"
  shows "almost_full_on (sum_le P Q) (A <+> B)" (is "almost_full_on ?P ?A")
proof
  fix f :: "nat \<Rightarrow> ('a + 'b)"
  let ?I = "f -` Inl ` A"
  let ?J = "f -` Inr ` B"
  assume "\<forall>i. f i \<in> ?A"
  then have *: "?J = (UNIV::nat set) - ?I" by (fastforce)
  show "good ?P f"
  proof (rule ccontr)
    assume bad: "bad ?P f"
    show False
    proof (cases "finite ?I")
      assume "finite ?I"
      then have "infinite ?J" by (auto simp: *)
      then interpret infinitely_many1 "\<lambda>i. f i \<in> Inr ` B"
        by (unfold_locales) (simp add: infinite_nat_iff_unbounded)
      have [dest]: "\<And>i x. f (enum i) = Inl x \<Longrightarrow> False"
        using enum_P by (auto simp: image_iff) (metis Inr_Inl_False)
      let ?f = "\<lambda>i. projr (f (enum i))"
      have B: "\<And>i. ?f i \<in> B" using enum_P by (auto simp: image_iff) (metis sum.sel(2))
      { fix i j :: nat
        assume "i < j"
        then have "enum i < enum j" using enum_less by auto
        with bad have "\<not> ?P (f (enum i)) (f (enum j))" by (auto simp: good_def)
        then have "\<not> Q (?f i) (?f j)" by (auto elim: not_sum_le_cases) }
      then have "bad Q ?f" by (auto simp: good_def)
      moreover from `almost_full_on Q B` and B
        have "good Q ?f" by (auto simp: good_def almost_full_on_def)
      ultimately show False by blast
    next
      assume "infinite ?I"
      then interpret infinitely_many1 "\<lambda>i. f i \<in> Inl ` A"
        by (unfold_locales) (simp add: infinite_nat_iff_unbounded)
      have [dest]: "\<And>i x. f (enum i) = Inr x \<Longrightarrow> False"
        using enum_P by (auto simp: image_iff) (metis Inr_Inl_False)
      let ?f = "\<lambda>i. projl (f (enum i))"
      have A: "\<forall>i. ?f i \<in> A" using enum_P by (auto simp: image_iff) (metis sum.sel(1))
      { fix i j :: nat
        assume "i < j"
        then have "enum i < enum j" using enum_less by auto
        with bad have "\<not> ?P (f (enum i)) (f (enum j))" by (auto simp: good_def)
        then have "\<not> P (?f i) (?f j)" by (auto elim: not_sum_le_cases) }
      then have "bad P ?f" by (auto simp: good_def)
      moreover from `almost_full_on P A` and A
        have "good P ?f" by (auto simp: good_def almost_full_on_def)
      ultimately show False by blast
    qed
  qed
qed

subsection {* Dickson's Lemma for Almost-Full Relations *}

text {*
  When two sets are almost-full, then their Cartesian product is almost-full.
*}

definition
  prod_le :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool"
where
  "prod_le P1 P2 = (\<lambda>(p1, p2) (q1, q2). P1 p1 q1 \<and> P2 p2 q2)"

lemma prod_le_True [simp]:
  "prod_le P (\<lambda>_ _. True) a b = P (fst a) (fst b)"
  by (auto simp: prod_le_def)

lemma almost_full_on_Sigma:
  assumes "almost_full_on P1 A1" and "almost_full_on P2 A2"
  shows "almost_full_on (prod_le P1 P2) (A1 \<times> A2)" (is "almost_full_on ?P ?A")
proof (rule ccontr)
  assume "\<not> almost_full_on ?P ?A"
  then obtain f where f: "\<forall>i. f i \<in> ?A"
    and bad: "bad ?P f" by (auto simp: almost_full_on_def)
  let ?W = "\<lambda>x y. P1 (fst x) (fst y)"
  let ?B = "\<lambda>x y. P2 (snd x) (snd y)"
  from f have fst: "\<forall>i. fst (f i) \<in> A1" and snd: "\<forall>i. snd (f i) \<in> A2"
    by (metis SigmaE fst_conv, metis SigmaE snd_conv)
  from almost_full_on_imp_homogeneous_subseq [OF assms(1) fst]
    obtain \<phi> :: "nat \<Rightarrow> nat" where mono: "\<And>i j. i < j \<Longrightarrow> \<phi> i < \<phi> j"
    and *: "\<And>i j. i < j \<Longrightarrow> ?W (f (\<phi> i)) (f (\<phi> j))" by auto
  from snd have "\<forall>i. snd (f (\<phi> i)) \<in> A2" by auto
  then have "snd \<circ> f \<circ> \<phi> \<in> SEQ A2" by auto
  with assms(2) have "good P2 (snd \<circ> f \<circ> \<phi>)" by (auto simp: almost_full_on_def)
  then obtain i j :: nat
    where "i < j" and "?B (f (\<phi> i)) (f (\<phi> j))" by auto
  with * [OF `i < j`] have "?P (f (\<phi> i)) (f (\<phi> j))" by (simp add: case_prod_beta prod_le_def)
  with mono [OF `i < j`] and bad show False by auto
qed

subsection {* Higman's Lemma for Almost-Full Relations *}

lemma Nil_imp_good_list_emb [simp]:
  assumes "f i = []"
  shows "good (list_emb P) f"
proof (rule ccontr)
  assume "bad (list_emb P) f"
  moreover have "(list_emb P) (f i) (f (Suc i))"
    unfolding assms by auto
  ultimately show False
    unfolding good_def by auto
qed

lemma ne_lists:
  assumes "xs \<noteq> []" and "xs \<in> lists A"
  shows "hd xs \<in> A" and "tl xs \<in> lists A"
  using assms by (case_tac [!] xs) simp_all

lemma almost_full_on_lists:
  assumes "almost_full_on P A"
  shows "almost_full_on (list_emb P) (lists A)" (is "almost_full_on ?P ?A")
proof (rule ccontr)
  interpret mbs ?A .
  assume "\<not> ?thesis"
  from mbs' [OF this] obtain m
    where bad: "m \<in> BAD ?P"
    and min: "\<forall>g. (m, g) \<in> gseq \<longrightarrow> good ?P g" ..
  then have lists: "\<And>i. m i \<in> lists A"
    and ne: "\<And>i. m i \<noteq> []" by auto

  def h \<equiv> "\<lambda>i. hd (m i)"
  def t \<equiv> "\<lambda>i. tl (m i)"

  have m: "\<And>i. m i = h i # t i" using ne by (simp add: h_def t_def)

  have "\<forall>i. h i \<in> A" using ne_lists [OF ne] and lists by (auto simp add: h_def)
  from almost_full_on_imp_homogeneous_subseq [OF assms this] obtain \<phi> :: "nat \<Rightarrow> nat"
    where less: "\<And>i j. i < j \<Longrightarrow> \<phi> i < \<phi> j"
      and P: "\<forall>i j. i < j \<longrightarrow> P (h (\<phi> i)) (h (\<phi> j))" by blast

  have bad_t: "bad ?P (t \<circ> \<phi>)"
  proof
    assume "good ?P (t \<circ> \<phi>)"
    then obtain i j where "i < j" and "?P (t (\<phi> i)) (t (\<phi> j))" by auto
    moreover with P have "P (h (\<phi> i)) (h (\<phi> j))" by blast
    ultimately have "?P (m (\<phi> i)) (m (\<phi> j))"
      by (subst (1 2) m) (rule list_emb_Cons2, auto)
    with less and `i < j` have "good ?P m" by (auto simp: good_def)
    with bad show False by blast
  qed

  def m' \<equiv> "\<lambda>i. if i < \<phi> 0 then m i else t (\<phi> (i - \<phi> 0))"

  have m'_less: "\<And>i. i < \<phi> 0 \<Longrightarrow> m' i = m i" by (simp add: m'_def)
  have m'_geq: "\<And>i. i \<ge> \<phi> 0 \<Longrightarrow> m' i = t (\<phi> (i - \<phi> 0))" by (simp add: m'_def)

  have "\<forall>i. m' i \<in> lists A" using ne_lists [OF ne] and lists by (auto simp: m'_def t_def)
  moreover have "length (m' (\<phi> 0)) < length (m (\<phi> 0))" using ne by (simp add: t_def m'_geq)
  moreover have "\<forall>j<\<phi> 0. m' j = m j" by (auto simp: m'_less)
  ultimately have "(m, m') \<in> gseq" using lists by (auto simp: gseq_def)
  moreover have "bad ?P m'"
  proof
    assume "good ?P m'"
    then obtain i j where "i < j" and emb: "?P (m' i) (m' j)" by (auto simp: good_def)
    { assume "j < \<phi> 0"
      with `i < j` and emb have "?P (m i) (m j)" by (auto simp: m'_less)
      with `i < j` and bad have False by blast }
    moreover
    { assume "\<phi> 0 \<le> i"
      with `i < j` and emb have "?P (t (\<phi> (i - \<phi> 0))) (t (\<phi> (j - \<phi> 0)))"
        and "i - \<phi> 0 < j - \<phi> 0" by (auto simp: m'_geq)
      with bad_t have False by auto }
    moreover
    { assume "i < \<phi> 0" and "\<phi> 0 \<le> j"
      with `i < j` and emb have "?P (m i) (t (\<phi> (j - \<phi> 0)))" by (simp add: m'_less m'_geq)
      from list_emb_Cons [OF this, of "h (\<phi> (j - \<phi> 0))"]
        have "?P (m i) (m (\<phi> (j - \<phi> 0)))" using ne by (simp add: h_def t_def)
      moreover have "i < \<phi> (j - \<phi> 0)"
        using less [of 0 "j - \<phi> 0"] and `i < \<phi> 0` and `\<phi> 0 \<le> j`
        by (cases "j = \<phi> 0") auto
      ultimately have False using bad by blast }
    ultimately show False using `i < j` by arith
  qed
  ultimately show False using min by blast
qed

lemma list_emb_eq_length_induct [consumes 2, case_names Nil Cons]:
  assumes "length xs = length ys"
    and "list_emb P xs ys"
    and "Q [] []"
    and "\<And>x y xs ys. \<lbrakk>P x y; list_emb P xs ys; Q xs ys\<rbrakk> \<Longrightarrow> Q (x#xs) (y#ys)"
  shows "Q xs ys"
  using assms(2, 1, 3-) by (induct) (auto dest: list_emb_length)

lemma list_emb_eq_length_P:
  assumes "length xs = length ys"
    and "list_emb P xs ys"
  shows "\<forall>i<length xs. P (xs ! i) (ys ! i)"
using assms
proof (induct rule: list_emb_eq_length_induct)
  case (Cons x y xs ys)
  show ?case
  proof (intro allI impI)
    fix i assume "i < length (x # xs)"
    with Cons show "P ((x#xs)!i) ((y#ys)!i)"
      by (cases i) simp_all
  qed
qed simp

subsection {* Special Case: Finite Sets *}

text {*
  Every reflexive relation on a finite set is almost-full.
*}
lemma finite_almost_full_on:
  assumes finite: "finite A"
    and refl: "reflp_on P A"
  shows "almost_full_on P A"
proof
  fix f :: "nat \<Rightarrow> 'a"
  assume *: "\<forall>i. f i \<in> A"
  let ?I = "UNIV::nat set"
  have "f ` ?I \<subseteq> A" using * by auto
  with finite and finite_subset have 1: "finite (f ` ?I)" by blast
  have "infinite ?I" by auto
  from pigeonhole_infinite [OF this 1]
    obtain k where "infinite {j. f j = f k}" by auto
  then obtain l where "k < l" and "f l = f k"
    unfolding infinite_nat_iff_unbounded by auto
  then have "P (f k) (f l)" using refl and * by (auto simp: reflp_on_def)
  with `k < l` show "good P f" by (auto simp: good_def)
qed

lemma eq_almost_full_on_finite_set:
  assumes "finite A"
  shows "almost_full_on (op =) A"
  using finite_almost_full_on [OF assms, of "op ="]
  by (auto simp: reflp_on_def)

subsection {* Natural Numbers *}

lemma almost_full_on_UNIV_nat:
  "almost_full_on (op \<le>) (UNIV :: nat set)"
proof -
  let ?P = "sublisteq :: bool list \<Rightarrow> bool list \<Rightarrow> bool"
  have *: "length ` (UNIV :: bool list set) = (UNIV :: nat set)"
    by (metis Ex_list_of_length surj_def)
  have "almost_full_on (op \<le>) (length ` (UNIV :: bool list set))"
  proof (rule almost_full_on_hom)
    fix xs ys :: "bool list"
    assume "?P xs ys"
    then show "length xs \<le> length ys"
      by (metis list_emb_length)
  next
    have "finite (UNIV :: bool set)" by auto
    from almost_full_on_lists [OF eq_almost_full_on_finite_set [OF this]]
      show "almost_full_on ?P UNIV" unfolding lists_UNIV .
  qed
  then show ?thesis unfolding * .
qed

subsection {* Further Results *}

lemma af_trans_imp_wf:
  assumes af: "almost_full_on P A"
    and trans: "transp_on P A"
  shows "wfp_on (strict P) A"
proof -
  show "wfp_on (strict P) A"
  proof (unfold wfp_on_def, rule notI)
    assume "\<exists>f. \<forall>i. f i \<in> A \<and> strict P (f (Suc i)) (f i)"
    then obtain f where *: "chain_on ((strict P)\<inverse>\<inverse>) f A" by blast
    from chain_on_transp_on_less [OF this]
      and transp_on_strict [THEN transp_on_converse, OF trans]
      have "\<forall>i j. i < j \<longrightarrow> \<not> P (f i) (f j)" by blast
    with af show False
      using * by (auto simp: almost_full_on_def good_def)
  qed
qed

lemma wf_and_no_antichain_imp_qo_extension_wf:
  assumes wf: "wfp_on (strict P) A"
    and anti: "\<not> (\<exists>f. antichain_on P f A)"
    and subrel: "\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q x y"
    and qo: "qo_on Q A"
  shows "wfp_on (strict Q) A"
proof (rule ccontr)
  have "transp_on (strict Q) A"
    using qo unfolding qo_on_def transp_on_def by blast
  then have *: "transp_on ((strict Q)\<inverse>\<inverse>) A" by (rule transp_on_converse)
  assume "\<not> wfp_on (strict Q) A"
  then obtain f :: "nat \<Rightarrow> 'a" where A: "\<And>i. f i \<in> A"
    and "\<forall>i. strict Q (f (Suc i)) (f i)" unfolding wfp_on_def by blast+
  then have "chain_on ((strict Q)\<inverse>\<inverse>) f A" by auto
  from chain_on_transp_on_less [OF this *]
    have *: "\<And>i j. i < j \<Longrightarrow> \<not> P (f i) (f j)"
    using subrel and A by blast
  show False
  proof (cases)
    assume "\<exists>k. \<forall>i>k. \<exists>j>i. P (f j) (f i)"
    then obtain k where "\<forall>i>k. \<exists>j>i. P (f j) (f i)" by auto
    from subchain [of k _ f, OF this] obtain g
      where "\<And>i j. i < j \<Longrightarrow> g i < g j"
      and "\<And>i. P (f (g (Suc i))) (f (g i))" by auto
    with * have "\<And>i. strict P (f (g (Suc i))) (f (g i))" by blast
    with wf [unfolded wfp_on_def not_ex, THEN spec, of "\<lambda>i. f (g i)"] and A
      show False by fast
  next
    assume "\<not> (\<exists>k. \<forall>i>k. \<exists>j>i. P (f j) (f i))"
    then have "\<forall>k. \<exists>i>k. \<forall>j>i. \<not> P (f j) (f i)" by auto
    from choice [OF this] obtain h
      where "\<forall>k. h k > k"
      and **: "\<forall>k. (\<forall>j>h k. \<not> P (f j) (f (h k)))" by auto
    def [simp]: \<phi> \<equiv> "\<lambda>i. (h ^^ Suc i) 0"
    have "\<And>i. \<phi> i < \<phi> (Suc i)"
      using `\<forall>k. h k > k` by (induct_tac i) auto
    then have mono: "\<And>i j. i < j \<Longrightarrow> \<phi> i < \<phi> j" by (metis lift_Suc_mono_less)
    then have "\<forall>i j. i < j \<longrightarrow> \<not> P (f (\<phi> j)) (f (\<phi> i))"
      using ** by auto
    with mono [THEN *]
      have "\<forall>i j. i < j \<longrightarrow> incomparable P (f (\<phi> j)) (f (\<phi> i))" by blast
    moreover have "\<exists>i j. i < j \<and> \<not> incomparable P (f (\<phi> i)) (f (\<phi> j))"
      using anti [unfolded not_ex, THEN spec, of "\<lambda>i. f (\<phi> i)"] and A by blast
    ultimately show False by blast
  qed
qed

lemma every_qo_extension_wf_imp_af:
  assumes ext: "\<forall>Q. (\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q x y) \<and>
    qo_on Q A \<longrightarrow> wfp_on (strict Q) A"
    and "qo_on P A"
  shows "almost_full_on P A"
proof
  from `qo_on P A`
    have refl: "reflp_on P A"
    and trans: "transp_on P A"
    by (auto intro: qo_on_imp_reflp_on qo_on_imp_transp_on)

  fix f :: "nat \<Rightarrow> 'a"
  assume "\<forall>i. f i \<in> A"
  then have A: "\<And>i. f i \<in> A" ..
  show "good P f"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have bad: "\<forall>i j. i < j \<longrightarrow> \<not> P (f i) (f j)" by (auto simp: good_def)
    then have *: "\<And>i j. P (f i) (f j) \<Longrightarrow> i \<ge> j" by (metis not_leE)

    def [simp]: D \<equiv> "\<lambda>x y. \<exists>i. x = f (Suc i) \<and> y = f i"
    def P' \<equiv> "restrict_to P A"
    def [simp]: Q \<equiv> "(sup P' D)\<^sup>*\<^sup>*"

    have **: "\<And>i j. (D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+ (f i) (f j) \<Longrightarrow> i > j"
    proof -
      fix i j
      assume "(D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+ (f i) (f j)"
      then show "i > j"
        apply (induct "f i" "f j" arbitrary: j)
        apply (insert A, auto dest!: * simp: P'_def reflp_on_restrict_to_rtranclp [OF refl trans])
        apply (metis "*" dual_order.strict_trans1 less_Suc_eq_le refl reflp_on_def)
        by (metis le_imp_less_Suc less_trans)
    qed

    have "\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q x y" by (auto simp: P'_def)
    moreover have "qo_on Q A" by (auto simp: qo_on_def reflp_on_def transp_on_def)
    ultimately have "wfp_on (strict Q) A"
        using ext [THEN spec, of Q] by blast
    moreover have "\<forall>i. f i \<in> A \<and> strict Q (f (Suc i)) (f i)"
    proof
      fix i
      have "\<not> Q (f i) (f (Suc i))"
      proof
        assume "Q (f i) (f (Suc i))"
        then have "(sup P' D)\<^sup>*\<^sup>* (f i) (f (Suc i))" by auto
        moreover have "(sup P' D)\<^sup>*\<^sup>* = sup (P'\<^sup>*\<^sup>*) (P'\<^sup>*\<^sup>* OO (D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+)"
        proof -
          have "\<And>A B. (A \<union> B)\<^sup>* = A\<^sup>* \<union> A\<^sup>* O (B O A\<^sup>*)\<^sup>+" by regexp
          from this [to_pred] show ?thesis by blast
        qed
        ultimately have "sup (P'\<^sup>*\<^sup>*) (P'\<^sup>*\<^sup>* OO (D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+) (f i) (f (Suc i))" by simp
        then have "(P'\<^sup>*\<^sup>* OO (D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+) (f i) (f (Suc i))" by auto
        then have "Suc i < i"
          using ** apply auto
          by (metis (lifting, mono_tags) max.semilattice_strict_iff_order relcompp.relcompI tranclp_into_tranclp2)
        then show False by auto
      qed
      with A [of i] show "f i \<in> A \<and> strict Q (f (Suc i)) (f i)" by auto
    qed
    ultimately show False unfolding wfp_on_def by blast
  qed
qed

end


section \<open>Properties of the Generalized Multiset Ordering\<close>

theory Multiset_Ordering_More
  imports
    Weighted_Path_Order.Multiset_Extension2
begin

text \<open>We provide characterizations of @{const s_mul_ext} and @{const ns_mul_ext} via
  introduction and elimination rules that are based on lists.\<close>

lemma s_mul_ext_intro:
  assumes "xs = mset xs1 + mset xs2"
  and "ys = mset ys1 + mset ys2"
  and "length xs1 = length ys1"
  and "\<And>i. i < length ys1 \<Longrightarrow> (xs1 ! i, ys1 ! i) \<in> NS"
  and "xs2 \<noteq> []"
  and "\<And>y. y \<in> set ys2 \<Longrightarrow> \<exists>a \<in> set xs2. (a, y) \<in> S"
shows "(xs, ys) \<in> s_mul_ext NS S"
  by (rule s_mul_extI[OF assms(1-2) multpw_listI[OF assms(3)]], insert assms(4-), auto)

lemma ns_mul_ext_intro:
  assumes "xs = mset xs1 + mset xs2"
  and "ys = mset ys1 + mset ys2"
  and "length xs1 = length ys1"
  and "\<And>i. i < length ys1 \<Longrightarrow> (xs1 ! i, ys1 ! i) \<in> NS"
  and "\<And>y. y \<in> set ys2 \<Longrightarrow> \<exists>x \<in> set xs2. (x, y) \<in> S"
shows "(xs, ys) \<in> ns_mul_ext NS S"
  by (rule ns_mul_extI[OF assms(1-2) multpw_listI[OF assms(3)]], insert assms(4-), auto)

lemma ns_mul_ext_elim: assumes "(xs, ys) \<in> ns_mul_ext NS S"
  shows "\<exists> xs1 xs2 ys1 ys2.
    xs = mset xs1 + mset xs2
  \<and> ys = mset ys1 + mset ys2
  \<and> length xs1 = length ys1
  \<and> (\<forall> i. i < length ys1 \<longrightarrow> (xs1 ! i, ys1 ! i) \<in> NS)
  \<and> (\<forall> y \<in> set ys2. \<exists>x \<in> set xs2. (x, y) \<in> S)"
proof -
  from ns_mul_extE[OF assms] obtain
    A1 A2 B1 B2 where *: "xs = A1 + A2" "ys = B1 + B2"
    and NS: "(A1, B1) \<in> multpw NS"
      and S: "\<And>b. b \<in># B2 \<Longrightarrow> \<exists>a. a \<in># A2 \<and> (a, b) \<in> S"
    by blast
  from multpw_listE[OF NS] obtain xs1 ys1 where **: "length xs1 = length ys1" "A1 = mset xs1" "B1 = mset ys1"
    and NS: "\<And> i. i < length ys1 \<Longrightarrow> (xs1 ! i, ys1 ! i) \<in> NS" by auto
  from surj_mset obtain xs2 where A2: "A2 = mset xs2" by auto
  from surj_mset obtain ys2 where B2: "B2 = mset ys2" by auto
  show ?thesis
  proof (rule exI[of _ xs1], rule exI[of _ xs2], rule exI[of _ ys1], rule exI[of _ ys2], intro conjI)
    show "xs = mset xs1 + mset xs2" using * ** A2 B2 by auto
    show "ys = mset ys1 + mset ys2" using * ** A2 B2 by auto
    show "length xs1 = length ys1"  by fact
    show "\<forall>i<length ys1. (xs1 ! i, ys1 ! i) \<in> NS" using * ** A2 B2 NS by auto
    show "\<forall>y\<in>set ys2. \<exists>x\<in>set xs2. (x, y) \<in> S" using * ** A2 B2 S by auto
  qed
qed

lemma s_mul_ext_elim: assumes "(xs, ys) \<in> s_mul_ext NS S"
  shows "\<exists> xs1 xs2 ys1 ys2.
    xs = mset xs1 + mset xs2
  \<and> ys = mset ys1 + mset ys2
  \<and> length xs1 = length ys1
  \<and> xs2 \<noteq> []
  \<and> (\<forall> i. i < length ys1 \<longrightarrow> (xs1 ! i, ys1 ! i) \<in> NS)
  \<and> (\<forall> y \<in> set ys2. \<exists>x \<in> set xs2. (x, y) \<in> S)"
proof -
  from s_mul_extE[OF assms] obtain
    A1 A2 B1 B2 where *: "xs = A1 + A2" "ys = B1 + B2"
    and NS: "(A1, B1) \<in> multpw NS" and nonempty: "A2 \<noteq> {#}"
      and S: "\<And>b. b \<in># B2 \<Longrightarrow> \<exists>a. a \<in># A2 \<and> (a, b) \<in> S"
    by blast
  from multpw_listE[OF NS] obtain xs1 ys1 where **: "length xs1 = length ys1" "A1 = mset xs1" "B1 = mset ys1"
    and NS: "\<And> i. i < length ys1 \<Longrightarrow> (xs1 ! i, ys1 ! i) \<in> NS" by auto
  from surj_mset obtain xs2 where A2: "A2 = mset xs2" by auto
  from surj_mset obtain ys2 where B2: "B2 = mset ys2" by auto
  show ?thesis
  proof (rule exI[of _ xs1], rule exI[of _ xs2], rule exI[of _ ys1], rule exI[of _ ys2], intro conjI)
    show "xs = mset xs1 + mset xs2" using * ** A2 B2 by auto
    show "ys = mset ys1 + mset ys2" using * ** A2 B2 by auto
    show "length xs1 = length ys1"  by fact
    show "\<forall>i<length ys1. (xs1 ! i, ys1 ! i) \<in> NS" using * ** A2 B2 NS by auto
    show "\<forall>y\<in>set ys2. \<exists>x\<in>set xs2. (x, y) \<in> S" using * ** A2 B2 S by auto
    show "xs2 \<noteq> []" using nonempty A2 by auto
  qed
qed

text \<open>We further add a lemma that shows, that it does not matter whether one adds the
  strict relation to the non-strict relation or not.\<close>

lemma ns_mul_ext_some_S_in_NS: assumes "S' \<subseteq> S"
  shows "ns_mul_ext (NS \<union> S') S = ns_mul_ext NS S"
proof
  show "ns_mul_ext NS S \<subseteq> ns_mul_ext (NS \<union> S') S"
    by (simp add: ns_mul_ext_mono)
  show "ns_mul_ext (NS \<union> S') S \<subseteq> ns_mul_ext NS S"
  proof
    fix as bs
    assume "(as, bs) \<in> ns_mul_ext (NS \<union> S') S"
    from ns_mul_extE[OF this] obtain nas sas nbs sbs where
       as: "as = nas + sas" and bs: "bs = nbs + sbs"
       and ns: "(nas,nbs) \<in> multpw (NS \<union> S')"
       and s: "(\<And>b. b \<in># sbs \<Longrightarrow> \<exists>a. a \<in># sas \<and> (a, b) \<in> S)" by blast
    from ns have "\<exists> nas2 sas2 nbs2 sbs2. nas = nas2 + sas2 \<and> nbs = nbs2 + sbs2 \<and> (nas2,nbs2) \<in> multpw NS
          \<and> (\<forall> b \<in># sbs2. (\<exists>a. a \<in># sas2 \<and> (a,b) \<in> S))"
    proof (induct)
      case (add a b nas nbs)
      from add(3) obtain nas2 sas2 nbs2 sbs2 where *: "nas = nas2 + sas2 \<and> nbs = nbs2 + sbs2 \<and> (nas2,nbs2) \<in> multpw NS
          \<and> (\<forall> b \<in># sbs2. (\<exists>a. a \<in># sas2 \<and> (a,b) \<in> S))" by blast
      from add(1)
      show ?case
      proof
        assume "(a,b) \<in> S'"
        with assms have ab: "(a,b) \<in> S" by auto
        have one: "add_mset a nas = nas2 + (add_mset a sas2)" using * by auto
        have two: "add_mset b nbs = nbs2 + (add_mset b sbs2)" using * by auto
        show ?thesis
          by (intro exI conjI, rule one, rule two, insert ab *, auto)
      next
        assume ab: "(a,b) \<in> NS"
        have one: "add_mset a nas = (add_mset a nas2) + sas2" using * by auto
        have two: "add_mset b nbs = (add_mset b nbs2) + sbs2" using * by auto
        show ?thesis
          by (intro exI conjI, rule one, rule two, insert ab *, auto intro: multpw.add)
      qed
    qed auto
    then obtain nas2 sas2 nbs2 sbs2 where *: "nas = nas2 + sas2 \<and> nbs = nbs2 + sbs2 \<and> (nas2,nbs2) \<in> multpw NS
          \<and> (\<forall> b \<in># sbs2. (\<exists>a. a \<in># sas2 \<and> (a,b) \<in> S))" by auto
    have as: "as = nas2 + (sas2 + sas)" and bs: "bs = nbs2 + (sbs2 + sbs)"
      unfolding as bs using * by auto
    show "(as, bs) \<in> ns_mul_ext NS S"
      by (intro ns_mul_extI[OF as bs], insert * s, auto)
  qed
qed

lemma ns_mul_ext_NS_union_S:  "ns_mul_ext (NS \<union> S) S = ns_mul_ext NS S"
  by (rule ns_mul_ext_some_S_in_NS, auto)

text \<open>Some further lemmas on multisets\<close>

lemma mset_map_filter: "mset (map v (filter (\<lambda>e. c e) t)) + mset (map v (filter (\<lambda>e. \<not>(c e)) t)) = mset (map v t)"
  by (induct t, auto)

lemma mset_map_split: assumes "mset (map f xs) = mset ys1 + mset ys2"
  shows "\<exists> zs1 zs2. mset xs = mset zs1 + mset zs2 \<and> ys1 = map f zs1 \<and> ys2 = map f zs2"
  using assms
proof (induct xs arbitrary: ys1 ys2)
  case (Cons x xs ys1 ys2)
  have "f x \<in># mset (map f (x # xs))" by simp
  from this[unfolded Cons(2)]
  have "f x \<in> set ys1 \<union> set ys2" by auto
  thus ?case
  proof
    let ?ys1 = ys1 let ?ys2 = ys2
    assume "f x \<in> set ?ys1"
    from split_list[OF this] obtain us1 us2 where ys1: "?ys1 = us1 @ f x # us2" by auto
    let ?us = "us1 @ us2"
    from Cons(2)[unfolded ys1] have "mset (map f xs) = mset ?us + mset ?ys2" by auto
    from Cons(1)[OF this] obtain zs1 zs2 where xs: "mset xs = mset zs1 + mset zs2"
      and us: "?us = map f zs1" and ys: "?ys2 = map f zs2"
      by auto
    let ?zs1 = "take (length us1) zs1" let ?zs2 = "drop (length us1) zs1"
    show ?thesis
      apply (rule exI[of _ "?zs1 @ x # ?zs2"], rule exI[of _ zs2])
      apply (unfold ys1, unfold ys, intro conjI refl)
    proof -
      have "mset (x # xs) = {# x #} + mset xs" by simp
      also have "\<dots> = mset (x # zs1) + mset zs2" using xs by simp
      also have "zs1 = ?zs1 @ ?zs2" by simp
      also have "mset (x # \<dots>) = mset (?zs1 @ x # ?zs2)" by (simp add: union_code)
      finally show "mset (x # xs) = mset (?zs1 @ x # ?zs2) + mset zs2" .
      show "us1 @ f x # us2 = map f (?zs1 @ x # ?zs2)" using us
        by (smt (verit, best) \<open>zs1 = take (length us1) zs1 @ drop (length us1) zs1\<close> add_diff_cancel_left' append_eq_append_conv length_append length_drop length_map list.simps(9) map_eq_append_conv)
    qed
  next
    let ?ys1 = ys2 let ?ys2 = ys1
    assume "f x \<in> set ?ys1"
    from split_list[OF this] obtain us1 us2 where ys1: "?ys1 = us1 @ f x # us2" by auto
    let ?us = "us1 @ us2"
    from Cons(2)[unfolded ys1] have "mset (map f xs) = mset ?us + mset ?ys2" by auto
    from Cons(1)[OF this] obtain zs1 zs2 where xs: "mset xs = mset zs1 + mset zs2"
      and us: "?us = map f zs1" and ys: "?ys2 = map f zs2"
      by auto
    let ?zs1 = "take (length us1) zs1" let ?zs2 = "drop (length us1) zs1"
    show ?thesis
      apply (rule exI[of _ zs2], rule exI[of _ "?zs1 @ x # ?zs2"])
      apply (unfold ys1, unfold ys, intro conjI refl)
    proof -
      have "mset (x # xs) = {# x #} + mset xs" by simp
      also have "\<dots> = mset zs2 + mset (x # zs1)" using xs by simp
      also have "zs1 = ?zs1 @ ?zs2" by simp
      also have "mset (x # \<dots>) = mset (?zs1 @ x # ?zs2)" by (simp add: union_code)
      finally show "mset (x # xs) = mset zs2 + mset (?zs1 @ x # ?zs2)" .
      show "us1 @ f x # us2 = map f (?zs1 @ x # ?zs2)" using us
        by (smt (verit, best) \<open>zs1 = take (length us1) zs1 @ drop (length us1) zs1\<close> add_diff_cancel_left' append_eq_append_conv length_append length_drop length_map list.simps(9) map_eq_append_conv)
    qed
  qed
qed auto

lemma deciding_mult:
  assumes tr: "trans S" and ir: "irrefl S"
  shows "(N,M) \<in> mult S = (M \<noteq> N \<and> (\<forall> b \<in># N - M. \<exists> a \<in># M - N. (b,a) \<in> S))"
proof -
  define I where "I = M \<inter># N"
  have N: "N = (N - M) + I" unfolding I_def
    by (metis add.commute diff_intersect_left_idem multiset_inter_commute subset_mset.add_diff_inverse subset_mset.inf_le1)
  have M: "M = (M - N) + I" unfolding I_def
    by (metis add.commute diff_intersect_left_idem subset_mset.add_diff_inverse subset_mset.inf_le1)
  have "(N,M) \<in> mult S \<longleftrightarrow>
     ((N - M) + I, (M - N) + I) \<in> mult S"
    using N M by auto
  also have "\<dots> \<longleftrightarrow> (N - M, M - N) \<in> mult S"
    by (rule mult_cancel[OF tr irrefl_on_subset[OF ir, simplified]])
  also have "\<dots> \<longleftrightarrow> (M \<noteq> N \<and> (\<forall> b \<in># N - M. \<exists> a \<in># M - N. (b,a) \<in> S))"
  proof
    assume *: "(M \<noteq> N \<and> (\<forall> b \<in># N - M. \<exists> a \<in># M - N. (b,a) \<in> S))"
    have "({#} + (N - M), {#} + (M - N)) \<in> mult S"
      apply (rule one_step_implies_mult, insert *, auto)
      using M N by auto
    thus "(N - M, M - N) \<in> mult S" by auto
  next
    assume "(N - M, M - N) \<in> mult S"
    from mult_implies_one_step[OF tr this]
    obtain E J K
      where *: " M - N = E + J \<and>
     N - M = E + K"  and rel: "J \<noteq> {#} \<and> (\<forall>k\<in>#K. \<exists>j\<in>#J. (k, j) \<in> S) " by auto
    from * have "E = {#}"
      by (metis (full_types) M N add_diff_cancel_right add_implies_diff cancel_ab_semigroup_add_class.diff_right_commute diff_add_zero)
    with * have JK: "J = M - N" "K = N - M" by auto
    show "(M \<noteq> N \<and> (\<forall> b \<in># N - M. \<exists> a \<in># M - N. (b,a) \<in> S))"
      using rel unfolding JK by auto
  qed
  finally show ?thesis .
qed

lemma s_mul_ext_map: "(\<And>a b. a \<in> set as \<Longrightarrow> b \<in> set bs \<Longrightarrow> (a, b) \<in> S \<Longrightarrow> (f a, f b) \<in> S') \<Longrightarrow>
  (\<And>a b. a \<in> set as \<Longrightarrow> b \<in> set bs \<Longrightarrow> (a, b) \<in> NS \<Longrightarrow> (f a, f b) \<in> NS') \<Longrightarrow>
  (as, bs) \<in> {(as, bs). (mset as, mset bs) \<in> s_mul_ext NS S} \<Longrightarrow>
  (map f as, map f bs) \<in> {(as, bs). (mset as, mset bs) \<in> s_mul_ext NS' S'}"
  using mult2_alt_map[of _ _ "NS\<inverse>" f f "(NS')\<inverse>" "S\<inverse>" "S'\<inverse>" False] unfolding s_mul_ext_def
  by fastforce

lemma fst_mul_ext_imp_fst: assumes "fst (mul_ext f xs ys)"
  and "length xs \<le> length ys"
shows "\<exists> x y. x \<in> set xs \<and> y \<in> set ys \<and> fst (f x y)"
proof -
  from assms(1)[unfolded mul_ext_def Let_def fst_conv]
  have "(mset xs, mset ys) \<in> s_mul_ext {(x, y). snd (f x y)} {(x, y). fst (f x y)}" by auto
  from s_mul_ext_elim[OF this] obtain xs1 xs2 ys1 ys2
    where *: "mset xs = mset xs1 + mset xs2"
     "mset ys = mset ys1 + mset ys2"
     "length xs1 = length ys1"
     "xs2 \<noteq> []"
     "(\<forall>y\<in>set ys2. \<exists>x\<in>set xs2. (x, y) \<in> {(x, y). fst (f x y)})" by auto
  from *(1-3) assms(2) have "length xs2 \<le> length ys2"
    by (metis add_le_cancel_left size_mset size_union)
  with *(4) have "hd ys2 \<in> set ys2" by (cases ys2, auto)
  with *(5,1,2) show ?thesis
    by (metis Un_iff mem_Collect_eq prod.simps(2) set_mset_mset set_mset_union)
qed

lemma ns_mul_ext_point: assumes "(as,bs) \<in> ns_mul_ext NS S"
  and "b \<in># bs"
shows "\<exists> a \<in># as. (a,b) \<in> NS \<union> S"
proof -
  from ns_mul_ext_elim[OF assms(1)]
  obtain xs1 xs2 ys1 ys2
    where *: "as = mset xs1 + mset xs2"
     "bs = mset ys1 + mset ys2"
     "length xs1 = length ys1"
     "(\<forall>i<length ys1. (xs1 ! i, ys1 ! i) \<in> NS)" "(\<forall>y\<in>set ys2. \<exists>x\<in>set xs2. (x, y) \<in> S)" by auto
  from assms(2)[unfolded *] have "b \<in> set ys1 \<or> b \<in> set ys2" by auto
  thus ?thesis
  proof
    assume "b \<in> set ys2"
    with * obtain a where "a \<in> set xs2" and "(a,b) \<in> S" by auto
    with *(1) show ?thesis by auto
  next
    assume "b \<in> set ys1"
    from this[unfolded set_conv_nth] obtain i where i: "i < length ys1" and "b = ys1 ! i" by auto
    with *(4) have "(xs1 ! i, b) \<in> NS" by auto
    moreover from i *(3) have "xs1 ! i \<in> set xs1" by auto
    ultimately show ?thesis using *(1) by auto
  qed
qed

lemma s_mul_ext_point: assumes "(as,bs) \<in> s_mul_ext NS S"
  and "b \<in># bs"
shows "\<exists> a \<in># as. (a,b) \<in> NS \<union> S"
  by (rule ns_mul_ext_point, insert assms s_ns_mul_ext, auto)

end


section\<open>Library of basic $\mathit{ZF}$ results\label{sec:zf-lib}\<close>

theory ZF_Library_Relative
  imports
    Aleph_Relative \<comment> \<open>must be before \<^theory>\<open>Transitive_Models.Cardinal_AC_Relative\<close>!\<close>
    Cardinal_AC_Relative
    FiniteFun_Relative
begin

locale M_Pi_assumption_repl = M_Pi_replacement +
  fixes A f
  assumes A_in_M: "M(A)" and
  f_repl : "lam_replacement(M,f)" and
  f_closed : "\<forall>x[M]. M(f(x))"
begin

sublocale M_Pi_assumptions M A f
    using Pi_replacement Pi_separation  A_in_M f_repl f_closed
      lam_replacement_Sigfun[THEN lam_replacement_imp_strong_replacement]
    by unfold_locales (simp_all add:transM[of _ A])

end \<comment> \<open>\<^locale>\<open>M_Pi_assumption_repl\<close>\<close>

no_notation sum (infixr \<open>+\<close> 65)
notation oadd (infixl \<open>+\<close> 65)

lemma (in M_cardinal_arith_jump) csucc_rel_cardinal_rel:
  assumes "Ord(\<kappa>)" "M(\<kappa>)"
  shows "(|\<kappa>|\<^bsup>M\<^esup>\<^sup>+)\<^bsup>M\<^esup> = (\<kappa>\<^sup>+)\<^bsup>M\<^esup>"
proof (intro le_anti_sym) \<comment> \<open>we show both inequalities\<close>
  from assms
  have hips:"M((\<kappa>\<^sup>+)\<^bsup>M\<^esup>)" "Ord((\<kappa>\<^sup>+)\<^bsup>M\<^esup>)" "\<kappa> < (\<kappa>\<^sup>+)\<^bsup>M\<^esup>"
    using Card_rel_csucc_rel[THEN Card_rel_is_Ord]
      csucc_rel_basic by simp_all
  then
  show "(|\<kappa>|\<^bsup>M\<^esup>\<^sup>+)\<^bsup>M\<^esup> \<le> (\<kappa>\<^sup>+)\<^bsup>M\<^esup>"
    using Ord_cardinal_rel_le[THEN lt_trans1]
      Card_rel_csucc_rel
    unfolding csucc_rel_def
    by (rule_tac Least_antitone) (assumption, simp_all add:assms)
  from assms
  have "\<kappa> < L" if "Card\<^bsup>M\<^esup>(L)" "|\<kappa>|\<^bsup>M\<^esup> < L" "M(L)" for L
    using that Card_rel_is_Ord leI Card_rel_le_iff[of \<kappa> L]
    by (rule_tac ccontr, auto dest:not_lt_imp_le) (fast dest: le_imp_not_lt)
  with hips
  show "(\<kappa>\<^sup>+)\<^bsup>M\<^esup> \<le> (|\<kappa>|\<^bsup>M\<^esup>\<^sup>+)\<^bsup>M\<^esup>"
    using Ord_cardinal_rel_le[THEN lt_trans1] Card_rel_csucc_rel
    unfolding csucc_rel_def
    by (rule_tac Least_antitone) (assumption, auto simp add:assms)
qed

lemma (in M_cardinal_arith_jump) csucc_rel_le_mono:
  assumes "\<kappa> \<le> \<nu>" "M(\<kappa>)" "M(\<nu>)"
  shows "(\<kappa>\<^sup>+)\<^bsup>M\<^esup> \<le> (\<nu>\<^sup>+)\<^bsup>M\<^esup>"
proof (cases "\<kappa> = \<nu>")
  case True
  with assms
  show ?thesis using Card_rel_csucc_rel [THEN Card_rel_is_Ord] by simp
next
  case False
  with assms
  have "\<kappa> < \<nu>" using le_neq_imp_lt by simp
  show ?thesis \<comment> \<open>by way of contradiction\<close>
  proof (rule ccontr)
    assume "\<not> (\<kappa>\<^sup>+)\<^bsup>M\<^esup> \<le> (\<nu>\<^sup>+)\<^bsup>M\<^esup>"
    with assms
    have "(\<nu>\<^sup>+)\<^bsup>M\<^esup> < (\<kappa>\<^sup>+)\<^bsup>M\<^esup>"
      using Card_rel_csucc_rel[THEN Card_rel_is_Ord] le_Ord2 lt_Ord
      by (intro not_le_iff_lt[THEN iffD1]) auto
    with assms
    have "(\<nu>\<^sup>+)\<^bsup>M\<^esup> \<le> |\<kappa>|\<^bsup>M\<^esup>"
      using le_Ord2[THEN Card_rel_csucc_rel, of \<kappa> \<nu>]
        Card_rel_lt_csucc_rel_iff[of "(\<nu>\<^sup>+)\<^bsup>M\<^esup>" "|\<kappa>|\<^bsup>M\<^esup>", THEN iffD1]
        csucc_rel_cardinal_rel[OF lt_Ord] leI[of "(\<nu>\<^sup>+)\<^bsup>M\<^esup>" "(\<kappa>\<^sup>+)\<^bsup>M\<^esup>"]
      by simp
    with assms
    have "(\<nu>\<^sup>+)\<^bsup>M\<^esup> \<le> \<kappa>"
      using Ord_cardinal_rel_le[OF lt_Ord] le_trans by auto
    with assms
    have "\<nu> < \<kappa>"
      using csucc_rel_basic le_Ord2[THEN Card_rel_csucc_rel, of \<kappa> \<nu>] Card_rel_is_Ord
        le_Ord2
      by (rule_tac j="(\<nu>\<^sup>+)\<^bsup>M\<^esup>" in lt_trans2) simp_all
    with \<open>\<kappa> < \<nu>\<close>
    show "False" using le_imp_not_lt leI by blast
  qed
qed

lemma (in M_cardinal_AC) cardinal_rel_succ_not_0:   "|A|\<^bsup>M\<^esup> = succ(n) \<Longrightarrow> M(A) \<Longrightarrow> M(n) \<Longrightarrow> A \<noteq> 0"
  by auto

(* "Finite_to_one(X,Y) \<equiv> {f:X\<rightarrow>Y. \<forall>y\<in>Y. Finite({x\<in>X . f`x = y})}" *)
reldb_add functional "Finite" "Finite" \<comment> \<open>wrongly done? Finite is absolute\<close>
relativize functional "Finite_to_one" "Finite_to_one_rel" external
(* reldb_add relational "Finite" "is_Finite" *) \<comment> \<open>don't have \<^term>\<open>is_Finite\<close> yet\<close>
(* relationalize "Finite_to_one_rel" "is_Finite_to_one" *)

notation Finite_to_one_rel (\<open>Finite'_to'_one\<^bsup>_\<^esup>'(_,_')\<close>)

abbreviation
  Finite_to_one_r_set :: "[i,i,i] \<Rightarrow> i" (\<open>Finite'_to'_one\<^bsup>_\<^esup>'(_,_')\<close>) where
  "Finite_to_one\<^bsup>M\<^esup>(X,Y) \<equiv> Finite_to_one_rel(##M,X,Y)"

locale M_ZF_library = M_aleph + M_FiniteFun
begin

lemma Finite_Collect_imp: "Finite({x\<in>X . Q(x)}) \<Longrightarrow> Finite({x\<in>X . M(x) \<and> Q(x)})"
  (is "Finite(?A) \<Longrightarrow> Finite(?B)")
  using subset_Finite[of ?B ?A] by auto

lemma Finite_to_one_relI[intro]:
  assumes "f:X\<rightarrow>\<^bsup>M\<^esup>Y" "\<And>y. y\<in>Y \<Longrightarrow> Finite({x\<in>X . f`x = y})"
    and types:"M(f)" "M(X)" "M(Y)"
  shows "f \<in> Finite_to_one\<^bsup>M\<^esup>(X,Y)"
  using assms Finite_Collect_imp unfolding Finite_to_one_rel_def
  by (simp)

lemma Finite_to_one_relI'[intro]:
  assumes "f:X\<rightarrow>\<^bsup>M\<^esup>Y" "\<And>y. y\<in>Y \<Longrightarrow> Finite({x\<in>X . M(x) \<and> f`x = y})"
    and types:"M(f)" "M(X)" "M(Y)"
  shows "f \<in> Finite_to_one\<^bsup>M\<^esup>(X,Y)"
  using assms unfolding Finite_to_one_rel_def
  by (simp)

lemma Finite_to_one_relD[dest]:
  "f \<in> Finite_to_one\<^bsup>M\<^esup>(X,Y) \<Longrightarrow>f:X\<rightarrow>\<^bsup>M\<^esup>Y"
  "f \<in> Finite_to_one\<^bsup>M\<^esup>(X,Y) \<Longrightarrow> y\<in>Y \<Longrightarrow> M(Y) \<Longrightarrow> Finite({x\<in>X . M(x) \<and> f`x = y})"
  unfolding Finite_to_one_rel_def by simp_all

lemma Diff_bij_rel:
  assumes "\<forall>A\<in>F. X \<subseteq> A"
    and types: "M(F)" "M(X)" shows "(\<lambda>A\<in>F. A-X) \<in> bij\<^bsup>M\<^esup>(F, {A-X. A\<in>F})"
proof -
  from assms
  have "A - X = C - X \<Longrightarrow> A = C" if "A\<in>F" "C\<in>F" for A C
    using that subset_Diff_Un[of X A] subset_Diff_Un[of X C]
    by simp
  moreover
  note assms
  moreover from this
  have "M({A-X . A\<in>F})"  "(\<lambda>A\<in>F. A-X) \<in> F \<rightarrow> {A-X. A\<in>F}" (is "?H \<in> _") "M(\<lambda>A\<in>F. A-X)"
    using lam_type lam_replacement_Diff[THEN [5] lam_replacement_hcomp2] lam_replacement_constant
      lam_replacement_identity transM[of _ F] lam_replacement_imp_strong_replacement RepFun_closed
      lam_replacement_imp_lam_closed
    by (simp,rule_tac lam_type,auto)
  ultimately
  show ?thesis
    using assms def_inj_rel def_surj_rel function_space_rel_char
    unfolding bij_rel_def
    by auto
qed

lemma function_space_rel_nonempty:
  assumes "b\<in>B"  and types: "M(B)" "M(A)"
  shows "(\<lambda>x\<in>A. b) : A \<rightarrow>\<^bsup>M\<^esup> B"
proof -
  note assms
  moreover from this
  have "M(\<lambda>x\<in>A. b)"
    using tag_replacement by (rule_tac lam_closed, auto dest:transM)
  ultimately
  show ?thesis
    by (simp add:mem_function_space_rel_abs)
qed

lemma mem_function_space_rel:
  assumes "f \<in> A \<rightarrow>\<^bsup>M\<^esup> y" "M(A)" "M(y)"
  shows  "f \<in> A \<rightarrow> y"
  using assms function_space_rel_char by simp

lemmas range_fun_rel_subset_codomain = range_fun_subset_codomain[OF mem_function_space_rel]

end \<comment> \<open>\<^locale>\<open>M_ZF_library\<close>\<close>

context M_Pi_assumptions
begin

lemma mem_Pi_rel: "f \<in> Pi\<^bsup>M\<^esup>(A,B) \<Longrightarrow> f \<in> Pi(A, B)"
  using trans_closed mem_Pi_rel_abs
  by force

lemmas Pi_rel_rangeD = Pi_rangeD[OF mem_Pi_rel]

lemmas rel_apply_Pair = apply_Pair[OF mem_Pi_rel]

lemmas rel_apply_rangeI = apply_rangeI[OF mem_Pi_rel]

lemmas Pi_rel_range_eq = Pi_range_eq[OF mem_Pi_rel]

lemmas Pi_rel_vimage_subset = Pi_vimage_subset[OF mem_Pi_rel]

end \<comment> \<open>\<^locale>\<open>M_Pi_assumptions\<close>\<close>

context M_ZF_library
begin

lemmas rel_apply_in_range = apply_in_codomain_Ord[OF _ _ mem_function_space_rel]

lemmas rel_range_eq_image = ZF_Library.range_eq_image[OF mem_function_space_rel]

lemmas rel_Image_sub_codomain = Image_sub_codomain[OF mem_function_space_rel]

lemma rel_inj_to_Image: "\<lbrakk>f:A\<rightarrow>\<^bsup>M\<^esup>B; f \<in> inj\<^bsup>M\<^esup>(A,B); M(A); M(B)\<rbrakk> \<Longrightarrow> f \<in> inj\<^bsup>M\<^esup>(A,f``A)"
  using inj_to_Image[OF mem_function_space_rel mem_inj_rel]
    transM[OF _ function_space_rel_closed] by simp

lemma inj_rel_imp_surj_rel:
  fixes f b
  defines [simp]: "ifx(x) \<equiv> if x\<in>range(f) then converse(f)`x else b"
  assumes "f \<in> inj\<^bsup>M\<^esup>(B,A)" "b\<in>B" and types: "M(f)" "M(B)" "M(A)"
  shows "(\<lambda>x\<in>A. ifx(x)) \<in> surj\<^bsup>M\<^esup>(A,B)"
proof -
  from types and \<open>b\<in>B\<close>
  have "M(\<lambda>x\<in>A. ifx(x))"
    using ifx_replacement by (rule_tac lam_closed) (auto dest:transM)
  with assms(2-)
  show ?thesis
    using inj_imp_surj mem_surj_abs by simp
qed

lemma function_space_rel_disjoint_Un:
  assumes "f \<in> A\<rightarrow>\<^bsup>M\<^esup>B" "g \<in> C\<rightarrow>\<^bsup>M\<^esup>D"  "A \<inter> C = 0"
    and types:"M(A)" "M(B)" "M(C)" "M(D)"
  shows "f \<union> g \<in> (A \<union> C)\<rightarrow>\<^bsup>M\<^esup> (B \<union> D)"
  using assms fun_Pi_disjoint_Un[OF mem_function_space_rel
      mem_function_space_rel, OF assms(1) _ _ assms(2)]
    function_space_rel_char by auto

lemma restrict_eq_imp_Un_into_function_space_rel:
  assumes "f \<in> A\<rightarrow>\<^bsup>M\<^esup>B" "g \<in> C\<rightarrow>\<^bsup>M\<^esup>D"  "restrict(f, A \<inter> C) = restrict(g, A \<inter> C)"
    and types:"M(A)" "M(B)" "M(C)" "M(D)"
  shows "f \<union> g \<in> (A \<union> C)\<rightarrow>\<^bsup>M\<^esup> (B \<union> D)"
  using assms restrict_eq_imp_Un_into_Pi[OF mem_function_space_rel
      mem_function_space_rel, OF assms(1) _ _ assms(2)]
    function_space_rel_char by auto

lemma lepoll_relD[dest]: "A \<lesssim>\<^bsup>M\<^esup> B \<Longrightarrow> \<exists>f[M]. f \<in> inj\<^bsup>M\<^esup>(A, B)"
  unfolding lepoll_rel_def .

\<comment> \<open>Should the assumptions be on \<^term>\<open>f\<close> or on \<^term>\<open>A\<close> and \<^term>\<open>B\<close>?
    Should BOTH be intro rules?\<close>
lemma lepoll_relI[intro]: "f \<in> inj\<^bsup>M\<^esup>(A, B) \<Longrightarrow> M(f) \<Longrightarrow> A \<lesssim>\<^bsup>M\<^esup> B"
  unfolding lepoll_rel_def by blast

lemma eqpollD[dest]: "A \<approx>\<^bsup>M\<^esup> B \<Longrightarrow> \<exists>f[M]. f \<in> bij\<^bsup>M\<^esup>(A, B)"
  unfolding eqpoll_rel_def .

\<comment> \<open>Same as @{thm [source] lepoll_relI}\<close>
lemma bij_rel_imp_eqpoll_rel[intro]: "f \<in> bij\<^bsup>M\<^esup>(A,B) \<Longrightarrow> M(f) \<Longrightarrow> A \<approx>\<^bsup>M\<^esup> B"
  unfolding eqpoll_rel_def by blast

lemma restrict_bij_rel:\<comment> \<open>Unused\<close>
  assumes "f \<in> inj\<^bsup>M\<^esup>(A,B)"  "C\<subseteq>A"
    and types:"M(A)" "M(B)" "M(C)"
  shows "restrict(f,C)\<in> bij\<^bsup>M\<^esup>(C, f``C)"
  using assms restrict_bij inj_rel_char bij_rel_char by auto

lemma range_of_subset_eqpoll_rel:
  assumes "f \<in> inj\<^bsup>M\<^esup>(X,Y)" "S \<subseteq> X"
    and types:"M(X)" "M(Y)" "M(S)"
  shows "S \<approx>\<^bsup>M\<^esup> f `` S"
  using assms restrict_bij bij_rel_char
    trans_inj_rel_closed[OF \<open>f \<in> inj\<^bsup>M\<^esup>(X,Y)\<close>]
  unfolding eqpoll_rel_def
  by (rule_tac x="restrict(f,S)" in rexI) auto

lemmas inj_rel_is_fun = inj_is_fun[OF mem_inj_rel]

lemma inj_rel_bij_rel_range: "f \<in> inj\<^bsup>M\<^esup>(A,B) \<Longrightarrow> M(A) \<Longrightarrow> M(B) \<Longrightarrow> f \<in> bij\<^bsup>M\<^esup>(A,range(f))"
  using bij_rel_char inj_rel_char inj_bij_range by force

lemma bij_rel_is_inj_rel: "f \<in> bij\<^bsup>M\<^esup>(A,B) \<Longrightarrow> M(A) \<Longrightarrow> M(B) \<Longrightarrow> f \<in> inj\<^bsup>M\<^esup>(A,B)"
  unfolding bij_rel_def by simp

lemma inj_rel_weaken_type: "[| f \<in> inj\<^bsup>M\<^esup>(A,B);  B\<subseteq>D; M(A); M(B); M(D) |] ==> f \<in> inj\<^bsup>M\<^esup>(A,D)"
  using inj_rel_char inj_rel_is_fun inj_weaken_type by auto

lemma bij_rel_converse_bij_rel [TC]: "f \<in> bij\<^bsup>M\<^esup>(A,B)  \<Longrightarrow> M(A) \<Longrightarrow> M(B) ==> converse(f): bij\<^bsup>M\<^esup>(B,A)"
  using bij_rel_char by force

lemma bij_rel_is_fun_rel: "f \<in> bij\<^bsup>M\<^esup>(A,B) \<Longrightarrow> M(A) \<Longrightarrow> M(B) \<Longrightarrow>  f \<in> A\<rightarrow>\<^bsup>M\<^esup>B"
  using bij_rel_char mem_function_space_rel_abs bij_is_fun by simp

lemmas bij_rel_is_fun = bij_rel_is_fun_rel[THEN mem_function_space_rel]

lemma comp_bij_rel:
  "g \<in> bij\<^bsup>M\<^esup>(A,B) \<Longrightarrow> f \<in> bij\<^bsup>M\<^esup>(B,C) \<Longrightarrow> M(A) \<Longrightarrow> M(B) \<Longrightarrow> M(C) \<Longrightarrow> (f O g) \<in> bij\<^bsup>M\<^esup>(A,C)"
  using bij_rel_char comp_bij by force

lemma inj_rel_converse_fun: "f \<in> inj\<^bsup>M\<^esup>(A,B) \<Longrightarrow> M(A) \<Longrightarrow> M(B) \<Longrightarrow> converse(f) \<in> range(f)\<rightarrow>\<^bsup>M\<^esup>A"
proof -
  assume "f \<in> inj\<^bsup>M\<^esup>(A,B)" "M(A)" "M(B)"
  then
  have "M(f)" "M(converse(f))" "M(range(f))" "f\<in>inj(A,B)"
    using inj_rel_char converse_closed range_closed
    by auto
  then
  show ?thesis
    using inj_converse_inj function_space_rel_char inj_is_fun \<open>M(A)\<close> by auto
qed

lemma fg_imp_bijective_rel:
  assumes "f \<in> A \<rightarrow>\<^bsup>M\<^esup>B"  "g \<in> B\<rightarrow>\<^bsup>M\<^esup>A"  "f O g = id(B)" "g O f = id(A)" "M(A)" "M(B)"
  shows "f \<in> bij\<^bsup>M\<^esup>(A,B)"
  using assms mem_bij_abs fg_imp_bijective mem_function_space_rel_abs[THEN iffD2] function_space_rel_char
  by auto

end \<comment> \<open>\<^locale>\<open>M_ZF_library\<close>\<close>

subsection\<open>Discipline for \<^term>\<open>cexp\<close>\<close>

relativize functional "cexp" "cexp_rel" external
relationalize "cexp_rel" "is_cexp"

context M_ZF_library
begin

is_iff_rel for "cexp"
  using is_cardinal_iff is_function_space_iff unfolding cexp_rel_def is_cexp_def
  by (simp)

rel_closed for "cexp" unfolding cexp_rel_def by simp

end \<comment> \<open>\<^locale>\<open>M_ZF_library\<close>\<close>

synthesize "is_cexp" from_definition assuming "nonempty"
notation is_cexp_fm (\<open>\<cdot>_\<^bsup>\<up>_\<^esup> is _\<cdot>\<close>)
arity_theorem for "is_cexp_fm"

abbreviation
  cexp_r :: "[i,i,i\<Rightarrow>o] \<Rightarrow> i"  (\<open>_\<^bsup>\<up>_,_\<^esup>\<close>) where
  "cexp_r(x,y,M) \<equiv> cexp_rel(M,x,y)"

abbreviation
  cexp_r_set :: "[i,i,i] \<Rightarrow> i"  (\<open>_\<^bsup>\<up>_,_\<^esup>\<close>) where
  "cexp_r_set(x,y,M) \<equiv> cexp_rel(##M,x,y)"

context M_ZF_library
begin

lemma Card_rel_cexp_rel: "M(\<kappa>) \<Longrightarrow> M(\<nu>) \<Longrightarrow> Card\<^bsup>M\<^esup>(\<kappa>\<^bsup>\<up>\<nu>,M\<^esup>)"
  unfolding cexp_rel_def by simp

\<comment> \<open>Restoring congruence rule\<close>
declare conj_cong[cong]

lemma eq_csucc_rel_ord:
  "Ord(i) \<Longrightarrow> M(i) \<Longrightarrow> (i\<^sup>+)\<^bsup>M\<^esup> = (|i|\<^bsup>M\<^esup>\<^sup>+)\<^bsup>M\<^esup>"
  using Card_rel_lt_iff Least_cong unfolding csucc_rel_def by auto

lemma lesspoll_succ_rel:
  assumes "Ord(\<kappa>)" "M(\<kappa>)"
  shows "\<kappa> \<lesssim>\<^bsup>M\<^esup> (\<kappa>\<^sup>+)\<^bsup>M\<^esup>"
  using csucc_rel_basic assms lt_Card_rel_imp_lesspoll_rel
    Card_rel_csucc_rel lepoll_rel_iff_leqpoll_rel
  by auto

lemma lesspoll_rel_csucc_rel:
  assumes "Ord(\<kappa>)"
    and types:"M(\<kappa>)" "M(d)"
  shows "d \<prec>\<^bsup>M\<^esup> (\<kappa>\<^sup>+)\<^bsup>M\<^esup> \<longleftrightarrow> d \<lesssim>\<^bsup>M\<^esup> \<kappa>"
proof
  assume "d \<prec>\<^bsup>M\<^esup> (\<kappa>\<^sup>+)\<^bsup>M\<^esup>"
  moreover
  note Card_rel_csucc_rel assms Card_rel_is_Ord
  moreover from calculation
  have "Card\<^bsup>M\<^esup>((\<kappa>\<^sup>+)\<^bsup>M\<^esup>)" "M((\<kappa>\<^sup>+)\<^bsup>M\<^esup>)" "Ord((\<kappa>\<^sup>+)\<^bsup>M\<^esup>)"
    using Card_rel_is_Ord by simp_all
  moreover from calculation
  have "d \<prec>\<^bsup>M\<^esup> (|\<kappa>|\<^bsup>M\<^esup>\<^sup>+)\<^bsup>M\<^esup>" "d \<approx>\<^bsup>M\<^esup> |d|\<^bsup>M\<^esup>"
    using eq_csucc_rel_ord[OF _ \<open>M(\<kappa>)\<close>]
      lesspoll_rel_imp_eqpoll_rel eqpoll_rel_sym by simp_all
  moreover from calculation
  have "|d|\<^bsup>M\<^esup> < (|\<kappa>|\<^bsup>M\<^esup>\<^sup>+)\<^bsup>M\<^esup>"
    using lesspoll_cardinal_lt_rel by simp
  moreover from calculation
  have "|d|\<^bsup>M\<^esup> \<lesssim>\<^bsup>M\<^esup> |\<kappa>|\<^bsup>M\<^esup>"
    using Card_rel_lt_csucc_rel_iff le_imp_lepoll_rel by simp
  moreover from calculation
  have "|d|\<^bsup>M\<^esup> \<lesssim>\<^bsup>M\<^esup> \<kappa>"
    using Ord_cardinal_rel_eqpoll_rel lepoll_rel_eq_trans
    by simp
  ultimately
  show "d \<lesssim>\<^bsup>M\<^esup> \<kappa>"
    using eq_lepoll_rel_trans by simp
next
  from \<open>Ord(\<kappa>)\<close>
  have "\<kappa> < (\<kappa>\<^sup>+)\<^bsup>M\<^esup>" "Card\<^bsup>M\<^esup>((\<kappa>\<^sup>+)\<^bsup>M\<^esup>)" "M((\<kappa>\<^sup>+)\<^bsup>M\<^esup>)"
    using Card_rel_csucc_rel lt_csucc_rel_iff types eq_csucc_rel_ord[OF _ \<open>M(\<kappa>)\<close>]
    by simp_all
  then
  have "\<kappa> \<prec>\<^bsup>M\<^esup> (\<kappa>\<^sup>+)\<^bsup>M\<^esup>"
    using lt_Card_rel_imp_lesspoll_rel[OF _ \<open>\<kappa> <_\<close>] types by simp
  moreover
  assume "d \<lesssim>\<^bsup>M\<^esup> \<kappa>"
  ultimately
  have "d \<lesssim>\<^bsup>M\<^esup> (\<kappa>\<^sup>+)\<^bsup>M\<^esup>"
    using Card_rel_csucc_rel types lesspoll_succ_rel lepoll_rel_trans \<open>Ord(\<kappa>)\<close>
    by simp
  moreover
  from \<open>d \<lesssim>\<^bsup>M\<^esup> \<kappa>\<close> \<open>Ord(\<kappa>)\<close>
  have "(\<kappa>\<^sup>+)\<^bsup>M\<^esup> \<lesssim>\<^bsup>M\<^esup> \<kappa>" if "d \<approx>\<^bsup>M\<^esup> (\<kappa>\<^sup>+)\<^bsup>M\<^esup>"
    using eqpoll_rel_sym[OF that] types eq_lepoll_rel_trans[OF _ \<open>d\<lesssim>\<^bsup>M\<^esup>\<kappa>\<close>]
    by simp
  moreover from calculation \<open>\<kappa> \<prec>\<^bsup>M\<^esup> (\<kappa>\<^sup>+)\<^bsup>M\<^esup>\<close>
  have False if "d \<approx>\<^bsup>M\<^esup> (\<kappa>\<^sup>+)\<^bsup>M\<^esup>"
    using lesspoll_rel_irrefl[OF _ \<open>M((\<kappa>\<^sup>+)\<^bsup>M\<^esup>)\<close>] lesspoll_rel_trans1 types that
    by auto
  ultimately
  show "d \<prec>\<^bsup>M\<^esup> (\<kappa>\<^sup>+)\<^bsup>M\<^esup>"
    unfolding lesspoll_rel_def by auto
qed

lemma Infinite_imp_nats_lepoll:
  assumes "Infinite(X)" "n \<in> \<omega>"
  shows "n \<lesssim> X"
  using \<open>n \<in> \<omega>\<close>
proof (induct)
  case 0
  then
  show ?case using empty_lepollI by simp
next
  case (succ x)
  show ?case
  proof -
    from \<open>Infinite(X)\<close> and \<open>x \<in> \<omega>\<close>
    have "\<not> (x \<approx> X)"
      using eqpoll_sym unfolding Finite_def by auto
    with \<open>x \<lesssim> X\<close>
    obtain f where "f \<in> inj(x,X)" "f \<notin> surj(x,X)"
      unfolding bij_def eqpoll_def by auto
    moreover from this
    obtain b where "b \<in> X" "\<forall>a\<in>x. f`a \<noteq> b"
      using inj_is_fun unfolding surj_def by auto
    ultimately
    have "f \<in> inj(x,X-{b})"
      unfolding inj_def by (auto intro:Pi_type)
    then
    have "cons(\<langle>x, b\<rangle>, f) \<in> inj(succ(x), cons(b, X - {b}))"
      using inj_extend[of f x "X-{b}" x b] unfolding succ_def
      by (auto dest:mem_irrefl)
    moreover from \<open>b\<in>X\<close>
    have "cons(b, X - {b}) = X" by auto
    ultimately
    show "succ(x) \<lesssim> X" by auto
  qed
qed

lemma nepoll_imp_nepoll_rel :
  assumes "\<not> x \<approx> X" "M(x)" "M(X)"
  shows "\<not> (x \<approx>\<^bsup>M\<^esup> X)"
  using assms unfolding eqpoll_def eqpoll_rel_def by simp

lemma Infinite_imp_nats_lepoll_rel:
  assumes "Infinite(X)" "n \<in> \<omega>"
    and types: "M(X)"
  shows "n \<lesssim>\<^bsup>M\<^esup> X"
  using \<open>n \<in> \<omega>\<close>
proof (induct)
  case 0
  then
  show ?case using empty_lepoll_relI types by simp
next
  case (succ x)
  show ?case
  proof -
    from \<open>Infinite(X)\<close> and \<open>x \<in> \<omega>\<close>
    have "\<not> (x \<approx> X)" "M(x)" "M(succ(x))"
      using eqpoll_sym unfolding Finite_def by auto
    then
    have "\<not> (x \<approx>\<^bsup>M\<^esup> X)"
      using nepoll_imp_nepoll_rel types by simp
    with \<open>x \<lesssim>\<^bsup>M\<^esup> X\<close>
    obtain f where "f \<in> inj\<^bsup>M\<^esup>(x,X)" "f \<notin> surj\<^bsup>M\<^esup>(x,X)" "M(f)"
      unfolding bij_rel_def eqpoll_rel_def by auto
    with \<open>M(X)\<close> \<open>M(x)\<close>
    have "f\<notin>surj(x,X)" "f\<in>inj(x,X)"
      using surj_rel_char by simp_all
    moreover
    from this
    obtain b where "b \<in> X" "\<forall>a\<in>x. f`a \<noteq> b"
      using inj_is_fun unfolding surj_def by auto
    moreover
    from this calculation \<open>M(x)\<close>
    have "f \<in> inj(x,X-{b})" "M(<x,b>)"
      unfolding inj_def using transM[OF _ \<open>M(X)\<close>]
      by (auto intro:Pi_type)
    moreover
    from this
    have "cons(\<langle>x, b\<rangle>, f) \<in> inj(succ(x), cons(b, X - {b}))" (is "?g\<in>_")
      using inj_extend[of f x "X-{b}" x b] unfolding succ_def
      by (auto dest:mem_irrefl)
    moreover
    note \<open>M(<x,b>)\<close> \<open>M(f)\<close> \<open>b\<in>X\<close> \<open>M(X)\<close> \<open>M(succ(x))\<close>
    moreover from this
    have "M(?g)" "cons(b, X - {b}) = X" by auto
    moreover from calculation
    have "?g\<in>inj_rel(M,succ(x),X)"
      using mem_inj_abs by simp
    with \<open>M(?g)\<close>
    show "succ(x) \<lesssim>\<^bsup>M\<^esup> X" using lepoll_relI by simp
  qed
qed

lemma lepoll_rel_imp_lepoll: "A \<lesssim>\<^bsup>M\<^esup> B \<Longrightarrow> M(A) \<Longrightarrow> M(B) \<Longrightarrow> A \<lesssim> B"
  unfolding lepoll_rel_def by auto

lemma zero_lesspoll_rel: assumes "0<\<kappa>" "M(\<kappa>)" shows "0 \<prec>\<^bsup>M\<^esup> \<kappa>"
  using assms eqpoll_rel_0_iff[THEN iffD1, of \<kappa>] eqpoll_rel_sym
  unfolding lesspoll_rel_def lepoll_rel_def
  by (auto simp add:inj_def)

lemma lepoll_rel_nat_imp_Infinite: "\<omega> \<lesssim>\<^bsup>M\<^esup> X \<Longrightarrow> M(X) \<Longrightarrow> Infinite(X)"
  using  lepoll_nat_imp_Infinite lepoll_rel_imp_lepoll by simp

lemma InfCard_rel_imp_Infinite: "InfCard\<^bsup>M\<^esup>(\<kappa>) \<Longrightarrow> M(\<kappa>) \<Longrightarrow> Infinite(\<kappa>)"
  using le_imp_lepoll_rel[THEN lepoll_rel_nat_imp_Infinite, of \<kappa>]
  unfolding InfCard_rel_def by simp

lemma lt_surj_rel_empty_imp_Card_rel:
  assumes "Ord(\<kappa>)" "\<And>\<alpha>. \<alpha> < \<kappa> \<Longrightarrow> surj\<^bsup>M\<^esup>(\<alpha>,\<kappa>) = 0"
    and types:"M(\<kappa>)"
  shows "Card\<^bsup>M\<^esup>(\<kappa>)"
proof -
  {
    define min where "min\<equiv>\<mu> x. \<exists>f[M]. f \<in> bij\<^bsup>M\<^esup>(x,\<kappa>)"
    moreover
    note \<open>Ord(\<kappa>)\<close> \<open>M(\<kappa>)\<close>
    moreover
    assume "|\<kappa>|\<^bsup>M\<^esup> < \<kappa>"
    moreover from calculation
    have "\<exists>f. f \<in> bij\<^bsup>M\<^esup>(min,\<kappa>)"
      using LeastI[of "\<lambda>i. i \<approx>\<^bsup>M\<^esup> \<kappa>" \<kappa>, OF eqpoll_rel_refl]
      unfolding Card_rel_def cardinal_rel_def eqpoll_rel_def
      by (auto)
    moreover from calculation
    have "min < \<kappa>"
      using lt_trans1[of min "\<mu> i. M(i) \<and> (\<exists>f[M]. f \<in> bij\<^bsup>M\<^esup>(i, \<kappa>))" \<kappa>]
        Least_le[of "\<lambda>i. i \<approx>\<^bsup>M\<^esup> \<kappa>" "|\<kappa>|\<^bsup>M\<^esup>", OF Ord_cardinal_rel_eqpoll_rel]
      unfolding Card_rel_def cardinal_rel_def eqpoll_rel_def
      by (simp)
    moreover
    note \<open>min < \<kappa> \<Longrightarrow> surj\<^bsup>M\<^esup>(min,\<kappa>) = 0\<close>
    ultimately
    have "False"
      unfolding bij_rel_def by simp
  }
  with assms
  show ?thesis
    using Ord_cardinal_rel_le[of \<kappa>] not_lt_imp_le[of "|\<kappa>|\<^bsup>M\<^esup>" \<kappa>] le_anti_sym
    unfolding Card_rel_def by auto
qed

end \<comment> \<open>\<^locale>\<open>M_ZF_library\<close>\<close>

relativize functional "mono_map" "mono_map_rel" external
relationalize "mono_map_rel" "is_mono_map"
synthesize "is_mono_map" from_definition assuming "nonempty"

notation mono_map_rel (\<open>mono'_map\<^bsup>_\<^esup>'(_,_,_,_')\<close>)

abbreviation
  mono_map_r_set  :: "[i,i,i,i,i]\<Rightarrow>i"  (\<open>mono'_map\<^bsup>_\<^esup>'(_,_,_,_')\<close>) where
  "mono_map\<^bsup>M\<^esup>(a,r,b,s) \<equiv> mono_map_rel(##M,a,r,b,s)"

context M_ZF_library
begin

lemma mono_map_rel_char:
  assumes "M(a)" "M(b)"
  shows "mono_map\<^bsup>M\<^esup>(a,r,b,s) = {f\<in>mono_map(a,r,b,s) . M(f)}"
  using assms function_space_rel_char unfolding mono_map_rel_def mono_map_def
  by auto

text\<open>Just a sample of porting results on \<^term>\<open>mono_map\<close>\<close>
lemma mono_map_rel_mono:
  assumes
    "f \<in> mono_map\<^bsup>M\<^esup>(A,r,B,s)" "B \<subseteq> C"
    and types:"M(A)" "M(B)" "M(C)"
  shows
    "f \<in> mono_map\<^bsup>M\<^esup>(A,r,C,s)"
  using assms mono_map_mono mono_map_rel_char by auto

lemma nats_le_InfCard_rel:
  assumes "n \<in> \<omega>" "InfCard\<^bsup>M\<^esup>(\<kappa>)"
  shows "n \<le> \<kappa>"
  using assms Ord_is_Transset
    le_trans[of n \<omega> \<kappa>, OF le_subset_iff[THEN iffD2]]
  unfolding InfCard_rel_def Transset_def by simp

lemma nat_into_InfCard_rel:
  assumes "n \<in> \<omega>" "InfCard\<^bsup>M\<^esup>(\<kappa>)"
  shows "n \<in> \<kappa>"
  using assms  le_imp_subset[of \<omega> \<kappa>]
  unfolding InfCard_rel_def by auto

lemma Finite_lesspoll_rel_nat:
  assumes "Finite(x)" "M(x)"
  shows "x \<prec>\<^bsup>M\<^esup> nat"
proof -
  note assms
  moreover from this
  obtain n where "n \<in> \<omega>" "M(n)" "x \<approx> n"
    unfolding Finite_def by auto
  moreover from calculation
  obtain f where "f \<in> bij(x,n)" "f: x-||>n"
    using Finite_Fin[THEN fun_FiniteFunI, OF _ subset_refl] bij_is_fun
    unfolding eqpoll_def by auto
  ultimately
  have "x\<approx>\<^bsup>M\<^esup> n" unfolding eqpoll_rel_def by (auto dest:transM)
  with assms and \<open>M(n)\<close>
  have "n \<approx>\<^bsup>M\<^esup> x" using eqpoll_rel_sym by simp
  moreover
  note \<open>n\<in>\<omega>\<close> \<open>M(n)\<close>
  ultimately
  show ?thesis
    using assms eq_lesspoll_rel_trans[OF \<open>x\<approx>\<^bsup>M\<^esup> n\<close> n_lesspoll_rel_nat]
    by simp
qed

lemma Finite_cardinal_rel_in_nat [simp]:
  assumes "Finite(A)" "M(A)" shows "|A|\<^bsup>M\<^esup> \<in> \<omega>"
proof -
  note assms
  moreover from this
  obtain n where "n \<in> \<omega>" "M(n)" "A \<approx> n"
    unfolding Finite_def by auto
  moreover from calculation
  obtain f where "f \<in> bij(A,n)" "f: A-||>n"
    using Finite_Fin[THEN fun_FiniteFunI, OF _ subset_refl] bij_is_fun
    unfolding eqpoll_def by auto
  ultimately
  have "A \<approx>\<^bsup>M\<^esup> n" unfolding eqpoll_rel_def by (auto dest:transM)
  with assms and \<open>M(n)\<close>
  have "n \<approx>\<^bsup>M\<^esup> A" using eqpoll_rel_sym by simp
  moreover
  note \<open>n\<in>\<omega>\<close> \<open>M(n)\<close>
  ultimately
  show ?thesis
    using assms Least_le[of "\<lambda>i. M(i) \<and> i \<approx>\<^bsup>M\<^esup> A" n]
      lt_trans1[of _ n \<omega>, THEN ltD]
    unfolding cardinal_rel_def Finite_def
    by (auto dest!:naturals_lt_nat)
qed

lemma Finite_cardinal_rel_eq_cardinal:
  assumes "Finite(A)" "M(A)" shows "|A|\<^bsup>M\<^esup> = |A|"
proof -
  \<comment> \<open>Copy-paste from @{thm [source] Finite_cardinal_rel_in_nat}\<close>
  note assms
  moreover from this
  obtain n where "n \<in> \<omega>" "M(n)" "A \<approx> n"
    unfolding Finite_def by auto
  moreover from this
  have "|A| = n"
    using cardinal_cong[of A n]
      nat_into_Card[THEN Card_cardinal_eq, of n] by simp
  moreover from calculation
  obtain f where "f \<in> bij(A,n)" "f: A-||>n"
    using Finite_Fin[THEN fun_FiniteFunI, OF _ subset_refl] bij_is_fun
    unfolding eqpoll_def by auto
  ultimately
  have "A \<approx>\<^bsup>M\<^esup> n" unfolding eqpoll_rel_def by (auto dest:transM)
  with assms and \<open>M(n)\<close> \<open>n\<in>\<omega>\<close>
  have "|A|\<^bsup>M\<^esup> = n"
    using cardinal_rel_cong[of A n]
      nat_into_Card_rel[THEN Card_rel_cardinal_rel_eq, of n]
    by simp
  with \<open>|A| = n\<close>
  show ?thesis by simp
qed

lemma Finite_imp_cardinal_rel_cons:
  assumes FA: "Finite(A)" and a: "a\<notin>A" and types:"M(A)" "M(a)"
  shows "|cons(a,A)|\<^bsup>M\<^esup> = succ(|A|\<^bsup>M\<^esup>)"
  using assms Finite_imp_cardinal_cons Finite_cardinal_rel_eq_cardinal by simp

lemma Finite_imp_succ_cardinal_rel_Diff:
  assumes "Finite(A)" "a \<in> A" "M(A)"
  shows "succ(|A-{a}|\<^bsup>M\<^esup>) = |A|\<^bsup>M\<^esup>"
proof -
  from assms
  have inM: "M(A-{a})" "M(a)" "M(A)" by (auto dest:transM)
  with \<open>Finite(A)\<close>
  have "succ(|A-{a}|\<^bsup>M\<^esup>) = succ(|A-{a}|)"
    using Diff_subset[THEN subset_Finite,
        THEN Finite_cardinal_rel_eq_cardinal, of A "{a}"] by simp
  also from assms
  have "\<dots> = |A|"
    using Finite_imp_succ_cardinal_Diff by simp
  also from assms
  have "\<dots> = |A|\<^bsup>M\<^esup>" using Finite_cardinal_rel_eq_cardinal by simp
  finally
  show ?thesis .
qed

lemma InfCard_rel_Aleph_rel:
  notes Aleph_rel_zero[simp]
  assumes "Ord(\<alpha>)"
    and types: "M(\<alpha>)"
  shows "InfCard\<^bsup>M\<^esup>(\<aleph>\<^bsub>\<alpha>\<^esub>\<^bsup>M\<^esup>)"
proof -
  have "\<not> (\<aleph>\<^bsub>\<alpha>\<^esub>\<^bsup>M\<^esup> \<in> \<omega>)"
  proof (cases "\<alpha>=0")
    case True
    then show ?thesis using mem_irrefl by auto
  next
    case False
    with assms
    have "\<omega> \<in> \<aleph>\<^bsub>\<alpha>\<^esub>\<^bsup>M\<^esup>" using Ord_0_lt[of \<alpha>] ltD by (auto dest:Aleph_rel_increasing)
    then show ?thesis using foundation by blast
  qed
  with assms
  have "\<not> (|\<aleph>\<^bsub>\<alpha>\<^esub>\<^bsup>M\<^esup>|\<^bsup>M\<^esup> \<in> \<omega>)"
    using Card_rel_cardinal_rel_eq by auto
  with assms
  have "Infinite(\<aleph>\<^bsub>\<alpha>\<^esub>\<^bsup>M\<^esup>)" using Ord_Aleph_rel by clarsimp
  with assms
  show ?thesis
    using Inf_Card_rel_is_InfCard_rel by simp
qed

lemmas Limit_Aleph_rel = InfCard_rel_Aleph_rel[THEN InfCard_rel_is_Limit]

bundle Ord_dests = Limit_is_Ord[dest] Card_rel_is_Ord[dest]
bundle Aleph_rel_dests = Aleph_rel_cont[dest]
bundle Aleph_rel_intros = Aleph_rel_increasing[intro!]
bundle Aleph_rel_mem_dests = Aleph_rel_increasing[OF ltI, THEN ltD, dest]

lemma f_imp_injective_rel:
  assumes "f \<in> A \<rightarrow>\<^bsup>M\<^esup> B" "\<forall>x\<in>A. d(f ` x) = x" "M(A)" "M(B)"
  shows "f \<in> inj\<^bsup>M\<^esup>(A, B)"
  using assms
  by (simp (no_asm_simp) add: def_inj_rel,auto intro: subst_context [THEN box_equals])

lemma lam_injective_rel:
  assumes "\<And>x. x \<in> A \<Longrightarrow> c(x) \<in> B"
    "\<And>x. x \<in> A \<Longrightarrow> d(c(x)) = x"
    "\<forall>x[M]. M(c(x))" "lam_replacement(M,c)"
    "M(A)" "M(B)"
  shows "(\<lambda>x\<in>A. c(x)) \<in> inj\<^bsup>M\<^esup>(A, B)"
  using assms function_space_rel_char lam_replacement_iff_lam_closed
  by (rule_tac d = d in f_imp_injective_rel)
    (auto simp add: lam_type)

lemma f_imp_surjective_rel:
  assumes "f \<in> A \<rightarrow>\<^bsup>M\<^esup> B" "\<And>y. y \<in> B \<Longrightarrow> d(y) \<in> A" "\<And>y. y \<in> B \<Longrightarrow> f ` d(y) = y"
    "M(A)" "M(B)"
  shows "f \<in> surj\<^bsup>M\<^esup>(A, B)"
  using assms
  by (simp add: def_surj_rel, blast)

lemma lam_surjective_rel:
  assumes "\<And>x. x \<in> A \<Longrightarrow> c(x) \<in> B"
    "\<And>y. y \<in> B \<Longrightarrow> d(y) \<in> A"
    "\<And>y. y \<in> B \<Longrightarrow> c(d(y)) = y"
    "\<forall>x[M]. M(c(x))" "lam_replacement(M,c)"
    "M(A)" "M(B)"
  shows "(\<lambda>x\<in>A. c(x)) \<in> surj\<^bsup>M\<^esup>(A, B)"
  using assms function_space_rel_char lam_replacement_iff_lam_closed
  by (rule_tac d = d in f_imp_surjective_rel)
    (auto simp add: lam_type)

lemma lam_bijective_rel:
  assumes "\<And>x. x \<in> A \<Longrightarrow> c(x) \<in> B"
    "\<And>y. y \<in> B \<Longrightarrow> d(y) \<in> A"
    "\<And>x. x \<in> A \<Longrightarrow> d(c(x)) = x"
    "\<And>y. y \<in> B \<Longrightarrow> c(d(y)) = y"
    "\<forall>x[M]. M(c(x))" "lam_replacement(M,c)"
    "M(A)" "M(B)"
  shows "(\<lambda>x\<in>A. c(x)) \<in> bij\<^bsup>M\<^esup>(A, B)"
  using assms
  unfolding bij_rel_def
  by (blast intro!: lam_injective_rel lam_surjective_rel)

lemma function_space_rel_eqpoll_rel_cong:
  assumes
    "A \<approx>\<^bsup>M\<^esup> A'" "B \<approx>\<^bsup>M\<^esup> B'" "M(A)" "M(A')" "M(B)" "M(B')"
  shows
    "A \<rightarrow>\<^bsup>M\<^esup> B \<approx>\<^bsup>M\<^esup> A' \<rightarrow>\<^bsup>M\<^esup> B'"
proof -
  from assms(1)[THEN eqpoll_rel_sym] assms(2) assms lam_type
  obtain f g where "f \<in> bij\<^bsup>M\<^esup>(A',A)" "g \<in> bij\<^bsup>M\<^esup>(B,B')"
    by blast
  with assms
  have "converse(g) : bij\<^bsup>M\<^esup>(B', B)" "converse(f): bij\<^bsup>M\<^esup>(A, A')"
    using bij_converse_bij by auto
  let ?H="\<lambda> h \<in> A \<rightarrow>\<^bsup>M\<^esup> B . g O h O f"
  let ?I="\<lambda> h \<in> A' \<rightarrow>\<^bsup>M\<^esup> B' . converse(g) O h O converse(f)"
  have go:"g O F O f : A' \<rightarrow>\<^bsup>M\<^esup> B'" if "F: A \<rightarrow>\<^bsup>M\<^esup> B" for F
  proof -
    note assms \<open>f\<in>_\<close> \<open>g\<in>_\<close> that
    moreover from this
    have "g O F O f : A' \<rightarrow> B'"
      using bij_rel_is_fun[OF \<open>g\<in>_\<close>] bij_rel_is_fun[OF \<open>f\<in>_\<close>] comp_fun
        mem_function_space_rel[OF \<open>F\<in>_\<close>]
      by blast
    ultimately
    show "g O F O f : A' \<rightarrow>\<^bsup>M\<^esup> B'"
      using comp_closed function_space_rel_char bij_rel_char
      by auto
  qed
  have og:"converse(g) O F O converse(f) : A \<rightarrow>\<^bsup>M\<^esup> B" if "F: A' \<rightarrow>\<^bsup>M\<^esup> B'" for F
  proof -
    note assms that \<open>converse(f) \<in> _\<close> \<open>converse(g) \<in> _\<close>
    moreover from this
    have "converse(g) O F O converse(f) : A \<rightarrow> B"
      using bij_rel_is_fun[OF \<open>converse(g)\<in>_\<close>] bij_rel_is_fun[OF \<open>converse(f)\<in>_\<close>] comp_fun
        mem_function_space_rel[OF \<open>F\<in>_\<close>]
      by blast
    ultimately
    show "converse(g) O F O converse(f) : A \<rightarrow>\<^bsup>M\<^esup> B" (is "?G\<in>_")
      using comp_closed function_space_rel_char bij_rel_char
      by auto
  qed
  with go
  have tc:"?H \<in> (A \<rightarrow>\<^bsup>M\<^esup> B) \<rightarrow> (A'\<rightarrow>\<^bsup>M\<^esup> B')" "?I \<in> (A' \<rightarrow>\<^bsup>M\<^esup> B') \<rightarrow> (A\<rightarrow>\<^bsup>M\<^esup> B)"
    using lam_type by auto
  with assms \<open>f\<in>_\<close> \<open>g\<in>_\<close>
  have "M(g O x O f)" and "M(converse(g) O x O converse(f))" if "M(x)" for x
    using bij_rel_char comp_closed that by auto
  with assms \<open>f\<in>_\<close> \<open>g\<in>_\<close>
  have "M(?H)" "M(?I)"
    using lam_replacement_iff_lam_closed[THEN iffD1,OF _ lam_replacement_comp']
      bij_rel_char by auto
  show ?thesis
    unfolding eqpoll_rel_def
  proof (intro rexI[of _ ?H] fg_imp_bijective_rel)
    from og go
    have "(\<And>x. x \<in> A' \<rightarrow>\<^bsup>M\<^esup> B' \<Longrightarrow> converse(g) O x O converse(f) \<in> A \<rightarrow>\<^bsup>M\<^esup> B)"
      by simp
  next
    show "M(A \<rightarrow>\<^bsup>M\<^esup> B)" using assms by simp
  next
    show "M(A' \<rightarrow>\<^bsup>M\<^esup> B')" using assms by simp
  next
    from og assms
    have "?H O ?I = (\<lambda>x\<in>A' \<rightarrow>\<^bsup>M\<^esup> B' . (g O converse(g)) O x O (converse(f) O f))"
      using lam_cong[OF refl[of "A' \<rightarrow>\<^bsup>M\<^esup> B'"]] comp_assoc comp_lam
      by auto
    also
    have "... = (\<lambda>x\<in>A' \<rightarrow>\<^bsup>M\<^esup> B' . id(B') O x O (id(A')))"
      using left_comp_inverse[OF mem_inj_rel[OF bij_rel_is_inj_rel]] \<open>f\<in>_\<close>
        right_comp_inverse[OF bij_is_surj[OF mem_bij_rel]] \<open>g\<in>_\<close> assms
      by auto
    also
    have "... = (\<lambda>x\<in>A' \<rightarrow>\<^bsup>M\<^esup> B' . x)"
      using left_comp_id[OF fun_is_rel[OF mem_function_space_rel]]
        right_comp_id[OF fun_is_rel[OF mem_function_space_rel]] assms
      by auto
    also
    have "... = id(A'\<rightarrow>\<^bsup>M\<^esup>B')" unfolding id_def by simp
    finally
    show "?H O ?I = id(A' \<rightarrow>\<^bsup>M\<^esup> B')" .
  next
    from go assms
    have "?I O ?H = (\<lambda>x\<in>A \<rightarrow>\<^bsup>M\<^esup> B . (converse(g) O g) O x O (f O converse(f)))"
      using lam_cong[OF refl[of "A \<rightarrow>\<^bsup>M\<^esup> B"]] comp_assoc comp_lam by auto
    also
    have "... = (\<lambda>x\<in>A \<rightarrow>\<^bsup>M\<^esup> B . id(B) O x O (id(A)))"
      using
        left_comp_inverse[OF mem_inj_rel[OF bij_rel_is_inj_rel[OF \<open>g\<in>_\<close>]]]
        right_comp_inverse[OF bij_is_surj[OF mem_bij_rel[OF \<open>f\<in>_\<close>]]] assms
      by auto
    also
    have "... = (\<lambda>x\<in>A \<rightarrow>\<^bsup>M\<^esup> B . x)"
      using left_comp_id[OF fun_is_rel[OF mem_function_space_rel]]
        right_comp_id[OF fun_is_rel[OF mem_function_space_rel]]
        assms
      by auto
    also
    have "... = id(A\<rightarrow>\<^bsup>M\<^esup>B)" unfolding id_def by simp
    finally
    show "?I O ?H = id(A \<rightarrow>\<^bsup>M\<^esup> B)" .
  next
    from assms tc \<open>M(?H)\<close> \<open>M(?I)\<close>
    show "?H \<in> (A\<rightarrow>\<^bsup>M\<^esup> B) \<rightarrow>\<^bsup>M\<^esup> (A'\<rightarrow>\<^bsup>M\<^esup> B')" "M(?H)"
      "?I \<in> (A'\<rightarrow>\<^bsup>M\<^esup> B') \<rightarrow>\<^bsup>M\<^esup> (A\<rightarrow>\<^bsup>M\<^esup> B)"
      using mem_function_space_rel_abs by auto
  qed
qed

lemma curry_eqpoll_rel:
  fixes \<nu>1 \<nu>2  \<kappa>
  assumes  "M(\<nu>1)" "M(\<nu>2)" "M(\<kappa>)"
  shows "\<nu>1 \<rightarrow>\<^bsup>M\<^esup> (\<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa>) \<approx>\<^bsup>M\<^esup> \<nu>1 \<times> \<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa>"
  unfolding eqpoll_rel_def
proof (intro rexI, rule lam_bijective_rel,
    rule_tac [1-2] mem_function_space_rel_abs[THEN iffD2],
    rule_tac [4] lam_type, rule_tac [8] lam_type,
    rule_tac [8] mem_function_space_rel_abs[THEN iffD2],
    rule_tac [11] lam_type, simp_all add:assms)
  let ?cur="\<lambda>x. \<lambda>w\<in>\<nu>1 \<times> \<nu>2. x ` fst(w) ` snd(w)"
  fix f z
  assume "f : \<nu>1 \<rightarrow>\<^bsup>M\<^esup> (\<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa>)"
  moreover
  note assms
  moreover from calculation
  have "M(\<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa>)"
    using function_space_rel_closed by simp
  moreover from calculation
  have "M(f)" "f : \<nu>1 \<rightarrow> (\<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa>)"
    using function_space_rel_char by (auto dest:transM)
  moreover from calculation
  have "x \<in> \<nu>1 \<Longrightarrow> f`x : \<nu>2 \<rightarrow> \<kappa>" for x
    by (auto dest:transM intro!:mem_function_space_rel_abs[THEN iffD1])
  moreover from this
  show "(\<lambda>a\<in>\<nu>1. \<lambda>b\<in>\<nu>2. ?cur(f) ` \<langle>a, b\<rangle>) = f"
    using Pi_type[OF \<open>f \<in> \<nu>1 \<rightarrow> \<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa>\<close>, of "\<lambda>_.\<nu>2 \<rightarrow> \<kappa>"] by simp
  moreover
  assume "z \<in> \<nu>1 \<times> \<nu>2"
  moreover from calculation
  have "f`fst(z): \<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa>" by simp
  ultimately
  show "f`fst(z)`snd(z) \<in> \<kappa>"
    using mem_function_space_rel_abs by (auto dest:transM)
next \<comment> \<open>one composition is the identity:\<close>
  let ?cur="\<lambda>x. \<lambda>w\<in>\<nu>1 \<times> \<nu>2. x ` fst(w) ` snd(w)"
  fix f
  assume "f : \<nu>1 \<times> \<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa>"
  with assms
  show "?cur(\<lambda>x\<in>\<nu>1. \<lambda>xa\<in>\<nu>2. f ` \<langle>x, xa\<rangle>) = f"
    using function_space_rel_char mem_function_space_rel_abs
    by (auto dest:transM intro:fun_extension)
  fix x y
  assume "x\<in>\<nu>1" "y\<in>\<nu>2"
  with assms \<open>f : \<nu>1 \<times> \<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa>\<close>
  show "f`\<langle>x,y\<rangle> \<in> \<kappa>"
    using function_space_rel_char mem_function_space_rel_abs
    by (auto dest:transM[of _ "\<nu>1 \<times> \<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa>"])
next
  let ?cur="\<lambda>x. \<lambda>w\<in>\<nu>1 \<times> \<nu>2. x ` fst(w) ` snd(w)"
  note assms
  moreover from this
  show "\<forall>x[M]. M(?cur(x))"
    using  lam_replacement_fst lam_replacement_snd
      lam_replacement_apply2[THEN [5] lam_replacement_hcomp2,
        THEN [1] lam_replacement_hcomp2, where h="(`)", OF
        lam_replacement_constant] lam_replacement_apply2
    by (auto intro: lam_replacement_iff_lam_closed[THEN iffD1, rule_format])
  moreover from calculation
  show "x \<in> \<nu>1 \<rightarrow>\<^bsup>M\<^esup> (\<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa>) \<Longrightarrow> M(?cur(x))" for x
    by (auto dest:transM)
  moreover from assms
  show "lam_replacement(M, ?cur)"
    using lam_replacement_Lambda_apply_fst_snd by simp
  ultimately
  show "M(\<lambda>x\<in>\<nu>1 \<rightarrow>\<^bsup>M\<^esup> (\<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa>). ?cur(x))"
    using lam_replacement_iff_lam_closed
    by (auto dest:transM)
  from assms
  show "y \<in> \<nu>1 \<times> \<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa> \<Longrightarrow> x \<in> \<nu>1 \<Longrightarrow> M(\<lambda>xa\<in>\<nu>2. y ` \<langle>x, xa\<rangle>)" for x y
    using lam_replacement_apply_const_id
    by (rule_tac lam_replacement_iff_lam_closed[THEN iffD1, rule_format])
      (auto dest:transM)
  from assms
  show "y \<in> \<nu>1 \<times> \<nu>2 \<rightarrow>\<^bsup>M\<^esup> \<kappa> \<Longrightarrow> M(\<lambda>x\<in>\<nu>1. \<lambda>xa\<in>\<nu>2. y ` \<langle>x, xa\<rangle>)" for y
    using lam_replacement_apply2[THEN [5] lam_replacement_hcomp2,
        OF lam_replacement_constant lam_replacement_const_id]
      lam_replacement_Lambda_apply_Pair[of \<nu>2]
    by (auto dest:transM
        intro!: lam_replacement_iff_lam_closed[THEN iffD1, rule_format])
qed

lemma Pow_rel_eqpoll_rel_function_space_rel:
  fixes d X
  notes bool_of_o_def [simp]
  defines [simp]:"d(A) \<equiv> (\<lambda>x\<in>X. bool_of_o(x\<in>A))"
    \<comment> \<open>the witnessing map for the thesis:\<close>
  assumes "M(X)"
  shows "Pow\<^bsup>M\<^esup>(X) \<approx>\<^bsup>M\<^esup> X \<rightarrow>\<^bsup>M\<^esup> 2"
proof -
  from assms
  interpret M_Pi_assumption_repl M X "\<lambda>x . 2"
    by unfold_locales (simp_all add:lam_replacement_constant)
  have "lam_replacement(M, \<lambda>x. bool_of_o(x\<in>A))" if "M(A)" for A
    using that lam_replacement_if lam_replacement_constant
      separation_in_constant by simp
  with assms
  have "lam_replacement(M, \<lambda>x. d(x))"
    using separation_in_constant[THEN [3] lam_replacement_if, of "\<lambda>_.1" "\<lambda>_.0"]
      lam_replacement_identity lam_replacement_constant lam_replacement_Lambda_if_mem
    by simp
  show ?thesis
    unfolding eqpoll_rel_def
  proof (intro rexI, rule lam_bijective_rel)
    \<comment> \<open>We give explicit mutual inverses\<close>
    fix A
    assume "A\<in>Pow\<^bsup>M\<^esup>(X)"
    moreover
    note \<open>M(X)\<close>
    moreover from calculation
    have "M(A)" by (auto dest:transM)
    moreover
    note \<open>_ \<Longrightarrow> lam_replacement(M, \<lambda>x. bool_of_o(x\<in>A))\<close>
    ultimately
    show "d(A) : X \<rightarrow>\<^bsup>M\<^esup> 2"
      using function_space_rel_char lam_replacement_iff_lam_closed[THEN iffD1]
      by (simp, rule_tac lam_type[of X "\<lambda>x. bool_of_o(x\<in>A)" "\<lambda>_. 2", simplified])
        auto
    from \<open>A\<in>Pow\<^bsup>M\<^esup>(X)\<close> \<open>M(X)\<close>
    show "{y\<in>X. d(A)`y = 1} = A"
      using Pow_rel_char by auto
  next
    fix f
    assume "f: X\<rightarrow>\<^bsup>M\<^esup> 2"
    with assms
    have "f: X\<rightarrow> 2" "M(f)" using function_space_rel_char by simp_all
    then
    show "d({y \<in> X . f ` y = 1}) = f"
      using apply_type[OF \<open>f: X\<rightarrow>2\<close>] by (force intro:fun_extension)
    from \<open>M(X)\<close> \<open>M(f)\<close>
    show "{ya \<in> X . f ` ya = 1} \<in> Pow\<^bsup>M\<^esup>(X)"
      using Pow_rel_char separation_equal_apply by auto
  next
    from assms \<open>lam_replacement(M, \<lambda>x. d(x))\<close>
      \<open>\<And>A. _ \<Longrightarrow> lam_replacement(M, \<lambda>x. bool_of_o(x\<in>A))\<close>
    show "M(\<lambda>x\<in>Pow\<^bsup>M\<^esup>(X). d(x))" "lam_replacement(M, \<lambda>x. d(x))"
      "\<forall>x[M]. M(d(x))"
      using lam_replacement_iff_lam_closed[THEN iffD1] by auto
  qed (auto simp:\<open>M(X)\<close>)
qed

lemma Pow_rel_bottom: "M(B) \<Longrightarrow> 0 \<in> Pow\<^bsup>M\<^esup>(B)"
  using Pow_rel_char by simp

lemma cantor_surj_rel:
  assumes "M(f)" "M(A)"
  shows "f \<notin> surj\<^bsup>M\<^esup>(A,Pow\<^bsup>M\<^esup>(A))"
proof
  assume "f \<in> surj\<^bsup>M\<^esup>(A,Pow\<^bsup>M\<^esup>(A))"
  with assms
  have "f \<in> surj(A,Pow\<^bsup>M\<^esup>(A))" using surj_rel_char by simp
  moreover
  note assms
  moreover from this
  have "M({x \<in> A . x \<in> f ` x})" "{x \<in> A . x \<notin> f ` x} = A - {x \<in> A . x \<in> f ` x}"
    using lam_replacement_apply[THEN [4] separation_in, of  "\<lambda>x. x"]
      lam_replacement_identity lam_replacement_constant by auto
  with \<open>M(A)\<close>
  have "{x\<in>A . x \<notin> f`x} \<in> Pow\<^bsup>M\<^esup>(A)"
    by (intro mem_Pow_rel_abs[THEN iffD2]) auto
  ultimately
  obtain d where "d\<in>A" "f`d = {x\<in>A . x \<notin> f`x}"
    unfolding surj_def by blast
  show False
  proof (cases "d \<in> f`d")
    case True
    note \<open>d \<in> f`d\<close>
    also
    note \<open>f`d = {x\<in>A . x \<notin> f`x}\<close>
    finally
    have "d \<notin> f`d" using \<open>d\<in>A\<close> by simp
    then
    show False using \<open>d \<in> f ` d\<close> by simp
  next
    case False
    with \<open>d\<in>A\<close>
    have "d \<in> {x\<in>A . x \<notin> f`x}" by simp
    also from \<open>f`d = \<dots>\<close>
    have "\<dots> = f`d" by simp
    finally
    show False using \<open>d \<notin> f`d\<close> by simp
  qed
qed

lemma cantor_inj_rel: "M(f) \<Longrightarrow> M(A) \<Longrightarrow> f \<notin> inj\<^bsup>M\<^esup>(Pow\<^bsup>M\<^esup>(A),A)"
  using inj_rel_imp_surj_rel[OF _ Pow_rel_bottom, of f A A]
    cantor_surj_rel[of "\<lambda>x\<in>A. if x \<in> range(f) then converse(f) ` x else 0" A]
    lam_replacement_if separation_in_constant[of "range(f)"]
    lam_replacement_converse_app[THEN [5] lam_replacement_hcomp2]
    lam_replacement_identity lam_replacement_constant
    lam_replacement_iff_lam_closed by auto

end \<comment> \<open>\<^locale>\<open>M_ZF_library\<close>\<close>

end