theory Interval_Help
  imports "HOL-Library.Interval" "HOL-Decision_Procs.Approximation_Bounds"

begin

section "General Lemmas on Intervals"

definition Interval'' where
"Interval'' = (\<lambda>(l,u). if (l :: 'a :: linorder) \<le> u then Interval (l, u) else Interval (u, l))"

lemma normal_interval'': "l \<le> u \<Longrightarrow> Interval'' (l, u) = Interval (l, u)" unfolding Interval''_def by simp

definition closed_real_segment :: "real \<Rightarrow> real \<Rightarrow> real set" where
"closed_real_segment a b = (if a \<le> b then {a..b} else {b..a})"

lemma lower_Interval[simp]: "l \<le> u \<Longrightarrow> lower (Interval (l, u)) = l"
by (metis Ivl.rep_eq bounds_of_interval_inverse fst_conv lower.rep_eq min_def)

lemma upper_Interval[simp]: "l \<le> u \<Longrightarrow> upper (Interval (l, u)) = u"
by (simp add: Interval_inverse upper.rep_eq)

lemma set_of_Interval: "l \<le> u \<Longrightarrow> set_of (Interval (l, u)) = {l..u}"
  by (simp add: set_of_eq)

lemma sign_of_element: "upper ivl < 0 \<Longrightarrow> \<forall>x \<in> set_of ivl. x < 0"
  by (metis atLeastAtMost_iff le_less_trans set_of_eq)

lemma sign_of_element': "0 < lower ivl \<Longrightarrow> \<forall>x \<in> set_of ivl. 0 < x"
  by (simp add: less_le_trans set_of_eq)

section "Lemmas and Definitions on Real Intervals"
subsection "General"

(* inverse, iff 0 \<notin> ivl, this is guaranteed in the implementation *)
definition inverse_interval' :: "real interval \<Rightarrow> real interval" where
"inverse_interval' ivl = Interval (inverse (upper ivl), inverse (lower ivl))"

lemma inverse_in_inverse_interval': "x \<in> set_of ivl \<and> 0 \<notin> set_of ivl \<Longrightarrow> inverse x \<in> set_of (inverse_interval' ivl)"
  by (smt atLeastAtMost_iff inverse_interval'_def le_imp_inverse_le le_imp_inverse_le_neg lower_Interval set_of_eq upper_Interval)

fun set_of_interval_list:: "real interval list \<Rightarrow> real set" where
"set_of_interval_list (ivl#ivls) = set_of ivl \<union> set_of_interval_list ivls" |
"set_of_interval_list [] = {}"

lemma in_interval_in_set_of_interval_list: "x \<in> set_of ivl \<Longrightarrow> x \<in> set_of_interval_list (ivls @ ivl # ivls')"
  by (induct ivls) auto

lemma in_larger_interval_list_set_l: "x \<in> set_of_interval_list ivls \<Longrightarrow> x \<in> set_of_interval_list (ivls' @ ivls)"
  by (induct ivls') auto

lemma in_larger_interval_list_set_r: "x \<in> set_of_interval_list ivls \<Longrightarrow> x \<in> set_of_interval_list (ivls @ ivls')"
  by (induct ivls) auto

subsection "Intersections and Split"

(* ivl \<inter> ivl' *)
definition interval_intersection:: "real interval \<Rightarrow> real interval \<Rightarrow> real interval list" where
"interval_intersection ivl ivl' = (
  if upper ivl' < lower ivl \<or> upper ivl < lower ivl' then []
  else [Interval (max (lower ivl) (lower ivl'), min (upper ivl) (upper ivl'))]
)"

(* x \<in> ivl \<and> x \<in> ivl' \<Longrightarrow> ivl \<inter> ivl' *)
lemma in_both_intervals_in_intersection:
  assumes "x \<in> set_of ivl" "x \<in> set_of ivl'"
  shows "x \<in> set_of_interval_list (interval_intersection ivl ivl')"
proof -
  have order: "lower ivl \<le> x \<and> x \<le> upper ivl \<and> lower ivl' \<le> x \<and> x \<le> upper ivl'" using assms(1) assms(2) by (simp add: set_of_eq)
  then have "x \<in> set_of (Interval (max (lower ivl) (lower ivl'), min (upper ivl) (upper ivl')))" by (simp add: set_of_eq)
  then show ?thesis using in_interval_in_set_of_interval_list interval_intersection_def order by auto
qed

(* ivl \<inter> [l,\<infinity>) *)
definition interval_intersection_unbounded_upper:: "real interval \<Rightarrow> real \<Rightarrow> real interval list" where
"interval_intersection_unbounded_upper ivl l = (
  if upper ivl < l then []
  else [Interval (max (lower ivl) l, upper ivl)]
)"

(* x \<in> ivl \<and> x \<in> [l,\<infinity>) \<Longrightarrow> ivl \<inter> [l,\<infinity>) *)
lemma in_both_intervals_in_uu_intersection:
  assumes "x \<in> set_of ivl" "l \<le> x"
  shows "x \<in> set_of_interval_list (interval_intersection_unbounded_upper ivl l)"
proof -
  have "lower ivl \<le> x \<and> x \<le> upper ivl" using assms(1) by (simp add: set_of_eq)
  then have "max (lower ivl) l \<le> x \<and> x \<le> upper ivl" by (simp add: assms(2))
  then show ?thesis using interval_intersection_unbounded_upper_def by (simp add: set_of_eq)
qed

(* (\<infinity>,u] \<inter> ivl *)
definition interval_intersection_unbounded_lower:: "real interval \<Rightarrow> real \<Rightarrow> real interval list" where
"interval_intersection_unbounded_lower ivl u = (
  if u < lower ivl then []
  else [Interval (lower ivl, min (upper ivl) u)]
)"

(* x \<in> (\<infinity>,u] \<and> x \<in> ivl \<Longrightarrow> (\<infinity>,u] \<inter> ivl *)
lemma in_both_intervals_in_ul_intersection:
  assumes "x \<in> set_of ivl" "x \<le> u"
  shows "x \<in> set_of_interval_list (interval_intersection_unbounded_lower ivl u)"
proof -
  have "lower ivl \<le> x \<and> x \<le> upper ivl" using assms(1) by (simp add: set_of_eq)
  then have "lower ivl \<le> x \<and> x \<le> min (upper ivl) u" by (simp add: assms(2))
  then show ?thesis using interval_intersection_unbounded_lower_def by (simp add: set_of_eq)
qed

(* m \<in> [l,u] \<Longrightarrow> [l,u] \<leadsto> [l,m],[m,u] *)
definition split_interval:: "real interval \<Rightarrow> real \<Rightarrow> real interval list" where
"split_interval ivl m = (if m \<in> set_of ivl then [Interval (lower ivl, m), Interval (m, upper ivl)] else [ivl])"

(* m \<in> [l,u] \<Longrightarrow> [l,u] = [l,m] \<union> [m,u] *)
lemma split_same_set: "set_of ivl = set_of_interval_list (split_interval ivl m)"
proof (cases "m \<in> set_of ivl")
case True
  show ?thesis
  proof
    show "set_of ivl \<subseteq> set_of_interval_list (split_interval ivl m)"
    proof
      fix x
      assume x: "x \<in> set_of ivl"
      then have "lower ivl \<le> x \<and> x \<le> upper ivl \<and> m \<le> x \<or> x \<le> m" by (auto simp: set_of_eq)
      then have "lower ivl \<le> x \<and> x \<le> m \<or> m \<le> x \<and> x \<le> upper ivl" using set_of_eq x by fastforce
      then show "x \<in> set_of_interval_list (split_interval ivl m)" using True split_interval_def by (simp add: set_of_eq)
    qed
  next
    show "set_of_interval_list (split_interval ivl m) \<subseteq> set_of ivl"
    proof
      fix x
      assume "x \<in> set_of_interval_list (split_interval ivl m)"
      then have "lower ivl \<le> x \<and> x \<le> m \<or> m \<le> x \<and> x \<le> upper ivl" using True split_interval_def by (simp add: set_of_eq)
      then have "lower ivl \<le> x \<and> x \<le> upper ivl" using True atLeastAtMost_iff by (auto simp: set_of_eq)
      then show "x \<in> set_of ivl" by (simp add: set_of_eq)
    qed
  qed
next
  case False
  then show ?thesis using split_interval_def by simp
qed

section "Lemmas and Definitions on Float Intervals"
subsection "General"

(* inverse, iff 0 \<notin> ivl; inverse_float_interval without option *)
definition inverse_float_interval':: "nat \<Rightarrow> float interval \<Rightarrow> float interval" where
"inverse_float_interval' prec ivl = Interval'' (float_divl prec 1 (upper ivl), float_divr prec 1 (lower ivl))"

fun set_of_float_interval_list:: "float interval list \<Rightarrow> float set" where
"set_of_float_interval_list (ivl#ivls) = set_of ivl \<union> set_of_float_interval_list ivls" |
"set_of_float_interval_list [] = {}"

lemma in_float_interval_in_set_of_float_interval_list: "x \<in> set_of ivl \<Longrightarrow> x \<in> set_of_float_interval_list (ivls @ ivl # ivls')"
  by (induct ivls) auto

lemma in_larger_float_interval_list_set_l: "x \<in> set_of_float_interval_list ivls \<Longrightarrow> x \<in> set_of_float_interval_list (ivls' @ ivls)"
  by (induct ivls') auto

lemma in_larger_float_interval_list_set_r: "x \<in> set_of_float_interval_list ivls \<Longrightarrow> x \<in> set_of_float_interval_list (ivls @ ivls')"
  by (induct ivls) auto

lemma in_float_interval_list_in_set_of_float_interval:
  "x \<in> set_of_float_interval_list ivls \<Longrightarrow> \<exists>i. x \<in> set_of (ivls ! i) \<and> i < length ivls"
proof (induction ivls)
  case Nil
  then show ?case by simp
next
  case (Cons ivl ivls)
  then show ?case
  proof (cases "x \<in> set_of ivl")
    case True
    then have "x \<in> set_of ((ivl # ivls) ! 0) \<and> 0 < length (ivl # ivls)" by simp
    then show ?thesis by blast
  next
    case False
    then obtain i where i: "x \<in> set_of (ivls ! i)" "i < length ivls"  using Cons.IH Cons.prems by auto
    then have "x \<in> set_of ((ivl # ivls) ! (i + 1)) \<and> (i + 1) < length (ivl # ivls)" by auto
    then show ?thesis by blast
  qed
qed

fun real_set_of_float_interval_list:: "float interval list \<Rightarrow> real set" where
"real_set_of_float_interval_list (ivl#ivls) = set_of (real_interval ivl) \<union> real_set_of_float_interval_list ivls" |
"real_set_of_float_interval_list [] = {}"

lemma in_float_interval_in_real_set_of_float_interval_list: "x \<in> set_of (real_interval ivl) \<Longrightarrow> x \<in> real_set_of_float_interval_list (ivls @ ivl # ivls')"
  by (induct ivls) auto

lemma in_larger_real_set_of_float_interval_list_l: "x \<in> real_set_of_float_interval_list ivls \<Longrightarrow> x \<in> real_set_of_float_interval_list (ivls' @ ivls)"
  by (induct ivls') auto

lemma in_larger_real_set_of_float_interval_list_r: "x \<in> real_set_of_float_interval_list ivls \<Longrightarrow> x \<in> real_set_of_float_interval_list (ivls @ ivls')"
  by (induct ivls) auto

lemma in_float_interval_list_in_set_of_float_interval':
  "x \<in> real_set_of_float_interval_list ivls \<Longrightarrow> \<exists>i. x \<in> set_of (real_interval (ivls ! i)) \<and> i < length ivls"
proof (induction ivls)
  case Nil
  then show ?case by simp
next
  case (Cons ivl ivls)
  thm Cons.IH
  then show ?case
  proof (cases "x \<in> set_of (real_interval ivl)")
    case True
    then have "x \<in> set_of (real_interval ((ivl # ivls) ! 0)) \<and> 0 < length (ivl # ivls)" by simp
    then show ?thesis by blast
  next
    case False
    then obtain i where i: "x \<in> set_of (real_interval (ivls ! i))" "i < length ivls"  using Cons.IH Cons.prems by auto
    then have "x \<in> set_of (real_interval ((ivl # ivls) ! (i + 1))) \<and> (i + 1) < length (ivl # ivls)" by auto
    then show ?thesis by blast
  qed
qed

lemma in_rounded_interval_list:
  "x \<in> real_set_of_float_interval_list ivls \<Longrightarrow> x \<in> real_set_of_float_interval_list (map (round_interval prec) ivls)"
  by (induct ivls) (auto simp: in_round_intervalI)

lemma real_interval_subset:
  assumes "ivl \<le> ivl'"
  shows "real_interval ivl \<le> real_interval ivl'"
proof -
  have "lower ivl' \<le> lower ivl \<and> upper ivl \<le> upper ivl'" using assms using less_eq_interval_def by blast
  then show ?thesis by (simp add: less_eq_interval_def)
qed

subsection "Definition of plus_float_interval"

context includes interval.lifting

begin

lift_definition plus_float_interval::"nat \<Rightarrow> float interval \<Rightarrow> float interval \<Rightarrow> float interval"
  is "\<lambda>prec. \<lambda>(a1, a2). \<lambda>(b1, b2). (float_plus_down prec a1 b1, float_plus_up prec a2 b2)"
  by (auto intro!: add_mono simp: float_plus_down_le float_plus_up_le)

lemma lower_plus_float_interval:
  "lower (plus_float_interval prec ivl ivl') = float_plus_down prec (lower ivl) (lower ivl')"
  by transfer auto
lemma upper_plus_float_interval:
  "upper (plus_float_interval prec ivl ivl') = float_plus_up prec (upper ivl) (upper ivl')"
  by transfer auto

lemma plus_float_interval_monotonic:
  "set_of (ivl + ivl') \<subseteq> set_of (plus_float_interval prec ivl ivl')"
  using float_plus_down_le float_plus_up_le lower_plus_float_interval upper_plus_float_interval
  by (simp add: set_of_subset_iff)

lemma plus_float_interval:
  "set_of (real_interval A) + set_of (real_interval B) \<subseteq>
    set_of (real_interval (plus_float_interval prec A B))"
proof
  fix x
  assume x: "x \<in> set_of (real_interval A) + set_of (real_interval B)"
  then have x: "x \<in> set_of(real_interval (A + B))" by (metis plus_in_float_intervalI set_plus_elim)
  then have "lower A + lower B \<le> x \<and> x \<le> upper A + upper B" by (simp add: set_of_eq)
  then have "float_plus_down prec (lower A) (lower B) \<le> x \<and> x \<le> float_plus_up prec (upper A) (upper B)"
    by (simp add: float_plus_down_le float_plus_up_le)
  then show "x \<in> set_of (real_interval (plus_float_interval prec A B))"
    by (simp add: in_intervalI lower_plus_float_interval upper_plus_float_interval)
qed

lemma plus_float_interval_mono:
  assumes "a \<le> real_interval a'" "b \<le> real_interval b'"
  shows   "a + b \<le> real_interval (plus_float_interval prec a' b')"
  using assms float_plus_down float_plus_up lower_plus_float_interval upper_plus_float_interval
  by (smt (z3) less_eq_interval_def lower_plus lower_real_interval upper_plus upper_real_interval)

lemma minus_float_interval_monotonic:
  "set_of (ivl - ivl') \<subseteq> set_of (plus_float_interval prec ivl (- ivl'))"
  using float_plus_down_le float_plus_up_le lower_plus_float_interval upper_plus_float_interval
  by (simp add: minus_interval_def plus_float_interval_monotonic)

end

subsection "Intersections and Split"

(* ivl \<inter> ivl' *)
definition float_interval_intersection:: "float interval \<Rightarrow> float interval \<Rightarrow> float interval list" where
"float_interval_intersection ivl ivl' = (
  if upper ivl' < lower ivl \<or> upper ivl < lower ivl' then []
  else [Interval (max (lower ivl) (lower ivl'), min (upper ivl) (upper ivl'))]
)"

(* x \<in> ivl \<and> x \<in> ivl' \<Longrightarrow> x \<in> ivl \<inter> ivl' *)
lemma in_both_float_intervals_in_float_intersection:
  assumes "x \<in> set_of ivl" "x \<in> set_of ivl'"
  shows "x \<in> set_of_float_interval_list (float_interval_intersection ivl ivl')"
proof -
  have order: "lower ivl \<le> x \<and> x \<le> upper ivl \<and> lower ivl' \<le> x \<and> x \<le> upper ivl'" using assms(1) assms(2) by (simp add: set_of_eq)
  then have "x \<in> set_of (Interval (max (lower ivl) (lower ivl'), min (upper ivl) (upper ivl')))"
    by (metis atLeastAtMost_iff max.bounded_iff min.bounded_iff order.trans set_of_Interval)
  then show ?thesis using order by (simp add: float_interval_intersection_def)
qed

lemma in_both_float_intervals_in_float_intersection':
  assumes "x \<in> set_of (real_interval ivl)" "x \<in> set_of (real_interval ivl')"
  shows "x \<in> real_set_of_float_interval_list (float_interval_intersection ivl ivl')"
proof -
  have order: "lower ivl \<le> x \<and> x \<le> upper ivl \<and> lower ivl' \<le> x \<and> x \<le> upper ivl'" using assms(1) assms(2) by (simp add: set_of_eq)
  then have "x \<in> set_of (real_interval (Interval (max (lower ivl) (lower ivl'), min (upper ivl) (upper ivl'))))"
    using in_real_intervalI by auto
  then show ?thesis using order by (simp add: float_interval_intersection_def)
qed

(* ivl \<inter> [l,\<infinity>) *)
definition float_interval_intersection_unbounded_upper:: "float interval \<Rightarrow> float \<Rightarrow> float interval list" where
"float_interval_intersection_unbounded_upper ivl l = (
  if upper ivl < l then []
  else [Interval (max (lower ivl) l, upper ivl)]
)"

(* x \<in> ivl \<and> x \<in> [l,\<infinity>) \<Longrightarrow> ivl \<inter> [l,\<infinity>) *)
lemma in_both_float_intervals_in_uu_intersection:
  assumes "x \<in> set_of ivl" "l \<le> x"
  shows "x \<in> set_of_float_interval_list (float_interval_intersection_unbounded_upper ivl l)"
proof -
  have "lower ivl \<le> x \<and> x \<le> upper ivl" using assms(1) by (simp add: set_of_eq)
  then show ?thesis using float_interval_intersection_unbounded_upper_def assms(2) by (auto simp add: set_of_eq)
qed

lemma in_both_float_intervals_in_uu_intersection':
  assumes "x \<in> set_of (real_interval ivl)" "l \<le> x"
  shows "x \<in> real_set_of_float_interval_list (float_interval_intersection_unbounded_upper ivl l)"
proof -
  have "lower ivl \<le> x \<and> x \<le> upper ivl" using assms(1) by (simp add: set_of_eq)
  then show ?thesis using float_interval_intersection_unbounded_upper_def assms(2) by (auto simp: set_of_eq)
qed

(* (\<infinity>,u] \<inter> ivl *)
definition float_interval_intersection_unbounded_lower:: "float interval \<Rightarrow> float \<Rightarrow> float interval list" where
"float_interval_intersection_unbounded_lower ivl u = (
  if u < lower ivl then []
  else [Interval (lower ivl, min (upper ivl) u)]
)"

(* x \<in> (\<infinity>,u] \<and> x \<in> ivl \<Longrightarrow> (\<infinity>,u] \<inter> ivl *)
lemma in_both_float_intervals_in_ul_intersection:
  assumes "x \<in> set_of ivl" "x \<le> u"
  shows "x \<in> set_of_float_interval_list (float_interval_intersection_unbounded_lower ivl u)"
proof -
  have "lower ivl \<le> x \<and> x \<le> upper ivl" using assms(1) by (simp add: set_of_eq)
  then show ?thesis using float_interval_intersection_unbounded_lower_def assms(2) by (auto simp add: set_of_eq)
qed

lemma in_both_float_intervals_in_ul_intersection':
  assumes "x \<in> set_of (real_interval ivl)" "x \<le> u"
  shows "x \<in> real_set_of_float_interval_list (float_interval_intersection_unbounded_lower ivl u)"
proof -
  have "lower ivl \<le> x \<and> x \<le> upper ivl" using assms(1) by (simp add: set_of_eq)
  then show ?thesis using float_interval_intersection_unbounded_lower_def assms(2) by (auto simp add: set_of_eq)
qed

(* x \<in> (\<infinity>,u] \<and> x \<in> ivl \<Longrightarrow> (\<infinity>,u] \<inter> ivl *)
definition split_float_interval:: "float interval \<Rightarrow> float \<Rightarrow> float interval list" where
"split_float_interval ivl m = (if m \<in> set_of ivl then [Interval (lower ivl, m), Interval (m, upper ivl)] else [ivl])"

(* x \<in> (\<infinity>,u] \<and> x \<in> ivl \<Longrightarrow> (\<infinity>,u] \<inter> ivl *)
lemma split_float_same_set: "set_of ivl = set_of_float_interval_list (split_float_interval ivl m)"
proof (cases "m \<in> set_of ivl")
case True
  show ?thesis
  proof
    show "set_of ivl \<subseteq> set_of_float_interval_list (split_float_interval ivl m)"
    proof
      fix x
      assume x: "x \<in> set_of ivl"
      then have "lower ivl \<le> x \<and> x \<le> upper ivl \<and> m \<le> x \<or> x \<le> m" by (auto simp: set_of_eq)
      then have "lower ivl \<le> x \<and> x \<le> m \<or> m \<le> x \<and> x \<le> upper ivl" using set_of_eq x atLeastAtMost_iff by blast
      then show "x \<in> set_of_float_interval_list (split_float_interval ivl m)" using True split_float_interval_def by (simp add: set_of_eq)
    qed
  next
    show "set_of_float_interval_list (split_float_interval ivl m) \<subseteq> set_of ivl"
    proof
      fix x
      assume x: "x \<in> set_of_float_interval_list (split_float_interval ivl m)"
      then have "lower ivl \<le> x \<and> x \<le> m \<or> m \<le> x \<and> x \<le> upper ivl" using True split_float_interval_def by (simp add: set_of_eq)
      then have "lower ivl \<le> x \<and> x \<le> upper ivl" using True atLeastAtMost_iff by (auto simp: set_of_eq)
      then show "x \<in> set_of ivl" by (simp add: set_of_eq)
    qed
  qed
next
  case False
  then show ?thesis using split_float_interval_def by simp
qed

lemma split_float_same_set': "set_of (real_interval ivl) = real_set_of_float_interval_list (split_float_interval ivl m)"
proof (cases "m \<in> set_of ivl")
case True
  show ?thesis
  proof
    show "set_of (real_interval ivl) \<subseteq> real_set_of_float_interval_list (split_float_interval ivl m)"
    proof
      fix x
      assume x: "x \<in> set_of (real_interval ivl)"
      then have "lower ivl \<le> x \<and> x \<le> upper ivl \<and> m \<le> x \<or> x \<le> m" by (auto simp: set_of_eq)
      then have "lower ivl \<le> x \<and> x \<le> m \<or> m \<le> x \<and> x \<le> upper ivl"
        using set_of_eq x atLeastAtMost_iff by (metis lower_real_interval)
      then show "x \<in> real_set_of_float_interval_list (split_float_interval ivl m)"
        using True split_float_interval_def by (simp add: set_of_eq)
    qed
  next
    show "real_set_of_float_interval_list (split_float_interval ivl m) \<subseteq> set_of (real_interval ivl)"
    proof
      fix x
      assume x: "x \<in> real_set_of_float_interval_list (split_float_interval ivl m)"
      then have "lower ivl \<le> x \<and> x \<le> m \<or> m \<le> x \<and> x \<le> upper ivl"
        using True split_float_interval_def by (simp add: set_of_eq)
      then have "lower ivl \<le> x \<and> x \<le> upper ivl" using True atLeastAtMost_iff by (auto simp: set_of_eq)
      then show "x \<in> set_of (real_interval ivl)" by (simp add: set_of_eq)
    qed
  qed
next
  case False
  then show ?thesis using split_float_interval_def by simp
qed

subsection "Lemmas Showing Monotonicity"

lemma set_of_subset_iff':
  "set_of a \<subseteq> set_of (b :: 'a :: linorder interval) \<longleftrightarrow> a \<le> b"
  unfolding less_eq_interval_def set_of_subset_iff ..

lemma set_of_times': "set_of (a * b) = set_of a * set_of b"
  for a b :: "'a :: {linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
  by (auto simp: set_of_times set_times_def)

lemma mult_mono_interval:
  fixes a b :: "'a :: {linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
  assumes "a \<le> a'" "b \<le> b'"
  shows   "a * b \<le> a' * b'"
  using assms unfolding set_of_subset_iff'[symmetric] set_of_times' by (intro set_times_mono2)

lemma add_mono_interval:
  assumes "a \<le> a'" "b \<le> b'"
  shows   "a + b \<le> a' + (b' :: 'a :: ordered_ab_semigroup_add interval)"
  using assms
  by (auto simp: less_eq_interval_def add_mono)

lemma diff_mono_interval:
  assumes "a \<le> a'" "b \<le> b'"
  shows   "a - b \<le> a' - (b' :: 'a :: ordered_ab_group_add interval)"
  using assms
  by (auto simp: less_eq_interval_def diff_mono)

lemma add_mono_real_interval:
  assumes "a \<le> real_interval a'" "b \<le> real_interval b'"
  shows   "a + b \<le> real_interval (a' + b')"
  using assms
  by (auto simp: less_eq_interval_def add_mono)

lemma diff_mono_real_interval:
  assumes "a \<le> real_interval a'" "b \<le> real_interval b'"
  shows   "a - b \<le> real_interval (a' - b')"
  using assms
  by (auto simp: less_eq_interval_def diff_mono)

lemma mult_float_interval_mono:
  assumes "a \<le> real_interval a'" "b \<le> real_interval b'"
  shows   "a * b \<le> real_interval (mult_float_interval prec a' b')"
proof -
  have "a * b \<le> real_interval a' * real_interval b'"
    by (intro mult_mono_interval assms)
  also {
    have "set_of (real_interval a' * real_interval b') =
            set_of (real_interval a') * set_of (real_interval b')"
      by (auto simp: set_of_times set_times_def)
    also have "\<dots> \<subseteq> set_of (real_interval (mult_float_interval prec a' b'))"
      by (rule mult_float_interval)
    finally have "real_interval a' * real_interval b' \<le> real_interval (mult_float_interval prec a' b')"
      by (simp add: set_of_subset_iff')
  }
  finally show ?thesis .
qed

lemma real_of_float_le_iff: "real_of_float x \<le> real_of_float y \<longleftrightarrow> x \<le> y"
  by simp

lemma real_of_float_less_iff: "real_of_float x < real_of_float y \<longleftrightarrow> x < y"
  by simp

lemma real_of_float_leI: "x \<le> y \<Longrightarrow> real_of_float x \<le> real_of_float y"
  by simp

lemma inverse_float_interval'_correctness:
  assumes "0 \<notin> set_of ivl"
  shows lower_inverse_float_interval:
          "lower (inverse_float_interval' prec ivl) = float_divl prec 1 (upper ivl)"
    and upper_inverse_float_interval:
          "upper (inverse_float_interval' prec ivl) = float_divr prec 1 (lower ivl)"
proof -
  from assms have "lower ivl > 0 \<or> upper ivl < 0"
    by (meson in_intervalI not_le)
  moreover have "real_of_float (lower ivl) \<le> real_of_float (upper ivl)"
    by (meson less_eq_float.rep_eq lower_le_upper)
  ultimately have *: "1 / real_of_float (upper ivl) \<le> 1 / real_of_float (lower ivl)"
    by (auto simp: divide_simps)

  show "lower (inverse_float_interval' prec ivl) = float_divl prec 1 (upper ivl)"
    using *  unfolding inverse_float_interval'_def
    by (smt Interval''_def Interval_Help.lower_Interval float_divl float_divr normal_interval'' one_float.rep_eq real_of_float_le_iff)
  show "upper (inverse_float_interval' prec ivl) = float_divr prec 1 (lower ivl)"
    using * unfolding inverse_float_interval'_def
    by (smt Interval''_def Interval_Help.upper_Interval float_divl float_divr normal_interval'' one_float.rep_eq real_of_float_le_iff)
qed

lemma inverse_interval'_correctness:
  assumes "0 \<notin> set_of ivl"
  shows   lower_inverse_interval': "lower (inverse_interval' ivl) = inverse (upper ivl)"
    and   upper_inverse_interval': "upper (inverse_interval' ivl) = inverse (lower ivl)"
proof -
  have "lower ivl > 0 \<or> upper ivl < 0"
    using assms by (meson in_intervalI not_le)
  hence *: "inverse (upper ivl) \<le> inverse (lower ivl)"
    by (auto simp: divide_simps)
  show "lower (inverse_interval' ivl) = inverse (upper ivl)"
    using * unfolding inverse_interval'_def
    by (subst lower.abs_eq) (auto simp: eq_onp_def)
  show "upper (inverse_interval' ivl) = inverse (lower ivl)"
    using * unfolding inverse_interval'_def
    by (subst upper.abs_eq) (auto simp: eq_onp_def)
qed

lemma inverse_float_interval'_mono:
  assumes "a \<le> real_interval a'" "0 \<notin> set_of a'"
  shows   "inverse_interval' a \<le> real_interval (inverse_float_interval' prec a')"
proof -
  have *: "lower a' > 0 \<or> upper a' < 0"
    using assms(2) by (meson in_intervalI not_le)
  have **: "real_of_float (lower a') \<le> real_of_float (upper a')"
    by (intro real_of_float_leI lower_le_upper)
  have ***: "1 / real_of_float (upper a') \<le> inverse (upper a)"
            "1 / real_of_float (lower a') \<ge> inverse (lower a)"
    using * ** lower_le_upper[of a] assms
      by (auto simp: divide_simps less_eq_interval_def simp del: lower_le_upper)
  have "0 \<notin> set_of a"
    using assms
    by (metis atLeastAtMost_iff in_mono less_eq_float.rep_eq lower_real_interval set_of_eq
              set_of_subset_iff' upper_real_interval zero_float.rep_eq)
  thus ?thesis using assms ***
    by (auto simp: less_eq_interval_def lower_inverse_float_interval upper_inverse_float_interval
                   lower_inverse_interval' upper_inverse_interval'
             intro!: order.trans[OF float_divl] order.trans[OF _ float_divr])
qed

lemma real_interval_interval_of [simp]:
  "real_interval (interval_of m) = interval_of (real_of_float m)"
  by (simp add: interval_eq_iff)

end


section \<open>Bounded Degree Polynomials\<close>

text \<open>This section contains a definition for the set of polynomials with a degree bound and
establishes its cardinality.\<close>

theory Bounded_Degree_Polynomials
  imports "HOL-Algebra.Polynomial_Divisibility"
begin

lemma (in ring) coeff_in_carrier: "p \<in> carrier (poly_ring R) \<Longrightarrow> coeff p i \<in> carrier R"
  using poly_coeff_in_carrier carrier_is_subring by (simp add: univ_poly_carrier)

definition bounded_degree_polynomials
  where "bounded_degree_polynomials F n = {x. x \<in> carrier (poly_ring F) \<and> (degree x < n \<or> x = [])}"

text \<open>Note: The definition for @{term "bounded_degree_polynomials"} includes the zero polynomial
in @{term "bounded_degree_polynomials F 0"}. The reason for this adjustment is that, contrary to
definition in HOL Algebra, most authors set the degree of the zero polynomial to
$-\infty$~\<^cite>\<open>\<open>\textsection 7.2.2\<close> in "shoup2009computational"\<close>. That
definition make some identities, such as $\mathrm{deg}(f g) = \mathrm{deg}\, f + \mathrm{deg}\, g$
for polynomials $f$ and $g$ unconditionally true.
In particular, it prevents an unnecessary corner case in the statement of the results established
in this entry.\<close>

lemma bounded_degree_polynomials_length:
  "bounded_degree_polynomials F n = {x. x \<in> carrier (poly_ring F) \<and> length x \<le> n}"
  unfolding bounded_degree_polynomials_def using leI order_less_le_trans by fastforce

lemma (in ring) fin_degree_bounded:
  assumes "finite (carrier R)"
  shows "finite (bounded_degree_polynomials R n)"
proof -
  have "bounded_degree_polynomials R n \<subseteq> {p. set p \<subseteq> carrier R \<and> length p \<le> n}"
    unfolding bounded_degree_polynomials_length
    using assms polynomial_incl univ_poly_carrier by blast
  thus ?thesis
    using assms finite_lists_length_le finite_subset by fast
qed

lemma (in ring) non_empty_bounded_degree_polynomials:
  "bounded_degree_polynomials R k \<noteq> {}"
proof -
  have "\<zero>\<^bsub>poly_ring R\<^esub> \<in> bounded_degree_polynomials R k"
    by (simp add: bounded_degree_polynomials_def univ_poly_zero univ_poly_zero_closed)
  thus ?thesis by auto
qed

lemma in_image_by_witness:
  assumes "\<And>x. x \<in> A \<Longrightarrow> g x \<in> B \<and> f (g x) = x"
  shows "A \<subseteq> f ` B"
  by (metis assms image_eqI subsetI)

lemma card_mostly_constant_maps:
  assumes "y \<in> B"
  shows "card {f. range f \<subseteq> B \<and> (\<forall>x. x \<ge> n \<longrightarrow> f x = y)} = card B ^ n" (is "card ?A = ?B")
proof -
  define f where "f = (\<lambda>f k. if k < n then f k else y)"

  have a:"?A \<subseteq> (f ` ({0..<n}  \<rightarrow>\<^sub>E B))"
    unfolding f_def
    by (rule in_image_by_witness[where g="\<lambda>f. restrict f {0..<n}"], auto)

  have b:"(f ` ({0..<n}  \<rightarrow>\<^sub>E B)) \<subseteq> ?A"
    using f_def assms by auto

  have c: "inj_on f ({0..<n} \<rightarrow>\<^sub>E B)"
    by (rule inj_onI, metis PiE_E atLeastLessThan_iff ext f_def)

  have "card ?A = card (f ` ({0..<n}  \<rightarrow>\<^sub>E B))"
    using a b by auto
  also have "... = card ({0..<n} \<rightarrow>\<^sub>E B)"
    by (metis c card_image)
  also have "... = card B ^ n"
    by (simp add: card_PiE[OF finite_atLeastLessThan])
  finally show ?thesis by simp
qed

definition (in ring) build_poly where
  "build_poly f n = normalize (rev (map f [0..<n]))"

lemma (in ring) poly_degree_bound_from_coeff:
  assumes "x \<in> carrier (poly_ring R)"
  assumes "\<And>k. k \<ge> n \<Longrightarrow> coeff x k = \<zero>"
  shows "degree x < n \<or> x = \<zero>\<^bsub>poly_ring R\<^esub>"
proof (rule ccontr)
  assume a:"\<not>(degree x < n \<or> x = \<zero>\<^bsub>poly_ring R\<^esub>)"
  hence b:"lead_coeff x \<noteq> \<zero>\<^bsub>R\<^esub>"
    by (metis assms(1) polynomial_def univ_poly_carrier univ_poly_zero)
  hence "coeff x (degree x) \<noteq> \<zero>"
    by (metis a lead_coeff_simp univ_poly_zero)
  moreover have "degree x \<ge> n" by (meson a not_le)
  ultimately show "False" using assms(2) by blast
qed

lemma (in ring) poly_degree_bound_from_coeff_1:
  assumes "x \<in> carrier (poly_ring R)"
  assumes "\<And>k. k \<ge> n \<Longrightarrow> coeff x k = \<zero>"
  shows "x \<in> bounded_degree_polynomials R n"
  using poly_degree_bound_from_coeff[OF assms]
  by (simp add:bounded_degree_polynomials_def univ_poly_zero assms)

lemma (in ring) length_build_poly:
  "length (build_poly f n) \<le> n"
  by (metis length_map build_poly_def normalize_length_le length_rev length_upt
      less_imp_diff_less linorder_not_less)

lemma (in ring) build_poly_degree:
  "degree (build_poly f n) \<le> n-1"
  using length_build_poly diff_le_mono by presburger

lemma (in ring) build_poly_poly:
  assumes "\<And>i. i < n \<Longrightarrow> f i \<in> carrier R"
  shows "build_poly f n \<in> carrier (poly_ring R)"
  unfolding build_poly_def univ_poly_carrier[symmetric]
  by (rule normalize_gives_polynomial, simp add:image_subset_iff Ball_def assms)

lemma (in ring) build_poly_coeff:
  "coeff (build_poly f n) i = (if i < n then f i else \<zero>)"
proof -
  show "coeff (build_poly f n) i = (if i < n then f i else \<zero>)"
    unfolding build_poly_def normalize_coeff[symmetric]
    by (cases "i < n", (simp add:coeff_nth rev_nth coeff_length)+)
qed

lemma (in ring) build_poly_bounded:
  assumes "\<And>k. k < n \<Longrightarrow> f k \<in> carrier R"
  shows "build_poly f n \<in> bounded_degree_polynomials R n"
  unfolding bounded_degree_polynomials_length
  using build_poly_poly[OF assms] length_build_poly by auto

text \<open>The following establishes the total number of polynomials with a degree less than $n$.
Unlike the results in the following sections, it is already possible to establish this property for
polynomials with coefficients in a ring.\<close>

lemma (in ring) bounded_degree_polynomials_card:
  "card (bounded_degree_polynomials R n) = card (carrier R) ^ n"
proof -
  have a:"coeff ` bounded_degree_polynomials R n \<subseteq> {f. range f \<subseteq> (carrier R) \<and> (\<forall>k \<ge> n. f k = \<zero>)}"
    by (rule image_subsetI, auto simp add:bounded_degree_polynomials_def coeff_length coeff_in_carrier)

  have b:"{f. range f \<subseteq> (carrier R) \<and> (\<forall>k \<ge> n. f k = \<zero>)} \<subseteq> coeff ` bounded_degree_polynomials R n"
    apply (rule in_image_by_witness[where g="\<lambda>x. build_poly x n"])
    by (auto simp add:build_poly_coeff intro:build_poly_bounded)

  have "inj_on coeff (carrier (poly_ring R))"
    by (rule inj_onI, simp add: coeff_iff_polynomial_cond univ_poly_carrier)

  hence coeff_inj: "inj_on coeff (bounded_degree_polynomials R n)"
    using inj_on_subset bounded_degree_polynomials_def by blast

  have "card ( bounded_degree_polynomials R n) = card (coeff `  bounded_degree_polynomials R n)"
    using coeff_inj card_image[symmetric] by blast
  also have "... = card {f. range f \<subseteq> (carrier R) \<and> (\<forall>k \<ge> n. f k = \<zero>)}"
    by (rule arg_cong[where f="card"], rule order_antisym[OF a b])
  also have "... = card (carrier R)^n"
    by (rule card_mostly_constant_maps, simp)
  finally show ?thesis by simp
qed

end


(*  Title:      HOL/Corec_Examples/Tests/Small_Concrete.thy
    Author:     Aymeric Bouzy, Ecole polytechnique
    Author:     Jasmin Blanchette, Inria, LORIA, MPII
    Copyright   2015, 2016

Small concrete examples.
*)

section \<open>Small Concrete Examples\<close>

theory Small_Concrete
imports "~~/src/HOL/Library/BNF_Corec"
begin

subsection \<open>Streams of Natural Numbers\<close>

codatatype natstream = S (head: nat) (tail: natstream)

corec (friend) incr_all where
  "incr_all s = S (head s + 1) (incr_all (tail s))"

corec all_numbers where
  "all_numbers = S 0 (incr_all all_numbers)"

corec all_numbers_efficient where
  "all_numbers_efficient n = S n (all_numbers_efficient (n + 1))"

corec remove_multiples where
  "remove_multiples n s =
    (if (head s) mod n = 0 then
      S (head (tail s)) (remove_multiples n (tail (tail s)))
    else
      S (head s) (remove_multiples n (tail s)))"

corec prime_numbers where
  "prime_numbers known_primes =
    (let next_prime = head (fold (%n s. remove_multiples n s) known_primes (tail (tail all_numbers))) in
      S next_prime (prime_numbers (next_prime # known_primes)))"

term "prime_numbers []"

corec prime_numbers_more_efficient where
  "prime_numbers_more_efficient n remaining_numbers =
    (let remaining_numbers = remove_multiples n remaining_numbers in
      S (head remaining_numbers) (prime_numbers_more_efficient (head remaining_numbers) remaining_numbers))"

term "prime_numbers_more_efficient 0 (tail (tail all_numbers))"

corec (friend) alternate where
  "alternate s1 s2 = S (head s1) (S (head s2) (alternate (tail s1) (tail s2)))"

corec (friend) all_sums where
  "all_sums s1 s2 = S (head s1 + head s2) (alternate (all_sums s1 (tail s2)) (all_sums (tail s1) s2))"

corec app_list where
  "app_list s l = (case l of
    [] \<Rightarrow> s
  | a # r \<Rightarrow> S a (app_list s r))"

friend_of_corec app_list where
  "app_list s l = (case l of
    [] \<Rightarrow> (case s of S a b \<Rightarrow> S a b)
  | a # r \<Rightarrow> S a (app_list s r))"
  sorry

corec expand_with where
  "expand_with f s = (let l = f (head s) in S (hd l) (app_list (expand_with f (tail s)) (tl l)))"

friend_of_corec expand_with where
  "expand_with f s = (let l = f (head s) in S (hd l) (app_list (expand_with f (tail s)) (tl l)))"
  sorry

corec iterations where
  "iterations f a = S a (iterations f (f a))"

corec exponential_iterations where
  "exponential_iterations f a = S (f a) (exponential_iterations (f o f) a)"

corec (friend) alternate_list where
  "alternate_list l = (let heads = (map head l) in S (hd heads) (app_list (alternate_list (map tail l)) (tl heads)))"

corec switch_one_two0 where
  "switch_one_two0 f a s = (case s of
    S b r \<Rightarrow> S b (S a (f r)))"

corec switch_one_two where
  "switch_one_two s = (case s of
    S a (S b r) \<Rightarrow> S b (S a (switch_one_two r)))"

corec fibonacci where
  "fibonacci n m = S m (fibonacci (n + m) n)"

corec sequence2 where
  "sequence2 f u1 u0 = S u0 (sequence2 f (f u1 u0) u1)"

corec (friend) alternate_with_function where
  "alternate_with_function f s =
    (let f_head_s = f (head s) in S (head f_head_s) (alternate (tail f_head_s) (alternate_with_function f (tail s))))"

corec h where
  "h l s = (case l of
    [] \<Rightarrow> s
  | (S a s') # r \<Rightarrow> S a (alternate s (h r s')))"

friend_of_corec h where
  "h l s = (case l of
    [] \<Rightarrow> (case s of S a b \<Rightarrow> S a b)
  | (S a s') # r \<Rightarrow> S a (alternate s (h r s')))"
  sorry

corec z where
  "z = S 0 (S 0 z)"

lemma "\<And>x. x = S 0 (S 0 x) \<Longrightarrow> x = z"
  apply corec_unique
  apply (rule z.code)
  done

corec enum where
  "enum m = S m (enum (m + 1))"

lemma "(\<And>m. f m = S m (f (m + 1))) \<Longrightarrow> f m = enum m"
  apply corec_unique
  apply (rule enum.code)
  done

lemma "(\<forall>m. f m = S m (f (m + 1))) \<Longrightarrow> f m = enum m"
  apply corec_unique
  apply (rule enum.code)
  done

subsection \<open>Lazy Lists of Natural Numbers\<close>

codatatype llist = LNil | LCons nat llist

corec h1 where
  "h1 x = (if x = 1 then
    LNil
  else
    let x = if x mod 2 = 0 then x div 2 else 3 * x + 1 in
    LCons x (h1 x))"

corec h3 where
  "h3 s = (case s of
    LNil \<Rightarrow> LNil
  | LCons x r \<Rightarrow> LCons x (h3 r))"

corec fold_map where
  "fold_map f a s = (let v = f a (head s) in S v (fold_map f v (tail s)))"

friend_of_corec fold_map where
  "fold_map f a s = (let v = f a (head s) in S v (fold_map f v (tail s)))"
   apply (rule fold_map.code)
  sorry

subsection \<open>Coinductive Natural Numbers\<close>

codatatype conat = CoZero | CoSuc conat

corec sum where
  "sum x y = (case x of
      CoZero \<Rightarrow> y
    | CoSuc x \<Rightarrow> CoSuc (sum x y))"

friend_of_corec sum where
  "sum x y = (case x of
      CoZero \<Rightarrow> (case y of CoZero \<Rightarrow> CoZero | CoSuc y \<Rightarrow> CoSuc y)
    | CoSuc x \<Rightarrow> CoSuc (sum x y))"
  sorry

corec (friend) prod where
  "prod x y = (case (x, y) of
      (CoZero, _) \<Rightarrow> CoZero
    | (_, CoZero) \<Rightarrow> CoZero
    | (CoSuc x, CoSuc y) \<Rightarrow> CoSuc (sum (prod x y) (sum x y)))"

end


(* Title: Interval
   Author: Christoph Traut, TU Muenchen
           Fabian Immler, TU Muenchen
*)
section \<open>Interval Type\<close>
theory Interval
  imports
    Complex_Main
    Lattice_Algebras
    Set_Algebras
begin

text \<open>A type of non-empty, closed intervals.\<close>

typedef (overloaded) 'a interval =
  "{(a::'a::preorder, b). a \<le> b}"
  morphisms bounds_of_interval Interval
  by auto

setup_lifting type_definition_interval

lift_definition lower::"('a::preorder) interval \<Rightarrow> 'a" is fst .

lift_definition upper::"('a::preorder) interval \<Rightarrow> 'a" is snd .

lemma interval_eq_iff: "a = b \<longleftrightarrow> lower a = lower b \<and> upper a = upper b"
  by transfer auto

lemma interval_eqI: "lower a = lower b \<Longrightarrow> upper a = upper b \<Longrightarrow> a = b"
  by (auto simp: interval_eq_iff)

lemma lower_le_upper[simp]: "lower i \<le> upper i"
  by transfer auto

lift_definition set_of :: "'a::preorder interval \<Rightarrow> 'a set" is "\<lambda>x. {fst x .. snd x}" .

lemma set_of_eq: "set_of x = {lower x .. upper x}"
  by transfer simp

context notes [[typedef_overloaded]] begin

lift_definition(code_dt) Interval'::"'a::preorder \<Rightarrow> 'a::preorder \<Rightarrow> 'a interval option"
  is "\<lambda>a b. if a \<le> b then Some (a, b) else None"
  by auto

lemma Interval'_split:
  "P (Interval' a b) \<longleftrightarrow>
    (\<forall>ivl. a \<le> b \<longrightarrow> lower ivl = a \<longrightarrow> upper ivl = b \<longrightarrow> P (Some ivl)) \<and> (\<not>a\<le>b \<longrightarrow> P None)"
  by transfer auto

lemma Interval'_split_asm:
  "P (Interval' a b) \<longleftrightarrow>
    \<not>((\<exists>ivl. a \<le> b \<and> lower ivl = a \<and> upper ivl = b \<and> \<not>P (Some ivl)) \<or> (\<not>a\<le>b \<and> \<not>P None))"
  unfolding Interval'_split
  by auto

lemmas Interval'_splits = Interval'_split Interval'_split_asm

lemma Interval'_eq_Some: "Interval' a b = Some i \<Longrightarrow> lower i = a \<and> upper i = b"
  by (simp split: Interval'_splits)

end

instantiation "interval" :: ("{preorder,equal}") equal
begin

definition "equal_class.equal a b \<equiv> (lower a = lower b) \<and> (upper a = upper b)"

instance proof qed (simp add: equal_interval_def interval_eq_iff)
end

instantiation interval :: ("preorder") ord begin

definition less_eq_interval :: "'a interval \<Rightarrow> 'a interval \<Rightarrow> bool"
  where "less_eq_interval a b \<longleftrightarrow> lower b \<le> lower a \<and> upper a \<le> upper b"

definition less_interval :: "'a interval \<Rightarrow> 'a interval \<Rightarrow> bool"
  where  "less_interval x y = (x \<le> y \<and> \<not> y \<le> x)"

instance proof qed
end

instantiation interval :: ("lattice") semilattice_sup
begin

lift_definition sup_interval :: "'a interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval"
  is "\<lambda>(a, b) (c, d). (inf a c, sup b d)"
  by (auto simp: le_infI1 le_supI1)

lemma lower_sup[simp]: "lower (sup A B) = inf (lower A) (lower B)"
  by transfer auto

lemma upper_sup[simp]: "upper (sup A B) = sup (upper A) (upper B)"
  by transfer auto

instance proof qed (auto simp: less_eq_interval_def less_interval_def interval_eq_iff)
end

lemma set_of_interval_union: "set_of A \<union> set_of B \<subseteq> set_of (sup A B)" for A::"'a::lattice interval"
  by (auto simp: set_of_eq)

lemma interval_union_commute: "sup A B = sup B A" for A::"'a::lattice interval"
  by (auto simp add: interval_eq_iff inf.commute sup.commute)

lemma interval_union_mono1: "set_of a \<subseteq> set_of (sup a A)" for A :: "'a::lattice interval"
  using set_of_interval_union by blast

lemma interval_union_mono2: "set_of A \<subseteq> set_of (sup a A)" for A :: "'a::lattice interval"
  using set_of_interval_union by blast

lift_definition interval_of :: "'a::preorder \<Rightarrow> 'a interval" is "\<lambda>x. (x, x)"
  by auto

lemma lower_interval_of[simp]: "lower (interval_of a) = a"
  by transfer auto

lemma upper_interval_of[simp]: "upper (interval_of a) = a"
  by transfer auto

definition width :: "'a::{preorder,minus} interval \<Rightarrow> 'a"
  where "width i = upper i - lower i"

instantiation "interval" :: ("ordered_ab_semigroup_add") ab_semigroup_add
begin

lift_definition plus_interval::"'a interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval"
  is "\<lambda>(a, b). \<lambda>(c, d). (a + c, b + d)"
  by (auto intro!: add_mono)
lemma lower_plus[simp]: "lower (plus A B) = plus (lower A) (lower B)"
  by transfer auto
lemma upper_plus[simp]: "upper (plus A B) = plus (upper A) (upper B)"
  by transfer auto

instance proof qed (auto simp: interval_eq_iff less_eq_interval_def ac_simps)
end

instance "interval" :: ("{ordered_ab_semigroup_add, lattice}") ordered_ab_semigroup_add
proof qed (auto simp: less_eq_interval_def intro!: add_mono)

instantiation "interval" :: ("{preorder,zero}") zero
begin

lift_definition zero_interval::"'a interval" is "(0, 0)" by auto
lemma lower_zero[simp]: "lower 0 = 0"
  by transfer auto
lemma upper_zero[simp]: "upper 0 = 0"
  by transfer auto
instance proof qed
end

instance "interval" :: ("{ordered_comm_monoid_add}") comm_monoid_add
proof qed (auto simp: interval_eq_iff)

instance "interval" :: ("{ordered_comm_monoid_add,lattice}") ordered_comm_monoid_add ..

instantiation "interval" :: ("{ordered_ab_group_add}") uminus
begin

lift_definition uminus_interval::"'a interval \<Rightarrow> 'a interval" is "\<lambda>(a, b). (-b, -a)" by auto
lemma lower_uminus[simp]: "lower (- A) = - upper A"
  by transfer auto
lemma upper_uminus[simp]: "upper (- A) = - lower A"
  by transfer auto
instance ..
end

instantiation "interval" :: ("{ordered_ab_group_add}") minus
begin

definition minus_interval::"'a interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval"
  where "minus_interval a b = a + - b"
lemma lower_minus[simp]: "lower (minus A B) = minus (lower A) (upper B)"
  by (auto simp: minus_interval_def)
lemma upper_minus[simp]: "upper (minus A B) = minus (upper A) (lower B)"
  by (auto simp: minus_interval_def)

instance ..
end

instantiation "interval" :: (linordered_semiring) times
begin

lift_definition times_interval :: "'a interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval"
  is "\<lambda>(a1, a2). \<lambda>(b1, b2).
    (let x1 = a1 * b1; x2 = a1 * b2; x3 = a2 * b1; x4 = a2 * b2
    in (min x1 (min x2 (min x3 x4)), max x1 (max x2 (max x3 x4))))"
  by (auto simp: Let_def intro!: min.coboundedI1 max.coboundedI1)

lemma lower_times:
  "lower (times A B) = Min {lower A * lower B, lower A * upper B, upper A * lower B, upper A * upper B}"
  by transfer (auto simp: Let_def)

lemma upper_times:
  "upper (times A B) = Max {lower A * lower B, lower A * upper B, upper A * lower B, upper A * upper B}"
  by transfer (auto simp: Let_def)

instance ..
end

lemma interval_eq_set_of_iff: "X = Y \<longleftrightarrow> set_of X = set_of Y" for X Y::"'a::order interval"
  by (auto simp: set_of_eq interval_eq_iff)

subsection \<open>Membership\<close>

abbreviation (in preorder) in_interval ("(_/ \<in>\<^sub>i _)" [51, 51] 50)
  where "in_interval x X \<equiv> x \<in> set_of X"

lemma in_interval_to_interval[intro!]: "a \<in>\<^sub>i interval_of a"
  by (auto simp: set_of_eq)

lemma plus_in_intervalI:
  fixes x y :: "'a :: ordered_ab_semigroup_add"
  shows "x \<in>\<^sub>i X \<Longrightarrow> y \<in>\<^sub>i Y \<Longrightarrow> x + y \<in>\<^sub>i X + Y"
  by (simp add: add_mono_thms_linordered_semiring(1) set_of_eq)

lemma connected_set_of[intro, simp]:
  "connected (set_of X)" for X::"'a::linear_continuum_topology interval"
  by (auto simp: set_of_eq )

lemma ex_sum_in_interval_lemma: "\<exists>xa\<in>{la .. ua}. \<exists>xb\<in>{lb .. ub}. x = xa + xb"
  if "la \<le> ua" "lb \<le> ub" "la + lb \<le> x" "x \<le> ua + ub"
    "ua - la \<le> ub - lb"
  for la b c d::"'a::linordered_ab_group_add"
proof -
  define wa where "wa = ua - la"
  define wb where "wb = ub - lb"
  define w where "w = wa + wb"
  define d where "d = x - la - lb"
  define da where "da = max 0 (min wa (d - wa))"
  define db where "db = d - da"
  from that have nonneg: "0 \<le> wa" "0 \<le> wb" "0 \<le> w" "0 \<le> d" "d \<le> w"
    by (auto simp add: wa_def wb_def w_def d_def add.commute le_diff_eq)
  have "0 \<le> db"
    by (auto simp: da_def nonneg db_def intro!: min.coboundedI2)
  have "x = (la + da) + (lb + db)"
    by (simp add: da_def db_def d_def)
  moreover
  have "x - la - ub \<le> da"
    using that
    unfolding da_def
    by (intro max.coboundedI2) (auto simp: wa_def d_def diff_le_eq diff_add_eq)
  then have "db \<le> wb"
    by (auto simp: db_def d_def wb_def algebra_simps)
  with \<open>0 \<le> db\<close> that nonneg have "lb + db \<in> {lb..ub}"
    by (auto simp: wb_def algebra_simps)
  moreover
  have "da \<le> wa"
    by (auto simp: da_def nonneg)
  then have "la + da \<in> {la..ua}"
    by (auto simp: da_def wa_def algebra_simps)
  ultimately show ?thesis
    by force
qed

lemma ex_sum_in_interval: "\<exists>xa\<ge>la. xa \<le> ua \<and> (\<exists>xb\<ge>lb. xb \<le> ub \<and> x = xa + xb)"
  if a: "la \<le> ua" and b: "lb \<le> ub" and x: "la + lb \<le> x" "x \<le> ua + ub"
  for la b c d::"'a::linordered_ab_group_add"
proof -
  from linear consider "ua - la \<le> ub - lb" | "ub - lb \<le> ua - la"
    by blast
  then show ?thesis
  proof cases
    case 1
    from ex_sum_in_interval_lemma[OF that 1]
    show ?thesis by auto
  next
    case 2
    from x have "lb + la \<le> x" "x \<le> ub + ua" by (simp_all add: ac_simps)
    from ex_sum_in_interval_lemma[OF b a this 2]
    show ?thesis by auto
  qed
qed

lemma Icc_plus_Icc:
  "{a .. b} + {c .. d} = {a + c .. b + d}"
  if "a \<le> b" "c \<le> d"
  for a b c d::"'a::linordered_ab_group_add"
  using ex_sum_in_interval[OF that]
  by (auto intro: add_mono simp: atLeastAtMost_iff Bex_def set_plus_def)

lemma set_of_plus:
  fixes A :: "'a::linordered_ab_group_add interval"
  shows "set_of (A + B) = set_of A + set_of B"
  using Icc_plus_Icc[of "lower A" "upper A" "lower B" "upper B"]
  by (auto simp: set_of_eq)

lemma plus_in_intervalE:
  fixes xy :: "'a :: linordered_ab_group_add"
  assumes "xy \<in>\<^sub>i X + Y"
  obtains x y where "xy = x + y" "x \<in>\<^sub>i X" "y \<in>\<^sub>i Y"
  using assms
  unfolding set_of_plus set_plus_def
  by auto

lemma set_of_uminus: "set_of (-X) = {- x | x. x \<in> set_of X}"
  for X :: "'a :: ordered_ab_group_add interval"
  by (auto simp: set_of_eq simp: le_minus_iff minus_le_iff
      intro!: exI[where x="-x" for x])

lemma uminus_in_intervalI:
  fixes x :: "'a :: ordered_ab_group_add"
  shows "x \<in>\<^sub>i X \<Longrightarrow> -x \<in>\<^sub>i -X"
  by (auto simp: set_of_uminus)

lemma uminus_in_intervalD:
  fixes x :: "'a :: ordered_ab_group_add"
  shows "x \<in>\<^sub>i - X \<Longrightarrow> - x \<in>\<^sub>i X"
  by (auto simp: set_of_uminus)

lemma minus_in_intervalI:
  fixes x y :: "'a :: ordered_ab_group_add"
  shows "x \<in>\<^sub>i X \<Longrightarrow> y \<in>\<^sub>i Y \<Longrightarrow> x - y \<in>\<^sub>i X - Y"
  by (metis diff_conv_add_uminus minus_interval_def plus_in_intervalI uminus_in_intervalI)

lemma set_of_minus: "set_of (X - Y) = {x - y | x y . x \<in> set_of X \<and> y \<in> set_of Y}"
  for X Y :: "'a :: linordered_ab_group_add interval"
  unfolding minus_interval_def set_of_plus set_of_uminus set_plus_def
  by force

lemma times_in_intervalI:
  fixes x y::"'a::linordered_ring"
  assumes "x \<in>\<^sub>i X" "y \<in>\<^sub>i Y"
  shows "x * y \<in>\<^sub>i X * Y"
proof -
  define X1 where "X1 \<equiv> lower X"
  define X2 where "X2 \<equiv> upper X"
  define Y1 where "Y1 \<equiv> lower Y"
  define Y2 where "Y2 \<equiv> upper Y"
  from assms have assms: "X1 \<le> x" "x \<le> X2" "Y1 \<le> y" "y \<le> Y2"
    by (auto simp: X1_def X2_def Y1_def Y2_def set_of_eq)
  have "(X1 * Y1 \<le> x * y \<or> X1 * Y2 \<le> x * y \<or> X2 * Y1 \<le> x * y \<or> X2 * Y2 \<le> x * y) \<and>
        (X1 * Y1 \<ge> x * y \<or> X1 * Y2 \<ge> x * y \<or> X2 * Y1 \<ge> x * y \<or> X2 * Y2 \<ge> x * y)"
  proof (cases x "0::'a" rule: linorder_cases)
    case x0: less
    show ?thesis
    proof (cases "y < 0")
      case y0: True
      from y0 x0 assms have "x * y \<le> X1 * y" by (intro mult_right_mono_neg, auto)
      also from x0 y0 assms have "X1 * y \<le> X1 * Y1" by (intro mult_left_mono_neg, auto)
      finally have 1: "x * y \<le> X1 * Y1".
      show ?thesis proof(cases "X2 \<le> 0")
        case True
        with assms have "X2 * Y2 \<le> X2 * y" by (auto intro: mult_left_mono_neg)
        also from assms y0 have "... \<le> x * y" by (auto intro: mult_right_mono_neg)
        finally have "X2 * Y2 \<le> x * y".
        with 1 show ?thesis by auto
      next
        case False
        with assms have "X2 * Y1 \<le> X2 * y" by (auto intro: mult_left_mono)
        also from assms y0 have "... \<le> x * y" by (auto intro: mult_right_mono_neg)
        finally have "X2 * Y1 \<le> x * y".
        with 1 show ?thesis by auto
      qed
    next
      case False
      then have y0: "y \<ge> 0" by auto
      from x0 y0 assms have "X1 * Y2 \<le> x * Y2" by (intro mult_right_mono, auto)
      also from y0 x0 assms have "... \<le> x * y" by (intro mult_left_mono_neg, auto)
      finally have 1: "X1 * Y2 \<le> x * y".
      show ?thesis
      proof(cases "X2 \<le> 0")
        case X2: True
        from assms y0 have "x * y \<le> X2 * y" by (intro mult_right_mono)
        also from assms X2 have "... \<le> X2 * Y1" by (auto intro: mult_left_mono_neg)
        finally have "x * y \<le> X2 * Y1".
        with 1 show ?thesis by auto
      next
        case X2: False
        from assms y0 have "x * y \<le> X2 * y" by (intro mult_right_mono)
        also from assms X2 have "... \<le> X2 * Y2" by (auto intro: mult_left_mono)
        finally have "x * y \<le> X2 * Y2".
        with 1 show ?thesis by auto
      qed
    qed
  next
    case [simp]: equal
    with assms show ?thesis by (cases "Y2 \<le> 0", auto intro:mult_sign_intros)
  next
    case x0: greater
    show ?thesis
    proof (cases "y < 0")
      case y0: True
      from x0 y0 assms have "X2 * Y1 \<le> X2 * y" by (intro mult_left_mono, auto)
      also from y0 x0 assms have "X2 * y \<le> x * y" by (intro mult_right_mono_neg, auto)
      finally have 1: "X2 * Y1 \<le> x * y".
      show ?thesis
      proof(cases "Y2 \<le> 0")
        case Y2: True
        from x0 assms have "x * y \<le> x * Y2" by (auto intro: mult_left_mono)
        also from assms Y2 have "... \<le> X1 * Y2" by (auto intro: mult_right_mono_neg)
        finally have "x * y \<le> X1 * Y2".
        with 1 show ?thesis by auto
      next
        case Y2: False
        from x0 assms have "x * y \<le> x * Y2" by (auto intro: mult_left_mono)
        also from assms Y2 have "... \<le> X2 * Y2" by (auto intro: mult_right_mono)
        finally have "x * y \<le> X2 * Y2".
        with 1 show ?thesis by auto
      qed
    next
      case y0: False
      from x0 y0 assms have "x * y \<le> X2 * y" by (intro mult_right_mono, auto)
      also from y0 x0 assms have "... \<le> X2 * Y2" by (intro mult_left_mono, auto)
      finally have 1: "x * y \<le> X2 * Y2".
      show ?thesis
      proof(cases "X1 \<le> 0")
        case True
        with assms have "X1 * Y2 \<le> X1 * y" by (auto intro: mult_left_mono_neg)
        also from assms y0 have "... \<le> x * y" by (auto intro: mult_right_mono)
        finally have "X1 * Y2 \<le> x * y".
        with 1 show ?thesis by auto
      next
        case False
        with assms have "X1 * Y1 \<le> X1 * y" by (auto intro: mult_left_mono)
        also from assms y0 have "... \<le> x * y" by (auto intro: mult_right_mono)
        finally have "X1 * Y1 \<le> x * y".
        with 1 show ?thesis by auto
      qed
    qed
  qed
  hence min:"min (X1 * Y1) (min (X1 * Y2) (min (X2 * Y1) (X2 * Y2))) \<le> x * y"
    and max:"x * y \<le> max (X1 * Y1) (max (X1 * Y2) (max (X2 * Y1) (X2 * Y2)))"
    by (auto simp:min_le_iff_disj le_max_iff_disj)
  show ?thesis using min max
    by (auto simp: Let_def X1_def X2_def Y1_def Y2_def set_of_eq lower_times upper_times)
qed

lemma times_in_intervalE:
  fixes xy :: "'a :: {linordered_semiring, real_normed_algebra, linear_continuum_topology}"
    \<comment> \<open>TODO: linear continuum topology is pretty strong\<close>
  assumes "xy \<in>\<^sub>i X * Y"
  obtains x y where "xy = x * y" "x \<in>\<^sub>i X" "y \<in>\<^sub>i Y"
proof -
  let ?mult = "\<lambda>(x, y). x * y"
  let ?XY = "set_of X \<times> set_of Y"
  have cont: "continuous_on ?XY ?mult"
    by (auto intro!: tendsto_eq_intros simp: continuous_on_def split_beta')
  have conn: "connected (?mult ` ?XY)"
    by (rule connected_continuous_image[OF cont]) auto
  have "lower (X * Y) \<in> ?mult ` ?XY" "upper (X * Y) \<in> ?mult ` ?XY"
    by (auto simp: set_of_eq lower_times upper_times min_def max_def split: if_splits)
  from connectedD_interval[OF conn this, of xy] assms
  obtain x y where "xy = x * y" "x \<in>\<^sub>i X" "y \<in>\<^sub>i Y" by (auto simp: set_of_eq)
  then show ?thesis ..
qed

lemma set_of_times: "set_of (X * Y) = {x * y | x y. x \<in> set_of X \<and> y \<in> set_of Y}"
  for X Y::"'a :: {linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
  by (auto intro!: times_in_intervalI elim!: times_in_intervalE)

instance "interval" :: (linordered_idom) cancel_semigroup_add
proof qed (auto simp: interval_eq_iff)

lemma interval_mul_commute: "A * B = B * A" for A B:: "'a::linordered_idom interval"
  by (simp add: interval_eq_iff lower_times upper_times ac_simps)

lemma interval_times_zero_right[simp]: "A * 0 = 0" for A :: "'a::linordered_ring interval"
  by (simp add: interval_eq_iff lower_times upper_times ac_simps)

lemma interval_times_zero_left[simp]:
  "0 * A = 0" for A :: "'a::linordered_ring interval"
  by (simp add: interval_eq_iff lower_times upper_times ac_simps)

instantiation "interval" :: ("{preorder,one}") one
begin

lift_definition one_interval::"'a interval" is "(1, 1)" by auto
lemma lower_one[simp]: "lower 1 = 1"
  by transfer auto
lemma upper_one[simp]: "upper 1 = 1"
  by transfer auto
instance proof qed
end

instance interval :: ("{one, preorder, linordered_semiring}") power
proof qed

lemma set_of_one[simp]: "set_of (1::'a::{one, order} interval) = {1}"
  by (auto simp: set_of_eq)

instance "interval" ::
  ("{linordered_idom,linordered_ring, real_normed_algebra, linear_continuum_topology}") monoid_mult
  apply standard
  unfolding interval_eq_set_of_iff set_of_times
  subgoal
    by (auto simp: interval_eq_set_of_iff set_of_times; metis mult.assoc)
  by auto

lemma one_times_ivl_left[simp]: "1 * A = A" for A :: "'a::linordered_idom interval"
  by (simp add: interval_eq_iff lower_times upper_times ac_simps min_def max_def)

lemma one_times_ivl_right[simp]: "A * 1 = A" for A :: "'a::linordered_idom interval"
  by (metis interval_mul_commute one_times_ivl_left)

lemma set_of_power_mono: "a^n \<in> set_of (A^n)" if "a \<in> set_of A"
  for a :: "'a::linordered_idom"
  using that
  by (induction n) (auto intro!: times_in_intervalI)

lemma set_of_add_cong:
  "set_of (A + B) = set_of (A' + B')"
  if "set_of A = set_of A'" "set_of B = set_of B'"
  for A :: "'a::linordered_ab_group_add interval"
  unfolding set_of_plus that ..

lemma set_of_add_inc_left:
  "set_of (A + B) \<subseteq> set_of (A' + B)"
  if "set_of A \<subseteq> set_of A'"
  for A :: "'a::linordered_ab_group_add interval"
  unfolding set_of_plus using that by (auto simp: set_plus_def)

lemma set_of_add_inc_right:
  "set_of (A + B) \<subseteq> set_of (A + B')"
  if "set_of B \<subseteq> set_of B'"
  for A :: "'a::linordered_ab_group_add interval"
  using set_of_add_inc_left[OF that]
  by (simp add: add.commute)

lemma set_of_add_inc:
  "set_of (A + B) \<subseteq> set_of (A' + B')"
  if "set_of A \<subseteq> set_of A'" "set_of B \<subseteq> set_of B'"
  for A :: "'a::linordered_ab_group_add interval"
  using set_of_add_inc_left[OF that(1)] set_of_add_inc_right[OF that(2)]
  by auto

lemma set_of_neg_inc:
  "set_of (-A) \<subseteq> set_of (-A')"
  if "set_of A \<subseteq> set_of A'"
  for A :: "'a::ordered_ab_group_add interval"
  using that
  unfolding set_of_uminus
  by auto

lemma set_of_sub_inc_left:
  "set_of (A - B) \<subseteq> set_of (A' - B)"
  if "set_of A \<subseteq> set_of A'"
  for A :: "'a::linordered_ab_group_add interval"
  using that
  unfolding set_of_minus
  by auto

lemma set_of_sub_inc_right:
  "set_of (A - B) \<subseteq> set_of (A - B')"
  if "set_of B \<subseteq> set_of B'"
  for A :: "'a::linordered_ab_group_add interval"
  using that
  unfolding set_of_minus
  by auto

lemma set_of_sub_inc:
  "set_of (A - B) \<subseteq> set_of (A' - B')"
  if "set_of A \<subseteq> set_of A'" "set_of B \<subseteq> set_of B'"
  for A :: "'a::linordered_idom interval"
  using set_of_sub_inc_left[OF that(1)] set_of_sub_inc_right[OF that(2)]
  by auto

lemma set_of_mul_inc_right:
  "set_of (A * B) \<subseteq> set_of (A * B')"
  if "set_of B \<subseteq> set_of B'"
  for A :: "'a::linordered_ring interval"
  using that
  apply transfer
  apply (clarsimp simp add: Let_def)
  apply (intro conjI)
         apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
        apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
       apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
      apply (metis linear min.coboundedI1 min.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
     apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
    apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
   apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
  apply (metis linear max.coboundedI1 max.coboundedI2 mult_left_mono mult_left_mono_neg order_trans)
  done

lemma set_of_distrib_left:
  "set_of (B * (A1 + A2)) \<subseteq> set_of (B * A1 + B * A2)"
  for A1 :: "'a::linordered_ring interval"
  apply transfer
  apply (clarsimp simp: Let_def distrib_left distrib_right)
  apply (intro conjI)
         apply (metis add_mono min.cobounded1 min.left_commute)
        apply (metis add_mono min.cobounded1 min.left_commute)
       apply (metis add_mono min.cobounded1 min.left_commute)
      apply (metis add_mono min.assoc min.cobounded2)
     apply (meson add_mono order.trans max.cobounded1 max.cobounded2)
    apply (meson add_mono order.trans max.cobounded1 max.cobounded2)
   apply (meson add_mono order.trans max.cobounded1 max.cobounded2)
  apply (meson add_mono order.trans max.cobounded1 max.cobounded2)
  done

lemma set_of_distrib_right:
  "set_of ((A1 + A2) * B) \<subseteq> set_of (A1 * B + A2 * B)"
  for A1 A2 B :: "'a::{linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
  unfolding set_of_times set_of_plus set_plus_def
  apply clarsimp
  subgoal for b a1 a2
    apply (rule exI[where x="a1 * b"])
    apply (rule conjI)
    subgoal by force
    subgoal
      apply (rule exI[where x="a2 * b"])
      apply (rule conjI)
      subgoal by force
      subgoal by (simp add: algebra_simps)
      done
    done
  done

lemma set_of_mul_inc_left:
  "set_of (A * B) \<subseteq> set_of (A' * B)"
  if "set_of A \<subseteq> set_of A'"
  for A :: "'a::{linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
  using that
  unfolding set_of_times
  by auto

lemma set_of_mul_inc:
  "set_of (A * B) \<subseteq> set_of (A' * B')"
  if "set_of A \<subseteq> set_of A'" "set_of B \<subseteq> set_of B'"
  for A :: "'a::{linordered_ring, real_normed_algebra, linear_continuum_topology} interval"
  using that unfolding set_of_times by auto

lemma set_of_pow_inc:
  "set_of (A^n) \<subseteq> set_of (A'^n)"
  if "set_of A \<subseteq> set_of A'"
  for A :: "'a::{linordered_idom, real_normed_algebra, linear_continuum_topology} interval"
  using that
  by (induction n, simp_all add: set_of_mul_inc)

lemma set_of_distrib_right_left:
  "set_of ((A1 + A2) * (B1 + B2)) \<subseteq> set_of (A1 * B1 + A1 * B2 + A2 * B1 + A2 * B2)"
  for A1 :: "'a::{linordered_idom, real_normed_algebra, linear_continuum_topology} interval"
proof-
  have "set_of ((A1 + A2) * (B1 + B2)) \<subseteq> set_of (A1 * (B1 + B2) + A2 * (B1 + B2))"
    by (rule set_of_distrib_right)
  also have "... \<subseteq> set_of ((A1 * B1 + A1 * B2) + A2 * (B1 + B2))"
    by (rule set_of_add_inc_left[OF set_of_distrib_left])
  also have "... \<subseteq> set_of ((A1 * B1 + A1 * B2) + (A2 * B1 + A2 * B2))"
    by (rule set_of_add_inc_right[OF set_of_distrib_left])
  finally show ?thesis
    by (simp add: add.assoc)
qed

lemma mult_bounds_enclose_zero1:
  "min (la * lb) (min (la * ub) (min (lb * ua) (ua * ub))) \<le> 0"
  "0 \<le> max (la * lb) (max (la * ub) (max (lb * ua) (ua * ub)))"
  if "la \<le> 0" "0 \<le> ua"
  for la lb ua ub:: "'a::linordered_idom"
  subgoal by (metis (no_types, opaque_lifting) that eq_iff min_le_iff_disj mult_zero_left mult_zero_right
        zero_le_mult_iff)
  subgoal by (metis that le_max_iff_disj mult_zero_right order_refl zero_le_mult_iff)
  done

lemma mult_bounds_enclose_zero2:
  "min (la * lb) (min (la * ub) (min (lb * ua) (ua * ub))) \<le> 0"
  "0 \<le> max (la * lb) (max (la * ub) (max (lb * ua) (ua * ub)))"
  if "lb \<le> 0" "0 \<le> ub"
  for la lb ua ub:: "'a::linordered_idom"
  using mult_bounds_enclose_zero1[OF that, of la ua]
  by (simp_all add: ac_simps)

lemma set_of_mul_contains_zero:
  "0 \<in> set_of (A * B)"
  if "0 \<in> set_of A \<or> 0 \<in> set_of B"
  for A :: "'a::linordered_idom interval"
  using that
  by (auto simp: set_of_eq lower_times upper_times algebra_simps mult_le_0_iff
      mult_bounds_enclose_zero1 mult_bounds_enclose_zero2)

instance "interval" :: (linordered_semiring) mult_zero
  apply standard
  subgoal by transfer auto
  subgoal by transfer auto
  done

lift_definition min_interval::"'a::linorder interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval" is
  "\<lambda>(l1, u1). \<lambda>(l2, u2). (min l1 l2, min u1 u2)"
  by (auto simp: min_def)
lemma lower_min_interval[simp]: "lower (min_interval x y) = min (lower x) (lower y)"
  by transfer auto
lemma upper_min_interval[simp]: "upper (min_interval x y) = min (upper x) (upper y)"
  by transfer auto

lemma min_intervalI:
  "a \<in>\<^sub>i A \<Longrightarrow> b \<in>\<^sub>i B \<Longrightarrow> min a b \<in>\<^sub>i min_interval A B"
  by (auto simp: set_of_eq min_def)

lift_definition max_interval::"'a::linorder interval \<Rightarrow> 'a interval \<Rightarrow> 'a interval" is
  "\<lambda>(l1, u1). \<lambda>(l2, u2). (max l1 l2, max u1 u2)"
  by (auto simp: max_def)
lemma lower_max_interval[simp]: "lower (max_interval x y) = max (lower x) (lower y)"
  by transfer auto
lemma upper_max_interval[simp]: "upper (max_interval x y) = max (upper x) (upper y)"
  by transfer auto

lemma max_intervalI:
  "a \<in>\<^sub>i A \<Longrightarrow> b \<in>\<^sub>i B \<Longrightarrow> max a b \<in>\<^sub>i max_interval A B"
  by (auto simp: set_of_eq max_def)

lift_definition abs_interval::"'a::linordered_idom interval \<Rightarrow> 'a interval" is
  "(\<lambda>(l,u). (if l < 0 \<and> 0 < u then 0 else min \<bar>l\<bar> \<bar>u\<bar>, max \<bar>l\<bar> \<bar>u\<bar>))"
  by auto

lemma lower_abs_interval[simp]:
  "lower (abs_interval x) = (if lower x < 0 \<and> 0 < upper x then 0 else min \<bar>lower x\<bar> \<bar>upper x\<bar>)"
  by transfer auto
lemma upper_abs_interval[simp]: "upper (abs_interval x) = max \<bar>lower x\<bar> \<bar>upper x\<bar>"
  by transfer auto

lemma in_abs_intervalI1:
  "lx < 0 \<Longrightarrow> 0 < ux \<Longrightarrow> 0 \<le> xa \<Longrightarrow> xa \<le> max (- lx) (ux) \<Longrightarrow> xa \<in> abs ` {lx..ux}"
  for xa::"'a::linordered_idom"
  by (metis abs_minus_cancel abs_of_nonneg atLeastAtMost_iff image_eqI le_less le_max_iff_disj
      le_minus_iff neg_le_0_iff_le order_trans)

lemma in_abs_intervalI2:
  "min (\<bar>lx\<bar>) \<bar>ux\<bar> \<le> xa \<Longrightarrow> xa \<le> max \<bar>lx\<bar> \<bar>ux\<bar> \<Longrightarrow> lx \<le> ux \<Longrightarrow> 0 \<le> lx \<or> ux \<le> 0 \<Longrightarrow>
    xa \<in> abs ` {lx..ux}"
  for xa::"'a::linordered_idom"
  by (force intro: image_eqI[where x="-xa"] image_eqI[where x="xa"])

lemma set_of_abs_interval: "set_of (abs_interval x) = abs ` set_of x"
  by (auto simp: set_of_eq not_less intro: in_abs_intervalI1 in_abs_intervalI2 cong del: image_cong_simp)

fun split_domain :: "('a::preorder interval \<Rightarrow> 'a interval list) \<Rightarrow> 'a interval list \<Rightarrow> 'a interval list list"
  where "split_domain split [] = [[]]"
  | "split_domain split (I#Is) = (
         let S = split I;
             D = split_domain split Is
         in concat (map (\<lambda>d. map (\<lambda>s. s # d) S) D)
       )"

context notes [[typedef_overloaded]] begin
lift_definition(code_dt) split_interval::"'a::linorder interval \<Rightarrow> 'a \<Rightarrow> ('a interval \<times> 'a interval)"
  is "\<lambda>(l, u) x. ((min l x, max l x), (min u x, max u x))"
  by (auto simp: min_def)
end

lemma split_domain_nonempty:
  assumes "\<And>I. split I \<noteq> []"
  shows "split_domain split I \<noteq> []"
  using last_in_set assms
  by (induction I, auto)

lemma lower_split_interval1: "lower (fst (split_interval X m)) = min (lower X) m"
  and lower_split_interval2: "lower (snd (split_interval X m)) = min (upper X) m"
  and upper_split_interval1: "upper (fst (split_interval X m)) = max (lower X) m"
  and upper_split_interval2: "upper (snd (split_interval X m)) = max (upper X) m"
  subgoal by transfer auto
  subgoal by transfer (auto simp: min.commute)
  subgoal by transfer auto
  subgoal by transfer auto
  done

lemma split_intervalD: "split_interval X x = (A, B) \<Longrightarrow> set_of X \<subseteq> set_of A \<union> set_of B"
  unfolding set_of_eq
  by transfer (auto simp: min_def max_def split: if_splits)

instantiation interval :: ("{topological_space, preorder}") topological_space
begin

definition open_interval_def[code del]: "open (X::'a interval set) =
  (\<forall>x\<in>X.
      \<exists>A B.
         open A \<and>
         open B \<and>
         lower x \<in> A \<and> upper x \<in> B \<and> Interval ` (A \<times> B) \<subseteq> X)"

instance
proof
  show "open (UNIV :: ('a interval) set)"
    unfolding open_interval_def by auto
next
  fix S T :: "('a interval) set"
  assume "open S" "open T"
  show "open (S \<inter> T)"
    unfolding open_interval_def
  proof (safe)
    fix x assume "x \<in> S" "x \<in> T"
    from \<open>x \<in> S\<close> \<open>open S\<close> obtain Sl Su where S:
      "open Sl" "open Su" "lower x \<in> Sl" "upper x \<in> Su" "Interval ` (Sl \<times> Su) \<subseteq> S"
      by (auto simp: open_interval_def)
    from \<open>x \<in> T\<close> \<open>open T\<close> obtain Tl Tu where T:
      "open Tl" "open Tu" "lower x \<in> Tl" "upper x \<in> Tu" "Interval ` (Tl \<times> Tu) \<subseteq> T"
      by (auto simp: open_interval_def)

    let ?L = "Sl \<inter> Tl" and ?U = "Su \<inter> Tu"
    have "open ?L \<and> open ?U \<and> lower x \<in> ?L \<and> upper x \<in> ?U \<and> Interval ` (?L \<times> ?U) \<subseteq> S \<inter> T"
      using S T by (auto simp add: open_Int)
    then show "\<exists>A B. open A \<and> open B \<and> lower x \<in> A \<and> upper x \<in> B \<and> Interval ` (A \<times> B) \<subseteq> S \<inter> T"
      by fast
  qed
qed (unfold open_interval_def, fast)

end

subsection \<open>Quickcheck\<close>

lift_definition Ivl::"'a \<Rightarrow> 'a::preorder \<Rightarrow> 'a interval" is "\<lambda>a b. (min a b, b)"
  by (auto simp: min_def)

instantiation interval :: ("{exhaustive,preorder}") exhaustive
begin

definition exhaustive_interval::"('a interval \<Rightarrow> (bool \<times> term list) option)
     \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
  where
    "exhaustive_interval f d =
    Quickcheck_Exhaustive.exhaustive (\<lambda>x. Quickcheck_Exhaustive.exhaustive (\<lambda>y. f (Ivl x y)) d) d"

instance ..

end

context
  includes term_syntax
begin

definition [code_unfold]:
  "valtermify_interval x y = Code_Evaluation.valtermify (Ivl::'a::{preorder,typerep}\<Rightarrow>_) {\<cdot>} x {\<cdot>} y"

end

instantiation interval :: ("{full_exhaustive,preorder,typerep}") full_exhaustive
begin

definition full_exhaustive_interval::
  "('a interval \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
     \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option" where
  "full_exhaustive_interval f d =
    Quickcheck_Exhaustive.full_exhaustive
      (\<lambda>x. Quickcheck_Exhaustive.full_exhaustive (\<lambda>y. f (valtermify_interval x y)) d) d"

instance ..

end

instantiation interval :: ("{random,preorder,typerep}") random
begin

definition random_interval ::
  "natural
  \<Rightarrow> natural \<times> natural
     \<Rightarrow> ('a interval \<times> (unit \<Rightarrow> term)) \<times> natural \<times> natural" where
  "random_interval i =
  scomp (Quickcheck_Random.random i)
    (\<lambda>man. scomp (Quickcheck_Random.random i) (\<lambda>exp. Pair (valtermify_interval man exp)))"

instance ..

end

lifting_update interval.lifting
lifting_forget interval.lifting

end