section \<open>Young's Inequality for Increasing Functions\<close>

text \<open>From the following paper:
Cunningham, F., and Nathaniel Grossman. “On Young’s Inequality.”
The American Mathematical Monthly 78, no. 7 (1971): 781–83.
\url{https://doi.org/10.2307/2318018}\<close>

theory Youngs imports
  "HOL-Analysis.Analysis"

begin

subsection \<open>Library Extras: already added to the repository\<close>

text \<open>In fact, strict inequality is required only at a single point within the box.\<close>
lemma integral_less:
  fixes f :: "'n::euclidean_space \<Rightarrow> real"
  assumes cont: "continuous_on (cbox a b) f" "continuous_on (cbox a b) g" and ne: "box a b \<noteq> {}"
    and fg: "\<And>x. x \<in> box a b \<Longrightarrow> f x < g x"
  shows "integral (cbox a b) f < integral (cbox a b) g"
proof -
  obtain int: "f integrable_on (cbox a b)" "g integrable_on (cbox a b)"
    using cont integrable_continuous by blast
  then have "integral (cbox a b) f \<le> integral (cbox a b) g"
    by (metis fg integrable_on_open_interval integral_le integral_open_interval less_eq_real_def)
  moreover have "integral (cbox a b) f \<noteq> integral (cbox a b) g"
  proof (rule ccontr)
    assume "\<not> integral (cbox a b) f \<noteq> integral (cbox a b) g"
    then have 0: "((\<lambda>x. g x - f x) has_integral 0) (cbox a b)"
      by (metis (full_types) cancel_comm_monoid_add_class.diff_cancel has_integral_diff int
                integrable_integral)
    have cgf: "continuous_on (cbox a b) (\<lambda>x. g x - f x)"
      using cont continuous_on_diff by blast
    show False
      using has_integral_0_cbox_imp_0 [OF cgf _ 0] ne box_subset_cbox fg by fastforce
  qed
  ultimately show ?thesis
    by linarith
qed

lemma integral_less_real:
  fixes f :: "real \<Rightarrow> real"
  assumes "continuous_on {a..b} f" "continuous_on {a..b} g" and "{a<..<b} \<noteq> {}"
    and "\<And>x. x \<in> {a<..<b} \<Longrightarrow> f x < g x"
  shows "integral {a..b} f < integral {a..b} g"
  by (metis assms box_real integral_less)

lemma has_integral_UN:
  fixes f :: "'n::euclidean_space \<Rightarrow> 'a::banach"
  assumes "finite I"
    and int: "\<And>i. i \<in> I \<Longrightarrow> (f has_integral (g i)) (\<T> i)"
    and neg: "pairwise (\<lambda>i i'. negligible (\<T> i \<inter> \<T> i')) I"
  shows "(f has_integral (sum g I)) (\<Union>i\<in>I. \<T> i)"
proof -
  let ?\<U> = "((\<lambda>(a,b). \<T> a \<inter> \<T> b) ` {(a,b). a \<in> I \<and> b \<in> I-{a}})"
  have "((\<lambda>x. if x \<in> (\<Union>i\<in>I. \<T> i) then f x else 0) has_integral sum g I) UNIV"
  proof (rule has_integral_spike)
    show "negligible (\<Union>?\<U>)"
    proof (rule negligible_Union)
      have "finite (I \<times> I)"
        by (simp add: \<open>finite I\<close>)
      moreover have "{(a,b). a \<in> I \<and> b \<in> I-{a}} \<subseteq> I \<times> I"
        by auto
      ultimately show "finite ?\<U>"
        by (simp add: finite_subset)
      show "\<And>t. t \<in> ?\<U> \<Longrightarrow> negligible t"
        using neg unfolding pairwise_def by auto
    qed
  next
    show "(if x \<in> (\<Union>i\<in>I. \<T> i) then f x else 0) = (\<Sum>i\<in>I. if x \<in> \<T> i then f x else 0)"
      if "x \<in> UNIV - (\<Union>?\<U>)" for x
    proof clarsimp
      fix i assume i: "i \<in> I" "x \<in> \<T> i"
      then have "\<forall>j\<in>I. x \<in> \<T> j \<longleftrightarrow> j = i"
        using that by blast
      with i show "f x = (\<Sum>i\<in>I. if x \<in> \<T> i then f x else 0)"
        by (simp add: sum.delta[OF \<open>finite I\<close>])
    qed
  next
    show "((\<lambda>x. (\<Sum>i\<in>I. if x \<in> \<T> i then f x else 0)) has_integral sum g I) UNIV"
      using int by (simp add: has_integral_restrict_UNIV has_integral_sum[OF \<open>finite I\<close>])
  qed
  then show ?thesis
    using has_integral_restrict_UNIV by blast
qed

lemma integrable_mono_on_nonneg:
  fixes f :: "real \<Rightarrow> real"
  assumes mon: "mono_on {a..b} f" and 0: "\<And>x. 0 \<le> f x"
  shows "integrable (lebesgue_on {a..b}) f"
proof -
  have "space lborel = space lebesgue" "sets borel \<subseteq> sets lebesgue"
    by force+
  then have fborel: "f \<in> borel_measurable (lebesgue_on {a..b})"
    by (metis mon borel_measurable_mono_on_fnc borel_measurable_subalgebra mono_restrict_space
              space_lborel space_restrict_space)
  then obtain g where g: "incseq g" and simple: "\<And>i. simple_function (lebesgue_on {a..b}) (g i)"
                and bdd: " (\<forall>x. bdd_above (range (\<lambda>i. g i x)))" and nonneg: "\<forall>i x. 0 \<le> g i x"
                and fsup: "f = (SUP i. g i)"
    by (metis borel_measurable_implies_simple_function_sequence_real 0)
  have "f ` {a..b} \<subseteq> {f a..f b}"
    using assms by (auto simp: mono_on_def)
  have g_le_f: "g i x \<le> f x" for i x
  proof -
    have "bdd_above ((\<lambda>h. h x) ` range g)"
      using bdd cSUP_lessD linorder_not_less by fastforce
    then show ?thesis
      by (metis SUP_apply UNIV_I bdd cSUP_upper fsup)
  qed
  then have gfb: "g i x \<le> f b" if "x \<in> {a..b}" for i x
    by (smt (verit, best) mon atLeastAtMost_iff mono_on_def that)
  have g_le: "g i x \<le> g j x" if "i\<le>j"  for i j x
    using g by (simp add: incseq_def le_funD that)
  show "integrable (lebesgue_on {a..b}) ( f)"
  proof (rule integrable_dominated_convergence)
    show "f \<in> borel_measurable (lebesgue_on {a..b})"
      using fborel by blast
    have "\<And>x. (\<lambda>i. g i x) \<longlonglongrightarrow> (SUP h \<in> range g. h  x)"
    proof (rule order_tendstoI)
      show "\<forall>\<^sub>F i in sequentially. y < g i x"
        if "y < (SUP h\<in>range g. h x)" for x y
      proof -
        from that obtain h where h: "h \<in> range g" "y < h x"
          using g_le_f by (subst (asm)less_cSUP_iff) fastforce+
        then show ?thesis
          by (smt (verit, ccfv_SIG) eventually_sequentially g_le imageE)
      qed
      show "\<forall>\<^sub>F i in sequentially. g i x < y"
        if "(SUP h\<in>range g. h x) < y" for x y
        by (smt (verit, best) that Sup_apply g_le_f always_eventually fsup image_cong)
    qed
    then show "AE x in lebesgue_on {a..b}. (\<lambda>i. g i x) \<longlonglongrightarrow> f x"
      by (simp add: fsup)
    fix i
    show "g i \<in> borel_measurable (lebesgue_on {a..b})"
      using borel_measurable_simple_function simple by blast
    show "AE x in lebesgue_on {a..b}. norm (g i x) \<le> f b"
      by (simp add: gfb nonneg Measure_Space.AE_I' [of "{}"])
  qed auto
qed

lemma integrable_mono_on:
  fixes f :: "real \<Rightarrow> real"
  assumes "mono_on {a..b} f"
  shows "integrable (lebesgue_on {a..b}) f"
proof -
  define f' where "f' \<equiv> \<lambda>x. if x \<in> {a..b} then f x - f a else 0"
  have "mono_on {a..b} f'"
    by (smt (verit, best) assms f'_def mono_on_def)
  moreover have 0: "\<And>x. 0 \<le> f' x"
    by (smt (verit, best) assms atLeastAtMost_iff f'_def mono_on_def)
  ultimately have "integrable (lebesgue_on {a..b}) f'"
    using integrable_mono_on_nonneg by presburger
  then have "integrable (lebesgue_on {a..b}) (\<lambda>x. f' x + f a)"
    by force
  moreover have "space lborel = space lebesgue" "sets borel \<subseteq> sets lebesgue"
    by force+
  then have fborel: "f \<in> borel_measurable (lebesgue_on {a..b})"
    using borel_measurable_mono_on_fnc [OF assms]
    by (metis borel_measurable_subalgebra mono_restrict_space space_lborel space_restrict_space)
  ultimately show ?thesis
    by (rule integrable_cong_AE_imp) (auto simp: f'_def)
qed

lemma integrable_on_mono_on:
  fixes f :: "real \<Rightarrow> real"
  assumes "mono_on {a..b} f"
  shows "f integrable_on {a..b}"
  by (simp add: assms integrable_mono_on integrable_on_lebesgue_on)

lemma strict_mono_image_endpoints:
  fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
  assumes "strict_mono_on {a..b} f" and f: "continuous_on {a..b} f" and "a \<le> b"
  shows "f ` {a..b} = {f a..f b}"
proof
  show "f ` {a..b} \<subseteq> {f a..f b}"
    using assms(1) strict_mono_on_leD by fastforce
  show "{f a..f b} \<subseteq> f ` {a..b}"
    using assms IVT'[OF _ _ _ f] by (force simp: Bex_def)
qed

subsection \<open>Toward Young's inequality\<close>

text \<open>Generalisations of the type of @{term f} are not obvious\<close>
lemma strict_mono_continuous_invD:
  fixes f :: "real \<Rightarrow> real"
  assumes sm: "strict_mono_on {a..} f" and contf: "continuous_on {a..} f"
    and fim: "f ` {a..} = {f a..}" and g: "\<And>x. x \<ge> a \<Longrightarrow> g (f x) = x"
  shows "continuous_on {f a..} g"
proof (clarsimp simp add: continuous_on_eq_continuous_within)
  fix y
  assume "f a \<le> y"
  then obtain u where u: "y+1 = f u" "u \<ge> a"
    by (smt (verit, best) atLeast_iff fim imageE)
  have "continuous_on {f a..y+1} g"
  proof -
    obtain "continuous_on {a..u} f"  "strict_mono_on {a..u} f"
      using contf sm continuous_on_subset by (force simp add: strict_mono_on_def)
    moreover have "continuous_on (f ` {a..u}) g"
      using assms continuous_on_subset
      by (intro continuous_on_inv) fastforce+
    ultimately show ?thesis
      using strict_mono_image_endpoints [of _ _ f]
      by (simp add: strict_mono_image_endpoints u)
  qed
  then have *: "continuous (at y within {f a..y+1}) g"
    by (simp add: \<open>f a \<le> y\<close> continuous_on_imp_continuous_within)
  show "continuous (at y within {f a..}) g"
  proof (clarsimp simp add: continuous_within_topological Ball_def)
    fix B
    assume "open B" and "g y \<in> B"
    with * obtain A where A: "open A" "y \<in> A" and "\<And>x. f a \<le> x \<and> x \<le> y+1 \<Longrightarrow> x \<in> A \<longrightarrow> g x \<in> B"
      by (force simp: continuous_within_topological)
    then have "\<forall>x\<ge>f a. x \<in> A \<inter> ball y 1 \<longrightarrow> g x \<in> B"
      by (smt (verit, ccfv_threshold) IntE dist_norm mem_ball real_norm_def)
    then show "\<exists>A. open A \<and> y \<in> A \<and> (\<forall>x\<ge>f a. x \<in> A \<longrightarrow> g x \<in> B)"
      by (metis Elementary_Metric_Spaces.open_ball Int_iff A centre_in_ball open_Int zero_less_one)
  qed
qed

subsection \<open>Regular divisions\<close>

text \<open>Our lack of the Riemann integral forces us to construct explicitly
the step functions mentioned in the text.\<close>

definition "segment \<equiv> \<lambda>n k. {real k / real n..(1 + k) / real n}"

lemma segment_nonempty: "segment n k \<noteq> {}"
  by (auto simp: segment_def divide_simps)

lemma segment_Suc: "segment n ` {..<Suc k} = insert {k/n..(1 + real k) / n} (segment n ` {..<k})"
  by (simp add: segment_def lessThan_Suc)

lemma Union_segment_image: "\<Union> (segment n ` {..<k}) = (if k=0 then {} else {0..real k/real n})"
proof (induction k)
  case (Suc k)
  then show ?case
    by (simp add: divide_simps segment_Suc Un_commute ivl_disj_un_two_touch split: if_split_asm)
qed (auto simp: segment_def)

definition "segments \<equiv> \<lambda>n. segment n ` {..<n}"

lemma card_segments [simp]: "card (segments n) = n"
  by (simp add: segments_def segment_def card_image divide_right_mono inj_on_def)

lemma segments_0 [simp]: "segments 0 = {}"
  by (simp add: segments_def)

lemma Union_segments: "\<Union> (segments n) = (if n=0 then {} else {0..1})"
  by (simp add: segments_def Union_segment_image)

definition "regular_division \<equiv> \<lambda>a b n. (image ((+) a \<circ> (*) (b-a))) ` (segments n)"

lemma translate_scale_01:
  assumes "a \<le> b"
  shows "(\<lambda>x. a + (b - a) * x) ` {0..1} = {a..b::real}"
  using closed_segment_real_eq [of a b] assms closed_segment_eq_real_ivl by auto

lemma finite_regular_division [simp]: "finite (regular_division a b n)"
  by (simp add: regular_division_def segments_def)

lemma card_regular_division [simp]:
  assumes "a<b"
  shows "card (regular_division a b n) = n"
proof -
  have "inj_on ((`) ((+) a \<circ> (*) (b - a))) (segments n)"
  proof
    fix x y
    assume "((+) a \<circ> (*) (b - a)) ` x = ((+) a \<circ> (*) (b - a)) ` y"
    then have "(+) (-a) ` ((+) a \<circ> (*) (b - a)) ` x = (+) (-a) ` ((+) a \<circ> (*) (b - a)) ` y"
      by simp
    then have "((*) (b - a)) ` x = ((*) (b - a)) ` y"
      by (simp add: image_comp)
    then have "(*) (inverse(b - a)) ` (*) (b - a) ` x = (*) (inverse(b - a)) ` (*) (b - a) ` y"
      by simp
    then show "x = y"
      using assms by (simp add: image_comp mult_ac)
  qed
  then show ?thesis
    by (metis card_image card_segments regular_division_def)
qed

lemma Union_regular_division:
  assumes "a \<le> b"
  shows "\<Union>(regular_division a b n) = (if n=0 then {} else {a..b})"
  using assms
  by (auto simp: regular_division_def Union_segments translate_scale_01 simp flip: image_Union)

lemma regular_division_eqI:
  assumes K: "K = {a + (b-a)*(real k / n) .. a + (b-a)*((1 + real k) / n)}"
    and "a<b" "k < n"
  shows "K \<in> regular_division a b n"
  unfolding regular_division_def segments_def image_comp
proof
  have "K = (\<lambda>x. (b-a) * x + a) ` {real k / real n..(1 + real k) / real n}"
    using K \<open>a<b\<close> by (simp add: image_affinity_atLeastAtMost divide_simps)
  then show "K = ((`) ((+) a \<circ> (*) (b - a)) \<circ> segment n) k"
    by (simp add: segment_def add.commute)
qed (use assms in auto)

lemma regular_divisionE:
  assumes "K \<in> regular_division a b n" "a<b"
  obtains k where "k<n" "K = {a + (b-a)*(real k / n) .. a + (b-a)*((1 + real k) / n)}"
proof -
  have eq: "(\<lambda>x. a + (b - a) * x) = (\<lambda>x. a + x) \<circ> (\<lambda>x. (b - a) * x)"
    by (simp add: o_def)
  obtain k where "k<n" "K = ((\<lambda>x. a+x) \<circ> (\<lambda>x. (b-a) * x)) ` {k/n .. (1 + real k) / n}"
    using assms by (auto simp: regular_division_def segments_def segment_def)
  with that \<open>a<b\<close> show ?thesis
    unfolding image_comp [symmetric]  by auto
qed

lemma regular_division_division_of:
  assumes "a < b" "n>0"
  shows "(regular_division a b n) division_of {a..b}"
proof (rule division_ofI)
  show "finite (regular_division a b n)"
    by (simp add: regular_division_def segments_def)
  show \<section>: "\<Union> (regular_division a b n) = {a..b}"
    using Union_regular_division assms by simp
  fix K
  assume K: "K \<in> regular_division a b n"
  then obtain k where Keq: "K = {a + (b-a)*(k/n) .. a + (b-a)*((1 + real k) / n)}"
    using \<open>a<b\<close> regular_divisionE by meson
  show "K \<subseteq> {a..b}"
    using K Union_regular_division \<open>n>0\<close> by (metis Union_upper \<section>)
  show "K \<noteq> {}"
    using K by (auto simp: regular_division_def segment_nonempty segments_def)
  show "\<exists>a b. K = cbox a b"
    by (metis K \<open>a<b\<close> box_real(2) regular_divisionE)
  fix K'
  assume K': "K' \<in> regular_division a b n" and "K \<noteq> K'"
  then obtain k' where Keq': "K' = {a + (b-a)*(k'/n) .. a + (b-a)*((1 + real k') / n)}"
    using K \<open>a<b\<close> regular_divisionE by meson
  consider "1 + real k \<le> k'" | "1 + real k' \<le> k"
    using Keq Keq' \<open>K \<noteq> K'\<close> by force
  then show "interior K \<inter> interior K' = {}"
  proof cases
    case 1
    then show ?thesis
      by (simp add: Keq Keq' min_def max_def divide_right_mono assms)
  next
    case 2
    then have "interior K' \<inter> interior K = {}"
      by (simp add: Keq Keq' min_def max_def divide_right_mono assms)
    then show ?thesis
      by (simp add: inf_commute)
  qed
qed

subsection \<open>Special cases of Young's inequality\<close>

lemma weighted_nesting_sum:
  fixes g :: "nat \<Rightarrow> 'a::comm_ring_1"
  shows "(\<Sum>k<n. (1 + of_nat k) * (g (Suc k) - g k)) = of_nat n * g n - (\<Sum>i<n. g i)"
  by (induction n) (auto simp: algebra_simps)

theorem Youngs_exact:
  fixes f :: "real \<Rightarrow> real"
  assumes sm: "strict_mono_on {0..} f" and cont: "continuous_on {0..} f" and a: "a\<ge>0"
    and f: "f 0 = 0" "f a = b"
    and g: "\<And>x. \<lbrakk>0 \<le> x; x \<le> a\<rbrakk> \<Longrightarrow> g (f x) = x"
  shows "a*b = integral {0..a} f + integral {0..b} g"
proof (cases "a=0")
  case False
  with \<open>a \<ge> 0\<close> have "a > 0" by linarith
  then have "b \<ge> 0"
    by (smt (verit, best) atLeast_iff f sm strict_mono_onD)
  have sm_0a: "strict_mono_on {0..a} f"
    by (metis atLeastAtMost_iff atLeast_iff sm strict_mono_on_def)
  have cont_0a: "continuous_on {0..a} f"
    using cont continuous_on_subset by fastforce
  with sm_0a have "continuous_on {0..b} g"
    by (metis a atLeastAtMost_iff compact_Icc continuous_on_inv f g strict_mono_image_endpoints)
  then have intgb_g: "g integrable_on {0..b}"
    using integrable_continuous_interval by blast
  have intgb_f: "f integrable_on {0..a}"
    using cont_0a integrable_continuous_real by blast

  have f_iff [simp]: "f x < f y \<longleftrightarrow> x < y" "f x \<le> f y \<longleftrightarrow> x \<le> y"
    if "x \<ge> 0" "y \<ge> 0" for x y
    using that by (smt (verit, best) atLeast_iff sm strict_mono_onD)+
  have fim: "f ` {0..a} = {0..b}"
    by (simp add: \<open>a \<ge> 0\<close> cont_0a strict_mono_image_endpoints strict_mono_on_def f)
  have "uniformly_continuous_on {0..a} f"
    using compact_uniformly_continuous cont_0a by blast
  then obtain del where del_gt0: "\<And>e. e>0 \<Longrightarrow> del e > 0"
        and del:  "\<And>e x x'. \<lbrakk>\<bar>x'-x\<bar> < del e; e>0; x \<in> {0..a}; x' \<in> {0..a}\<rbrakk> \<Longrightarrow> \<bar>f x' - f x\<bar> < e"
    unfolding uniformly_continuous_on_def dist_real_def by metis

  have *: "\<bar>a * b - integral {0..a} f - integral {0..b} g\<bar> < 2*\<epsilon>" if "\<epsilon> > 0" for \<epsilon>
  proof -
    define \<delta> where "\<delta> = min a (del (\<epsilon>/a)) / 2"
    have "\<delta> > 0" "\<delta> \<le> a"
      using \<open>a > 0\<close> \<open>\<epsilon> > 0\<close> del_gt0 by (auto simp: \<delta>_def)
    define n where "n \<equiv> nat\<lfloor>a / \<delta>\<rfloor>"
    define a_seg where "a_seg \<equiv> \<lambda>u::real. u * a/n"
    have "n > 0"
      using  \<open>a > 0\<close> \<open>\<delta> > 0\<close> \<open>\<delta> \<le> a\<close> by (simp add: n_def)
    have a_seg_ge_0 [simp]: "a_seg x \<ge> 0 \<longleftrightarrow> x \<ge> 0"
     and a_seg_le_a [simp]: "a_seg x \<le> a \<longleftrightarrow> x \<le> n" for x
      using \<open>n > 0\<close> \<open>a > 0\<close> by (auto simp: a_seg_def zero_le_mult_iff divide_simps)
    have a_seg_le_iff [simp]: "a_seg x \<le> a_seg y \<longleftrightarrow> x \<le> y"
      and a_seg_less_iff [simp]: "a_seg x < a_seg y \<longleftrightarrow> x < y" for x y
      using \<open>n > 0\<close> \<open>a > 0\<close> by (auto simp: a_seg_def zero_le_mult_iff divide_simps)
    have "strict_mono a_seg"
      by (simp add: strict_mono_def)
    have a_seg_eq_a_iff: "a_seg x = a \<longleftrightarrow> x=n" for x
      using \<open>0 < n\<close> \<open>a > 0\<close> by (simp add: a_seg_def nonzero_divide_eq_eq)
    have fa_eq_b: "f (a_seg n) = b"
      using a_seg_eq_a_iff f by fastforce

    have "a/d < real_of_int \<lfloor>a * 2 / min a d\<rfloor>" if "d>0" for d
      by (smt (verit) \<open>0 < \<delta>\<close> \<open>\<delta> \<le> a\<close> add_divide_distrib divide_less_eq_1_pos floor_eq_iff that)
    then have an_less_del: "a/n < del (\<epsilon>/a)"
      using \<open>a > 0\<close> \<open>\<epsilon> > 0\<close> del_gt0  by (simp add: n_def \<delta>_def field_simps)

    define lower where "lower \<equiv> \<lambda>x. a_seg\<lfloor>(real n * x) / a\<rfloor>"
    define f1 where "f1 \<equiv> f \<circ> lower"
    have f1_lower: "f1 x \<le> f x" if "0 \<le> x" "x \<le> a" for x
    proof -
      have "lower x \<le> x"
        using \<open>n > 0\<close> floor_divide_lower [OF \<open>a > 0\<close>]
        by (auto simp: lower_def a_seg_def field_simps)
      moreover have "lower x \<ge> 0"
        unfolding lower_def using \<open>n > 0\<close> \<open>a \<ge> 0\<close> \<open>0 \<le> x\<close> by force
      ultimately show ?thesis
        using sm strict_mono_on_leD by (fastforce simp add: f1_def)
    qed
    define upper where "upper \<equiv> \<lambda>x. a_seg\<lceil>real n * x / a\<rceil>"
    define f2 where "f2 \<equiv> f \<circ> upper"
    have f2_upper: "f2 x \<ge> f x" if "0 \<le> x" "x \<le> a" for x
    proof -
      have "x \<le> upper x"
        using \<open>n > 0\<close> ceiling_divide_upper [OF \<open>a > 0\<close>] by (simp add: upper_def a_seg_def field_simps)
      then show ?thesis
        using sm strict_mono_on_leD \<open>0 \<le> x\<close> by (force simp: f2_def)
    qed
    let ?\<D> = "regular_division 0 a n"
    have div: "?\<D> division_of {0..a}"
      using \<open>a > 0\<close> \<open>n > 0\<close> regular_division_division_of zero_less_nat_eq by presburger

    have int_f1_D: "(f1 has_integral f(Inf K) * (a/n)) K"
      and int_f2_D: "(f2 has_integral f(Sup K) * (a/n)) K" and less: "\<bar>f(Sup K) - f(Inf K)\<bar> < \<epsilon>/a"
      if "K\<in>?\<D>" for K
    proof -
      from regular_divisionE [OF that] \<open>a > 0\<close>
      obtain k where "k<n" and k: "K = {a_seg(real k)..a_seg(Suc k)}"
        by (auto simp: a_seg_def mult.commute)
      define u where "u \<equiv> a_seg k"
      define v where "v \<equiv> a_seg (Suc k)"
      have "u < v" "0 \<le> u" "0 \<le> v" "u \<le> a" "v \<le> a" and Kuv: "K = {u..v}"
        using \<open>n > 0\<close> \<open>k < n\<close> \<open>a > 0\<close> by (auto simp: k u_def v_def divide_simps)
      have InfK: "Inf K = u" and SupK: "Sup K = v"
        using Kuv \<open>u < v\<close> apply force
        using \<open>n > 0\<close> \<open>a > 0\<close> by (auto simp: divide_right_mono k u_def v_def)
      have f1: "f1 x = f (Inf K)" if "x \<in> K - {v}" for x
      proof -
        have "x \<in> {u..<v}"
          using that Kuv atLeastLessThan_eq_atLeastAtMost_diff by blast
        then have "\<lfloor>real_of_int n * x / a\<rfloor> = int k"
          using \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: field_simps u_def v_def a_seg_def floor_eq_iff)
        then show ?thesis
          by (simp add: InfK f1_def lower_def a_seg_def mult.commute u_def)
      qed
      have "((\<lambda>x. f (Inf K)) has_integral (f (Inf K) * (a/n))) K"
        using has_integral_const_real [of "f (Inf K)" u v]
              \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: Kuv field_simps a_seg_def u_def v_def)
      then show "(f1 has_integral (f (Inf K) * (a/n))) K"
        using has_integral_spike_finite_eq [of "{v}" K "\<lambda>x. f (Inf K)" f1] f1 by simp
      have f2: "f2 x = f (Sup K)" if "x \<in> K - {u}" for x
      proof -
        have "x \<in> {u<..v}"
          using that Kuv greaterThanAtMost_eq_atLeastAtMost_diff by blast
        then have "\<lceil>x * real_of_int n / a\<rceil>  = 1 + int k"
          using \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: field_simps u_def v_def a_seg_def ceiling_eq_iff)
        then show ?thesis
          by (simp add: mult.commute f2_def upper_def a_seg_def SupK v_def)
      qed
      have "((\<lambda>x. f (Sup K)) has_integral (f (Sup K) * (a/n))) K"
        using  \<open>n > 0\<close> \<open>a > 0\<close> has_integral_const_real [of "f (Sup K)" u v]
        by (simp add: Kuv field_simps u_def v_def a_seg_def)
      then show "(f2 has_integral (f (Sup K) * (a/n))) K"
        using has_integral_spike_finite_eq [of "{u}" K "\<lambda>x. f (Sup K)" f2] f2 by simp
      have "\<bar>v - u\<bar> < del (\<epsilon>/a)"
        using \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: v_def u_def a_seg_def field_simps an_less_del)
      then have "\<bar>f v - f u\<bar> < \<epsilon>/a"
        using \<open>\<epsilon> > 0\<close> \<open>a > 0\<close> \<open>0 \<le> u\<close> \<open>u \<le> a\<close> \<open>0 \<le> v\<close> \<open>v \<le> a\<close>
        by (intro del) auto
      then show "\<bar>f(Sup K) - f(Inf K)\<bar> < \<epsilon>/a"
        using InfK SupK by blast
    qed

    have int_21_D: "((\<lambda>x. f2 x - f1 x) has_integral (f(Sup K) - f(Inf K)) * (a/n)) K" if "K\<in>?\<D>" for K
      using that has_integral_diff [OF int_f2_D int_f1_D] by (simp add: algebra_simps)

    have D_ne: "?\<D> \<noteq> {}"
      by (metis \<open>0 < a\<close> \<open>n > 0\<close> card_gt_0_iff card_regular_division)
    have f12: "((\<lambda>x. f2 x - f1 x) has_integral (\<Sum>K\<in>?\<D>. (f(Sup K) - f(Inf K)) * (a/n))) {0..a}"
      by (intro div int_21_D has_integral_combine_division)
    moreover have "(\<Sum>K\<in>?\<D>. (f(Sup K) - f(Inf K)) * (a/n)) < \<epsilon>"
    proof -
      have "(\<Sum>K\<in>?\<D>. (f(Sup K) - f(Inf K)) * (a/n)) \<le> (\<Sum>K\<in>?\<D>. \<bar>f(Sup K) - f(Inf K)\<bar> * (a/n))"
        using \<open>n > 0\<close> \<open>a > 0\<close>
        by (smt (verit) divide_pos_pos of_nat_0_less_iff sum_mono zero_le_mult_iff)
      also have "\<dots> < (\<Sum>K\<in>?\<D>. \<epsilon>/n)"
        using \<open>n > 0\<close> \<open>a > 0\<close> less
        by (intro sum_strict_mono finite_regular_division D_ne) (simp add: field_simps)
      also have "\<dots> = \<epsilon>"
        using \<open>n > 0\<close> \<open>a > 0\<close> by simp
      finally show ?thesis .
    qed
    ultimately have f2_near_f1: "integral {0..a} (\<lambda>x. f2 x - f1 x) < \<epsilon>"
      by (simp add: integral_unique)

    define yidx where "yidx \<equiv> \<lambda>y. LEAST k. y < f (a_seg (Suc k))"
    have fa_yidx_le: "f (a_seg (yidx y)) \<le> y" and yidx_gt: "y < f (a_seg (Suc (yidx y)))"
      if "y \<in> {0..b}" for y
    proof -
      obtain x where x: "f x = y" "x \<in> {0..a}"
        using Topological_Spaces.IVT' [OF _ _ _ cont_0a] assms
        by (metis \<open>y \<in> {0..b}\<close> atLeastAtMost_iff)
      define k where "k \<equiv> nat \<lfloor>x/a * n\<rfloor>"
      have x_lims: "a_seg k \<le> x" "x < a_seg (Suc k)"
        using \<open>n > 0\<close> \<open>0 < a\<close> floor_divide_lower floor_divide_upper [of a "x*n"] x
        by (auto simp: k_def a_seg_def field_simps)
      with that x obtain f_lims: "f (a_seg k) \<le> y" "y < f (a_seg (Suc k))"
        using strict_mono_onD [OF sm] by force
      then have "a_seg (yidx y) \<le> a_seg k"
        by (simp add: Least_le \<open>strict_mono a_seg\<close> strict_mono_less_eq yidx_def)
      then have "f (a_seg (yidx y)) \<le> f (a_seg k)"
        using strict_mono_onD [OF sm] by simp
      then show "f (a_seg (yidx y)) \<le> y"
        using f_lims by linarith
      show "y < f (a_seg (Suc (yidx y)))"
        by (metis LeastI f_lims(2) yidx_def)
    qed

    have yidx_equality: "yidx y = k" if "y \<in> {0..b}" "y \<in> {f (a_seg k)..<f (a_seg (Suc k))}" for y k
    proof (rule antisym)
      show "yidx y \<le> k"
        unfolding yidx_def by (metis atLeastLessThan_iff that(2) Least_le)
      have "(a_seg (real k)) < a_seg (1 + real (yidx y))"
        using yidx_gt [OF that(1)] that(2) strict_mono_onD [OF sm] order_le_less_trans by fastforce
      then have "real k < 1 + real (yidx y)"
        by (simp add: \<open>strict_mono a_seg\<close> strict_mono_less)
      then show "k \<le> yidx y"
        by simp
    qed
    have "yidx b = n"
    proof -
      have "a < (1 + real n) * a / real n"
        using \<open>0 < n\<close> \<open>0 < a\<close> by (simp add: divide_simps)
      then have "b < f (a_seg (1 + real n))"
        using f \<open>a \<ge> 0\<close> a_seg_def sm strict_mono_onD by fastforce
      then show ?thesis
        using \<open>0 \<le> b\<close> by (auto simp: f a_seg_def yidx_equality)
    qed
    moreover have yidx_less_n: "yidx y < n" if "y < b" for y
      by (metis \<open>0 < n\<close> fa_eq_b gr0_conv_Suc less_Suc_eq_le that Least_le yidx_def)
    ultimately have yidx_le_n: "yidx y \<le> n" if "y \<le> b" for y
      by (metis dual_order.order_iff_strict that)

    have zero_to_b_eq: "{0..b} = (\<Union>k<n. {f(a_seg k)..f(a_seg (Suc k))})" (is "?lhs = ?rhs")
    proof
      show "?lhs \<subseteq> ?rhs"
      proof
        fix y assume y: "y \<in> {0..b}"
        have fn: "f (a_seg n) = b"
          using a_seg_eq_a_iff \<open>f a = b\<close> by fastforce
        show "y \<in> ?rhs"
        proof (cases "y=b")
          case True
          with fn \<open>n>0\<close> show ?thesis
            by (rule_tac a="n-1" in UN_I) auto
        next
          case False
          with y show ?thesis
            apply (simp add: subset_iff Bex_def)
            by (metis atLeastAtMost_iff of_nat_Suc order_le_less yidx_gt fa_yidx_le yidx_less_n)
        qed
      qed
      show "?rhs \<subseteq> ?lhs"
        apply clarsimp
        by (smt (verit, best) a_seg_ge_0 a_seg_le_a f f_iff(2) nat_less_real_le of_nat_0_le_iff)
    qed

    define g1 where "g1 \<equiv> \<lambda>y. if y=b then a else a_seg (Suc (yidx y))"
    define g2 where "g2 \<equiv> \<lambda>y. if y=0 then 0 else a_seg (yidx y)"
    have g1: "g1 y \<in> {0..a}" if "y \<in> {0..b}" for y
      using that \<open>a > 0\<close> yidx_less_n [of y] by (auto simp: g1_def a_seg_def divide_simps)
    have g2: "g2 y \<in> {0..a}" if "y \<in> {0..b}" for y
      using that \<open>a > 0\<close> yidx_le_n [of y] by (simp add: g2_def a_seg_def divide_simps)

    have g2_le_g: "g2 y \<le> g y" if "y \<in> {0..b}" for y
    proof -
      have "f (g2 y) \<le> y"
        using \<open>f 0 = 0\<close> g2_def that fa_yidx_le by presburger
      then have "f (g2 y) \<le> f (g y)"
        using that g by (smt (verit, best) atLeastAtMost_iff fim image_iff)
      then show ?thesis
        by (smt (verit, best) atLeastAtMost_iff fim g g2 imageE sm_0a strict_mono_onD that)
    qed
    have g_le_g1: "g y \<le> g1 y" if "y \<in> {0..b}" for y
    proof -
      have "y \<le> f (g1 y)"
        by (smt (verit, best) \<open>f a = b\<close> g1_def that yidx_gt)
      then have "f (g y) \<le> f (g1 y)"
        using that g by (smt (verit, best) atLeastAtMost_iff fim image_iff)
      then show ?thesis
        by (smt (verit, ccfv_threshold) atLeastAtMost_iff f_iff(1) g1 that)
    qed

    define DN where "DN \<equiv> \<lambda>K. nat \<lfloor>Inf K * real n / a\<rfloor>"
    have [simp]: "DN {a * real k / n..a * (1 + real k) / n} = k" for k
      using \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: DN_def divide_simps)
    have DN: "bij_betw DN ?\<D> {..<n}"
    proof (intro bij_betw_imageI)
      show "inj_on DN (regular_division 0 a n)"
      proof
        fix K K'
        assume "K \<in> regular_division 0 a n"
        with \<open>a > 0\<close> obtain k where k: "K = {a * (real k / n) .. a * (1 + real k) / n}"
          by (force elim: regular_divisionE)
        assume "K' \<in> regular_division 0 a n"
        with \<open>a > 0\<close> obtain k' where k': "K' = {a * (real k' / n) .. a * (1 + real k') / n}"
          by (force elim: regular_divisionE)
        assume "DN K = DN K'"
        then show "K = K'" by (simp add: k k')
      qed
      have "\<exists>K\<in>regular_division 0 a n. k = nat \<lfloor>Inf K * real n / a\<rfloor>" if "k < n" for k
        using \<open>n > 0\<close> \<open>a > 0\<close> that
        by (force simp: divide_simps intro: regular_division_eqI [OF refl])
      with \<open>a>0\<close> show "DN ` regular_division 0 a n = {..<n}"
        by (auto simp: DN_def bij_betw_def image_iff frac_le elim!: regular_divisionE)
    qed

    have int_f1: "(f1 has_integral (\<Sum>k<n. f(a_seg k)) * (a/n)) {0..a}"
    proof -
      have "a_seg (real (DN K)) = Inf K" if "K \<in> ?\<D>" for K
        using that \<open>a>0\<close> by (auto simp: DN_def field_simps a_seg_def elim: regular_divisionE)
      then have "(\<Sum>K\<in>?\<D>. f(Inf K) * (a/n)) = (\<Sum>k<n. (f(a_seg k)) * (a/n))"
        by (simp flip: sum.reindex_bij_betw [OF DN])
      moreover have "(f1 has_integral (\<Sum>K\<in>?\<D>. f(Inf K) * (a/n))) {0..a}"
        by (intro div int_f1_D has_integral_combine_division)
      ultimately show ?thesis
        by (metis sum_distrib_right)
    qed
    text \<open>The claim @{term "(f2 has_integral (\<Sum>k<n. f(a_seg(Suc k))) * (a/n)) {0..a}"} can similarly be proved\<close>

    have int_g1_D: "(g1 has_integral a_seg (Suc k) * (f (a_seg (Suc k)) - f (a_seg k)))
                    {f(a_seg k)..f(a_seg (Suc k))}"
     and int_g2_D: "(g2 has_integral a_seg k * (f (a_seg (Suc k)) - f (a_seg k)))
                    {f(a_seg k)..f(a_seg (Suc k))}"
      if "k < n" for k
    proof -
      define u where "u \<equiv> f (a_seg k)"
      define v where "v \<equiv> f (a_seg (Suc k))"
      obtain "u < v" "0 \<le> u" "0 \<le> v"
        unfolding u_def v_def assms
        by (smt (verit, best) a_seg_ge_0 a_seg_le_iff f(1) f_iff(1) of_nat_0_le_iff of_nat_Suc)
      have "u \<le> b" "v \<le> b"
        using \<open>k < n\<close> \<open>a \<ge> 0\<close> by (simp_all add: u_def v_def flip: \<open>f a = b\<close>)
      have yidx_eq: "yidx x = k" if "x \<in> {u..<v}" for x
        using \<open>0 \<le> u\<close> \<open>v \<le> b\<close> that u_def v_def yidx_equality by auto

      have "g1 x = a_seg (Suc k)" if "x \<in> {u..<v}" for x
        using that \<open>v \<le> b\<close> by (simp add: g1_def yidx_eq)
      moreover have "((\<lambda>x. a_seg (Suc k)) has_integral (a_seg (Suc k) * (v-u))) {u..v}"
        using has_integral_const_real \<open>u < v\<close>
        by (metis content_real_if less_eq_real_def mult.commute real_scaleR_def)
      ultimately show "(g1 has_integral (a_seg (Suc k) * (v-u))) {u..v}"
        using has_integral_spike_finite_eq [of "{v}" "{u..v}" "\<lambda>x. a_seg (Suc k)" g1] by simp

      have g2: "g2 x = a_seg k" if "x \<in> {u<..<v}" for x
        using that \<open>0 \<le> u\<close> by (simp add: g2_def yidx_eq)
      moreover have "((\<lambda>x. a_seg k) has_integral (a_seg k * (v-u))) {u..v}"
        using has_integral_const_real \<open>u < v\<close>
        by (metis content_real_if less_eq_real_def mult.commute real_scaleR_def)
      ultimately show "(g2 has_integral (a_seg k * (v-u))) {u..v}"
        using has_integral_spike_finite_eq [of "{u,v}" "{u..v}" "\<lambda>x. a_seg k" g2] by simp
    qed

    have int_g1: "(g1 has_integral (\<Sum>k<n. a_seg (Suc k) * (f (a_seg (Suc k)) - f (a_seg k)))) {0..b}"
    and int_g2: "(g2 has_integral (\<Sum>k<n. a_seg k * (f (a_seg (Suc k)) - f (a_seg k)))) {0..b}"
      unfolding zero_to_b_eq using int_g1_D int_g2_D
      by (auto simp: min_def pairwise_def intro!: has_integral_UN negligible_atLeastAtMostI)

    have "(\<Sum>k<n. a_seg (Suc k) * (f (a_seg (Suc k)) - f (a_seg k)))
        = (\<Sum>k<n. (Suc k) * (f (a_seg (Suc k)) - f (a_seg k))) * (a/n)"
      unfolding a_seg_def sum_distrib_right sum_divide_distrib by (simp add: mult_ac)
    also have "\<dots> = (n * f (a_seg n) - (\<Sum>k<n. f (a_seg k))) * a / n"
      using weighted_nesting_sum [where g = "f o a_seg"] by simp
    also have "\<dots> = a * b - (\<Sum>k<n. f (a_seg k)) * a / n"
      using \<open>n > 0\<close> by (simp add: fa_eq_b field_simps)
    finally have int_g1': "(g1 has_integral a * b - (\<Sum>k<n. f (a_seg k)) * a / n) {0..b}"
      using int_g1 by simp
    text \<open>The claim @{term "(g2 has_integral a * b - (\<Sum>k<n. f (a_seg (Suc k))) * a / n) {0..b}"} can similarly be proved.\<close>

    have a_seg_diff: "a_seg (Suc k) - a_seg k = a/n" for k
      by (simp add: a_seg_def field_split_simps)
    have f_a_seg_diff: "\<bar>f (a_seg (Suc k)) - f (a_seg k)\<bar> < \<epsilon>/a" if "k<n" for k
      using that \<open>a > 0\<close> a_seg_diff an_less_del \<open>\<epsilon> > 0\<close>
      by (intro del) auto

    have "((\<lambda>x. g1 x - g2 x) has_integral (\<Sum>k<n. (f (a_seg (Suc k)) - f (a_seg k)) * (a/n))) {0..b}"
      using has_integral_diff [OF int_g1 int_g2] a_seg_diff
      apply (simp flip: sum_subtractf left_diff_distrib)
      apply (simp add: field_simps)
      done
    moreover have "(\<Sum>k<n. (f (a_seg (Suc k)) - f (a_seg k)) * (a/n)) < \<epsilon>"
    proof -
      have "(\<Sum>k<n. (f (a_seg (Suc k)) - f (a_seg k)) * (a/n))
         \<le> (\<Sum>k<n. \<bar>f (a_seg (Suc k)) - f (a_seg k)\<bar> * (a/n))"
        by simp
      also have "\<dots> < (\<Sum>k<n. (\<epsilon>/a) * (a/n))"
      proof (rule sum_strict_mono)
        fix k assume "k \<in> {..<n}"
        with \<open>n > 0\<close> \<open>a > 0\<close> divide_strict_right_mono f_a_seg_diff pos_less_divide_eq
        show "\<bar>f (a_seg (Suc k)) - f (a_seg k)\<bar> * (a/n) < \<epsilon>/a * (a/n)" by fastforce
      qed (use \<open>n > 0\<close> in auto)
      also have "\<dots> = \<epsilon>"
        using \<open>n > 0\<close> \<open>a > 0\<close> by simp
      finally show ?thesis .
    qed
    ultimately have g2_near_g1: "integral {0..b} (\<lambda>x. g1 x - g2 x) < \<epsilon>"
      by (simp add: integral_unique)

    have ab1: "integral {0..a} f1 + integral {0..b} g1 = a*b"
      using int_f1 int_g1' by (simp add: integral_unique)

    have "integral {0..a} (\<lambda>x. f x - f1 x) \<le> integral {0..a} (\<lambda>x. f2 x - f1 x)"
    proof (rule integral_le)
      show "(\<lambda>x. f x - f1 x) integrable_on {0..a}" "(\<lambda>x. f2 x - f1 x) integrable_on {0..a}"
        using Henstock_Kurzweil_Integration.integrable_diff int_f1 intgb_f f12 by blast+
    qed (auto simp: f2_upper)
    with f2_near_f1 have "integral {0..a} (\<lambda>x. f x - f1 x) < \<epsilon>"
      by simp
    moreover have "integral {0..a} f1 \<le> integral {0..a} f"
      by (intro integral_le has_integral_integral intgb_f has_integral_integrable [OF int_f1])
         (simp add: f1_lower)
    ultimately have f_error: "\<bar>integral {0..a} f - integral {0..a} f1\<bar> < \<epsilon>"
      using Henstock_Kurzweil_Integration.integral_diff int_f1 intgb_f by fastforce

    have "integral {0..b} (\<lambda>x. g1 x - g x) \<le> integral {0..b} (\<lambda>x. g1 x - g2 x)"
    proof (rule integral_le)
      show "(\<lambda>x. g1 x - g x) integrable_on {0..b}" "(\<lambda>x. g1 x - g2 x) integrable_on {0..b}"
        using Henstock_Kurzweil_Integration.integrable_diff int_g1 int_g2 intgb_g by blast+
    qed (auto simp: g2_le_g)
    with g2_near_g1 have "integral {0..b} (\<lambda>x. g1 x - g x) < \<epsilon>"
      by simp
    moreover have "integral {0..b} g \<le> integral {0..b} g1"
      by (intro integral_le has_integral_integral intgb_g has_integral_integrable [OF int_g1])
         (simp add: g_le_g1)
    ultimately have g_error: "\<bar>integral {0..b} g1 - integral {0..b} g\<bar> < \<epsilon>"
      using integral_diff int_g1 intgb_g by fastforce
    show ?thesis
      using f_error g_error ab1 by linarith
  qed
  show ?thesis
    using * [of "\<bar>a * b - integral {0..a} f - integral {0..b} g\<bar> / 2"] by fastforce
qed (use assms in force)

corollary Youngs_strict:
  fixes f :: "real \<Rightarrow> real"
  assumes sm: "strict_mono_on {0..} f" and cont: "continuous_on {0..} f" and "a>0" "b\<ge>0"
    and f: "f 0 = 0" "f a \<noteq> b" and fim: "f ` {0..} = {0..}"
    and g: "\<And>x. 0 \<le> x \<Longrightarrow> g (f x) = x"
  shows "a*b < integral {0..a} f + integral {0..b} g"
proof -
  have f_iff [simp]: "f x < f y \<longleftrightarrow> x < y" "f x \<le> f y \<longleftrightarrow> x \<le> y"
    if "x \<ge> 0" "y \<ge> 0" for x y
    using that by (smt (verit, best) atLeast_iff sm strict_mono_onD)+
  let ?b' = "f a"
  have "?b' \<ge> 0"
    by (smt (verit, best) \<open>0 < a\<close> atLeast_iff f sm strict_mono_onD)
  then have sm_gx: "strict_mono_on {0..} g"
    unfolding strict_mono_on_def
    by (smt (verit, best) atLeast_iff f_iff(1) f_inv_into_f fim g inv_into_into)
  show ?thesis
  proof (cases "?b' < b")
    case True
    have gt_a: "a < g y" if "y \<in> {?b'<..b}" for y
    proof -
      have "a = g ?b'"
        using \<open>a > 0\<close> g by force
      also have "\<dots> < g y"
        using \<open>0 \<le> ?b'\<close> sm_gx strict_mono_onD that by fastforce
      finally show ?thesis .
    qed
    have "continuous_on {0..} g"
      by (metis cont f(1) fim g sm strict_mono_continuous_invD)
    then have contg: "continuous_on {?b'..b} g"
      by (meson Icc_subset_Ici_iff \<open>0 \<le> f a\<close> continuous_on_subset)
    have "mono_on {0..} g"
      by (simp add: sm_gx strict_mono_on_imp_mono_on)
    then have int_g0b: "g integrable_on {0..b}"
      by (simp add: integrable_on_mono_on mono_on_subset)
    then have int_gb'b: "g integrable_on {?b'..b}"
      by (simp add: \<open>0 \<le> ?b'\<close> integrable_on_subinterval)
    have "a * (b - ?b') = integral {?b'..b} (\<lambda>y. a)"
      using True by force
    also have "\<dots> < integral {?b'..b} g"
      using contg True gt_a by (intro integral_less_real) auto
    finally have *: "a * (b - ?b') < integral {?b'..b} g" .
    have "a*b = a * ?b' + a * (b - ?b')"
      by (simp add: algebra_simps)
    also have "\<dots> = integral {0..a} f + integral {0..?b'} g + a * (b - ?b')"
      using Youngs_exact \<open>a > 0\<close> cont \<open>f 0 = 0\<close> g sm by force
    also have "\<dots> < integral {0..a} f + integral {0..?b'} g + integral {?b'..b} g"
      by (simp add: *)
    also have "\<dots> = integral {0..a} f + integral {0..b} g"
      by (smt (verit) Henstock_Kurzweil_Integration.integral_combine True \<open>0 \<le> ?b'\<close> int_g0b)
    finally show ?thesis .
  next
    case False
    with f have "b < ?b'" by force
    obtain a' where "f a' = b" "a' \<ge> 0"
      using fim \<open>b \<ge> 0\<close> by force
    then have "a' < a"
      using \<open>b < f a\<close> \<open>a > 0\<close> by force
    have gt_b: "b < f x" if "x \<in> {a'<..a}" for x
      using \<open>0 \<le> a'\<close> \<open>f a' = b\<close> that by fastforce
    have int_f0a: "f integrable_on {0..a}"
      by (simp add: integrable_on_mono_on mono_on_def)
    then have int_fa'a: "f integrable_on {a'..a}"
      by (simp add: \<open>0 \<le> a'\<close> integrable_on_subinterval)
    have cont_f': "continuous_on {a'..a} f"
      by (meson Icc_subset_Ici_iff \<open>0 \<le> a'\<close> cont continuous_on_subset)
    have "b * (a - a') = integral {a'..a} (\<lambda>x. b)"
      using \<open>a' < a\<close> by simp
    also have "\<dots> < integral {a'..a} f"
      using cont_f' \<open>a' < a\<close> gt_b by (intro integral_less_real) auto
    finally have *: "b * (a - a') < integral {a'..a} f" .
    have "a*b = a' * b + b * (a - a')"
      by (simp add: algebra_simps)
    also have "\<dots> = integral {0..a'} f + integral {0..b} g + b * (a - a')"
      by (simp add: Youngs_exact \<open>0 \<le> a'\<close> \<open>f a' = b\<close> cont f g sm)
    also have "\<dots> < integral {0..a'} f + integral {0..b} g + integral {a'..a} f"
      by (simp add: *)
    also have "\<dots> = integral {0..a} f + integral {0..b} g"
      by (smt (verit) Henstock_Kurzweil_Integration.integral_combine \<open>0 \<le> a'\<close> \<open>a' < a\<close> int_f0a)
    finally show ?thesis .
  qed
qed

corollary Youngs_inequality:
  fixes f :: "real \<Rightarrow> real"
  assumes sm: "strict_mono_on {0..} f" and cont: "continuous_on {0..} f" and "a\<ge>0" "b\<ge>0"
    and f: "f 0 = 0" and fim: "f ` {0..} = {0..}"
    and g: "\<And>x. 0 \<le> x \<Longrightarrow> g (f x) = x"
  shows "a*b \<le> integral {0..a} f + integral {0..b} g"
proof (cases "a=0")
  case True
  have "g x \<ge> 0" if "x \<ge> 0" for x
    by (metis atLeast_iff fim g imageE that)
  then have "0 \<le> integral {0..b} g"
    by (metis Henstock_Kurzweil_Integration.integral_nonneg atLeastAtMost_iff
              not_integrable_integral order_refl)
  then show ?thesis
    by (simp add: True)
next
  case False
  then show ?thesis
    by (smt (verit) assms Youngs_exact Youngs_strict)
qed

end


(* Author: Peter Lammich
           Tobias Nipkow (tuning)
*)

section \<open>Binomial Heap\<close>

theory Binomial_Heap
imports
  "HOL-Library.Pattern_Aliases"
  Complex_Main
  Priority_Queue_Specs
begin

text \<open>
  We formalize the binomial heap presentation from Okasaki's book.
  We show the functional correctness and complexity of all operations.

  The presentation is engineered for simplicity, and most
  proofs are straightforward and automatic.
\<close>

subsection \<open>Binomial Tree and Heap Datatype\<close>

datatype 'a tree = Node (rank: nat) (root: 'a) (children: "'a tree list")

type_synonym 'a heap = "'a tree list"

subsubsection \<open>Multiset of elements\<close>

fun mset_tree :: "'a::linorder tree \<Rightarrow> 'a multiset" where
  "mset_tree (Node _ a ts) = {#a#} + (\<Sum>t\<in>#mset ts. mset_tree t)"

definition mset_heap :: "'a::linorder heap \<Rightarrow> 'a multiset" where
  "mset_heap ts = (\<Sum>t\<in>#mset ts. mset_tree t)"

lemma mset_tree_simp_alt[simp]:
  "mset_tree (Node r a ts) = {#a#} + mset_heap ts"
  unfolding mset_heap_def by auto
declare mset_tree.simps[simp del]

lemma mset_tree_nonempty[simp]: "mset_tree t \<noteq> {#}"
by (cases t) auto

lemma mset_heap_Nil[simp]:
  "mset_heap [] = {#}"
by (auto simp: mset_heap_def)

lemma mset_heap_Cons[simp]: "mset_heap (t#ts) = mset_tree t + mset_heap ts"
by (auto simp: mset_heap_def)

lemma mset_heap_empty_iff[simp]: "mset_heap ts = {#} \<longleftrightarrow> ts=[]"
by (auto simp: mset_heap_def)

lemma root_in_mset[simp]: "root t \<in># mset_tree t"
by (cases t) auto

lemma mset_heap_rev_eq[simp]: "mset_heap (rev ts) = mset_heap ts"
by (auto simp: mset_heap_def)

subsubsection \<open>Invariants\<close>

text \<open>Binomial tree\<close>
fun invar_btree :: "'a::linorder tree \<Rightarrow> bool" where
"invar_btree (Node r x ts) \<longleftrightarrow>
   (\<forall>t\<in>set ts. invar_btree t) \<and> map rank ts = rev [0..<r]"

text \<open>Ordering (heap) invariant\<close>
fun invar_otree :: "'a::linorder tree \<Rightarrow> bool" where
"invar_otree (Node _ x ts) \<longleftrightarrow> (\<forall>t\<in>set ts. invar_otree t \<and> x \<le> root t)"

definition "invar_tree t \<longleftrightarrow> invar_btree t \<and> invar_otree t"

text \<open>Binomial Heap invariant\<close>
definition "invar ts \<longleftrightarrow> (\<forall>t\<in>set ts. invar_tree t) \<and> (sorted_wrt (<) (map rank ts))"

text \<open>The children of a node are a valid heap\<close>
lemma invar_children:
  "invar_tree (Node r v ts) \<Longrightarrow> invar (rev ts)"
  by (auto simp: invar_tree_def invar_def rev_map[symmetric])

subsection \<open>Operations and Their Functional Correctness\<close>

subsubsection \<open>\<open>link\<close>\<close>

context
includes pattern_aliases
begin

fun link :: "('a::linorder) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "link (Node r x\<^sub>1 ts\<^sub>1 =: t\<^sub>1) (Node r' x\<^sub>2 ts\<^sub>2 =: t\<^sub>2) =
    (if x\<^sub>1\<le>x\<^sub>2 then Node (r+1) x\<^sub>1 (t\<^sub>2#ts\<^sub>1) else Node (r+1) x\<^sub>2 (t\<^sub>1#ts\<^sub>2))"

end

lemma invar_link:
  assumes "invar_tree t\<^sub>1"
  assumes "invar_tree t\<^sub>2"
  assumes "rank t\<^sub>1 = rank t\<^sub>2"
  shows "invar_tree (link t\<^sub>1 t\<^sub>2)"
using assms unfolding invar_tree_def
by (cases "(t\<^sub>1, t\<^sub>2)" rule: link.cases) auto

lemma rank_link[simp]: "rank (link t\<^sub>1 t\<^sub>2) = rank t\<^sub>1 + 1"
by (cases "(t\<^sub>1, t\<^sub>2)" rule: link.cases) simp

lemma mset_link[simp]: "mset_tree (link t\<^sub>1 t\<^sub>2) = mset_tree t\<^sub>1 + mset_tree t\<^sub>2"
by (cases "(t\<^sub>1, t\<^sub>2)" rule: link.cases) simp

subsubsection \<open>\<open>ins_tree\<close>\<close>

fun ins_tree :: "'a::linorder tree \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
  "ins_tree t [] = [t]"
| "ins_tree t\<^sub>1 (t\<^sub>2#ts) =
  (if rank t\<^sub>1 < rank t\<^sub>2 then t\<^sub>1#t\<^sub>2#ts else ins_tree (link t\<^sub>1 t\<^sub>2) ts)"

lemma invar_tree0[simp]: "invar_tree (Node 0 x [])"
unfolding invar_tree_def by auto

lemma invar_Cons[simp]:
  "invar (t#ts)
  \<longleftrightarrow> invar_tree t \<and> invar ts \<and> (\<forall>t'\<in>set ts. rank t < rank t')"
by (auto simp: invar_def)

lemma invar_ins_tree:
  assumes "invar_tree t"
  assumes "invar ts"
  assumes "\<forall>t'\<in>set ts. rank t \<le> rank t'"
  shows "invar (ins_tree t ts)"
using assms
by (induction t ts rule: ins_tree.induct) (auto simp: invar_link less_eq_Suc_le[symmetric])

lemma mset_heap_ins_tree[simp]:
  "mset_heap (ins_tree t ts) = mset_tree t + mset_heap ts"
by (induction t ts rule: ins_tree.induct) auto

lemma ins_tree_rank_bound:
  assumes "t' \<in> set (ins_tree t ts)"
  assumes "\<forall>t'\<in>set ts. rank t\<^sub>0 < rank t'"
  assumes "rank t\<^sub>0 < rank t"
  shows "rank t\<^sub>0 < rank t'"
using assms
by (induction t ts rule: ins_tree.induct) (auto split: if_splits)

subsubsection \<open>\<open>insert\<close>\<close>

hide_const (open) insert

definition insert :: "'a::linorder \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"insert x ts = ins_tree (Node 0 x []) ts"

lemma invar_insert[simp]: "invar t \<Longrightarrow> invar (insert x t)"
by (auto intro!: invar_ins_tree simp: insert_def)

lemma mset_heap_insert[simp]: "mset_heap (insert x t) = {#x#} + mset_heap t"
by(auto simp: insert_def)

subsubsection \<open>\<open>merge\<close>\<close>

context
includes pattern_aliases
begin

fun merge :: "'a::linorder heap \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
  "merge ts\<^sub>1 [] = ts\<^sub>1"
| "merge [] ts\<^sub>2 = ts\<^sub>2"
| "merge (t\<^sub>1#ts\<^sub>1 =: h\<^sub>1) (t\<^sub>2#ts\<^sub>2 =: h\<^sub>2) = (
    if rank t\<^sub>1 < rank t\<^sub>2 then t\<^sub>1 # merge ts\<^sub>1 h\<^sub>2 else
    if rank t\<^sub>2 < rank t\<^sub>1 then t\<^sub>2 # merge h\<^sub>1 ts\<^sub>2
    else ins_tree (link t\<^sub>1 t\<^sub>2) (merge ts\<^sub>1 ts\<^sub>2)
  )"

end

lemma merge_simp2[simp]: "merge [] ts\<^sub>2 = ts\<^sub>2"
by (cases ts\<^sub>2) auto

lemma merge_rank_bound:
  assumes "t' \<in> set (merge ts\<^sub>1 ts\<^sub>2)"
  assumes "\<forall>t\<^sub>1\<in>set ts\<^sub>1. rank t < rank t\<^sub>1"
  assumes "\<forall>t\<^sub>2\<in>set ts\<^sub>2. rank t < rank t\<^sub>2"
  shows "rank t < rank t'"
using assms
by (induction ts\<^sub>1 ts\<^sub>2 arbitrary: t' rule: merge.induct)
   (auto split: if_splits simp: ins_tree_rank_bound)

lemma invar_merge[simp]:
  assumes "invar ts\<^sub>1"
  assumes "invar ts\<^sub>2"
  shows "invar (merge ts\<^sub>1 ts\<^sub>2)"
using assms
by (induction ts\<^sub>1 ts\<^sub>2 rule: merge.induct)
   (auto 0 3 simp: Suc_le_eq intro!: invar_ins_tree invar_link elim!: merge_rank_bound)

text \<open>Longer, more explicit proof of @{thm [source] invar_merge},
      to illustrate the application of the @{thm [source] merge_rank_bound} lemma.\<close>
lemma
  assumes "invar ts\<^sub>1"
  assumes "invar ts\<^sub>2"
  shows "invar (merge ts\<^sub>1 ts\<^sub>2)"
  using assms
proof (induction ts\<^sub>1 ts\<^sub>2 rule: merge.induct)
  case (3 t\<^sub>1 ts\<^sub>1 t\<^sub>2 ts\<^sub>2)
  \<comment> \<open>Invariants of the parts can be shown automatically\<close>
  from "3.prems" have [simp]:
    "invar_tree t\<^sub>1" "invar_tree t\<^sub>2"
    (*"invar (merge (t\<^sub>1#ts\<^sub>1) ts\<^sub>2)"
    "invar (merge ts\<^sub>1 (t\<^sub>2#ts\<^sub>2))"
    "invar (merge ts\<^sub>1 ts\<^sub>2)"*)
    by auto

  \<comment> \<open>These are the three cases of the @{const merge} function\<close>
  consider (LT) "rank t\<^sub>1 < rank t\<^sub>2"
         | (GT) "rank t\<^sub>1 > rank t\<^sub>2"
         | (EQ) "rank t\<^sub>1 = rank t\<^sub>2"
    using antisym_conv3 by blast
  then show ?case proof cases
    case LT
    \<comment> \<open>@{const merge} takes the first tree from the left heap\<close>
    then have "merge (t\<^sub>1 # ts\<^sub>1) (t\<^sub>2 # ts\<^sub>2) = t\<^sub>1 # merge ts\<^sub>1 (t\<^sub>2 # ts\<^sub>2)" by simp
    also have "invar \<dots>" proof (simp, intro conjI)
      \<comment> \<open>Invariant follows from induction hypothesis\<close>
      show "invar (merge ts\<^sub>1 (t\<^sub>2 # ts\<^sub>2))"
        using LT "3.IH" "3.prems" by simp

      \<comment> \<open>It remains to show that \<open>t\<^sub>1\<close> has smallest rank.\<close>
      show "\<forall>t'\<in>set (merge ts\<^sub>1 (t\<^sub>2 # ts\<^sub>2)). rank t\<^sub>1 < rank t'"
        \<comment> \<open>Which is done by auxiliary lemma @{thm [source] merge_rank_bound}\<close>
        using LT "3.prems" by (force elim!: merge_rank_bound)
    qed
    finally show ?thesis .
  next
    \<comment> \<open>@{const merge} takes the first tree from the right heap\<close>
    case GT
    \<comment> \<open>The proof is anaologous to the \<open>LT\<close> case\<close>
    then show ?thesis using "3.prems" "3.IH" by (force elim!: merge_rank_bound)
  next
    case [simp]: EQ
    \<comment> \<open>@{const merge} links both first trees, and inserts them into the merged remaining heaps\<close>
    have "merge (t\<^sub>1 # ts\<^sub>1) (t\<^sub>2 # ts\<^sub>2) = ins_tree (link t\<^sub>1 t\<^sub>2) (merge ts\<^sub>1 ts\<^sub>2)" by simp
    also have "invar \<dots>" proof (intro invar_ins_tree invar_link)
      \<comment> \<open>Invariant of merged remaining heaps follows by IH\<close>
      show "invar (merge ts\<^sub>1 ts\<^sub>2)"
        using EQ "3.prems" "3.IH" by auto

      \<comment> \<open>For insertion, we have to show that the rank of the linked tree is \<open>\<le>\<close> the
          ranks in the merged remaining heaps\<close>
      show "\<forall>t'\<in>set (merge ts\<^sub>1 ts\<^sub>2). rank (link t\<^sub>1 t\<^sub>2) \<le> rank t'"
      proof -
        \<comment> \<open>Which is, again, done with the help of @{thm [source] merge_rank_bound}\<close>
        have "rank (link t\<^sub>1 t\<^sub>2) = Suc (rank t\<^sub>2)" by simp
        thus ?thesis using "3.prems" by (auto simp: Suc_le_eq elim!: merge_rank_bound)
      qed
    qed simp_all
    finally show ?thesis .
  qed
qed auto

lemma mset_heap_merge[simp]:
  "mset_heap (merge ts\<^sub>1 ts\<^sub>2) = mset_heap ts\<^sub>1 + mset_heap ts\<^sub>2"
by (induction ts\<^sub>1 ts\<^sub>2 rule: merge.induct) auto

subsubsection \<open>\<open>get_min\<close>\<close>

fun get_min :: "'a::linorder heap \<Rightarrow> 'a" where
  "get_min [t] = root t"
| "get_min (t#ts) = min (root t) (get_min ts)"

lemma invar_tree_root_min:
  assumes "invar_tree t"
  assumes "x \<in># mset_tree t"
  shows "root t \<le> x"
using assms unfolding invar_tree_def
by (induction t arbitrary: x rule: mset_tree.induct) (fastforce simp: mset_heap_def)

lemma get_min_mset:
  assumes "ts\<noteq>[]"
  assumes "invar ts"
  assumes "x \<in># mset_heap ts"
  shows "get_min ts \<le> x"
  using assms
apply (induction ts arbitrary: x rule: get_min.induct)
apply (auto
      simp: invar_tree_root_min min_def intro: order_trans;
      meson linear order_trans invar_tree_root_min
      )+
done

lemma get_min_member:
  "ts\<noteq>[] \<Longrightarrow> get_min ts \<in># mset_heap ts"
by (induction ts rule: get_min.induct) (auto simp: min_def)

lemma get_min:
  assumes "mset_heap ts \<noteq> {#}"
  assumes "invar ts"
  shows "get_min ts = Min_mset (mset_heap ts)"
using assms get_min_member get_min_mset
by (auto simp: eq_Min_iff)

subsubsection \<open>\<open>get_min_rest\<close>\<close>

fun get_min_rest :: "'a::linorder heap \<Rightarrow> 'a tree \<times> 'a heap" where
  "get_min_rest [t] = (t,[])"
| "get_min_rest (t#ts) = (let (t',ts') = get_min_rest ts
                     in if root t \<le> root t' then (t,ts) else (t',t#ts'))"

lemma get_min_rest_get_min_same_root:
  assumes "ts\<noteq>[]"
  assumes "get_min_rest ts = (t',ts')"
  shows "root t' = get_min ts"
using assms
by (induction ts arbitrary: t' ts' rule: get_min.induct) (auto simp: min_def split: prod.splits)

lemma mset_get_min_rest:
  assumes "get_min_rest ts = (t',ts')"
  assumes "ts\<noteq>[]"
  shows "mset ts = {#t'#} + mset ts'"
using assms
by (induction ts arbitrary: t' ts' rule: get_min.induct) (auto split: prod.splits if_splits)

lemma set_get_min_rest:
  assumes "get_min_rest ts = (t', ts')"
  assumes "ts\<noteq>[]"
  shows "set ts = Set.insert t' (set ts')"
using mset_get_min_rest[OF assms, THEN arg_cong[where f=set_mset]]
by auto

lemma invar_get_min_rest:
  assumes "get_min_rest ts = (t',ts')"
  assumes "ts\<noteq>[]"
  assumes "invar ts"
  shows "invar_tree t'" and "invar ts'"
proof -
  have "invar_tree t' \<and> invar ts'"
    using assms
    proof (induction ts arbitrary: t' ts' rule: get_min.induct)
      case (2 t v va)
      then show ?case
        apply (clarsimp split: prod.splits if_splits)
        apply (drule set_get_min_rest; fastforce)
        done
    qed auto
  thus "invar_tree t'" and "invar ts'" by auto
qed

subsubsection \<open>\<open>del_min\<close>\<close>

definition del_min :: "'a::linorder heap \<Rightarrow> 'a::linorder heap" where
"del_min ts = (case get_min_rest ts of
   (Node r x ts\<^sub>1, ts\<^sub>2) \<Rightarrow> merge (rev ts\<^sub>1) ts\<^sub>2)"

lemma invar_del_min[simp]:
  assumes "ts \<noteq> []"
  assumes "invar ts"
  shows "invar (del_min ts)"
using assms
unfolding del_min_def
by (auto
      split: prod.split tree.split
      intro!: invar_merge invar_children
      dest: invar_get_min_rest
    )

lemma mset_heap_del_min:
  assumes "ts \<noteq> []"
  shows "mset_heap ts = mset_heap (del_min ts) + {# get_min ts #}"
using assms
unfolding del_min_def
apply (clarsimp split: tree.split prod.split)
apply (frule (1) get_min_rest_get_min_same_root)
apply (frule (1) mset_get_min_rest)
apply (auto simp: mset_heap_def)
done

subsubsection \<open>Instantiating the Priority Queue Locale\<close>

text \<open>Last step of functional correctness proof: combine all the above lemmas
to show that binomial heaps satisfy the specification of priority queues with merge.\<close>

interpretation binheap: Priority_Queue_Merge
  where empty = "[]" and is_empty = "(=) []" and insert = insert
  and get_min = get_min and del_min = del_min and merge = merge
  and invar = invar and mset = mset_heap
proof (unfold_locales, goal_cases)
  case 1 thus ?case by simp
next
  case 2 thus ?case by auto
next
  case 3 thus ?case by auto
next
  case (4 q)
  thus ?case using mset_heap_del_min[of q] get_min[OF _ \<open>invar q\<close>]
    by (auto simp: union_single_eq_diff)
next
  case (5 q) thus ?case using get_min[of q] by auto
next
  case 6 thus ?case by (auto simp add: invar_def)
next
  case 7 thus ?case by simp
next
  case 8 thus ?case by simp
next
  case 9 thus ?case by simp
next
  case 10 thus ?case by simp
qed

subsection \<open>Complexity\<close>

text \<open>The size of a binomial tree is determined by its rank\<close>
lemma size_mset_btree:
  assumes "invar_btree t"
  shows "size (mset_tree t) = 2^rank t"
  using assms
proof (induction t)
  case (Node r v ts)
  hence IH: "size (mset_tree t) = 2^rank t" if "t \<in> set ts" for t
    using that by auto

  from Node have COMPL: "map rank ts = rev [0..<r]" by auto

  have "size (mset_heap ts) = (\<Sum>t\<leftarrow>ts. size (mset_tree t))"
    by (induction ts) auto
  also have "\<dots> = (\<Sum>t\<leftarrow>ts. 2^rank t)" using IH
    by (auto cong: map_cong)
  also have "\<dots> = (\<Sum>r\<leftarrow>map rank ts. 2^r)"
    by (induction ts) auto
  also have "\<dots> = (\<Sum>i\<in>{0..<r}. 2^i)"
    unfolding COMPL
    by (auto simp: rev_map[symmetric] interv_sum_list_conv_sum_set_nat)
  also have "\<dots> = 2^r - 1"
    by (induction r) auto
  finally show ?case
    by (simp)
qed

lemma size_mset_tree:
  assumes "invar_tree t"
  shows "size (mset_tree t) = 2^rank t"
using assms unfolding invar_tree_def
by (simp add: size_mset_btree)

text \<open>The length of a binomial heap is bounded by the number of its elements\<close>
lemma size_mset_heap:
  assumes "invar ts"
  shows "length ts \<le> log 2 (size (mset_heap ts) + 1)"
proof -
  from \<open>invar ts\<close> have
    ASC: "sorted_wrt (<) (map rank ts)" and
    TINV: "\<forall>t\<in>set ts. invar_tree t"
    unfolding invar_def by auto

  have "(2::nat)^length ts = (\<Sum>i\<in>{0..<length ts}. 2^i) + 1"
    by (simp add: sum_power2)
  also have "\<dots> \<le> (\<Sum>t\<leftarrow>ts. 2^rank t) + 1"
    using sorted_wrt_less_sum_mono_lowerbound[OF _ ASC, of "(^) (2::nat)"]
    using power_increasing[where a="2::nat"]
    by (auto simp: o_def)
  also have "\<dots> = (\<Sum>t\<leftarrow>ts. size (mset_tree t)) + 1" using TINV
    by (auto cong: map_cong simp: size_mset_tree)
  also have "\<dots> = size (mset_heap ts) + 1"
    unfolding mset_heap_def by (induction ts) auto
  finally have "2^length ts \<le> size (mset_heap ts) + 1" .
  then show ?thesis using le_log2_of_power by blast
qed

subsubsection \<open>Timing Functions\<close>

text \<open>
  We define timing functions for each operation, and provide
  estimations of their complexity.
\<close>
definition T_link :: "'a::linorder tree \<Rightarrow> 'a tree \<Rightarrow> nat" where
[simp]: "T_link _ _ = 1"

text \<open>This function is non-canonical: we omitted a \<open>+1\<close> in the \<open>else\<close>-part,
  to keep the following analysis simpler and more to the point.
\<close>
fun T_ins_tree :: "'a::linorder tree \<Rightarrow> 'a heap \<Rightarrow> nat" where
  "T_ins_tree t [] = 1"
| "T_ins_tree t\<^sub>1 (t\<^sub>2 # ts) = (
    (if rank t\<^sub>1 < rank t\<^sub>2 then 1
     else T_link t\<^sub>1 t\<^sub>2 + T_ins_tree (link t\<^sub>1 t\<^sub>2) ts)
  )"

definition T_insert :: "'a::linorder \<Rightarrow> 'a heap \<Rightarrow> nat" where
"T_insert x ts = T_ins_tree (Node 0 x []) ts + 1"

lemma T_ins_tree_simple_bound: "T_ins_tree t ts \<le> length ts + 1"
by (induction t ts rule: T_ins_tree.induct) auto

subsubsection \<open>\<open>T_insert\<close>\<close>

lemma T_insert_bound:
  assumes "invar ts"
  shows "T_insert x ts \<le> log 2 (size (mset_heap ts) + 1) + 2"
proof -
  have "real (T_insert x ts) \<le> real (length ts) + 2"
    unfolding T_insert_def using T_ins_tree_simple_bound
    using of_nat_mono by fastforce
  also note size_mset_heap[OF \<open>invar ts\<close>]
  finally show ?thesis by simp
qed

subsubsection \<open>\<open>T_merge\<close>\<close>

context
includes pattern_aliases
begin

fun T_merge :: "'a::linorder heap \<Rightarrow> 'a heap \<Rightarrow> nat" where
  "T_merge ts\<^sub>1 [] = 1"
| "T_merge [] ts\<^sub>2 = 1"
| "T_merge (t\<^sub>1#ts\<^sub>1 =: h\<^sub>1) (t\<^sub>2#ts\<^sub>2 =: h\<^sub>2) = 1 + (
    if rank t\<^sub>1 < rank t\<^sub>2 then T_merge ts\<^sub>1 h\<^sub>2
    else if rank t\<^sub>2 < rank t\<^sub>1 then T_merge h\<^sub>1 ts\<^sub>2
    else T_ins_tree (link t\<^sub>1 t\<^sub>2) (merge ts\<^sub>1 ts\<^sub>2) + T_merge ts\<^sub>1 ts\<^sub>2
  )"

end

text \<open>A crucial idea is to estimate the time in correlation with the
  result length, as each carry reduces the length of the result.\<close>

lemma T_ins_tree_length:
  "T_ins_tree t ts + length (ins_tree t ts) = 2 + length ts"
by (induction t ts rule: ins_tree.induct) auto

lemma T_merge_length:
  "length (merge ts\<^sub>1 ts\<^sub>2) + T_merge ts\<^sub>1 ts\<^sub>2 \<le> 2 * (length ts\<^sub>1 + length ts\<^sub>2) + 1"
by (induction ts\<^sub>1 ts\<^sub>2 rule: T_merge.induct)
   (auto simp: T_ins_tree_length algebra_simps)

text \<open>Finally, we get the desired logarithmic bound\<close>
lemma T_merge_bound:
  fixes ts\<^sub>1 ts\<^sub>2
  defines "n\<^sub>1 \<equiv> size (mset_heap ts\<^sub>1)"
  defines "n\<^sub>2 \<equiv> size (mset_heap ts\<^sub>2)"
  assumes "invar ts\<^sub>1" "invar ts\<^sub>2"
  shows "T_merge ts\<^sub>1 ts\<^sub>2 \<le> 4*log 2 (n\<^sub>1 + n\<^sub>2 + 1) + 1"
proof -
  note n_defs = assms(1,2)

  have "T_merge ts\<^sub>1 ts\<^sub>2 \<le> 2 * real (length ts\<^sub>1) + 2 * real (length ts\<^sub>2) + 1"
    using T_merge_length[of ts\<^sub>1 ts\<^sub>2] by simp
  also note size_mset_heap[OF \<open>invar ts\<^sub>1\<close>]
  also note size_mset_heap[OF \<open>invar ts\<^sub>2\<close>]
  finally have "T_merge ts\<^sub>1 ts\<^sub>2 \<le> 2 * log 2 (n\<^sub>1 + 1) + 2 * log 2 (n\<^sub>2 + 1) + 1"
    unfolding n_defs by (simp add: algebra_simps)
  also have "log 2 (n\<^sub>1 + 1) \<le> log 2 (n\<^sub>1 + n\<^sub>2 + 1)"
    unfolding n_defs by (simp add: algebra_simps)
  also have "log 2 (n\<^sub>2 + 1) \<le> log 2 (n\<^sub>1 + n\<^sub>2 + 1)"
    unfolding n_defs by (simp add: algebra_simps)
  finally show ?thesis by (simp add: algebra_simps)
qed

subsubsection \<open>\<open>T_get_min\<close>\<close>

fun T_get_min :: "'a::linorder heap \<Rightarrow> nat" where
  "T_get_min [t] = 1"
| "T_get_min (t#ts) = 1 + T_get_min ts"

lemma T_get_min_estimate: "ts\<noteq>[] \<Longrightarrow> T_get_min ts = length ts"
by (induction ts rule: T_get_min.induct) auto

lemma T_get_min_bound:
  assumes "invar ts"
  assumes "ts\<noteq>[]"
  shows "T_get_min ts \<le> log 2 (size (mset_heap ts) + 1)"
proof -
  have 1: "T_get_min ts = length ts" using assms T_get_min_estimate by auto
  also note size_mset_heap[OF \<open>invar ts\<close>]
  finally show ?thesis .
qed

subsubsection \<open>\<open>T_del_min\<close>\<close>

fun T_get_min_rest :: "'a::linorder heap \<Rightarrow> nat" where
  "T_get_min_rest [t] = 1"
| "T_get_min_rest (t#ts) = 1 + T_get_min_rest ts"

lemma T_get_min_rest_estimate: "ts\<noteq>[] \<Longrightarrow> T_get_min_rest ts = length ts"
  by (induction ts rule: T_get_min_rest.induct) auto

lemma T_get_min_rest_bound:
  assumes "invar ts"
  assumes "ts\<noteq>[]"
  shows "T_get_min_rest ts \<le> log 2 (size (mset_heap ts) + 1)"
proof -
  have 1: "T_get_min_rest ts = length ts" using assms T_get_min_rest_estimate by auto
  also note size_mset_heap[OF \<open>invar ts\<close>]
  finally show ?thesis .
qed

text\<open>Note that although the definition of function \<^const>\<open>rev\<close> has quadratic complexity,
it can and is implemented (via suitable code lemmas) as a linear time function.
Thus the following definition is justified:\<close>

definition "T_rev xs = length xs + 1"

definition T_del_min :: "'a::linorder heap \<Rightarrow> nat" where
  "T_del_min ts = T_get_min_rest ts + (case get_min_rest ts of (Node _ x ts\<^sub>1, ts\<^sub>2)
                    \<Rightarrow> T_rev ts\<^sub>1 + T_merge (rev ts\<^sub>1) ts\<^sub>2
  ) + 1"

lemma T_del_min_bound:
  fixes ts
  defines "n \<equiv> size (mset_heap ts)"
  assumes "invar ts" and "ts\<noteq>[]"
  shows "T_del_min ts \<le> 6 * log 2 (n+1) + 3"
proof -
  obtain r x ts\<^sub>1 ts\<^sub>2 where GM: "get_min_rest ts = (Node r x ts\<^sub>1, ts\<^sub>2)"
    by (metis surj_pair tree.exhaust_sel)

  have I1: "invar (rev ts\<^sub>1)" and I2: "invar ts\<^sub>2"
    using invar_get_min_rest[OF GM \<open>ts\<noteq>[]\<close> \<open>invar ts\<close>] invar_children
    by auto

  define n\<^sub>1 where "n\<^sub>1 = size (mset_heap ts\<^sub>1)"
  define n\<^sub>2 where "n\<^sub>2 = size (mset_heap ts\<^sub>2)"

  have "n\<^sub>1 \<le> n" "n\<^sub>1 + n\<^sub>2 \<le> n" unfolding n_def n\<^sub>1_def n\<^sub>2_def
    using mset_get_min_rest[OF GM \<open>ts\<noteq>[]\<close>]
    by (auto simp: mset_heap_def)

  have "T_del_min ts = real (T_get_min_rest ts) + real (T_rev ts\<^sub>1) + real (T_merge (rev ts\<^sub>1) ts\<^sub>2) + 1"
    unfolding T_del_min_def GM
    by simp
  also have "T_get_min_rest ts \<le> log 2 (n+1)"
    using T_get_min_rest_bound[OF \<open>invar ts\<close> \<open>ts\<noteq>[]\<close>] unfolding n_def by simp
  also have "T_rev ts\<^sub>1 \<le> 1 + log 2 (n\<^sub>1 + 1)"
    unfolding T_rev_def n\<^sub>1_def using size_mset_heap[OF I1] by simp
  also have "T_merge (rev ts\<^sub>1) ts\<^sub>2 \<le> 4*log 2 (n\<^sub>1 + n\<^sub>2 + 1) + 1"
    unfolding n\<^sub>1_def n\<^sub>2_def using T_merge_bound[OF I1 I2] by (simp add: algebra_simps)
  finally have "T_del_min ts \<le> log 2 (n+1) + log 2 (n\<^sub>1 + 1) + 4*log 2 (real (n\<^sub>1 + n\<^sub>2) + 1) + 3"
    by (simp add: algebra_simps)
  also note \<open>n\<^sub>1 + n\<^sub>2 \<le> n\<close>
  also note \<open>n\<^sub>1 \<le> n\<close>
  finally show ?thesis by (simp add: algebra_simps)
qed

end


theory Exercises2_04
  imports Main
begin

(*---------------- Exercise 2.4----------------*)
(* snoc function -- reverse of cons *)
fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc Nil a = (Cons a Nil)" |
"snoc (Cons x xs) a = (Cons x (snoc xs a))"

(* reverse function*)
fun reverse :: "'a list \<Rightarrow> 'a list" where
"reverse Nil = Nil" |
"reverse (Cons x xs) = snoc (reverse xs) x"

lemma snoc_reverse : "reverse(snoc xs a) = a # reverse xs"
  apply(induction xs)
   apply(auto)
  done

theorem double_rev : "reverse (reverse xs) = xs"
  apply(induction xs)
   apply(auto)
  apply(simp add: snoc_reverse)
  done

end


theory Bexp
imports Aexp
begin

section \<open>Boolean Expressions\<close>

text \<open>We proceed as in \verb?Aexp.thy?.\<close>

subsection\<open>Basic definitions\<close>

subsubsection \<open>The $\mathit{bexp}$ type-synonym\<close>

text \<open>We represent boolean expressions, their set of variables and the notion of freshness of a
variable in the same way than for arithmetic expressions.\<close>

type_synonym ('v,'d) bexp = "('v,'d) state \<Rightarrow> bool"

definition vars ::
  "('v,'d) bexp \<Rightarrow> 'v set"
where
  "vars e = {v. \<exists> \<sigma> val. e (\<sigma>(v := val)) \<noteq> e \<sigma>}"

abbreviation fresh ::
  "'v \<Rightarrow> ('v,'d) bexp \<Rightarrow> bool"
where
  "fresh v e \<equiv> v \<notin> vars e"

subsubsection\<open>Satisfiability of an expression\<close>

text \<open>A boolean expression @{term "e"} is satisfiable if there exists a state @{term "\<sigma>"} such
that @{term "e \<sigma>"} is \emph{true}.\<close>

definition sat ::
  "('v,'d) bexp \<Rightarrow> bool"
where
  "sat e = (\<exists> \<sigma>. e \<sigma>)"

subsubsection \<open>Entailment\<close>

text \<open>A boolean expression @{term "\<phi>"} entails another boolean expression @{term "\<psi>"} if all
states making @{term "\<phi>"} true also make @{term "\<psi>"} true.\<close>

definition entails ::
  "('v,'d) bexp \<Rightarrow> ('v,'d) bexp \<Rightarrow> bool" (infixl "\<Turnstile>\<^sub>B" 55)
where
  "\<phi> \<Turnstile>\<^sub>B \<psi> \<equiv> (\<forall> \<sigma>. \<phi> \<sigma> \<longrightarrow> \<psi> \<sigma>)"

subsubsection \<open>Conjunction\<close>

text \<open>In the following, path predicates are represented by sets of boolean expressions. We define
the conjunction of a set of boolean expressions @{term "E"} as the expression that
associates \emph{true} to a state @{term "\<sigma>"} if, for all elements \<open>e\<close> of
@{term "E"}, @{term "e"} associates \emph{true} to @{term "\<sigma>"}.\<close>

definition conjunct ::
  "('v,'d) bexp set \<Rightarrow> ('v,'d) bexp"
where
  "conjunct E \<equiv> (\<lambda> \<sigma>. \<forall> e \<in> E. e \<sigma>)"

subsection\<open>Properties about the variables of an expression\<close>

text \<open>As said earlier, our definition of symbolic execution requires the existence of a fresh
symbolic variable in the case of an assignment. In the following, a number of proof relies on this
fact. We will show the existence of such variables assuming the set of symbolic variables already in
use is finite and show that symbolic execution preserves the finiteness of this set, under certain
conditions. This in turn
requires a number of lemmas about the finiteness of boolean expressions.
More precisely, when symbolic execution goes through a guard or an assignment, it conjuncts a new
expression to the path predicate. In the case of an assignment, this new expression is an equality
linking the new symbolic variable associated to the defined program variable to its symbolic value.
In the following, we prove that:
\begin{enumerate}
  \item the conjunction of a finite set of expressions whose sets of variables are finite has a
finite set of variables,
  \item the equality of two arithmetic expressions whose sets of variables are finite has a finite
set of variables.
\end{enumerate}\<close>

subsubsection \<open>Variables of a conjunction\<close>

text \<open>The set of variables of the conjunction of two expressions is a subset of the union of the
sets of variables of the two sub-expressions. As a consequence, the set of variables of the conjunction
of a finite set of expressions whose sets of variables are finite is also finite.\<close>

lemma vars_of_conj :
  "vars (\<lambda> \<sigma>. e1 \<sigma> \<and> e2 \<sigma>) \<subseteq> vars e1 \<union> vars e2"
(is "vars ?e \<subseteq> vars e1 \<union> vars e2")
unfolding subset_iff
proof (intro allI impI)
  fix v assume "v \<in> vars ?e"

  then obtain \<sigma> val
  where "?e (\<sigma> (v := val)) \<noteq> ?e \<sigma>"
  unfolding vars_def by blast

  hence "e1 (\<sigma> (v := val)) \<noteq> e1 \<sigma> \<or> e2 (\<sigma> (v := val)) \<noteq> e2 \<sigma>"
  by auto

  thus "v \<in> vars e1 \<union> vars e2" unfolding vars_def by blast
qed

lemma finite_conj :
  assumes "finite E"
  assumes "\<forall> e \<in> E. finite (vars e)"
  shows   "finite (vars (conjunct E))"
using assms
proof (induct rule : finite_induct, goal_cases)
  case 1 thus ?case by (simp add : vars_def conjunct_def)
next
  case (2 e E)

  thus ?case
  using vars_of_conj[of e "conjunct E"]
  by (rule_tac rev_finite_subset, auto simp add : conjunct_def)
qed

subsubsection \<open>Variables of an equality\<close>

text \<open>We proceed analogously for the equality of two arithmetic expressions.\<close>

lemma vars_of_eq_a :
  shows  "vars (\<lambda> \<sigma>. e1 \<sigma> = e2 \<sigma>) \<subseteq> Aexp.vars e1 \<union> Aexp.vars e2"
(is "vars ?e \<subseteq> Aexp.vars e1 \<union> Aexp.vars e2")
unfolding subset_iff
proof (intro allI impI)

  fix v assume "v \<in> vars ?e"

  then obtain \<sigma> val where "?e (\<sigma> (v := val)) \<noteq> ?e \<sigma>"
  unfolding vars_def by blast

  hence "e1 (\<sigma> (v := val)) \<noteq> e1 \<sigma> \<or> e2 (\<sigma> (v := val)) \<noteq> e2 \<sigma>"
  by auto

  thus "v \<in> Aexp.vars e1 \<union> Aexp.vars e2"
  unfolding Aexp.vars_def by blast
qed

lemma finite_vars_of_a_eq :
  assumes "finite (Aexp.vars e1)"
  assumes "finite (Aexp.vars e2)"
  shows   "finite (vars (\<lambda> \<sigma>. e1 \<sigma> = e2 \<sigma>))"
using assms vars_of_eq_a[of e1 e2] by (rule_tac rev_finite_subset, auto)

end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM
*)

header "Maximal prefix"

theory MaxPrefix
imports "~~/src/HOL/Library/Sublist"
begin

definition
 is_maxpref :: "('a list => bool) => 'a list => 'a list => bool" where
"is_maxpref P xs ys =
 (prefixeq xs ys & (xs=[] | P xs) & (!zs. prefixeq zs ys & P zs --> prefixeq zs xs))"

type_synonym 'a splitter = "'a list => 'a list * 'a list"

definition
 is_maxsplitter :: "('a list => bool) => 'a splitter => bool" where
"is_maxsplitter P f =
 (!xs ps qs. f xs = (ps,qs) = (xs=ps@qs & is_maxpref P ps xs))"

primrec maxsplit :: "('a list => bool) => 'a list * 'a list => 'a list => 'a splitter" where
"maxsplit P res ps []     = (if P ps then (ps,[]) else res)" |
"maxsplit P res ps (q#qs) = maxsplit P (if P ps then (ps,q#qs) else res)
                                     (ps@[q]) qs"

declare split_if[split del]

lemma maxsplit_lemma: "!!(ps::'a list) res.
  (maxsplit P res ps qs = (xs,ys)) =
  (if EX us. prefixeq us qs & P(ps@us) then xs@ys=ps@qs & is_maxpref P xs (ps@qs)
   else (xs,ys)=res)"
apply(unfold is_maxpref_def)
apply (induct "qs")
 apply (simp split: split_if)
 apply blast
apply simp
apply (erule thin_rl)
apply clarify
apply (case_tac "EX us. prefixeq us qs & P (ps @ a # us)")
 apply (subgoal_tac "EX us. prefixeq us (a # qs) & P (ps @ us)")
  apply simp
 apply (blast intro: prefixeq_Cons[THEN iffD2])
apply (subgoal_tac "~P(ps@[a])")
 prefer 2 apply blast
apply (simp (no_asm_simp))
apply (case_tac "EX us. prefixeq us (a#qs) & P (ps @ us)")
 apply simp
 apply clarify
 apply (case_tac "us")
  apply (rule iffI)
   apply (simp add: prefixeq_Cons prefixeq_append)
   apply blast
  apply (simp add: prefixeq_Cons prefixeq_append)
  apply clarify
  apply (erule disjE)
   apply (fast dest: prefix_order.antisym)
  apply clarify
  apply (erule disjE)
   apply clarify
   apply simp
  apply (erule disjE)
   apply clarify
   apply simp
  apply blast
 apply simp
apply (subgoal_tac "~P(ps)")
apply (simp (no_asm_simp))
apply fastforce
done

declare split_if[split add]

lemma is_maxpref_Nil[simp]:
 "~(? us. prefixeq us xs & P us) ==> is_maxpref P ps xs = (ps = [])"
apply(unfold is_maxpref_def)
apply blast
done

lemma is_maxsplitter_maxsplit:
 "is_maxsplitter P (%xs. maxsplit P ([],xs) [] xs)"
apply(unfold is_maxsplitter_def)
apply (simp add: maxsplit_lemma)
apply (fastforce)
done

lemmas maxsplit_eq = is_maxsplitter_maxsplit[simplified is_maxsplitter_def]

end


theorem sqrt2_not_rational:
"sqrt 2 ∉ Q"
proof
let ?x = "sqrt 2"
assume "?x ∈ Q"
then obtain m n :: nat where
sqrt_rat: "¦?x¦ = m / n" and lowest_terms: "coprime m n"
by (rule Rats_abs_nat_div_natE)
hence "m^2 = ?x^2 * n^2" by (auto simp add: power2_eq_square)
hence eq: "m^2 = 2 * n^2" using of_nat_eq_iff power2_eq_square by fastforce
hence "2 dvd m^2" by simp
hence "2 dvd m" by simp
have "2 dvd n" proof -
from ‹2 dvd m› obtain k where "m = 2 * k" ..
with eq have "2 * n^2 = 2^2 * k^2" by simp
hence "2 dvd n^2" by simp
thus "2 dvd n" by simp
qed
with ‹2 dvd m› have "2 dvd gcd m n" by (rule gcd_greatest)
with lowest_terms have "2 dvd 1" by simp
thus False using odd_one by blast
qed


section \<open>Union-Find Data-Structure\<close>
theory Union_Find
imports
  "../Sep_Main"
  Collections.Partial_Equivalence_Relation
  "HOL-Library.Code_Target_Numeral"
begin
text \<open>
  We implement a simple union-find data-structure based on an array.
  It uses path compression and a size-based union heuristics.
\<close>

subsection \<open>Abstract Union-Find on Lists\<close>
text \<open>
  We first formulate union-find structures on lists, and later implement
  them using Imperative/HOL. This is a separation of proof concerns
  between proving the algorithmic idea correct and generating the verification
  conditions.
\<close>

subsubsection \<open>Representatives\<close>
text \<open>
  We define a function that searches for the representative of an element.
  This function is only partially defined, as it does not terminate on all
  lists. We use the domain of this function to characterize valid union-find
  lists.
\<close>
function (domintros) rep_of
  where "rep_of l i = (if l!i = i then i else rep_of l (l!i))"
  by pat_completeness auto

text \<open>A valid union-find structure only contains valid indexes, and
  the \<open>rep_of\<close> function terminates for all indexes.\<close>
definition
  "ufa_invar l \<equiv> \<forall>i<length l. rep_of_dom (l,i) \<and> l!i<length l"

lemma ufa_invarD:
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> rep_of_dom (l,i)"
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> l!i<length l"
  unfolding ufa_invar_def by auto

text \<open>We derive the following equations for the \<open>rep-of\<close> function.\<close>
lemma rep_of_refl: "l!i=i \<Longrightarrow> rep_of l i = i"
  apply (subst rep_of.psimps)
  apply (rule rep_of.domintros)
  apply (auto)
  done

lemma rep_of_step:
  "\<lbrakk>ufa_invar l; i<length l; l!i\<noteq>i\<rbrakk> \<Longrightarrow> rep_of l i = rep_of l (l!i)"
  apply (subst rep_of.psimps)
  apply (auto dest: ufa_invarD)
  done

lemmas rep_of_simps = rep_of_refl rep_of_step

lemma rep_of_iff: "\<lbrakk>ufa_invar l; i<length l\<rbrakk>
  \<Longrightarrow> rep_of l i = (if l!i=i then i else rep_of l (l!i))"
  by (simp add: rep_of_simps)

text \<open>We derive a custom induction rule, that is more suited to
  our purposes.\<close>
lemma rep_of_induct[case_names base step, consumes 2]:
  assumes I: "ufa_invar l"
  assumes L: "i<length l"
  assumes BASE: "\<And>i. \<lbrakk> ufa_invar l; i<length l; l!i=i \<rbrakk> \<Longrightarrow> P l i"
  assumes STEP: "\<And>i. \<lbrakk> ufa_invar l; i<length l; l!i\<noteq>i; P l (l!i) \<rbrakk>
    \<Longrightarrow> P l i"
  shows "P l i"
proof -
  from ufa_invarD[OF I L] have "ufa_invar l \<and> i<length l \<longrightarrow> P l i"
    apply (induct l\<equiv>l i rule: rep_of.pinduct)
    apply (auto intro: STEP BASE dest: ufa_invarD)
    done
  thus ?thesis using I L by simp
qed

text \<open>In the following, we define various properties of \<open>rep_of\<close>.\<close>
lemma rep_of_min:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
proof -
  have "\<lbrakk>rep_of_dom (l,i) \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
    apply (induct arbitrary:  rule: rep_of.pinduct)
    apply (subst rep_of.psimps, assumption)
    apply (subst (2) rep_of.psimps, assumption)
    apply auto
    done
  thus "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> l!(rep_of l i) = rep_of l i"
    by (metis ufa_invarD(1))
qed

lemma rep_of_bound:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> rep_of l i < length l"
  apply (induct rule: rep_of_induct)
  apply (auto simp: rep_of_iff)
  done

lemma rep_of_idem:
  "\<lbrakk> ufa_invar l; i<length l \<rbrakk> \<Longrightarrow> rep_of l (rep_of l i) = rep_of l i"
  by (auto simp: rep_of_min rep_of_refl)

lemma rep_of_min_upd: "\<lbrakk> ufa_invar l; x<length l; i<length l \<rbrakk> \<Longrightarrow>
  rep_of (l[rep_of l x := rep_of l x]) i = rep_of l i"
  by (metis list_update_id rep_of_min)

lemma rep_of_idx:
  "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow> rep_of l (l!i) = rep_of l i"
  by (metis rep_of_step)

subsubsection \<open>Abstraction to Partial Equivalence Relation\<close>
definition ufa_\<alpha> :: "nat list \<Rightarrow> (nat\<times>nat) set"
  where "ufa_\<alpha> l
    \<equiv> {(x,y). x<length l \<and> y<length l \<and> rep_of l x = rep_of l y}"

lemma ufa_\<alpha>_equiv[simp, intro!]: "part_equiv (ufa_\<alpha> l)"
  apply rule
  unfolding ufa_\<alpha>_def
  apply (rule symI)
  apply auto
  apply (rule transI)
  apply auto
  done

lemma ufa_\<alpha>_lenD:
  "(x,y)\<in>ufa_\<alpha> l \<Longrightarrow> x<length l"
  "(x,y)\<in>ufa_\<alpha> l \<Longrightarrow> y<length l"
  unfolding ufa_\<alpha>_def by auto

lemma ufa_\<alpha>_dom[simp]: "Domain (ufa_\<alpha> l) = {0..<length l}"
  unfolding ufa_\<alpha>_def by auto

lemma ufa_\<alpha>_refl[simp]: "(i,i)\<in>ufa_\<alpha> l \<longleftrightarrow> i<length l"
  unfolding ufa_\<alpha>_def
  by simp

lemma ufa_\<alpha>_len_eq:
  assumes "ufa_\<alpha> l = ufa_\<alpha> l'"
  shows "length l = length l'"
  by (metis assms le_antisym less_not_refl linorder_le_less_linear ufa_\<alpha>_refl)

subsubsection \<open>Operations\<close>
lemma ufa_init_invar: "ufa_invar [0..<n]"
  unfolding ufa_invar_def
  by (auto intro: rep_of.domintros)

lemma ufa_init_correct: "ufa_\<alpha> [0..<n] = {(x,x) | x. x<n}"
  unfolding ufa_\<alpha>_def
  using ufa_init_invar[of n]
  apply (auto simp: rep_of_refl)
  done

lemma ufa_find_correct: "\<lbrakk>ufa_invar l; x<length l; y<length l\<rbrakk>
  \<Longrightarrow> rep_of l x = rep_of l y \<longleftrightarrow> (x,y)\<in>ufa_\<alpha> l"
  unfolding ufa_\<alpha>_def
  by auto

abbreviation "ufa_union l x y \<equiv> l[rep_of l x := rep_of l y]"

lemma ufa_union_invar:
  assumes I: "ufa_invar l"
  assumes L: "x<length l" "y<length l"
  shows "ufa_invar (ufa_union l x y)"
  unfolding ufa_invar_def
proof (intro allI impI, simp only: length_list_update)
  fix i
  assume A: "i<length l"
  with I have "rep_of_dom (l,i)" by (auto dest: ufa_invarD)

  have "ufa_union l x y ! i < length l" using I L A
    apply (cases "i=rep_of l x")
    apply (auto simp: rep_of_bound dest: ufa_invarD)
    done
  moreover have "rep_of_dom (ufa_union l x y, i)" using I A L
  proof (induct rule: rep_of_induct)
    case (base i)
    thus ?case
      apply -
      apply (rule rep_of.domintros)
      apply (cases "i=rep_of l x")
      apply auto
      apply (rule rep_of.domintros)
      apply (auto simp: rep_of_min)
      done
  next
    case (step i)

    from step.prems \<open>ufa_invar l\<close> \<open>i<length l\<close> \<open>l!i\<noteq>i\<close>
    have [simp]: "ufa_union l x y ! i = l!i"
      apply (auto simp: rep_of_min rep_of_bound nth_list_update)
      done

    from step show ?case
      apply -
      apply (rule rep_of.domintros)
      apply simp
      done
  qed
  ultimately show
    "rep_of_dom (ufa_union l x y, i) \<and> ufa_union l x y ! i < length l"
    by blast

qed

lemma ufa_union_aux:
  assumes I: "ufa_invar l"
  assumes L: "x<length l" "y<length l"
  assumes IL: "i<length l"
  shows "rep_of (ufa_union l x y) i =
    (if rep_of l i = rep_of l x then rep_of l y else rep_of l i)"
  using I IL
proof (induct rule: rep_of_induct)
  case (base i)
  have [simp]: "rep_of l i = i" using \<open>l!i=i\<close> by (simp add: rep_of_refl)
  note [simp] = \<open>ufa_invar l\<close> \<open>i<length l\<close>
  show ?case proof (cases)
    assume A[simp]: "rep_of l x = i"
    have [simp]: "l[i := rep_of l y] ! i = rep_of l y"
      by (auto simp: rep_of_bound)

    show ?thesis proof (cases)
      assume [simp]: "rep_of l y = i"
      show ?thesis by (simp add: rep_of_refl)
    next
      assume A: "rep_of l y \<noteq> i"
      have [simp]: "rep_of (l[i := rep_of l y]) i = rep_of l y"
        apply (subst rep_of_step[OF ufa_union_invar[OF I L], simplified])
        using A apply simp_all
        apply (subst rep_of_refl[where i="rep_of l y"])
        using I L
        apply (simp_all add: rep_of_min)
        done
      show ?thesis by (simp add: rep_of_refl)
    qed
  next
    assume A: "rep_of l x \<noteq> i"
    hence "ufa_union l x y ! i = l!i" by (auto)
    also note \<open>l!i=i\<close>
    finally have "rep_of (ufa_union l x y) i = i" by (simp add: rep_of_refl)
    thus ?thesis using A by auto
  qed
next
  case (step i)

  note [simp] = I L \<open>i<length l\<close>

  have "rep_of l x \<noteq> i" by (metis I L(1) rep_of_min \<open>l!i\<noteq>i\<close>)
  hence [simp]: "ufa_union l x y ! i = l!i"
    by (auto simp add: nth_list_update rep_of_bound \<open>l!i\<noteq>i\<close>) []

  have "rep_of (ufa_union l x y) i = rep_of (ufa_union l x y) (l!i)"
    by (auto simp add: rep_of_iff[OF ufa_union_invar[OF I L]])
  also note step.hyps(4)
  finally show ?case
    by (auto simp: rep_of_idx)
qed

lemma ufa_union_correct: "\<lbrakk> ufa_invar l; x<length l; y<length l \<rbrakk>
  \<Longrightarrow> ufa_\<alpha> (ufa_union l x y) = per_union (ufa_\<alpha> l) x y"
  unfolding ufa_\<alpha>_def per_union_def
  by (auto simp: ufa_union_aux
    split: if_split_asm
  )

lemma ufa_compress_aux:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_invar (l[x := rep_of l x])"
  and "\<forall>i<length l. rep_of (l[x := rep_of l x]) i = rep_of l i"
proof -
  {
    fix i
    assume "i<length (l[x := rep_of l x])"
    hence IL: "i<length l" by simp

    have G1: "l[x := rep_of l x] ! i < length (l[x := rep_of l x])"
      using I IL
      by (auto dest: ufa_invarD[OF I] simp: nth_list_update rep_of_bound)
    from I IL have G2: "rep_of (l[x := rep_of l x]) i = rep_of l i
      \<and> rep_of_dom (l[x := rep_of l x], i)"
    proof (induct rule: rep_of_induct)
      case (base i)
      thus ?case
        apply (cases "x=i")
        apply (auto intro: rep_of.domintros simp: rep_of_refl)
        done
    next
      case (step i)
      hence D: "rep_of_dom (l[x := rep_of l x], i)"
        apply -
        apply (rule rep_of.domintros)
        apply (cases "x=i")
        apply (auto intro: rep_of.domintros simp: rep_of_min)
        done

      thus ?case apply simp using step
        apply -
        apply (subst rep_of.psimps[OF D])
        apply (cases "x=i")
        apply (auto simp: rep_of_min rep_of_idx)
        apply (subst rep_of.psimps[where i="rep_of l i"])
        apply (auto intro: rep_of.domintros simp: rep_of_min)
        done
    qed
    note G1 G2
  } note G=this

  thus "\<forall>i<length l. rep_of (l[x := rep_of l x]) i = rep_of l i"
    by auto

  from G show "ufa_invar (l[x := rep_of l x])"
    by (auto simp: ufa_invar_def)
qed

lemma ufa_compress_invar:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_invar (l[x := rep_of l x])"
  using assms by (rule ufa_compress_aux)

lemma ufa_compress_correct:
  assumes I: "ufa_invar l"
  assumes L[simp]: "x<length l"
  shows "ufa_\<alpha> (l[x := rep_of l x]) = ufa_\<alpha> l"
  by (auto simp: ufa_\<alpha>_def ufa_compress_aux[OF I])

subsection \<open>Implementation with Imperative/HOL\<close>
text \<open>In this section, we implement the union-find data-structure with
  two arrays, one holding the next-pointers, and another one holding the size
  information. Note that we do not prove that the array for the
  size information contains any reasonable values, as the correctness of the
  algorithm is not affected by this. We leave it future work to also estimate
  the complexity of the algorithm.
\<close>

type_synonym uf = "nat array \<times> nat array"

definition is_uf :: "(nat\<times>nat) set \<Rightarrow> uf \<Rightarrow> assn" where
  "is_uf R u \<equiv> case u of (s,p) \<Rightarrow>
  \<exists>\<^sub>Al szl. p\<mapsto>\<^sub>al * s\<mapsto>\<^sub>aszl
    * \<up>(ufa_invar l \<and> ufa_\<alpha> l = R \<and> length szl = length l)"

definition uf_init :: "nat \<Rightarrow> uf Heap" where
  "uf_init n \<equiv> do {
    l \<leftarrow> Array.of_list [0..<n];
    szl \<leftarrow> Array.new n (1::nat);
    return (szl,l)
  }"

lemma uf_init_rule[sep_heap_rules]:
  "<emp> uf_init n <is_uf {(i,i) |i. i<n}>"
  unfolding uf_init_def is_uf_def[abs_def]
  by (sep_auto simp: ufa_init_correct ufa_init_invar)

partial_function (heap) uf_rep_of :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap"
  where [code]:
  "uf_rep_of p i = do {
    n \<leftarrow> Array.nth p i;
    if n=i then return i else uf_rep_of p n
  }"

lemma uf_rep_of_rule[sep_heap_rules]: "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al> uf_rep_of p i <\<lambda>r. p\<mapsto>\<^sub>al * \<up>(r=rep_of l i)>"
  apply (induct rule: rep_of_induct)
  apply (subst uf_rep_of.simps)
  apply (sep_auto simp: rep_of_refl)

  apply (subst uf_rep_of.simps)
  apply (sep_auto simp: rep_of_step)
  done

text \<open>We chose a non tail-recursive version here, as it is easier to prove.\<close>
partial_function (heap) uf_compress :: "nat \<Rightarrow> nat \<Rightarrow> nat array \<Rightarrow> unit Heap"
  where [code]:
  "uf_compress i ci p = (
    if i=ci then return ()
    else do {
      ni\<leftarrow>Array.nth p i;
      uf_compress ni ci p;
      Array.upd i ci p;
      return ()
    })"

lemma uf_compress_rule: "\<lbrakk> ufa_invar l; i<length l; ci=rep_of l i \<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al> uf_compress i ci p
  <\<lambda>_. \<exists>\<^sub>Al'. p\<mapsto>\<^sub>al' * \<up>(ufa_invar l' \<and> length l' = length l
     \<and> (\<forall>i<length l. rep_of l' i = rep_of l i))>"
proof (induction rule: rep_of_induct)
  case (base i) thus ?case
    apply (subst uf_compress.simps)
    apply (sep_auto simp: rep_of_refl)
    done
next
  case (step i)
  note SS = \<open>ufa_invar l\<close> \<open>i<length l\<close> \<open>l!i\<noteq>i\<close> \<open>ci = rep_of l i\<close>

  from step.IH
  have IH':
    "<p \<mapsto>\<^sub>a l>
       uf_compress (l ! i) (rep_of l i) p
     <\<lambda>_. \<exists>\<^sub>Al'. p \<mapsto>\<^sub>a l' *
        \<up> (ufa_invar l' \<and> length l = length l'
           \<and> (\<forall>i<length l'. rep_of l i = rep_of l' i))
     >"
    apply (simp add: rep_of_idx SS)
    apply (erule
      back_subst[OF _ cong[OF cong[OF arg_cong[where f=hoare_triple]]]])
    apply (auto) [2]
    apply (rule ext)
    apply (rule ent_iffI)
    apply sep_auto+
    done

  show ?case
    apply (subst uf_compress.simps)
    apply (sep_auto simp: SS)

    apply (rule IH')

    using SS apply (sep_auto (plain))
    using ufa_compress_invar apply fastforce []
    apply simp
    using ufa_compress_aux(2) apply fastforce []
    done
qed

definition uf_rep_of_c :: "nat array \<Rightarrow> nat \<Rightarrow> nat Heap"
  where "uf_rep_of_c p i \<equiv> do {
    ci\<leftarrow>uf_rep_of p i;
    uf_compress i ci p;
    return ci
  }"

lemma uf_rep_of_c_rule[sep_heap_rules]: "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al> uf_rep_of_c p i <\<lambda>r. \<exists>\<^sub>Al'. p\<mapsto>\<^sub>al'
    * \<up>(r=rep_of l i \<and> ufa_invar l'
       \<and> length l' = length l
       \<and> (\<forall>i<length l. rep_of l' i = rep_of l i))>"
  unfolding uf_rep_of_c_def
  by (sep_auto heap: uf_compress_rule)

definition uf_cmp :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool Heap" where
  "uf_cmp u i j \<equiv> do {
    let (s,p)=u;
    n\<leftarrow>Array.len p;
    if (i\<ge>n \<or> j\<ge>n) then return False
    else do {
      ci\<leftarrow>uf_rep_of_c p i;
      cj\<leftarrow>uf_rep_of_c p j;
      return (ci=cj)
    }
  }"

lemma cnv_to_ufa_\<alpha>_eq:
  "\<lbrakk>(\<forall>i<length l. rep_of l' i = rep_of l i); length l = length l'\<rbrakk>
  \<Longrightarrow> (ufa_\<alpha> l = ufa_\<alpha> l')"
  unfolding ufa_\<alpha>_def by auto

lemma uf_cmp_rule[sep_heap_rules]:
  "<is_uf R u> uf_cmp u i j <\<lambda>r. is_uf R u * \<up>(r\<longleftrightarrow>(i,j)\<in>R)>"
  unfolding uf_cmp_def is_uf_def
  apply (sep_auto dest: ufa_\<alpha>_lenD simp: not_le split: prod.split)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (drule cnv_to_ufa_\<alpha>_eq, simp_all)
  apply (subst ufa_find_correct)
  apply (auto simp add: )
  done

definition uf_union :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> uf Heap" where
  "uf_union u i j \<equiv> do {
    let (s,p)=u;
    ci \<leftarrow> uf_rep_of p i;
    cj \<leftarrow> uf_rep_of p j;
    if (ci=cj) then return (s,p)
    else do {
      si \<leftarrow> Array.nth s ci;
      sj \<leftarrow> Array.nth s cj;
      if si<sj then do {
        Array.upd ci cj p;
        Array.upd cj (si+sj) s;
        return (s,p)
      } else do {
        Array.upd cj ci p;
        Array.upd ci (si+sj) s;
        return (s,p)
      }
    }
  }"

lemma uf_union_rule[sep_heap_rules]: "\<lbrakk>i\<in>Domain R; j\<in> Domain R\<rbrakk>
  \<Longrightarrow> <is_uf R u> uf_union u i j <is_uf (per_union R i j)>"
  unfolding uf_union_def
  apply (cases u)
  apply (simp add: is_uf_def[abs_def])
  apply (sep_auto
    simp: per_union_cmp ufa_\<alpha>_lenD ufa_find_correct
    rep_of_bound
    ufa_union_invar
    ufa_union_correct
  )
  done

export_code uf_init uf_cmp uf_union checking SML_imp

export_code uf_init uf_cmp uf_union checking Scala_imp

(*
ML_val {*
  val u = @{code uf_init} 10 ();

  val u = @{code uf_union} u 1 2 ();
  val u = @{code uf_union} u 3 4 ();
  val u = @{code uf_union} u 5 6 ();
  val u = @{code uf_union} u 7 8 ();

  val u = @{code uf_union} u 1 3 ();
  val u = @{code uf_union} u 5 7 ();

  val u = @{code uf_union} u 1 5 ();

  val b = @{code uf_cmp} u 8 4 ();
  val it = u;
*}*)

end