text \<open> Version 0.4, last changed 2018-02-27
  (C) fovefi ltd, www.fovefi.co
  (author: Lukas Bulwahn [lubu@fovefi.co], comments by Manfred Kerber [make@fovefi.co])

  Dually licenced under
  Creative Commons Attribution (CC-BY) 4.0 [https://creativecommons.org/licenses/by/4.0/]
  ISC License (1-clause BSD License)       [https://www.isc.org/downloads/software-support-policy/isc-license/]
  See LICENSE files for details.
  (Rationale for this dual licence: http://arxiv.org/abs/1107.3212)

  In this file, a linear approximation (i.e., linear interpolation) is defined. The linear approximation
  of two given points (x1,y1) and (x2,y2) is a function f(x) = a*(x-b) + c with f(x1) = y1 and
  f(x2) = y2. This is the function with slope a = (y2 - y1)/(x2 - x1), b = x1,
  and c = y1. There is a priori a problem if the two given points are the same. We implicitly assume
  in the following that they are not. Note that Isabelle's logic is total and 1/0 has been defined
  as 0.

  In addition to the definition, properties of the linear approximation are presented
  such as about the maximum and minimum of linear approximation. \<close>

theory Linear_Interpolation
  imports Complex_Main
begin

section \<open>Linear function defined by two points\<close>

text \<open> A linear function through two points (x1, y1) and (x2, y2) is defined as the unique
      straight line through the points (assumed the points are different and x1 \<noteq> x2). \<close>
definition linear :: "real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> real \<Rightarrow> real"
where
  "linear xy1 xy2 = (case (xy1, xy2) of
    ((x1, y1), (x2, y2)) \<Rightarrow> (\<lambda>x. (y2 - y1) / (x2 - x1) * (x - x1) + y1))"

text \<open> Alternative description with explicit pair representation. \<close>
lemma linear_def':
  "linear (x1, y1) (x2, y2) = (\<lambda>x. (y2 - y1) / (x2 - x1) * (x - x1) + y1)"
unfolding linear_def by simp

text \<open> Alternative description of linear function. \<close>
lemma linear_eq:
  "linear (x1, y1) (x2, y2) x = y1 + (x - x1) * (y2 - y1) / (x2 - x1)"
unfolding linear_def by simp

text \<open> The linear function evaluates correctly at the first point. \<close>
lemma linear_first:
  "linear (x1, y1) (x2, y2) x1 = y1"
unfolding linear_def' by simp

text \<open> The linear function evaluates correctly at the second point, assumed the x-values are different \<close>
lemma linear_second:
  assumes "x1 \<noteq> x2"
  shows "linear (x1, y1) (x2, y2) x2 = y2"
using assms unfolding linear_def' by simp

text \<open> A linear function is bounded from above by the bigger of two values (for all values in between). \<close>
lemma linear_upper_bound:
  assumes "x1 \<le> x" "x \<le> x2"
  shows "linear (x1, y1) (x2, y2) x \<le> max y1 y2"
proof -
  have "linear (x1, y1) (x2, y2) x = (y2 - y1) / (x2 - x1) * (x - x1) + y1"
    unfolding linear_def' by simp
  also have "\<dots> \<le> max y1 y2"
  proof cases
    assume "y1 \<le> y2"
    have "(x - x1) / (x2 - x1) \<le> 1"
      using assms divide_le_eq_1 by force
    have "(y2 - y1) / (x2 - x1) * (x - x1) + y1 = y2 - ((1 - (x - x1) / (x2 - x1)) * (y2 - y1))"
      by algebra
    also have "\<dots> \<le> y2" by (simp add: \<open>(x - x1) / (x2 - x1) \<le> 1\<close> \<open>y1 \<le> y2\<close>)
    also have "\<dots> \<le> max y1 y2" by simp
    finally show ?thesis .
  next
    assume "\<not> y1 \<le> y2"
    from this have "(y2 - y1) / (x2 - x1) \<le> 0"
      using assms divide_le_0_iff by force
    from this have "(y2 - y1) / (x2 - x1) * (x - x1) + y1 \<le> y1"
      using assms(1) by (meson add_le_same_cancel2 diff_ge_0_iff_ge mult_le_0_iff)
    also have "\<dots> \<le> max y1 y2" by simp
    finally show ?thesis .
  qed
  finally show ?thesis .
qed

text \<open> A linear function is bounded from below by the smaller of two values (for all values in between).\<close>
lemma linear_lower_bound:
  assumes "x1 \<le> x" "x \<le> x2"
  shows "min y1 y2 \<le> linear (x1, y1) (x2, y2) x"
proof -
  have "min y1 y2 \<le> (y2 - y1) / (x2 - x1) * (x - x1) + y1"
  proof cases
    assume "y1 \<le> y2"
    have "(y2 - y1) / (x2 - x1) \<ge> 0"
      using \<open>y1 \<le> y2\<close> assms(1) assms(2) by auto
    have "min y1 y2 \<le> y1" by simp
    also have "\<dots> \<le> (y2 - y1) / (x2 - x1) * (x - x1) + y1"
      using \<open>0 \<le> (y2 - y1) / (x2 - x1)\<close> assms(1) mult_nonneg_nonneg by fastforce
    finally show ?thesis .
  next
    assume "\<not> y1 \<le> y2"
    have "(x - x1) / (x2 - x1) \<le> 1"
      using assms divide_le_eq_1 by fastforce
    have "min y1 y2 \<le> y2" by simp
    also have "\<dots> \<le> y2 - ((1 - (x - x1) / (x2 - x1)) * (y2 - y1))"
      using \<open>(x - x1) / (x2 - x1) \<le> 1\<close> \<open>\<not> y1 \<le> y2\<close> mult_le_0_iff by fastforce
    also have "\<dots> = (y2 - y1) / (x2 - x1) * (x - x1) + y1" by algebra
    finally show ?thesis .
  qed
  also have "(y2 - y1) / (x2 - x1) * (x - x1) + y1 = linear (x1, y1) (x2, y2) x"
    unfolding linear_def' by simp
  finally show ?thesis .
qed

text \<open> Linear functions with the value at the 2nd point greater or equal the value at the 1st point
   are (weakly) monotonically increasing. \<close>
lemma linear_monotonic:
  assumes "x1 < x2" "y1 \<le> y2"
  assumes "x \<le> x'"
  shows "linear (x1, y1) (x2, y2) x \<le> linear (x1, y1) (x2, y2) x'"
proof -
  from \<open>x1 < x2\<close> \<open>y1 \<le> y2\<close> have "(y2 - y1) / (x2 - x1) \<ge> 0" by auto
  from this show ?thesis
    using assms unfolding linear_def'
    by (metis add.commute add_le_cancel_left diff_right_mono mult.commute mult_le_cancel_right not_le)
qed

text \<open> Linear functions scale by constant factors.\<close>
lemma linear_scale:
  "c * linear (x1, y1) (x2, y2) x = linear (x1, c * y1) (x2, c * y2) x"
unfolding linear_def'
by (simp add: distrib_left linordered_field_class.sign_simps(38) mult.commute mult.left_commute)

text \<open> Linear functions are Lipschitz continuous with the Lipschitz constant being the slope. \<close>
lemma linear_Lipschitz:
  "\<bar>linear (x1, y1) (x2, y2) x' - linear (x1, y1) (x2, y2) x\<bar> = \<bar>(y2 - y1) / (x2 - x1)\<bar> * \<bar>x' - x\<bar>"
proof -
  have "\<bar>linear (x1, y1) (x2, y2) x' - linear (x1, y1) (x2, y2) x\<bar> =
     \<bar>(y2 - y1) / (x2 - x1) * (x' - x1) + y1 - ((y2 - y1) / (x2 - x1) * (x - x1) + y1)\<bar>"
    unfolding linear_def by simp
  also have "\<dots> = \<bar>(y2 - y1) / (x2 - x1) * (x' - x)\<bar>"
    by (simp add: linordered_field_class.sign_simps(38))
  also have "\<dots> = \<bar>(y2 - y1) / (x2 - x1)\<bar> * \<bar>x' - x\<bar>" by (simp add: abs_mult)
  finally show ?thesis .
qed

section \<open>Nearest rank method\<close>
text \<open> The nearest rank method assumes a partial function (concretely, a function with domain type
  "real option", which is defined only for some values. This is perhaps best been explained with
  the help of an example.

  Let us assume that you have a list of 5 real numbers xs = [8, 10, 1, 4, 5] in order to compute a
  particular rank, e.g., that of 0.75, first you order the list and get sxs = [1, 4, 5, 8, 10].
  Then you put 5 values (length of the list) on the unit interval [0;1] at equal distances of 1/5,
  staying half the distance (i.e., 1/10) away from the left and right border, that is, you get
  [0.1, 0.3, 0.5, 0.7, 0.9]. For all other values it is undefined. The nearest rank is the biggest
  defined position smaller than the position, e.g. for 0.75 it is 0.7.
 \<close>

definition nearest_rank :: "(real \<Rightarrow> real option) \<Rightarrow> real \<Rightarrow> real"
where
  "nearest_rank p x = the (p (Max {x'. p x' = Some x' \<and> x' \<le> x}))"

section \<open>Linear approximation of partial function\<close>

text \<open> Let p be a partial function and x be a real value, then the neighbors of x wrt p are two values,
  1) the biggest value - where p is defined - of the values smaller than or equal to x (as the
  next smaller neighbor) and
  2) the smallest value - where p is defined - of the values bigger than or equal to x (as the
  next bigger neighbor of x). \<close>
definition neighbors :: "(real \<Rightarrow> real option) \<Rightarrow> real \<Rightarrow> real \<times> real"
where
  "neighbors p x = (Max {x' \<in> dom p. x' \<le> x}, Min {x' \<in> dom p. x \<le> x'})"

text \<open> For a partial function p (i.e., a function of type real option), the defined interval of p is
  defined as the interval between the minimal element in the domain and the maximal element
  in the domain, (assumed p is not completely undefined, in which case it is the empty set). \<close>
definition defined_interval_of :: "(real \<Rightarrow> real option) \<Rightarrow> real set"
where
  "defined_interval_of p = (if (p = Map.empty) then {} else {Min (dom p)..Max (dom p)})"

text \<open> The linear approximation of a partial (real) function p is defined as the linear function
  going through the left and right neighbors where p is defined. \<close>
definition linear_approximation :: "(real \<Rightarrow> real option) \<Rightarrow> real \<Rightarrow> real"
where
  "linear_approximation p x = (let (x1, x2) = neighbors p x;
     (y1, y2) = (the (p x1), the (p x2)) in linear (x1, y1) (x2, y2) x)"

subsection \<open>Basic Properties\<close>

text \<open> The domain of a partial function p is a subset of the defined interval of p. \<close>
lemma subseteq_defined_interval_of:
  assumes "finite (dom p)"
  shows "dom p \<subseteq> defined_interval_of p"
using assms by (simp add: defined_interval_of_def subset_iff)

text \<open> If the domain of a partial function p is finite and an element is in the defined interval of p then
  the minimum of the elements in the domain greater than or equal to the element is in the domain
  of p as well and greater than or equal to the element. \<close>
lemma defined_interval_of_Min_in:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  shows "Min {x' \<in> dom p. x \<le> x'} \<in> {x' \<in> dom p. x \<le> x'}"
proof -
  from assms have "p \<noteq> Map.empty"
    unfolding defined_interval_of_def by auto
  from assms have "x \<in> {Min (dom p)..Max (dom p)}"
    by (simp add: \<open>p \<noteq> Map.empty\<close> defined_interval_of_def)
  from this have "Max (dom p) \<in> {x' \<in> dom p. x \<le> x'}"
    using \<open>p \<noteq> Map.empty\<close> \<open>finite (dom p)\<close> by auto
  have "finite {x' \<in> dom p. x \<le> x'}"
    using \<open>finite (dom p)\<close> by auto
  have "\<exists>y. p (Min {x' \<in> dom p. x \<le> x'}) = Some y"
    using \<open>finite {x' \<in> dom p. _}\<close> \<open>_ \<in> {x' \<in> dom p. _}\<close> Min_in by blast
  moreover have "x \<le> Min {x' \<in> dom p. x \<le> x'}"
    using \<open>finite {x' \<in> dom p. _}\<close> \<open>_ \<in> {x' \<in> dom p. _}\<close> Min_in by blast
  ultimately show ?thesis by auto
qed

text \<open> If the domain of a partial function p is finite and an element in the defined interval of p then
  the maximum of the elements in the domain smaller than or equal to the element is in the domain
  of p as well and smaller than or equal to the element. \<close>
lemma defined_interval_of_Max_in:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  shows "Max {x' \<in> dom p. x' \<le> x} \<in> {x' \<in> dom p. x' \<le> x}"
proof -
  from assms have "p \<noteq> Map.empty"
    unfolding defined_interval_of_def by auto
  from assms have "x \<in> {Min (dom p)..Max (dom p)}"
    by (simp add: \<open>p \<noteq> Map.empty\<close> defined_interval_of_def)
  from this have "Min (dom p) \<in> {x' \<in> dom p. x' \<le> x}"
    using \<open>p \<noteq> Map.empty\<close> \<open>finite (dom p)\<close> by auto
  have "finite {x' \<in> dom p. x' \<le> x}"
    using \<open>finite (dom p)\<close> by auto
  have "\<exists>y. p (Max {x' \<in> dom p. x' \<le> x}) = Some y"
    using \<open>finite {x' \<in> dom p. _}\<close> \<open>_ \<in> {x' \<in> dom p. _}\<close> Max_in by blast
  moreover have "Max {x' \<in> dom p. x' \<le> x} \<le> x"
    using \<open>finite {x' \<in> dom p. _}\<close> \<open>_ \<in> {x' \<in> dom p. _}\<close> Max_in by blast
  ultimately show ?thesis by auto
qed

text \<open> For a partial function p, the neighbors of two defined values are equal or the right neighbor
  of the smaller is less than or equal to the left neighbor of the bigger. \<close>
lemma neighbors_cases:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p" "x' \<in> defined_interval_of p"
  assumes "x \<le> x'"
  shows "(neighbors p x = neighbors p x') \<or> (snd (neighbors p x) \<le> fst (neighbors p x'))"
proof cases
  have "finite {x'' \<in> dom p. x \<le> x''}"
    by (simp add: \<open>finite (dom p)\<close>)
  assume "x' < Min {x'' \<in> dom p. x \<le> x''}"
  have "Min {x'' \<in> dom p. x' \<le> x''} = Min {x'' \<in> dom p. x \<le> x''}"
    using \<open>x \<le> x'\<close> \<open>x' < _\<close> \<open>finite {x'' \<in> dom p. _}\<close>
    by (metis (mono_tags, lifting) Min.bounded_iff eq_iff ex_in_conv less_eq_real_def mem_Collect_eq order_trans)
  moreover have "Max {x'' \<in> dom p. x'' \<le> x} = Max {x'' \<in> dom p. x'' \<le> x'}"
    using \<open>x \<le> x'\<close> \<open>x' < _\<close> \<open>finite {x'' \<in> dom p. _}\<close>
    by (smt Collect_cong Min_le mem_Collect_eq)
  ultimately show ?thesis
    unfolding neighbors_def by auto
next
  assume "\<not> x' < Min {x'' \<in> dom p. x \<le> x''}"
  have "Min {x'' \<in> dom p. x \<le> x''} \<in> {x'' \<in> dom p. x'' \<le> x'}"
    using assms(1, 2, 4) \<open>\<not> x' < _\<close> defined_interval_of_Min_in by auto
  have "Min {x'' \<in> dom p. x \<le> x''} \<le> Max {x'' \<in> dom p. x'' \<le> x'}"
    using \<open>finite _\<close> \<open>Min _ \<in> _\<close> by auto
  from this show ?thesis
    unfolding neighbors_def by auto
qed

text \<open> If the domain of a partial function is finite and x an element of the defined interval then
  there are neighbors of x such that x is between the neighbors (included). \<close>
lemma neighbors_dest:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  obtains x1 y1 x2 y2 where "neighbors p x = (x1, x2)"
    and "p x1 = Some y1" and "p x2 = Some y2" and "x1 \<le> x" and "x \<le> x2"
proof -
  obtain x1 x2 where "neighbors p x = (x1, x2)" by fastforce
  from assms(1) have "finite {x' \<in> dom p. x' \<le> x}" by auto
  from this have "Max {x' \<in> dom p. x' \<le> x} \<in> {x' \<in> dom p. x' \<le> x}"
    using defined_interval_of_Max_in assms(1, 2) by auto
  from this obtain y1 where "p x1 = Some y1"
    using \<open>neighbors p x = (x1, x2)\<close> unfolding neighbors_def by auto
  from assms(1) have "finite {x' \<in> dom p. x \<le> x'}" by auto
  from this have "Min {x' \<in> dom p. x \<le> x'} \<in> {x' \<in> dom p. x \<le> x'}"
    using defined_interval_of_Min_in assms(1, 2) by auto
  from this obtain y2 where "p x2 = Some y2"
    using \<open>neighbors p x = (x1, x2)\<close> unfolding neighbors_def by auto
  have "x1 \<le> x" and "x \<le> x2"
    using \<open>Max {x' \<in> dom p. x' \<le> x} \<in> {x' \<in> dom p. x' \<le> x}\<close>
    using \<open>Min {x' \<in> dom p. x \<le> x'} \<in> {x' \<in> dom p. x \<le> x'}\<close>
    using \<open>neighbors p x = (x1, x2)\<close> unfolding neighbors_def by auto
  from that show thesis
    using \<open>neighbors p x = (x1, x2)\<close> \<open>p x1 = Some y1\<close> \<open>p x2 = Some y2\<close> \<open>x1 \<le> x\<close> \<open>x \<le> x2\<close> by blast
qed

subsection \<open>Boundedness\<close>

text \<open> The linear approximation of a partial function with finite domain is limited by the maximum of
  the values of the partial function from above. \<close>
lemma upper_bound:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  shows "linear_approximation p x \<le> Max (ran p)"
proof -
  have "finite (ran p)"
    using assms(1) by (simp add: finite_ran)
  from assms obtain x1 y1 x2 y2 where
    "neighbors p x = (x1, x2)" and "p x1 = Some y1" and "p x2 = Some y2"
    and "x1 \<le> x" and "x \<le> x2"
    using neighbors_dest[of p x] by metis
  from this have "linear_approximation p x = linear (x1, y1) (x2, y2) x"
    unfolding linear_approximation_def by simp
  also have "\<dots> \<le> max y1 y2"
    using \<open>x1 \<le> x\<close> \<open>x \<le> x2\<close> by (simp add: linear_upper_bound)
  also have "\<dots> \<le> Max (ran p)"
    using Max_ge \<open>finite (ran p)\<close> \<open>p x1 = Some y1\<close> \<open>p x2 = Some y2\<close> ranI by fastforce
  finally show ?thesis .
qed

text \<open> The linear approximation of a partial function with finite domain is limited by the minimum of
  the values of the partial function from below. \<close>
lemma lower_bound:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  shows "Min (ran p) \<le> linear_approximation p x"
proof -
  have "finite (ran p)"
    using assms(1) by (simp add: finite_ran)
  from assms obtain x1 y1 x2 y2 where
    "neighbors p x = (x1, x2)" and "p x1 = Some y1" and "p x2 = Some y2"
    and "x1 \<le> x" and "x \<le> x2"
    using neighbors_dest[of p x] by metis
  have "Min (ran p) \<le> min y1 y2"
    using Min_le \<open>finite (ran p)\<close> \<open>p x1 = Some y1\<close> \<open>p x2 = Some y2\<close> ranI by fastforce
  also have "\<dots> \<le> linear (x1, y1) (x2, y2) x"
    using \<open>x1 \<le> x\<close> \<open>x \<le> x2\<close> by (simp add: linear_lower_bound)
  also have "\<dots> = linear_approximation p x"
    unfolding linear_approximation_def
    using \<open>neighbors p x = (x1, x2)\<close> \<open>p x1 = Some y1\<close> \<open>p x2 = Some y2\<close> by simp
  finally show ?thesis .
qed

subsection \<open>Monotonicity\<close>

text \<open> If a partial function has finite domain and is monotonically increasing for the values where
  it is defined, then its linear approximation is monotonically increasing.\<close>
lemma linear_approximation_monotonic:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p" "x' \<in> defined_interval_of p"
  assumes "\<forall>x x' y y'. x \<le> x' \<and> p x = Some y \<and> p x' = Some y' \<longrightarrow> y \<le> y'"
  assumes "x \<le> x'"
  shows "linear_approximation p x \<le> linear_approximation p x'"
proof -
  from assms(1,2,5) obtain x1 y1 x2 y2
    where neighbors_x: "neighbors p x = (x1, x2)" "p x1 = Some y1" "p x2 = Some y2"
    and "x1 \<le> x" and "x \<le> x2"
    using neighbors_dest[of p x] by metis
  from assms(1,3,5) obtain x1' y1' x2' y2'
    where neighbors_x': "neighbors p x' = (x1', x2')" "p x1' = Some y1'" "p x2' = Some y2'"
    and "x1' \<le> x'" and "x' \<le> x2'"
    using neighbors_dest[of p x'] by metis
  have "max y1 y2 = y2"
    using \<open>x \<le> x2\<close> \<open>x1 \<le> x\<close> assms(4) neighbors_x(2) neighbors_x(3)
    by (meson dual_order.trans max_absorb2)
  have "min y1' y2' = y1'"
    using \<open>x' \<le> x2'\<close> \<open>x1' \<le> x'\<close> assms(4) neighbors_x'(2) neighbors_x'(3)
    by (metis dual_order.trans min.order_iff)
  from \<open>x \<le> x'\<close> have "(x1 = x1' \<and> x2 = x2') \<or> x2 \<le> x1'"
    using neighbors_cases[OF assms(1, 2, 3)]
    by (simp add: neighbors_x'(1) neighbors_x(1))
  from neighbors_x have "linear_approximation p x = linear (x1, y1) (x2, y2) x"
    unfolding linear_approximation_def by simp
  also from \<open>_ \<or> _\<close> have "linear (x1, y1) (x2, y2) x \<le> linear (x1', y1') (x2', y2') x'"
  proof
    assume a: "x1 = x1' \<and> x2 = x2'"
    from this have b: "y1 = y1' \<and> y2 = y2'"
      using neighbors_x'(2) neighbors_x'(3) neighbors_x(2) neighbors_x(3) by auto
    from \<open>max y1 y2 = y2\<close> have "y1 \<le> y2" by simp
    from a b this \<open>x \<le> x2\<close> \<open>x1 \<le> x\<close> \<open>x' \<le> x2'\<close> show ?thesis
      using linear_monotonic assms(5) by (metis (no_types, lifting) dual_order.trans eq_iff not_le)
  next
    assume "x2 \<le> x1'"
    have "linear (x1, y1) (x2, y2) x \<le> y2"
      using \<open>max y1 y2 = y2\<close> by (metis \<open>x \<le> x2\<close> \<open>x1 \<le> x\<close> linear_upper_bound)
    also from \<open>x2 \<le> x1'\<close> have "y2 \<le> y1'"
      using \<open>p x1' = Some y1'\<close> \<open>p x2 = Some y2\<close> assms(4) by blast
    also have "y1' \<le> linear (x1', y1') (x2', y2') x'"
      using \<open>x' \<le> x2'\<close> \<open>x1' \<le> x'\<close> \<open>min y1' y2' = y1'\<close> by (metis linear_lower_bound)
    finally show ?thesis .
  qed
  also have "linear (x1', y1') (x2', y2') x' = linear_approximation p x'"
    unfolding linear_approximation_def
    using neighbors_x' by simp
  finally show ?thesis .
qed

subsection \<open>Scalar multiplication\<close>

text \<open> Multiplying a partial function by a scalar does not change the neighbors. \<close>
lemma neighbors_scale_invariant:
  shows "neighbors (\<lambda>x. map_option (\<lambda>y. (c * y)) (p x)) x = neighbors p x"
  using neighbors_def by (simp add: domIff)

text \<open> Linear approximation of a partial function is linear with respect to multiplication. \<close>
lemma linear_approximation_scale:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  shows "linear_approximation (\<lambda>x. map_option (\<lambda>y. c * y) (p x)) x = c * linear_approximation p x"
proof -
  obtain x1 y1 x2 y2 where "neighbors p x = (x1, x2)" and "p x1 = Some y1" and "p x2 = Some y2"
    using assms neighbors_dest[of p x] by (metis (no_types, lifting))
  have "linear_approximation (\<lambda>x. map_option (\<lambda>y. c * y) (p x)) x = linear (x1, c * the (p x1)) (x2, c * the (p x2)) x"
    using \<open>neighbors p x = (x1, x2)\<close> \<open>p x1 = Some y1\<close> \<open>p x2 = Some y2\<close>
    unfolding linear_approximation_def by (simp add: neighbors_scale_invariant)
  also have "\<dots> = c * linear_approximation p x"
    unfolding linear_approximation_def
    using \<open>neighbors p x = (x1, x2)\<close> by (simp add: linear_scale)
  finally show ?thesis .
qed

subsection \<open>Lipschitz\<close>

text \<open> If for a partial function p there is no defined value between x and x' then
  the neighbors of x and x' are the same. \<close>
lemma neighbors_eq:
  assumes "x \<le> x'"
  assumes "\<forall>x''. x \<le> x'' \<and> x'' \<le> x' \<longrightarrow> p x'' = None"
  shows "neighbors p x = neighbors p x'"
proof -
  have "{x'' \<in> dom p. x'' \<le> x} = {x'' \<in> dom p. x'' \<le> x'}"
    using \<open>x \<le> x'\<close> \<open>\<forall>x''. x \<le> x'' \<and> x'' \<le> x' \<longrightarrow> p x'' = None\<close> linear by force
  moreover have "{x'' \<in> dom p. x \<le> x''} = {x'' \<in> dom p. x' \<le> x''}"
    using \<open>x \<le> x'\<close> \<open>\<forall>x''. x \<le> x'' \<and> x'' \<le> x' \<longrightarrow> p x'' = None\<close> by auto
  ultimately show ?thesis
    unfolding neighbors_def by simp
qed

text \<open> For a partial function with finite domain, the neighbors of a defined value are the point itself. \<close>
lemma defined_point_neighbors_eq:
  assumes "finite (dom p)"
  assumes "x \<in> dom p"
  shows "neighbors p x = (x, x)"
proof -
  from assms have "Max {x' \<in> dom p. x' \<le> x} = x"
    by (metis (mono_tags, lifting) Max_eqI infinite_super mem_Collect_eq order_refl subsetI)
  moreover from assms have "Min {x' \<in> dom p. x \<le> x'} = x"
    by (metis (mono_tags, lifting) Min_eqI infinite_super mem_Collect_eq order_refl subsetI)
  ultimately show ?thesis
    unfolding neighbors_def by auto
qed

text \<open> finite' defines in an inductive way on ordered sets, starting from the empty set inserting
  elements smaller than all elements to a set. \<close>
inductive finite'
where
  "finite' {}"
| "finite' A \<Longrightarrow> a \<notin> A \<Longrightarrow> a < Min A \<or> A = {} \<Longrightarrow> finite' (insert a A)"

text \<open> On sets with a linear order the concept finite' is equivalent to the standard finite concept.\<close>
thm finite'.induct
lemma finite_eq_finite':
  fixes X :: "('a :: linorder) set"
  shows "finite X \<longleftrightarrow> finite' X"
proof
  show "finite X" if "finite' X"
    using that by (induct rule: finite'.induct) auto
  find_theorems "finite" name: induct
  thm finite_remove_induct
  show "finite' X" if "finite X" using that
  proof (induct rule: finite_remove_induct)
    show "finite' {}" by (rule finite'.intros)
  next
    case (remove A)
    let ?a' = "Min A"
    let ?A' = "A - {?a'}"
    from \<open>finite A\<close> \<open>A \<noteq> {}\<close> have "?a' \<in> A" by simp
    from \<open>?a' \<in> A\<close> have "insert ?a' ?A' = A" by auto
    from \<open>?a' \<in> A\<close> remove(4) have "finite' ?A'" by simp
    moreover have "?a' \<notin> ?A'" by blast
    moreover have "?a' < Min ?A' \<or> ?A' = {}"
      by (metis Min.remove Min_in \<open>Min A \<in> A\<close> calculation(2) finite_Diff min.strict_order_iff remove.hyps(1))
    ultimately have "finite' (insert ?a' ?A')" by (rule finite'.intros)
    from this \<open>insert ?a' ?A' = A\<close> show ?case by simp
  qed
qed

text \<open> On finite sets with minima, there is an induction principle based on adding elements smaller
   than the minimum. \<close>
lemma finite_Min_induct [consumes 1, case_names empty insert]:
  "finite X \<Longrightarrow> P {} \<Longrightarrow> (\<And>A a. finite A \<Longrightarrow> P A \<Longrightarrow> a \<notin> A \<Longrightarrow> a < Min A \<or> A = {} \<Longrightarrow> P (insert a A)) \<Longrightarrow> P X"
unfolding finite_eq_finite' by (rule finite'.induct)

text \<open> If a property holds for a two place partial function in all four cases depending on whether
  the arguments are in the domain or not, the property holds in general. \<close>
lemma four_cases:
  assumes "x \<in> dom p \<and> x' \<in> dom p \<Longrightarrow> P p x x'"
  assumes "x \<in> dom p \<and> x' \<notin> dom p \<Longrightarrow> P p x x'"
  assumes "x \<notin> dom p \<and> x' \<in> dom p \<Longrightarrow> P p x x'"
  assumes "x \<notin> dom p \<and> x' \<notin> dom p \<Longrightarrow> P p x x'"
  shows "P p x x'"
using assms(1) assms(2) assms(3) assms(4) by blast

text \<open> The linear approximation of a partial function p is Lipschitz continuous in case that there is
  no defined element between x and x'. \<close>
lemma empty_case:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p"
  assumes "x' \<in> defined_interval_of p"
  assumes "x \<le> x'"
  assumes "\<forall>x''. x < x'' \<and> x'' < x' \<longrightarrow> p x'' = None"
  shows "\<exists>K. \<bar>linear_approximation p x' - linear_approximation p x\<bar> \<le> K * \<bar>x' - x\<bar>"
proof cases
  assume "x = x'"
  from this show ?thesis by simp
next
  assume "x \<noteq> x'"
  text \<open> cases: TODO: check if we can reduce it to at most two cases, when we look at the larger proof!
     and hence refine the assumption! \<close>
  show ?thesis
  proof (rule four_cases[of x p x'])
    assume a: "x \<in> dom p \<and> x' \<in> dom p"
    from this \<open>finite _\<close> have 1: "neighbors p x = (x, x)"
      by (simp add: defined_point_neighbors_eq)
    from a \<open>finite _\<close> have "neighbors p x' = (x', x')"
      by (simp add: defined_point_neighbors_eq)
    from 1 this show ?thesis
      unfolding linear_approximation_def apply simp
      apply (simp add: linear_first)
      by (metis abs_ge_self abs_minus_commute abs_of_nonneg assms(4) diff_ge_0_iff_ge mult.commute nonzero_mult_div_cancel_left right_minus_eq times_divide_eq_right)
  next
    assume "x \<in> dom p \<and> x' \<notin> dom p"
    from assms obtain x1 y1 x2 y2 where
      n: "neighbors p x' = (x1, x2)" and 1: "p x1 = Some y1" and 2: "p x2 = Some y2"
      and "x1 \<le> x'" and "x' \<le> x2"
      using neighbors_dest[of p x'] by metis
    have "x = x1"
      using \<open>x \<in> dom p \<and> x' \<notin> dom p\<close> assms
      by (smt "1" \<open>x1 \<le> x'\<close> defined_point_neighbors_eq domI domIff n neighbors_cases prod.sel(1) prod.sel(2))
    from this n 1 2 \<open>x \<in> dom p \<and> _\<close> \<open>finite _\<close> show ?thesis
      unfolding linear_approximation_def
      apply (simp add: defined_point_neighbors_eq linear_first)
      by (metis (no_types, hide_lams) abs_eq_0 add_diff_cancel_left' cancel_comm_monoid_add_class.diff_cancel diff_diff_eq2 mult.commute nonzero_mult_div_cancel_left order_refl times_divide_eq_right)
  next
    assume "x \<notin> dom p \<and> x' \<in> dom p"
    from assms obtain x1 y1 x2 y2 where
      n: "neighbors p x = (x1, x2)" and 1: "p x1 = Some y1" and 2: "p x2 = Some y2"
      and "x1 \<le> x" and "x \<le> x2"
      using neighbors_dest[of p x] by metis
    have "x' = x2"
      by (smt \<open>x \<notin> dom p \<and> x' \<in> dom p\<close> assms defined_point_neighbors_eq domI domIff fst_conv n neighbors_cases neighbors_dest snd_conv)
    from this n 1 2 \<open>_ \<and> _\<close> \<open>finite _\<close> show ?thesis
      unfolding linear_approximation_def
      apply (simp add: defined_point_neighbors_eq linear_first)
      by (metis (no_types, hide_lams) abs_eq_0 add_diff_cancel_left' cancel_comm_monoid_add_class.diff_cancel diff_diff_eq2 mult.commute nonzero_mult_div_cancel_left order_refl times_divide_eq_right)
  next
    assume a: "x \<notin> dom p \<and> x' \<notin> dom p"
    from assms obtain x1 y1 x2 y2 where
      "neighbors p x = (x1, x2)" and "p x1 = Some y1" and "p x2 = Some y2"
      and "x1 \<le> x" and "x \<le> x2"
      using neighbors_dest[of p x] by metis
    have n: "neighbors p x' = (x1, x2)"
      using neighbors_eq assms(5) a
      by (metis \<open>neighbors p x = (x1, x2)\<close> assms(4) domIff less_eq_real_def)
    from this have "x' \<le> x2"
      using assms(1) assms(3) n neighbors_dest by force
    from \<open>x \<noteq> x'\<close> \<open>x1 \<le> x\<close> \<open>x \<le> x'\<close> \<open>x' \<le> x2\<close> have "x1 < x2" by linarith
    have "linear_approximation p x = linear (x1, y1) (x2, y2) x"
      using \<open>neighbors p x = (x1, x2)\<close> \<open>p x1 = _\<close> \<open>p x2 = _\<close>
      unfolding linear_approximation_def by simp
    moreover have "linear_approximation p x' = linear (x1, y1) (x2, y2) x'"
    proof -
      from n \<open>p x1 = _\<close> \<open>p x2 = _\<close> show ?thesis
        unfolding linear_approximation_def apply auto done
    qed
    ultimately show "\<exists>K. \<bar>linear_approximation p x' - linear_approximation p x\<bar> \<le> K * \<bar>x' - x\<bar>"
      by (metis linear_Lipschitz order_refl)
  qed
qed

text \<open> The linear approximation of a partial function with finite domain is Lipschitz continuous on
  the defined interval. \<close>
lemma linear_approximation_Lipschitz:
  assumes "finite (dom p)"
  assumes "x \<in> defined_interval_of p" "x' \<in> defined_interval_of p"
  shows "\<exists>K. abs (linear_approximation p x' - linear_approximation p x) \<le> K * abs (x' - x)"
proof -
  { fix x x' :: real
  (*assume with loss of generality *)
    assume "x \<le> x'"
  assume "x \<in> defined_interval_of p"
  assume "x' \<in> defined_interval_of p"
  have "finite {x''. \<exists>y. p x'' = Some y \<and> x < x'' \<and> x'' \<le> x'}"
    using \<open>finite (dom p)\<close>
    by (simp add: dom_def)
  { fix A
    have "finite A \<Longrightarrow> x \<le> x' \<Longrightarrow> x \<in> defined_interval_of p \<Longrightarrow> {x''. \<exists>y. p x'' = Some y \<and> x < x'' \<and> x'' \<le> x'} = A \<longrightarrow>
      (\<exists>K. abs (linear_approximation p x' - linear_approximation p x) \<le> K * abs (x' - x))"
    proof (induct A arbitrary: x rule: finite_Min_induct)
      case empty
      {
        assume "{x''. \<exists>y. p x'' = Some y \<and> x < x'' \<and> x'' \<le> x'} = {}"
        from this have "\<forall>x''. x < x'' \<and> x'' \<le> x' \<longrightarrow> p x'' = None" by auto
        from this have "\<exists>K. \<bar>linear_approximation p x' - linear_approximation p x\<bar> \<le> K * \<bar>x' - x\<bar>"
          using \<open>x \<le> x'\<close> empty_case \<open>finite (dom p)\<close> \<open>x \<in> defined_interval_of p\<close> \<open>x' \<in> defined_interval_of p\<close>
          by simp
      }
      then show ?case by auto
    next
      case (insert A a)
      {
        assume a: "{x''. \<exists>y. p x'' = Some y \<and> x < x'' \<and> x'' \<le> x'} = insert a A"
        from this have "x < a" and "a \<le> x'" by blast+
        have "a \<in> defined_interval_of p"
          using \<open>a \<le> x'\<close> \<open>x < a\<close> \<open>x' \<in> defined_interval_of p\<close> defined_interval_of_def insert.prems(2) by auto
        have "{x''. \<exists>y. p x'' = Some y \<and> a < x'' \<and> x'' \<le> x'} = A"
          using insert.hyps(1,3,4) a \<open>x < a\<close> Min.coboundedI by fastforce
        (* possible improvement: replace linear_approximation p by an local abbreviation for shorter proofs *)
        from insert.hyps(2) \<open>a \<le> x'\<close> \<open>a \<in> _\<close> this obtain K where
          1: "\<bar>linear_approximation p x' - linear_approximation p a\<bar> \<le> K * \<bar>x' - a\<bar>" by auto
        have "{x''. \<exists>y. p x'' = Some y \<and> x < x'' \<and> x'' < a} = {}"
        proof -
          have "p x'' = None" if "x < x'' \<and> x'' < a" for x''
          proof (rule ccontr)
            assume "p x'' \<noteq> None"
            from this have "x'' \<in> insert a A"
              using \<open>a \<le> x'\<close> a that by fastforce
            from this that show False
              using insert.hyps(1,3,4) Min_gr_iff by fastforce
          qed
          from this show ?thesis by auto
        qed
        from this have "\<forall>x''. x < x'' \<and> x'' < a \<longrightarrow> p x'' = None" by auto
        from this obtain K' where 2: "\<bar>linear_approximation p a - linear_approximation p x\<bar> \<le> K' * \<bar>a - x\<bar>"
          using empty_case \<open>x < a\<close> \<open>finite (dom p)\<close> \<open>x \<in> _\<close> \<open>a \<in> _\<close> by fastforce
        have "\<bar>linear_approximation p x' - linear_approximation p x\<bar> \<le>
          \<bar>linear_approximation p x' - linear_approximation p a\<bar> + \<bar>linear_approximation p a - linear_approximation p x\<bar>"
          by auto
        also have "\<dots> \<le> K * \<bar>x' - a\<bar> + K' * \<bar>a - x\<bar>" using 1 2 by simp
        also have "\<dots> \<le> max K K' * \<bar>x' - a\<bar> + max K K' * \<bar>a - x\<bar>"
          by (simp add: add_mono_thms_linordered_semiring(1) mult_le_cancel_right)
        also have "\<dots> \<le> max K K' * \<bar>x' - x\<bar>" (* todo: simpler proof or lemma *)
        proof -
          have f1: "\<bar>a - x'\<bar> = x' - a"
            by (simp add: \<open>a \<le> x'\<close>)
          have "\<bar>x' - x\<bar> = x' - x"
            by (simp add: insert.prems)
          then show ?thesis
            using f1
            by (metis (no_types) \<open>x < a\<close> abs_minus_commute abs_of_nonneg add.right_neutral add_diff_eq cancel_comm_monoid_add_class.diff_cancel diff_add_eq diff_ge_0_iff_ge distrib_left dual_order.strict_implies_order order_refl)
        qed
        finally have "\<exists>K. \<bar>linear_approximation p x' - linear_approximation p x\<bar> \<le> K * \<bar>x' - x\<bar>" by auto
      }
      then show ?case by auto
    qed
  }
  from this have "\<exists>K. \<bar>linear_approximation p x' - linear_approximation p x\<bar> \<le> K * \<bar>x' - x\<bar>"
    using \<open>finite {x''. \<exists>y. p x'' = Some y \<and> x < x'' \<and> x'' \<le> x'}\<close> \<open>x \<le> x'\<close> \<open>x \<in> _\<close> by blast
  } note derived_case = this
  show ?thesis
  proof cases
    assume "x \<le> x'"
    from this derived_case \<open>x \<in> _\<close> \<open>x' \<in> _\<close> show ?thesis by simp
  next
    assume "\<not> x \<le> x'"
    from this have "x' \<le> x" by simp
    from this derived_case[of x' x] \<open>x \<in> _\<close> \<open>x' \<in> _\<close> show ?thesis by (simp add: abs_minus_commute)
  qed
qed

end


theory Sorting_Log2
imports Sorting_Setup
begin

section \<open>Count Leading Zeroes and Log2\<close>
(* TODO: Define semantics of llvm.ctlz intrinsic! *)

subsection \<open>Explicit Implementation by Loop\<close>

definition word_clz' :: "'a::len word \<Rightarrow> nat" where
  "word_clz' x \<equiv> if x=0 then 0 else word_clz x"

lemma word_clz'_eq: "x\<noteq>0 \<Longrightarrow> word_clz' x = word_clz x"
  by (simp add: word_clz'_def)

lemma of_bl_eqZ:
  "\<lbrakk> length xs = LENGTH ('a::len) \<rbrakk> \<Longrightarrow> (of_bl xs :: 'a word) = 0 \<longleftrightarrow> (xs = replicate LENGTH('a) False)"
  apply auto
  by (metis to_bl_0 to_bl_use_of_bl word_bl_Rep')

lemma word_clz'_rec: "word_clz' x = (if x <=s 0 then 0 else 1 + word_clz' (x << 1))"
  (* TODO: Clean up this mess! *)
  apply (clarsimp simp: word_clz'_def word_clz_def)
  apply (cases "to_bl x")
  apply auto
  apply (simp add: word_msb_alt word_sle_msb_le)
  apply (simp add: word_msb_alt word_sle_msb_le)
  apply (simp add: word_msb_alt word_sle_msb_le shiftl_bl)
  apply (subst (asm) of_bl_eqZ)
  apply (auto) []
  apply (metis length_Cons word_bl_Rep')
  apply (metis length_append_singleton length_replicate replicate_Suc replicate_append_same rotate1_rl' to_bl_0 word_bl.Rep_eqD)
  apply (simp add: word_msb_alt word_sle_msb_le)
  apply (simp add: bl_shiftl shiftl_bl)
  apply (subst (asm) of_bl_eqZ)
  apply auto
  apply (metis length_Cons word_bl_Rep')
  apply (subst word_bl.Abs_inverse)
  apply auto
  apply (metis length_Cons word_bl_Rep')
  apply (subgoal_tac "True\<in>set list")
  apply simp
  by (simp add: eq_zero_set_bl)

lemma word_clz'_rec2: "word_clz' x = (if 0 <s x then 1 + word_clz' (x << 1) else 0)"
  by (meson signed.not_le word_clz'_rec)

lemma word_clz'_simps2:
  "0 <s x \<Longrightarrow> word_clz' x = 1 + word_clz' (x << 1)"
  "\<not>(0 <s x) \<Longrightarrow> word_clz' x = 0"
  using word_clz'_rec2 by metis+

definition word_clz2 :: "'a::len2 word \<Rightarrow> nat nres"
  where "word_clz2 x \<equiv> do {
    (c,_) \<leftarrow> WHILET (\<lambda>(c,x). 0 <s x) (\<lambda>(c,x). do {
      ASSERT (c + 1 < max_snat LENGTH('a));
      RETURN (c+1,x << 1)
    }) (0,x);
    RETURN c
  }"

lemma word_clz'_fits_snat: "word_clz' (x::'a::len2 word) < max_snat LENGTH('a)"
  unfolding word_clz'_def using word_clz_nonzero_max[of x]
  apply (auto simp: word_size max_snat_def)
  by (meson le_def n_less_equal_power_2 nat_le_Suc_less_imp order_trans)

lemma word_clz2_refine: "word_clz2 x\<^sub>0 \<le> RETURN (word_clz' x\<^sub>0)"
  unfolding word_clz2_def
  supply [refine_vcg] = WHILET_rule[
    where I="\<lambda>(c,x). word_clz' x\<^sub>0 = c + word_clz' x"
      and R="measure (word_clz' o snd)"
  ]
  apply refine_vcg
  using word_clz'_fits_snat[of x\<^sub>0]
  apply (auto simp: word_clz'_simps2)
  done

lemma word_clz2_refine': "(word_clz2, RETURN o word_clz') \<in> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  by (auto intro!: nres_relI simp: word_clz2_refine)

sepref_def word_clz'_impl is word_clz2 :: "(word_assn' TYPE('a::len2))\<^sup>k \<rightarrow>\<^sub>a snat_assn' TYPE('a)"
  unfolding word_clz2_def
  apply (rewrite at "(_ + \<hole>,_)" snat_const_fold[where 'a='a])
  apply (rewrite at "(_ << \<hole>)" snat_const_fold[where 'a='a])
  apply (rewrite at "(\<hole>,_)" snat_const_fold[where 'a='a])
  by sepref

export_llvm "word_clz'_impl :: 64 word \<Rightarrow> 64 word llM"

sepref_register word_clz word_clz'
lemmas [sepref_fr_rules] = word_clz'_impl.refine[FCOMP word_clz2_refine']

lemma word_clz_alt: "word_clz x = (if x=0 then size x else word_clz' x)"
  unfolding word_clz'_def by (auto simp: word_size)

sepref_def word_clz_impl
  is "RETURN o word_clz" :: "[\<lambda>_. LENGTH('a)>2]\<^sub>a (word_assn' TYPE('a::len2))\<^sup>k \<rightarrow> snat_assn' TYPE('a)"
  unfolding word_clz_alt
  by sepref

export_llvm "word_clz_impl :: 64 word \<Rightarrow> _"

lemma word_clz_nonzero_max': "x\<noteq>0 \<Longrightarrow> word_clz (x::'a::len2 word) < LENGTH('a)"
  using word_clz_nonzero_max[of x] unfolding word_size
  by simp

sepref_def word_log2_impl is
  "RETURN o word_log2" :: "[\<lambda>x. x>0 \<and> LENGTH('a)>2]\<^sub>a (word_assn' TYPE('a::len2))\<^sup>k \<rightarrow> snat_assn' TYPE('a)"
  unfolding word_log2_def word_size
  apply (annot_snat_const "TYPE('a)")
  supply [simp] = word_clz_nonzero_max'
  by sepref

export_llvm "word_log2_impl :: 64 word \<Rightarrow> _"

subsection \<open>Connection with \<^const>\<open>Discrete.log\<close>\<close>

lemma discrete_log_ltI: (* TODO: Check how precise this bound is! *)
  assumes "n\<noteq>0" "N\<noteq>0" "n<2^N"
  shows "Discrete.log n < N"
  using assms
  by (metis Discrete.log_le_iff leD linorder_neqE_nat log_exp log_exp2_le order_less_le zero_order(3))

lemma unat_x_div_2_conv:
  fixes x y :: "'a::len2 word"
  shows "unat x div 2 = unat y \<longleftrightarrow> y = x div 2"
proof -
  have A: "2 = unat (2::'a word)"
    by (metis le_less_trans len2_simps(2) n_less_equal_power_2 of_nat_numeral unat_of_nat_len)

  have B: "unat x div 2 = unat (x div 2)"
    unfolding A
    by (simp add: unat_div)

  show ?thesis
    by (auto simp: B dest: word_unat.Rep_eqD)

qed

lemma take_size_m1_to_bl:
  fixes x :: "'a::len word"
  shows "take (size x - Suc 0) (to_bl x) = butlast (to_bl x)"
  by (simp add: butlast_conv_take word_size_bl)

lemma takeWhile_butlast_eqI: "\<lbrakk>x\<in>set xs; \<not>P x\<rbrakk> \<Longrightarrow> takeWhile P (butlast xs) = takeWhile P xs"
  by (metis append_Nil2 butlast.simps(2) butlast_append list.simps(3) split_list_last takeWhile_tail)

lemma takeWhile_butlast_eqI': "\<lbrakk>\<exists>x\<in>set xs. \<not>P x\<rbrakk> \<Longrightarrow> takeWhile P (butlast xs) = takeWhile P xs"
  by (metis append_Nil2 butlast.simps(2) butlast_append list.simps(3) split_list_last takeWhile_tail)

lemma ex_True_in_set_conv: "(\<exists>x\<in>S. x) \<longleftrightarrow> True\<in>S" by auto

lemma word_clz_rec:
  fixes x :: "'a::len2 word"
  shows "2\<le>x \<Longrightarrow> word_clz (x div 2) = word_clz x + 1"
  unfolding word_clz_def shiftr1_is_div_2[symmetric]
  apply (auto simp: bl_shiftr word_size)
  apply (subst bl_shiftr)
  apply (simp add: word_size Suc_leI)
  apply (auto simp: take_size_m1_to_bl)
  apply (subst takeWhile_butlast_eqI')
  apply (simp_all add: ex_True_in_set_conv)
  apply (rule ccontr)
  apply (simp only: eq_zero_set_bl[symmetric])
  by (metis le_unat_uoi len2_simps(2) n_less_equal_power_2 of_nat_numeral unat_0 unat_of_nat_len word_le_0_iff zero_neq_numeral)

lemma word_clz_ge2_max: "2\<le>(x::'a::len2 word) \<Longrightarrow> word_clz x + 1 < size x"
  apply (simp only: word_clz_rec[symmetric] word_size)
  apply (rule word_clz_nonzero_max[of "x div 2", unfolded word_size])
  by (smt One_nat_def Suc_pred add.left_neutral add.right_neutral add_diff_cancel_left' add_diff_cancel_right' add_left_cancel diff_Suc_Suc div_less div_of_0_id div_self lessI less_eq_Suc_le less_one linorder_neqE_nat linorder_not_le mult.right_neutral not_numeral_le_zero numeral_2_eq_2 numeral_One numeral_le_one_iff order_less_le overflow_safe_hbound_check pos2 power.simps(1) power.simps(2) semiring_norm(69) unat_0 unat_div unat_eq_zero unat_gt_0 unat_x_div_2_conv word_clz_rec word_gt_0_no word_le_nat_alt zero_less_one zero_neq_one)

lemma word_log2_rec:
  fixes x :: "'a::len2 word" shows "2\<le>x \<Longrightarrow> word_log2 x = Suc (word_log2 (x div 2))"
  apply (auto simp: word_log2_def word_size word_clz_rec)
  using word_clz_ge2_max[unfolded word_size, of x]
  by auto

lemma word_log2_is_discrete_log:
  fixes x :: "'a::len2 word"
  shows "word_log2 x = Discrete.log (unat x)"
  apply (cases "x=0")
  apply simp
  subgoal proof -
    assume "x \<noteq> 0"
    hence "unat x > 0" by (simp add: unat_gt_0)
    then show ?thesis
    proof (induction "unat x" arbitrary: x rule: log_induct)
      case one
      hence "x=1" using word_unat_Rep_inject1 by auto
      then show ?case
        unfolding word_log2_def
        by (auto simp: word_size)

    next
      case double

      from double.hyps(2) have "Discrete.log (unat x div 2) = word_log2 (x div 2)"
        by (metis unat_x_div_2_conv)

      then show ?case
        apply (subst log_rec, simp add: \<open>2 \<le> unat x\<close>)
        apply simp
        apply (subst word_log2_rec)
        apply auto
        using double.hyps(1) le_unat_uoi word_le_nat_alt by fastforce

    qed
  qed
  done

lemma word_log2_refine_unat: "(word_log2, Discrete.log) \<in> unat_rel' TYPE('a::len2) \<rightarrow> nat_rel"
  using word_log2_is_discrete_log
  by (fastforce simp: unat_rel_def unat.rel_def in_br_conv)

lemma word_log2_refine_snat: "(word_log2, Discrete.log) \<in> snat_rel' TYPE('a::len2) \<rightarrow> nat_rel"
  using word_log2_is_discrete_log
  by (fastforce simp: snat_rel_def snat.rel_def in_br_conv snat_eq_unat)

sepref_register Discrete.log

lemmas discrete_log_unat_hnr[sepref_fr_rules] = word_log2_impl.refine[FCOMP word_log2_refine_unat]
lemmas discrete_log_snat_hnr[sepref_fr_rules] = word_log2_impl.refine[FCOMP word_log2_refine_snat]

end


(*  Title:      HOL/HOLCF/Product_Cpo.thy
    Author:     Franz Regensburger
*)

section {* The cpo of cartesian products *}

theory Product_Cpo
imports Adm
begin

default_sort cpo

subsection {* Unit type is a pcpo *}

instantiation unit :: discrete_cpo
begin

definition
  below_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<longleftrightarrow> True"

instance proof
qed simp

end

instance unit :: pcpo
by intro_classes simp

subsection {* Product type is a partial order *}

instantiation prod :: (below, below) below
begin

definition
  below_prod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"

instance ..
end

instance prod :: (po, po) po
proof
  fix x :: "'a \<times> 'b"
  show "x \<sqsubseteq> x"
    unfolding below_prod_def by simp
next
  fix x y :: "'a \<times> 'b"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
    unfolding below_prod_def prod_eq_iff
    by (fast intro: below_antisym)
next
  fix x y z :: "'a \<times> 'b"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
    unfolding below_prod_def
    by (fast intro: below_trans)
qed

subsection {* Monotonicity of \emph{Pair}, \emph{fst}, \emph{snd} *}

lemma prod_belowI: "\<lbrakk>fst p \<sqsubseteq> fst q; snd p \<sqsubseteq> snd q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q"
unfolding below_prod_def by simp

lemma Pair_below_iff [simp]: "(a, b) \<sqsubseteq> (c, d) \<longleftrightarrow> a \<sqsubseteq> c \<and> b \<sqsubseteq> d"
unfolding below_prod_def by simp

text {* Pair @{text "(_,_)"}  is monotone in both arguments *}

lemma monofun_pair1: "monofun (\<lambda>x. (x, y))"
by (simp add: monofun_def)

lemma monofun_pair2: "monofun (\<lambda>y. (x, y))"
by (simp add: monofun_def)

lemma monofun_pair:
  "\<lbrakk>x1 \<sqsubseteq> x2; y1 \<sqsubseteq> y2\<rbrakk> \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
by simp

lemma ch2ch_Pair [simp]:
  "chain X \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. (X i, Y i))"
by (rule chainI, simp add: chainE)

text {* @{term fst} and @{term snd} are monotone *}

lemma fst_monofun: "x \<sqsubseteq> y \<Longrightarrow> fst x \<sqsubseteq> fst y"
unfolding below_prod_def by simp

lemma snd_monofun: "x \<sqsubseteq> y \<Longrightarrow> snd x \<sqsubseteq> snd y"
unfolding below_prod_def by simp

lemma monofun_fst: "monofun fst"
by (simp add: monofun_def below_prod_def)

lemma monofun_snd: "monofun snd"
by (simp add: monofun_def below_prod_def)

lemmas ch2ch_fst [simp] = ch2ch_monofun [OF monofun_fst]

lemmas ch2ch_snd [simp] = ch2ch_monofun [OF monofun_snd]

lemma prod_chain_cases:
  assumes "chain Y"
  obtains A B
  where "chain A" and "chain B" and "Y = (\<lambda>i. (A i, B i))"
proof
  from `chain Y` show "chain (\<lambda>i. fst (Y i))" by (rule ch2ch_fst)
  from `chain Y` show "chain (\<lambda>i. snd (Y i))" by (rule ch2ch_snd)
  show "Y = (\<lambda>i. (fst (Y i), snd (Y i)))" by simp
qed

subsection {* Product type is a cpo *}

lemma is_lub_Pair:
  "\<lbrakk>range A <<| x; range B <<| y\<rbrakk> \<Longrightarrow> range (\<lambda>i. (A i, B i)) <<| (x, y)"
unfolding is_lub_def is_ub_def ball_simps below_prod_def by simp

lemma lub_Pair:
  "\<lbrakk>chain (A::nat \<Rightarrow> 'a::cpo); chain (B::nat \<Rightarrow> 'b::cpo)\<rbrakk>
    \<Longrightarrow> (\<Squnion>i. (A i, B i)) = (\<Squnion>i. A i, \<Squnion>i. B i)"
by (fast intro: lub_eqI is_lub_Pair elim: thelubE)

lemma is_lub_prod:
  fixes S :: "nat \<Rightarrow> ('a::cpo \<times> 'b::cpo)"
  assumes S: "chain S"
  shows "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
using S by (auto elim: prod_chain_cases simp add: is_lub_Pair cpo_lubI)

lemma lub_prod:
  "chain (S::nat \<Rightarrow> 'a::cpo \<times> 'b::cpo)
    \<Longrightarrow> (\<Squnion>i. S i) = (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
by (rule is_lub_prod [THEN lub_eqI])

instance prod :: (cpo, cpo) cpo
proof
  fix S :: "nat \<Rightarrow> ('a \<times> 'b)"
  assume "chain S"
  hence "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
    by (rule is_lub_prod)
  thus "\<exists>x. range S <<| x" ..
qed

instance prod :: (discrete_cpo, discrete_cpo) discrete_cpo
proof
  fix x y :: "'a \<times> 'b"
  show "x \<sqsubseteq> y \<longleftrightarrow> x = y"
    unfolding below_prod_def prod_eq_iff
    by simp
qed

subsection {* Product type is pointed *}

lemma minimal_prod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
by (simp add: below_prod_def)

instance prod :: (pcpo, pcpo) pcpo
by intro_classes (fast intro: minimal_prod)

lemma inst_prod_pcpo: "\<bottom> = (\<bottom>, \<bottom>)"
by (rule minimal_prod [THEN bottomI, symmetric])

lemma Pair_bottom_iff [simp]: "(x, y) = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
unfolding inst_prod_pcpo by simp

lemma fst_strict [simp]: "fst \<bottom> = \<bottom>"
unfolding inst_prod_pcpo by (rule fst_conv)

lemma snd_strict [simp]: "snd \<bottom> = \<bottom>"
unfolding inst_prod_pcpo by (rule snd_conv)

lemma Pair_strict [simp]: "(\<bottom>, \<bottom>) = \<bottom>"
by simp

lemma split_strict [simp]: "split f \<bottom> = f \<bottom> \<bottom>"
unfolding split_def by simp

subsection {* Continuity of \emph{Pair}, \emph{fst}, \emph{snd} *}

lemma cont_pair1: "cont (\<lambda>x. (x, y))"
apply (rule contI)
apply (rule is_lub_Pair)
apply (erule cpo_lubI)
apply (rule is_lub_const)
done

lemma cont_pair2: "cont (\<lambda>y. (x, y))"
apply (rule contI)
apply (rule is_lub_Pair)
apply (rule is_lub_const)
apply (erule cpo_lubI)
done

lemma cont_fst: "cont fst"
apply (rule contI)
apply (simp add: lub_prod)
apply (erule cpo_lubI [OF ch2ch_fst])
done

lemma cont_snd: "cont snd"
apply (rule contI)
apply (simp add: lub_prod)
apply (erule cpo_lubI [OF ch2ch_snd])
done

lemma cont2cont_Pair [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. (f x, g x))"
apply (rule cont_apply [OF f cont_pair1])
apply (rule cont_apply [OF g cont_pair2])
apply (rule cont_const)
done

lemmas cont2cont_fst [simp, cont2cont] = cont_compose [OF cont_fst]

lemmas cont2cont_snd [simp, cont2cont] = cont_compose [OF cont_snd]

lemma cont2cont_case_prod:
  assumes f1: "\<And>a b. cont (\<lambda>x. f x a b)"
  assumes f2: "\<And>x b. cont (\<lambda>a. f x a b)"
  assumes f3: "\<And>x a. cont (\<lambda>b. f x a b)"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. case g x of (a, b) \<Rightarrow> f x a b)"
unfolding split_def
apply (rule cont_apply [OF g])
apply (rule cont_apply [OF cont_fst f2])
apply (rule cont_apply [OF cont_snd f3])
apply (rule cont_const)
apply (rule f1)
done

lemma prod_contI:
  assumes f1: "\<And>y. cont (\<lambda>x. f (x, y))"
  assumes f2: "\<And>x. cont (\<lambda>y. f (x, y))"
  shows "cont f"
proof -
  have "cont (\<lambda>(x, y). f (x, y))"
    by (intro cont2cont_case_prod f1 f2 cont2cont)
  thus "cont f"
    by (simp only: split_eta)
qed

lemma prod_cont_iff:
  "cont f \<longleftrightarrow> (\<forall>y. cont (\<lambda>x. f (x, y))) \<and> (\<forall>x. cont (\<lambda>y. f (x, y)))"
apply safe
apply (erule cont_compose [OF _ cont_pair1])
apply (erule cont_compose [OF _ cont_pair2])
apply (simp only: prod_contI)
done

lemma cont2cont_case_prod' [simp, cont2cont]:
  assumes f: "cont (\<lambda>p. f (fst p) (fst (snd p)) (snd (snd p)))"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. case_prod (f x) (g x))"
using assms by (simp add: cont2cont_case_prod prod_cont_iff)

text {* The simple version (due to Joachim Breitner) is needed if
  either element type of the pair is not a cpo. *}

lemma cont2cont_split_simple [simp, cont2cont]:
 assumes "\<And>a b. cont (\<lambda>x. f x a b)"
 shows "cont (\<lambda>x. case p of (a, b) \<Rightarrow> f x a b)"
using assms by (cases p) auto

text {* Admissibility of predicates on product types. *}

lemma adm_case_prod [simp]:
  assumes "adm (\<lambda>x. P x (fst (f x)) (snd (f x)))"
  shows "adm (\<lambda>x. case f x of (a, b) \<Rightarrow> P x a b)"
unfolding case_prod_beta using assms .

subsection {* Compactness and chain-finiteness *}

lemma fst_below_iff: "fst (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (y, snd x)"
unfolding below_prod_def by simp

lemma snd_below_iff: "snd (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (fst x, y)"
unfolding below_prod_def by simp

lemma compact_fst: "compact x \<Longrightarrow> compact (fst x)"
by (rule compactI, simp add: fst_below_iff)

lemma compact_snd: "compact x \<Longrightarrow> compact (snd x)"
by (rule compactI, simp add: snd_below_iff)

lemma compact_Pair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (x, y)"
by (rule compactI, simp add: below_prod_def)

lemma compact_Pair_iff [simp]: "compact (x, y) \<longleftrightarrow> compact x \<and> compact y"
apply (safe intro!: compact_Pair)
apply (drule compact_fst, simp)
apply (drule compact_snd, simp)
done

instance prod :: (chfin, chfin) chfin
apply intro_classes
apply (erule compact_imp_max_in_chain)
apply (case_tac "\<Squnion>i. Y i", simp)
done

end


section {* Extending FOL by a modified version of HOL set theory *}

theory Set
imports "~~/src/FOL/FOL"
begin

declare [[eta_contract]]

typedecl 'a set
instance set :: ("term") "term" ..

consts
  Collect       :: "['a \<Rightarrow> o] \<Rightarrow> 'a set"                    (*comprehension*)
  Compl         :: "('a set) \<Rightarrow> 'a set"                     (*complement*)
  Int           :: "['a set, 'a set] \<Rightarrow> 'a set"         (infixl "Int" 70)
  Un            :: "['a set, 'a set] \<Rightarrow> 'a set"         (infixl "Un" 65)
  Union         :: "(('a set)set) \<Rightarrow> 'a set"                (*...of a set*)
  Inter         :: "(('a set)set) \<Rightarrow> 'a set"                (*...of a set*)
  UNION         :: "['a set, 'a \<Rightarrow> 'b set] \<Rightarrow> 'b set"       (*general*)
  INTER         :: "['a set, 'a \<Rightarrow> 'b set] \<Rightarrow> 'b set"       (*general*)
  Ball          :: "['a set, 'a \<Rightarrow> o] \<Rightarrow> o"                 (*bounded quants*)
  Bex           :: "['a set, 'a \<Rightarrow> o] \<Rightarrow> o"                 (*bounded quants*)
  mono          :: "['a set \<Rightarrow> 'b set] \<Rightarrow> o"                (*monotonicity*)
  mem           :: "['a, 'a set] \<Rightarrow> o"                  (infixl ":" 50) (*membership*)
  subset        :: "['a set, 'a set] \<Rightarrow> o"              (infixl "<=" 50)
  singleton     :: "'a \<Rightarrow> 'a set"                       ("{_}")
  empty         :: "'a set"                             ("{}")

syntax
  "_Coll"       :: "[idt, o] \<Rightarrow> 'a set"                 ("(1{_./ _})") (*collection*)

  (* Big Intersection / Union *)

  "_INTER"      :: "[idt, 'a set, 'b set] \<Rightarrow> 'b set"    ("(INT _:_./ _)" [0, 0, 0] 10)
  "_UNION"      :: "[idt, 'a set, 'b set] \<Rightarrow> 'b set"    ("(UN _:_./ _)" [0, 0, 0] 10)

  (* Bounded Quantifiers *)

  "_Ball"       :: "[idt, 'a set, o] \<Rightarrow> o"              ("(ALL _:_./ _)" [0, 0, 0] 10)
  "_Bex"        :: "[idt, 'a set, o] \<Rightarrow> o"              ("(EX _:_./ _)" [0, 0, 0] 10)

translations
  "{x. P}"      == "CONST Collect(\<lambda>x. P)"
  "INT x:A. B"  == "CONST INTER(A, \<lambda>x. B)"
  "UN x:A. B"   == "CONST UNION(A, \<lambda>x. B)"
  "ALL x:A. P"  == "CONST Ball(A, \<lambda>x. P)"
  "EX x:A. P"   == "CONST Bex(A, \<lambda>x. P)"

axiomatization where
  mem_Collect_iff: "(a : {x. P(x)}) \<longleftrightarrow> P(a)" and
  set_extension: "A = B \<longleftrightarrow> (ALL x. x:A \<longleftrightarrow> x:B)"

defs
  Ball_def:      "Ball(A, P)  == ALL x. x:A \<longrightarrow> P(x)"
  Bex_def:       "Bex(A, P)   == EX x. x:A \<and> P(x)"
  mono_def:      "mono(f)     == (ALL A B. A <= B \<longrightarrow> f(A) <= f(B))"
  subset_def:    "A <= B      == ALL x:A. x:B"
  singleton_def: "{a}         == {x. x=a}"
  empty_def:     "{}          == {x. False}"
  Un_def:        "A Un B      == {x. x:A | x:B}"
  Int_def:       "A Int B     == {x. x:A \<and> x:B}"
  Compl_def:     "Compl(A)    == {x. \<not>x:A}"
  INTER_def:     "INTER(A, B) == {y. ALL x:A. y: B(x)}"
  UNION_def:     "UNION(A, B) == {y. EX x:A. y: B(x)}"
  Inter_def:     "Inter(S)    == (INT x:S. x)"
  Union_def:     "Union(S)    == (UN x:S. x)"

lemma CollectI: "P(a) \<Longrightarrow> a : {x. P(x)}"
  apply (rule mem_Collect_iff [THEN iffD2])
  apply assumption
  done

lemma CollectD: "a : {x. P(x)} \<Longrightarrow> P(a)"
  apply (erule mem_Collect_iff [THEN iffD1])
  done

lemmas CollectE = CollectD [elim_format]

lemma set_ext: "(\<And>x. x:A \<longleftrightarrow> x:B) \<Longrightarrow> A = B"
  apply (rule set_extension [THEN iffD2])
  apply simp
  done

subsection {* Bounded quantifiers *}

lemma ballI: "(\<And>x. x:A \<Longrightarrow> P(x)) \<Longrightarrow> ALL x:A. P(x)"
  by (simp add: Ball_def)

lemma bspec: "\<lbrakk>ALL x:A. P(x); x:A\<rbrakk> \<Longrightarrow> P(x)"
  by (simp add: Ball_def)

lemma ballE: "\<lbrakk>ALL x:A. P(x); P(x) \<Longrightarrow> Q; \<not> x:A \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  unfolding Ball_def by blast

lemma bexI: "\<lbrakk>P(x); x:A\<rbrakk> \<Longrightarrow> EX x:A. P(x)"
  unfolding Bex_def by blast

lemma bexCI: "\<lbrakk>EX x:A. \<not>P(x) \<Longrightarrow> P(a); a:A\<rbrakk> \<Longrightarrow> EX x:A. P(x)"
  unfolding Bex_def by blast

lemma bexE: "\<lbrakk>EX x:A. P(x); \<And>x. \<lbrakk>x:A; P(x)\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  unfolding Bex_def by blast

(*Trival rewrite rule;   (! x:A.P)=P holds only if A is nonempty!*)
lemma ball_rew: "(ALL x:A. True) \<longleftrightarrow> True"
  by (blast intro: ballI)

subsection {* Congruence rules *}

lemma ball_cong:
  "\<lbrakk>A = A'; \<And>x. x:A' \<Longrightarrow> P(x) \<longleftrightarrow> P'(x)\<rbrakk> \<Longrightarrow>
    (ALL x:A. P(x)) \<longleftrightarrow> (ALL x:A'. P'(x))"
  by (blast intro: ballI elim: ballE)

lemma bex_cong:
  "\<lbrakk>A = A'; \<And>x. x:A' \<Longrightarrow> P(x) \<longleftrightarrow> P'(x)\<rbrakk> \<Longrightarrow>
    (EX x:A. P(x)) \<longleftrightarrow> (EX x:A'. P'(x))"
  by (blast intro: bexI elim: bexE)

subsection {* Rules for subsets *}

lemma subsetI: "(\<And>x. x:A \<Longrightarrow> x:B) \<Longrightarrow> A <= B"
  unfolding subset_def by (blast intro: ballI)

(*Rule in Modus Ponens style*)
lemma subsetD: "\<lbrakk>A <= B; c:A\<rbrakk> \<Longrightarrow> c:B"
  unfolding subset_def by (blast elim: ballE)

(*Classical elimination rule*)
lemma subsetCE: "\<lbrakk>A <= B; \<not>(c:A) \<Longrightarrow> P; c:B \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (blast dest: subsetD)

lemma subset_refl: "A <= A"
  by (blast intro: subsetI)

lemma subset_trans: "\<lbrakk>A <= B; B <= C\<rbrakk> \<Longrightarrow> A <= C"
  by (blast intro: subsetI dest: subsetD)

subsection {* Rules for equality *}

(*Anti-symmetry of the subset relation*)
lemma subset_antisym: "\<lbrakk>A <= B; B <= A\<rbrakk> \<Longrightarrow> A = B"
  by (blast intro: set_ext dest: subsetD)

lemmas equalityI = subset_antisym

(* Equality rules from ZF set theory -- are they appropriate here? *)
lemma equalityD1: "A = B \<Longrightarrow> A<=B"
  and equalityD2: "A = B \<Longrightarrow> B<=A"
  by (simp_all add: subset_refl)

lemma equalityE: "\<lbrakk>A = B; \<lbrakk>A <= B; B <= A\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (simp add: subset_refl)

lemma equalityCE: "\<lbrakk>A = B; \<lbrakk>c:A; c:B\<rbrakk> \<Longrightarrow> P; \<lbrakk>\<not> c:A; \<not> c:B\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (blast elim: equalityE subsetCE)

lemma trivial_set: "{x. x:A} = A"
  by (blast intro: equalityI subsetI CollectI dest: CollectD)

subsection {* Rules for binary union *}

lemma UnI1: "c:A \<Longrightarrow> c : A Un B"
  and UnI2: "c:B \<Longrightarrow> c : A Un B"
  unfolding Un_def by (blast intro: CollectI)+

(*Classical introduction rule: no commitment to A vs B*)
lemma UnCI: "(\<not>c:B \<Longrightarrow> c:A) \<Longrightarrow> c : A Un B"
  by (blast intro: UnI1 UnI2)

lemma UnE: "\<lbrakk>c : A Un B; c:A \<Longrightarrow> P; c:B \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  unfolding Un_def by (blast dest: CollectD)

subsection {* Rules for small intersection *}

lemma IntI: "\<lbrakk>c:A; c:B\<rbrakk> \<Longrightarrow> c : A Int B"
  unfolding Int_def by (blast intro: CollectI)

lemma IntD1: "c : A Int B \<Longrightarrow> c:A"
  and IntD2: "c : A Int B \<Longrightarrow> c:B"
  unfolding Int_def by (blast dest: CollectD)+

lemma IntE: "\<lbrakk>c : A Int B; \<lbrakk>c:A; c:B\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (blast dest: IntD1 IntD2)

subsection {* Rules for set complement *}

lemma ComplI: "(c:A \<Longrightarrow> False) \<Longrightarrow> c : Compl(A)"
  unfolding Compl_def by (blast intro: CollectI)

(*This form, with negated conclusion, works well with the Classical prover.
  Negated assumptions behave like formulae on the right side of the notional
  turnstile...*)
lemma ComplD: "c : Compl(A) \<Longrightarrow> \<not>c:A"
  unfolding Compl_def by (blast dest: CollectD)

lemmas ComplE = ComplD [elim_format]

subsection {* Empty sets *}

lemma empty_eq: "{x. False} = {}"
  by (simp add: empty_def)

lemma emptyD: "a : {} \<Longrightarrow> P"
  unfolding empty_def by (blast dest: CollectD)

lemmas emptyE = emptyD [elim_format]

lemma not_emptyD:
  assumes "\<not> A={}"
  shows "EX x. x:A"
proof -
  have "\<not> (EX x. x:A) \<Longrightarrow> A = {}"
    by (rule equalityI) (blast intro!: subsetI elim!: emptyD)+
  with assms show ?thesis by blast
qed

subsection {* Singleton sets *}

lemma singletonI: "a : {a}"
  unfolding singleton_def by (blast intro: CollectI)

lemma singletonD: "b : {a} \<Longrightarrow> b=a"
  unfolding singleton_def by (blast dest: CollectD)

lemmas singletonE = singletonD [elim_format]

subsection {* Unions of families *}

(*The order of the premises presupposes that A is rigid; b may be flexible*)
lemma UN_I: "\<lbrakk>a:A; b: B(a)\<rbrakk> \<Longrightarrow> b: (UN x:A. B(x))"
  unfolding UNION_def by (blast intro: bexI CollectI)

lemma UN_E: "\<lbrakk>b : (UN x:A. B(x)); \<And>x. \<lbrakk>x:A; b: B(x)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding UNION_def by (blast dest: CollectD elim: bexE)

lemma UN_cong: "\<lbrakk>A = B; \<And>x. x:B \<Longrightarrow> C(x) = D(x)\<rbrakk> \<Longrightarrow> (UN x:A. C(x)) = (UN x:B. D(x))"
  by (simp add: UNION_def cong: bex_cong)

subsection {* Intersections of families *}

lemma INT_I: "(\<And>x. x:A \<Longrightarrow> b: B(x)) \<Longrightarrow> b : (INT x:A. B(x))"
  unfolding INTER_def by (blast intro: CollectI ballI)

lemma INT_D: "\<lbrakk>b : (INT x:A. B(x)); a:A\<rbrakk> \<Longrightarrow> b: B(a)"
  unfolding INTER_def by (blast dest: CollectD bspec)

(*"Classical" elimination rule -- does not require proving X:C *)
lemma INT_E: "\<lbrakk>b : (INT x:A. B(x)); b: B(a) \<Longrightarrow> R; \<not> a:A \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding INTER_def by (blast dest: CollectD bspec)

lemma INT_cong: "\<lbrakk>A = B; \<And>x. x:B \<Longrightarrow> C(x) = D(x)\<rbrakk> \<Longrightarrow> (INT x:A. C(x)) = (INT x:B. D(x))"
  by (simp add: INTER_def cong: ball_cong)

subsection {* Rules for Unions *}

(*The order of the premises presupposes that C is rigid; A may be flexible*)
lemma UnionI: "\<lbrakk>X:C; A:X\<rbrakk> \<Longrightarrow> A : Union(C)"
  unfolding Union_def by (blast intro: UN_I)

lemma UnionE: "\<lbrakk>A : Union(C); \<And>X. \<lbrakk> A:X; X:C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding Union_def by (blast elim: UN_E)

subsection {* Rules for Inter *}

lemma InterI: "(\<And>X. X:C \<Longrightarrow> A:X) \<Longrightarrow> A : Inter(C)"
  unfolding Inter_def by (blast intro: INT_I)

(*A "destruct" rule -- every X in C contains A as an element, but
  A:X can hold when X:C does not!  This rule is analogous to "spec". *)
lemma InterD: "\<lbrakk>A : Inter(C);  X:C\<rbrakk> \<Longrightarrow> A:X"
  unfolding Inter_def by (blast dest: INT_D)

(*"Classical" elimination rule -- does not require proving X:C *)
lemma InterE: "\<lbrakk>A : Inter(C); A:X \<Longrightarrow> R; \<not> X:C \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding Inter_def by (blast elim: INT_E)

section {* Derived rules involving subsets; Union and Intersection as lattice operations *}

subsection {* Big Union -- least upper bound of a set *}

lemma Union_upper: "B:A \<Longrightarrow> B <= Union(A)"
  by (blast intro: subsetI UnionI)

lemma Union_least: "(\<And>X. X:A \<Longrightarrow> X<=C) \<Longrightarrow> Union(A) <= C"
  by (blast intro: subsetI dest: subsetD elim: UnionE)

subsection {* Big Intersection -- greatest lower bound of a set *}

lemma Inter_lower: "B:A \<Longrightarrow> Inter(A) <= B"
  by (blast intro: subsetI dest: InterD)

lemma Inter_greatest: "(\<And>X. X:A \<Longrightarrow> C<=X) \<Longrightarrow> C <= Inter(A)"
  by (blast intro: subsetI InterI dest: subsetD)

subsection {* Finite Union -- the least upper bound of 2 sets *}

lemma Un_upper1: "A <= A Un B"
  by (blast intro: subsetI UnI1)

lemma Un_upper2: "B <= A Un B"
  by (blast intro: subsetI UnI2)

lemma Un_least: "\<lbrakk>A<=C; B<=C\<rbrakk> \<Longrightarrow> A Un B <= C"
  by (blast intro: subsetI elim: UnE dest: subsetD)

subsection {* Finite Intersection -- the greatest lower bound of 2 sets *}

lemma Int_lower1: "A Int B <= A"
  by (blast intro: subsetI elim: IntE)

lemma Int_lower2: "A Int B <= B"
  by (blast intro: subsetI elim: IntE)

lemma Int_greatest: "\<lbrakk>C<=A; C<=B\<rbrakk> \<Longrightarrow> C <= A Int B"
  by (blast intro: subsetI IntI dest: subsetD)

subsection {* Monotonicity *}

lemma monoI: "(\<And>A B. A <= B \<Longrightarrow> f(A) <= f(B)) \<Longrightarrow> mono(f)"
  unfolding mono_def by blast

lemma monoD: "\<lbrakk>mono(f); A <= B\<rbrakk> \<Longrightarrow> f(A) <= f(B)"
  unfolding mono_def by blast

lemma mono_Un: "mono(f) \<Longrightarrow> f(A) Un f(B) <= f(A Un B)"
  by (blast intro: Un_least dest: monoD intro: Un_upper1 Un_upper2)

lemma mono_Int: "mono(f) \<Longrightarrow> f(A Int B) <= f(A) Int f(B)"
  by (blast intro: Int_greatest dest: monoD intro: Int_lower1 Int_lower2)

subsection {* Automated reasoning setup *}

lemmas [intro!] = ballI subsetI InterI INT_I CollectI ComplI IntI UnCI singletonI
  and [intro] = bexI UnionI UN_I
  and [elim!] = bexE UnionE UN_E CollectE ComplE IntE UnE emptyE singletonE
  and [elim] = ballE InterD InterE INT_D INT_E subsetD subsetCE

lemma mem_rews:
  "(a : A Un B)   \<longleftrightarrow>  (a:A | a:B)"
  "(a : A Int B)  \<longleftrightarrow>  (a:A \<and> a:B)"
  "(a : Compl(B)) \<longleftrightarrow>  (\<not>a:B)"
  "(a : {b})      \<longleftrightarrow>  (a=b)"
  "(a : {})       \<longleftrightarrow>   False"
  "(a : {x. P(x)}) \<longleftrightarrow>  P(a)"
  by blast+

lemmas [simp] = trivial_set empty_eq mem_rews
  and [cong] = ball_cong bex_cong INT_cong UN_cong

section {* Equalities involving union, intersection, inclusion, etc. *}

subsection {* Binary Intersection *}

lemma Int_absorb: "A Int A = A"
  by (blast intro: equalityI)

lemma Int_commute: "A Int B  =  B Int A"
  by (blast intro: equalityI)

lemma Int_assoc: "(A Int B) Int C  =  A Int (B Int C)"
  by (blast intro: equalityI)

lemma Int_Un_distrib: "(A Un B) Int C  =  (A Int C) Un (B Int C)"
  by (blast intro: equalityI)

lemma subset_Int_eq: "(A<=B) \<longleftrightarrow> (A Int B = A)"
  by (blast intro: equalityI elim: equalityE)

subsection {* Binary Union *}

lemma Un_absorb: "A Un A = A"
  by (blast intro: equalityI)

lemma Un_commute: "A Un B  =  B Un A"
  by (blast intro: equalityI)

lemma Un_assoc: "(A Un B) Un C  =  A Un (B Un C)"
  by (blast intro: equalityI)

lemma Un_Int_distrib: "(A Int B) Un C  =  (A Un C) Int (B Un C)"
  by (blast intro: equalityI)

lemma Un_Int_crazy:
    "(A Int B) Un (B Int C) Un (C Int A) = (A Un B) Int (B Un C) Int (C Un A)"
  by (blast intro: equalityI)

lemma subset_Un_eq: "(A<=B) \<longleftrightarrow> (A Un B = B)"
  by (blast intro: equalityI elim: equalityE)

subsection {* Simple properties of @{text "Compl"} -- complement of a set *}

lemma Compl_disjoint: "A Int Compl(A) = {x. False}"
  by (blast intro: equalityI)

lemma Compl_partition: "A Un Compl(A) = {x. True}"
  by (blast intro: equalityI)

lemma double_complement: "Compl(Compl(A)) = A"
  by (blast intro: equalityI)

lemma Compl_Un: "Compl(A Un B) = Compl(A) Int Compl(B)"
  by (blast intro: equalityI)

lemma Compl_Int: "Compl(A Int B) = Compl(A) Un Compl(B)"
  by (blast intro: equalityI)

lemma Compl_UN: "Compl(UN x:A. B(x)) = (INT x:A. Compl(B(x)))"
  by (blast intro: equalityI)

lemma Compl_INT: "Compl(INT x:A. B(x)) = (UN x:A. Compl(B(x)))"
  by (blast intro: equalityI)

(*Halmos, Naive Set Theory, page 16.*)
lemma Un_Int_assoc_eq: "((A Int B) Un C = A Int (B Un C)) \<longleftrightarrow> (C<=A)"
  by (blast intro: equalityI elim: equalityE)

subsection {* Big Union and Intersection *}

lemma Union_Un_distrib: "Union(A Un B) = Union(A) Un Union(B)"
  by (blast intro: equalityI)

lemma Union_disjoint:
    "(Union(C) Int A = {x. False}) \<longleftrightarrow> (ALL B:C. B Int A = {x. False})"
  by (blast intro: equalityI elim: equalityE)

lemma Inter_Un_distrib: "Inter(A Un B) = Inter(A) Int Inter(B)"
  by (blast intro: equalityI)

subsection {* Unions and Intersections of Families *}

lemma UN_eq: "(UN x:A. B(x)) = Union({Y. EX x:A. Y=B(x)})"
  by (blast intro: equalityI)

(*Look: it has an EXISTENTIAL quantifier*)
lemma INT_eq: "(INT x:A. B(x)) = Inter({Y. EX x:A. Y=B(x)})"
  by (blast intro: equalityI)

lemma Int_Union_image: "A Int Union(B) = (UN C:B. A Int C)"
  by (blast intro: equalityI)

lemma Un_Inter_image: "A Un Inter(B) = (INT C:B. A Un C)"
  by (blast intro: equalityI)

section {* Monotonicity of various operations *}

lemma Union_mono: "A<=B \<Longrightarrow> Union(A) <= Union(B)"
  by blast

lemma Inter_anti_mono: "B <= A \<Longrightarrow> Inter(A) <= Inter(B)"
  by blast

lemma UN_mono: "\<lbrakk>A <= B; \<And>x. x:A \<Longrightarrow> f(x)<=g(x)\<rbrakk> \<Longrightarrow> (UN x:A. f(x)) <= (UN x:B. g(x))"
  by blast

lemma INT_anti_mono: "\<lbrakk>B <= A; \<And>x. x:A \<Longrightarrow> f(x) <= g(x)\<rbrakk> \<Longrightarrow> (INT x:A. f(x)) <= (INT x:A. g(x))"
  by blast

lemma Un_mono: "\<lbrakk>A <= C; B <= D\<rbrakk> \<Longrightarrow> A Un B <= C Un D"
  by blast

lemma Int_mono: "\<lbrakk>A <= C; B <= D\<rbrakk> \<Longrightarrow> A Int B <= C Int D"
  by blast

lemma Compl_anti_mono: "A <= B \<Longrightarrow> Compl(B) <= Compl(A)"
  by blast

end


(*  Title:      HOL/Cardinals/Order_Union.thy
    Author:     Andrei Popescu, TU Muenchen

The ordinal-like sum of two orders with disjoint fields
*)

section \<open>Order Union\<close>

theory Order_Union
imports MainRLT
begin

definition Osum :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel"  (infix "Osum" 60) where
  "r Osum r' = r \<union> r' \<union> {(a, a'). a \<in> Field r \<and> a' \<in> Field r'}"

notation Osum  (infix "\<union>o" 60)

lemma Field_Osum: "Field (r \<union>o r') = Field r \<union> Field r'"
  unfolding Osum_def Field_def by blast

lemma Osum_wf:
assumes FLD: "Field r Int Field r' = {}" and
        WF: "wf r" and WF': "wf r'"
shows "wf (r Osum r')"
unfolding wf_eq_minimal2 unfolding Field_Osum
proof(intro allI impI, elim conjE)
  fix A assume *: "A \<subseteq> Field r \<union> Field r'" and **: "A \<noteq> {}"
  obtain B where B_def: "B = A Int Field r" by blast
  show "\<exists>a\<in>A. \<forall>a'\<in>A. (a', a) \<notin> r \<union>o r'"
  proof(cases "B = {}")
    assume Case1: "B \<noteq> {}"
    hence "B \<noteq> {} \<and> B \<le> Field r" using B_def by auto
    then obtain a where 1: "a \<in> B" and 2: "\<forall>a1 \<in> B. (a1,a) \<notin> r"
    using WF unfolding wf_eq_minimal2 by blast
    hence 3: "a \<in> Field r \<and> a \<notin> Field r'" using B_def FLD by auto
    (*  *)
    have "\<forall>a1 \<in> A. (a1,a) \<notin> r Osum r'"
    proof(intro ballI)
      fix a1 assume **: "a1 \<in> A"
      {assume Case11: "a1 \<in> Field r"
       hence "(a1,a) \<notin> r" using B_def ** 2 by auto
       moreover
       have "(a1,a) \<notin> r'" using 3 by (auto simp add: Field_def)
       ultimately have "(a1,a) \<notin> r Osum r'"
       using 3 unfolding Osum_def by auto
      }
      moreover
      {assume Case12: "a1 \<notin> Field r"
       hence "(a1,a) \<notin> r" unfolding Field_def by auto
       moreover
       have "(a1,a) \<notin> r'" using 3 unfolding Field_def by auto
       ultimately have "(a1,a) \<notin> r Osum r'"
       using 3 unfolding Osum_def by auto
      }
      ultimately show "(a1,a) \<notin> r Osum r'" by blast
    qed
    thus ?thesis using 1 B_def by auto
  next
    assume Case2: "B = {}"
    hence 1: "A \<noteq> {} \<and> A \<le> Field r'" using * ** B_def by auto
    then obtain a' where 2: "a' \<in> A" and 3: "\<forall>a1' \<in> A. (a1',a') \<notin> r'"
    using WF' unfolding wf_eq_minimal2 by blast
    hence 4: "a' \<in> Field r' \<and> a' \<notin> Field r" using 1 FLD by blast
    (*  *)
    have "\<forall>a1' \<in> A. (a1',a') \<notin> r Osum r'"
    proof(unfold Osum_def, auto simp add: 3)
      fix a1' assume "(a1', a') \<in> r"
      thus False using 4 unfolding Field_def by blast
    next
      fix a1' assume "a1' \<in> A" and "a1' \<in> Field r"
      thus False using Case2 B_def by auto
    qed
    thus ?thesis using 2 by blast
  qed
qed

lemma Osum_Refl:
assumes FLD: "Field r Int Field r' = {}" and
        REFL: "Refl r" and REFL': "Refl r'"
shows "Refl (r Osum r')"
using assms
unfolding refl_on_def Field_Osum unfolding Osum_def by blast

lemma Osum_trans:
assumes FLD: "Field r Int Field r' = {}" and
        TRANS: "trans r" and TRANS': "trans r'"
shows "trans (r Osum r')"
proof(unfold trans_def, auto)
  fix x y z assume *: "(x, y) \<in> r \<union>o r'" and **: "(y, z) \<in> r \<union>o r'"
  show  "(x, z) \<in> r \<union>o r'"
  proof-
    {assume Case1: "(x,y) \<in> r"
     hence 1: "x \<in> Field r \<and> y \<in> Field r" unfolding Field_def by auto
     have ?thesis
     proof-
       {assume Case11: "(y,z) \<in> r"
        hence "(x,z) \<in> r" using Case1 TRANS trans_def[of r] by blast
        hence ?thesis unfolding Osum_def by auto
       }
       moreover
       {assume Case12: "(y,z) \<in> r'"
        hence "y \<in> Field r'" unfolding Field_def by auto
        hence False using FLD 1 by auto
       }
       moreover
       {assume Case13: "z \<in> Field r'"
        hence ?thesis using 1 unfolding Osum_def by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case2: "(x,y) \<in> r'"
     hence 2: "x \<in> Field r' \<and> y \<in> Field r'" unfolding Field_def by auto
     have ?thesis
     proof-
       {assume Case21: "(y,z) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD 2 by auto
       }
       moreover
       {assume Case22: "(y,z) \<in> r'"
        hence "(x,z) \<in> r'" using Case2 TRANS' trans_def[of r'] by blast
        hence ?thesis unfolding Osum_def by auto
       }
       moreover
       {assume Case23: "y \<in> Field r"
        hence False using FLD 2 by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case3: "x \<in> Field r \<and> y \<in> Field r'"
     have ?thesis
     proof-
       {assume Case31: "(y,z) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD Case3 by auto
       }
       moreover
       {assume Case32: "(y,z) \<in> r'"
        hence "z \<in> Field r'" unfolding Field_def by blast
        hence ?thesis unfolding Osum_def using Case3 by auto
       }
       moreover
       {assume Case33: "y \<in> Field r"
        hence False using FLD Case3 by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    ultimately show ?thesis using * unfolding Osum_def by blast
  qed
qed

lemma Osum_Preorder:
"\<lbrakk>Field r Int Field r' = {}; Preorder r; Preorder r'\<rbrakk> \<Longrightarrow> Preorder (r Osum r')"
unfolding preorder_on_def using Osum_Refl Osum_trans by blast

lemma Osum_antisym:
assumes FLD: "Field r Int Field r' = {}" and
        AN: "antisym r" and AN': "antisym r'"
shows "antisym (r Osum r')"
proof(unfold antisym_def, auto)
  fix x y assume *: "(x, y) \<in> r \<union>o r'" and **: "(y, x) \<in> r \<union>o r'"
  show  "x = y"
  proof-
    {assume Case1: "(x,y) \<in> r"
     hence 1: "x \<in> Field r \<and> y \<in> Field r" unfolding Field_def by auto
     have ?thesis
     proof-
       have "(y,x) \<in> r \<Longrightarrow> ?thesis"
       using Case1 AN antisym_def[of r] by blast
       moreover
       {assume "(y,x) \<in> r'"
        hence "y \<in> Field r'" unfolding Field_def by auto
        hence False using FLD 1 by auto
       }
       moreover
       have "x \<in> Field r' \<Longrightarrow> False" using FLD 1 by auto
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case2: "(x,y) \<in> r'"
     hence 2: "x \<in> Field r' \<and> y \<in> Field r'" unfolding Field_def by auto
     have ?thesis
     proof-
       {assume "(y,x) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD 2 by auto
       }
       moreover
       have "(y,x) \<in> r' \<Longrightarrow> ?thesis"
       using Case2 AN' antisym_def[of r'] by blast
       moreover
       {assume "y \<in> Field r"
        hence False using FLD 2 by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case3: "x \<in> Field r \<and> y \<in> Field r'"
     have ?thesis
     proof-
       {assume "(y,x) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD Case3 by auto
       }
       moreover
       {assume Case32: "(y,x) \<in> r'"
        hence "x \<in> Field r'" unfolding Field_def by blast
        hence False using FLD Case3 by auto
       }
       moreover
       have "\<not> y \<in> Field r" using FLD Case3 by auto
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    ultimately show ?thesis using * unfolding Osum_def by blast
  qed
qed

lemma Osum_Partial_order:
"\<lbrakk>Field r Int Field r' = {}; Partial_order r; Partial_order r'\<rbrakk> \<Longrightarrow>
 Partial_order (r Osum r')"
unfolding partial_order_on_def using Osum_Preorder Osum_antisym by blast

lemma Osum_Total:
assumes FLD: "Field r Int Field r' = {}" and
        TOT: "Total r" and TOT': "Total r'"
shows "Total (r Osum r')"
using assms
unfolding total_on_def  Field_Osum unfolding Osum_def by blast

lemma Osum_Linear_order:
"\<lbrakk>Field r Int Field r' = {}; Linear_order r; Linear_order r'\<rbrakk> \<Longrightarrow>
 Linear_order (r Osum r')"
unfolding linear_order_on_def using Osum_Partial_order Osum_Total by blast

lemma Osum_minus_Id1:
assumes "r \<le> Id"
shows "(r Osum r') - Id \<le> (r' - Id) \<union> (Field r \<times> Field r')"
proof-
  let ?Left = "(r Osum r') - Id"
  let ?Right = "(r' - Id) \<union> (Field r \<times> Field r')"
  {fix a::'a and b assume *: "(a,b) \<notin> Id"
   {assume "(a,b) \<in> r"
    with * have False using assms by auto
   }
   moreover
   {assume "(a,b) \<in> r'"
    with * have "(a,b) \<in> r' - Id" by auto
   }
   ultimately
   have "(a,b) \<in> ?Left \<Longrightarrow> (a,b) \<in> ?Right"
   unfolding Osum_def by auto
  }
  thus ?thesis by auto
qed

lemma Osum_minus_Id2:
assumes "r' \<le> Id"
shows "(r Osum r') - Id \<le> (r - Id) \<union> (Field r \<times> Field r')"
proof-
  let ?Left = "(r Osum r') - Id"
  let ?Right = "(r - Id) \<union> (Field r \<times> Field r')"
  {fix a::'a and b assume *: "(a,b) \<notin> Id"
   {assume "(a,b) \<in> r'"
    with * have False using assms by auto
   }
   moreover
   {assume "(a,b) \<in> r"
    with * have "(a,b) \<in> r - Id" by auto
   }
   ultimately
   have "(a,b) \<in> ?Left \<Longrightarrow> (a,b) \<in> ?Right"
   unfolding Osum_def by auto
  }
  thus ?thesis by auto
qed

lemma Osum_minus_Id:
assumes TOT: "Total r" and TOT': "Total r'" and
        NID: "\<not> (r \<le> Id)" and NID': "\<not> (r' \<le> Id)"
shows "(r Osum r') - Id \<le> (r - Id) Osum (r' - Id)"
proof-
  {fix a a' assume *: "(a,a') \<in> (r Osum r')" and **: "a \<noteq> a'"
   have "(a,a') \<in> (r - Id) Osum (r' - Id)"
   proof-
     {assume "(a,a') \<in> r \<or> (a,a') \<in> r'"
      with ** have ?thesis unfolding Osum_def by auto
     }
     moreover
     {assume "a \<in> Field r \<and> a' \<in> Field r'"
      hence "a \<in> Field(r - Id) \<and> a' \<in> Field (r' - Id)"
      using assms Total_Id_Field by blast
      hence ?thesis unfolding Osum_def by auto
     }
     ultimately show ?thesis using * unfolding Osum_def by fast
   qed
  }
  thus ?thesis by(auto simp add: Osum_def)
qed

lemma wf_Int_Times:
assumes "A Int B = {}"
shows "wf(A \<times> B)"
unfolding wf_def using assms by blast

lemma Osum_wf_Id:
assumes TOT: "Total r" and TOT': "Total r'" and
        FLD: "Field r Int Field r' = {}" and
        WF: "wf(r - Id)" and WF': "wf(r' - Id)"
shows "wf ((r Osum r') - Id)"
proof(cases "r \<le> Id \<or> r' \<le> Id")
  assume Case1: "\<not>(r \<le> Id \<or> r' \<le> Id)"
  have "Field(r - Id) Int Field(r' - Id) = {}"
  using FLD mono_Field[of "r - Id" r]  mono_Field[of "r' - Id" r']
            Diff_subset[of r Id] Diff_subset[of r' Id] by blast
  thus ?thesis
  using Case1 Osum_minus_Id[of r r'] assms Osum_wf[of "r - Id" "r' - Id"]
        wf_subset[of "(r - Id) \<union>o (r' - Id)" "(r Osum r') - Id"] by auto
next
  have 1: "wf(Field r \<times> Field r')"
  using FLD by (auto simp add: wf_Int_Times)
  assume Case2: "r \<le> Id \<or> r' \<le> Id"
  moreover
  {assume Case21: "r \<le> Id"
   hence "(r Osum r') - Id \<le> (r' - Id) \<union> (Field r \<times> Field r')"
   using Osum_minus_Id1[of r r'] by simp
   moreover
   {have "Domain(Field r \<times> Field r') Int Range(r' - Id) = {}"
    using FLD unfolding Field_def by blast
    hence "wf((r' - Id) \<union> (Field r \<times> Field r'))"
    using 1 WF' wf_Un[of "Field r \<times> Field r'" "r' - Id"]
    by (auto simp add: Un_commute)
   }
   ultimately have ?thesis using wf_subset by blast
  }
  moreover
  {assume Case22: "r' \<le> Id"
   hence "(r Osum r') - Id \<le> (r - Id) \<union> (Field r \<times> Field r')"
   using Osum_minus_Id2[of r' r] by simp
   moreover
   {have "Range(Field r \<times> Field r') Int Domain(r - Id) = {}"
    using FLD unfolding Field_def by blast
    hence "wf((r - Id) \<union> (Field r \<times> Field r'))"
    using 1 WF wf_Un[of "r - Id" "Field r \<times> Field r'"]
    by (auto simp add: Un_commute)
   }
   ultimately have ?thesis using wf_subset by blast
  }
  ultimately show ?thesis by blast
qed

lemma Osum_Well_order:
assumes FLD: "Field r Int Field r' = {}" and
        WELL: "Well_order r" and WELL': "Well_order r'"
shows "Well_order (r Osum r')"
proof-
  have "Total r \<and> Total r'" using WELL WELL'
  by (auto simp add: order_on_defs)
  thus ?thesis using assms unfolding well_order_on_def
  using Osum_Linear_order Osum_wf_Id by blast
qed

end