(*  Title:      HOL/BNF_Wellorder_Embedding.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Well-order embeddings as needed by bounded natural functors.
*)

section {* Well-Order Embeddings as Needed by Bounded Natural Functors *}

theory BNF_Wellorder_Embedding
imports Hilbert_Choice BNF_Wellorder_Relation
begin

text{* In this section, we introduce well-order {\em embeddings} and {\em isomorphisms} and
prove their basic properties.  The notion of embedding is considered from the point
of view of the theory of ordinals, and therefore requires the source to be injected
as an {\em initial segment} (i.e., {\em order filter}) of the target.  A main result
of this section is the existence of embeddings (in one direction or another) between
any two well-orders, having as a consequence the fact that, given any two sets on
any two types, one is smaller than (i.e., can be injected into) the other. *}

subsection {* Auxiliaries *}

lemma UNION_inj_on_ofilter:
assumes WELL: "Well_order r" and
        OF: "\<And> i. i \<in> I \<Longrightarrow> wo_rel.ofilter r (A i)" and
       INJ: "\<And> i. i \<in> I \<Longrightarrow> inj_on f (A i)"
shows "inj_on f (\<Union> i \<in> I. A i)"
proof-
  have "wo_rel r" using WELL by (simp add: wo_rel_def)
  hence "\<And> i j. \<lbrakk>i \<in> I; j \<in> I\<rbrakk> \<Longrightarrow> A i <= A j \<or> A j <= A i"
  using wo_rel.ofilter_linord[of r] OF by blast
  with WELL INJ show ?thesis
  by (auto simp add: inj_on_UNION_chain)
qed

lemma under_underS_bij_betw:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and
        IN: "a \<in> Field r" and IN': "f a \<in> Field r'" and
        BIJ: "bij_betw f (underS r a) (underS r' (f a))"
shows "bij_betw f (under r a) (under r' (f a))"
proof-
  have "a \<notin> underS r a \<and> f a \<notin> underS r' (f a)"
  unfolding underS_def by auto
  moreover
  {have "Refl r \<and> Refl r'" using WELL WELL'
   by (auto simp add: order_on_defs)
   hence "under r a = underS r a \<union> {a} \<and>
          under r' (f a) = underS r' (f a) \<union> {f a}"
   using IN IN' by(auto simp add: Refl_under_underS)
  }
  ultimately show ?thesis
  using BIJ notIn_Un_bij_betw[of a "underS r a" f "underS r' (f a)"] by auto
qed

subsection {* (Well-order) embeddings, strict embeddings, isomorphisms and order-compatible
functions *}

text{* Standardly, a function is an embedding of a well-order in another if it injectively and
order-compatibly maps the former into an order filter of the latter.
Here we opt for a more succinct definition (operator @{text "embed"}),
asking that, for any element in the source, the function should be a bijection
between the set of strict lower bounds of that element
and the set of strict lower bounds of its image.  (Later we prove equivalence with
the standard definition -- lemma @{text "embed_iff_compat_inj_on_ofilter"}.)
A {\em strict embedding} (operator @{text "embedS"})  is a non-bijective embedding
and an isomorphism (operator @{text "iso"}) is a bijective embedding. *}

definition embed :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> bool"
where
"embed r r' f \<equiv> \<forall>a \<in> Field r. bij_betw f (under r a) (under r' (f a))"

lemmas embed_defs = embed_def embed_def[abs_def]

text {* Strict embeddings: *}

definition embedS :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> bool"
where
"embedS r r' f \<equiv> embed r r' f \<and> \<not> bij_betw f (Field r) (Field r')"

lemmas embedS_defs = embedS_def embedS_def[abs_def]

definition iso :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> bool"
where
"iso r r' f \<equiv> embed r r' f \<and> bij_betw f (Field r) (Field r')"

lemmas iso_defs = iso_def iso_def[abs_def]

definition compat :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> bool"
where
"compat r r' f \<equiv> \<forall>a b. (a,b) \<in> r \<longrightarrow> (f a, f b) \<in> r'"

lemma compat_wf:
assumes CMP: "compat r r' f" and WF: "wf r'"
shows "wf r"
proof-
  have "r \<le> inv_image r' f"
  unfolding inv_image_def using CMP
  by (auto simp add: compat_def)
  with WF show ?thesis
  using wf_inv_image[of r' f] wf_subset[of "inv_image r' f"] by auto
qed

lemma id_embed: "embed r r id"
by(auto simp add: id_def embed_def bij_betw_def)

lemma id_iso: "iso r r id"
by(auto simp add: id_def embed_def iso_def bij_betw_def)

lemma embed_in_Field:
assumes WELL: "Well_order r" and
        EMB: "embed r r' f" and IN: "a \<in> Field r"
shows "f a \<in> Field r'"
proof-
  have Well: "wo_rel r"
  using WELL by (auto simp add: wo_rel_def)
  hence 1: "Refl r"
  by (auto simp add: wo_rel.REFL)
  hence "a \<in> under r a" using IN Refl_under_in by fastforce
  hence "f a \<in> under r' (f a)"
  using EMB IN by (auto simp add: embed_def bij_betw_def)
  thus ?thesis unfolding Field_def
  by (auto simp: under_def)
qed

lemma comp_embed:
assumes WELL: "Well_order r" and
        EMB: "embed r r' f" and EMB': "embed r' r'' f'"
shows "embed r r'' (f' o f)"
proof(unfold embed_def, auto)
  fix a assume *: "a \<in> Field r"
  hence "bij_betw f (under r a) (under r' (f a))"
  using embed_def[of r] EMB by auto
  moreover
  {have "f a \<in> Field r'"
   using EMB WELL * by (auto simp add: embed_in_Field)
   hence "bij_betw f' (under r' (f a)) (under r'' (f' (f a)))"
   using embed_def[of r'] EMB' by auto
  }
  ultimately
  show "bij_betw (f' \<circ> f) (under r a) (under r'' (f'(f a)))"
  by(auto simp add: bij_betw_trans)
qed

lemma comp_iso:
assumes WELL: "Well_order r" and
        EMB: "iso r r' f" and EMB': "iso r' r'' f'"
shows "iso r r'' (f' o f)"
using assms unfolding iso_def
by (auto simp add: comp_embed bij_betw_trans)

text{* That @{text "embedS"} is also preserved by function composition shall be proved only later. *}

lemma embed_Field:
"\<lbrakk>Well_order r; embed r r' f\<rbrakk> \<Longrightarrow> f`(Field r) \<le> Field r'"
by (auto simp add: embed_in_Field)

lemma embed_preserves_ofilter:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and
        EMB: "embed r r' f" and OF: "wo_rel.ofilter r A"
shows "wo_rel.ofilter r' (f`A)"
proof-
  (* Preliminary facts *)
  from WELL have Well: "wo_rel r" unfolding wo_rel_def .
  from WELL' have Well': "wo_rel r'" unfolding wo_rel_def .
  from OF have 0: "A \<le> Field r" by(auto simp add: Well wo_rel.ofilter_def)
  (* Main proof *)
  show ?thesis  using Well' WELL EMB 0 embed_Field[of r r' f]
  proof(unfold wo_rel.ofilter_def, auto simp add: image_def)
    fix a b'
    assume *: "a \<in> A" and **: "b' \<in> under r' (f a)"
    hence "a \<in> Field r" using 0 by auto
    hence "bij_betw f (under r a) (under r' (f a))"
    using * EMB by (auto simp add: embed_def)
    hence "f`(under r a) = under r' (f a)"
    by (simp add: bij_betw_def)
    with ** image_def[of f "under r a"] obtain b where
    1: "b \<in> under r a \<and> b' = f b" by blast
    hence "b \<in> A" using Well * OF
    by (auto simp add: wo_rel.ofilter_def)
    with 1 show "\<exists>b \<in> A. b' = f b" by blast
  qed
qed

lemma embed_Field_ofilter:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and
        EMB: "embed r r' f"
shows "wo_rel.ofilter r' (f`(Field r))"
proof-
  have "wo_rel.ofilter r (Field r)"
  using WELL by (auto simp add: wo_rel_def wo_rel.Field_ofilter)
  with WELL WELL' EMB
  show ?thesis by (auto simp add: embed_preserves_ofilter)
qed

lemma embed_compat:
assumes EMB: "embed r r' f"
shows "compat r r' f"
proof(unfold compat_def, clarify)
  fix a b
  assume *: "(a,b) \<in> r"
  hence 1: "b \<in> Field r" using Field_def[of r] by blast
  have "a \<in> under r b"
  using * under_def[of r] by simp
  hence "f a \<in> under r' (f b)"
  using EMB embed_def[of r r' f]
        bij_betw_def[of f "under r b" "under r' (f b)"]
        image_def[of f "under r b"] 1 by auto
  thus "(f a, f b) \<in> r'"
  by (auto simp add: under_def)
qed

lemma embed_inj_on:
assumes WELL: "Well_order r" and EMB: "embed r r' f"
shows "inj_on f (Field r)"
proof(unfold inj_on_def, clarify)
  (* Preliminary facts *)
  from WELL have Well: "wo_rel r" unfolding wo_rel_def .
  with wo_rel.TOTAL[of r]
  have Total: "Total r" by simp
  from Well wo_rel.REFL[of r]
  have Refl: "Refl r" by simp
  (* Main proof *)
  fix a b
  assume *: "a \<in> Field r" and **: "b \<in> Field r" and
         ***: "f a = f b"
  hence 1: "a \<in> Field r \<and> b \<in> Field r"
  unfolding Field_def by auto
  {assume "(a,b) \<in> r"
   hence "a \<in> under r b \<and> b \<in> under r b"
   using Refl by(auto simp add: under_def refl_on_def)
   hence "a = b"
   using EMB 1 ***
   by (auto simp add: embed_def bij_betw_def inj_on_def)
  }
  moreover
  {assume "(b,a) \<in> r"
   hence "a \<in> under r a \<and> b \<in> under r a"
   using Refl by(auto simp add: under_def refl_on_def)
   hence "a = b"
   using EMB 1 ***
   by (auto simp add: embed_def bij_betw_def inj_on_def)
  }
  ultimately
  show "a = b" using Total 1
  by (auto simp add: total_on_def)
qed

lemma embed_underS:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and
        EMB: "embed r r' f" and IN: "a \<in> Field r"
shows "bij_betw f (underS r a) (underS r' (f a))"
proof-
  have "bij_betw f (under r a) (under r' (f a))"
  using assms by (auto simp add: embed_def)
  moreover
  {have "f a \<in> Field r'" using assms  embed_Field[of r r' f] by auto
   hence "under r a = underS r a \<union> {a} \<and>
          under r' (f a) = underS r' (f a) \<union> {f a}"
   using assms by (auto simp add: order_on_defs Refl_under_underS)
  }
  moreover
  {have "a \<notin> underS r a \<and> f a \<notin> underS r' (f a)"
   unfolding underS_def by blast
  }
  ultimately show ?thesis
  by (auto simp add: notIn_Un_bij_betw3)
qed

lemma embed_iff_compat_inj_on_ofilter:
assumes WELL: "Well_order r" and WELL': "Well_order r'"
shows "embed r r' f = (compat r r' f \<and> inj_on f (Field r) \<and> wo_rel.ofilter r' (f`(Field r)))"
using assms
proof(auto simp add: embed_compat embed_inj_on embed_Field_ofilter,
      unfold embed_def, auto) (* get rid of one implication *)
  fix a
  assume *: "inj_on f (Field r)" and
         **: "compat r r' f" and
         ***: "wo_rel.ofilter r' (f`(Field r))" and
         ****: "a \<in> Field r"
  (* Preliminary facts *)
  have Well: "wo_rel r"
  using WELL wo_rel_def[of r] by simp
  hence Refl: "Refl r"
  using wo_rel.REFL[of r] by simp
  have Total: "Total r"
  using Well wo_rel.TOTAL[of r] by simp
  have Well': "wo_rel r'"
  using WELL' wo_rel_def[of r'] by simp
  hence Antisym': "antisym r'"
  using wo_rel.ANTISYM[of r'] by simp
  have "(a,a) \<in> r"
  using **** Well wo_rel.REFL[of r]
        refl_on_def[of _ r] by auto
  hence "(f a, f a) \<in> r'"
  using ** by(auto simp add: compat_def)
  hence 0: "f a \<in> Field r'"
  unfolding Field_def by auto
  have "f a \<in> f`(Field r)"
  using **** by auto
  hence 2: "under r' (f a) \<le> f`(Field r)"
  using Well' *** wo_rel.ofilter_def[of r' "f`(Field r)"] by fastforce
  (* Main proof *)
  show "bij_betw f (under r a) (under r' (f a))"
  proof(unfold bij_betw_def, auto)
    show  "inj_on f (under r a)" by (rule subset_inj_on[OF * under_Field])
  next
    fix b assume "b \<in> under r a"
    thus "f b \<in> under r' (f a)"
    unfolding under_def using **
    by (auto simp add: compat_def)
  next
    fix b' assume *****: "b' \<in> under r' (f a)"
    hence "b' \<in> f`(Field r)"
    using 2 by auto
    with Field_def[of r] obtain b where
    3: "b \<in> Field r" and 4: "b' = f b" by auto
    have "(b,a): r"
    proof-
      {assume "(a,b) \<in> r"
       with ** 4 have "(f a, b'): r'"
       by (auto simp add: compat_def)
       with ***** Antisym' have "f a = b'"
       by(auto simp add: under_def antisym_def)
       with 3 **** 4 * have "a = b"
       by(auto simp add: inj_on_def)
      }
      moreover
      {assume "a = b"
       hence "(b,a) \<in> r" using Refl **** 3
       by (auto simp add: refl_on_def)
      }
      ultimately
      show ?thesis using Total **** 3 by (fastforce simp add: total_on_def)
    qed
    with 4 show  "b' \<in> f`(under r a)"
    unfolding under_def by auto
  qed
qed

lemma inv_into_ofilter_embed:
assumes WELL: "Well_order r" and OF: "wo_rel.ofilter r A" and
        BIJ: "\<forall>b \<in> A. bij_betw f (under r b) (under r' (f b))" and
        IMAGE: "f ` A = Field r'"
shows "embed r' r (inv_into A f)"
proof-
  (* Preliminary facts *)
  have Well: "wo_rel r"
  using WELL wo_rel_def[of r] by simp
  have Refl: "Refl r"
  using Well wo_rel.REFL[of r] by simp
  have Total: "Total r"
  using Well wo_rel.TOTAL[of r] by simp
  (* Main proof *)
  have 1: "bij_betw f A (Field r')"
  proof(unfold bij_betw_def inj_on_def, auto simp add: IMAGE)
    fix b1 b2
    assume *: "b1 \<in> A" and **: "b2 \<in> A" and
           ***: "f b1 = f b2"
    have 11: "b1 \<in> Field r \<and> b2 \<in> Field r"
    using * ** Well OF by (auto simp add: wo_rel.ofilter_def)
    moreover
    {assume "(b1,b2) \<in> r"
     hence "b1 \<in> under r b2 \<and> b2 \<in> under r b2"
     unfolding under_def using 11 Refl
     by (auto simp add: refl_on_def)
     hence "b1 = b2" using BIJ * ** ***
     by (simp add: bij_betw_def inj_on_def)
    }
    moreover
     {assume "(b2,b1) \<in> r"
     hence "b1 \<in> under r b1 \<and> b2 \<in> under r b1"
     unfolding under_def using 11 Refl
     by (auto simp add: refl_on_def)
     hence "b1 = b2" using BIJ * ** ***
     by (simp add: bij_betw_def inj_on_def)
    }
    ultimately
    show "b1 = b2"
    using Total by (auto simp add: total_on_def)
  qed
  (*  *)
  let ?f' = "(inv_into A f)"
  (*  *)
  have 2: "\<forall>b \<in> A. bij_betw ?f' (under r' (f b)) (under r b)"
  proof(clarify)
    fix b assume *: "b \<in> A"
    hence "under r b \<le> A"
    using Well OF by(auto simp add: wo_rel.ofilter_def)
    moreover
    have "f ` (under r b) = under r' (f b)"
    using * BIJ by (auto simp add: bij_betw_def)
    ultimately
    show "bij_betw ?f' (under r' (f b)) (under r b)"
    using 1 by (auto simp add: bij_betw_inv_into_subset)
  qed
  (*  *)
  have 3: "\<forall>b' \<in> Field r'. bij_betw ?f' (under r' b') (under r (?f' b'))"
  proof(clarify)
    fix b' assume *: "b' \<in> Field r'"
    have "b' = f (?f' b')" using * 1
    by (auto simp add: bij_betw_inv_into_right)
    moreover
    {obtain b where 31: "b \<in> A" and "f b = b'" using IMAGE * by force
     hence "?f' b' = b" using 1 by (auto simp add: bij_betw_inv_into_left)
     with 31 have "?f' b' \<in> A" by auto
    }
    ultimately
    show  "bij_betw ?f' (under r' b') (under r (?f' b'))"
    using 2 by auto
  qed
  (*  *)
  thus ?thesis unfolding embed_def .
qed

lemma inv_into_underS_embed:
assumes WELL: "Well_order r" and
        BIJ: "\<forall>b \<in> underS r a. bij_betw f (under r b) (under r' (f b))" and
        IN: "a \<in> Field r" and
        IMAGE: "f ` (underS r a) = Field r'"
shows "embed r' r (inv_into (underS r a) f)"
using assms
by(auto simp add: wo_rel_def wo_rel.underS_ofilter inv_into_ofilter_embed)

lemma inv_into_Field_embed:
assumes WELL: "Well_order r" and EMB: "embed r r' f" and
        IMAGE: "Field r' \<le> f ` (Field r)"
shows "embed r' r (inv_into (Field r) f)"
proof-
  have "(\<forall>b \<in> Field r. bij_betw f (under r b) (under r' (f b)))"
  using EMB by (auto simp add: embed_def)
  moreover
  have "f ` (Field r) \<le> Field r'"
  using EMB WELL by (auto simp add: embed_Field)
  ultimately
  show ?thesis using assms
  by(auto simp add: wo_rel_def wo_rel.Field_ofilter inv_into_ofilter_embed)
qed

lemma inv_into_Field_embed_bij_betw:
assumes WELL: "Well_order r" and
        EMB: "embed r r' f" and BIJ: "bij_betw f (Field r) (Field r')"
shows "embed r' r (inv_into (Field r) f)"
proof-
  have "Field r' \<le> f ` (Field r)"
  using BIJ by (auto simp add: bij_betw_def)
  thus ?thesis using assms
  by(auto simp add: inv_into_Field_embed)
qed

subsection {* Given any two well-orders, one can be embedded in the other *}

text{* Here is an overview of the proof of of this fact, stated in theorem
@{text "wellorders_totally_ordered"}:

   Fix the well-orders @{text "r::'a rel"} and @{text "r'::'a' rel"}.
   Attempt to define an embedding @{text "f::'a \<Rightarrow> 'a'"} from @{text "r"} to @{text "r'"} in the
   natural way by well-order recursion ("hoping" that @{text "Field r"} turns out to be smaller
   than @{text "Field r'"}), but also record, at the recursive step, in a function
   @{text "g::'a \<Rightarrow> bool"}, the extra information of whether @{text "Field r'"}
   gets exhausted or not.

   If @{text "Field r'"} does not get exhausted, then @{text "Field r"} is indeed smaller
   and @{text "f"} is the desired embedding from @{text "r"} to @{text "r'"}
   (lemma @{text "wellorders_totally_ordered_aux"}).

   Otherwise, it means that @{text "Field r'"} is the smaller one, and the inverse of
   (the "good" segment of) @{text "f"} is the desired embedding from @{text "r'"} to @{text "r"}
   (lemma @{text "wellorders_totally_ordered_aux2"}).
*}

lemma wellorders_totally_ordered_aux:
fixes r ::"'a rel"  and r'::"'a' rel" and
      f :: "'a \<Rightarrow> 'a'" and a::'a
assumes WELL: "Well_order r" and WELL': "Well_order r'" and IN: "a \<in> Field r" and
        IH: "\<forall>b \<in> underS r a. bij_betw f (under r b) (under r' (f b))" and
        NOT: "f ` (underS r a) \<noteq> Field r'" and SUC: "f a = wo_rel.suc r' (f`(underS r a))"
shows "bij_betw f (under r a) (under r' (f a))"
proof-
  (* Preliminary facts *)
  have Well: "wo_rel r" using WELL unfolding wo_rel_def .
  hence Refl: "Refl r" using wo_rel.REFL[of r] by auto
  have Trans: "trans r" using Well wo_rel.TRANS[of r] by auto
  have Well': "wo_rel r'" using WELL' unfolding wo_rel_def .
  have OF: "wo_rel.ofilter r (underS r a)"
  by (auto simp add: Well wo_rel.underS_ofilter)
  hence UN: "underS r a = (\<Union>  b \<in> underS r a. under r b)"
  using Well wo_rel.ofilter_under_UNION[of r "underS r a"] by blast
  (* Gather facts about elements of underS r a *)
  {fix b assume *: "b \<in> underS r a"
   hence t0: "(b,a) \<in> r \<and> b \<noteq> a" unfolding underS_def by auto
   have t1: "b \<in> Field r"
   using * underS_Field[of r a] by auto
   have t2: "f`(under r b) = under r' (f b)"
   using IH * by (auto simp add: bij_betw_def)
   hence t3: "wo_rel.ofilter r' (f`(under r b))"
   using Well' by (auto simp add: wo_rel.under_ofilter)
   have "f`(under r b) \<le> Field r'"
   using t2 by (auto simp add: under_Field)
   moreover
   have "b \<in> under r b"
   using t1 by(auto simp add: Refl Refl_under_in)
   ultimately
   have t4:  "f b \<in> Field r'" by auto
   have "f`(under r b) = under r' (f b) \<and>
         wo_rel.ofilter r' (f`(under r b)) \<and>
         f b \<in> Field r'"
   using t2 t3 t4 by auto
  }
  hence bFact:
  "\<forall>b \<in> underS r a. f`(under r b) = under r' (f b) \<and>
                       wo_rel.ofilter r' (f`(under r b)) \<and>
                       f b \<in> Field r'" by blast
  (*  *)
  have subField: "f`(underS r a) \<le> Field r'"
  using bFact by blast
  (*  *)
  have OF': "wo_rel.ofilter r' (f`(underS r a))"
  proof-
    have "f`(underS r a) = f`(\<Union>  b \<in> underS r a. under r b)"
    using UN by auto
    also have "\<dots> = (\<Union>  b \<in> underS r a. f`(under r b))" by blast
    also have "\<dots> = (\<Union>  b \<in> underS r a. (under r' (f b)))"
    using bFact by auto
    finally
    have "f`(underS r a) = (\<Union>  b \<in> underS r a. (under r' (f b)))" .
    thus ?thesis
    using Well' bFact
          wo_rel.ofilter_UNION[of r' "underS r a" "\<lambda> b. under r' (f b)"] by fastforce
  qed
  (*  *)
  have "f`(underS r a) \<union> AboveS r' (f`(underS r a)) = Field r'"
  using Well' OF' by (auto simp add: wo_rel.ofilter_AboveS_Field)
  hence NE: "AboveS r' (f`(underS r a)) \<noteq> {}"
  using subField NOT by blast
  (* Main proof *)
  have INCL1: "f`(underS r a) \<le> underS r' (f a) "
  proof(auto)
    fix b assume *: "b \<in> underS r a"
    have "f b \<noteq> f a \<and> (f b, f a) \<in> r'"
    using subField Well' SUC NE *
          wo_rel.suc_greater[of r' "f`(underS r a)" "f b"] by force
    thus "f b \<in> underS r' (f a)"
    unfolding underS_def by simp
  qed
  (*  *)
  have INCL2: "underS r' (f a) \<le> f`(underS r a)"
  proof
    fix b' assume "b' \<in> underS r' (f a)"
    hence "b' \<noteq> f a \<and> (b', f a) \<in> r'"
    unfolding underS_def by simp
    thus "b' \<in> f`(underS r a)"
    using Well' SUC NE OF'
          wo_rel.suc_ofilter_in[of r' "f ` underS r a" b'] by auto
  qed
  (*  *)
  have INJ: "inj_on f (underS r a)"
  proof-
    have "\<forall>b \<in> underS r a. inj_on f (under r b)"
    using IH by (auto simp add: bij_betw_def)
    moreover
    have "\<forall>b. wo_rel.ofilter r (under r b)"
    using Well by (auto simp add: wo_rel.under_ofilter)
    ultimately show  ?thesis
    using WELL bFact UN
          UNION_inj_on_ofilter[of r "underS r a" "\<lambda>b. under r b" f]
    by auto
  qed
  (*  *)
  have BIJ: "bij_betw f (underS r a) (underS r' (f a))"
  unfolding bij_betw_def
  using INJ INCL1 INCL2 by auto
  (*  *)
  have "f a \<in> Field r'"
  using Well' subField NE SUC
  by (auto simp add: wo_rel.suc_inField)
  thus ?thesis
  using WELL WELL' IN BIJ under_underS_bij_betw[of r r' a f] by auto
qed

lemma wellorders_totally_ordered_aux2:
fixes r ::"'a rel"  and r'::"'a' rel" and
      f :: "'a \<Rightarrow> 'a'" and g :: "'a \<Rightarrow> bool"  and a::'a
assumes WELL: "Well_order r" and WELL': "Well_order r'" and
MAIN1:
  "\<And> a. (False \<notin> g`(underS r a) \<and> f`(underS r a) \<noteq> Field r'
          \<longrightarrow> f a = wo_rel.suc r' (f`(underS r a)) \<and> g a = True)
         \<and>
         (\<not>(False \<notin> (g`(underS r a)) \<and> f`(underS r a) \<noteq> Field r')
          \<longrightarrow> g a = False)" and
MAIN2: "\<And> a. a \<in> Field r \<and> False \<notin> g`(under r a) \<longrightarrow>
              bij_betw f (under r a) (under r' (f a))" and
Case: "a \<in> Field r \<and> False \<in> g`(under r a)"
shows "\<exists>f'. embed r' r f'"
proof-
  have Well: "wo_rel r" using WELL unfolding wo_rel_def .
  hence Refl: "Refl r" using wo_rel.REFL[of r] by auto
  have Trans: "trans r" using Well wo_rel.TRANS[of r] by auto
  have Antisym: "antisym r" using Well wo_rel.ANTISYM[of r] by auto
  have Well': "wo_rel r'" using WELL' unfolding wo_rel_def .
  (*  *)
  have 0: "under r a = underS r a \<union> {a}"
  using Refl Case by(auto simp add: Refl_under_underS)
  (*  *)
  have 1: "g a = False"
  proof-
    {assume "g a \<noteq> False"
     with 0 Case have "False \<in> g`(underS r a)" by blast
     with MAIN1 have "g a = False" by blast}
    thus ?thesis by blast
  qed
  let ?A = "{a \<in> Field r. g a = False}"
  let ?a = "(wo_rel.minim r ?A)"
  (*  *)
  have 2: "?A \<noteq> {} \<and> ?A \<le> Field r" using Case 1 by blast
  (*  *)
  have 3: "False \<notin> g`(underS r ?a)"
  proof
    assume "False \<in> g`(underS r ?a)"
    then obtain b where "b \<in> underS r ?a" and 31: "g b = False" by auto
    hence 32: "(b,?a) \<in> r \<and> b \<noteq> ?a"
    by (auto simp add: underS_def)
    hence "b \<in> Field r" unfolding Field_def by auto
    with 31 have "b \<in> ?A" by auto
    hence "(?a,b) \<in> r" using wo_rel.minim_least 2 Well by fastforce
    (* again: why worked without type annotations? *)
    with 32 Antisym show False
    by (auto simp add: antisym_def)
  qed
  have temp: "?a \<in> ?A"
  using Well 2 wo_rel.minim_in[of r ?A] by auto
  hence 4: "?a \<in> Field r" by auto
  (*   *)
  have 5: "g ?a = False" using temp by blast
  (*  *)
  have 6: "f`(underS r ?a) = Field r'"
  using MAIN1[of ?a] 3 5 by blast
  (*  *)
  have 7: "\<forall>b \<in> underS r ?a. bij_betw f (under r b) (under r' (f b))"
  proof
    fix b assume as: "b \<in> underS r ?a"
    moreover
    have "wo_rel.ofilter r (underS r ?a)"
    using Well by (auto simp add: wo_rel.underS_ofilter)
    ultimately
    have "False \<notin> g`(under r b)" using 3 Well by (subst (asm) wo_rel.ofilter_def) fast+
    moreover have "b \<in> Field r"
    unfolding Field_def using as by (auto simp add: underS_def)
    ultimately
    show "bij_betw f (under r b) (under r' (f b))"
    using MAIN2 by auto
  qed
  (*  *)
  have "embed r' r (inv_into (underS r ?a) f)"
  using WELL WELL' 7 4 6 inv_into_underS_embed[of r ?a f r'] by auto
  thus ?thesis
  unfolding embed_def by blast
qed

theorem wellorders_totally_ordered:
fixes r ::"'a rel"  and r'::"'a' rel"
assumes WELL: "Well_order r" and WELL': "Well_order r'"
shows "(\<exists>f. embed r r' f) \<or> (\<exists>f'. embed r' r f')"
proof-
  (* Preliminary facts *)
  have Well: "wo_rel r" using WELL unfolding wo_rel_def .
  hence Refl: "Refl r" using wo_rel.REFL[of r] by auto
  have Trans: "trans r" using Well wo_rel.TRANS[of r] by auto
  have Well': "wo_rel r'" using WELL' unfolding wo_rel_def .
  (* Main proof *)
  obtain H where H_def: "H =
  (\<lambda>h a. if False \<notin> (snd o h)`(underS r a) \<and> (fst o h)`(underS r a) \<noteq> Field r'
                then (wo_rel.suc r' ((fst o h)`(underS r a)), True)
                else (undefined, False))" by blast
  have Adm: "wo_rel.adm_wo r H"
  using Well
  proof(unfold wo_rel.adm_wo_def, clarify)
    fix h1::"'a \<Rightarrow> 'a' * bool" and h2::"'a \<Rightarrow> 'a' * bool" and x
    assume "\<forall>y\<in>underS r x. h1 y = h2 y"
    hence "\<forall>y\<in>underS r x. (fst o h1) y = (fst o h2) y \<and>
                          (snd o h1) y = (snd o h2) y" by auto
    hence "(fst o h1)`(underS r x) = (fst o h2)`(underS r x) \<and>
           (snd o h1)`(underS r x) = (snd o h2)`(underS r x)"
      by (auto simp add: image_def)
    thus "H h1 x = H h2 x" by (simp add: H_def del: not_False_in_image_Ball)
  qed
  (* More constant definitions:  *)
  obtain h::"'a \<Rightarrow> 'a' * bool" and f::"'a \<Rightarrow> 'a'" and g::"'a \<Rightarrow> bool"
  where h_def: "h = wo_rel.worec r H" and
        f_def: "f = fst o h" and g_def: "g = snd o h" by blast
  obtain test where test_def:
  "test = (\<lambda> a. False \<notin> (g`(underS r a)) \<and> f`(underS r a) \<noteq> Field r')" by blast
  (*  *)
  have *: "\<And> a. h a  = H h a"
  using Adm Well wo_rel.worec_fixpoint[of r H] by (simp add: h_def)
  have Main1:
  "\<And> a. (test a \<longrightarrow> f a = wo_rel.suc r' (f`(underS r a)) \<and> g a = True) \<and>
         (\<not>(test a) \<longrightarrow> g a = False)"
  proof-  (* How can I prove this withou fixing a? *)
    fix a show "(test a \<longrightarrow> f a = wo_rel.suc r' (f`(underS r a)) \<and> g a = True) \<and>
                (\<not>(test a) \<longrightarrow> g a = False)"
    using *[of a] test_def f_def g_def H_def by auto
  qed
  (*  *)
  let ?phi = "\<lambda> a. a \<in> Field r \<and> False \<notin> g`(under r a) \<longrightarrow>
                   bij_betw f (under r a) (under r' (f a))"
  have Main2: "\<And> a. ?phi a"
  proof-
    fix a show "?phi a"
    proof(rule wo_rel.well_order_induct[of r ?phi],
          simp only: Well, clarify)
      fix a
      assume IH: "\<forall>b. b \<noteq> a \<and> (b,a) \<in> r \<longrightarrow> ?phi b" and
             *: "a \<in> Field r" and
             **: "False \<notin> g`(under r a)"
      have 1: "\<forall>b \<in> underS r a. bij_betw f (under r b) (under r' (f b))"
      proof(clarify)
        fix b assume ***: "b \<in> underS r a"
        hence 0: "(b,a) \<in> r \<and> b \<noteq> a" unfolding underS_def by auto
        moreover have "b \<in> Field r"
        using *** underS_Field[of r a] by auto
        moreover have "False \<notin> g`(under r b)"
        using 0 ** Trans under_incr[of r b a] by auto
        ultimately show "bij_betw f (under r b) (under r' (f b))"
        using IH by auto
      qed
      (*  *)
      have 21: "False \<notin> g`(underS r a)"
      using ** underS_subset_under[of r a] by auto
      have 22: "g`(under r a) \<le> {True}" using ** by auto
      moreover have 23: "a \<in> under r a"
      using Refl * by (auto simp add: Refl_under_in)
      ultimately have 24: "g a = True" by blast
      have 2: "f`(underS r a) \<noteq> Field r'"
      proof
        assume "f`(underS r a) = Field r'"
        hence "g a = False" using Main1 test_def by blast
        with 24 show False using ** by blast
      qed
      (*  *)
      have 3: "f a = wo_rel.suc r' (f`(underS r a))"
      using 21 2 Main1 test_def by blast
      (*  *)
      show "bij_betw f (under r a) (under r' (f a))"
      using WELL  WELL' 1 2 3 *
            wellorders_totally_ordered_aux[of r r' a f] by auto
    qed
  qed
  (*  *)
  let ?chi = "(\<lambda> a. a \<in> Field r \<and> False \<in> g`(under r a))"
  show ?thesis
  proof(cases "\<exists>a. ?chi a")
    assume "\<not> (\<exists>a. ?chi a)"
    hence "\<forall>a \<in> Field r.  bij_betw f (under r a) (under r' (f a))"
    using Main2 by blast
    thus ?thesis unfolding embed_def by blast
  next
    assume "\<exists>a. ?chi a"
    then obtain a where "?chi a" by blast
    hence "\<exists>f'. embed r' r f'"
    using wellorders_totally_ordered_aux2[of r r' g f a]
          WELL WELL' Main1 Main2 test_def by fast
    thus ?thesis by blast
  qed
qed

subsection {* Uniqueness of embeddings *}

text{* Here we show a fact complementary to the one from the previous subsection -- namely,
that between any two well-orders there is {\em at most} one embedding, and is the one
definable by the expected well-order recursive equation.  As a consequence, any two
embeddings of opposite directions are mutually inverse. *}

lemma embed_determined:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and
        EMB: "embed r r' f" and IN: "a \<in> Field r"
shows "f a = wo_rel.suc r' (f`(underS r a))"
proof-
  have "bij_betw f (underS r a) (underS r' (f a))"
  using assms by (auto simp add: embed_underS)
  hence "f`(underS r a) = underS r' (f a)"
  by (auto simp add: bij_betw_def)
  moreover
  {have "f a \<in> Field r'" using IN
   using EMB WELL embed_Field[of r r' f] by auto
   hence "f a = wo_rel.suc r' (underS r' (f a))"
   using WELL' by (auto simp add: wo_rel_def wo_rel.suc_underS)
  }
  ultimately show ?thesis by simp
qed

lemma embed_unique:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and
        EMBf: "embed r r' f" and EMBg: "embed r r' g"
shows "a \<in> Field r \<longrightarrow> f a = g a"
proof(rule wo_rel.well_order_induct[of r], auto simp add: WELL wo_rel_def)
  fix a
  assume IH: "\<forall>b. b \<noteq> a \<and> (b,a): r \<longrightarrow> b \<in> Field r \<longrightarrow> f b = g b" and
         *: "a \<in> Field r"
  hence "\<forall>b \<in> underS r a. f b = g b"
  unfolding underS_def by (auto simp add: Field_def)
  hence "f`(underS r a) = g`(underS r a)" by force
  thus "f a = g a"
  using assms * embed_determined[of r r' f a] embed_determined[of r r' g a] by auto
qed

lemma embed_bothWays_inverse:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and
        EMB: "embed r r' f" and EMB': "embed r' r f'"
shows "(\<forall>a \<in> Field r. f'(f a) = a) \<and> (\<forall>a' \<in> Field r'. f(f' a') = a')"
proof-
  have "embed r r (f' o f)" using assms
  by(auto simp add: comp_embed)
  moreover have "embed r r id" using assms
  by (auto simp add: id_embed)
  ultimately have "\<forall>a \<in> Field r. f'(f a) = a"
  using assms embed_unique[of r r "f' o f" id] id_def by auto
  moreover
  {have "embed r' r' (f o f')" using assms
   by(auto simp add: comp_embed)
   moreover have "embed r' r' id" using assms
   by (auto simp add: id_embed)
   ultimately have "\<forall>a' \<in> Field r'. f(f' a') = a'"
   using assms embed_unique[of r' r' "f o f'" id] id_def by auto
  }
  ultimately show ?thesis by blast
qed

lemma embed_bothWays_bij_betw:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and
        EMB: "embed r r' f" and EMB': "embed r' r g"
shows "bij_betw f (Field r) (Field r')"
proof-
  let ?A = "Field r"  let ?A' = "Field r'"
  have "embed r r (g o f) \<and> embed r' r' (f o g)"
  using assms by (auto simp add: comp_embed)
  hence 1: "(\<forall>a \<in> ?A. g(f a) = a) \<and> (\<forall>a' \<in> ?A'. f(g a') = a')"
  using WELL id_embed[of r] embed_unique[of r r "g o f" id]
        WELL' id_embed[of r'] embed_unique[of r' r' "f o g" id]
        id_def by auto
  have 2: "(\<forall>a \<in> ?A. f a \<in> ?A') \<and> (\<forall>a' \<in> ?A'. g a' \<in> ?A)"
  using assms embed_Field[of r r' f] embed_Field[of r' r g] by blast
  (*  *)
  show ?thesis
  proof(unfold bij_betw_def inj_on_def, auto simp add: 2)
    fix a b assume *: "a \<in> ?A" "b \<in> ?A" and **: "f a = f b"
    have "a = g(f a) \<and> b = g(f b)" using * 1 by auto
    with ** show "a = b" by auto
  next
    fix a' assume *: "a' \<in> ?A'"
    hence "g a' \<in> ?A \<and> f(g a') = a'" using 1 2 by auto
    thus "a' \<in> f ` ?A" by force
  qed
qed

lemma embed_bothWays_iso:
assumes WELL: "Well_order r"  and WELL': "Well_order r'" and
        EMB: "embed r r' f" and EMB': "embed r' r g"
shows "iso r r' f"
unfolding iso_def using assms by (auto simp add: embed_bothWays_bij_betw)

subsection {* More properties of embeddings, strict embeddings and isomorphisms *}

lemma embed_bothWays_Field_bij_betw:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and
        EMB: "embed r r' f" and EMB': "embed r' r f'"
shows "bij_betw f (Field r) (Field r')"
proof-
  have "(\<forall>a \<in> Field r. f'(f a) = a) \<and> (\<forall>a' \<in> Field r'. f(f' a') = a')"
  using assms by (auto simp add: embed_bothWays_inverse)
  moreover
  have "f`(Field r) \<le> Field r' \<and> f' ` (Field r') \<le> Field r"
  using assms by (auto simp add: embed_Field)
  ultimately
  show ?thesis using bij_betw_byWitness[of "Field r" f' f "Field r'"] by auto
qed

lemma embedS_comp_embed:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
        and  EMB: "embedS r r' f" and EMB': "embed r' r'' f'"
shows "embedS r r'' (f' o f)"
proof-
  let ?g = "(f' o f)"  let ?h = "inv_into (Field r) ?g"
  have 1: "embed r r' f \<and> \<not> (bij_betw f (Field r) (Field r'))"
  using EMB by (auto simp add: embedS_def)
  hence 2: "embed r r'' ?g"
  using WELL EMB' comp_embed[of r r' f r'' f'] by auto
  moreover
  {assume "bij_betw ?g (Field r) (Field r'')"
   hence "embed r'' r ?h" using 2 WELL
   by (auto simp add: inv_into_Field_embed_bij_betw)
   hence "embed r' r (?h o f')" using WELL' EMB'
   by (auto simp add: comp_embed)
   hence "bij_betw f (Field r) (Field r')" using WELL WELL' 1
   by (auto simp add: embed_bothWays_Field_bij_betw)
   with 1 have False by blast
  }
  ultimately show ?thesis unfolding embedS_def by auto
qed

lemma embed_comp_embedS:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
        and  EMB: "embed r r' f" and EMB': "embedS r' r'' f'"
shows "embedS r r'' (f' o f)"
proof-
  let ?g = "(f' o f)"  let ?h = "inv_into (Field r) ?g"
  have 1: "embed r' r'' f' \<and> \<not> (bij_betw f' (Field r') (Field r''))"
  using EMB' by (auto simp add: embedS_def)
  hence 2: "embed r r'' ?g"
  using WELL EMB comp_embed[of r r' f r'' f'] by auto
  moreover
  {assume "bij_betw ?g (Field r) (Field r'')"
   hence "embed r'' r ?h" using 2 WELL
   by (auto simp add: inv_into_Field_embed_bij_betw)
   hence "embed r'' r' (f o ?h)" using WELL'' EMB
   by (auto simp add: comp_embed)
   hence "bij_betw f' (Field r') (Field r'')" using WELL' WELL'' 1
   by (auto simp add: embed_bothWays_Field_bij_betw)
   with 1 have False by blast
  }
  ultimately show ?thesis unfolding embedS_def by auto
qed

lemma embed_comp_iso:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
        and  EMB: "embed r r' f" and EMB': "iso r' r'' f'"
shows "embed r r'' (f' o f)"
using assms unfolding iso_def
by (auto simp add: comp_embed)

lemma iso_comp_embed:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
        and  EMB: "iso r r' f" and EMB': "embed r' r'' f'"
shows "embed r r'' (f' o f)"
using assms unfolding iso_def
by (auto simp add: comp_embed)

lemma embedS_comp_iso:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
        and  EMB: "embedS r r' f" and EMB': "iso r' r'' f'"
shows "embedS r r'' (f' o f)"
using assms unfolding iso_def
by (auto simp add: embedS_comp_embed)

lemma iso_comp_embedS:
assumes WELL: "Well_order r" and WELL': "Well_order r'" and WELL'': "Well_order r''"
        and  EMB: "iso r r' f" and EMB': "embedS r' r'' f'"
shows "embedS r r'' (f' o f)"
using assms unfolding iso_def  using embed_comp_embedS
by (auto simp add: embed_comp_embedS)

lemma embedS_Field:
assumes WELL: "Well_order r" and EMB: "embedS r r' f"
shows "f ` (Field r) < Field r'"
proof-
  have "f`(Field r) \<le> Field r'" using assms
  by (auto simp add: embed_Field embedS_def)
  moreover
  {have "inj_on f (Field r)" using assms
   by (auto simp add: embedS_def embed_inj_on)
   hence "f`(Field r) \<noteq> Field r'" using EMB
   by (auto simp add: embedS_def bij_betw_def)
  }
  ultimately show ?thesis by blast
qed

lemma embedS_iff:
assumes WELL: "Well_order r" and ISO: "embed r r' f"
shows "embedS r r' f = (f ` (Field r) < Field r')"
proof
  assume "embedS r r' f"
  thus "f ` Field r \<subset> Field r'"
  using WELL by (auto simp add: embedS_Field)
next
  assume "f ` Field r \<subset> Field r'"
  hence "\<not> bij_betw f (Field r) (Field r')"
  unfolding bij_betw_def by blast
  thus "embedS r r' f" unfolding embedS_def
  using ISO by auto
qed

lemma iso_Field:
"iso r r' f \<Longrightarrow> f ` (Field r) = Field r'"
using assms by (auto simp add: iso_def bij_betw_def)

lemma iso_iff:
assumes "Well_order r"
shows "iso r r' f = (embed r r' f \<and> f ` (Field r) = Field r')"
proof
  assume "iso r r' f"
  thus "embed r r' f \<and> f ` (Field r) = Field r'"
  by (auto simp add: iso_Field iso_def)
next
  assume *: "embed r r' f \<and> f ` Field r = Field r'"
  hence "inj_on f (Field r)" using assms by (auto simp add: embed_inj_on)
  with * have "bij_betw f (Field r) (Field r')"
  unfolding bij_betw_def by simp
  with * show "iso r r' f" unfolding iso_def by auto
qed

lemma iso_iff2:
assumes "Well_order r"
shows "iso r r' f = (bij_betw f (Field r) (Field r') \<and>
                     (\<forall>a \<in> Field r. \<forall>b \<in> Field r.
                         (((a,b) \<in> r) = ((f a, f b) \<in> r'))))"
using assms
proof(auto simp add: iso_def)
  fix a b
  assume "embed r r' f"
  hence "compat r r' f" using embed_compat[of r] by auto
  moreover assume "(a,b) \<in> r"
  ultimately show "(f a, f b) \<in> r'" using compat_def[of r] by auto
next
  let ?f' = "inv_into (Field r) f"
  assume "embed r r' f" and 1: "bij_betw f (Field r) (Field r')"
  hence "embed r' r ?f'" using assms
  by (auto simp add: inv_into_Field_embed_bij_betw)
  hence 2: "compat r' r ?f'" using embed_compat[of r'] by auto
  fix a b assume *: "a \<in> Field r" "b \<in> Field r" and **: "(f a,f b) \<in> r'"
  hence "?f'(f a) = a \<and> ?f'(f b) = b" using 1
  by (auto simp add: bij_betw_inv_into_left)
  thus "(a,b) \<in> r" using ** 2 compat_def[of r' r ?f'] by fastforce
next
  assume *: "bij_betw f (Field r) (Field r')" and
         **: "\<forall>a\<in>Field r. \<forall>b\<in>Field r. ((a, b) \<in> r) = ((f a, f b) \<in> r')"
  have 1: "\<And> a. under r a \<le> Field r \<and> under r' (f a) \<le> Field r'"
  by (auto simp add: under_Field)
  have 2: "inj_on f (Field r)" using * by (auto simp add: bij_betw_def)
  {fix a assume ***: "a \<in> Field r"
   have "bij_betw f (under r a) (under r' (f a))"
   proof(unfold bij_betw_def, auto)
     show "inj_on f (under r a)" using 1 2 subset_inj_on by blast
   next
     fix b assume "b \<in> under r a"
     hence "a \<in> Field r \<and> b \<in> Field r \<and> (b,a) \<in> r"
     unfolding under_def by (auto simp add: Field_def Range_def Domain_def)
     with 1 ** show "f b \<in> under r' (f a)"
     unfolding under_def by auto
   next
     fix b' assume "b' \<in> under r' (f a)"
     hence 3: "(b',f a) \<in> r'" unfolding under_def by simp
     hence "b' \<in> Field r'" unfolding Field_def by auto
     with * obtain b where "b \<in> Field r \<and> f b = b'"
     unfolding bij_betw_def by force
     with 3 ** ***
     show "b' \<in> f ` (under r a)" unfolding under_def by blast
   qed
  }
  thus "embed r r' f" unfolding embed_def using * by auto
qed

lemma iso_iff3:
assumes WELL: "Well_order r" and WELL': "Well_order r'"
shows "iso r r' f = (bij_betw f (Field r) (Field r') \<and> compat r r' f)"
proof
  assume "iso r r' f"
  thus "bij_betw f (Field r) (Field r') \<and> compat r r' f"
  unfolding compat_def using WELL by (auto simp add: iso_iff2 Field_def)
next
  have Well: "wo_rel r \<and> wo_rel r'" using WELL WELL'
  by (auto simp add: wo_rel_def)
  assume *: "bij_betw f (Field r) (Field r') \<and> compat r r' f"
  thus "iso r r' f"
  unfolding "compat_def" using assms
  proof(auto simp add: iso_iff2)
    fix a b assume **: "a \<in> Field r" "b \<in> Field r" and
                  ***: "(f a, f b) \<in> r'"
    {assume "(b,a) \<in> r \<or> b = a"
     hence "(b,a): r"using Well ** wo_rel.REFL[of r] refl_on_def[of _ r] by blast
     hence "(f b, f a) \<in> r'" using * unfolding compat_def by auto
     hence "f a = f b"
     using Well *** wo_rel.ANTISYM[of r'] antisym_def[of r'] by blast
     hence "a = b" using * ** unfolding bij_betw_def inj_on_def by auto
     hence "(a,b) \<in> r" using Well ** wo_rel.REFL[of r] refl_on_def[of _ r] by blast
    }
    thus "(a,b) \<in> r"
    using Well ** wo_rel.TOTAL[of r] total_on_def[of _ r] by blast
  qed
qed

end


theory Asymptotics_Recurrences
imports Asymptotics_2D
begin

section \<open>Linear recurrences in the one variable case\<close>

lemma fixes a b c :: real
  shows K: "a \<ge> 0 \<Longrightarrow> b \<ge> 1 \<Longrightarrow> c \<ge> 1 \<Longrightarrow> a \<le> a * b * c"
  by (metis mult.right_neutral mult_left_mono order_trans)

lemma bigO_linear_recurrence:
  fixes f g :: "nat \<Rightarrow> real"
  assumes "\<And>i. i\<ge>N \<Longrightarrow> f (Suc i) = f i + g i" and g: "g \<in> O(\<lambda>n. n)"
  shows "f \<in> O(\<lambda>n. n * n)"
proof -
  from g have "\<exists>c>0. \<forall>\<^sub>F x in at_top. norm (g x) \<le> c * norm (x)"
    unfolding bigo_def by auto
  then obtain cg Ng where nncg: "cg > 0" and b: "\<forall>n\<ge>Ng. norm (g n) \<le> cg * norm (n)"
    using eventually_sequentially by auto
  let ?cg = "max cg 1"
  from nncg b have nncg2: "?cg \<ge> 1" and b2: "\<forall>n\<ge>Ng. norm (g n) \<le> ?cg * norm (n)"
    apply auto
    by (meson max.cobounded1 mult_le_cancel_right of_nat_less_0_iff order_trans)

  let ?N = "max Ng (N+1)"
  let ?nfN = "max (norm (f ?N)) 1"

  show ?thesis apply(rule bigoI[where c="?nfN * ?cg"])
    apply(rule eventually_sequentiallyI[where c="?N"])
    subgoal for x
      proof (induction rule: Nat.dec_induct)
        case base
        have nn2: "norm (real ((?N) * (?N))) \<ge> 1"
          by (metis le_add2 le_square le_trans max.bounded_iff norm_of_nat real_of_nat_ge_one_iff)
        have "norm (f (max Ng (N + 1))) \<le> ?nfN" by auto
        also have "\<dots> \<le> ?nfN * ?cg * norm (real ?N * real ?N)" apply(rule K) using nn2 nncg2 by auto
        finally show ?case .
      next
        case (step n)
        from step(1) assms(1) have i: "f (Suc n) = f n + g n" by auto
        have z: "?nfN \<ge> 1" by auto
        from step(1) b2 have ii: "norm (g n) \<le> ?cg * norm (n)" by auto
        also have "\<dots> \<le> ?nfN * ?cg * norm (n)" using z
          by (metis (no_types, hide_lams) less_eq_real_def max_def mult.commute mult.left_neutral mult_left_mono nncg norm_of_nat of_nat_0_le_iff)
        finally have ii: "norm (g n) \<le> ?nfN * ?cg * norm (real n) " .
        have "norm (f (Suc n)) = norm (f n + g n)" using i by auto
        also have "\<dots> \<le> norm (f n) + norm (g n)" by simp
        also have "\<dots> \<le> (?nfN * ?cg * norm (real (n * n))) + norm (g n)" using step(3) by simp
        also have "\<dots> \<le> (?nfN * ?cg * norm (real (n * n))) + ?nfN * ?cg * norm (real n) " using ii by simp
        also have "\<dots> = ?nfN * ?cg * (norm (real (n * n)) + norm (real n))" by algebra
        also have "\<dots> \<le> ?nfN * ?cg * norm (real (Suc n * Suc n))"
          by(auto intro: mult_left_mono)
        also have "\<dots> = ?nfN * ?cg * norm (real (Suc n) * real (Suc n))"
          by (metis of_nat_mult)
        finally show ?case .
      qed
      done
  qed

lemma bigO_linear_recurrence':
  fixes f g :: "nat \<Rightarrow> real"
  assumes "\<And>i. i\<ge>N \<Longrightarrow> f (Suc i) = f i + g i" and g: "g \<in> O(G)"
    and monoG: "\<And>x y. x\<ge>N \<Longrightarrow> x\<le> y \<Longrightarrow> G x \<le> G y"
    and posG: "\<And>x. x\<ge>N \<Longrightarrow> G x > 0"
  shows "f \<in> O(\<lambda>n. n * G n)"
proof -
  from g have "\<exists>c>0. \<forall>\<^sub>F x in at_top. norm (g x) \<le> c * norm (G x)"
    unfolding bigo_def by auto
  then obtain cg Ng where nncg: "cg > 0" and b: "\<forall>n\<ge>Ng. norm (g n) \<le> cg * norm (G n)"
    using eventually_sequentially by auto
  let ?cg = "max cg 1"
  from nncg b have nncg2: "?cg \<ge> 1" and b2: "\<forall>n\<ge>Ng. norm (g n) \<le> ?cg * norm (G n)"
    apply auto
    by (metis (no_types) abs_not_less_zero b comm_monoid_mult_class.mult_1 landau_omega.R_trans max_def mult_le_cancel_right2 real_norm_def)

  define K where  "K = max (nat (ceiling (1 / G N))) N"
  have KK: "\<And>x. x\<ge>K \<Longrightarrow> norm (((x) * (G x))) \<ge> 1"
  proof -
    fix x assume "K \<le> x"
    then have x: "x \<ge> N" and xi: "x \<ge> 1 / G N" apply (auto simp: K_def) done
    have i: "norm (((x) * (G x))) = x * G x" using x posG apply auto
      by (meson abs_of_nonneg less_eq_real_def mult_nonneg_nonneg not_le of_nat_0_le_iff of_nat_less_iff)
    have p: "G (real N) > 0" using posG by auto
    have o: "G N \<le> G x" using x monoG by auto
    have "1 = (1/G N) * G N" using p by auto
    also have "\<dots> \<le> x * G N" using xi p by (auto simp: divide_le_eq)
    also have "\<dots> \<le> x * G x" using o  by (simp add:  mult_left_mono)
    finally show "norm (((x) * (G x))) \<ge> 1"
      unfolding i .
  qed

  let ?N = "max Ng (max (N+1) K)"
  define nfN  where "nfN = (max (norm (f ?N)) 1)"

  show ?thesis apply(rule bigoI[where c="nfN * ?cg"])
    apply(rule eventually_sequentiallyI[where c="?N"])
    subgoal for x
      proof (induction rule: Nat.dec_induct)
        case base
        have nn2: "norm (((?N) * (G ?N))) \<ge> 1"
          apply(rule KK) by auto
        have "norm (f ?N) \<le> nfN" by (auto simp: nfN_def)
        also have "\<dots> \<le> nfN * ?cg * norm (real ?N * G ?N)" apply(rule K)
            subgoal by (auto simp: nfN_def) apply(rule nncg2)  apply(rule nn2) done
        finally show ?case .
      next
        case (step n)
        from step(1) have nN: "n\<ge>N" by auto
        with assms(1) posG have i: "f (Suc n) = f n + g n" and ii: "G (real n) > 0" by auto
        have z: "nfN \<ge> 1" by (auto simp: nfN_def)
        from ii have zz: "norm (G (real n)) > 0"  by auto
        from step(1) b2 have ii: "norm (g n) \<le> ?cg * norm (G n)" by auto
        also have "\<dots> \<le> nfN * ?cg * norm (G n)" using z nncg zz
          by (simp add: max_def)
        finally have ii: "norm (g n) \<le> nfN * ?cg * norm (G n) " .
        have kl: "G n \<le> G (Suc n)" using monoG nN by auto
        have t: "norm (real n * G n) + norm (G n) = (n * G n) + (G n)" using   ii
          by (metis abs_of_nonneg less_eq_real_def of_nat_le_iff nN norm_mult norm_of_nat posG real_norm_def)
        also have "\<dots> \<le> (Suc n * G (Suc n))" using kl
          by (metis add.commute distrib_right mult.left_neutral mult_left_mono of_nat_0_le_iff of_nat_Suc)
        also have "\<dots> = norm (Suc n * G (Suc n))" using kl ii
          using less_eq_real_def nN posG by fastforce
        finally have pf: "norm (real n * G n) + norm (G n) \<le>norm (Suc n * G (Suc n))" .

        have "norm (f (Suc n)) = norm (f n + g n)" using i by auto
        also have "\<dots> \<le> norm (f n) + norm (g n)" by simp
        also have "\<dots> \<le> (nfN * ?cg * norm (real n * G n)) + norm (g n)" using step(3) by simp
        also have "\<dots> \<le> (nfN * ?cg * norm (real n * G n)) + nfN * ?cg * norm (G n) " using ii by simp
        also have "\<dots> = nfN * ?cg * (norm (real n * G n) + norm (G n))" by algebra
        also have "\<dots> \<le>  nfN * ?cg * norm (real (Suc n) * G (Suc n))" using pf z by (auto intro: mult_left_mono)
        finally show ?case .
      qed
      done
qed

lemma bigOmega_linear_recurrence:
  fixes f g :: "nat \<Rightarrow> real"
  assumes "\<And>i. i\<ge>N \<Longrightarrow> f (Suc i) = f i + g i"
      and g: "g \<in> \<Omega>(\<lambda>n. n)" and "\<And>n. f n \<ge> 0" "\<And>n. g n \<ge> 0"
  shows "f \<in> \<Omega>(\<lambda>n. n * n)"
proof -
  from g have "\<exists>c>0. \<forall>\<^sub>F x in at_top. norm (g x) \<ge> c * norm (x)"
    unfolding bigomega_def by auto
  then obtain cg Ng where nncg: "cg > 0" and b: "\<forall>n\<ge>Ng. norm (g n) \<ge> cg * norm (n)"
    using eventually_sequentially by auto
  let ?cg = "max (1/cg) 1"
  have nncg2: "?cg \<ge> 1" by auto
  have b2: "\<And>n. n\<ge>Ng \<Longrightarrow>  n  \<le> ?cg * norm (g n)"
  proof -
    fix n assume "n\<ge>Ng"
    then have "n \<le> norm (g n) / cg" using b nncg
      by (simp add: mult.commute pos_le_divide_eq)
    also have "\<dots> = (1/cg) * norm (g n)" by auto
    also have "\<dots> \<le> ?cg * norm (g n)" apply(rule mult_right_mono) by auto
    finally show "n \<le> max (1 / cg) 1 * norm (g n)" .
  qed

  let ?N' = "max Ng (N+1)"
  let ?N = "2*?N'"
  have n: "norm (f ?N) > 0"
  proof -
    have "?N>0" by auto then
    obtain N' where f: "?N=Suc N'" using gr0_implies_Suc by blast
    then have p: "N' \<ge> N"
      by (metis Suc_eq_plus1 Suc_le_mono max.cobounded2 nat_le_prod_with_le zero_neq_numeral)
    from f have gN: "N'>0"
      using gr0I by force
    have n: "N'\<ge>Ng" using f
      by (metis add_le_cancel_left antisym_conv le_add_same_cancel1 le_simps(3) linorder_not_le max.bounded_iff nat_mult_2 zero_order(1))
    have "0 < cg * norm (real N')" using gN nncg by auto
    also have "\<dots> \<le>  norm (g N')" using b n  by auto
    also have "\<dots> \<le> norm (f N' + g N')" using assms(3,4) by auto
    also have "\<dots> = norm (f ?N)" unfolding f using p assms(1) by auto
    finally show ?thesis .
  qed
  let ?nfN = "norm (real ?N * real ?N)/(norm (f ?N))"
  define nfN' where "nfN' = max ?nfN 4"

  show ?thesis apply(rule bigomegaI[where c="?cg * nfN'"])
    apply(rule eventually_sequentiallyI[where c="?N"])
    subgoal for x
      proof(induction rule: Nat.dec_induct)
        case base
        have "norm (real ?N * real ?N) = 1 * (?nfN * (norm (f ?N)))" using n by auto
        also have "\<dots> \<le> ?cg * (?nfN * (norm (f ?N)))" apply(rule mult_right_mono) using nncg2 by auto
        also have "\<dots> = (?cg * ?nfN) * (norm (f ?N))" by auto
        also have "\<dots> \<le> (?cg * nfN') * (norm (f ?N))" unfolding nfN'_def apply(rule mult_right_mono) apply(rule mult_left_mono) by auto
        finally show ?case by auto
      next
        case (step n)
        then have nN: "n\<ge>N"
          by (metis Suc_eq_plus1 Suc_leD le_trans max.cobounded2 nat_le_prod_with_le zero_neq_numeral)
        from step(1) have nNg: "n\<ge>Ng"
          by (metis le_trans max.cobounded1 nat_le_prod_with_le zero_neq_numeral)
        from nN assms(1) have i: "f (Suc n) = f n + g n" by auto
        from nNg b2 have b3: "n \<le> ?cg * norm (g n)" by auto
        from step(1) have "n\<ge>1"
          by (metis One_nat_def Suc_eq_plus1 gr0I le_0_eq le_simps(3) max.cobounded2 mult_is_0 nat.simps(3) numeral_eq_Suc)
        then have ii: "n+1\<le>2*n" by auto
        have 4: "4\<le>nfN'" unfolding nfN'_def by auto
        have "norm (real (Suc n) * real (Suc n)) = (n+1)*(n+1)" by (metis Suc_eq_plus1 norm_of_nat of_nat_mult)
        also have "\<dots> \<le> n*n + 2*(n + 1)"  by auto
        also have "\<dots> \<le> ?cg * nfN' * norm (f n) + 4*n" using ii step(3) by auto
        also have "\<dots> \<le> ?cg * nfN' * norm (f n) + 4*(?cg * norm (g n))" using b3 by auto
        also have "\<dots> \<le> ?cg * nfN' * norm (f n) + nfN'*(?cg * norm (g n))" using 4 apply auto apply(rule mult_right_mono) by auto
        also have "\<dots> = (?cg * nfN') * norm (f n) + (?cg * nfN') * norm (g n)" by auto
        also have "\<dots> = (?cg * nfN') * (norm (f n) + norm (g n))" by argo
        also have "\<dots> = (?cg* nfN') * (norm (f n + g n))" using assms(3,4) by auto
        also have "\<dots> = (?cg* nfN') * norm (f (Suc n))" using i by auto
        finally
        show "norm (real (Suc n) * real (Suc n)) \<le> (?cg * nfN') * norm (f (Suc n))" .
      qed
      done
qed

lemma bigOmega_linear_recurrence':
  fixes f g :: "nat \<Rightarrow> real"
  assumes "\<And>i. i\<ge>N \<Longrightarrow> f (Suc i) = f i + g i"
      and g: "g \<in> \<Omega>(G)" and "\<And>n. f n \<ge> 0" "\<And>n. g n \<ge> 0"
    and posG: "\<And>x. x\<ge>N \<Longrightarrow> G x > 0"
    and C: "\<And>n. n\<ge>N \<Longrightarrow> (n+1) * G (n+1) \<le> n * G n + C * G n"
      (* conjecture: proposition C always holds for G being polylog, or even stablebigO *)
    and Cpos: "C\<ge>0"
    shows "f \<in> \<Omega>(\<lambda>n. n * G n)"
proof -
  from g have "\<exists>c>0. \<forall>\<^sub>F x in at_top. norm (g x) \<ge> c * norm (G x)"
    unfolding bigomega_def by auto
  then obtain cg Ng where nncg: "cg > 0" and b: "\<forall>n\<ge>Ng. norm (g n) \<ge> cg * norm (G n)"
    using eventually_sequentially by auto
  let ?cg = "max (1/cg) 1"
  have nncg2: "?cg \<ge> 1" by auto
  have b2: "\<And>n. n\<ge>max Ng N \<Longrightarrow>  G n  \<le> ?cg * norm (g n)"
  proof -
    fix n assume n:"n\<ge>max Ng N"
    then have n: "n\<ge> Ng" and nl: "n\<ge> N" by auto
    from nl posG have "G n \<ge> 0"
      using less_eq_real_def of_nat_le_iff by blast
    then have "G n = norm (G n)" by auto
    also from n have "norm (G n) \<le> norm (g n) / cg" using b nncg
      by (simp add: mult.commute pos_le_divide_eq)
    also have "\<dots> = (1/cg) * norm (g n)" by auto
    also have "\<dots> \<le> ?cg * norm (g n)" apply(rule mult_right_mono) by auto
    finally show "G n \<le> max (1 / cg) 1 * norm (g n)" .
  qed

  let ?N' = "max Ng (N+1)"
  let ?N = "2*?N'"
  have n: "norm (f ?N) > 0"
  proof -
    have "?N>0" by auto then
    obtain N' where f: "?N=Suc N'" using gr0_implies_Suc by blast
    then have p: "N' \<ge> N"
      by (metis Suc_eq_plus1 Suc_le_mono max.cobounded2 nat_le_prod_with_le zero_neq_numeral)
    have gN: "G N' > 0" apply(rule posG) using p by simp
    have n: "N'\<ge>Ng" using f
      by (metis add_le_cancel_left antisym_conv le_add_same_cancel1 le_simps(3) linorder_not_le max.bounded_iff nat_mult_2 zero_order(1))
    have "0 < cg * norm (G N')" using gN nncg by auto
    also have "\<dots> \<le>  norm (g N')" using b n  by auto
    also have "\<dots> \<le> norm (f N' + g N')" using assms(3,4) by auto
    also have "\<dots> = norm (f ?N)" unfolding f using p assms(1) by auto
    finally show ?thesis .
  qed
  let ?nfN = "norm (?N * G ?N)/(norm (f ?N))"

  define nfN' where "nfN' = max ?nfN C"

  show ?thesis apply(rule bigomegaI[where c="?cg * nfN'"])
    apply(rule eventually_sequentiallyI[where c="?N"])
    subgoal for x
      proof(induction rule: Nat.dec_induct)
        case base
        have "norm (?N * G ?N) = 1 * (?nfN * (norm (f ?N)))" using n by auto
        also have "\<dots> \<le> ?cg * (?nfN * (norm (f ?N)))" apply(rule mult_right_mono) using nncg2 by auto
        also have "\<dots> = (?cg * ?nfN) * (norm (f ?N))" by auto
        also have "\<dots> \<le> (?cg * nfN') * (norm (f ?N))" unfolding nfN'_def apply(rule mult_right_mono) apply(rule mult_left_mono) by auto
        finally show ?case by auto
      next
        case (step n)
        then have nN: "n\<ge>N"
          by (metis Suc_eq_plus1 Suc_leD le_trans max.cobounded2 nat_le_prod_with_le zero_neq_numeral)
        then have rNN: "real N \<le> n" by auto
        from step(1) have nNg: "n\<ge>Ng"
          by (metis le_trans max.cobounded1 nat_le_prod_with_le zero_neq_numeral)
        from nN assms(1) have i: "f (Suc n) = f n + g n" by auto
         have b3: "G n \<le> ?cg * norm (g n)" apply(rule b2) using nN nNg by auto
        have Gm: "G (n+1) > 0" apply(rule posG)  using nN by auto
        from step(1) have "n\<ge>1"
          by (metis One_nat_def Suc_eq_plus1 gr0I le_0_eq le_simps(3) max.cobounded2 mult_is_0 nat.simps(3) numeral_eq_Suc)

        have 4: "C\<le>nfN'" unfolding nfN'_def by auto
        have "norm ((Suc n) * G (Suc n)) = (n+1)*(G (n+1))" using Gm by auto
        also have "\<dots> \<le>  n*G n + C * G n" using
            C(1)[OF rNN]
          by (metis Suc_eq_plus1 add.commute of_nat_Suc)
        also have "\<dots> \<le> ?cg * nfN' * norm (f n) + C * G n" using  step(3) by auto
        also have "\<dots> \<le> ?cg * nfN' * norm (f n) + C*(?cg * norm (g n))" using b3 Cpos apply auto apply(rule mult_left_mono) by auto
        also have "\<dots> \<le> ?cg * nfN' * norm (f n) + nfN'*(?cg * norm (g n))" using 4 apply auto apply(rule mult_right_mono) by auto
        also have "\<dots> = (?cg * nfN') * norm (f n) + (?cg * nfN') * norm (g n)" by auto
        also have "\<dots> = (?cg * nfN') * (norm (f n) + norm (g n))" by argo
        also have "\<dots> = (?cg* nfN') * (norm (f n + g n))" using assms(3,4) by auto
        also have "\<dots> = (?cg* nfN') * norm (f (Suc n))" using i by auto
        finally
        show "norm ((Suc n) * G (Suc n)) \<le> (?cg * nfN') * norm (f (Suc n))" .
      qed
      done
qed

lemma chara_ln: "(x::real)\<ge>3 \<Longrightarrow> (x + 1) * ln (x + 1) \<le> x * ln x +  3 * ln x"
proof -
 { fix x :: real
    assume e: "x\<ge>exp 1"
    then have x1: "ln x\<ge>1"
      using exp_gt_zero less_le_trans ln_ge_iff by blast
    from e have x2: "1/x \<le> ln x"
      by (metis (mono_tags) landau_o.R_linear landau_o.R_trans ln_less_self mult.left_neutral not_exp_le_zero not_less pos_le_divide_eq x1)

    have x0: "x>0"
      using e exp_gt_zero less_le_trans by blast
    then  have "x+1 = x * (1+ 1/x)"
      by (metis distrib_left divide_self_if less_numeral_extra(3) mult.commute mult.left_neutral times_divide_eq_right)
    then have"ln (x+1) = ln (x * (1+1/x))" by auto
    also have "\<dots> = ln x + ln (1+ 1/x)"
      using x0 by(auto intro: ln_mult simp add: add_pos_pos)
    also have "ln (1+ 1/x) \<le> 1/x" apply(rule ln_add_one_self_le_self)
      using x0 by auto
    finally have lnx1:  "ln (x + 1) \<le> ln x + 1 / x " by auto
    then have "x * ln (x+1) \<le> x * (ln x + 1 / x)" apply(rule mult_left_mono) using x0 by simp
    also have "\<dots> = x*ln x + 1" using x0
      by (metis distrib_left nonzero_mult_div_cancel_left not_le order_refl times_divide_eq_right)
    also have "\<dots> \<le> x*ln x + ln x" using x1 by auto
    finally have i: "x * ln (x + 1) \<le> x * ln x + ln x " .

    from lnx1 x2 have ii: "ln (x+1) \<le> ln x + ln x" by auto

    have "(x+1)*ln(x+1) = x*ln(x+1) + ln(x+1)"
      by (simp add: add.commute semiring_normalization_rules(3))
    also have "\<dots> \<le> x * ln x + ln x + ln (x+1)" using i by auto
    also have "\<dots> \<le> x * ln x + ln x + ln x + ln x" using ii by auto
    also have "\<dots> = x*ln x + 3*ln x" by auto
    finally have "(x + 1) * ln (x + 1) \<le> x * ln x +  3 * ln x" .
  } note p=this
  assume "x\<ge>3"
  then show ?thesis using exp_le by(auto intro!: p)
qed

lemma bigTheta_linear_recurrence_const:
  fixes f g :: "nat \<Rightarrow> real"
  assumes "\<And>i. i\<ge>N \<Longrightarrow> f (Suc i) = f i + g i"
      and g: "g \<in> \<Theta>(\<lambda>n. 1)" and "\<And>n. f n \<ge> 0" "\<And>n. g n \<ge> 0"
  shows "f \<in> \<Theta>(\<lambda>n. n )"
proof
  have "f \<in> O(\<lambda>n. n * 1)"
    apply (rule bigO_linear_recurrence'[where g=g and N="max N 3"])
    using assms by auto
  thus "f \<in> O(\<lambda>n. n )" by simp

  have "f \<in> \<Omega>(\<lambda>n. n * 1)"
    apply (rule bigOmega_linear_recurrence'[where g=g and N="max N 3" and C=3])
    using assms by (auto)
  thus "f \<in> \<Omega>(\<lambda>n. n)" by simp
qed

lemma bigTheta_linear_recurrence_log:
  fixes f g :: "nat \<Rightarrow> real"
  assumes "\<And>i. i\<ge>N \<Longrightarrow> f (Suc i) = f i + g i"
      and g: "g \<in> \<Theta>(ln)" and "\<And>n. f n \<ge> 0" "\<And>n. g n \<ge> 0"
  shows "f \<in> \<Theta>(\<lambda>n. n * ln n)"
proof
  show "f \<in> O(\<lambda>n. n * ln n)"
    apply (rule bigO_linear_recurrence'[where g=g and N="max N 3"])
    using assms by auto

  show "f \<in> \<Omega>(\<lambda>n. n * ln n)"
    apply (rule bigOmega_linear_recurrence'[where g=g and N="max N 3" and C=3])
    using assms by (auto intro!: chara_ln)
qed

lemma bigTheta_linear_recurrence:
  fixes f g :: "nat \<Rightarrow> real"
  assumes "\<And>i. i\<ge>N \<Longrightarrow> f (Suc i) = f i + g i"
      and g: "g \<in> \<Theta>(\<lambda>n. n)" and "\<And>n. f n \<ge> 0" "\<And>n. g n \<ge> 0"
  shows "f \<in> \<Theta>(\<lambda>n. n * n)"
proof
  show "f \<in> O(\<lambda>n. n * n)"
    apply (rule bigO_linear_recurrence)
    using assms by auto
  show "f \<in> \<Omega>(\<lambda>n. n * n)"
    apply (rule bigOmega_linear_recurrence)
    using assms by auto
qed

section \<open>Example\<close>

fun bla_time :: "nat \<Rightarrow> real" where
   "bla_time 0 = 1"
|  "bla_time (Suc n) = bla_time n + n"

lemma bla_time_nneg:
  "bla_time n \<ge> 0" by (induct n) auto

lemma "bla_time \<in> \<Theta>(\<lambda>n. real n * real n)"
  apply (rule bigTheta_linear_recurrence[where N=0 and g="(\<lambda>n. n)"])
  by (auto simp: bla_time_nneg)

section \<open>Linear recurrence in the two variable case\<close>

lemma bivariate:
  assumes "\<And>n m. n\<ge>N \<Longrightarrow>  f (Suc n,m) = f (n,m) + g m"
    and "\<And>n m. n \<le> N \<Longrightarrow> f (n,m) \<le> C"
    and g: "g \<in> O(\<lambda>m. m)"
    and fpos: "eventually_nonneg (at_top\<times>\<^sub>Fat_top) f"
    and Cpos: "C \<ge> 0"
  shows "f \<in> O\<^sub>2(\<lambda>(n,m). real (n * m))"
proof -
  { fix n m
    have "f (N+n, m) \<le> C + n * g m"
    proof (induct n)
      case 0
      then show ?case using assms(2) by simp
    next
      case (Suc n)
      have "f (N + Suc n, m) = f (N + n, m) + g m" using assms(1) by simp
      also have "\<dots> \<le> C + real n * g m + g m" using Suc by auto
      also have "\<dots> = C + (real (n+1)) * g m"
        by (metis Suc_eq_plus1 add.assoc add.commute of_nat_Suc semiring_normalization_rules(3))
      finally show ?case by simp
    qed
  } then have k: "\<And>n m. n\<ge>N \<Longrightarrow> f (n,m)\<le> C + (n-N) * g m"
    by (metis le_add_diff_inverse)

  from g have "\<exists>c>0. \<forall>\<^sub>F x in at_top. norm (g x) \<le> c * norm (x)"
    unfolding bigo_def by auto
  then obtain cg Ng where nncg: "cg > 0" and b: "\<forall>m\<ge>Ng. norm (g m) \<le> cg * norm (m)"
    using eventually_sequentially by auto
  let ?cg = "max cg 1"
  from nncg b have nncg2: "?cg \<ge> 1" and b2: "\<forall>m\<ge>Ng. norm (g m) \<le> ?cg * norm (m)"
    apply auto
    by (meson max.cobounded1 mult_le_cancel_right of_nat_less_0_iff order_trans)

  from fpos obtain npos where fpos': "\<And>n m. n\<ge>npos \<Longrightarrow> m\<ge>npos \<Longrightarrow> f (n,m) \<ge> 0"
    unfolding eventually_nonneg_def eventually_prod_sequentially by blast

  let ?N = "max (max Ng npos) (N+1)"
  let ?nfN = "max (norm (f (?N,?N))) 1"

  show ?thesis apply(rule bigoI[where c="(C / (?N*?N) + ?cg)"])
    apply(simp only: eventually_prod_sequentially)
    apply(rule exI[where x="?N"])
    proof safe
      fix m n
      have "norm (n-N) = n-N" by auto
      assume pf: "?N \<le> m"  "?N \<le> n"
      with fpos' have fpos'': "f (n,m) \<ge> 0" by auto
      have NN: "?N*?N > 0" by auto
      from pf have "?N > 0" by auto
      with pf have nm: "n*m\<ge>?N*?N" using mult_le_mono by blast
      then   have urghs: "C / (n*m) \<le> C / (?N*?N)" using NN
        by (meson Cpos frac_le of_nat_le_iff of_nat_0_less_iff order_refl)
      from pf have Nn: "N \<le> n " and mNg: "m \<ge> Ng" and nm0: "n*m>0"  by auto
      then have "norm (f (n, m)) \<le> norm (C + (n-N) * g m)" using k[of "n"] fpos''
        by (smt real_norm_def)
      also have "\<dots> \<le> norm C + norm (n-N) * norm(g m)"
        using  Cpos unfolding real_norm_def by (metis abs_mult abs_triangle_ineq)
      also have "\<dots> = C + (n-N) * norm (g m)" using Cpos  by auto
      also have "\<dots> \<le> C + n * norm (g m)"
        by (simp add: mult_right_mono)
      also have "\<dots> \<le>   C + n * ( ?cg * norm (m))" using mNg b2
        by (simp add: mult_left_mono)
      also have "\<dots> \<le> C + ?cg * n * m" by auto
      also
        have "\<dots> = (C / (n*m) + ?cg) * n * m" using nm0
        proof -
          have "0 < m * n"
          using nm0 by force
            then have "real m * (real n * (C / (real m * real n))) + real m * (real n * max 1 cg) = C + real m * (real n * max 1 cg)"
              by simp
            then show ?thesis
              by (metis (no_types) distrib_right max.commute mult.commute of_nat_mult)
          qed
      also have "\<dots> \<le> (C / (?N*?N) + ?cg) * n * m" using urghs
        by (simp add: mult_right_mono)
      also have "\<dots> \<le> (C / real (?N*?N) + ?cg) * norm (real (n * m))" by auto
      finally show i: "norm (f (n, m)) \<le> (C / real (?N*?N) + ?cg) * norm (real (n * m))" .
    qed
  qed

lemma bivariateOmega:
  assumes "\<And>n m. n\<ge>N \<Longrightarrow>  f (Suc n,m) = f (n,m) + g m"
    and "\<And>n m. n \<le> N \<Longrightarrow> f (n,m) \<le> C"
    and g: "g \<in> \<Omega>(\<lambda>m. m)"
    and fpos: "eventually_nonneg (at_top\<times>\<^sub>Fat_top) f"
    and gpos: "\<And>n m. g n \<ge> 0"
    and Cpos: "C \<ge> 0"
  shows "f \<in> \<Omega>\<^sub>2(\<lambda>(n,m). real (n * m))"
proof -
  from fpos obtain npos where fpos': "\<And>n m. n\<ge>npos \<Longrightarrow> m\<ge>npos \<Longrightarrow> f (n,m) \<ge> 0"
    unfolding eventually_nonneg_def eventually_prod_sequentially by blast

  let ?N = "max N npos"
  { fix n m
    assume m: "m\<ge>?N"
    then have "f (?N+n, m) \<ge> n * g m"
    proof (induct n)
      case 0
      then show ?case using m fpos' by simp
    next
      case (Suc n)
      have "(real (n+1)) * g m = real n * g m + g m"
        by (metis Suc_eq_plus1 add.commute of_nat_Suc semiring_normalization_rules(3))
      also have "\<dots> \<le>  f (?N + n, m) + g m" using  Suc by auto
      also have "\<dots> = f (?N + Suc n, m)"  using assms(1) by simp
      finally show ?case by simp
    qed
  } then have k: "\<And>n m. n\<ge>?N \<Longrightarrow> m\<ge>?N \<Longrightarrow> f (n,m) \<ge> (n-?N) * g m"
    by (metis le_add_diff_inverse)

  have ka: "\<And>n. n\<ge>2*?N \<Longrightarrow> n \<le> 2 * (n-?N)" by auto

  from g obtain cg Ng where nncg: "cg > 0" and b: "\<forall>m\<ge>Ng. norm (g m) \<ge> cg * norm (m)"
    using bigOmegaE by blast
  from nncg have pff: "\<And>m. m \<ge> Ng \<Longrightarrow> m \<le> (1/cg) * g m " using gpos b apply auto
    by (simp add: mult.commute pos_le_divide_eq)

  let ?N' = "max (max Ng npos) (2*?N)"

  let ?C = "2*(1/cg)"
  show ?thesis apply(rule bigomegaI[where c="?C"])
    apply(simp only: eventually_prod_sequentially)
    apply(rule exI[where x="?N'"])
    proof safe
      fix m n
      have "norm (n-?N) = n-?N" by auto
      assume pf: "?N' \<le> m"  "?N' \<le> n"
      then have t: "n \<ge> 2*?N" and l: "Ng \<le> m" by auto
      from pf fpos' have fpos'': "0 \<le> f (n, m)" by auto
      from pf have tl: "n\<ge>?N" "m\<ge>?N" by auto

      have " norm (real (n * m)) = real n * real m" by simp
      also have "\<dots> \<le> n * ( (1/cg) * g m)" apply(rule mult_left_mono) apply(rule pff) apply (fact l) by simp
      also have "\<dots> \<le> (1/cg) * (n * g m)" by auto
      also have "\<dots> \<le> (1/cg) * (2*(n-?N) * g m)" apply(rule mult_left_mono)
            apply(rule mult_right_mono) using nncg gpos ka[OF t] by auto
      also have "\<dots> = ?C * ((n-?N) * g m)" by auto
      also have "\<dots> \<le> ?C * (f (n, m))" apply(rule mult_left_mono) using k[of n m] nncg pf tl by auto
      also have "\<dots> \<le> ?C * norm (f (n,m))" apply(rule mult_left_mono) using nncg fpos by auto
      finally show "norm (real (n * m)) \<le> ?C * norm (f (n, m))" .
  qed
qed

lemma bivariateTheta:
  assumes "\<And>n m. n\<ge>N \<Longrightarrow>  f (Suc n,m) = f (n,m) + g m"
    and "\<And>n m. n \<le> N \<Longrightarrow> f (n,m) \<le> C"
    and g: "g \<in> \<Theta>(\<lambda>m. m)"
    and fpos: "eventually_nonneg (at_top\<times>\<^sub>Fat_top) f"
    and gpos: "\<And>n m. g n \<ge> 0"
    and Cpos: "C \<ge> 0"
  shows "f \<in> \<Theta>\<^sub>2(\<lambda>(n,m). real (n * m))"
proof -
  from g have "g \<in> \<Omega>(\<lambda>m. m)" "g \<in> O(\<lambda>m. m)" by auto
  have "f \<in> O\<^sub>2(\<lambda>(n,m). real (n * m))"
    apply(rule bivariate[where N=N and C=C]) using assms by auto
  moreover
  have "f \<in> \<Omega>\<^sub>2(\<lambda>(n,m). real (n * m))"
    apply(rule bivariateOmega[where N=N and C=C and g=g]) using assms by auto
  ultimately show ?thesis by auto
qed

section \<open>Examples in the bivariate case\<close>

fun ex :: "nat \<times> nat \<Rightarrow> real" where
  "ex (0,m) = 1"
| "ex (Suc n, m) = ex (n,m) + m"

lemma ex_pos[simp]: "0 \<le> ex (n, m)" by (induct n) auto

lemma "ex \<in> \<Theta>\<^sub>2(\<lambda>(n,m). real (n * m))"
  apply (rule bivariateTheta[where N=0 and C=1])
  by (auto simp: eventually_prod_sequentially eventually_nonneg_def)

end


(* Author: Rafal Kolanski, 2008
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

header {* More properties of maps plus map disjuction. *}

theory Map_Extra
  imports Main
begin

text {*
  A note on naming:
  Anything not involving heap disjuction can potentially be incorporated
  directly into Map.thy, thus uses @{text "m"} for map variable names.
  Anything involving heap disjunction is not really mergeable with Map, is
  destined for use in separation logic, and hence uses @{text "h"}
*}

section {* Things that could go into Option Type *}

text {* Misc option lemmas *}

lemma None_not_eq: "(None \<noteq> x) = (\<exists>y. x = Some y)" by (cases x) auto

lemma None_com: "(None = x) = (x = None)" by fast

lemma Some_com: "(Some y = x) = (x = Some y)" by fast

section {* Things that go into Map.thy *}

text {* Map intersection: set of all keys for which the maps agree. *}

definition
  map_inter :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> 'a set" (infixl "\<inter>\<^sub>m" 70) where
  "m\<^sub>1 \<inter>\<^sub>m m\<^sub>2 \<equiv> {x \<in> dom m\<^sub>1. m\<^sub>1 x = m\<^sub>2 x}"

text {* Map restriction via domain subtraction *}

definition
  sub_restrict_map :: "('a \<rightharpoonup> 'b) => 'a set => ('a \<rightharpoonup> 'b)" (infixl "`-"  110)
  where
  "m `- S \<equiv> (\<lambda>x. if x \<in> S then None else m x)"

subsection {* Properties of maps not related to restriction *}

lemma empty_forall_equiv: "(m = empty) = (\<forall>x. m x = None)"
  by (fastforce intro!: ext)

lemma map_le_empty2 [simp]:
  "(m \<subseteq>\<^sub>m empty) = (m = empty)"
  by (auto simp: map_le_def intro: ext)

lemma dom_iff:
  "(\<exists>y. m x = Some y) = (x \<in> dom m)"
  by auto

lemma non_dom_eval:
  "x \<notin> dom m \<Longrightarrow> m x = None"
  by auto

lemma non_dom_eval_eq:
  "x \<notin> dom m = (m x = None)"
  by auto

lemma map_add_same_left_eq:
  "m\<^sub>1 = m\<^sub>1' \<Longrightarrow> (m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0 ++ m\<^sub>1')"
  by simp

lemma map_add_left_cancelI [intro!]:
  "m\<^sub>1 = m\<^sub>1' \<Longrightarrow> m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0 ++ m\<^sub>1'"
  by simp

lemma dom_empty_is_empty:
  "(dom m = {}) = (m = empty)"
proof (rule iffI)
  assume a: "dom m = {}"
  { assume "m \<noteq> empty"
    hence "dom m \<noteq> {}"
      by - (subst (asm) empty_forall_equiv, simp add: dom_def)
    hence False using a by blast
  }
  thus "m = empty" by blast
next
  assume a: "m = empty"
  thus "dom m = {}" by simp
qed

lemma map_add_dom_eq:
  "dom m = dom m' \<Longrightarrow> m ++ m' = m'"
  by (rule ext) (auto simp: map_add_def split: option.splits)

lemma map_add_right_dom_eq:
  "\<lbrakk> m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0' ++ m\<^sub>1'; dom m\<^sub>1 = dom m\<^sub>1' \<rbrakk> \<Longrightarrow> m\<^sub>1 = m\<^sub>1'"
  unfolding map_add_def
  by (rule ext, rule ccontr,
      drule_tac x=x in fun_cong, clarsimp split: option.splits,
      drule sym, drule sym, force+)

lemma map_le_same_dom_eq:
  "\<lbrakk> m\<^sub>0 \<subseteq>\<^sub>m m\<^sub>1 ; dom m\<^sub>0 = dom m\<^sub>1 \<rbrakk> \<Longrightarrow> m\<^sub>0 = m\<^sub>1"
  by (auto intro!: ext simp: map_le_def elim!: ballE)

subsection {* Properties of map restriction *}

lemma restrict_map_cancel:
  "(m |` S = m |` T) = (dom m \<inter> S = dom m \<inter> T)"
  by (fastforce intro: ext dest: fun_cong
               simp: restrict_map_def None_not_eq
               split: split_if_asm)

lemma map_add_restricted_self [simp]:
  "m ++ m |` S = m"
  by (auto intro: ext simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_dom_right [simp]:
  "(m ++ m') |` dom m' = m'"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_UNIV [simp]:
  "m |` UNIV = m"
  by (simp add: restrict_map_def)

lemma restrict_map_dom:
  "S = dom m \<Longrightarrow> m |` S = m"
  by (auto intro!: ext simp: restrict_map_def None_not_eq)

lemma restrict_map_subdom:
  "dom m \<subseteq> S \<Longrightarrow> m |` S = m"
  by (fastforce simp: restrict_map_def None_com intro: ext)

lemma map_add_restrict:
  "(m\<^sub>0 ++ m\<^sub>1) |` S = ((m\<^sub>0 |` S) ++ (m\<^sub>1 |` S))"
  by (force simp: map_add_def restrict_map_def intro: ext)

lemma map_le_restrict:
  "m \<subseteq>\<^sub>m m' \<Longrightarrow> m = m' |` dom m"
  by (force simp: map_le_def restrict_map_def None_com intro: ext)

lemma restrict_map_le:
  "m |` S \<subseteq>\<^sub>m m"
  by (auto simp: map_le_def)

lemma restrict_map_remerge:
  "\<lbrakk> S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` S ++ m |` T = m |` (S \<union> T)"
  by (rule ext, clarsimp simp: restrict_map_def map_add_def
                         split: option.splits)

lemma restrict_map_empty:
  "dom m \<inter> S = {} \<Longrightarrow> m |` S = empty"
  by (fastforce simp: restrict_map_def intro: ext)

lemma map_add_restrict_comp_right [simp]:
  "(m |` S ++ m |` (UNIV - S)) = m"
  by (force simp: map_add_def restrict_map_def split: option.splits intro: ext)

lemma map_add_restrict_comp_right_dom [simp]:
  "(m |` S ++ m |` (dom m - S)) = m"
  by (auto simp: map_add_def restrict_map_def split: option.splits intro!: ext)

lemma map_add_restrict_comp_left [simp]:
  "(m |` (UNIV - S) ++ m |` S) = m"
  by (subst map_add_comm, auto)

lemma restrict_self_UNIV:
  "m |` (dom m - S) = m |` (UNIV - S)"
  by (auto intro!: ext simp: restrict_map_def)

lemma map_add_restrict_nonmember_right:
  "x \<notin> dom m' \<Longrightarrow> (m ++ m') |` {x} = m |` {x}"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_nonmember_left:
  "x \<notin> dom m \<Longrightarrow> (m ++ m') |` {x} = m' |` {x}"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_right:
  "x \<subseteq> dom m' \<Longrightarrow> (m ++ m') |` x = m' |` x"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_compose:
  "\<lbrakk> S \<union> T = dom m ; S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` S ++ m |` T = m"
  by (fastforce intro: ext simp: map_add_def restrict_map_def)

lemma map_le_dom_subset_restrict:
  "\<lbrakk> m' \<subseteq>\<^sub>m m; dom m' \<subseteq> S \<rbrakk> \<Longrightarrow> m' \<subseteq>\<^sub>m (m |` S)"
  by (force simp: restrict_map_def map_le_def)

lemma map_le_dom_restrict_sub_add:
  "m' \<subseteq>\<^sub>m m \<Longrightarrow> m |` (dom m - dom m') ++ m' = m"
  by (auto simp: None_com map_add_def restrict_map_def map_le_def
           split: option.splits
           intro!: ext)
     (force simp: Some_com)+

lemma subset_map_restrict_sub_add:
  "T \<subseteq> S \<Longrightarrow> m |` (S - T) ++ m |` T = m |` S"
  by (auto simp: restrict_map_def map_add_def intro!: ext split: option.splits)

lemma restrict_map_sub_union:
  "m |` (dom m - (S \<union> T)) = (m |` (dom m - T)) |` (dom m - S)"
  by (auto intro!: ext simp: restrict_map_def)

lemma prod_restrict_map_add:
  "\<lbrakk> S \<union> T = U; S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` (X \<times> S) ++ m |` (X \<times> T) = m |` (X \<times> U)"
  by (auto simp: map_add_def restrict_map_def intro!: ext split: option.splits)

section {* Things that should not go into Map.thy (separation logic) *}

subsection {* Definitions *}

text {* Map disjuction *}

definition
  map_disj :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool" (infix "\<bottom>" 51) where
  "h\<^sub>0 \<bottom> h\<^sub>1 \<equiv> dom h\<^sub>0 \<inter> dom h\<^sub>1 = {}"

declare None_not_eq [simp]

subsection {* Properties of @{term "sub_restrict_map"} *}

lemma restrict_map_sub_add: "h |` S ++ h `- S = h"
  by (fastforce simp: sub_restrict_map_def restrict_map_def map_add_def
               split: option.splits split_if
               intro: ext)

subsection {* Properties of map disjunction *}

lemma map_disj_empty_right [simp]:
  "h \<bottom> empty"
  by (simp add: map_disj_def)

lemma map_disj_empty_left [simp]:
  "empty \<bottom> h"
  by (simp add: map_disj_def)

lemma map_disj_com:
  "h\<^sub>0 \<bottom> h\<^sub>1 = h\<^sub>1 \<bottom> h\<^sub>0"
  by (simp add: map_disj_def, fast)

lemma map_disjD:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> dom h\<^sub>0 \<inter> dom h\<^sub>1 = {}"
  by (simp add: map_disj_def)

lemma map_disjI:
  "dom h\<^sub>0 \<inter> dom h\<^sub>1 = {} \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1"
  by (simp add: map_disj_def)

subsection {* Map associativity-commutativity based on map disjuction *}

lemma map_add_com:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 ++ h\<^sub>1 = h\<^sub>1 ++ h\<^sub>0"
  by (drule map_disjD, rule map_add_comm, force)

lemma map_add_left_commute:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 ++ (h\<^sub>1 ++ h\<^sub>2) = h\<^sub>1 ++ (h\<^sub>0 ++ h\<^sub>2)"
  by (simp add: map_add_com map_disj_com map_add_assoc)

lemma map_add_disj:
  "h\<^sub>0 \<bottom> (h\<^sub>1 ++ h\<^sub>2) = (h\<^sub>0 \<bottom> h\<^sub>1 \<and> h\<^sub>0 \<bottom> h\<^sub>2)"
  by (simp add: map_disj_def, fast)

lemma map_add_disj':
  "(h\<^sub>1 ++ h\<^sub>2) \<bottom> h\<^sub>0 = (h\<^sub>1 \<bottom> h\<^sub>0 \<and> h\<^sub>2 \<bottom> h\<^sub>0)"
  by (simp add: map_disj_def, fast)

text {*
  We redefine @{term "map_add"} associativity to bind to the right, which
  seems to be the more common case.
  Note that when a theory includes Map again, @{text "map_add_assoc"} will
  return to the simpset and will cause infinite loops if its symmetric
  counterpart is added (e.g. via @{text "map_add_ac"})
  *}

declare map_add_assoc [simp del]

text {*
  Since the associativity-commutativity of @{term "map_add"} relies on
  map disjunction, we include some basic rules into the ac set.
  *}

lemmas map_add_ac =
  map_add_assoc[symmetric] map_add_com map_disj_com
  map_add_left_commute map_add_disj map_add_disj'

subsection {* Basic properties *}

lemma map_disj_None_right:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; x \<in> dom h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>1 x = None"
  by (auto simp: map_disj_def dom_def)

lemma map_disj_None_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; x \<in> dom h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 x = None"
  by (auto simp: map_disj_def dom_def)

lemma map_disj_None_left':
  "\<lbrakk> h\<^sub>0 x = Some y ; h\<^sub>1 \<bottom> h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>1 x = None "
  by (auto simp: map_disj_def)

lemma map_disj_None_right':
  "\<lbrakk> h\<^sub>1 x = Some y ; h\<^sub>1 \<bottom> h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0 x = None "
  by (auto simp: map_disj_def)

lemma map_disj_common:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; h\<^sub>0 p = Some v ; h\<^sub>1 p = Some v' \<rbrakk> \<Longrightarrow> False"
  by (frule (1) map_disj_None_left', simp)

lemma map_disj_eq_dom_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; dom h\<^sub>0' = dom h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0' \<bottom> h\<^sub>1"
  by (auto simp: map_disj_def)

subsection {* Map disjunction and addition *}

lemma map_add_eval_left:
  "\<lbrakk> x \<in> dom h ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h x"
  by (auto dest!: map_disj_None_right simp: map_add_def cong: option.case_cong)

lemma map_add_eval_right:
  "\<lbrakk> x \<in> dom h' ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h' x"
  by (auto elim!: map_disjD simp: map_add_comm map_add_eval_left map_disj_com)

lemma map_add_eval_right':
  "\<lbrakk> x \<notin> dom h ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h' x"
  by (clarsimp simp: map_disj_def map_add_def split: option.splits)

lemma map_add_left_dom_eq:
  assumes eq: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'"
  assumes etc: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0' \<bottom> h\<^sub>1'" "dom h\<^sub>0 = dom h\<^sub>0'"
  shows "h\<^sub>0 = h\<^sub>0'"
proof -
  from eq have "h\<^sub>1 ++ h\<^sub>0 = h\<^sub>1' ++ h\<^sub>0'" using etc by (simp add: map_add_ac)
  thus ?thesis using etc
    by (fastforce elim!: map_add_right_dom_eq simp: map_add_ac)
qed

lemma map_add_left_eq:
  assumes eq: "h\<^sub>0 ++ h = h\<^sub>1 ++ h"
  assumes disj: "h\<^sub>0 \<bottom> h" "h\<^sub>1 \<bottom> h"
  shows "h\<^sub>0 = h\<^sub>1"
proof (rule ext)
  fix x
  from eq have eq': "(h\<^sub>0 ++ h) x = (h\<^sub>1 ++ h) x" by (auto intro!: ext)
  { assume "x \<in> dom h"
    hence "h\<^sub>0 x = h\<^sub>1 x" using disj by (simp add: map_disj_None_left)
  } moreover {
    assume "x \<notin> dom h"
    hence "h\<^sub>0 x = h\<^sub>1 x" using disj eq' by (simp add: map_add_eval_left')
  }
  ultimately show "h\<^sub>0 x = h\<^sub>1 x" by cases
qed

lemma map_add_right_eq:
  "\<lbrakk>h ++ h\<^sub>0 = h ++ h\<^sub>1; h\<^sub>0 \<bottom> h; h\<^sub>1 \<bottom> h\<rbrakk> \<Longrightarrow> h\<^sub>0 = h\<^sub>1"
  by (rule_tac h=h in map_add_left_eq, auto simp: map_add_ac)

lemma map_disj_add_eq_dom_right_eq:
  assumes merge: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'" and d: "dom h\<^sub>0 = dom h\<^sub>0'" and
      ab_disj: "h\<^sub>0 \<bottom> h\<^sub>1" and cd_disj: "h\<^sub>0' \<bottom> h\<^sub>1'"
  shows "h\<^sub>1 = h\<^sub>1'"
proof (rule ext)
  fix x
  from merge have merge_x: "(h\<^sub>0 ++ h\<^sub>1) x = (h\<^sub>0' ++ h\<^sub>1') x" by simp
  with d ab_disj cd_disj show  "h\<^sub>1 x = h\<^sub>1' x"
    by - (case_tac "h\<^sub>1 x", case_tac "h\<^sub>1' x", simp, fastforce simp: map_disj_def,
          case_tac "h\<^sub>1' x", clarsimp, simp add: Some_com,
          force simp: map_disj_def, simp)
qed

lemma map_disj_add_eq_dom_left_eq:
  assumes add: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'" and
          dom: "dom h\<^sub>1 = dom h\<^sub>1'" and
          disj: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0' \<bottom> h\<^sub>1'"
  shows "h\<^sub>0 = h\<^sub>0'"
proof -
  have "h\<^sub>1 ++ h\<^sub>0 = h\<^sub>1' ++ h\<^sub>0'" using add disj by (simp add: map_add_ac)
  thus ?thesis using dom disj
    by - (rule map_disj_add_eq_dom_right_eq, auto simp: map_disj_com)
qed

lemma map_add_left_cancel:
  assumes disj: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0 \<bottom> h\<^sub>1'"
  shows "(h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0 ++ h\<^sub>1') = (h\<^sub>1 = h\<^sub>1')"
proof (rule iffI, rule ext)
  fix x
  assume "(h\<^sub>0 ++ h\<^sub>1) = (h\<^sub>0 ++ h\<^sub>1')"
  hence "(h\<^sub>0 ++ h\<^sub>1) x = (h\<^sub>0 ++ h\<^sub>1') x" by (auto intro!: ext)
  hence "h\<^sub>1 x = h\<^sub>1' x" using disj
    by - (cases "x \<in> dom h\<^sub>0",
          simp_all add: map_disj_None_right map_add_eval_right')
  thus "h\<^sub>1 x = h\<^sub>1' x" by (auto intro!: ext)
qed auto

lemma map_add_lr_disj:
  "\<lbrakk> h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'; h\<^sub>1 \<bottom> h\<^sub>1'  \<rbrakk> \<Longrightarrow> dom h\<^sub>1 \<subseteq> dom h\<^sub>0'"
  by (clarsimp simp: map_disj_def map_add_def, drule_tac x=x in fun_cong)
     (auto split: option.splits)

subsection {* Map disjunction and map updates *}

lemma map_disj_update_left [simp]:
  "p \<in> dom h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1(p \<mapsto> v) = h\<^sub>0 \<bottom> h\<^sub>1"
  by (clarsimp simp add: map_disj_def, blast)

lemma map_disj_update_right [simp]:
  "p \<in> dom h\<^sub>1 \<Longrightarrow> h\<^sub>1(p \<mapsto> v) \<bottom> h\<^sub>0 = h\<^sub>1 \<bottom> h\<^sub>0"
  by (simp add: map_disj_com)

lemma map_add_update_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; p \<in> dom h\<^sub>0 \<rbrakk> \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>1)(p \<mapsto> v) = (h\<^sub>0(p \<mapsto> v) ++ h\<^sub>1)"
  by (drule (1) map_disj_None_right)
     (auto intro: ext simp: map_add_def cong: option.case_cong)

lemma map_add_update_right:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; p \<in> dom h\<^sub>1  \<rbrakk> \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>1)(p \<mapsto> v) = (h\<^sub>0 ++ h\<^sub>1 (p \<mapsto> v))"
  by (drule (1) map_disj_None_left)
     (auto intro: ext simp: map_add_def cong: option.case_cong)

subsection {* Map disjunction and @{term "map_le"} *}

lemma map_le_override [simp]:
  "\<lbrakk> h \<bottom> h' \<rbrakk> \<Longrightarrow> h \<subseteq>\<^sub>m h ++ h'"
  by (auto simp: map_le_def map_add_def map_disj_def split: option.splits)

lemma map_leI_left:
  "\<lbrakk> h = h\<^sub>0 ++ h\<^sub>1 ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h" by auto

lemma map_leI_right:
  "\<lbrakk> h = h\<^sub>0 ++ h\<^sub>1 ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>1 \<subseteq>\<^sub>m h" by auto

lemma map_disj_map_le:
  "\<lbrakk> h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0' \<bottom> h\<^sub>1"
  by (force simp: map_disj_def map_le_def)

lemma map_le_on_disj_left:
  "\<lbrakk> h' \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 ; h' = h\<^sub>0 ++ h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h"
  unfolding map_le_def
  by (rule ballI, erule_tac x=a in ballE, auto simp: map_add_eval_left)+

lemma map_le_on_disj_right:
  "\<lbrakk> h' \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 ; h' = h\<^sub>1 ++ h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h"
  by (auto simp: map_le_on_disj_left map_add_ac)

lemma map_le_add_cancel:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0' ++ h\<^sub>1 \<subseteq>\<^sub>m h\<^sub>0 ++ h\<^sub>1"
  by (auto simp: map_le_def map_add_def map_disj_def split: option.splits)

lemma map_le_override_bothD:
  assumes subm: "h\<^sub>0' ++ h\<^sub>1 \<subseteq>\<^sub>m h\<^sub>0 ++ h\<^sub>1"
  assumes disj': "h\<^sub>0' \<bottom> h\<^sub>1"
  assumes disj: "h\<^sub>0 \<bottom> h\<^sub>1"
  shows "h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0"
unfolding map_le_def
proof (rule ballI)
  fix a
  assume a: "a \<in> dom h\<^sub>0'"
  hence sumeq: "(h\<^sub>0' ++ h\<^sub>1) a = (h\<^sub>0 ++ h\<^sub>1) a"
    using subm unfolding map_le_def by auto
  from a have "a \<notin> dom h\<^sub>1" using disj' by (auto dest!: map_disj_None_right)
  thus "h\<^sub>0' a = h\<^sub>0 a" using a sumeq disj disj'
    by (simp add: map_add_eval_left map_add_eval_left')
qed

lemma map_le_conv:
  "(h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 \<and> h\<^sub>0' \<noteq> h\<^sub>0) = (\<exists>h\<^sub>1. h\<^sub>0 = h\<^sub>0' ++ h\<^sub>1 \<and> h\<^sub>0' \<bottom> h\<^sub>1 \<and> h\<^sub>0' \<noteq> h\<^sub>0)"
  unfolding map_le_def map_disj_def map_add_def
  by (rule iffI,
      clarsimp intro!: exI[where x="\<lambda>x. if x \<notin> dom h\<^sub>0' then h\<^sub>0 x else None"])
     (fastforce intro: ext intro: split: option.splits split_if_asm)+

lemma map_le_conv2:
  "h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 = (\<exists>h\<^sub>1. h\<^sub>0 = h\<^sub>0' ++ h\<^sub>1 \<and> h\<^sub>0' \<bottom> h\<^sub>1)"
  by (case_tac "h\<^sub>0'=h\<^sub>0", insert map_le_conv, auto intro: exI[where x=empty])

subsection {* Map disjunction and restriction *}

lemma map_disj_comp [simp]:
  "h\<^sub>0 \<bottom> h\<^sub>1 |` (UNIV - dom h\<^sub>0)"
  by (force simp: map_disj_def)

lemma restrict_map_disj:
  "S \<inter> T = {} \<Longrightarrow> h |` S \<bottom> h |` T"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_disj_restrict_dom [simp]:
  "h\<^sub>0 \<bottom> h\<^sub>1 |` (dom h\<^sub>1 - dom h\<^sub>0)"
  by (force simp: map_disj_def)

lemma restrict_map_disj_dom_empty:
  "h \<bottom> h' \<Longrightarrow> h |` dom h' = empty"
  by (fastforce simp: map_disj_def restrict_map_def intro: ext)

lemma restrict_map_univ_disj_eq:
  "h \<bottom> h' \<Longrightarrow> h |` (UNIV - dom h') = h"
  by (rule ext, auto simp: map_disj_def restrict_map_def)

lemma restrict_map_disj_dom:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h |` dom h\<^sub>0 \<bottom> h |` dom h\<^sub>1"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_add_restrict_dom_left:
  "h \<bottom> h' \<Longrightarrow> (h ++ h') |` dom h = h"
  by (rule ext, auto simp: restrict_map_def map_add_def dom_def map_disj_def
                     split: option.splits)

lemma map_add_restrict_dom_left':
  "h \<bottom> h' \<Longrightarrow> S = dom h \<Longrightarrow> (h ++ h') |` S = h"
  by (rule ext, auto simp: restrict_map_def map_add_def dom_def map_disj_def
                     split: option.splits)

lemma restrict_map_disj_right:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1 |` S"
  by (auto simp: map_disj_def)

lemmas restrict_map_disj_both = restrict_map_disj_right restrict_map_disj_left

lemma map_dom_disj_restrict_right:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>0') |` dom h\<^sub>1 = h\<^sub>0' |` dom h\<^sub>1"
  by (simp add: map_add_restrict restrict_map_empty map_disj_def)

lemma restrict_map_on_disj:
  "h\<^sub>0' \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 |` dom h\<^sub>0' \<bottom> h\<^sub>1"
  unfolding map_disj_def by auto

lemma restrict_map_on_disj':
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1 |` S"
  by (auto simp: map_disj_def map_add_def)

lemma map_le_sub_dom:
  "\<lbrakk> h\<^sub>0 ++ h\<^sub>1 \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h |` (dom h - dom h\<^sub>1)"
  by (rule map_le_override_bothD, subst map_le_dom_restrict_sub_add)
     (auto elim: map_add_le_mapE simp: map_add_ac)

lemma map_submap_break:
  "\<lbrakk> h \<subseteq>\<^sub>m h' \<rbrakk> \<Longrightarrow> h' = (h' |` (UNIV - dom h)) ++ h"
  by (fastforce intro!: ext split: option.splits
               simp: map_le_restrict restrict_map_def map_le_def map_add_def
                     dom_def)

lemma map_add_disj_restrict_both:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1; S \<inter> S' = {}; T \<inter> T' = {} \<rbrakk>
   \<Longrightarrow> (h\<^sub>0 |` S) ++ (h\<^sub>1 |` T) \<bottom> (h\<^sub>0 |` S') ++ (h\<^sub>1 |` T')"
  by (auto simp: map_add_ac intro!: restrict_map_disj_both restrict_map_disj)

end