(*  Title:      HOL/Analysis/Interval_Integral.thy
    Author:     Jeremy Avigad (CMU), Johannes Hölzl (TUM), Luke Serafin (CMU)

Lebesgue integral over an interval (with endpoints possibly +-\<infinity>)
*)

theory Interval_Integral (*FIX ME rename? Lebesgue  *)
  imports Equivalence_Lebesgue_Henstock_Integration
begin

definition "einterval a b = {x. a < ereal x \<and> ereal x < b}"

lemma einterval_eq[simp]:
  shows einterval_eq_Icc: "einterval (ereal a) (ereal b) = {a <..< b}"
    and einterval_eq_Ici: "einterval (ereal a) \<infinity> = {a <..}"
    and einterval_eq_Iic: "einterval (- \<infinity>) (ereal b) = {..< b}"
    and einterval_eq_UNIV: "einterval (- \<infinity>) \<infinity> = UNIV"
  by (auto simp: einterval_def)

lemma einterval_same: "einterval a a = {}"
  by (auto simp: einterval_def)

lemma einterval_iff: "x \<in> einterval a b \<longleftrightarrow> a < ereal x \<and> ereal x < b"
  by (simp add: einterval_def)

lemma einterval_nonempty: "a < b \<Longrightarrow> \<exists>c. c \<in> einterval a b"
  by (cases a b rule: ereal2_cases, auto simp: einterval_def intro!: dense gt_ex lt_ex)

lemma open_einterval[simp]: "open (einterval a b)"
  by (cases a b rule: ereal2_cases)
     (auto simp: einterval_def intro!: open_Collect_conj open_Collect_less continuous_intros)

lemma borel_einterval[measurable]: "einterval a b \<in> sets borel"
  unfolding einterval_def by measurable

subsection \<open>Approximating a (possibly infinite) interval\<close>

lemma filterlim_sup1: "(LIM x F. f x :> G1) \<Longrightarrow> (LIM x F. f x :> (sup G1 G2))"
 unfolding filterlim_def by (auto intro: le_supI1)

lemma ereal_incseq_approx:
  fixes a b :: ereal
  assumes "a < b"
  obtains X :: "nat \<Rightarrow> real" where "incseq X" "\<And>i. a < X i" "\<And>i. X i < b" "X \<longlonglongrightarrow> b"
proof (cases b)
  case PInf
  with \<open>a < b\<close> have "a = -\<infinity> \<or> (\<exists>r. a = ereal r)"
    by (cases a) auto
  moreover have "(\<lambda>x. ereal (real (Suc x))) \<longlonglongrightarrow> \<infinity>"
    by (simp add: Lim_PInfty filterlim_sequentially_Suc) (metis le_SucI of_nat_Suc of_nat_mono order_trans real_arch_simple)
  moreover have "\<And>r. (\<lambda>x. ereal (r + real (Suc x))) \<longlonglongrightarrow> \<infinity>"
    by (simp add: filterlim_sequentially_Suc Lim_PInfty) (metis add.commute diff_le_eq nat_ceiling_le_eq)
  ultimately show thesis
    by (intro that[of "\<lambda>i. real_of_ereal a + Suc i"])
       (auto simp: incseq_def PInf)
next
  case (real b')
  define d where "d = b' - (if a = -\<infinity> then b' - 1 else real_of_ereal a)"
  with \<open>a < b\<close> have a': "0 < d"
    by (cases a) (auto simp: real)
  moreover
  have "\<And>i r. r < b' \<Longrightarrow> (b' - r) * 1 < (b' - r) * real (Suc (Suc i))"
    by (intro mult_strict_left_mono) auto
  with \<open>a < b\<close> a' have "\<And>i. a < ereal (b' - d / real (Suc (Suc i)))"
    by (cases a) (auto simp: real d_def field_simps)
  moreover
  have "(\<lambda>i. b' - d / real i) \<longlonglongrightarrow> b'"
    by (force intro: tendsto_eq_intros tendsto_divide_0[OF tendsto_const] filterlim_sup1
              simp: at_infinity_eq_at_top_bot filterlim_real_sequentially)
  then have "(\<lambda>i. b' - d / Suc (Suc i)) \<longlonglongrightarrow> b'"
    by (blast intro: dest: filterlim_sequentially_Suc [THEN iffD2])
  ultimately show thesis
    by (intro that[of "\<lambda>i. b' - d / Suc (Suc i)"])
       (auto simp: real incseq_def intro!: divide_left_mono)
qed (use \<open>a < b\<close> in auto)

lemma ereal_decseq_approx:
  fixes a b :: ereal
  assumes "a < b"
  obtains X :: "nat \<Rightarrow> real" where
    "decseq X" "\<And>i. a < X i" "\<And>i. X i < b" "X \<longlonglongrightarrow> a"
proof -
  have "-b < -a" using \<open>a < b\<close> by simp
  from ereal_incseq_approx[OF this] obtain X where
    "incseq X"
    "\<And>i. - b < ereal (X i)"
    "\<And>i. ereal (X i) < - a"
    "(\<lambda>x. ereal (X x)) \<longlonglongrightarrow> - a"
    by auto
  then show thesis
    apply (intro that[of "\<lambda>i. - X i"])
    apply (auto simp: decseq_def incseq_def simp flip: uminus_ereal.simps)
    apply (metis ereal_minus_less_minus ereal_uminus_uminus ereal_Lim_uminus)+
    done
qed

proposition einterval_Icc_approximation:
  fixes a b :: ereal
  assumes "a < b"
  obtains u l :: "nat \<Rightarrow> real" where
    "einterval a b = (\<Union>i. {l i .. u i})"
    "incseq u" "decseq l" "\<And>i. l i < u i" "\<And>i. a < l i" "\<And>i. u i < b"
    "l \<longlonglongrightarrow> a" "u \<longlonglongrightarrow> b"
proof -
  from dense[OF \<open>a < b\<close>] obtain c where "a < c" "c < b" by safe
  from ereal_incseq_approx[OF \<open>c < b\<close>] obtain u where u:
    "incseq u"
    "\<And>i. c < ereal (u i)"
    "\<And>i. ereal (u i) < b"
    "(\<lambda>x. ereal (u x)) \<longlonglongrightarrow> b"
    by auto
  from ereal_decseq_approx[OF \<open>a < c\<close>] obtain l where l:
    "decseq l"
    "\<And>i. a < ereal (l i)"
    "\<And>i. ereal (l i) < c"
    "(\<lambda>x. ereal (l x)) \<longlonglongrightarrow> a"
    by auto
  { fix i from less_trans[OF \<open>l i < c\<close> \<open>c < u i\<close>] have "l i < u i" by simp }
  have "einterval a b = (\<Union>i. {l i .. u i})"
  proof (auto simp: einterval_iff)
    fix x assume "a < ereal x" "ereal x < b"
    have "eventually (\<lambda>i. ereal (l i) < ereal x) sequentially"
      using l(4) \<open>a < ereal x\<close> by (rule order_tendstoD)
    moreover
    have "eventually (\<lambda>i. ereal x < ereal (u i)) sequentially"
      using u(4) \<open>ereal x< b\<close> by (rule order_tendstoD)
    ultimately have "eventually (\<lambda>i. l i < x \<and> x < u i) sequentially"
      by eventually_elim auto
    then show "\<exists>i. l i \<le> x \<and> x \<le> u i"
      by (auto intro: less_imp_le simp: eventually_sequentially)
  next
    fix x i assume "l i \<le> x" "x \<le> u i"
    with \<open>a < ereal (l i)\<close> \<open>ereal (u i) < b\<close>
    show "a < ereal x" "ereal x < b"
      by (auto simp flip: ereal_less_eq(3))
  qed
  show thesis
    by (intro that) fact+
qed

(* TODO: in this definition, it would be more natural if einterval a b included a and b when
   they are real. *)
definition\<^marker>\<open>tag important\<close> interval_lebesgue_integral :: "real measure \<Rightarrow> ereal \<Rightarrow> ereal \<Rightarrow> (real \<Rightarrow> 'a) \<Rightarrow> 'a::{banach, second_countable_topology}" where
  "interval_lebesgue_integral M a b f =
    (if a \<le> b then (LINT x:einterval a b|M. f x) else - (LINT x:einterval b a|M. f x))"

syntax
  "_ascii_interval_lebesgue_integral" :: "pttrn \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real measure \<Rightarrow> real \<Rightarrow> real"
  ("(5LINT _=_.._|_. _)" [0,60,60,61,100] 60)

translations
  "LINT x=a..b|M. f" == "CONST interval_lebesgue_integral M a b (\<lambda>x. f)"

definition\<^marker>\<open>tag important\<close> interval_lebesgue_integrable :: "real measure \<Rightarrow> ereal \<Rightarrow> ereal \<Rightarrow> (real \<Rightarrow> 'a::{banach, second_countable_topology}) \<Rightarrow> bool" where
  "interval_lebesgue_integrable M a b f =
    (if a \<le> b then set_integrable M (einterval a b) f else set_integrable M (einterval b a) f)"

syntax
  "_ascii_interval_lebesgue_borel_integral" :: "pttrn \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real"
  ("(4LBINT _=_.._. _)" [0,60,60,61] 60)

translations
  "LBINT x=a..b. f" == "CONST interval_lebesgue_integral CONST lborel a b (\<lambda>x. f)"

subsection\<open>Basic properties of integration over an interval\<close>

lemma interval_lebesgue_integral_cong:
  "a \<le> b \<Longrightarrow> (\<And>x. x \<in> einterval a b \<Longrightarrow> f x = g x) \<Longrightarrow> einterval a b \<in> sets M \<Longrightarrow>
    interval_lebesgue_integral M a b f = interval_lebesgue_integral M a b g"
  by (auto intro: set_lebesgue_integral_cong simp: interval_lebesgue_integral_def)

lemma interval_lebesgue_integral_cong_AE:
  "f \<in> borel_measurable M \<Longrightarrow> g \<in> borel_measurable M \<Longrightarrow>
    a \<le> b \<Longrightarrow> AE x \<in> einterval a b in M. f x = g x \<Longrightarrow> einterval a b \<in> sets M \<Longrightarrow>
    interval_lebesgue_integral M a b f = interval_lebesgue_integral M a b g"
  by (auto intro: set_lebesgue_integral_cong_AE simp: interval_lebesgue_integral_def)

lemma interval_integrable_mirror:
  shows "interval_lebesgue_integrable lborel a b (\<lambda>x. f (-x)) \<longleftrightarrow>
    interval_lebesgue_integrable lborel (-b) (-a) f"
proof -
  have *: "indicator (einterval a b) (- x) = (indicator (einterval (-b) (-a)) x :: real)"
    for a b :: ereal and x :: real
    by (cases a b rule: ereal2_cases) (auto simp: einterval_def split: split_indicator)
  show ?thesis
    unfolding interval_lebesgue_integrable_def
    using lborel_integrable_real_affine_iff[symmetric, of "-1" "\<lambda>x. indicator (einterval _ _) x *\<^sub>R f x" 0]
    by (simp add: * set_integrable_def)
qed

lemma interval_lebesgue_integral_add [intro, simp]:
  fixes M a b f
  assumes "interval_lebesgue_integrable M a b f" "interval_lebesgue_integrable M a b g"
  shows "interval_lebesgue_integrable M a b (\<lambda>x. f x + g x)" and
    "interval_lebesgue_integral M a b (\<lambda>x. f x + g x) =
   interval_lebesgue_integral M a b f + interval_lebesgue_integral M a b g"
using assms by (auto simp: interval_lebesgue_integral_def interval_lebesgue_integrable_def
    field_simps)

lemma interval_lebesgue_integral_diff [intro, simp]:
  fixes M a b f
  assumes "interval_lebesgue_integrable M a b f"
    "interval_lebesgue_integrable M a b g"
  shows "interval_lebesgue_integrable M a b (\<lambda>x. f x - g x)" and
    "interval_lebesgue_integral M a b (\<lambda>x. f x - g x) =
   interval_lebesgue_integral M a b f - interval_lebesgue_integral M a b g"
using assms by (auto simp: interval_lebesgue_integral_def interval_lebesgue_integrable_def
    field_simps)

lemma interval_lebesgue_integrable_mult_right [intro, simp]:
  fixes M a b c and f :: "real \<Rightarrow> 'a::{banach, real_normed_field, second_countable_topology}"
  shows "(c \<noteq> 0 \<Longrightarrow> interval_lebesgue_integrable M a b f) \<Longrightarrow>
    interval_lebesgue_integrable M a b (\<lambda>x. c * f x)"
  by (simp add: interval_lebesgue_integrable_def)

lemma interval_lebesgue_integrable_mult_left [intro, simp]:
  fixes M a b c and f :: "real \<Rightarrow> 'a::{banach, real_normed_field, second_countable_topology}"
  shows "(c \<noteq> 0 \<Longrightarrow> interval_lebesgue_integrable M a b f) \<Longrightarrow>
    interval_lebesgue_integrable M a b (\<lambda>x. f x * c)"
  by (simp add: interval_lebesgue_integrable_def)

lemma interval_lebesgue_integrable_divide [intro, simp]:
  fixes M a b c and f :: "real \<Rightarrow> 'a::{banach, real_normed_field, field, second_countable_topology}"
  shows "(c \<noteq> 0 \<Longrightarrow> interval_lebesgue_integrable M a b f) \<Longrightarrow>
    interval_lebesgue_integrable M a b (\<lambda>x. f x / c)"
  by (simp add: interval_lebesgue_integrable_def)

lemma interval_lebesgue_integral_mult_right [simp]:
  fixes M a b c and f :: "real \<Rightarrow> 'a::{banach, real_normed_field, second_countable_topology}"
  shows "interval_lebesgue_integral M a b (\<lambda>x. c * f x) =
    c * interval_lebesgue_integral M a b f"
  by (simp add: interval_lebesgue_integral_def)

lemma interval_lebesgue_integral_mult_left [simp]:
  fixes M a b c and f :: "real \<Rightarrow> 'a::{banach, real_normed_field, second_countable_topology}"
  shows "interval_lebesgue_integral M a b (\<lambda>x. f x * c) =
    interval_lebesgue_integral M a b f * c"
  by (simp add: interval_lebesgue_integral_def)

lemma interval_lebesgue_integral_divide [simp]:
  fixes M a b c and f :: "real \<Rightarrow> 'a::{banach, real_normed_field, field, second_countable_topology}"
  shows "interval_lebesgue_integral M a b (\<lambda>x. f x / c) =
    interval_lebesgue_integral M a b f / c"
  by (simp add: interval_lebesgue_integral_def)

lemma interval_lebesgue_integral_uminus:
  "interval_lebesgue_integral M a b (\<lambda>x. - f x) = - interval_lebesgue_integral M a b f"
  by (auto simp: interval_lebesgue_integral_def interval_lebesgue_integrable_def set_lebesgue_integral_def)

lemma interval_lebesgue_integral_of_real:
  "interval_lebesgue_integral M a b (\<lambda>x. complex_of_real (f x)) =
    of_real (interval_lebesgue_integral M a b f)"
  unfolding interval_lebesgue_integral_def
  by (auto simp: interval_lebesgue_integral_def set_integral_complex_of_real)

lemma interval_lebesgue_integral_le_eq:
  fixes a b f
  assumes "a \<le> b"
  shows "interval_lebesgue_integral M a b f = (LINT x : einterval a b | M. f x)"
  using assms by (auto simp: interval_lebesgue_integral_def)

lemma interval_lebesgue_integral_gt_eq:
  fixes a b f
  assumes "a > b"
  shows "interval_lebesgue_integral M a b f = -(LINT x : einterval b a | M. f x)"
using assms by (auto simp: interval_lebesgue_integral_def less_imp_le einterval_def)

lemma interval_lebesgue_integral_gt_eq':
  fixes a b f
  assumes "a > b"
  shows "interval_lebesgue_integral M a b f = - interval_lebesgue_integral M b a f"
using assms by (auto simp: interval_lebesgue_integral_def less_imp_le einterval_def)

lemma interval_integral_endpoints_same [simp]: "(LBINT x=a..a. f x) = 0"
  by (simp add: interval_lebesgue_integral_def set_lebesgue_integral_def einterval_same)

lemma interval_integral_endpoints_reverse: "(LBINT x=a..b. f x) = -(LBINT x=b..a. f x)"
  by (cases a b rule: linorder_cases) (auto simp: interval_lebesgue_integral_def set_lebesgue_integral_def einterval_same)

lemma interval_integrable_endpoints_reverse:
  "interval_lebesgue_integrable lborel a b f \<longleftrightarrow>
    interval_lebesgue_integrable lborel b a f"
  by (cases a b rule: linorder_cases) (auto simp: interval_lebesgue_integrable_def einterval_same)

lemma interval_integral_reflect:
  "(LBINT x=a..b. f x) = (LBINT x=-b..-a. f (-x))"
proof (induct a b rule: linorder_wlog)
  case (sym a b) then show ?case
    by (auto simp: interval_lebesgue_integral_def interval_integrable_endpoints_reverse
             split: if_split_asm)
next
  case (le a b)
  have "LBINT x:{x. - x \<in> einterval a b}. f (- x) = LBINT x:einterval (- b) (- a). f (- x)"
    unfolding interval_lebesgue_integrable_def set_lebesgue_integral_def
    apply (rule Bochner_Integration.integral_cong [OF refl])
    by (auto simp: einterval_iff ereal_uminus_le_reorder ereal_uminus_less_reorder not_less
             simp flip: uminus_ereal.simps
             split: split_indicator)
  then show ?case
    unfolding interval_lebesgue_integral_def
    by (subst set_integral_reflect) (simp add: le)
qed

lemma interval_lebesgue_integral_0_infty:
  "interval_lebesgue_integrable M 0 \<infinity> f \<longleftrightarrow> set_integrable M {0<..} f"
  "interval_lebesgue_integral M 0 \<infinity> f = (LINT x:{0<..}|M. f x)"
  unfolding zero_ereal_def
  by (auto simp: interval_lebesgue_integral_le_eq interval_lebesgue_integrable_def)

lemma interval_integral_to_infinity_eq: "(LINT x=ereal a..\<infinity> | M. f x) = (LINT x : {a<..} | M. f x)"
  unfolding interval_lebesgue_integral_def by auto

proposition interval_integrable_to_infinity_eq: "(interval_lebesgue_integrable M a \<infinity> f) =
  (set_integrable M {a<..} f)"
  unfolding interval_lebesgue_integrable_def by auto

subsection\<open>Basic properties of integration over an interval wrt lebesgue measure\<close>

lemma interval_integral_zero [simp]:
  fixes a b :: ereal
  shows "LBINT x=a..b. 0 = 0"
unfolding interval_lebesgue_integral_def set_lebesgue_integral_def einterval_eq
by simp

lemma interval_integral_const [intro, simp]:
  fixes a b c :: real
  shows "interval_lebesgue_integrable lborel a b (\<lambda>x. c)" and "LBINT x=a..b. c = c * (b - a)"
  unfolding interval_lebesgue_integral_def interval_lebesgue_integrable_def einterval_eq
  by (auto simp: less_imp_le field_simps measure_def set_integrable_def set_lebesgue_integral_def)

lemma interval_integral_cong_AE:
  assumes [measurable]: "f \<in> borel_measurable borel" "g \<in> borel_measurable borel"
  assumes "AE x \<in> einterval (min a b) (max a b) in lborel. f x = g x"
  shows "interval_lebesgue_integral lborel a b f = interval_lebesgue_integral lborel a b g"
  using assms
proof (induct a b rule: linorder_wlog)
  case (sym a b) then show ?case
    by (simp add: min.commute max.commute interval_integral_endpoints_reverse[of a b])
next
  case (le a b) then show ?case
    by (auto simp: interval_lebesgue_integral_def max_def min_def
             intro!: set_lebesgue_integral_cong_AE)
qed

lemma interval_integral_cong:
  assumes "\<And>x. x \<in> einterval (min a b) (max a b) \<Longrightarrow> f x = g x"
  shows "interval_lebesgue_integral lborel a b f = interval_lebesgue_integral lborel a b g"
  using assms
proof (induct a b rule: linorder_wlog)
  case (sym a b) then show ?case
    by (simp add: min.commute max.commute interval_integral_endpoints_reverse[of a b])
next
  case (le a b) then show ?case
    by (auto simp: interval_lebesgue_integral_def max_def min_def
             intro!: set_lebesgue_integral_cong)
qed

lemma interval_lebesgue_integrable_cong_AE:
    "f \<in> borel_measurable lborel \<Longrightarrow> g \<in> borel_measurable lborel \<Longrightarrow>
    AE x \<in> einterval (min a b) (max a b) in lborel. f x = g x \<Longrightarrow>
    interval_lebesgue_integrable lborel a b f = interval_lebesgue_integrable lborel a b g"
  apply (simp add: interval_lebesgue_integrable_def)
  apply (intro conjI impI set_integrable_cong_AE)
  apply (auto simp: min_def max_def)
  done

lemma interval_integrable_abs_iff:
  fixes f :: "real \<Rightarrow> real"
  shows  "f \<in> borel_measurable lborel \<Longrightarrow>
    interval_lebesgue_integrable lborel a b (\<lambda>x. \<bar>f x\<bar>) = interval_lebesgue_integrable lborel a b f"
  unfolding interval_lebesgue_integrable_def
  by (subst (1 2) set_integrable_abs_iff') simp_all

lemma interval_integral_Icc:
  fixes a b :: real
  shows "a \<le> b \<Longrightarrow> (LBINT x=a..b. f x) = (LBINT x : {a..b}. f x)"
  by (auto intro!: set_integral_discrete_difference[where X="{a, b}"]
           simp add: interval_lebesgue_integral_def)

lemma interval_integral_Icc':
  "a \<le> b \<Longrightarrow> (LBINT x=a..b. f x) = (LBINT x : {x. a \<le> ereal x \<and> ereal x \<le> b}. f x)"
  by (auto intro!: set_integral_discrete_difference[where X="{real_of_ereal a, real_of_ereal b}"]
           simp add: interval_lebesgue_integral_def einterval_iff)

lemma interval_integral_Ioc:
  "a \<le> b \<Longrightarrow> (LBINT x=a..b. f x) = (LBINT x : {a<..b}. f x)"
  by (auto intro!: set_integral_discrete_difference[where X="{a, b}"]
           simp add: interval_lebesgue_integral_def einterval_iff)

(* TODO: other versions as well? *) (* Yes: I need the Icc' version. *)
lemma interval_integral_Ioc':
  "a \<le> b \<Longrightarrow> (LBINT x=a..b. f x) = (LBINT x : {x. a < ereal x \<and> ereal x \<le> b}. f x)"
  by (auto intro!: set_integral_discrete_difference[where X="{real_of_ereal a, real_of_ereal b}"]
           simp add: interval_lebesgue_integral_def einterval_iff)

lemma interval_integral_Ico:
  "a \<le> b \<Longrightarrow> (LBINT x=a..b. f x) = (LBINT x : {a..<b}. f x)"
  by (auto intro!: set_integral_discrete_difference[where X="{a, b}"]
           simp add: interval_lebesgue_integral_def einterval_iff)

lemma interval_integral_Ioi:
  "\<bar>a\<bar> < \<infinity> \<Longrightarrow> (LBINT x=a..\<infinity>. f x) = (LBINT x : {real_of_ereal a <..}. f x)"
  by (auto simp: interval_lebesgue_integral_def einterval_iff)

lemma interval_integral_Ioo:
  "a \<le> b \<Longrightarrow> \<bar>a\<bar> < \<infinity> ==> \<bar>b\<bar> < \<infinity> \<Longrightarrow> (LBINT x=a..b. f x) = (LBINT x : {real_of_ereal a <..< real_of_ereal b}. f x)"
  by (auto simp: interval_lebesgue_integral_def einterval_iff)

lemma interval_integral_discrete_difference:
  fixes f :: "real \<Rightarrow> 'b::{banach, second_countable_topology}" and a b :: ereal
  assumes "countable X"
  and eq: "\<And>x. a \<le> b \<Longrightarrow> a < x \<Longrightarrow> x < b \<Longrightarrow> x \<notin> X \<Longrightarrow> f x = g x"
  and anti_eq: "\<And>x. b \<le> a \<Longrightarrow> b < x \<Longrightarrow> x < a \<Longrightarrow> x \<notin> X \<Longrightarrow> f x = g x"
  assumes "\<And>x. x \<in> X \<Longrightarrow> emeasure M {x} = 0" "\<And>x. x \<in> X \<Longrightarrow> {x} \<in> sets M"
  shows "interval_lebesgue_integral M a b f = interval_lebesgue_integral M a b g"
  unfolding interval_lebesgue_integral_def set_lebesgue_integral_def
  apply (intro if_cong refl arg_cong[where f="\<lambda>x. - x"] integral_discrete_difference[of X] assms)
  apply (auto simp: eq anti_eq einterval_iff split: split_indicator)
  done

lemma interval_integral_sum:
  fixes a b c :: ereal
  assumes integrable: "interval_lebesgue_integrable lborel (min a (min b c)) (max a (max b c)) f"
  shows "(LBINT x=a..b. f x) + (LBINT x=b..c. f x) = (LBINT x=a..c. f x)"
proof -
  let ?I = "\<lambda>a b. LBINT x=a..b. f x"
  { fix a b c :: ereal assume "interval_lebesgue_integrable lborel a c f" "a \<le> b" "b \<le> c"
    then have ord: "a \<le> b" "b \<le> c" "a \<le> c" and f': "set_integrable lborel (einterval a c) f"
      by (auto simp: interval_lebesgue_integrable_def)
    then have f: "set_borel_measurable borel (einterval a c) f"
      unfolding set_integrable_def set_borel_measurable_def
      by (drule_tac borel_measurable_integrable) simp
    have "(LBINT x:einterval a c. f x) = (LBINT x:einterval a b \<union> einterval b c. f x)"
    proof (rule set_integral_cong_set)
      show "AE x in lborel. (x \<in> einterval a b \<union> einterval b c) = (x \<in> einterval a c)"
        using AE_lborel_singleton[of "real_of_ereal b"] ord
        by (cases a b c rule: ereal3_cases) (auto simp: einterval_iff)
      show "set_borel_measurable lborel (einterval a c) f" "set_borel_measurable lborel (einterval a b \<union> einterval b c) f"
        unfolding set_borel_measurable_def
        using ord by (auto simp: einterval_iff intro!: set_borel_measurable_subset[OF f, unfolded set_borel_measurable_def])
    qed
    also have "\<dots> = (LBINT x:einterval a b. f x) + (LBINT x:einterval b c. f x)"
      using ord
      by (intro set_integral_Un_AE) (auto intro!: set_integrable_subset[OF f'] simp: einterval_iff not_less)
    finally have "?I a b + ?I b c = ?I a c"
      using ord by (simp add: interval_lebesgue_integral_def)
  } note 1 = this
  { fix a b c :: ereal assume "interval_lebesgue_integrable lborel a c f" "a \<le> b" "b \<le> c"
    from 1[OF this] have "?I b c + ?I a b = ?I a c"
      by (metis add.commute)
  } note 2 = this
  have 3: "\<And>a b. b \<le> a \<Longrightarrow> (LBINT x=a..b. f x) = - (LBINT x=b..a. f x)"
    by (rule interval_integral_endpoints_reverse)
  show ?thesis
    using integrable
    apply (cases a b b c a c rule: linorder_le_cases[case_product linorder_le_cases linorder_cases])
    apply simp_all (* remove some looping cases *)
    by (simp_all add: min_absorb1 min_absorb2 max_absorb1 max_absorb2 field_simps 1 2 3)
qed

lemma interval_integrable_isCont:
  fixes a b and f :: "real \<Rightarrow> 'a::{banach, second_countable_topology}"
  shows "(\<And>x. min a b \<le> x \<Longrightarrow> x \<le> max a b \<Longrightarrow> isCont f x) \<Longrightarrow>
    interval_lebesgue_integrable lborel a b f"
proof (induct a b rule: linorder_wlog)
  case (le a b) then show ?case
    unfolding interval_lebesgue_integrable_def set_integrable_def
    by (auto simp: interval_lebesgue_integrable_def
        intro!: set_integrable_subset[unfolded set_integrable_def, OF borel_integrable_compact[of "{a .. b}"]]
        continuous_at_imp_continuous_on)
qed (auto intro: interval_integrable_endpoints_reverse[THEN iffD1])

lemma interval_integrable_continuous_on:
  fixes a b :: real and f
  assumes "a \<le> b" and "continuous_on {a..b} f"
  shows "interval_lebesgue_integrable lborel a b f"
using assms unfolding interval_lebesgue_integrable_def apply simp
  by (rule set_integrable_subset, rule borel_integrable_atLeastAtMost' [of a b], auto)

lemma interval_integral_eq_integral:
  fixes f :: "real \<Rightarrow> 'a::euclidean_space"
  shows "a \<le> b \<Longrightarrow> set_integrable lborel {a..b} f \<Longrightarrow> LBINT x=a..b. f x = integral {a..b} f"
  by (subst interval_integral_Icc, simp) (rule set_borel_integral_eq_integral)

lemma interval_integral_eq_integral':
  fixes f :: "real \<Rightarrow> 'a::euclidean_space"
  shows "a \<le> b \<Longrightarrow> set_integrable lborel (einterval a b) f \<Longrightarrow> LBINT x=a..b. f x = integral (einterval a b) f"
  by (subst interval_lebesgue_integral_le_eq, simp) (rule set_borel_integral_eq_integral)

subsection\<open>General limit approximation arguments\<close>

proposition interval_integral_Icc_approx_nonneg:
  fixes a b :: ereal
  assumes "a < b"
  fixes u l :: "nat \<Rightarrow> real"
  assumes  approx: "einterval a b = (\<Union>i. {l i .. u i})"
    "incseq u" "decseq l" "\<And>i. l i < u i" "\<And>i. a < l i" "\<And>i. u i < b"
    "l \<longlonglongrightarrow> a" "u \<longlonglongrightarrow> b"
  fixes f :: "real \<Rightarrow> real"
  assumes f_integrable: "\<And>i. set_integrable lborel {l i..u i} f"
  assumes f_nonneg: "AE x in lborel. a < ereal x \<longrightarrow> ereal x < b \<longrightarrow> 0 \<le> f x"
  assumes f_measurable: "set_borel_measurable lborel (einterval a b) f"
  assumes lbint_lim: "(\<lambda>i. LBINT x=l i.. u i. f x) \<longlonglongrightarrow> C"
  shows
    "set_integrable lborel (einterval a b) f"
    "(LBINT x=a..b. f x) = C"
proof -
  have 1 [unfolded set_integrable_def]: "\<And>i. set_integrable lborel {l i..u i} f" by (rule f_integrable)
  have 2: "AE x in lborel. mono (\<lambda>n. indicator {l n..u n} x *\<^sub>R f x)"
  proof -
     from f_nonneg have "AE x in lborel. \<forall>i. l i \<le> x \<longrightarrow> x \<le> u i \<longrightarrow> 0 \<le> f x"
      by eventually_elim
         (metis approx(5) approx(6) dual_order.strict_trans1 ereal_less_eq(3) le_less_trans)
    then show ?thesis
      apply eventually_elim
      apply (auto simp: mono_def split: split_indicator)
      apply (metis approx(3) decseqD order_trans)
      apply (metis approx(2) incseqD order_trans)
      done
  qed
  have 3: "AE x in lborel. (\<lambda>i. indicator {l i..u i} x *\<^sub>R f x) \<longlonglongrightarrow> indicator (einterval a b) x *\<^sub>R f x"
  proof -
    { fix x i assume "l i \<le> x" "x \<le> u i"
      then have "eventually (\<lambda>i. l i \<le> x \<and> x \<le> u i) sequentially"
        apply (auto simp: eventually_sequentially intro!: exI[of _ i])
        apply (metis approx(3) decseqD order_trans)
        apply (metis approx(2) incseqD order_trans)
        done
      then have "eventually (\<lambda>i. f x * indicator {l i..u i} x = f x) sequentially"
        by eventually_elim auto }
    then show ?thesis
      unfolding approx(1) by (auto intro!: AE_I2 tendsto_eventually split: split_indicator)
  qed
  have 4: "(\<lambda>i. \<integral> x. indicator {l i..u i} x *\<^sub>R f x \<partial>lborel) \<longlonglongrightarrow> C"
    using lbint_lim by (simp add: interval_integral_Icc [unfolded set_lebesgue_integral_def] approx less_imp_le)
  have 5: "(\<lambda>x. indicat_real (einterval a b) x *\<^sub>R f x) \<in> borel_measurable lborel"
    using f_measurable set_borel_measurable_def by blast
  have "(LBINT x=a..b. f x) = lebesgue_integral lborel (\<lambda>x. indicator (einterval a b) x *\<^sub>R f x)"
    using assms by (simp add: interval_lebesgue_integral_def set_lebesgue_integral_def less_imp_le)
  also have "\<dots> = C"
    by (rule integral_monotone_convergence [OF 1 2 3 4 5])
  finally show "(LBINT x=a..b. f x) = C" .
  show "set_integrable lborel (einterval a b) f"
    unfolding set_integrable_def
    by (rule integrable_monotone_convergence[OF 1 2 3 4 5])
qed

proposition interval_integral_Icc_approx_integrable:
  fixes u l :: "nat \<Rightarrow> real" and a b :: ereal
  fixes f :: "real \<Rightarrow> 'a::{banach, second_countable_topology}"
  assumes "a < b"
  assumes  approx: "einterval a b = (\<Union>i. {l i .. u i})"
    "incseq u" "decseq l" "\<And>i. l i < u i" "\<And>i. a < l i" "\<And>i. u i < b"
    "l \<longlonglongrightarrow> a" "u \<longlonglongrightarrow> b"
  assumes f_integrable: "set_integrable lborel (einterval a b) f"
  shows "(\<lambda>i. LBINT x=l i.. u i. f x) \<longlonglongrightarrow> (LBINT x=a..b. f x)"
proof -
  have "(\<lambda>i. LBINT x:{l i.. u i}. f x) \<longlonglongrightarrow> (LBINT x:einterval a b. f x)"
    unfolding set_lebesgue_integral_def
  proof (rule integral_dominated_convergence)
    show "integrable lborel (\<lambda>x. norm (indicator (einterval a b) x *\<^sub>R f x))"
      using f_integrable integrable_norm set_integrable_def by blast
    show "(\<lambda>x. indicat_real (einterval a b) x *\<^sub>R f x) \<in> borel_measurable lborel"
      using f_integrable by (simp add: set_integrable_def)
    then show "\<And>i. (\<lambda>x. indicat_real {l i..u i} x *\<^sub>R f x) \<in> borel_measurable lborel"
      by (rule set_borel_measurable_subset [unfolded set_borel_measurable_def]) (auto simp: approx)
    show "\<And>i. AE x in lborel. norm (indicator {l i..u i} x *\<^sub>R f x) \<le> norm (indicator (einterval a b) x *\<^sub>R f x)"
      by (intro AE_I2) (auto simp: approx split: split_indicator)
    show "AE x in lborel. (\<lambda>i. indicator {l i..u i} x *\<^sub>R f x) \<longlonglongrightarrow> indicator (einterval a b) x *\<^sub>R f x"
    proof (intro AE_I2 tendsto_intros tendsto_eventually)
      fix x
      { fix i assume "l i \<le> x" "x \<le> u i"
        with \<open>incseq u\<close>[THEN incseqD, of i] \<open>decseq l\<close>[THEN decseqD, of i]
        have "eventually (\<lambda>i. l i \<le> x \<and> x \<le> u i) sequentially"
          by (auto simp: eventually_sequentially decseq_def incseq_def intro: order_trans) }
      then show "eventually (\<lambda>xa. indicator {l xa..u xa} x = (indicator (einterval a b) x::real)) sequentially"
        using approx order_tendstoD(2)[OF \<open>l \<longlonglongrightarrow> a\<close>, of x] order_tendstoD(1)[OF \<open>u \<longlonglongrightarrow> b\<close>, of x]
        by (auto split: split_indicator)
    qed
  qed
  with \<open>a < b\<close> \<open>\<And>i. l i < u i\<close> show ?thesis
    by (simp add: interval_lebesgue_integral_le_eq[symmetric] interval_integral_Icc less_imp_le)
qed

subsection\<open>A slightly stronger Fundamental Theorem of Calculus\<close>

text\<open>Three versions: first, for finite intervals, and then two versions for
    arbitrary intervals.\<close>

(*
  TODO: make the older versions corollaries of these (using continuous_at_imp_continuous_on, etc.)
*)

lemma interval_integral_FTC_finite:
  fixes f F :: "real \<Rightarrow> 'a::euclidean_space" and a b :: real
  assumes f: "continuous_on {min a b..max a b} f"
  assumes F: "\<And>x. min a b \<le> x \<Longrightarrow> x \<le> max a b \<Longrightarrow> (F has_vector_derivative (f x)) (at x within
    {min a b..max a b})"
  shows "(LBINT x=a..b. f x) = F b - F a"
proof (cases "a \<le> b")
  case True
  have "(LBINT x=a..b. f x) = (LBINT x. indicat_real {a..b} x *\<^sub>R f x)"
    by (simp add: True interval_integral_Icc set_lebesgue_integral_def)
  also have "\<dots> = F b - F a"
  proof (rule integral_FTC_atLeastAtMost [OF True])
    show "continuous_on {a..b} f"
      using True f by linarith
    show "\<And>x. \<lbrakk>a \<le> x; x \<le> b\<rbrakk> \<Longrightarrow> (F has_vector_derivative f x) (at x within {a..b})"
      by (metis F True max.commute max_absorb1 min_def)
  qed
  finally show ?thesis .
next
  case False
  then have "b \<le> a"
    by simp
  have "- interval_lebesgue_integral lborel (ereal b) (ereal a) f = - (LBINT x. indicat_real {b..a} x *\<^sub>R f x)"
    by (simp add: \<open>b \<le> a\<close> interval_integral_Icc set_lebesgue_integral_def)
  also have "\<dots> = F b - F a"
  proof (subst integral_FTC_atLeastAtMost [OF \<open>b \<le> a\<close>])
    show "continuous_on {b..a} f"
      using False f by linarith
    show "\<And>x. \<lbrakk>b \<le> x; x \<le> a\<rbrakk>
         \<Longrightarrow> (F has_vector_derivative f x) (at x within {b..a})"
      by (metis F False max_def min_def)
  qed auto
  finally show ?thesis
    by (metis interval_integral_endpoints_reverse)
qed

lemma interval_integral_FTC_nonneg:
  fixes f F :: "real \<Rightarrow> real" and a b :: ereal
  assumes "a < b"
  assumes F: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> DERIV F x :> f x"
  assumes f: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> isCont f x"
  assumes f_nonneg: "AE x in lborel. a < ereal x \<longrightarrow> ereal x < b \<longrightarrow> 0 \<le> f x"
  assumes A: "((F \<circ> real_of_ereal) \<longlongrightarrow> A) (at_right a)"
  assumes B: "((F \<circ> real_of_ereal) \<longlongrightarrow> B) (at_left b)"
  shows
    "set_integrable lborel (einterval a b) f"
    "(LBINT x=a..b. f x) = B - A"
proof -
  obtain u l where approx:
    "einterval a b = (\<Union>i. {l i .. u i})"
    "incseq u" "decseq l" "\<And>i. l i < u i" "\<And>i. a < l i" "\<And>i. u i < b"
    "l \<longlonglongrightarrow> a" "u \<longlonglongrightarrow> b"
    by (blast intro: einterval_Icc_approximation[OF \<open>a < b\<close>])
  have [simp]: "\<And>x i. l i \<le> x \<Longrightarrow> a < ereal x"
    by (rule order_less_le_trans, rule approx, force)
  have [simp]: "\<And>x i. x \<le> u i \<Longrightarrow> ereal x < b"
    by (rule order_le_less_trans, subst ereal_less_eq(3), assumption, rule approx)
  have FTCi: "\<And>i. (LBINT x=l i..u i. f x) = F (u i) - F (l i)"
    using assms approx apply (intro interval_integral_FTC_finite)
    apply (auto simp: less_imp_le min_def max_def
      has_real_derivative_iff_has_vector_derivative[symmetric])
    apply (rule continuous_at_imp_continuous_on, auto intro!: f)
    by (rule DERIV_subset [OF F], auto)
  have 1: "\<And>i. set_integrable lborel {l i..u i} f"
  proof -
    fix i show "set_integrable lborel {l i .. u i} f"
      using \<open>a < l i\<close> \<open>u i < b\<close> unfolding set_integrable_def
      by (intro borel_integrable_compact f continuous_at_imp_continuous_on compact_Icc ballI)
         (auto simp flip: ereal_less_eq)
  qed
  have 2: "set_borel_measurable lborel (einterval a b) f"
    unfolding set_borel_measurable_def
    by (auto simp del: real_scaleR_def intro!: borel_measurable_continuous_on_indicator
             simp: continuous_on_eq_continuous_at einterval_iff f)
  have 3: "(\<lambda>i. LBINT x=l i..u i. f x) \<longlonglongrightarrow> B - A"
    apply (subst FTCi)
    apply (intro tendsto_intros)
    using B approx unfolding tendsto_at_iff_sequentially comp_def
    using tendsto_at_iff_sequentially[where 'a=real]
    apply (elim allE[of _ "\<lambda>i. ereal (u i)"], auto)
    using A approx unfolding tendsto_at_iff_sequentially comp_def
    by (elim allE[of _ "\<lambda>i. ereal (l i)"], auto)
  show "(LBINT x=a..b. f x) = B - A"
    by (rule interval_integral_Icc_approx_nonneg [OF \<open>a < b\<close> approx 1 f_nonneg 2 3])
  show "set_integrable lborel (einterval a b) f"
    by (rule interval_integral_Icc_approx_nonneg [OF \<open>a < b\<close> approx 1 f_nonneg 2 3])
qed

theorem interval_integral_FTC_integrable:
  fixes f F :: "real \<Rightarrow> 'a::euclidean_space" and a b :: ereal
  assumes "a < b"
  assumes F: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> (F has_vector_derivative f x) (at x)"
  assumes f: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> isCont f x"
  assumes f_integrable: "set_integrable lborel (einterval a b) f"
  assumes A: "((F \<circ> real_of_ereal) \<longlongrightarrow> A) (at_right a)"
  assumes B: "((F \<circ> real_of_ereal) \<longlongrightarrow> B) (at_left b)"
  shows "(LBINT x=a..b. f x) = B - A"
proof -
  obtain u l where approx:
    "einterval a b = (\<Union>i. {l i .. u i})"
    "incseq u" "decseq l" "\<And>i. l i < u i" "\<And>i. a < l i" "\<And>i. u i < b"
    "l \<longlonglongrightarrow> a" "u \<longlonglongrightarrow> b"
    by (blast intro: einterval_Icc_approximation[OF \<open>a < b\<close>])
  have [simp]: "\<And>x i. l i \<le> x \<Longrightarrow> a < ereal x"
    by (rule order_less_le_trans, rule approx, force)
  have [simp]: "\<And>x i. x \<le> u i \<Longrightarrow> ereal x < b"
    by (rule order_le_less_trans, subst ereal_less_eq(3), assumption, rule approx)
  have FTCi: "\<And>i. (LBINT x=l i..u i. f x) = F (u i) - F (l i)"
    using assms approx
    by (auto simp: less_imp_le min_def max_def
             intro!: f continuous_at_imp_continuous_on interval_integral_FTC_finite
             intro: has_vector_derivative_at_within)
  have "(\<lambda>i. LBINT x=l i..u i. f x) \<longlonglongrightarrow> B - A"
    unfolding FTCi
  proof (intro tendsto_intros)
    show "(\<lambda>x. F (l x)) \<longlonglongrightarrow> A"
      using A approx unfolding tendsto_at_iff_sequentially comp_def
      by (elim allE[of _ "\<lambda>i. ereal (l i)"], auto)
    show "(\<lambda>x. F (u x)) \<longlonglongrightarrow> B"
      using B approx unfolding tendsto_at_iff_sequentially comp_def
      by (elim allE[of _ "\<lambda>i. ereal (u i)"], auto)
  qed
  moreover have "(\<lambda>i. LBINT x=l i..u i. f x) \<longlonglongrightarrow> (LBINT x=a..b. f x)"
    by (rule interval_integral_Icc_approx_integrable [OF \<open>a < b\<close> approx f_integrable])
  ultimately show ?thesis
    by (elim LIMSEQ_unique)
qed

(*
  The second Fundamental Theorem of Calculus and existence of antiderivatives on an
  einterval.
*)

theorem interval_integral_FTC2:
  fixes a b c :: real and f :: "real \<Rightarrow> 'a::euclidean_space"
  assumes "a \<le> c" "c \<le> b"
  and contf: "continuous_on {a..b} f"
  fixes x :: real
  assumes "a \<le> x" and "x \<le> b"
  shows "((\<lambda>u. LBINT y=c..u. f y) has_vector_derivative (f x)) (at x within {a..b})"
proof -
  let ?F = "(\<lambda>u. LBINT y=a..u. f y)"
  have intf: "set_integrable lborel {a..b} f"
    by (rule borel_integrable_atLeastAtMost', rule contf)
  have "((\<lambda>u. integral {a..u} f) has_vector_derivative f x) (at x within {a..b})"
    using \<open>a \<le> x\<close> \<open>x \<le> b\<close>
    by (auto intro: integral_has_vector_derivative continuous_on_subset [OF contf])
  then have "((\<lambda>u. integral {a..u} f) has_vector_derivative (f x)) (at x within {a..b})"
    by simp
  then have "(?F has_vector_derivative (f x)) (at x within {a..b})"
    by (rule has_vector_derivative_weaken)
       (auto intro!: assms interval_integral_eq_integral[symmetric] set_integrable_subset [OF intf])
  then have "((\<lambda>x. (LBINT y=c..a. f y) + ?F x) has_vector_derivative (f x)) (at x within {a..b})"
    by (auto intro!: derivative_eq_intros)
  then show ?thesis
  proof (rule has_vector_derivative_weaken)
    fix u assume "u \<in> {a .. b}"
    then show "(LBINT y=c..a. f y) + (LBINT y=a..u. f y) = (LBINT y=c..u. f y)"
      using assms
      apply (intro interval_integral_sum)
      apply (auto simp: interval_lebesgue_integrable_def simp del: real_scaleR_def)
      by (rule set_integrable_subset [OF intf], auto simp: min_def max_def)
  qed (insert assms, auto)
qed

proposition einterval_antiderivative:
  fixes a b :: ereal and f :: "real \<Rightarrow> 'a::euclidean_space"
  assumes "a < b" and contf: "\<And>x :: real. a < x \<Longrightarrow> x < b \<Longrightarrow> isCont f x"
  shows "\<exists>F. \<forall>x :: real. a < x \<longrightarrow> x < b \<longrightarrow> (F has_vector_derivative f x) (at x)"
proof -
  from einterval_nonempty [OF \<open>a < b\<close>] obtain c :: real where [simp]: "a < c" "c < b"
    by (auto simp: einterval_def)
  let ?F = "(\<lambda>u. LBINT y=c..u. f y)"
  show ?thesis
  proof (rule exI, clarsimp)
    fix x :: real
    assume [simp]: "a < x" "x < b"
    have 1: "a < min c x" by simp
    from einterval_nonempty [OF 1] obtain d :: real where [simp]: "a < d" "d < c" "d < x"
      by (auto simp: einterval_def)
    have 2: "max c x < b" by simp
    from einterval_nonempty [OF 2] obtain e :: real where [simp]: "c < e" "x < e" "e < b"
      by (auto simp: einterval_def)
    have "(?F has_vector_derivative f x) (at x within {d<..<e})"
    proof (rule has_vector_derivative_within_subset [of _ _ _ "{d..e}"])
      have "continuous_on {d..e} f"
      proof (intro continuous_at_imp_continuous_on ballI contf; clarsimp)
        show "\<And>x. \<lbrakk>d \<le> x; x \<le> e\<rbrakk> \<Longrightarrow> a < ereal x"
          using \<open>a < ereal d\<close> ereal_less_ereal_Ex by auto
        show "\<And>x. \<lbrakk>d \<le> x; x \<le> e\<rbrakk> \<Longrightarrow> ereal x < b"
          using \<open>ereal e < b\<close> ereal_less_eq(3) le_less_trans by blast
      qed
      then show "(?F has_vector_derivative f x) (at x within {d..e})"
        by (intro interval_integral_FTC2) (use \<open>d < c\<close> \<open>c < e\<close> \<open>d < x\<close> \<open>x < e\<close> in \<open>linarith+\<close>)
    qed auto
    then show "(?F has_vector_derivative f x) (at x)"
      by (force simp: has_vector_derivative_within_open [of _ "{d<..<e}"])
  qed
qed

subsection\<open>The substitution theorem\<close>

text\<open>Once again, three versions: first, for finite intervals, and then two versions for
    arbitrary intervals.\<close>

theorem interval_integral_substitution_finite:
  fixes a b :: real and f :: "real \<Rightarrow> 'a::euclidean_space"
  assumes "a \<le> b"
  and derivg: "\<And>x. a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> (g has_real_derivative (g' x)) (at x within {a..b})"
  and contf : "continuous_on (g ` {a..b}) f"
  and contg': "continuous_on {a..b} g'"
  shows "LBINT x=a..b. g' x *\<^sub>R f (g x) = LBINT y=g a..g b. f y"
proof-
  have v_derivg: "\<And>x. a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> (g has_vector_derivative (g' x)) (at x within {a..b})"
    using derivg unfolding has_real_derivative_iff_has_vector_derivative .
  then have contg [simp]: "continuous_on {a..b} g"
    by (rule continuous_on_vector_derivative) auto
  have 1: "\<exists>x\<in>{a..b}. u = g x" if "min (g a) (g b) \<le> u" "u \<le> max (g a) (g b)" for u
    by (cases "g a \<le> g b") (use that assms IVT' [of g a u b]  IVT2' [of g b u a]  in \<open>auto simp: min_def max_def\<close>)
  obtain c d where g_im: "g ` {a..b} = {c..d}" and "c \<le> d"
    by (metis continuous_image_closed_interval contg \<open>a \<le> b\<close>)
  obtain F where derivF:
         "\<And>x. \<lbrakk>a \<le> x; x \<le> b\<rbrakk> \<Longrightarrow> (F has_vector_derivative (f (g x))) (at (g x) within (g ` {a..b}))"
    using continuous_on_subset [OF contf] g_im
      by (metis antiderivative_continuous atLeastAtMost_iff image_subset_iff set_eq_subset)
  have contfg: "continuous_on {a..b} (\<lambda>x. f (g x))"
    by (blast intro: continuous_on_compose2 contf contg)
  have "LBINT x. indicat_real {a..b} x *\<^sub>R g' x *\<^sub>R f (g x) = F (g b) - F (g a)"
    apply (rule integral_FTC_atLeastAtMost
                [OF \<open>a \<le> b\<close> vector_diff_chain_within[OF v_derivg derivF, unfolded comp_def]])
    apply (auto intro!: continuous_on_scaleR contg' contfg)
    done
  then have "LBINT x=a..b. g' x *\<^sub>R f (g x) = F (g b) - F (g a)"
    by (simp add: assms interval_integral_Icc set_lebesgue_integral_def)
  moreover have "LBINT y=(g a)..(g b). f y = F (g b) - F (g a)"
  proof (rule interval_integral_FTC_finite)
    show "continuous_on {min (g a) (g b)..max (g a) (g b)} f"
      by (rule continuous_on_subset [OF contf]) (auto simp: image_def 1)
    show "(F has_vector_derivative f y) (at y within {min (g a) (g b)..max (g a) (g b)})"
      if y: "min (g a) (g b) \<le> y" "y \<le> max (g a) (g b)" for y
    proof -
      obtain x where "a \<le> x" "x \<le> b" "y = g x"
        using 1 y by force
      then show ?thesis
        by (auto simp: image_def intro!: 1  has_vector_derivative_within_subset [OF derivF])
    qed
  qed
  ultimately show ?thesis by simp
qed

(* TODO: is it possible to lift the assumption here that g' is nonnegative? *)

theorem interval_integral_substitution_integrable:
  fixes f :: "real \<Rightarrow> 'a::euclidean_space" and a b u v :: ereal
  assumes "a < b"
  and deriv_g: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> DERIV g x :> g' x"
  and contf: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> isCont f (g x)"
  and contg': "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> isCont g' x"
  and g'_nonneg: "\<And>x. a \<le> ereal x \<Longrightarrow> ereal x \<le> b \<Longrightarrow> 0 \<le> g' x"
  and A: "((ereal \<circ> g \<circ> real_of_ereal) \<longlongrightarrow> A) (at_right a)"
  and B: "((ereal \<circ> g \<circ> real_of_ereal) \<longlongrightarrow> B) (at_left b)"
  and integrable: "set_integrable lborel (einterval a b) (\<lambda>x. g' x *\<^sub>R f (g x))"
  and integrable2: "set_integrable lborel (einterval A B) (\<lambda>x. f x)"
  shows "(LBINT x=A..B. f x) = (LBINT x=a..b. g' x *\<^sub>R f (g x))"
proof -
  obtain u l where approx [simp]:
    "einterval a b = (\<Union>i. {l i .. u i})"
    "incseq u" "decseq l" "\<And>i. l i < u i" "\<And>i. a < l i" "\<And>i. u i < b"
    "l \<longlonglongrightarrow> a" "u \<longlonglongrightarrow> b"
    by (blast intro: einterval_Icc_approximation[OF \<open>a < b\<close>])
  note less_imp_le [simp]
  have [simp]: "\<And>x i. l i \<le> x \<Longrightarrow> a < ereal x"
    by (rule order_less_le_trans, rule approx, force)
  have [simp]: "\<And>x i. x \<le> u i \<Longrightarrow> ereal x < b"
    by (rule order_le_less_trans, subst ereal_less_eq(3), assumption, rule approx)
  then have lessb[simp]: "\<And>i. l i < b"
    using approx(4) less_eq_real_def by blast
  have [simp]: "\<And>i. a < u i"
    by (rule order_less_trans, rule approx, auto, rule approx)
  have lle[simp]: "\<And>i j. i \<le> j \<Longrightarrow> l j \<le> l i" by (rule decseqD, rule approx)
  have [simp]: "\<And>i j. i \<le> j \<Longrightarrow> u i \<le> u j" by (rule incseqD, rule approx)
  have g_nondec [simp]: "g x \<le> g y" if "a < x" "x \<le> y" "y < b" for x y
  proof (rule DERIV_nonneg_imp_nondecreasing [OF \<open>x \<le> y\<close>], intro exI conjI)
    show "\<And>u. x \<le> u \<Longrightarrow> u \<le> y \<Longrightarrow> (g has_real_derivative g' u) (at u)"
      by (meson deriv_g ereal_less_eq(3) le_less_trans less_le_trans that)
    show "\<And>u. x \<le> u \<Longrightarrow> u \<le> y \<Longrightarrow> 0 \<le> g' u"
      by (meson assms(5) dual_order.trans le_ereal_le less_imp_le order_refl that)
  qed
  have "A \<le> B" and un: "einterval A B = (\<Union>i. {g(l i)<..<g(u i)})"
  proof -
    have A2: "(\<lambda>i. g (l i)) \<longlonglongrightarrow> A"
      using A apply (auto simp: einterval_def tendsto_at_iff_sequentially comp_def)
      by (drule_tac x = "\<lambda>i. ereal (l i)" in spec, auto)
    hence A3: "\<And>i. g (l i) \<ge> A"
      by (intro decseq_ge, auto simp: decseq_def)
    have B2: "(\<lambda>i. g (u i)) \<longlonglongrightarrow> B"
      using B apply (auto simp: einterval_def tendsto_at_iff_sequentially comp_def)
      by (drule_tac x = "\<lambda>i. ereal (u i)" in spec, auto)
    hence B3: "\<And>i. g (u i) \<le> B"
      by (intro incseq_le, auto simp: incseq_def)
    have "ereal (g (l 0)) \<le> ereal (g (u 0))"
      by auto
    then show "A \<le> B"
      by (meson A3 B3 order.trans)
    { fix x :: real
      assume "A < x" and "x < B"
      then have "eventually (\<lambda>i. ereal (g (l i)) < x \<and> x < ereal (g (u i))) sequentially"
        by (fast intro: eventually_conj order_tendstoD A2 B2)
      hence "\<exists>i. g (l i) < x \<and> x < g (u i)"
        by (simp add: eventually_sequentially, auto)
    } note AB = this
    show "einterval A B = (\<Union>i. {g(l i)<..<g(u i)})"
    proof
      show "einterval A B \<subseteq> (\<Union>i. {g(l i)<..<g(u i)})"
        by (auto simp: einterval_def AB)
      show "(\<Union>i. {g(l i)<..<g(u i)}) \<subseteq> einterval A B"
      proof (clarsimp simp add: einterval_def, intro conjI)
        show "\<And>x i. \<lbrakk>g (l i) < x; x < g (u i)\<rbrakk> \<Longrightarrow> A < ereal x"
          using A3 le_ereal_less by blast
        show "\<And>x i. \<lbrakk>g (l i) < x; x < g (u i)\<rbrakk> \<Longrightarrow> ereal x < B"
          using B3 ereal_le_less by blast
      qed
    qed
  qed
  (* finally, the main argument *)
  have eq1: "(LBINT x=l i.. u i. g' x *\<^sub>R f (g x)) = (LBINT y=g (l i)..g (u i). f y)" for i
    apply (rule interval_integral_substitution_finite [OF _ DERIV_subset [OF deriv_g]])
    unfolding has_real_derivative_iff_has_vector_derivative[symmetric]
         apply (auto intro!: continuous_at_imp_continuous_on contf contg')
    done
  have "(\<lambda>i. LBINT x=l i..u i. g' x *\<^sub>R f (g x)) \<longlonglongrightarrow> (LBINT x=a..b. g' x *\<^sub>R f (g x))"
    apply (rule interval_integral_Icc_approx_integrable [OF \<open>a < b\<close> approx])
    by (rule assms)
  hence 2: "(\<lambda>i. (LBINT y=g (l i)..g (u i). f y)) \<longlonglongrightarrow> (LBINT x=a..b. g' x *\<^sub>R f (g x))"
    by (simp add: eq1)
  have incseq: "incseq (\<lambda>i. {g (l i)<..<g (u i)})"
    apply (auto simp: incseq_def)
    using lessb lle approx(5) g_nondec le_less_trans apply blast
    by (force intro: less_le_trans)
  have "(\<lambda>i. set_lebesgue_integral lborel {g (l i)<..<g (u i)} f)
        \<longlonglongrightarrow> set_lebesgue_integral lborel (einterval A B) f"
    unfolding un  by (rule set_integral_cont_up) (use incseq  integrable2 un in auto)
  then have "(\<lambda>i. (LBINT y=g (l i)..g (u i). f y)) \<longlonglongrightarrow> (LBINT x = A..B. f x)"
    by (simp add: interval_lebesgue_integral_le_eq \<open>A \<le> B\<close>)
  thus ?thesis by (intro LIMSEQ_unique [OF _ 2])
qed

(* TODO: the last two proofs are only slightly different. Factor out common part?
   An alternative: make the second one the main one, and then have another lemma
   that says that if f is nonnegative and all the other hypotheses hold, then it is integrable. *)

theorem interval_integral_substitution_nonneg:
  fixes f g g':: "real \<Rightarrow> real" and a b u v :: ereal
  assumes "a < b"
  and deriv_g: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> DERIV g x :> g' x"
  and contf: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> isCont f (g x)"
  and contg': "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> isCont g' x"
  and f_nonneg: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> 0 \<le> f (g x)" (* TODO: make this AE? *)
  and g'_nonneg: "\<And>x. a \<le> ereal x \<Longrightarrow> ereal x \<le> b \<Longrightarrow> 0 \<le> g' x"
  and A: "((ereal \<circ> g \<circ> real_of_ereal) \<longlongrightarrow> A) (at_right a)"
  and B: "((ereal \<circ> g \<circ> real_of_ereal) \<longlongrightarrow> B) (at_left b)"
  and integrable_fg: "set_integrable lborel (einterval a b) (\<lambda>x. f (g x) * g' x)"
  shows
    "set_integrable lborel (einterval A B) f"
    "(LBINT x=A..B. f x) = (LBINT x=a..b. (f (g x) * g' x))"
proof -
  from einterval_Icc_approximation[OF \<open>a < b\<close>] obtain u l where approx [simp]:
    "einterval a b = (\<Union>i. {l i..u i})"
    "incseq u"
    "decseq l"
    "\<And>i. l i < u i"
    "\<And>i. a < ereal (l i)"
    "\<And>i. ereal (u i) < b"
    "(\<lambda>x. ereal (l x)) \<longlonglongrightarrow> a"
    "(\<lambda>x. ereal (u x)) \<longlonglongrightarrow> b" by this auto
  have aless[simp]: "\<And>x i. l i \<le> x \<Longrightarrow> a < ereal x"
    by (rule order_less_le_trans, rule approx, force)
  have lessb[simp]: "\<And>x i. x \<le> u i \<Longrightarrow> ereal x < b"
    by (rule order_le_less_trans, subst ereal_less_eq(3), assumption, rule approx)
  have llb[simp]: "\<And>i. l i < b"
    using lessb approx(4) less_eq_real_def by blast
  have alu[simp]: "\<And>i. a < u i"
    by (rule order_less_trans, rule approx, auto, rule approx)
  have [simp]: "\<And>i j. i \<le> j \<Longrightarrow> l j \<le> l i" by (rule decseqD, rule approx)
  have uleu[simp]: "\<And>i j. i \<le> j \<Longrightarrow> u i \<le> u j" by (rule incseqD, rule approx)
  have g_nondec [simp]: "g x \<le> g y" if "a < x" "x \<le> y" "y < b" for x y
  proof (rule DERIV_nonneg_imp_nondecreasing [OF \<open>x \<le> y\<close>], intro exI conjI)
    show "\<And>u. x \<le> u \<Longrightarrow> u \<le> y \<Longrightarrow> (g has_real_derivative g' u) (at u)"
      by (meson deriv_g ereal_less_eq(3) le_less_trans less_le_trans that)
    show "\<And>u. x \<le> u \<Longrightarrow> u \<le> y \<Longrightarrow> 0 \<le> g' u"
      by (meson g'_nonneg less_ereal.simps(1) less_trans not_less that)
  qed
  have "A \<le> B" and un: "einterval A B = (\<Union>i. {g(l i)<..<g(u i)})"
  proof -
    have A2: "(\<lambda>i. g (l i)) \<longlonglongrightarrow> A"
      using A apply (auto simp: einterval_def tendsto_at_iff_sequentially comp_def)
      by (drule_tac x = "\<lambda>i. ereal (l i)" in spec, auto)
    hence A3: "\<And>i. g (l i) \<ge> A"
      by (intro decseq_ge, auto simp: decseq_def)
    have B2: "(\<lambda>i. g (u i)) \<longlonglongrightarrow> B"
      using B apply (auto simp: einterval_def tendsto_at_iff_sequentially comp_def)
      by (drule_tac x = "\<lambda>i. ereal (u i)" in spec, auto)
    hence B3: "\<And>i. g (u i) \<le> B"
      by (intro incseq_le, auto simp: incseq_def)
    have "ereal (g (l 0)) \<le> ereal (g (u 0))"
      by (auto simp: less_imp_le)
    then show "A \<le> B"
      by (meson A3 B3 order.trans)
    { fix x :: real
      assume "A < x" and "x < B"
      then have "eventually (\<lambda>i. ereal (g (l i)) < x \<and> x < ereal (g (u i))) sequentially"
        by (fast intro: eventually_conj order_tendstoD A2 B2)
      hence "\<exists>i. g (l i) < x \<and> x < g (u i)"
        by (simp add: eventually_sequentially, auto)
    } note AB = this
    show "einterval A B = (\<Union>i. {g(l i)<..<g(u i)})"
    proof
      show "einterval A B \<subseteq> (\<Union>i. {g (l i)<..<g (u i)})"
        by (auto simp: einterval_def AB)
      show "(\<Union>i. {g (l i)<..<g (u i)}) \<subseteq> einterval A B"
        apply (clarsimp simp: einterval_def, intro conjI)
        using A3 le_ereal_less apply blast
        using B3 ereal_le_less by blast
    qed
  qed
    (* finally, the main argument *)
  have eq1: "(LBINT x=l i.. u i. (f (g x) * g' x)) = (LBINT y=g (l i)..g (u i). f y)" for i
  proof -
    have "(LBINT x=l i.. u i. g' x *\<^sub>R f (g x)) = (LBINT y=g (l i)..g (u i). f y)"
      apply (rule interval_integral_substitution_finite [OF _ DERIV_subset [OF deriv_g]])
      unfolding has_real_derivative_iff_has_vector_derivative[symmetric]
           apply (auto simp: less_imp_le intro!: continuous_at_imp_continuous_on contf contg')
      done
    then show ?thesis
      by (simp add: ac_simps)
  qed
  have incseq: "incseq (\<lambda>i. {g (l i)<..<g (u i)})"
    apply (clarsimp simp add: incseq_def, intro conjI)
    apply (meson llb antimono_def approx(3) approx(5) g_nondec le_less_trans)
    using alu uleu approx(6) g_nondec less_le_trans by blast
  have img: "\<exists>c \<ge> l i. c \<le> u i \<and> x = g c" if "g (l i) \<le> x" "x \<le> g (u i)" for x i
  proof -
    have "continuous_on {l i..u i} g"
      by (force intro!: DERIV_isCont deriv_g continuous_at_imp_continuous_on)
    with that show ?thesis
      using IVT' [of g] approx(4) dual_order.strict_implies_order by blast
  qed
  have "continuous_on {g (l i)..g (u i)} f" for i
    apply (intro continuous_intros continuous_at_imp_continuous_on)
    using contf img by force
  then have int_f: "\<And>i. set_integrable lborel {g (l i)<..<g (u i)} f"
    by (rule set_integrable_subset [OF borel_integrable_atLeastAtMost']) (auto intro: less_imp_le)
  have integrable: "set_integrable lborel (\<Union>i. {g (l i)<..<g (u i)}) f"
  proof (intro pos_integrable_to_top incseq int_f)
    let ?l = "(LBINT x=a..b. f (g x) * g' x)"
    have "(\<lambda>i. LBINT x=l i..u i. f (g x) * g' x) \<longlonglongrightarrow> ?l"
      by (intro assms interval_integral_Icc_approx_integrable [OF \<open>a < b\<close> approx])
    hence "(\<lambda>i. (LBINT y=g (l i)..g (u i). f y)) \<longlonglongrightarrow> ?l"
      by (simp add: eq1)
    then show "(\<lambda>i. set_lebesgue_integral lborel {g (l i)<..<g (u i)} f) \<longlonglongrightarrow> ?l"
      unfolding interval_lebesgue_integral_def by (auto simp: less_imp_le)
    have "\<And>x i. g (l i) \<le> x \<Longrightarrow> x \<le> g (u i) \<Longrightarrow> 0 \<le> f x"
      using aless f_nonneg img lessb by blast
    then show "\<And>x i. x \<in> {g (l i)<..<g (u i)} \<Longrightarrow> 0 \<le> f x"
      using less_eq_real_def by auto
  qed (auto simp: greaterThanLessThan_borel)
  thus "set_integrable lborel (einterval A B) f"
    by (simp add: un)

  have "(LBINT x=A..B. f x) = (LBINT x=a..b. g' x *\<^sub>R f (g x))"
  proof (rule interval_integral_substitution_integrable)
    show "set_integrable lborel (einterval a b) (\<lambda>x. g' x *\<^sub>R f (g x))"
      using integrable_fg by (simp add: ac_simps)
  qed fact+
  then show "(LBINT x=A..B. f x) = (LBINT x=a..b. (f (g x) * g' x))"
    by (simp add: ac_simps)
qed

syntax "_complex_lebesgue_borel_integral" :: "pttrn \<Rightarrow> real \<Rightarrow> complex"
  ("(2CLBINT _. _)" [0,60] 60)

translations "CLBINT x. f" == "CONST complex_lebesgue_integral CONST lborel (\<lambda>x. f)"

syntax "_complex_set_lebesgue_borel_integral" :: "pttrn \<Rightarrow> real set \<Rightarrow> real \<Rightarrow> complex"
  ("(3CLBINT _:_. _)" [0,60,61] 60)

translations
  "CLBINT x:A. f" == "CONST complex_set_lebesgue_integral CONST lborel A (\<lambda>x. f)"

abbreviation complex_interval_lebesgue_integral ::
    "real measure \<Rightarrow> ereal \<Rightarrow> ereal \<Rightarrow> (real \<Rightarrow> complex) \<Rightarrow> complex" where
  "complex_interval_lebesgue_integral M a b f \<equiv> interval_lebesgue_integral M a b f"

abbreviation complex_interval_lebesgue_integrable ::
  "real measure \<Rightarrow> ereal \<Rightarrow> ereal \<Rightarrow> (real \<Rightarrow> complex) \<Rightarrow> bool" where
  "complex_interval_lebesgue_integrable M a b f \<equiv> interval_lebesgue_integrable M a b f"

syntax
  "_ascii_complex_interval_lebesgue_borel_integral" :: "pttrn \<Rightarrow> ereal \<Rightarrow> ereal \<Rightarrow> real \<Rightarrow> complex"
  ("(4CLBINT _=_.._. _)" [0,60,60,61] 60)

translations
  "CLBINT x=a..b. f" == "CONST complex_interval_lebesgue_integral CONST lborel a b (\<lambda>x. f)"

proposition interval_integral_norm:
  fixes f :: "real \<Rightarrow> 'a :: {banach, second_countable_topology}"
  shows "interval_lebesgue_integrable lborel a b f \<Longrightarrow> a \<le> b \<Longrightarrow>
    norm (LBINT t=a..b. f t) \<le> LBINT t=a..b. norm (f t)"
  using integral_norm_bound[of lborel "\<lambda>x. indicator (einterval a b) x *\<^sub>R f x"]
  by (auto simp: interval_lebesgue_integral_def interval_lebesgue_integrable_def set_lebesgue_integral_def)

proposition interval_integral_norm2:
  "interval_lebesgue_integrable lborel a b f \<Longrightarrow>
    norm (LBINT t=a..b. f t) \<le> \<bar>LBINT t=a..b. norm (f t)\<bar>"
proof (induct a b rule: linorder_wlog)
  case (sym a b) then show ?case
    by (simp add: interval_integral_endpoints_reverse[of a b] interval_integrable_endpoints_reverse[of a b])
next
  case (le a b)
  then have "\<bar>LBINT t=a..b. norm (f t)\<bar> = LBINT t=a..b. norm (f t)"
    using integrable_norm[of lborel "\<lambda>x. indicator (einterval a b) x *\<^sub>R f x"]
    by (auto simp: interval_lebesgue_integral_def interval_lebesgue_integrable_def set_lebesgue_integral_def
             intro!: integral_nonneg_AE abs_of_nonneg)
  then show ?case
    using le by (simp add: interval_integral_norm)
qed

(* TODO: should we have a library of facts like these? *)
lemma integral_cos: "t \<noteq> 0 \<Longrightarrow> LBINT x=a..b. cos (t * x) = sin (t * b) / t - sin (t * a) / t"
  apply (intro interval_integral_FTC_finite continuous_intros)
  by (auto intro!: derivative_eq_intros simp: has_real_derivative_iff_has_vector_derivative[symmetric])

end


(*  Author:     Tobias Nipkow, 2007  *)

section "Arrow's Theorem for Strict Linear Orders"

theory Arrow_Order imports Main "HOL-Library.FuncSet"
begin

text\<open>This theory formalizes the third proof due to
Geanakoplos~\cite{Geanakoplos05}.  Preferences are modeled as strict
linear orderings. The set of alternatives need not be finite.

Individuals are assumed to be finite but are not a priori identified with an
initial segment of the naturals. In retrospect this generality appears
gratuitous and complicates some of the low-level reasoning where we use a
bijection with such an initial segment.\<close>

typedecl alt
typedecl indi

abbreviation "I == (UNIV::indi set)"

axiomatization where
  alt3: "\<exists>a b c::alt. distinct[a,b,c]" and
  finite_indi: "finite I"

abbreviation "N == card I"

lemma third_alt: "a \<noteq> b \<Longrightarrow> \<exists>c::alt. distinct[a,b,c]"
using alt3 by simp metis

lemma alt2: "\<exists>b::alt. b \<noteq> a"
using alt3 by simp metis

type_synonym pref = "(alt * alt)set"

definition "Lin == {L::pref. strict_linear_order L}"

lemmas slo_defs = Lin_def strict_linear_order_on_def total_on_def irrefl_def

lemma notin_Lin_iff: "L : Lin \<Longrightarrow> x\<noteq>y \<Longrightarrow> (x,y) \<notin> L \<longleftrightarrow> (y,x) : L"
apply(auto simp add: slo_defs)
apply(metis trans_def)
done

lemma converse_in_Lin[simp]: "L\<inverse> : Lin \<longleftrightarrow> L : Lin"
apply (simp add: slo_defs)
apply blast
done

lemma Lin_irrefl: "L:Lin \<Longrightarrow> (a,b):L \<Longrightarrow> (b,a):L \<Longrightarrow> False"
by(simp add:slo_defs)(metis trans_def)

corollary linear_alt: "\<exists>L::pref. L : Lin"
using well_order_on[where 'a = "alt", of UNIV]
apply (auto simp:well_order_on_def Lin_def)
apply (metis strict_linear_order_on_diff_Id)
done

abbreviation
 rem :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"rem L a \<equiv> {(x,y). (x,y) \<in> L \<and> x\<noteq>a \<and> y\<noteq>a}"
definition
 mktop :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"mktop L b \<equiv> rem L b \<union> {(x,b)|x. x\<noteq>b}"
definition
 mkbot :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"mkbot L b \<equiv> rem L b \<union> {(b,y)|y. y\<noteq>b}"
definition
 below :: "pref \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> pref" where
"below L a b \<equiv> rem L a \<union>
  {(a,b)} \<union> {(x,a)|x. (x,b) : L \<and> x\<noteq>a} \<union> {(a,y)|y. (b,y) : L \<and> y\<noteq>a}"
definition
 above :: "pref \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> pref" where
"above L a b \<equiv> rem L b \<union>
  {(a,b)} \<union> {(x,b)|x. (x,a) : L \<and> x\<noteq>b} \<union> {(b,y)|y. (a,y) : L \<and> y\<noteq>b}"

lemma in_mktop: "(x,y) \<in> mktop L z \<longleftrightarrow> x\<noteq>z \<and> (if y=z then x\<noteq>y else (x,y) \<in> L)"
by(auto simp:mktop_def)

lemma in_mkbot: "(x,y) \<in> mkbot L z \<longleftrightarrow> y\<noteq>z \<and> (if x=z then x\<noteq>y else (x,y) \<in> L)"
by(auto simp:mkbot_def)

lemma in_above: "a\<noteq>b \<Longrightarrow> L:Lin \<Longrightarrow>
  (x,y) : above L a b \<longleftrightarrow> x\<noteq>y \<and>
  (if x=b then (a,y) : L else
   if y=b then x=a | (x,a) : L else (x,y) : L)"
by(auto simp:above_def slo_defs)

lemma in_below: "a\<noteq>b \<Longrightarrow> L:Lin \<Longrightarrow>
  (x,y) : below L a b \<longleftrightarrow> x\<noteq>y \<and>
  (if y=a then (x,b) : L else
   if x=a then y=b | (b,y) : L else (x,y) : L)"
by(auto simp:below_def slo_defs)

declare [[simp_depth_limit = 2]]

lemma mktop_Lin: "L : Lin \<Longrightarrow> mktop L x : Lin"
by(auto simp add:slo_defs mktop_def trans_def)
lemma mkbot_Lin: "L : Lin \<Longrightarrow> mkbot L x : Lin"
by(auto simp add:slo_defs trans_def mkbot_def)

lemma below_Lin: "x\<noteq>y \<Longrightarrow> L : Lin \<Longrightarrow> below L x y : Lin"
unfolding slo_defs below_def trans_def
apply(simp)
apply blast
done

lemma above_Lin: "x\<noteq>y \<Longrightarrow> L : Lin \<Longrightarrow> above L x y : Lin"
unfolding slo_defs above_def trans_def
apply(simp)
apply blast
done

declare [[simp_depth_limit = 50]]

abbreviation lessLin :: "alt \<Rightarrow> pref \<Rightarrow> alt \<Rightarrow> bool" ("(_ <\<^bsub>_\<^esub> _)" [51, 51] 50)
where "a <\<^bsub>L\<^esub> b == (a,b) : L"

definition "Prof = I \<rightarrow> Lin"

abbreviation "SWF == Prof \<rightarrow> Lin"

definition "unanimity F == \<forall>P\<in>Prof.\<forall>a b. (\<forall>i. a <\<^bsub>P i\<^esub> b) \<longrightarrow>  a <\<^bsub>F P\<^esub> b"

definition "IIA F == \<forall>P\<in>Prof.\<forall>P'\<in>Prof.\<forall>a b.
   (\<forall>i. a <\<^bsub>P i\<^esub> b \<longleftrightarrow> a <\<^bsub>P' i\<^esub> b) \<longrightarrow> (a <\<^bsub>F P\<^esub> b \<longleftrightarrow> a <\<^bsub>F P'\<^esub> b)"

definition "dictator F i == \<forall>P\<in>Prof. F P = P i"

lemma dictatorI: "F : SWF \<Longrightarrow>
  \<forall>P\<in>Prof. \<forall>a b. a \<noteq> b \<longrightarrow> (a,b) : P i \<longrightarrow> (a,b) : F P \<Longrightarrow> dictator F i"
apply(simp add:dictator_def Prof_def Pi_def Lin_def strict_linear_order_on_def)
apply safe
 apply(erule_tac x=P in allE)
 apply(erule_tac x=P in allE)
 apply(simp add:total_on_def irrefl_def)
 apply (metis trans_def)
apply (metis irrefl_def)
done

lemma const_Lin_Prof: "L:Lin \<Longrightarrow> (%p. L) : Prof"
by(simp add:Prof_def Pi_def)

lemma complete_Lin: assumes "a\<noteq>b" shows "\<exists>L\<in>Lin. (a,b) : L"
proof -
  from linear_alt obtain R where "R:Lin" by auto
  thus ?thesis by (metis assms in_mkbot mkbot_Lin)
qed

declare Let_def[simp]

theorem Arrow: assumes "F : SWF" and u: "unanimity F" and "IIA F"
shows "\<exists>i. dictator F i"
proof -
  { fix a b a' b' and P P'
    assume d1: "a\<noteq>b" "a'\<noteq>b'" and d2: "a\<noteq>b'" "b\<noteq>a'" and
      "P : Prof" "P' : Prof" and 1: "\<forall>i. (a,b) : P i \<longleftrightarrow> (a',b') : P' i"
    assume "(a,b) : F P"
    define Q where
      "Q i = (let L = (if a=a' then P i else below (P i) a' a)
              in if b=b' then L else above L b b')" for i
    have "Q : Prof" using \<open>P : Prof\<close>
      by(simp add:Q_def Prof_def Pi_def above_Lin below_Lin)
    hence "F Q : Lin" using \<open>F : SWF\<close> by(simp add:Pi_def)
    have "\<forall>i. (a,b) : P i \<longleftrightarrow> (a,b) : Q i" using d1 d2 \<open>P : Prof\<close>
      by(simp add:in_above in_below Q_def Prof_def Pi_def below_Lin)
    hence "(a,b) : F Q" using \<open>(a,b) : F P\<close> \<open>IIA F\<close> \<open>P:Prof\<close> \<open>Q : Prof\<close>
      unfolding IIA_def by blast
    moreover
    { assume "a\<noteq>a'"
      hence "!!i. (a',a) : Q i" using d1 d2 \<open>P : Prof\<close>
        by(simp add:in_above in_below Q_def Prof_def Pi_def below_Lin)
      hence "(a',a) : F Q" using u \<open>Q : Prof\<close> by(simp add:unanimity_def)
    } moreover
    { assume "b\<noteq>b'"
      hence "!!i. (b,b') : Q i" using d1 d2 \<open>P : Prof\<close>
        by(simp add:in_above in_below Q_def Prof_def Pi_def below_Lin)
      hence "(b,b') : F Q" using u \<open>Q : Prof\<close> by(simp add:unanimity_def)
    }
    ultimately have "(a',b') : F Q" using \<open>F Q : Lin\<close>
      unfolding slo_defs trans_def
      by safe metis
    moreover
    have "\<forall>i. (a',b') : Q i \<longleftrightarrow> (a',b') : P' i" using d1 d2 \<open>P : Prof\<close> 1
      by(simp add:Q_def in_below in_above Prof_def Pi_def below_Lin) blast
    ultimately have "(a',b') : F P'"
      using \<open>IIA F\<close> \<open>P' : Prof\<close> \<open>Q : Prof\<close> unfolding IIA_def by blast
  } note 1 = this
  { fix a b a' b' and P P'
    assume "a\<noteq>b" "a'\<noteq>b'" "a\<noteq>b'" "b\<noteq>a'" "P : Prof" "P' : Prof"
           "\<forall>i. (a,b) : P i \<longleftrightarrow> (a',b') : P' i"
    hence "(a,b) : F P \<longleftrightarrow> (a',b') : F P'" using 1 by blast
  } note 2 = this
  { fix a b P P'
    assume "a\<noteq>b" "P : Prof" "P' : Prof" and
      iff: "\<forall>i. (a,b) : P i \<longleftrightarrow> (b,a) : P' i"
    from \<open>a\<noteq>b\<close> obtain c where dist: "distinct[a,b,c]" using third_alt by metis
    let ?Q = "%p. below (P p) c b"
    let ?R = "%p. below (?Q p) b a"
    let ?S = "%p. below (?R p) a c"
    have "?Q : Prof" using \<open>P : Prof\<close> dist
      by(auto simp add:Prof_def Pi_def below_Lin)
    hence "?R : Prof" using dist by(auto simp add:Prof_def Pi_def below_Lin)
    hence "?S : Prof" using dist by(auto simp add:Prof_def Pi_def below_Lin)
    have "\<forall>i. (a,b) : P i \<longleftrightarrow> (a,c) : ?Q i" using \<open>P : Prof\<close> dist
      by(auto simp add:in_below Prof_def Pi_def)
    hence ab: "(a,b) : F P \<longleftrightarrow> (a,c) : F ?Q"
      using 2 \<open>P : Prof\<close> \<open>?Q : Prof\<close> dist[simplified] by (blast)
    have "\<forall>i. (a,c) : ?Q i \<longleftrightarrow> (b,c) : ?R i" using \<open>P : Prof\<close> dist
      by(auto simp add:in_below Prof_def Pi_def below_Lin)
    hence ac: "(a,c) : F ?Q \<longleftrightarrow> (b,c) : F ?R"
      using 2 \<open>?Q : Prof\<close> \<open>?R : Prof\<close> dist[simplified] by (blast)
    have "\<forall>i. (b,c) : ?R i \<longleftrightarrow> (b,a) : ?S i" using \<open>P : Prof\<close> dist
      by(auto simp add:in_below Prof_def Pi_def below_Lin)
    hence bc: "(b,c) : F ?R \<longleftrightarrow> (b,a) : F ?S"
      using \<open>?R : Prof\<close> \<open>?S : Prof\<close> dist[simplified] 2
      apply -
      apply(rule 2)
      by fast+
    have "\<forall>i. (b,a) : ?S i \<longleftrightarrow> (a,b) : P i" using \<open>P : Prof\<close> dist
      by(auto simp add:in_below Prof_def Pi_def below_Lin)
    hence "\<forall>i. (b,a) : ?S i \<longleftrightarrow> (b,a) : P' i" using iff by blast
    hence ba: "(b,a) : F ?S \<longleftrightarrow> (b,a) : F P'"
      using \<open>IIA F\<close> \<open>P' : Prof\<close> \<open>?S : Prof\<close> unfolding IIA_def by fast
    from ab ac bc ba have "(a,b) : F P \<longleftrightarrow> (b,a) : F P'" by simp
  } note 3 = this
  { fix a b c P P'
    assume A: "a\<noteq>b" "b\<noteq>c" "a\<noteq>c" "P : Prof" "P' : Prof" and
      iff: "\<forall>i. (a,b) : P i \<longleftrightarrow> (b,c) : P' i"
    hence "\<forall>i. (b,a) : (converse o P)i \<longleftrightarrow> (b,c) : P' i" by simp
    moreover have cP: "converse o P : Prof"
      using \<open>P:Prof\<close> by(simp add:Prof_def Pi_def)
    ultimately have "(b,a) : F(converse o P) \<longleftrightarrow> (b,c) : F P'" using A 2
      by metis
    moreover have "(a,b) : F P \<longleftrightarrow> (b,a) : F(converse o P)"
      by (rule 3[OF \<open>a\<noteq>b\<close> \<open>P:Prof\<close> cP]) simp
    ultimately have "(a,b) : F P \<longleftrightarrow> (b,c) : F P'" by blast
  } note 4 = this
  { fix a b a' b' :: alt and P P'
    assume A: "a\<noteq>b" "a'\<noteq>b'" "P : Prof" "P' : Prof"
      "\<forall>i. (a,b) : P i \<longleftrightarrow> (a',b') : P' i"
    have "(a,b) : F P \<longleftrightarrow> (a',b') : F P'"
    proof-
      { assume "a\<noteq>b' & b\<noteq>a'" hence ?thesis using 2 A by blast }
      moreover
      { assume "a=b' & b\<noteq>a'" hence ?thesis using 4 A by blast }
      moreover
      { assume "a\<noteq>b' & b=a'" hence ?thesis using 4 A by blast }
      moreover
      { assume "a=b' & b=a'" hence ?thesis using 3 A by blast }
      ultimately show ?thesis by blast
    qed
  } note pairwise_neutrality = this
  obtain h :: "indi \<Rightarrow> nat" where
    injh: "inj h" and surjh: "h ` I = {0..<N}"
    by(metis ex_bij_betw_finite_nat[OF finite_indi] bij_betw_def)
  obtain a b :: alt where "a \<noteq> b" using alt3 by auto
  obtain Lab where "(a,b) : Lab" "Lab:Lin" using \<open>a\<noteq>b\<close> by (metis complete_Lin)
  hence "(b,a) \<notin> Lab" by(simp add:slo_defs trans_def) metis
  obtain Lba where "(b,a) : Lba" "Lba:Lin" using \<open>a\<noteq>b\<close> by (metis complete_Lin)
  hence "(a,b) \<notin> Lba" by(simp add:slo_defs trans_def) metis
  let ?Pi = "%n. %i. if h i < n then Lab else Lba"
  have PiProf: "!!n. ?Pi n : Prof" using \<open>Lab:Lin\<close> \<open>Lba:Lin\<close>
    unfolding Prof_def Pi_def by simp
  have "\<exists>n<N. (\<forall>m\<le>n. (b,a) : F(?Pi m)) & (a,b) : F(?Pi(n+1))"
  proof -
    have 0: "!!n. F(?Pi n) : Lin" using \<open>F : SWF\<close> PiProf by(simp add:Pi_def)
    have "F(%i. Lba):Lin" using \<open>F:SWF\<close> \<open>Lba:Lin\<close> by(simp add:Prof_def Pi_def)
    hence 1: "(a,b) \<notin> F(?Pi 0)" using u \<open>(a,b) \<notin> Lba\<close> \<open>Lba:Lin\<close> \<open>Lba:Lin\<close> \<open>a\<noteq>b\<close>
      by(simp add:unanimity_def notin_Lin_iff const_Lin_Prof)
    have "?Pi N = (%p. Lab)" using surjh [THEN equalityD1]
      by(auto simp: subset_eq)
    moreover
    have "F(%i. Lab):Lin" using \<open>F:SWF\<close> \<open>Lab:Lin\<close> by(simp add:Prof_def Pi_def)
    ultimately have 2: "(a,b) \<in> F(?Pi N)" using u \<open>(a,b) : Lab\<close> \<open>Lab:Lin\<close>
      by(simp add:unanimity_def const_Lin_Prof)
    with ex_least_nat_less[of "%n. (a,b) : F(?Pi n)",OF 1 2]
      notin_Lin_iff[OF 0 \<open>a\<noteq>b\<close>]
    show ?thesis by simp
  qed
  then obtain n where n: "n<N" "\<forall>m\<le>n. (b,a) : F(?Pi m)" "(a,b) : F(?Pi(n+1))"
    by blast
  have "dictator F (inv h n)"
  proof (rule dictatorI [OF \<open>F : SWF\<close>], auto)
    fix P c d assume "P \<in> Prof" "c\<noteq>d" "(c,d) \<in> P(inv h n)"
    then obtain e where dist: "distinct[c,d,e]" using third_alt by metis
    let ?W = "%i. if h i < n then mktop (P i) e else
                  if h i = n then above (P i) c e else mkbot (P i) e"
    have "?W : Prof" using \<open>P : Prof\<close> dist
      by(simp add:Pi_def Prof_def mkbot_Lin mktop_Lin above_Lin)
    have "\<forall>i. (c,d) : P i \<longleftrightarrow> (c,d) : ?W i" using dist \<open>P : Prof\<close>
      by(auto simp: in_above in_mkbot in_mktop Prof_def Pi_def)
    hence PW: "(c,d) : F P \<longleftrightarrow> (c,d) : F ?W"
      using \<open>IIA F\<close>[unfolded IIA_def] \<open>P:Prof\<close> \<open>?W:Prof\<close> by fast
    have "\<forall>i. (c,e) : ?W i \<longleftrightarrow> (a,b) : ?Pi (n+1) i" using dist \<open>P : Prof\<close>
      by (auto simp: \<open>(a,b):Lab\<close> \<open>(a,b)\<notin>Lba\<close>
        in_mkbot in_mktop in_above Prof_def Pi_def)
    hence "(c,e) : F ?W \<longleftrightarrow> (a,b) : F(?Pi(n+1))"
      using pairwise_neutrality[of c e a b ?W "?Pi(n+1)"]
        \<open>a\<noteq>b\<close> dist \<open>?W : Prof\<close> PiProf by simp
    hence "(c,e) : F ?W" using n(3) by blast
    have "\<forall>i. (e,d) : ?W i \<longleftrightarrow> (b,a) : ?Pi n i"
      using dist \<open>P : Prof\<close> \<open>(c,d) \<in> P(inv h n)\<close> \<open>inj h\<close>
      by(auto simp: \<open>(b,a):Lba\<close> \<open>(b,a)\<notin>Lab\<close>
        in_mkbot in_mktop in_above Prof_def Pi_def)
    hence "(e,d) : F ?W \<longleftrightarrow> (b,a) : F(?Pi n)"
      using pairwise_neutrality[of e d b a ?W "?Pi n"]
        \<open>a\<noteq>b\<close> dist \<open>?W : Prof\<close> PiProf by simp blast
    hence "(e,d) : F ?W" using n(2) by auto
    with \<open>(c,e) : F ?W\<close> \<open>?W : Prof\<close> \<open>F:SWF\<close>
    have "(c,d) \<in> F ?W" unfolding Pi_def slo_defs trans_def by blast
    thus "(c,d) \<in> F P" using PW by blast
  qed
  thus ?thesis ..
qed

end


theory ex_4_4
  imports Main
begin
inductive ev::"nat\<Rightarrow>bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

lemma "\<not> ev (Suc (Suc (Suc 0)))"
proof
  assume "ev (Suc (Suc (Suc 0)))"
  thus False
  proof cases
    assume "ev (Suc 0)"
    thus False by cases
  qed
qed
end


section "Big-step semantics of CBV lambda calculus"

theory BigStepLam
  imports Lambda SmallStepLam
begin

datatype bval
  = BNat nat
  | BClos name exp "(name \<times> bval) list"

type_synonym benv = "(name \<times> bval) list"

inductive eval :: "benv \<Rightarrow> exp \<Rightarrow> bval \<Rightarrow> bool" ("_ \<turnstile> _ \<Down> _" [50,50,50] 51) where
  eval_nat[intro!]: "\<rho> \<turnstile> ENat n \<Down> BNat n" |
  eval_var[intro!]: "lookup \<rho> x = Some v \<Longrightarrow> \<rho> \<turnstile> EVar x \<Down> v" |
  eval_lam[intro!]: "\<rho> \<turnstile> ELam x e \<Down> BClos x e \<rho>" |
  eval_app[intro!]: "\<lbrakk> \<rho> \<turnstile> e1 \<Down> BClos x e \<rho>'; \<rho> \<turnstile> e2 \<Down> arg;
                       (x,arg)#\<rho>' \<turnstile> e \<Down> v \<rbrakk> \<Longrightarrow>
                      \<rho> \<turnstile> EApp e1 e2 \<Down> v" |
  eval_prim[intro!]: "\<lbrakk> \<rho> \<turnstile> e1 \<Down> BNat n1; \<rho> \<turnstile> e2 \<Down> BNat n2 ; n3 = f n1 n2\<rbrakk> \<Longrightarrow>
                       \<rho> \<turnstile> EPrim f e1 e2 \<Down> BNat n3" |
  eval_if0[intro!]: "\<lbrakk> \<rho> \<turnstile> e1 \<Down> BNat 0; \<rho> \<turnstile> e3 \<Down> v3 \<rbrakk> \<Longrightarrow>
                      \<rho> \<turnstile> EIf e1 e2 e3 \<Down> v3" |
  eval_if1[intro!]: "\<lbrakk> \<rho> \<turnstile> e1 \<Down> BNat n; n \<noteq> 0; \<rho> \<turnstile> e2 \<Down> v2 \<rbrakk> \<Longrightarrow>
                      \<rho> \<turnstile> EIf e1 e2 e3 \<Down> v2"

inductive_cases
  eval_nat_inv[elim!]: "\<rho> \<turnstile> ENat n \<Down> v" and
  eval_var_inv[elim!]: "\<rho> \<turnstile> EVar x \<Down> v" and
  eval_lam_inv[elim!]: "\<rho> \<turnstile> ELam x e \<Down> v" and
  eval_app_inv[elim!]: "\<rho> \<turnstile> EApp e1 e2 \<Down> v" and
  eval_prim_inv[elim!]: "\<rho> \<turnstile> EPrim f e1 e2 \<Down> v" and
  eval_if_inv[elim!]: "\<rho> \<turnstile> EIf e1 e2 e3 \<Down> v"

subsection "Big-step semantics is sound wrt. small-step semantics"

type_synonym env = "(name \<times> exp) list"

fun psubst :: "env \<Rightarrow> exp \<Rightarrow> exp" where
  "psubst \<rho> (ENat n) = ENat n" |
  "psubst \<rho> (EVar x) =
     (case lookup \<rho> x of
       None \<Rightarrow> EVar x
     | Some v \<Rightarrow> v)" |
  "psubst \<rho> (ELam x e) = ELam x (psubst ((x,EVar x)#\<rho>) e)" |
  "psubst \<rho> (EApp e1 e2) = EApp (psubst \<rho> e1) (psubst \<rho> e2)" |
  "psubst \<rho> (EPrim f e1 e2) = EPrim f (psubst \<rho> e1) (psubst \<rho> e2)" |
  "psubst \<rho> (EIf e1 e2 e3) = EIf (psubst \<rho> e1) (psubst \<rho> e2) (psubst \<rho> e3)"

inductive bs_val :: "bval \<Rightarrow> exp \<Rightarrow> bool" and
  bs_env :: "benv \<Rightarrow> env \<Rightarrow> bool" where
  bs_nat[intro!]: "bs_val (BNat n) (ENat n)" |
  bs_clos[intro!]: "\<lbrakk> bs_env \<rho> \<rho>'; FV (ELam x (psubst ((x,EVar x)#\<rho>') e)) = {} \<rbrakk> \<Longrightarrow>
                    bs_val (BClos x e \<rho>) (ELam x (psubst ((x,EVar x)#\<rho>') e))" |
  bs_nil[intro!]: "bs_env [] []" |
  bs_cons[intro!]: "\<lbrakk> bs_val w v; bs_env \<rho> \<rho>' \<rbrakk> \<Longrightarrow> bs_env ((x,w)#\<rho>) ((x,v)#\<rho>')"

inductive_cases bs_env_inv1[elim!]: "bs_env ((x, w) # \<rho>) \<rho>'" and
  bs_clos_inv[elim!]: "bs_val (BClos x e \<rho>'') v1" and
  bs_nat_inv[elim!]: "bs_val (BNat n) v"

lemma bs_val_is_val[intro!]: "bs_val w v \<Longrightarrow> is_val v"
  by (cases w) auto

lemma lookup_bs_env: "\<lbrakk> bs_env \<rho> \<rho>'; lookup \<rho> x = Some w \<rbrakk> \<Longrightarrow>
  \<exists> v. lookup \<rho>' x = Some v \<and> bs_val w v"
  by (induction \<rho> arbitrary: \<rho>' x w) auto

lemma app_red_cong1: "e1 \<longrightarrow>* e1' \<Longrightarrow> EApp e1 e2 \<longrightarrow>* EApp e1' e2"
  by (induction rule: multi_step.induct) blast+

lemma app_red_cong2: "e2 \<longrightarrow>* e2' \<Longrightarrow> EApp e1 e2 \<longrightarrow>* EApp e1 e2'"
  by (induction rule: multi_step.induct) blast+

lemma prim_red_cong1: "e1 \<longrightarrow>* e1' \<Longrightarrow> EPrim f e1 e2 \<longrightarrow>* EPrim f e1' e2"
  by (induction rule: multi_step.induct) blast+

lemma prim_red_cong2: "e2 \<longrightarrow>* e2' \<Longrightarrow> EPrim f e1 e2 \<longrightarrow>* EPrim f e1 e2'"
  by (induction rule: multi_step.induct) blast+

lemma if_red_cong1: "e1 \<longrightarrow>* e1' \<Longrightarrow> EIf e1 e2 e3 \<longrightarrow>* EIf e1' e2 e3"
  by (induction rule: multi_step.induct) blast+

lemma multi_step_trans: "\<lbrakk> e1 \<longrightarrow>* e2; e2 \<longrightarrow>* e3 \<rbrakk> \<Longrightarrow> e1 \<longrightarrow>* e3"
proof (induction arbitrary: e3 rule: multi_step.induct)
  case (ms_cons e1 e2 e3 e3')
  then have "e2 \<longrightarrow>* e3'" by auto
  with ms_cons(1) show ?case by blast
qed blast

lemma subst_id_fv: "x \<notin> FV e \<Longrightarrow> subst x v e = e"
  by (induction e arbitrary: x v) auto

definition sdom :: "env \<Rightarrow> name set" where
  "sdom \<rho> \<equiv> {x. \<exists> v. lookup \<rho> x = Some v \<and> v \<noteq> EVar x }"

definition closed_env :: "env \<Rightarrow> bool" where
  "closed_env \<rho> \<equiv> (\<forall> x v. x \<in> sdom \<rho> \<longrightarrow> lookup \<rho> x = Some v \<longrightarrow> FV v = {})"

definition equiv_env :: "env \<Rightarrow> env \<Rightarrow> bool" where
  "equiv_env \<rho> \<rho>' \<equiv> (sdom \<rho> = sdom \<rho>' \<and> (\<forall> x. x \<in> sdom \<rho> \<longrightarrow> lookup \<rho> x = lookup \<rho>' x))"

lemma sdom_cons_xx[simp]: "sdom ((x,EVar x)#\<rho>) = sdom \<rho> - {x}"
  unfolding sdom_def by auto

lemma sdom_cons_v[simp]: "FV v = {} \<Longrightarrow> sdom ((x,v)#\<rho>) = insert x (sdom \<rho>)"
  unfolding sdom_def by auto

lemma lookup_some_in_dom: "\<lbrakk> lookup \<rho> x = Some v; v \<noteq> EVar x \<rbrakk> \<Longrightarrow> x \<in> sdom \<rho>"
proof (induction \<rho>)
  case (Cons b \<rho>)
  show ?case
  proof (cases b)
    case (Pair y v')
    with Cons show ?thesis unfolding sdom_def by auto
  qed
qed auto

lemma lookup_none_notin_dom: "lookup \<rho> x = None \<Longrightarrow> x \<notin> sdom \<rho>"
proof (induction \<rho>)
  case (Cons b \<rho>)
  show ?case
  proof (cases b)
    case (Pair y v)
    with Cons show ?thesis unfolding sdom_def by auto
  qed
qed (auto simp: sdom_def)

lemma psubst_change: "equiv_env \<rho> \<rho>' \<Longrightarrow> psubst \<rho> e = psubst \<rho>' e"
proof (induction e arbitrary: \<rho> \<rho>')
  case (EVar x)
  show ?case
  proof (cases "lookup \<rho> x")
    case None from None have lx: "lookup \<rho> x = None" by simp
    show ?thesis
    proof (cases "lookup \<rho>' x")
      case None
      with EVar lx show ?thesis by auto
    next
      case (Some v)
      from EVar lx Some have "x \<notin> sdom \<rho>'" unfolding equiv_env_def by auto
      with lx Some show ?thesis unfolding sdom_def by simp
    qed
  next
    case (Some v) from Some have lx: "lookup \<rho> x = Some v" by simp
    show ?thesis
    proof (cases "lookup \<rho>' x")
      case None
      from EVar lx None have "x \<notin> sdom \<rho>" unfolding equiv_env_def by auto
      with None Some show ?thesis unfolding sdom_def by simp
    next
      case (Some v')
      from EVar Some lx show ?thesis by (simp add: equiv_env_def sdom_def) force
    qed
  qed
next
  case (ELam x' e)
  from ELam(2) have "equiv_env ((x',EVar x')#\<rho>) ((x',EVar x')#\<rho>')" by (simp add: equiv_env_def)
  with ELam show ?case by (simp add: equiv_env_def)
qed fastforce+

lemma subst_psubst: "\<lbrakk> closed_env \<rho>; FV v = {} \<rbrakk> \<Longrightarrow>
    subst x v (psubst ((x, EVar x) # \<rho>) e) = psubst ((x, v) # \<rho>) e"
proof (induction e arbitrary: x v \<rho>)
  case (EVar x x' v \<rho>)
  show ?case
  proof (cases "x = x'")
    case True
    then show ?thesis by force
  next
    case False from False have xxp: "x \<noteq> x'" by simp
    show ?thesis
    proof (cases "lookup \<rho> x")
      case None
      then show ?thesis by auto
    next
      case (Some v')
      show ?thesis
      proof (cases "v' = EVar x")
        case True
        with Some show ?thesis by auto
      next
        case False
        from False Some have xdom: "x \<in> sdom \<rho>" using lookup_some_in_dom by simp
        from this EVar Some have "FV v' = {}" using closed_env_def by blast
        from this Some show ?thesis using subst_id_fv by auto
      qed
    qed
  qed
next
  case (ELam x' e)
  show ?case
  proof (cases "x = x'")
    case True
    then show ?thesis apply simp apply (rule psubst_change)
      using equiv_env_def sdom_def by auto
  next
    case False
    then show ?thesis apply simp
    proof -
      assume x_xp: "x \<noteq> x'"
      let ?r = "(x',EVar x') # \<rho>"
      from ELam have IHprem: "closed_env ((x', EVar x') # \<rho>)" using closed_env_def by auto
      have "psubst ((x',EVar x')#(x, EVar x)#\<rho>) e = psubst ((x,EVar x)#(x',EVar x') # \<rho>) e"
        apply (rule psubst_change) using x_xp equiv_env_def by auto
      from this have "subst x v (psubst ((x', EVar x') # (x, EVar x) # \<rho>) e)
                       = subst x v (psubst ((x,EVar x)#(x',EVar x') # \<rho>) e)" by simp
      also with ELam IHprem have "... = psubst ((x,v)#(x',EVar x')#\<rho>) e"
        using ELam(1)[of "(x',EVar x')#\<rho>" v x] by simp
      also have "... = psubst ((x',EVar x')#(x,v)#\<rho>) e"
        apply (rule psubst_change) using x_xp equiv_env_def sdom_def by auto
      finally show "subst x v (psubst ((x', EVar x') # (x, EVar x) # \<rho>) e)
                    = psubst ((x', EVar x') # (x,v) # \<rho>) e" .
    qed
  qed
qed fastforce+

inductive_cases bsenv_nil[elim!]: "bs_env [] \<rho>'"

lemma bs_env_dom: "bs_env \<rho> \<rho>' \<Longrightarrow> set (map fst \<rho>) = sdom \<rho>'"
proof (induction \<rho> arbitrary: \<rho>')
  case Nil
  then show ?case by (force simp: sdom_def)
next
  case (Cons b \<rho>)
  then show ?case
  proof (cases b)
    case (Pair x v')
    with Cons show ?thesis by (cases v') force+
  qed
qed

lemma closed_env_cons[intro!]: "FV v = {} \<Longrightarrow> closed_env \<rho>'' \<Longrightarrow> closed_env ((a, v) # \<rho>'')"
  by (simp add: closed_env_def sdom_def)

lemma bs_env_closed: "bs_env \<rho> \<rho>' \<Longrightarrow> closed_env \<rho>'"
proof (induction \<rho> arbitrary: \<rho>')
  case Nil
  then show ?case by (force simp: closed_env_def)
next
  case (Cons b \<rho>)
  from Cons obtain x v v' \<rho>'' where b: "b = (x,v)" and rp: "\<rho>' = (x,v')#\<rho>''"
    and vvp: "bs_val v v'" and r_rpp: "bs_env \<rho> \<rho>''" by (cases b) blast
  from vvp have "is_val v'" by blast
  from this have fv_vp: "FV v' = {}" by auto
  from Cons r_rpp have "closed_env \<rho>''" by blast
  from this rp fv_vp show ?case by blast
qed

lemma psubst_fv: "closed_env \<rho> \<Longrightarrow> FV (psubst \<rho> e) = FV e - sdom \<rho>"
proof (induction e arbitrary: \<rho>)
  case (EVar x)
  then show ?case
    apply (simp add: closed_env_def)
    apply (cases "x \<in> sdom \<rho>")
     apply (erule_tac x=x in allE)
     apply (erule impE) apply blast apply (simp add: sdom_def) apply clarify
     apply force
    apply (simp add: sdom_def)
    apply (cases "lookup \<rho> x")
     apply force
    apply force
    done
next
  case (ELam x e)
  from ELam have "closed_env ((x, EVar x) # \<rho>)" by (simp add: closed_env_def sdom_def)
  from this ELam show ?case by auto
qed fastforce+

lemma big_small_step:
  assumes ev: "\<rho> \<turnstile> e \<Down> w" and r_rp: "bs_env \<rho> \<rho>'" and fv_e: "FV e \<subseteq> set (map fst \<rho>)"
  shows "\<exists> v. psubst \<rho>' e \<longrightarrow>* v \<and> is_val v \<and> bs_val w v"
  using ev r_rp fv_e
proof (induction arbitrary: \<rho>' rule: eval.induct)
  case (eval_nat \<rho> n \<rho>')
  then show ?case by (rule_tac x="ENat n" in exI) auto
next
  case (eval_var \<rho> x w \<rho>')
  from eval_var obtain v where lx: "lookup \<rho>' x = Some v" and
    vv: "is_val v" and w_v: "bs_val w v" using lookup_bs_env by blast
  from lx vv w_v show ?case by (rule_tac x=v in exI) auto
next
  case (eval_lam \<rho> x e \<rho>')
  from eval_lam(1) have dom_eq: "set (map fst \<rho>) = sdom \<rho>'" using bs_env_dom by blast
  from eval_lam(1) have "closed_env ((x,EVar x)#\<rho>')" using bs_env_closed closed_env_def by auto
  from this psubst_fv have "FV (psubst ((x,EVar x)#\<rho>') e) = FV e - sdom ((x,EVar x)#\<rho>')" by blast
  from this eval_lam(2) dom_eq
  have fv_lam: "FV (ELam x (psubst ((x,EVar x)#\<rho>') e)) = {}" by auto
  from fv_lam eval_lam have 1: "bs_val (BClos x e \<rho>) (ELam x (psubst ((x, EVar x) # \<rho>') e))" by auto
  from this eval_lam fv_lam show ?case
    by (rule_tac x="ELam x (psubst ((x,EVar x)#\<rho>') e)" in exI) auto
next
  case (eval_app \<rho> e1 x e \<rho>' e2 arg v  \<rho>'')
  from eval_app(8) have "FV e1 \<subseteq> set (map fst \<rho>)" by auto
  from this eval_app(7) eval_app(4)[of \<rho>''] obtain v1 where e1_v1: "psubst \<rho>'' e1 \<longrightarrow>* v1" and
    vv1: "is_val v1" and clos_v1: "bs_val (BClos x e \<rho>') v1" by (simp, blast)
  from eval_app(8) have "FV e2 \<subseteq> set (map fst \<rho>)" by auto
  from this eval_app(5) eval_app(7) obtain v2 where e2_v2: "psubst \<rho>'' e2 \<longrightarrow>* v2" and
    vv2: "is_val v2" and arg_v2: "bs_val arg v2" by blast
  from vv2 have fv_v2: "FV v2 = {}" by auto
  from clos_v1 obtain \<rho>2 where rpp_r2: "bs_env \<rho>' \<rho>2" and fv_v1: "FV v1 = {}" and
    v1_lam: "v1 = ELam x (psubst ((x,EVar x)#\<rho>2) e)" by auto
  let ?r = "((x,v2) # \<rho>2)"
  from rpp_r2 have cr2: "closed_env \<rho>2" using bs_env_closed by auto
  from this have "closed_env ((x,EVar x)#\<rho>2)"  using  closed_env_def sdom_def by auto
  from this have fve: "FV (psubst ((x,EVar x)#\<rho>2) e) = FV e - sdom ((x,EVar x)#\<rho>2)"
    using psubst_fv[of "(x,EVar x)#\<rho>2"] by blast
  let ?r2 = "((x, arg) # \<rho>')"
  from rpp_r2 arg_v2 vv2 have rr: "bs_env ?r2 ?r" by auto
  from rr bs_env_dom have dr2_dr: "set (map fst ?r2) = sdom ?r" by blast
  from fve dr2_dr fv_v1 v1_lam fv_v2 have "FV e \<subseteq> set (map fst ((x, arg) # \<rho>'))" by auto
  from this rr eval_app(6) obtain v3 where e_v3: "psubst ?r e \<longrightarrow>* v3" and
    vv3: "isval v3" and v_v3: "bs_val v v3" by (simp, blast)
  from e1_v1 have 1: "EApp (psubst \<rho>'' e1) (psubst \<rho>'' e2) \<longrightarrow>* EApp v1 (psubst \<rho>'' e2)"
    by (rule app_red_cong1)
  from e2_v2 have 2: "EApp v1 (psubst \<rho>'' e2) \<longrightarrow>* EApp v1 v2"
    by (rule app_red_cong2)
  from vv2 fv_v2 have vv2b: "is_val v2" by auto
  let ?body = "psubst ((x,EVar x)#\<rho>2) e"
  from v1_lam vv2b have 3: "EApp (ELam x ?body) v2 \<longrightarrow>
      subst x v2 (psubst ((x,EVar x)#\<rho>2) e)" using beta[of v2 x "?body"] by simp
  have 4: "subst x v2 (psubst ((x,EVar x)#\<rho>2) e) = psubst ?r e"
    apply (rule subst_psubst) using fv_v2 cr2 by auto
  have 4: "subst x v2 (psubst ((x,EVar x)#\<rho>2) e) = psubst ?r e"
    apply (rule subst_psubst) using fv_v2 cr2 by auto
  from 1 2 have 5: "psubst \<rho>'' (EApp e1 e2) \<longrightarrow>* EApp v1 v2" apply simp
    by (rule multi_step_trans) auto
  from 5 3 4 v1_lam have 6: "psubst \<rho>'' (EApp e1 e2) \<longrightarrow>* psubst ?r e"
    apply simp apply (rule multi_step_trans) apply assumption apply blast done
  from 6 e_v3 have 7: "psubst \<rho>'' (EApp e1 e2) \<longrightarrow>* v3" by (rule multi_step_trans)
  from 7 vv3 v_v3 show ?case by blast
next
  case (eval_prim \<rho> e1 n1 e2 n2 n3 f \<rho>')
  from eval_prim(7) have "FV e1 \<subseteq> set (map fst \<rho>)" by auto
  from this eval_prim obtain v1 where e1_v1: "psubst \<rho>' e1 \<longrightarrow>* v1" and
    n1_v1: "bs_val (BNat n1) v1" by blast
  from n1_v1 have v1: "v1 = ENat n1" by blast

  from eval_prim(7) have "FV e2 \<subseteq> set (map fst \<rho>)" by auto
  from this eval_prim obtain v2 where e2_v2: "psubst \<rho>' e2 \<longrightarrow>* v2" and
    n2_v2: "bs_val (BNat n2) v2" by blast
  from n2_v2 have v2: "v2 = ENat n2" by blast

  from e1_v1 have 1: "EPrim f (psubst \<rho>' e1) (psubst \<rho>' e2) \<longrightarrow>* EPrim f v1 (psubst \<rho>' e2)"
    by (rule prim_red_cong1)
  from e2_v2 have 2: "EPrim f v1 (psubst \<rho>' e2) \<longrightarrow>* EPrim f v1 v2"
    by (rule prim_red_cong2)
  from v1 v2 have 3: "EPrim f v1 v2 \<longrightarrow> ENat (f n1 n2)" by auto
  from 1 2 have 5: "psubst \<rho>' (EPrim f e1 e2) \<longrightarrow>* EPrim f v1 v2" apply simp
    apply (rule multi_step_trans) apply auto done
  from 5 3  have 6: "psubst \<rho>' (EPrim f e1 e2) \<longrightarrow>* ENat (f n1 n2)" apply simp
    apply (rule multi_step_trans) apply assumption apply blast done
  from this eval_prim(3) show ?case apply (rule_tac x="ENat (f n1 n2)" in exI) by auto
next
  case (eval_if0 \<rho> e1 e3 v3 e2 \<rho>')
  from eval_if0(6) have "FV e1 \<subseteq> set (map fst \<rho>)" by auto
  from this eval_if0 obtain v1 where e1_v1: "psubst \<rho>' e1 \<longrightarrow>* v1" and
    n1_v1: "bs_val (BNat 0) v1" by blast
  from n1_v1 have v1: "v1 = ENat 0" by blast
  from eval_if0(6) have "FV e3 \<subseteq> set (map fst \<rho>)" by auto
  from this eval_if0 obtain v3' where e3_v3: "psubst \<rho>' e3 \<longrightarrow>* v3'" and
    v3_v3: "bs_val v3 v3'" by blast

  from e1_v1 have 1: "EIf (psubst \<rho>' e1) (psubst \<rho>' e2) (psubst \<rho>' e3)
    \<longrightarrow>* EIf v1 (psubst \<rho>' e2) (psubst \<rho>' e3)" by (rule if_red_cong1)
  from v1 have 3: "EIf v1 (psubst \<rho>' e2) (psubst \<rho>' e3) \<longrightarrow> (psubst \<rho>' e3)" by auto
  from 1 3 have 5: "psubst \<rho>' (EIf e1 e2 e3) \<longrightarrow>* psubst \<rho>' e3" apply simp
    apply (rule multi_step_trans) apply assumption apply blast done
  from 5 e3_v3 have 6: "psubst \<rho>' (EIf e1 e2 e3) \<longrightarrow>* v3'"
    apply (rule multi_step_trans) done
  from 6 v3_v3 show ?case by blast
next
  case (eval_if1 \<rho> e1 n e2 v2 e3 \<rho>')
  from eval_if1 have "FV e1 \<subseteq> set (map fst \<rho>)" by auto
  from this eval_if1 obtain v1 where e1_v1: "psubst \<rho>' e1 \<longrightarrow>* v1" and
    n1_v1: "bs_val (BNat n) v1" and nz: "n \<noteq> 0" apply auto apply blast done
  from n1_v1 have v1: "v1 = ENat n" by blast
  from eval_if1 have "FV e2 \<subseteq> set (map fst \<rho>)" by auto
  from this eval_if1 obtain v2' where e2_v2: "psubst \<rho>' e2 \<longrightarrow>* v2'" and
    v2_v2: "bs_val v2 v2'" by blast
  from e1_v1 have 1: "EIf (psubst \<rho>' e1) (psubst \<rho>' e2) (psubst \<rho>' e3)
    \<longrightarrow>* EIf v1 (psubst \<rho>' e2) (psubst \<rho>' e3)" by (rule if_red_cong1)
  from v1 nz have 3: "EIf v1 (psubst \<rho>' e2) (psubst \<rho>' e3) \<longrightarrow> (psubst \<rho>' e2)" by auto
  from 1 3 have 5: "psubst \<rho>' (EIf e1 e2 e3) \<longrightarrow>* psubst \<rho>' e2" apply simp
    apply (rule multi_step_trans) apply assumption apply blast done
  from 5 e2_v2 have 6: "psubst \<rho>' (EIf e1 e2 e3) \<longrightarrow>* v2'"
    by (rule multi_step_trans)
  from 6 v2_v2 show ?case by blast
qed

lemma psubst_id: "FV e \<inter> sdom \<rho> = {} \<Longrightarrow> psubst \<rho> e = e"
proof (induction e arbitrary: \<rho>)
  case (EVar x)
  then show ?case by (cases "lookup \<rho> x") (auto simp: sdom_def)
next
  case (ENat x \<rho>)
  from ENat have "sdom ((x,EVar x)#\<rho>) = sdom \<rho> - {x}" by simp
  with ENat show ?case by auto
next
  case (ELam x e)
  from ELam have "FV e \<inter> sdom ((x,EVar x)#\<rho>) = {}" by auto
  with ELam show ?case by auto
qed fastforce+

fun bs_observe :: "bval \<Rightarrow> obs \<Rightarrow> bool" where
  "bs_observe (BNat n) (ONat n') = (n = n')" |
  "bs_observe (BClos x e \<rho>) OFun = True" |
  "bs_observe e ob = False"

theorem sound_wrt_small_step:
  assumes e_v: "[] \<turnstile> e \<Down> v" and fv_e: "FV e = {}"
  shows "\<exists> v' ob. e \<longrightarrow>* v' \<and> isval v' \<and> observe v' ob
    \<and> bs_observe v ob"
proof -
  have 1: "bs_env [] []" by blast
  from fv_e have 2: "FV e \<subseteq> set (map fst [])" by simp
  from e_v 1 2 big_small_step obtain v' where 3: "psubst [] e \<longrightarrow>* v'" and 4: "is_val v'" and
    5: "bs_val v v'" by blast
  have "psubst [] e = e" using psubst_id sdom_def apply auto done
  from this 3 4 5 show ?thesis apply (rule_tac x=v' in exI) apply simp
    apply (case_tac v)
     apply simp apply clarify apply simp
       apply (rename_tac n) apply (rule_tac x="ONat n" in exI) apply force
     apply (rule_tac x=OFun in exI) apply force done
qed

subsection "Big-step semantics is deterministic"

theorem big_step_fun:
  assumes ev: "\<rho> \<turnstile> e \<Down> v" and evp: "\<rho> \<turnstile> e \<Down> v'" shows "v = v'"
  using ev evp
proof (induction arbitrary: v')
  case (eval_app \<rho> e1 x e \<rho>' e2 arg v)
  from eval_app(7) obtain x' e' \<rho>'' arg' where e1_cl: "\<rho> \<turnstile> e1 \<Down> BClos x' e' \<rho>''" and
    e2_argp: "\<rho> \<turnstile> e2 \<Down> arg'" and e_vp: "(x', arg') # \<rho>'' \<turnstile> e' \<Down> v'" by blast
  from eval_app(4) e1_cl have 1: "BClos x e \<rho>' = BClos x' e' \<rho>''" by simp
  from eval_app(5) e2_argp have 2: "arg = arg'" by simp
  from eval_app(6) e_vp 1 2 show ?case by simp
next
  case (eval_if0 \<rho> e1 e3 v3 e2)
  from eval_if0(5)
  show ?case
  proof (rule eval_if_inv)
    assume "\<rho> \<turnstile> e3 \<Down> v'" with eval_if0(4) show ?thesis by simp
  next
    fix n assume "\<rho> \<turnstile> e1 \<Down> BNat n" and nz: "n > 0"
    with eval_if0(3) have "False" by auto thus ?thesis ..
  qed
next
  case (eval_if1 \<rho> e1 n e2 v2 e3)
  then show ?case by blast
qed fastforce+

end