(*  Author:     Jacques D. Fleuriot, University of Edinburgh
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004

    Replaced by ~~/src/HOL/Multivariate_Analysis/Real_Integral.thy .
*)

section{*Theory of Integration on real intervals*}

theory Gauge_Integration
imports Complex_Main
begin

text {*

\textbf{Attention}: This theory defines the Integration on real
intervals.  This is just a example theory for historical / expository interests.
A better replacement is found in the Multivariate Analysis library. This defines
the gauge integral on real vector spaces and in the Real Integral theory
is a specialization to the integral on arbitrary real intervals.  The
Multivariate Analysis package also provides a better support for analysis on
integrals.

*}

text{*We follow John Harrison in formalizing the Gauge integral.*}

subsection {* Gauges *}

definition
  gauge :: "[real set, real => real] => bool" where
  "gauge E g = (\<forall>x\<in>E. 0 < g(x))"

subsection {* Gauge-fine divisions *}

inductive
  fine :: "[real \<Rightarrow> real, real \<times> real, (real \<times> real \<times> real) list] \<Rightarrow> bool"
for
  \<delta> :: "real \<Rightarrow> real"
where
  fine_Nil:
    "fine \<delta> (a, a) []"
| fine_Cons:
    "\<lbrakk>fine \<delta> (b, c) D; a < b; a \<le> x; x \<le> b; b - a < \<delta> x\<rbrakk>
      \<Longrightarrow> fine \<delta> (a, c) ((a, x, b) # D)"

lemmas fine_induct [induct set: fine] =
  fine.induct [of "\<delta>" "(a,b)" "D" "split P", unfolded split_conv] for \<delta> a b D P

lemma fine_single:
  "\<lbrakk>a < b; a \<le> x; x \<le> b; b - a < \<delta> x\<rbrakk> \<Longrightarrow> fine \<delta> (a, b) [(a, x, b)]"
by (rule fine_Cons [OF fine_Nil])

lemma fine_append:
  "\<lbrakk>fine \<delta> (a, b) D; fine \<delta> (b, c) D'\<rbrakk> \<Longrightarrow> fine \<delta> (a, c) (D @ D')"
by (induct set: fine, simp, simp add: fine_Cons)

lemma fine_imp_le: "fine \<delta> (a, b) D \<Longrightarrow> a \<le> b"
by (induct set: fine, simp_all)

lemma nonempty_fine_imp_less: "\<lbrakk>fine \<delta> (a, b) D; D \<noteq> []\<rbrakk> \<Longrightarrow> a < b"
apply (induct set: fine, simp)
apply (drule fine_imp_le, simp)
done

lemma fine_Nil_iff: "fine \<delta> (a, b) [] \<longleftrightarrow> a = b"
by (auto elim: fine.cases intro: fine.intros)

lemma fine_same_iff: "fine \<delta> (a, a) D \<longleftrightarrow> D = []"
proof
  assume "fine \<delta> (a, a) D" thus "D = []"
    by (metis nonempty_fine_imp_less less_irrefl)
next
  assume "D = []" thus "fine \<delta> (a, a) D"
    by (simp add: fine_Nil)
qed

lemma empty_fine_imp_eq: "\<lbrakk>fine \<delta> (a, b) D; D = []\<rbrakk> \<Longrightarrow> a = b"
by (simp add: fine_Nil_iff)

lemma mem_fine:
  "\<lbrakk>fine \<delta> (a, b) D; (u, x, v) \<in> set D\<rbrakk> \<Longrightarrow> u < v \<and> u \<le> x \<and> x \<le> v"
by (induct set: fine, simp, force)

lemma mem_fine2: "\<lbrakk>fine \<delta> (a, b) D; (u, z, v) \<in> set D\<rbrakk> \<Longrightarrow> a \<le> u \<and> v \<le> b"
apply (induct arbitrary: z u v set: fine, auto)
apply (simp add: fine_imp_le)
apply (erule order_trans [OF less_imp_le], simp)
done

lemma mem_fine3: "\<lbrakk>fine \<delta> (a, b) D; (u, z, v) \<in> set D\<rbrakk> \<Longrightarrow> v - u < \<delta> z"
by (induct arbitrary: z u v set: fine) auto

lemma BOLZANO:
  fixes P :: "real \<Rightarrow> real \<Rightarrow> bool"
  assumes 1: "a \<le> b"
  assumes 2: "\<And>a b c. \<lbrakk>P a b; P b c; a \<le> b; b \<le> c\<rbrakk> \<Longrightarrow> P a c"
  assumes 3: "\<And>x. \<exists>d>0. \<forall>a b. a \<le> x & x \<le> b & (b-a) < d \<longrightarrow> P a b"
  shows "P a b"
  using 1 2 3 by (rule Bolzano)

text{*We can always find a division that is fine wrt any gauge*}

lemma fine_exists:
  assumes "a \<le> b" and "gauge {a..b} \<delta>" shows "\<exists>D. fine \<delta> (a, b) D"
proof -
  {
    fix u v :: real assume "u \<le> v"
    have "a \<le> u \<Longrightarrow> v \<le> b \<Longrightarrow> \<exists>D. fine \<delta> (u, v) D"
      apply (induct u v rule: BOLZANO, rule `u \<le> v`)
       apply (simp, fast intro: fine_append)
      apply (case_tac "a \<le> x \<and> x \<le> b")
       apply (rule_tac x="\<delta> x" in exI)
       apply (rule conjI)
        apply (simp add: `gauge {a..b} \<delta>` [unfolded gauge_def])
       apply (clarify, rename_tac u v)
       apply (case_tac "u = v")
        apply (fast intro: fine_Nil)
       apply (subgoal_tac "u < v", fast intro: fine_single, simp)
      apply (rule_tac x="1" in exI, clarsimp)
      done
  }
  with `a \<le> b` show ?thesis by auto
qed

lemma fine_covers_all:
  assumes "fine \<delta> (a, c) D" and "a < x" and "x \<le> c"
  shows "\<exists> N < length D. \<forall> d t e. D ! N = (d,t,e) \<longrightarrow> d < x \<and> x \<le> e"
  using assms
proof (induct set: fine)
  case (2 b c D a t)
  thus ?case
  proof (cases "b < x")
    case True
    with 2 obtain N where *: "N < length D"
      and **: "\<And> d t e. D ! N = (d,t,e) \<Longrightarrow> d < x \<and> x \<le> e" by auto
    hence "Suc N < length ((a,t,b)#D) \<and>
           (\<forall> d t' e. ((a,t,b)#D) ! Suc N = (d,t',e) \<longrightarrow> d < x \<and> x \<le> e)" by auto
    thus ?thesis by auto
  next
    case False with 2
    have "0 < length ((a,t,b)#D) \<and>
           (\<forall> d t' e. ((a,t,b)#D) ! 0 = (d,t',e) \<longrightarrow> d < x \<and> x \<le> e)" by auto
    thus ?thesis by auto
  qed
qed auto

lemma fine_append_split:
  assumes "fine \<delta> (a,b) D" and "D2 \<noteq> []" and "D = D1 @ D2"
  shows "fine \<delta> (a,fst (hd D2)) D1" (is "?fine1")
  and "fine \<delta> (fst (hd D2), b) D2" (is "?fine2")
proof -
  from assms
  have "?fine1 \<and> ?fine2"
  proof (induct arbitrary: D1 D2)
    case (2 b c D a' x D1 D2)
    note induct = this

    thus ?case
    proof (cases D1)
      case Nil
      hence "fst (hd D2) = a'" using 2 by auto
      with fine_Cons[OF `fine \<delta> (b,c) D` induct(3,4,5)] Nil induct
      show ?thesis by (auto intro: fine_Nil)
    next
      case (Cons d1 D1')
      with induct(2)[OF `D2 \<noteq> []`, of D1'] induct(8)
      have "fine \<delta> (b, fst (hd D2)) D1'" and "fine \<delta> (fst (hd D2), c) D2" and
        "d1 = (a', x, b)" by auto
      with fine_Cons[OF this(1) induct(3,4,5), OF induct(6)] Cons
      show ?thesis by auto
    qed
  qed auto
  thus ?fine1 and ?fine2 by auto
qed

lemma fine_\<delta>_expand:
  assumes "fine \<delta> (a,b) D"
  and "\<And>x. a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> \<delta> x \<le> \<delta>' x"
  shows "fine \<delta>' (a,b) D"
using assms proof induct
  case 1 show ?case by (rule fine_Nil)
next
  case (2 b c D a x)
  show ?case
  proof (rule fine_Cons)
    show "fine \<delta>' (b,c) D" using 2 by auto
    from fine_imp_le[OF 2(1)] 2(6) `x \<le> b`
    show "b - a < \<delta>' x"
      using 2(7)[OF `a \<le> x`] by auto
  qed (auto simp add: 2)
qed

lemma fine_single_boundaries:
  assumes "fine \<delta> (a,b) D" and "D = [(d, t, e)]"
  shows "a = d \<and> b = e"
using assms proof induct
  case (2 b c  D a x)
  hence "D = []" and "a = d" and "b = e" by auto
  moreover
  from `fine \<delta> (b,c) D` `D = []` have "b = c"
    by (rule empty_fine_imp_eq)
  ultimately show ?case by simp
qed auto

lemma fine_listsum_eq_diff:
  fixes f :: "real \<Rightarrow> real"
  shows "fine \<delta> (a, b) D \<Longrightarrow> (\<Sum>(u, x, v)\<leftarrow>D. f v - f u) = f b - f a"
by (induct set: fine) simp_all

text{*Lemmas about combining gauges*}

lemma gauge_min:
     "[| gauge(E) g1; gauge(E) g2 |]
      ==> gauge(E) (%x. min (g1(x)) (g2(x)))"
by (simp add: gauge_def)

lemma fine_min:
      "fine (%x. min (g1(x)) (g2(x))) (a,b) D
       ==> fine(g1) (a,b) D & fine(g2) (a,b) D"
apply (erule fine.induct)
apply (simp add: fine_Nil)
apply (simp add: fine_Cons)
done

subsection {* Riemann sum *}

definition
  rsum :: "[(real \<times> real \<times> real) list, real \<Rightarrow> real] \<Rightarrow> real" where
  "rsum D f = (\<Sum>(u, x, v)\<leftarrow>D. f x * (v - u))"

lemma rsum_Nil [simp]: "rsum [] f = 0"
unfolding rsum_def by simp

lemma rsum_Cons [simp]: "rsum ((u, x, v) # D) f = f x * (v - u) + rsum D f"
unfolding rsum_def by simp

lemma rsum_zero [simp]: "rsum D (\<lambda>x. 0) = 0"
by (induct D, auto)

lemma rsum_left_distrib: "rsum D f * c = rsum D (\<lambda>x. f x * c)"
by (induct D, auto simp add: algebra_simps)

lemma rsum_right_distrib: "c * rsum D f = rsum D (\<lambda>x. c * f x)"
by (induct D, auto simp add: algebra_simps)

lemma rsum_add: "rsum D (\<lambda>x. f x + g x) =  rsum D f + rsum D g"
by (induct D, auto simp add: algebra_simps)

lemma rsum_append: "rsum (D1 @ D2) f = rsum D1 f + rsum D2 f"
unfolding rsum_def map_append listsum_append ..

subsection {* Gauge integrability (definite) *}

definition
  Integral :: "[(real*real),real=>real,real] => bool" where
  "Integral = (%(a,b) f k. \<forall>e > 0.
                               (\<exists>\<delta>. gauge {a .. b} \<delta> &
                               (\<forall>D. fine \<delta> (a,b) D -->
                                         \<bar>rsum D f - k\<bar> < e)))"

lemma Integral_eq:
  "Integral (a, b) f k \<longleftrightarrow>
    (\<forall>e>0. \<exists>\<delta>. gauge {a..b} \<delta> \<and> (\<forall>D. fine \<delta> (a,b) D \<longrightarrow> \<bar>rsum D f - k\<bar> < e))"
unfolding Integral_def by simp

lemma IntegralI:
  assumes "\<And>e. 0 < e \<Longrightarrow>
    \<exists>\<delta>. gauge {a..b} \<delta> \<and> (\<forall>D. fine \<delta> (a, b) D \<longrightarrow> \<bar>rsum D f - k\<bar> < e)"
  shows "Integral (a, b) f k"
using assms unfolding Integral_def by auto

lemma IntegralE:
  assumes "Integral (a, b) f k" and "0 < e"
  obtains \<delta> where "gauge {a..b} \<delta>" and "\<forall>D. fine \<delta> (a, b) D \<longrightarrow> \<bar>rsum D f - k\<bar> < e"
using assms unfolding Integral_def by auto

lemma Integral_def2:
  "Integral = (%(a,b) f k. \<forall>e>0. (\<exists>\<delta>. gauge {a..b} \<delta> &
                               (\<forall>D. fine \<delta> (a,b) D -->
                                         \<bar>rsum D f - k\<bar> \<le> e)))"
unfolding Integral_def
apply (safe intro!: ext)
apply (fast intro: less_imp_le)
apply (drule_tac x="e/2" in spec)
apply force
done

text{*The integral is unique if it exists*}

lemma Integral_unique:
  assumes le: "a \<le> b"
  assumes 1: "Integral (a, b) f k1"
  assumes 2: "Integral (a, b) f k2"
  shows "k1 = k2"
proof (rule ccontr)
  assume "k1 \<noteq> k2"
  hence e: "0 < \<bar>k1 - k2\<bar> / 2" by simp
  obtain d1 where "gauge {a..b} d1" and
    d1: "\<forall>D. fine d1 (a, b) D \<longrightarrow> \<bar>rsum D f - k1\<bar> < \<bar>k1 - k2\<bar> / 2"
    using 1 e by (rule IntegralE)
  obtain d2 where "gauge {a..b} d2" and
    d2: "\<forall>D. fine d2 (a, b) D \<longrightarrow> \<bar>rsum D f - k2\<bar> < \<bar>k1 - k2\<bar> / 2"
    using 2 e by (rule IntegralE)
  have "gauge {a..b} (\<lambda>x. min (d1 x) (d2 x))"
    using `gauge {a..b} d1` and `gauge {a..b} d2`
    by (rule gauge_min)
  then obtain D where "fine (\<lambda>x. min (d1 x) (d2 x)) (a, b) D"
    using fine_exists [OF le] by fast
  hence "fine d1 (a, b) D" and "fine d2 (a, b) D"
    by (auto dest: fine_min)
  hence "\<bar>rsum D f - k1\<bar> < \<bar>k1 - k2\<bar> / 2" and "\<bar>rsum D f - k2\<bar> < \<bar>k1 - k2\<bar> / 2"
    using d1 d2 by simp_all
  hence "\<bar>rsum D f - k1\<bar> + \<bar>rsum D f - k2\<bar> < \<bar>k1 - k2\<bar> / 2 + \<bar>k1 - k2\<bar> / 2"
    by (rule add_strict_mono)
  thus False by auto
qed

lemma Integral_zero: "Integral(a,a) f 0"
apply (rule IntegralI)
apply (rule_tac x = "\<lambda>x. 1" in exI)
apply (simp add: fine_same_iff gauge_def)
done

lemma Integral_same_iff [simp]: "Integral (a, a) f k \<longleftrightarrow> k = 0"
  by (auto intro: Integral_zero Integral_unique)

lemma Integral_zero_fun: "Integral (a,b) (\<lambda>x. 0) 0"
apply (rule IntegralI)
apply (rule_tac x="\<lambda>x. 1" in exI, simp add: gauge_def)
done

lemma fine_rsum_const: "fine \<delta> (a,b) D \<Longrightarrow> rsum D (\<lambda>x. c) = (c * (b - a))"
unfolding rsum_def
by (induct set: fine, auto simp add: algebra_simps)

lemma Integral_mult_const: "a \<le> b \<Longrightarrow> Integral(a,b) (\<lambda>x. c) (c * (b - a))"
apply (cases "a = b", simp)
apply (rule IntegralI)
apply (rule_tac x = "\<lambda>x. b - a" in exI)
apply (rule conjI, simp add: gauge_def)
apply (clarify)
apply (subst fine_rsum_const, assumption, simp)
done

lemma Integral_eq_diff_bounds: "a \<le> b \<Longrightarrow> Integral(a,b) (\<lambda>x. 1) (b - a)"
  using Integral_mult_const [of a b 1] by simp

lemma Integral_mult:
     "[| a \<le> b; Integral(a,b) f k |] ==> Integral(a,b) (%x. c * f x) (c * k)"
apply (auto simp add: order_le_less)
apply (cases "c = 0", simp add: Integral_zero_fun)
apply (rule IntegralI)
apply (erule_tac e="e / \<bar>c\<bar>" in IntegralE, simp)
apply (rule_tac x="\<delta>" in exI, clarify)
apply (drule_tac x="D" in spec, clarify)
apply (simp add: pos_less_divide_eq abs_mult [symmetric]
                 algebra_simps rsum_right_distrib)
done

lemma Integral_add:
  assumes "Integral (a, b) f x1"
  assumes "Integral (b, c) f x2"
  assumes "a \<le> b" and "b \<le> c"
  shows "Integral (a, c) f (x1 + x2)"
proof (cases "a < b \<and> b < c", rule IntegralI)
  fix \<epsilon> :: real assume "0 < \<epsilon>"
  hence "0 < \<epsilon> / 2" by auto

  assume "a < b \<and> b < c"
  hence "a < b" and "b < c" by auto

  obtain \<delta>1 where \<delta>1_gauge: "gauge {a..b} \<delta>1"
    and I1: "\<And> D. fine \<delta>1 (a,b) D \<Longrightarrow> \<bar> rsum D f - x1 \<bar> < (\<epsilon> / 2)"
    using IntegralE [OF `Integral (a, b) f x1` `0 < \<epsilon>/2`] by auto

  obtain \<delta>2 where \<delta>2_gauge: "gauge {b..c} \<delta>2"
    and I2: "\<And> D. fine \<delta>2 (b,c) D \<Longrightarrow> \<bar> rsum D f - x2 \<bar> < (\<epsilon> / 2)"
    using IntegralE [OF `Integral (b, c) f x2` `0 < \<epsilon>/2`] by auto

  def \<delta> \<equiv> "\<lambda> x. if x < b then min (\<delta>1 x) (b - x)
           else if x = b then min (\<delta>1 b) (\<delta>2 b)
                         else min (\<delta>2 x) (x - b)"

  have "gauge {a..c} \<delta>"
    using \<delta>1_gauge \<delta>2_gauge unfolding \<delta>_def gauge_def by auto

  moreover {
    fix D :: "(real \<times> real \<times> real) list"
    assume fine: "fine \<delta> (a,c) D"
    from fine_covers_all[OF this `a < b` `b \<le> c`]
    obtain N where "N < length D"
      and *: "\<forall> d t e. D ! N = (d, t, e) \<longrightarrow> d < b \<and> b \<le> e"
      by auto
    obtain d t e where D_eq: "D ! N = (d, t, e)" by (cases "D!N", auto)
    with * have "d < b" and "b \<le> e" by auto
    have in_D: "(d, t, e) \<in> set D"
      using D_eq[symmetric] using `N < length D` by auto

    from mem_fine[OF fine in_D]
    have "d < e" and "d \<le> t" and "t \<le> e" by auto

    have "t = b"
    proof (rule ccontr)
      assume "t \<noteq> b"
      with mem_fine3[OF fine in_D] `b \<le> e` `d \<le> t` `t \<le> e` `d < b` \<delta>_def
      show False by (cases "t < b") auto
    qed

    let ?D1 = "take N D"
    let ?D2 = "drop N D"
    def D1 \<equiv> "take N D @ [(d, t, b)]"
    def D2 \<equiv> "(if b = e then [] else [(b, t, e)]) @ drop (Suc N) D"

    from hd_drop_conv_nth[OF `N < length D`]
    have "fst (hd ?D2) = d" using `D ! N = (d, t, e)` by auto
    with fine_append_split[OF _ _ append_take_drop_id[symmetric]]
    have fine1: "fine \<delta> (a,d) ?D1" and fine2: "fine \<delta> (d,c) ?D2"
      using `N < length D` fine by auto

    have "fine \<delta>1 (a,b) D1" unfolding D1_def
    proof (rule fine_append)
      show "fine \<delta>1 (a, d) ?D1"
      proof (rule fine1[THEN fine_\<delta>_expand])
        fix x assume "a \<le> x" "x \<le> d"
        hence "x \<le> b" using `d < b` `x \<le> d` by auto
        thus "\<delta> x \<le> \<delta>1 x" unfolding \<delta>_def by auto
      qed

      have "b - d < \<delta>1 t"
        using mem_fine3[OF fine in_D] \<delta>_def `b \<le> e` `t = b` by auto
      from `d < b` `d \<le> t` `t = b` this
      show "fine \<delta>1 (d, b) [(d, t, b)]" using fine_single by auto
    qed
    note rsum1 = I1[OF this]

    have drop_split: "drop N D = [D ! N] @ drop (Suc N) D"
      using Cons_nth_drop_Suc[OF `N < length D`] by simp

    have fine2: "fine \<delta>2 (e,c) (drop (Suc N) D)"
    proof (cases "drop (Suc N) D = []")
      case True
      note * = fine2[simplified drop_split True D_eq append_Nil2]
      have "e = c" using fine_single_boundaries[OF * refl] by auto
      thus ?thesis unfolding True using fine_Nil by auto
    next
      case False
      note * = fine_append_split[OF fine2 False drop_split]
      from fine_single_boundaries[OF *(1)]
      have "fst (hd (drop (Suc N) D)) = e" using D_eq by auto
      with *(2) have "fine \<delta> (e,c) (drop (Suc N) D)" by auto
      thus ?thesis
      proof (rule fine_\<delta>_expand)
        fix x assume "e \<le> x" and "x \<le> c"
        thus "\<delta> x \<le> \<delta>2 x" using `b \<le> e` unfolding \<delta>_def by auto
      qed
    qed

    have "fine \<delta>2 (b, c) D2"
    proof (cases "e = b")
      case True thus ?thesis using fine2 by (simp add: D1_def D2_def)
    next
      case False
      have "e - b < \<delta>2 b"
        using mem_fine3[OF fine in_D] \<delta>_def `d < b` `t = b` by auto
      with False `t = b` `b \<le> e`
      show ?thesis using D2_def
        by (auto intro!: fine_append[OF _ fine2] fine_single
               simp del: append_Cons)
    qed
    note rsum2 = I2[OF this]

    have "rsum D f = rsum (take N D) f + rsum [D ! N] f + rsum (drop (Suc N) D) f"
      using rsum_append[symmetric] Cons_nth_drop_Suc[OF `N < length D`] by auto
    also have "\<dots> = rsum D1 f + rsum D2 f"
      by (cases "b = e", auto simp add: D1_def D2_def D_eq rsum_append algebra_simps)
    finally have "\<bar>rsum D f - (x1 + x2)\<bar> < \<epsilon>"
      using add_strict_mono[OF rsum1 rsum2] by simp
  }
  ultimately show "\<exists> \<delta>. gauge {a .. c} \<delta> \<and>
    (\<forall>D. fine \<delta> (a,c) D \<longrightarrow> \<bar>rsum D f - (x1 + x2)\<bar> < \<epsilon>)"
    by blast
next
  case False
  hence "a = b \<or> b = c" using `a \<le> b` and `b \<le> c` by auto
  thus ?thesis
  proof (rule disjE)
    assume "a = b" hence "x1 = 0"
      using `Integral (a, b) f x1` by simp
    thus ?thesis using `a = b` `Integral (b, c) f x2` by simp
  next
    assume "b = c" hence "x2 = 0"
      using `Integral (b, c) f x2` by simp
    thus ?thesis using `b = c` `Integral (a, b) f x1` by simp
  qed
qed

text{*Fundamental theorem of calculus (Part I)*}

text{*"Straddle Lemma" : Swartz and Thompson: AMM 95(7) 1988 *}

lemma strad1:
  fixes z x s e :: real
  assumes P: "(\<And>z. z \<noteq> x \<Longrightarrow> \<bar>z - x\<bar> < s \<Longrightarrow> \<bar>(f z - f x) / (z - x) - f' x\<bar> < e / 2)"
  assumes "\<bar>z - x\<bar> < s"
  shows "\<bar>f z - f x - f' x * (z - x)\<bar> \<le> e / 2 * \<bar>z - x\<bar>"
proof (cases "z = x")
  case True then show ?thesis by simp
next
  case False
  then have "inverse (z - x) * (f z - f x - f' x * (z - x)) = (f z - f x) / (z - x) - f' x"
    apply (subst mult.commute)
    apply (simp add: left_diff_distrib)
    apply (simp add: mult.assoc divide_inverse)
    apply (simp add: ring_distribs)
    done
  moreover from False `\<bar>z - x\<bar> < s` have "\<bar>(f z - f x) / (z - x) - f' x\<bar> < e / 2"
    by (rule P)
  ultimately have "\<bar>inverse (z - x)\<bar> * (\<bar>f z - f x - f' x * (z - x)\<bar> * 2)
    \<le> \<bar>inverse (z - x)\<bar> * (e * \<bar>z - x\<bar>)"
    using False by (simp del: abs_inverse add: abs_mult [symmetric] ac_simps)
  with False have "\<bar>f z - f x - f' x * (z - x)\<bar> * 2 \<le> e * \<bar>z - x\<bar>"
    by simp
  then show ?thesis by simp
qed

lemma lemma_straddle:
  assumes f': "\<forall>x. a \<le> x & x \<le> b --> DERIV f x :> f'(x)" and "0 < e"
  shows "\<exists>g. gauge {a..b} g &
                (\<forall>x u v. a \<le> u & u \<le> x & x \<le> v & v \<le> b & (v - u) < g(x)
                  --> \<bar>(f(v) - f(u)) - (f'(x) * (v - u))\<bar> \<le> e * (v - u))"
proof -
  have "\<forall>x\<in>{a..b}.
        (\<exists>d > 0. \<forall>u v. u \<le> x & x \<le> v & (v - u) < d -->
                       \<bar>(f(v) - f(u)) - (f'(x) * (v - u))\<bar> \<le> e * (v - u))"
  proof (clarsimp)
    fix x :: real assume "a \<le> x" and "x \<le> b"
    with f' have "DERIV f x :> f'(x)" by simp
    then have "\<forall>r>0. \<exists>s>0. \<forall>z. z \<noteq> x \<and> \<bar>z - x\<bar> < s \<longrightarrow> \<bar>(f z - f x) / (z - x) - f' x\<bar> < r"
      by (simp add: DERIV_iff2 LIM_eq)
    with `0 < e` obtain s
    where "\<And>z. z \<noteq> x \<Longrightarrow> \<bar>z - x\<bar> < s \<Longrightarrow> \<bar>(f z - f x) / (z - x) - f' x\<bar> < e/2" and "0 < s"
      by (drule_tac x="e/2" in spec, auto)
    with strad1 [of x s f f' e] have strad:
        "\<And>z. \<bar>z - x\<bar> < s \<Longrightarrow> \<bar>f z - f x - f' x * (z - x)\<bar> \<le> e/2 * \<bar>z - x\<bar>"
      by auto
    show "\<exists>d>0. \<forall>u v. u \<le> x \<and> x \<le> v \<and> v - u < d \<longrightarrow> \<bar>f v - f u - f' x * (v - u)\<bar> \<le> e * (v - u)"
    proof (safe intro!: exI)
      show "0 < s" by fact
    next
      fix u v :: real assume "u \<le> x" and "x \<le> v" and "v - u < s"
      have "\<bar>f v - f u - f' x * (v - u)\<bar> =
            \<bar>(f v - f x - f' x * (v - x)) + (f x - f u - f' x * (x - u))\<bar>"
        by (simp add: right_diff_distrib)
      also have "\<dots> \<le> \<bar>f v - f x - f' x * (v - x)\<bar> + \<bar>f x - f u - f' x * (x - u)\<bar>"
        by (rule abs_triangle_ineq)
      also have "\<dots> = \<bar>f v - f x - f' x * (v - x)\<bar> + \<bar>f u - f x - f' x * (u - x)\<bar>"
        by (simp add: right_diff_distrib)
      also have "\<dots> \<le> (e/2) * \<bar>v - x\<bar> + (e/2) * \<bar>u - x\<bar>"
        using `u \<le> x` `x \<le> v` `v - u < s` by (intro add_mono strad, simp_all)
      also have "\<dots> \<le> e * (v - u) / 2 + e * (v - u) / 2"
        using `u \<le> x` `x \<le> v` `0 < e` by (intro add_mono, simp_all)
      also have "\<dots> = e * (v - u)"
        by simp
      finally show "\<bar>f v - f u - f' x * (v - u)\<bar> \<le> e * (v - u)" .
    qed
  qed
  thus ?thesis
    by (simp add: gauge_def) (drule bchoice, auto)
qed

lemma fundamental_theorem_of_calculus:
  assumes "a \<le> b"
  assumes f': "\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> DERIV f x :> f'(x)"
  shows "Integral (a, b) f' (f(b) - f(a))"
proof (cases "a = b")
  assume "a = b" thus ?thesis by simp
next
  assume "a \<noteq> b" with `a \<le> b` have "a < b" by simp
  show ?thesis
  proof (simp add: Integral_def2, clarify)
    fix e :: real assume "0 < e"
    with `a < b` have "0 < e / (b - a)" by simp

    from lemma_straddle [OF f' this]
    obtain \<delta> where "gauge {a..b} \<delta>"
      and \<delta>: "\<And>x u v. \<lbrakk>a \<le> u; u \<le> x; x \<le> v; v \<le> b; v - u < \<delta> x\<rbrakk> \<Longrightarrow>
           \<bar>f v - f u - f' x * (v - u)\<bar> \<le> e * (v - u) / (b - a)" by auto

    have "\<forall>D. fine \<delta> (a, b) D \<longrightarrow> \<bar>rsum D f' - (f b - f a)\<bar> \<le> e"
    proof (clarify)
      fix D assume D: "fine \<delta> (a, b) D"
      hence "(\<Sum>(u, x, v)\<leftarrow>D. f v - f u) = f b - f a"
        by (rule fine_listsum_eq_diff)
      hence "\<bar>rsum D f' - (f b - f a)\<bar> = \<bar>rsum D f' - (\<Sum>(u, x, v)\<leftarrow>D. f v - f u)\<bar>"
        by simp
      also have "\<dots> = \<bar>(\<Sum>(u, x, v)\<leftarrow>D. f v - f u) - rsum D f'\<bar>"
        by (rule abs_minus_commute)
      also have "\<dots> = \<bar>\<Sum>(u, x, v)\<leftarrow>D. (f v - f u) - f' x * (v - u)\<bar>"
        by (simp only: rsum_def listsum_subtractf split_def)
      also have "\<dots> \<le> (\<Sum>(u, x, v)\<leftarrow>D. \<bar>(f v - f u) - f' x * (v - u)\<bar>)"
        by (rule ord_le_eq_trans [OF listsum_abs], simp add: o_def split_def)
      also have "\<dots> \<le> (\<Sum>(u, x, v)\<leftarrow>D. (e / (b - a)) * (v - u))"
        apply (rule listsum_mono, clarify, rename_tac u x v)
        using D apply (simp add: \<delta> mem_fine mem_fine2 mem_fine3)
        done
      also have "\<dots> = e"
        using fine_listsum_eq_diff [OF D, where f="\<lambda>x. x"]
        unfolding split_def listsum_const_mult
        using `a < b` by simp
      finally show "\<bar>rsum D f' - (f b - f a)\<bar> \<le> e" .
    qed

    with `gauge {a..b} \<delta>`
    show "\<exists>\<delta>. gauge {a..b} \<delta> \<and> (\<forall>D. fine \<delta> (a, b) D \<longrightarrow> \<bar>rsum D f' - (f b - f a)\<bar> \<le> e)"
      by auto
  qed
qed

end


(*  Title:      ZF/Induct/Term.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Terms over an alphabet\<close>

theory Term imports ZF begin

text \<open>
  Illustrates the list functor (essentially the same type as in \<open>Trees_Forest\<close>).
\<close>

consts
  "term" :: "i => i"

datatype "term(A)" = Apply ("a \<in> A", "l \<in> list(term(A))")
  monos list_mono
  type_elims list_univ [THEN subsetD, elim_format]

declare Apply [TC]

definition
  term_rec :: "[i, [i, i, i] => i] => i"  where
  "term_rec(t,d) ==
    Vrec(t, \<lambda>t g. term_case(\<lambda>x zs. d(x, zs, map(\<lambda>z. g`z, zs)), t))"

definition
  term_map :: "[i => i, i] => i"  where
  "term_map(f,t) == term_rec(t, \<lambda>x zs rs. Apply(f(x), rs))"

definition
  term_size :: "i => i"  where
  "term_size(t) == term_rec(t, \<lambda>x zs rs. succ(list_add(rs)))"

definition
  reflect :: "i => i"  where
  "reflect(t) == term_rec(t, \<lambda>x zs rs. Apply(x, rev(rs)))"

definition
  preorder :: "i => i"  where
  "preorder(t) == term_rec(t, \<lambda>x zs rs. Cons(x, flat(rs)))"

definition
  postorder :: "i => i"  where
  "postorder(t) == term_rec(t, \<lambda>x zs rs. flat(rs) @ [x])"

lemma term_unfold: "term(A) = A * list(term(A))"
  by (fast intro!: term.intros [unfolded term.con_defs]
    elim: term.cases [unfolded term.con_defs])

lemma term_induct2:
  "[| t \<in> term(A);
      !!x.      [| x \<in> A |] ==> P(Apply(x,Nil));
      !!x z zs. [| x \<in> A;  z \<in> term(A);  zs: list(term(A));  P(Apply(x,zs))
                |] ==> P(Apply(x, Cons(z,zs)))
     |] ==> P(t)"
  \<comment> \<open>Induction on @{term "term(A)"} followed by induction on @{term list}.\<close>
  apply (induct_tac t)
  apply (erule list.induct)
   apply (auto dest: list_CollectD)
  done

lemma term_induct_eqn [consumes 1, case_names Apply]:
  "[| t \<in> term(A);
      !!x zs. [| x \<in> A;  zs: list(term(A));  map(f,zs) = map(g,zs) |] ==>
              f(Apply(x,zs)) = g(Apply(x,zs))
   |] ==> f(t) = g(t)"
  \<comment> \<open>Induction on @{term "term(A)"} to prove an equation.\<close>
  apply (induct_tac t)
  apply (auto dest: map_list_Collect list_CollectD)
  done

text \<open>
  \medskip Lemmas to justify using @{term "term"} in other recursive
  type definitions.
\<close>

lemma term_mono: "A \<subseteq> B ==> term(A) \<subseteq> term(B)"
  apply (unfold term.defs)
  apply (rule lfp_mono)
    apply (rule term.bnd_mono)+
  apply (rule univ_mono basic_monos| assumption)+
  done

lemma term_univ: "term(univ(A)) \<subseteq> univ(A)"
  \<comment> \<open>Easily provable by induction also\<close>
  apply (unfold term.defs term.con_defs)
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] A_subset_univ [THEN univ_mono])
  apply safe
  apply (assumption | rule Pair_in_univ list_univ [THEN subsetD])+
  done

lemma term_subset_univ: "A \<subseteq> univ(B) ==> term(A) \<subseteq> univ(B)"
  apply (rule subset_trans)
   apply (erule term_mono)
  apply (rule term_univ)
  done

lemma term_into_univ: "[| t \<in> term(A);  A \<subseteq> univ(B) |] ==> t \<in> univ(B)"
  by (rule term_subset_univ [THEN subsetD])

text \<open>
  \medskip \<open>term_rec\<close> -- by \<open>Vset\<close> recursion.
\<close>

lemma map_lemma: "[| l \<in> list(A);  Ord(i);  rank(l)<i |]
    ==> map(\<lambda>z. (\<lambda>x \<in> Vset(i).h(x)) ` z, l) = map(h,l)"
  \<comment> \<open>@{term map} works correctly on the underlying list of terms.\<close>
  apply (induct set: list)
   apply simp
  apply (subgoal_tac "rank (a) <i & rank (l) < i")
   apply (simp add: rank_of_Ord)
  apply (simp add: list.con_defs)
  apply (blast dest: rank_rls [THEN lt_trans])
  done

lemma term_rec [simp]: "ts \<in> list(A) ==>
  term_rec(Apply(a,ts), d) = d(a, ts, map (\<lambda>z. term_rec(z,d), ts))"
  \<comment> \<open>Typing premise is necessary to invoke \<open>map_lemma\<close>.\<close>
  apply (rule term_rec_def [THEN def_Vrec, THEN trans])
  apply (unfold term.con_defs)
  apply (simp add: rank_pair2 map_lemma)
  done

lemma term_rec_type:
  assumes t: "t \<in> term(A)"
    and a: "!!x zs r. [| x \<in> A;  zs: list(term(A));
                   r \<in> list(\<Union>t \<in> term(A). C(t)) |]
                ==> d(x, zs, r): C(Apply(x,zs))"
  shows "term_rec(t,d) \<in> C(t)"
  \<comment> \<open>Slightly odd typing condition on \<open>r\<close> in the second premise!\<close>
  using t
  apply induct
  apply (frule list_CollectD)
  apply (subst term_rec)
   apply (assumption | rule a)+
  apply (erule list.induct)
   apply auto
  done

lemma def_term_rec:
  "[| !!t. j(t)==term_rec(t,d);  ts: list(A) |] ==>
    j(Apply(a,ts)) = d(a, ts, map(\<lambda>Z. j(Z), ts))"
  apply (simp only:)
  apply (erule term_rec)
  done

lemma term_rec_simple_type [TC]:
  "[| t \<in> term(A);
      !!x zs r. [| x \<in> A;  zs: list(term(A));  r \<in> list(C) |]
                ==> d(x, zs, r): C
   |] ==> term_rec(t,d) \<in> C"
  apply (erule term_rec_type)
  apply (drule subset_refl [THEN UN_least, THEN list_mono, THEN subsetD])
  apply simp
  done

text \<open>
  \medskip @{term term_map}.
\<close>

lemma term_map [simp]:
  "ts \<in> list(A) ==>
    term_map(f, Apply(a, ts)) = Apply(f(a), map(term_map(f), ts))"
  by (rule term_map_def [THEN def_term_rec])

lemma term_map_type [TC]:
    "[| t \<in> term(A);  !!x. x \<in> A ==> f(x): B |] ==> term_map(f,t) \<in> term(B)"
  apply (unfold term_map_def)
  apply (erule term_rec_simple_type)
  apply fast
  done

lemma term_map_type2 [TC]:
    "t \<in> term(A) ==> term_map(f,t) \<in> term({f(u). u \<in> A})"
  apply (erule term_map_type)
  apply (erule RepFunI)
  done

text \<open>
  \medskip @{term term_size}.
\<close>

lemma term_size [simp]:
    "ts \<in> list(A) ==> term_size(Apply(a, ts)) = succ(list_add(map(term_size, ts)))"
  by (rule term_size_def [THEN def_term_rec])

lemma term_size_type [TC]: "t \<in> term(A) ==> term_size(t) \<in> nat"
  by (auto simp add: term_size_def)

text \<open>
  \medskip \<open>reflect\<close>.
\<close>

lemma reflect [simp]:
    "ts \<in> list(A) ==> reflect(Apply(a, ts)) = Apply(a, rev(map(reflect, ts)))"
  by (rule reflect_def [THEN def_term_rec])

lemma reflect_type [TC]: "t \<in> term(A) ==> reflect(t) \<in> term(A)"
  by (auto simp add: reflect_def)

text \<open>
  \medskip \<open>preorder\<close>.
\<close>

lemma preorder [simp]:
    "ts \<in> list(A) ==> preorder(Apply(a, ts)) = Cons(a, flat(map(preorder, ts)))"
  by (rule preorder_def [THEN def_term_rec])

lemma preorder_type [TC]: "t \<in> term(A) ==> preorder(t) \<in> list(A)"
  by (simp add: preorder_def)

text \<open>
  \medskip \<open>postorder\<close>.
\<close>

lemma postorder [simp]:
    "ts \<in> list(A) ==> postorder(Apply(a, ts)) = flat(map(postorder, ts)) @ [a]"
  by (rule postorder_def [THEN def_term_rec])

lemma postorder_type [TC]: "t \<in> term(A) ==> postorder(t) \<in> list(A)"
  by (simp add: postorder_def)

text \<open>
  \medskip Theorems about \<open>term_map\<close>.
\<close>

declare map_compose [simp]

lemma term_map_ident: "t \<in> term(A) ==> term_map(\<lambda>u. u, t) = t"
  by (induct rule: term_induct_eqn) simp

lemma term_map_compose:
    "t \<in> term(A) ==> term_map(f, term_map(g,t)) = term_map(\<lambda>u. f(g(u)), t)"
  by (induct rule: term_induct_eqn) simp

lemma term_map_reflect:
    "t \<in> term(A) ==> term_map(f, reflect(t)) = reflect(term_map(f,t))"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib [symmetric])

text \<open>
  \medskip Theorems about \<open>term_size\<close>.
\<close>

lemma term_size_term_map: "t \<in> term(A) ==> term_size(term_map(f,t)) = term_size(t)"
  by (induct rule: term_induct_eqn) simp

lemma term_size_reflect: "t \<in> term(A) ==> term_size(reflect(t)) = term_size(t)"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib [symmetric] list_add_rev)

lemma term_size_length: "t \<in> term(A) ==> term_size(t) = length(preorder(t))"
  by (induct rule: term_induct_eqn) (simp add: length_flat)

text \<open>
  \medskip Theorems about \<open>reflect\<close>.
\<close>

lemma reflect_reflect_ident: "t \<in> term(A) ==> reflect(reflect(t)) = t"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib)

text \<open>
  \medskip Theorems about preorder.
\<close>

lemma preorder_term_map:
    "t \<in> term(A) ==> preorder(term_map(f,t)) = map(f, preorder(t))"
  by (induct rule: term_induct_eqn) (simp add: map_flat)

lemma preorder_reflect_eq_rev_postorder:
    "t \<in> term(A) ==> preorder(reflect(t)) = rev(postorder(t))"
  by (induct rule: term_induct_eqn)
    (simp add: rev_app_distrib rev_flat rev_map_distrib [symmetric])

end


chapter \<open> Suppes' Theorem \label{sec:suppes-theorem} \<close>

theory Suppes_Theorem
  imports Probability_Logic
begin

no_notation FuncSet.funcset (infixr "\<rightarrow>" 60)

text \<open> An elementary completeness theorem for inequalities for probability logic
       is due to Patrick Suppes @{cite suppesProbabilisticInferenceConcept1966}. \<close>

text \<open> A consequence of this Suppes' theorem is an elementary form of \<^emph>\<open>collapse\<close>,
       which asserts that inequalities for probabilities are logically
       equivalent to the more restricted class of \<^emph>\<open>Dirac measures\<close> as
       defined in \S\ref{sec:dirac-measures}. \<close>

section \<open> Suppes' List Theorem \label{sec:suppes-theorem-for-lists} \<close>

text \<open> We first establish Suppes' theorem for lists of propositions. This
       is done by establishing our first completeness theorem using
       \<^emph>\<open>Dirac measures\<close>. \<close>

text \<open> First, we use the result from \S\ref{sec:basic-probability-inequality-results}
       that shows \<open>\<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>\<close> implies \<open>\
 \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \
 \<psi>)\<close>.
       This can be understood as a \<^emph>\<open>soundness\<close> result. \<close>

text \<open> To show completeness, assume \<open>\<not> \<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>\<close>. From this
       obtain a maximally consistent \<^term>\<open>\<Omega>\<close> such that \<open>\<phi> \<rightarrow> \<Squnion> \<Psi> \<notin> \<Omega>\<close>.
       We then define \<^term>\<open>\<delta> \<chi> = (if (\<chi> \<in> \<Omega>) then 1 else 0)\<close> and
       show \<^term>\<open>\<delta>\<close> is a  \<^emph>\<open>Dirac measure\<close> such that \<open>\<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>)\<close>. \<close>

lemma (in classical_logic) dirac_list_summation_completeness:
  "(\<forall> \<delta> \<in> dirac_measures. \<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>)) = \<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
proof -
  {
    fix \<delta> :: "'a \<Rightarrow> real"
    assume "\<delta> \<in> dirac_measures"
    from this interpret probability_logic "(\<lambda> \<phi>. \<turnstile> \<phi>)" "(\<rightarrow>)" "\<bottom>" "\<delta>"
      unfolding dirac_measures_def
      by auto
    assume "\<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
    hence "\<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>)"
      using implication_list_summation_inequality
      by auto
  }
  moreover {
    assume "\<not> \<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
    from this obtain \<Omega> where \<Omega>:
      "MCS \<Omega>"
      "\<phi> \<in> \<Omega>"
      "\<Squnion> \<Psi> \<notin> \<Omega>"
      by (meson
            insert_subset
            formula_consistent_def
            formula_maximal_consistency
            formula_maximally_consistent_extension
            formula_maximally_consistent_set_def_def
            set_deduction_base_theory
            set_deduction_reflection
            set_deduction_theorem)
    hence"\<forall> \<psi> \<in> set \<Psi>. \<psi> \<notin> \<Omega>"
      using arbitrary_disjunction_exclusion_MCS by blast
    define \<delta> where "\<delta> = (\<lambda> \<chi> . if \<chi>\<in>\<Omega> then (1 :: real) else 0)"
    from \<open>\<forall> \<psi> \<in> set \<Psi>. \<psi> \<notin> \<Omega>\<close> have "(\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>) = 0"
      unfolding \<delta>_def
      by (induct \<Psi>, simp, simp)
    hence "\<not> \<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>)"
      unfolding \<delta>_def
      by (simp add: \<Omega>(2))
    hence
      "\<exists> \<delta> \<in> dirac_measures. \<not> (\<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>))"
      unfolding \<delta>_def
      using \<Omega>(1) MCS_dirac_measure by auto
  }
  ultimately show ?thesis by blast
qed

theorem (in classical_logic) list_summation_completeness:
  "(\<forall> \
 \<in> probabilities. \
 \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \
 \<psi>)) = \<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  hence "\<forall> \<delta> \<in> dirac_measures. \<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>)"
    unfolding dirac_measures_def probabilities_def
    by blast
  thus ?rhs
    using dirac_list_summation_completeness by blast
next
  assume ?rhs
  show ?lhs
  proof
    fix \
 :: "'a \<Rightarrow> real"
    assume "\
 \<in> probabilities"
    from this interpret probability_logic "(\<lambda> \<phi>. \<turnstile> \<phi>)" "(\<rightarrow>)" \<bottom> \

      unfolding probabilities_def
      by auto
    show "\
 \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \
 \<psi>)"
      using \<open>?rhs\<close> implication_list_summation_inequality
      by simp
  qed
qed

text \<open> The collapse theorem asserts that to prove an inequalities for all
       probabilities in probability logic, one only needs to consider the
       case of functions which take on values of 0 or 1. \<close>

lemma (in classical_logic) suppes_collapse:
  "(\<forall> \
 \<in> probabilities. \
 \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \
 \<psi>))
      = (\<forall> \<delta> \<in> dirac_measures. \<delta> \<phi> \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. \<delta> \<psi>))"
  by (simp add:
        dirac_list_summation_completeness
        list_summation_completeness)

lemma (in classical_logic) probability_member_neg:
  fixes \

  assumes "\
 \<in> probabilities"
  shows "\
 (\<sim> \<phi>) = 1 - \
 \<phi>"
proof -
  from assms interpret probability_logic "(\<lambda> \<phi>. \<turnstile> \<phi>)" "(\<rightarrow>)" \<bottom> \

    unfolding probabilities_def
    by auto
  show ?thesis
    by (simp add: complementation)
qed

text \<open> Suppes' theorem has a philosophical interpretation.
       It asserts that if \<^term>\<open>\<Psi> :\<turnstile> \<phi>\<close>, then our \<^emph>\<open>uncertainty\<close>
       in \<^term>\<open>\<phi>\<close> is bounded above by our uncertainty in \<^term>\<open>\<Psi>\<close>.
       Here the uncertainty in the proposition \<^term>\<open>\<phi>\<close> is \<open>1 - \
 \<phi>\<close>.
       Our uncertainty in \<^term>\<open>\<Psi>\<close>, on the other hand, is
       \<open>\<Sum>\<psi>\<leftarrow>\<Psi>. 1 - \
 \<psi>\<close>. \<close>

theorem (in classical_logic) suppes_list_theorem:
  "\<Psi> :\<turnstile> \<phi> = (\<forall> \
 \<in> probabilities. (\<Sum>\<psi>\<leftarrow>\<Psi>. 1 - \
 \<psi>) \<ge> 1 - \
 \<phi>)"
proof -
  have
    "\<Psi> :\<turnstile> \<phi> = (\<forall> \
 \<in> probabilities. (\<Sum>\<psi> \<leftarrow> \<^bold>\<sim> \<Psi>. \
 \<psi>) \<ge> \
 (\<sim> \<phi>))"
    using
      list_summation_completeness
      weak_biconditional_weaken
      contra_list_curry_uncurry
      list_deduction_def
    by blast
  moreover have
    "\<forall> \
 \<in> probabilities. (\<Sum>\<psi> \<leftarrow> (\<^bold>\<sim> \<Psi>). \
 \<psi>) = (\<Sum>\<psi> \<leftarrow> \<Psi>. \
 (\<sim> \<psi>))"
    by (induct \<Psi>, auto)
  ultimately show ?thesis
    using probability_member_neg
    by (induct \<Psi>, simp+)
qed

section \<open> Suppes' Set Theorem \<close>

text \<open> Suppes theorem also obtains for \<^emph>\<open>sets\<close>. \<close>

lemma (in classical_logic) dirac_set_summation_completeness:
  "(\<forall> \<delta> \<in> dirac_measures. \<delta> \<phi> \<le> (\<Sum>\<psi>\<in> set \<Psi>. \<delta> \<psi>)) = \<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
  by (metis
        dirac_list_summation_completeness
        modus_ponens
        arbitrary_disjunction_remdups
        biconditional_left_elimination
        biconditional_right_elimination
        hypothetical_syllogism
        sum.set_conv_list)

theorem (in classical_logic) set_summation_completeness:
  "(\<forall> \<delta> \<in> probabilities. \<delta> \<phi> \<le> (\<Sum>\<psi>\<in> set \<Psi>. \<delta> \<psi>)) = \<turnstile> \<phi> \<rightarrow> \<Squnion> \<Psi>"
  by (metis
        dirac_list_summation_completeness
        dirac_set_summation_completeness
        list_summation_completeness
        sum.set_conv_list)

lemma (in classical_logic) suppes_set_collapse:
  "(\<forall> \
 \<in> probabilities. \
 \<phi> \<le> (\<Sum>\<psi> \<in> set \<Psi>. \
 \<psi>))
      = (\<forall> \<delta> \<in> dirac_measures. \<delta> \<phi> \<le> (\<Sum>\<psi> \<in> set \<Psi>. \<delta> \<psi>))"
  by (simp add:
        dirac_set_summation_completeness
        set_summation_completeness)

text \<open> In our formulation of logic, there is not reason that \<open>\<sim> a = \<sim> b\<close>
       while \<^term>\<open>a \<noteq> b\<close>.  As a consequence the Suppes theorem
       for sets presented below is different than the one given in
       \S\ref{sec:suppes-theorem-for-lists}. \<close>

theorem (in classical_logic) suppes_set_theorem:
  "\<Psi> :\<turnstile> \<phi>
     = (\<forall> \
 \<in> probabilities. (\<Sum>\<psi> \<in> set (\<^bold>\<sim> \<Psi>). \
 \<psi>) \<ge> 1 - \
 \<phi>)"
proof -
  have "\<Psi> :\<turnstile> \<phi>
          = (\<forall> \
 \<in> probabilities. (\<Sum>\<psi> \<in> set (\<^bold>\<sim> \<Psi>). \
 \<psi>) \<ge> \
 (\<sim> \<phi>))"
    using
      contra_list_curry_uncurry
      list_deduction_def
      set_summation_completeness
      weak_biconditional_weaken
    by blast
  thus ?thesis
    using probability_member_neg
    by (induct \<Psi>, auto)
qed

section \<open> Converse Suppes' Theorem \<close>

text \<open> A formulation of the converse of Suppes' theorem obtains
       for lists/sets of \<^emph>\<open>logically disjoint\<close> propositions. \<close>

lemma (in probability_logic) exclusive_sum_list_identity:
  assumes "\<turnstile> \<Coprod> \<Phi>"
  shows "\
 (\<Squnion> \<Phi>) = (\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>)"
  using assms
proof (induct \<Phi>)
  case Nil
  then show ?case
    by (simp add: gaines_weatherson_antithesis)
next
  case (Cons \<phi> \<Phi>)
  assume "\<turnstile> \<Coprod> (\<phi> # \<Phi>)"
  hence "\<turnstile> \<sim> (\<phi> \<sqinter> \<Squnion> \<Phi>)" "\<turnstile> \<Coprod> \<Phi>" by simp+
  hence "\
 (\<Squnion>(\<phi> # \<Phi>)) = \
 \<phi> + \
 (\<Squnion> \<Phi>)"
        "\
 (\<Squnion> \<Phi>) = (\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>)"
    using Cons.hyps probability_additivity by auto
  hence "\
 (\<Squnion>(\<phi> # \<Phi>)) = \
 \<phi> + (\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>)" by auto
  thus ?case by simp
qed

lemma sum_list_monotone:
  fixes f :: "'a \<Rightarrow> real"
  assumes "\<forall> x. f x \<ge> 0"
     and  "set \<Phi> \<subseteq> set \<Psi>"
     and  "distinct \<Phi>"
   shows "(\<Sum>\<phi>\<leftarrow>\<Phi>. f \<phi>) \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. f \<psi>)"
  using assms
proof -
  assume "\<forall> x. f x \<ge> 0"
  have "\<forall>\<Phi>. set \<Phi> \<subseteq> set \<Psi>
             \<longrightarrow> distinct \<Phi>
             \<longrightarrow> (\<Sum>\<phi>\<leftarrow>\<Phi>. f \<phi>) \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. f \<psi>)"
  proof (induct \<Psi>)
    case Nil
    then show ?case by simp
  next
    case (Cons \<psi> \<Psi>)
    {
      fix \<Phi>
      assume "set \<Phi> \<subseteq> set (\<psi> # \<Psi>)"
         and "distinct \<Phi>"
      have "(\<Sum>\<phi>\<leftarrow>\<Phi>. f \<phi>) \<le> (\<Sum>\<psi>'\<leftarrow>(\<psi> # \<Psi>). f \<psi>')"
      proof -
        {
          assume "\<psi> \<notin> set \<Phi>"
          with \<open>set \<Phi> \<subseteq> set (\<psi> # \<Psi>)\<close> have "set \<Phi> \<subseteq> set \<Psi>" by auto
          hence "(\<Sum>\<phi>\<leftarrow>\<Phi>. f \<phi>) \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. f \<psi>)"
            using Cons.hyps \<open>distinct \<Phi>\<close> by auto
          moreover have "f \<psi> \<ge> 0" using \<open>\<forall> x. f x \<ge> 0\<close> by metis
          ultimately have ?thesis by simp
        }
        moreover
        {
          assume "\<psi> \<in> set \<Phi>"
          hence "set \<Phi> = insert \<psi> (set (removeAll \<psi> \<Phi>))"
            by auto
          with \<open>set \<Phi> \<subseteq> set (\<psi> # \<Psi>)\<close> have "set (removeAll \<psi> \<Phi>) \<subseteq> set \<Psi>"
            by (metis
                  insert_subset
                  list.simps(15)
                  set_removeAll
                  subset_insert_iff)
          moreover from \<open>distinct \<Phi>\<close> have "distinct (removeAll \<psi> \<Phi>)"
            by (meson distinct_removeAll)
          ultimately have "(\<Sum>\<phi>\<leftarrow>(removeAll \<psi> \<Phi>). f \<phi>) \<le> (\<Sum>\<psi>\<leftarrow>\<Psi>. f \<psi>)"
            using Cons.hyps
            by simp
          moreover from \<open>\<psi> \<in> set \<Phi>\<close> \<open>distinct \<Phi>\<close>
          have "(\<Sum>\<phi>\<leftarrow>\<Phi>. f \<phi>) = f \<psi> + (\<Sum>\<phi>\<leftarrow>(removeAll \<psi> \<Phi>). f \<phi>)"
            using distinct_remove1_removeAll sum_list_map_remove1
            by fastforce
          ultimately have ?thesis using \<open>\<forall> x. f x \<ge> 0\<close>
            by simp
        }
        ultimately show ?thesis by blast
      qed
    }
    thus ?case by blast
  qed
  moreover assume "set \<Phi> \<subseteq> set \<Psi>" and "distinct \<Phi>"
  ultimately show ?thesis by blast
qed

lemma count_remove_all_sum_list:
  fixes f :: "'a \<Rightarrow> real"
  shows "real (count_list xs x) * f x + (\<Sum>x'\<leftarrow>(removeAll x xs). f x')
           = (\<Sum>x\<leftarrow>xs. f x)"
  by (induct xs, simp, simp, metis combine_common_factor mult_cancel_right1)

lemma (in classical_logic) dirac_exclusive_implication_completeness:
  "(\<forall> \<delta> \<in> dirac_measures. (\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>) \<le> \<delta> \<psi>) = (\<turnstile> \<Coprod> \<Phi> \<and>  \<turnstile> \<Squnion> \<Phi> \<rightarrow> \<psi>)"
proof -
  {
    fix \<delta>
    assume "\<delta> \<in> dirac_measures"
    from this interpret probability_logic "(\<lambda> \<phi>. \<turnstile> \<phi>)" "(\<rightarrow>)" "\<bottom>" "\<delta>"
      unfolding dirac_measures_def
      by simp
    assume "\<turnstile> \<Coprod> \<Phi>" "\<turnstile> \<Squnion> \<Phi> \<rightarrow> \<psi>"
    hence "(\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>) \<le> \<delta> \<psi>"
      using exclusive_sum_list_identity monotonicity by fastforce
  }
  moreover
  {
    assume "\<not> \<turnstile> \<Coprod> \<Phi>"
    hence "(\<exists> \<phi> \<in> set \<Phi>. \<exists> \<psi> \<in> set \<Phi>.
              \<phi> \<noteq> \<psi> \<and> \<not> \<turnstile> \<sim> (\<phi> \<sqinter> \<psi>)) \<or> (\<exists> \<phi> \<in> duplicates \<Phi>. \<not> \<turnstile> \<sim> \<phi>)"
      using exclusive_equivalence set_deduction_base_theory by blast
    hence "\<not> (\<forall> \<delta> \<in> dirac_measures. (\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>) \<le> \<delta> \<psi>)"
    proof (elim disjE)
      assume "\<exists> \<phi> \<in> set \<Phi>. \<exists> \<chi> \<in> set \<Phi>. \<phi> \<noteq> \<chi> \<and> \<not> \<turnstile> \<sim> (\<phi> \<sqinter> \<chi>)"
      from this obtain \<phi> and \<chi>
        where \<phi>\<chi>_properties:
          "\<phi> \<in> set \<Phi>"
          "\<chi> \<in> set \<Phi>"
          "\<phi> \<noteq> \<chi>"
          "\<not> \<turnstile> \<sim> (\<phi> \<sqinter> \<chi>)"
        by blast
      from this obtain \<Omega> where \<Omega>: "MCS \<Omega>" "\<sim> (\<phi> \<sqinter> \<chi>) \<notin> \<Omega>"
        by (meson
              insert_subset
              formula_consistent_def
              formula_maximal_consistency
              formula_maximally_consistent_extension
              formula_maximally_consistent_set_def_def
              set_deduction_base_theory
              set_deduction_reflection
              set_deduction_theorem)
      let ?\<delta> = "\<lambda> \<chi>. if \<chi>\<in>\<Omega> then (1 :: real) else 0"
      from \<Omega> have "\<phi> \<in> \<Omega>" "\<chi> \<in> \<Omega>"
        by (metis
              formula_maximally_consistent_set_def_implication
              maximally_consistent_set_def
              conjunction_def
              negation_def)+
      with \<phi>\<chi>_properties have
          "(\<Sum>\<phi>\<leftarrow>[\<phi>, \<chi>]. ?\<delta> \<phi>) = 2"
          "set [\<phi>, \<chi>] \<subseteq> set \<Phi>"
          "distinct [\<phi>, \<chi>]"
          "\<forall>\<phi>. ?\<delta> \<phi> \<ge> 0"
        by simp+
      hence "(\<Sum>\<phi>\<leftarrow>\<Phi>. ?\<delta> \<phi>) \<ge> 2" using sum_list_monotone by metis
      hence "\<not> (\<Sum>\<phi>\<leftarrow>\<Phi>. ?\<delta> \<phi>) \<le> ?\<delta> (\<psi>)" by auto
      thus ?thesis
        using \<Omega>(1) MCS_dirac_measure
        by auto
    next
      assume "\<exists> \<phi> \<in> duplicates \<Phi>. \<not> \<turnstile> \<sim> \<phi>"
      from this obtain \<phi> where \<phi>: "\<phi> \<in> duplicates \<Phi>" "\<not> \<turnstile> \<sim> \<phi>"
        using
          exclusive_equivalence [where \<Gamma>="{}"]
          set_deduction_base_theory
        by blast
      from \<phi> obtain \<Omega> where \<Omega>: "MCS \<Omega>" "\<sim> \<phi> \<notin> \<Omega>"
        by (meson
              insert_subset
              formula_consistent_def
              formula_maximal_consistency
              formula_maximally_consistent_extension
              formula_maximally_consistent_set_def_def
              set_deduction_base_theory
              set_deduction_reflection
              set_deduction_theorem)
      hence "\<phi> \<in> \<Omega>"
        using negation_def by auto
      let ?\<delta> = "\<lambda> \<chi>. if \<chi>\<in>\<Omega> then (1 :: real) else 0"
      from \<phi> have "count_list \<Phi> \<phi> \<ge> 2"
        using duplicates_alt_def [where xs="\<Phi>"]
        by blast
      hence "real (count_list \<Phi> \<phi>) * ?\<delta> \<phi> \<ge> 2" using \<open>\<phi> \<in> \<Omega>\<close> by simp
      moreover
      {
        fix \<Psi>
        have "(\<Sum>\<phi>\<leftarrow>\<Psi>. ?\<delta> \<phi>) \<ge> 0" by (induct \<Psi>, simp, simp)
      }
      moreover have "(0::real)
                          \<le> (\<Sum>a\<leftarrow>removeAll \<phi> \<Phi>. if a \<in> \<Omega> then 1 else 0)"
        using \<open>\<And>\<Psi>. 0 \<le> (\<Sum>\<phi>\<leftarrow>\<Psi>. if \<phi> \<in> \<Omega> then 1 else 0)\<close>
        by presburger
      ultimately have "real (count_list \<Phi> \<phi>) * ?\<delta> \<phi>
                            + (\<Sum> \<phi> \<leftarrow> (removeAll \<phi> \<Phi>). ?\<delta> \<phi>) \<ge> 2"
        using \<open>2 \<le> real (count_list \<Phi> \<phi>) * (if \<phi> \<in> \<Omega> then 1 else 0)\<close>
        by linarith
      hence "(\<Sum>\<phi>\<leftarrow>\<Phi>. ?\<delta> \<phi>) \<ge> 2" by (metis count_remove_all_sum_list)
      hence "\<not> (\<Sum>\<phi>\<leftarrow>\<Phi>. ?\<delta> \<phi>) \<le> ?\<delta> (\<psi>)" by auto
      thus ?thesis
        using \<Omega>(1) MCS_dirac_measure
        by auto
    qed
  }
  moreover
  {
    assume "\<not> \<turnstile> \<Squnion> \<Phi> \<rightarrow> \<psi>"
    from this obtain \<Omega> \<phi>
      where
        \<Omega>: "MCS \<Omega>"
        and \<psi>: "\<psi> \<notin> \<Omega>"
        and \<phi>: "\<phi> \<in> set \<Phi>" "\<phi> \<in> \<Omega>"
      by (meson
            insert_subset
            formula_consistent_def
            formula_maximal_consistency
            formula_maximally_consistent_extension
            formula_maximally_consistent_set_def_def
            arbitrary_disjunction_exclusion_MCS
            set_deduction_base_theory
            set_deduction_reflection
            set_deduction_theorem)
    let ?\<delta> = "\<lambda> \<chi>. if \<chi>\<in>\<Omega> then (1 :: real) else 0"
    from \<phi> have "(\<Sum>\<phi>\<leftarrow>\<Phi>. ?\<delta> \<phi>) \<ge> 1"
    proof (induct \<Phi>)
      case Nil
      then show ?case by simp
    next
      case (Cons \<phi>' \<Phi>)
      obtain f :: "real list \<Rightarrow> real" where f:
        "\<forall>rs. f rs \<in> set rs \<and> \<not> 0 \<le> f rs \<or> 0 \<le> sum_list rs"
        using sum_list_nonneg by moura
      moreover have "f (map ?\<delta> \<Phi>) \<notin> set (map ?\<delta> \<Phi>) \<or> 0 \<le> f (map ?\<delta> \<Phi>)"
        by fastforce
      ultimately show ?case
        by (simp, metis Cons.hyps Cons.prems(1) \<phi>(2) set_ConsD)
    qed
    hence "\<not> (\<Sum>\<phi>\<leftarrow>\<Phi>. ?\<delta> \<phi>) \<le> ?\<delta> (\<psi>)" using \<psi> by auto
    hence "\<not> (\<forall> \<delta> \<in> dirac_measures. (\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>) \<le> \<delta> \<psi>)"
      using \<Omega>(1) MCS_dirac_measure
      by auto
  }
  ultimately show ?thesis by blast
qed

theorem (in classical_logic) exclusive_implication_completeness:
  "(\<forall> \
 \<in> probabilities. (\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>) \<le> \
 \<psi>) = (\<turnstile> \<Coprod> \<Phi> \<and>  \<turnstile> \<Squnion> \<Phi> \<rightarrow> \<psi>)"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  thus ?rhs
    by (meson
          dirac_exclusive_implication_completeness
          dirac_measures_subset
          subset_eq)
next
  assume ?rhs
  show ?lhs
  proof
    fix \
 :: "'a \<Rightarrow> real"
    assume "\
 \<in> probabilities"
    from this interpret probability_logic "(\<lambda> \<phi>. \<turnstile> \<phi>)" "(\<rightarrow>)" \<bottom> \

      unfolding probabilities_def
      by simp
    show "(\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>) \<le> \
 \<psi>"
      using
        \<open>?rhs\<close>
        exclusive_sum_list_identity
        monotonicity
      by fastforce
  qed
qed

lemma (in classical_logic) dirac_inequality_completeness:
  "(\<forall> \<delta> \<in> dirac_measures. \<delta> \<phi> \<le> \<delta> \<psi>) = \<turnstile> \<phi> \<rightarrow> \<psi>"
proof -
  have "\<turnstile> \<Coprod> [\<phi>]"
    by (simp add: conjunction_right_elimination negation_def)
  hence "(\<turnstile> \<Coprod> [\<phi>] \<and>  \<turnstile> \<Squnion> [\<phi>] \<rightarrow> \<psi>) = \<turnstile> \<phi> \<rightarrow> \<psi>"
    by (metis
          arbitrary_disjunction.simps(1)
          arbitrary_disjunction.simps(2)
          disjunction_def implication_equivalence
          negation_def
          weak_biconditional_weaken)
  thus ?thesis
    using dirac_exclusive_implication_completeness [where \<Phi>="[\<phi>]"]
    by auto
qed

section \<open> Implication Inequality Completeness \<close>

text \<open> The following theorem establishes the converse of
       \<open>\<turnstile> \<phi> \<rightarrow> \<psi> \<Longrightarrow> \
 \<phi> \<le> \
 \<psi>\<close>, which was
       proved in \S\ref{sec:prob-logic-alt-def}. \<close>

theorem (in classical_logic) implication_inequality_completeness:
  "(\<forall> \
 \<in> probabilities. \
 \<phi> \<le> \
 \<psi>) = \<turnstile> \<phi> \<rightarrow> \<psi>"
proof -
  have "\<turnstile> \<Coprod> [\<phi>]"
    by (simp add: conjunction_right_elimination negation_def)
  hence "(\<turnstile> \<Coprod> [\<phi>] \<and>  \<turnstile> \<Squnion> [\<phi>] \<rightarrow> \<psi>) = \<turnstile> \<phi> \<rightarrow> \<psi>"
    by (metis
          arbitrary_disjunction.simps(1)
          arbitrary_disjunction.simps(2)
          disjunction_def implication_equivalence
          negation_def
          weak_biconditional_weaken)
  thus ?thesis
    using exclusive_implication_completeness [where \<Phi>="[\<phi>]"]
    by simp
qed

section \<open> Characterizing Logical Exclusiveness In Probability Logic \<close>

text \<open> Finally, we can say that \<open>\
 (\<Squnion> \<Phi>) = (\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>)\<close> if and only
       if the propositions in \<^term>\<open>\<Phi>\<close> are mutually exclusive (i.e. \<open>\<turnstile> \<Coprod> \<Phi>\<close>).
       This result also obtains for sets. \<close>

lemma (in classical_logic) dirac_exclusive_list_summation_completeness:
  "(\<forall> \<delta> \<in> dirac_measures. \<delta> (\<Squnion> \<Phi>) = (\<Sum>\<phi>\<leftarrow>\<Phi>. \<delta> \<phi>)) = \<turnstile> \<Coprod> \<Phi>"
  by (metis
        antisym_conv
        dirac_exclusive_implication_completeness
        dirac_list_summation_completeness
        trivial_implication)

theorem (in classical_logic) exclusive_list_summation_completeness:
  "(\<forall> \
 \<in> probabilities. \
 (\<Squnion> \<Phi>) = (\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>)) = \<turnstile> \<Coprod> \<Phi>"
  by (metis
        antisym_conv
        exclusive_implication_completeness
        list_summation_completeness
        trivial_implication)

lemma (in classical_logic) dirac_exclusive_set_summation_completeness:
  "(\<forall> \<delta> \<in> dirac_measures. \<delta> (\<Squnion> \<Phi>) = (\<Sum>\<phi> \<in> set \<Phi>. \<delta> \<phi>))
      = \<turnstile> \<Coprod> (remdups \<Phi>)"
  by (metis
        (mono_tags)
        eq_iff
        dirac_exclusive_implication_completeness
        dirac_set_summation_completeness
        trivial_implication
        set_remdups
        sum.set_conv_list    eq_iff
        dirac_exclusive_implication_completeness
        dirac_set_summation_completeness
        trivial_implication
        set_remdups
        sum.set_conv_list
        antisym_conv)

theorem (in classical_logic) exclusive_set_summation_completeness:
  "(\<forall> \
 \<in> probabilities.
        \
 (\<Squnion> \<Phi>) = (\<Sum>\<phi> \<in> set \<Phi>. \
 \<phi>)) = \<turnstile> \<Coprod> (remdups \<Phi>)"
  by (metis
        (mono_tags, opaque_lifting)
        antisym_conv
        exclusive_list_summation_completeness
        exclusive_implication_completeness
        implication_inequality_completeness
        set_summation_completeness
        order.refl
        sum.set_conv_list)

lemma (in probability_logic) exclusive_list_set_inequality:
  assumes "\<turnstile> \<Coprod> \<Phi>"
  shows "(\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>) = (\<Sum>\<phi>\<in>set \<Phi>. \
 \<phi>)"
proof -
  have "distinct (remdups \<Phi>)" using distinct_remdups by auto
  hence "duplicates (remdups \<Phi>) = {}"
    by (induct "\<Phi>", simp+)
  moreover have "set (remdups \<Phi>) = set \<Phi>"
    by (induct "\<Phi>", simp, simp add: insert_absorb)
  moreover have "(\<forall>\<phi> \<in> duplicates \<Phi>. \<turnstile> \<sim> \<phi>)
               \<and> (\<forall> \<phi> \<in> set \<Phi>. \<forall> \<psi> \<in> set \<Phi>. (\<phi> \<noteq> \<psi>) \<longrightarrow> \<turnstile> \<sim> (\<phi> \<sqinter> \<psi>))"
    using
      assms
      exclusive_elimination1
      exclusive_elimination2
      set_deduction_base_theory
    by blast
  ultimately have
    "(\<forall>\<phi>\<in>duplicates (remdups \<Phi>). \<turnstile> \<sim> \<phi>)
   \<and> (\<forall> \<phi> \<in> set (remdups \<Phi>). \<forall> \<psi> \<in> set (remdups \<Phi>).
          (\<phi> \<noteq> \<psi>) \<longrightarrow> \<turnstile> \<sim> (\<phi> \<sqinter> \<psi>))"
    by auto
  hence "\<turnstile> \<Coprod> (remdups \<Phi>)"
    by (meson exclusive_equivalence set_deduction_base_theory)
  hence "(\<Sum>\<phi>\<in>set \<Phi>. \
 \<phi>) = \
 (\<Squnion> \<Phi>)"
    by (metis
          arbitrary_disjunction_remdups
          biconditional_equivalence
          exclusive_sum_list_identity
          sum.set_conv_list)
  moreover have "(\<Sum>\<phi>\<leftarrow>\<Phi>. \
 \<phi>) = \
 (\<Squnion> \<Phi>)"
    by (simp add: assms exclusive_sum_list_identity)
  ultimately show ?thesis by metis
qed

notation FuncSet.funcset (infixr "\<rightarrow>" 60)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Monotonicity\<close>
theory Functions_Monotone
  imports
    Binary_Relations_Order_Base
    Function_Relators
    Predicates
begin

paragraph \<open>Summary\<close>
text \<open>Introduces the concept of monotone functions. A function is monotone
if it is related to itself \<hyphen> see \<^term>\<open>Dep_Fun_Rel_rel\<close>.\<close>

declare le_funI[intro]
declare le_funE[elim]

definition "dep_mono_wrt_rel R S f \<equiv> ([x y \<Colon> R] \<Rrightarrow> S x y) f f"

abbreviation "mono_wrt_rel R S \<equiv> dep_mono_wrt_rel R (\<lambda>_ _. S)"

definition "dep_mono_wrt_pred P Q f \<equiv> ([x \<Colon> P] \<Rrightarrow> (\<lambda>_. Q x)) f f"

abbreviation "mono_wrt_pred P Q \<equiv> dep_mono_wrt_pred P (\<lambda>_. Q)"

bundle dep_mono_wrt_syntax begin
syntax
  "_mono_wrt_rel" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow>
    bool" ("(_) \<Rrightarrow>\<^sub>m (_)" [41, 40] 40)
  "_dep_mono_wrt_rel" :: "idt \<Rightarrow> idt \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'b) \<Rightarrow> bool" ("[_/ _/ \<Colon>/ _] \<Rrightarrow>\<^sub>m (_)" [41, 41, 41, 40] 40)
  "_dep_mono_wrt_rel_if" :: "idt \<Rightarrow> idt \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'b) \<Rightarrow> bool" ("[_/ _/ \<Colon>/ _/ |/ _] \<Rrightarrow>\<^sub>m (_)" [41, 41, 41, 41, 40] 40)
  "_mono_wrt_pred" :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow>
    bool" ("[_] \<Rrightarrow>\<^sub>m (_)" [41, 40] 40)
  "_dep_mono_wrt_pred" :: "idt \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'b) \<Rightarrow> bool" ("[_/ \<Colon>/ _] \<Rrightarrow>\<^sub>m (_)" [41, 41, 40] 40)
  (*TODO: this only works if we introduce a pred_if constant first*)
  (* "_dep_mono_wrt_pred_if" :: "idt \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> *)
    (* ('a \<Rightarrow> 'b) \<Rightarrow> bool" ("[_/ \<Colon>/ _/ |/ _] \<Rrightarrow>\<^sub>m (_)" [41, 41, 41, 40] 40) *)
end
bundle no_dep_mono_wrt_syntax begin
no_syntax
  "_mono_wrt_rel" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow>
    bool" ("(_) \<Rrightarrow>\<^sub>m (_)" [41, 40] 40)
  "_dep_mono_wrt_rel" :: "idt \<Rightarrow> idt \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'b) \<Rightarrow> bool" ("[_/ _/ \<Colon>/ _] \<Rrightarrow>\<^sub>m (_)" [41, 41, 41, 40] 40)
  "_dep_mono_wrt_rel_if" :: "idt \<Rightarrow> idt \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'b) \<Rightarrow> bool" ("[_/ _/ \<Colon>/ _/ |/ _] \<Rrightarrow>\<^sub>m (_)" [41, 41, 41, 41, 40] 40)
  "_mono_wrt_pred" :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow>
    bool" ("[_] \<Rrightarrow>\<^sub>m (_)" [41, 40] 40)
  "_dep_mono_wrt_pred" :: "idt \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'b) \<Rightarrow> bool" ("[_/ \<Colon>/ _] \<Rrightarrow>\<^sub>m (_)" [41, 41, 40] 40)
  (* "_dep_mono_wrt_pred_if" :: "idt \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> *)
    (* ('a \<Rightarrow> 'b) \<Rightarrow> bool" ("[_/ \<Colon>/ _/ |/ _] \<Rrightarrow>\<^sub>m (_)" [41, 41, 41, 40] 40) *)
end
unbundle dep_mono_wrt_syntax
translations
  "R \<Rrightarrow>\<^sub>m S" \<rightleftharpoons> "CONST mono_wrt_rel R S"
  "[x y \<Colon> R] \<Rrightarrow>\<^sub>m S" \<rightleftharpoons> "CONST dep_mono_wrt_rel R (\<lambda>x y. S)"
  "[x y \<Colon> R | B] \<Rrightarrow>\<^sub>m S" \<rightleftharpoons> "CONST dep_mono_wrt_rel R (\<lambda>x y. CONST rel_if B S)"
  "[P] \<Rrightarrow>\<^sub>m Q" \<rightleftharpoons> "CONST mono_wrt_pred P Q"
  "[x \<Colon> P] \<Rrightarrow>\<^sub>m Q" \<rightleftharpoons> "CONST dep_mono_wrt_pred P (\<lambda>x. Q)"
  (* "[x \<Colon> P | B] \<Rrightarrow>\<^sub>m Q" \<rightleftharpoons> "CONST dep_mono_wrt_pred P (\<lambda>x. CONST rel_if B Q)" *)

lemma dep_mono_wrt_relI [intro]:
  assumes "\<And>x y. R x y \<Longrightarrow> S x y (f x) (f y)"
  shows "([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y) f"
  using assms unfolding dep_mono_wrt_rel_def by blast

lemma dep_mono_wrt_relE [elim]:
  assumes "([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y) f"
  and "R x y"
  obtains "S x y (f x) (f y)"
  using assms unfolding dep_mono_wrt_rel_def by blast

lemma dep_mono_wrt_relD:
  assumes "([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y) f"
  and "R x y"
  shows "S x y (f x) (f y)"
  using assms by blast

lemma dep_mono_wrt_predI [intro]:
  assumes "\<And>x. P x \<Longrightarrow> Q x (f x)"
  shows "([x \<Colon> P] \<Rrightarrow>\<^sub>m Q x) f"
  using assms unfolding dep_mono_wrt_pred_def by blast

lemma dep_mono_wrt_predE [elim]:
  assumes "([x \<Colon> P] \<Rrightarrow>\<^sub>m Q x) f"
  and "P x"
  obtains "Q x (f x)"
  using assms unfolding dep_mono_wrt_pred_def by blast

lemma dep_mono_wrt_predD:
  assumes "([x \<Colon> P] \<Rrightarrow>\<^sub>m Q x) f"
  and "P x"
  shows "Q x (f x)"
  using assms by blast

lemma dep_mono_wrt_rel_if_Dep_Fun_Rel_rel_self:
  assumes "([x y \<Colon> R] \<Rrightarrow> S x y) f f"
  shows "([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y) f"
  using assms by blast

lemma dep_mono_wrt_pred_if_Dep_Fun_Rel_pred_self:
  assumes "([x \<Colon> P] \<Rrightarrow> (\<lambda>_. Q x)) f f"
  shows "([x \<Colon> P] \<Rrightarrow>\<^sub>m Q x) f"
  using assms by blast

lemma Dep_Fun_Rel_rel_self_if_dep_mono_wrt_rel:
  assumes "([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y) f"
  shows "([x y \<Colon> R] \<Rrightarrow> S x y) f f"
  using assms by blast

lemma Dep_Fun_Rel_pred_self_if_dep_mono_wrt_pred:
  assumes "([x \<Colon> P] \<Rrightarrow>\<^sub>m Q x) f"
  shows "([x \<Colon> P] \<Rrightarrow> (\<lambda>_. Q x)) f f"
  using assms by blast

corollary Dep_Fun_Rel_rel_self_iff_dep_mono_wrt_rel:
  "([x y \<Colon> R] \<Rrightarrow> S x y) f f \<longleftrightarrow> ([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y) f"
  using dep_mono_wrt_rel_if_Dep_Fun_Rel_rel_self
    Dep_Fun_Rel_rel_self_if_dep_mono_wrt_rel by blast

corollary Dep_Fun_Rel_pred_self_iff_dep_mono_wrt_pred:
  "([x \<Colon> P] \<Rrightarrow> (\<lambda>_. Q x)) f f \<longleftrightarrow> ([x \<Colon> P] \<Rrightarrow>\<^sub>m Q x) f"
  using dep_mono_wrt_pred_if_Dep_Fun_Rel_pred_self
    Dep_Fun_Rel_pred_self_if_dep_mono_wrt_pred by blast

lemma dep_mono_wrt_rel_inv_eq [simp]:
  "([y x \<Colon> R\<inverse>] \<Rrightarrow>\<^sub>m (S x y)\<inverse>) = ([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y)"
  by (intro ext) auto

lemma in_dom_if_rel_if_dep_mono_wrt_rel:
  assumes "([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y) f"
  and "R x y"
  shows "in_dom (S x y) (f x)"
  using assms by (intro in_domI) blast

corollary in_dom_if_in_dom_if_mono_wrt_rel:
  assumes "(R \<Rrightarrow>\<^sub>m S) f"
  shows "([in_dom R] \<Rrightarrow>\<^sub>m in_dom S) f"
  using assms in_dom_if_rel_if_dep_mono_wrt_rel by fast

lemma in_codom_if_rel_if_dep_mono_wrt_rel:
  assumes "([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y) f"
  and "R x y"
  shows "in_codom (S x y) (f y)"
  using assms by (intro in_codomI) blast

corollary in_codom_if_in_codom_if_mono_wrt_rel:
  assumes "(R \<Rrightarrow>\<^sub>m S) f"
  shows "([in_codom R] \<Rrightarrow>\<^sub>m in_codom S) f"
  using assms in_dom_if_rel_if_dep_mono_wrt_rel by fast

corollary in_field_if_in_field_if_mono_wrt_rel:
  assumes "(R \<Rrightarrow>\<^sub>m S) f"
  shows "([in_field R] \<Rrightarrow>\<^sub>m in_field S) f"
  using assms by (intro dep_mono_wrt_predI) blast

lemma le_rel_map_if_mono_wrt_rel:
  assumes "(R \<Rrightarrow>\<^sub>m S) f"
  shows "R \<le> rel_map f S"
  using assms by (intro le_relI) auto

lemma le_pred_map_if_mono_wrt_pred:
  assumes "([P] \<Rrightarrow>\<^sub>m Q) f"
  shows "P \<le> pred_map f Q"
  using assms by (intro le_predI) auto

lemma mono_wrt_rel_if_le_rel_map:
  assumes "R \<le> rel_map f S"
  shows "(R \<Rrightarrow>\<^sub>m S) f"
  using assms by (intro dep_mono_wrt_relI) auto

lemma mono_wrt_pred_if_le_pred_map:
  assumes "P \<le> pred_map f Q"
  shows "([P] \<Rrightarrow>\<^sub>m Q) f"
  using assms by (intro dep_mono_wrt_predI) auto

corollary mono_wrt_rel_iff_le_rel_map: "(R \<Rrightarrow>\<^sub>m S) f \<longleftrightarrow> R \<le> rel_map f S"
  using mono_wrt_rel_if_le_rel_map le_rel_map_if_mono_wrt_rel by auto

corollary mono_wrt_pred_iff_le_pred_map: "([P] \<Rrightarrow>\<^sub>m Q) f \<longleftrightarrow> P \<le> pred_map f Q"
  using mono_wrt_pred_if_le_pred_map le_pred_map_if_mono_wrt_pred by auto

definition "mono \<equiv> ((\<le>) \<Rrightarrow>\<^sub>m (\<le>))"

definition "antimono \<equiv> ((\<le>) \<Rrightarrow>\<^sub>m (\<ge>))"

lemma monoI [intro]:
  assumes "\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y"
  shows "mono f"
  unfolding mono_def using assms by blast

lemma monoE [elim]:
  assumes "mono f"
  and "x \<le> y"
  obtains "f x \<le> f y"
  using assms unfolding mono_def by blast

lemma monoD:
  assumes "mono f"
  and "x \<le> y"
  shows "f x \<le> f y"
  using assms by blast

lemma antimonoI [intro]:
  assumes "\<And>x y. x \<le> y \<Longrightarrow> f y \<le> f x"
  shows "antimono f"
  unfolding antimono_def using assms by blast

lemma antimonoE [elim]:
  assumes "antimono f"
  and "x \<le> y"
  obtains "f y \<le> f x"
  using assms unfolding antimono_def by blast

lemma antimonoD:
  assumes "antimono f"
  and "x \<le> y"
  shows "f y \<le> f x"
  using assms by blast

lemma antimono_Dep_Fun_Rel_rel_left: "antimono (\<lambda>R. [x y \<Colon> R] \<Rrightarrow> S x y)"
  by (intro antimonoI) auto

lemma antimono_Dep_Fun_Rel_pred_left: "antimono (\<lambda>P. [x \<Colon> P] \<Rrightarrow> Q x)"
  by (intro antimonoI) auto

lemma antimono_dep_mono_wrt_rel_left: "antimono (\<lambda>R. [x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y)"
  by (intro antimonoI) auto

lemma antimono_dep_mono_wrt_pred_left: "antimono (\<lambda>P. [x \<Colon> P] \<Rrightarrow>\<^sub>m Q x)"
  by (intro antimonoI) auto

lemma Dep_Fun_Rel_rel_if_le_left_if_Dep_Fun_Rel_rel:
  assumes "([x y \<Colon> R] \<Rrightarrow> S x y) f g"
  and "T \<le> R"
  shows "([x y \<Colon> T] \<Rrightarrow> S x y) f g"
  using assms by blast

lemma Dep_Fun_Rel_pred_if_le_left_if_Dep_Fun_Rel_pred:
  assumes "([x \<Colon> P] \<Rrightarrow> Q x) f g"
  and "T \<le> P"
  shows "([x \<Colon> T] \<Rrightarrow> Q x) f g"
  using assms by blast

lemma dep_mono_wrt_rel_if_le_left_if_dep_mono_wrt_rel:
  assumes "([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y) f"
  and "T \<le> R"
  shows "([x y \<Colon> T] \<Rrightarrow>\<^sub>m S x y) f"
  using assms by blast

lemma dep_mono_wrt_pred_if_le_left_if_dep_mono_wrt_pred:
  assumes "([x \<Colon> P] \<Rrightarrow>\<^sub>m Q x) f"
  and "T \<le> P"
  shows "([x \<Colon> T] \<Rrightarrow>\<^sub>m Q x) f"
  using assms by blast

lemma mono_Dep_Fun_Rel_rel_right: "mono (\<lambda>S. [x y \<Colon> R] \<Rrightarrow> S x y)"
  by (intro monoI) blast

lemma mono_Dep_Fun_Rel_pred_right: "mono (\<lambda>Q. [x \<Colon> P] \<Rrightarrow> Q x)"
  by (intro monoI) blast

lemma mono_dep_mono_wrt_rel_right: "mono (\<lambda>S. [x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y)"
  by (intro monoI) blast

lemma mono_dep_mono_wrt_pred_right: "mono (\<lambda>Q. [x \<Colon> P] \<Rrightarrow>\<^sub>m Q x)"
  by (intro monoI) blast

lemma Dep_Fun_Rel_rel_if_le_right_if_Dep_Fun_Rel_rel:
  assumes "([x y \<Colon> R] \<Rrightarrow> S x y) f g"
  and "\<And>x y. R x y \<Longrightarrow> S x y (f x) (g y) \<Longrightarrow> T x y (f x) (g y)"
  shows "([x y \<Colon> R] \<Rrightarrow> T x y) f g"
  using assms by (intro Dep_Fun_Rel_relI) blast

lemma Dep_Fun_Rel_pred_if_le_right_if_Dep_Fun_Rel_pred:
  assumes "([x \<Colon> P] \<Rrightarrow> Q x) f g"
  and "\<And>x. P x \<Longrightarrow> Q x (f x) (g x) \<Longrightarrow> T x (f x) (g x)"
  shows "([x \<Colon> P] \<Rrightarrow> T x) f g"
  using assms by blast

lemma dep_mono_wrt_rel_if_le_right_if_dep_mono_wrt_rel:
  assumes "([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y) f"
  and "\<And>x y. R x y \<Longrightarrow> S x y (f x) (f y) \<Longrightarrow> T x y (f x) (f y)"
  shows "([x y \<Colon> R] \<Rrightarrow>\<^sub>m T x y) f"
  using assms by (intro dep_mono_wrt_relI) blast

lemma dep_mono_wrt_pred_if_le_right_if_dep_mono_wrt_pred:
  assumes "([x \<Colon> P] \<Rrightarrow>\<^sub>m Q x) f"
  and "\<And>x. P x \<Longrightarrow> Q x (f x) \<Longrightarrow> T x (f x)"
  shows "([x \<Colon> P] \<Rrightarrow>\<^sub>m T x) f"
  using assms by blast

paragraph \<open>Composition\<close>

lemma dep_mono_wrt_rel_compI:
  assumes "([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y) f"
  and "\<And>x y. R x y \<Longrightarrow> ([x' y' \<Colon> T x y] \<Rrightarrow>\<^sub>m U x y x' y') f'"
  and "\<And>x y. R x y \<Longrightarrow> S x y (f x) (f y) \<Longrightarrow> T x y (f x) (f y)"
  shows "([x y \<Colon> R] \<Rrightarrow>\<^sub>m U x y (f x) (f y)) (f' \<circ> f)"
  using assms by (intro dep_mono_wrt_relI) (auto 6 0)

corollary dep_mono_wrt_rel_compI':
  assumes "([x y \<Colon> R] \<Rrightarrow>\<^sub>m S x y) f"
  and "\<And>x y. R x y \<Longrightarrow> ([x' y' \<Colon> S x y] \<Rrightarrow>\<^sub>m T x y x' y') f'"
  shows "([x y \<Colon> R] \<Rrightarrow>\<^sub>m T x y (f x) (f y)) (f' \<circ> f)"
  using assms by (intro dep_mono_wrt_rel_compI)

lemma dep_mono_wrt_pred_comp_dep_mono_wrt_rel_compI:
  assumes "([x \<Colon> P] \<Rrightarrow>\<^sub>m Q x) f"
  and "\<And>x. P x \<Longrightarrow> ([x' y' \<Colon> R x] \<Rrightarrow>\<^sub>m S x x' y') f'"
  and "\<And>x. P x \<Longrightarrow> Q x (f x) \<Longrightarrow> R x (f x) (f x)"
  shows "([x \<Colon> P] \<Rrightarrow>\<^sub>m (\<lambda>y. S x (f x) (f x) y y)) (f' \<circ> f)"
  using assms by (intro dep_mono_wrt_predI) (auto 6 0)

lemma dep_mono_wrt_pred_comp_dep_mono_wrt_pred_compI:
  assumes "([x \<Colon> P] \<Rrightarrow>\<^sub>m Q x) f"
  and "\<And>x. P x \<Longrightarrow> ([x' \<Colon> R x] \<Rrightarrow>\<^sub>m S x x') f'"
  and "\<And>x. P x \<Longrightarrow> Q x (f x) \<Longrightarrow> R x (f x)"
  shows "([x \<Colon> P] \<Rrightarrow>\<^sub>m S x (f x)) (f' \<circ> f)"
  using assms by (intro dep_mono_wrt_predI) (auto 6 0)

corollary dep_mono_wrt_pred_comp_dep_mono_wrt_pred_compI':
  assumes "([x \<Colon> P] \<Rrightarrow>\<^sub>m Q x) f"
  and "\<And>x. P x \<Longrightarrow> ([x' \<Colon> Q x] \<Rrightarrow>\<^sub>m S x x') f'"
  shows "([x \<Colon> P] \<Rrightarrow>\<^sub>m S x (f x)) (f' \<circ> f)"
  using assms by (intro dep_mono_wrt_pred_comp_dep_mono_wrt_pred_compI)

paragraph \<open>Instantiations\<close>

lemma mono_wrt_rel_self_id: "(R \<Rrightarrow>\<^sub>m R) id" by auto
lemma mono_wrt_pred_self_id: "([P] \<Rrightarrow>\<^sub>m P) id" by auto

lemma mono_in_dom: "mono in_dom" by (intro monoI) fast
lemma mono_in_codom: "mono in_codom" by (intro monoI) fast
lemma mono_in_field: "mono in_field" by (intro monoI) fast
lemma mono_rel_comp1: "mono (\<circ>\<circ>)" by (intro monoI) fast
lemma mono_rel_comp2: "mono ((\<circ>\<circ>) x)" by (intro monoI) fast

end


(*  Title:      HOL/Proofs/Lambda/ListOrder.thy
    Author:     Tobias Nipkow
    Copyright   1998 TU Muenchen
*)

section \<open>Lifting an order to lists of elements\<close>

theory ListOrder
imports MainRLT
begin

declare [[syntax_ambiguity_warning = false]]

text \<open>
  Lifting an order to lists of elements, relating exactly one
  element.
\<close>

definition
  step1 :: "('a => 'a => bool) => 'a list => 'a list => bool" where
  "step1 r =
    (\<lambda>ys xs. \<exists>us z z' vs. xs = us @ z # vs \<and> r z' z \<and> ys =
      us @ z' # vs)"

lemma step1_converse [simp]: "step1 (r\<inverse>\<inverse>) = (step1 r)\<inverse>\<inverse>"
  apply (unfold step1_def)
  apply (blast intro!: order_antisym)
  done

lemma in_step1_converse [iff]: "(step1 (r\<inverse>\<inverse>) x y) = ((step1 r)\<inverse>\<inverse> x y)"
  apply auto
  done

lemma not_Nil_step1 [iff]: "\<not> step1 r [] xs"
  apply (unfold step1_def)
  apply blast
  done

lemma not_step1_Nil [iff]: "\<not> step1 r xs []"
  apply (unfold step1_def)
  apply blast
  done

lemma Cons_step1_Cons [iff]:
    "(step1 r (y # ys) (x # xs)) =
      (r y x \<and> xs = ys \<or> x = y \<and> step1 r ys xs)"
  apply (unfold step1_def)
  apply (rule iffI)
   apply (erule exE)
   apply (rename_tac ts)
   apply (case_tac ts)
    apply fastforce
   apply force
  apply (erule disjE)
   apply blast
  apply (blast intro: Cons_eq_appendI)
  done

lemma append_step1I:
  "step1 r ys xs \<and> vs = us \<or> ys = xs \<and> step1 r vs us
    ==> step1 r (ys @ vs) (xs @ us)"
  apply (unfold step1_def)
  apply auto
   apply blast
  apply (blast intro: append_eq_appendI)
  done

lemma Cons_step1E [elim!]:
  assumes "step1 r ys (x # xs)"
    and "!!y. ys = y # xs \<Longrightarrow> r y x \<Longrightarrow> R"
    and "!!zs. ys = x # zs \<Longrightarrow> step1 r zs xs \<Longrightarrow> R"
  shows R
  using assms
  apply (cases ys)
   apply (simp add: step1_def)
  apply blast
  done

lemma Snoc_step1_SnocD:
  "step1 r (ys @ [y]) (xs @ [x])
    ==> (step1 r ys xs \<and> y = x \<or> ys = xs \<and> r y x)"
  apply (unfold step1_def)
  apply (clarify del: disjCI)
  apply (rename_tac vs)
  apply (rule_tac xs = vs in rev_exhaust)
   apply force
  apply simp
  apply blast
  done

lemma Cons_acc_step1I [intro!]:
    "Wellfounded.accp r x ==> Wellfounded.accp (step1 r) xs \<Longrightarrow> Wellfounded.accp (step1 r) (x # xs)"
  apply (induct arbitrary: xs set: Wellfounded.accp)
  apply (erule thin_rl)
  apply (erule accp_induct)
  apply (rule accp.accI)
  apply blast
  done

lemma lists_accD: "listsp (Wellfounded.accp r) xs ==> Wellfounded.accp (step1 r) xs"
  apply (induct set: listsp)
   apply (rule accp.accI)
   apply simp
  apply (rule accp.accI)
  apply (fast dest: accp_downward)
  done

lemma ex_step1I:
  "[| x \<in> set xs; r y x |]
    ==> \<exists>ys. step1 r ys xs \<and> y \<in> set ys"
  apply (unfold step1_def)
  apply (drule in_set_conv_decomp [THEN iffD1])
  apply force
  done

lemma lists_accI: "Wellfounded.accp (step1 r) xs ==> listsp (Wellfounded.accp r) xs"
  apply (induct set: Wellfounded.accp)
  apply clarify
  apply (rule accp.accI)
  apply (drule_tac r=r in ex_step1I, assumption)
  apply blast
  done

end


(*  Title:      ZF/Induct/Acc.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>The accessible part of a relation\<close>

theory Acc imports ZF begin

text \<open>
  Inductive definition of \<open>acc(r)\<close>; see @{cite "paulin-tlca"}.
\<close>

consts
  acc :: "i \<Rightarrow> i"

inductive
  domains "acc(r)" \<subseteq> "field(r)"
  intros
    vimage:  "\<lbrakk>r-``{a}: Pow(acc(r)); a \<in> field(r)\<rbrakk> \<Longrightarrow> a \<in> acc(r)"
  monos      Pow_mono

text \<open>
  The introduction rule must require \<^prop>\<open>a \<in> field(r)\<close>,
  otherwise \<open>acc(r)\<close> would be a proper class!

  \medskip
  The intended introduction rule:
\<close>

lemma accI: "\<lbrakk>\<And>b. \<langle>b,a\<rangle>:r \<Longrightarrow> b \<in> acc(r);  a \<in> field(r)\<rbrakk> \<Longrightarrow> a \<in> acc(r)"
  by (blast intro: acc.intros)

lemma acc_downward: "\<lbrakk>b \<in> acc(r);  \<langle>a,b\<rangle>: r\<rbrakk> \<Longrightarrow> a \<in> acc(r)"
  by (erule acc.cases) blast

lemma acc_induct [consumes 1, case_names vimage, induct set: acc]:
    "\<lbrakk>a \<in> acc(r);
        \<And>x. \<lbrakk>x \<in> acc(r);  \<forall>y. \<langle>y,x\<rangle>:r \<longrightarrow> P(y)\<rbrakk> \<Longrightarrow> P(x)
\<rbrakk> \<Longrightarrow> P(a)"
  by (erule acc.induct) (blast intro: acc.intros)

lemma wf_on_acc: "wf[acc(r)](r)"
  apply (rule wf_onI2)
  apply (erule acc_induct)
  apply fast
  done

lemma acc_wfI: "field(r) \<subseteq> acc(r) \<Longrightarrow> wf(r)"
  by (erule wf_on_acc [THEN wf_on_subset_A, THEN wf_on_field_imp_wf])

lemma acc_wfD: "wf(r) \<Longrightarrow> field(r) \<subseteq> acc(r)"
  apply (rule subsetI)
  apply (erule wf_induct2, assumption)
   apply (blast intro: accI)+
  done

lemma wf_acc_iff: "wf(r) \<longleftrightarrow> field(r) \<subseteq> acc(r)"
  by (rule iffI, erule acc_wfD, erule acc_wfI)

end


theory Chapter16_4_Evaluation
imports Chapter16_3_Typechecking
begin

primrec is_val :: "expr => bool"
where "is_val (Var v) = False"
    | "is_val (Lam t e) = True"
    | "is_val (Appl e1 e2) = False"
    | "is_val Triv = True"
    | "is_val (Pair e1 e2) = (is_val e1 & is_val e2)"
    | "is_val (ProjL e) = False"
    | "is_val (ProjR e) = False"
    | "is_val (Abort t e) = False"
    | "is_val (Case et el er) = False"
    | "is_val (InL t1 t2 e) = is_val e"
    | "is_val (InR t1 t2 e) = is_val e"
    | "is_val (Fix t e) = False"
    | "is_val (Fold t e) = is_val e"
    | "is_val (Unfold e) = False"

inductive eval :: "expr => expr => bool"
where eval_appl_1 [simp]: "eval e1 e1' ==> eval (Appl e1 e2) (Appl e1' e2)"
    | eval_appl_2 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Appl e1 e2) (Appl e1 e2')"
    | eval_appl_3 [simp]: "is_val e2 ==> eval (Appl (Lam t2 e1) e2) (subst e2 first e1)"
    | eval_pair_1 [simp]: "eval e1 e1' ==> eval (Pair e1 e2) (Pair e1' e2)"
    | eval_pair_2 [simp]: "is_val e1 ==> eval e2 e2' ==> eval (Pair e1 e2) (Pair e1 e2')"
    | eval_projl_1 [simp]: "eval e e' ==> eval (ProjL e) (ProjL e')"
    | eval_projl_2 [simp]: "eval (ProjL (Pair e1 e2)) e1"
    | eval_projr_1 [simp]: "eval e e' ==> eval (ProjR e) (ProjR e')"
    | eval_projr_2 [simp]: "eval (ProjR (Pair e1 e2)) e2"
    | eval_abort [simp]: "eval e e' ==> eval (Abort t e) (Abort t e')"
    | eval_case_1 [simp]: "eval et et' ==> eval (Case et el er) (Case et' el er)"
    | eval_case_2 [simp]: "is_val e ==> eval (Case (InL t1 t2 e) el er) (subst e first el)"
    | eval_case_3 [simp]: "is_val e ==> eval (Case (InR t1 t2 e) el er) (subst e first er)"
    | eval_inl [simp]: "eval e e' ==> eval (InL t1 t2 e) (InL t1 t2 e')"
    | eval_inr [simp]: "eval e e' ==> eval (InR t1 t2 e) (InR t1 t2 e')"
    | eval_fix [simp]: "eval (Fix t e) (subst (Fix t e) first e)"
    | eval_fold [simp]: "eval e e' ==> eval (Fold t e) (Fold t e')"
    | eval_unfold_1 [simp]: "eval e e' ==> eval (Unfold e) (Unfold e')"
    | eval_unfold_2 [simp]: "is_val e ==> eval (Unfold (Fold t e)) e"

lemma canonical_arrow: "is_val e ==> typecheck gam e (Arrow t1 t2) ==>
              EX e'. e = Lam t1 e' & typecheck (extend gam t1) e' t2"
by (induction e, auto)

lemma canonical_unit: "is_val e ==> typecheck gam e Unit ==> e = Triv"
by (induction e, auto)

lemma canonical_prod: "is_val e ==> typecheck gam e (Prod t1 t2) ==>
              EX e1 e2. e = Pair e1 e2 & typecheck gam e1 t1 & typecheck gam e2 t2"
by (induction e, auto)

lemma canonical_void: "is_val e ==> typecheck gam e Void ==> False"
by (induction e, auto)

lemma canonical_sum: "is_val e ==> typecheck gam e (Sum t1 t2) ==>
          (EX e'. e = InL t1 t2 e' & typecheck gam e' t1) |
          (EX e'. e = InR t1 t2 e' & typecheck gam e' t2)"
by (induction e, auto)

lemma canonical_rec: "is_val e ==> typecheck gam e (Rec t) ==>
              EX e'. e = Fold t e' & typecheck gam e' (type_subst (Rec t) first t)"
by (induction e, auto)

theorem preservation: "eval e e' ==> typecheck gam e t ==> typecheck gam e' t"
by (induction e e' arbitrary: t rule: eval.induct, fastforce+)

theorem progress: "typecheck gam e t ==> gam = empty_env ==> is_val e | (EX e'. eval e e')"
proof (induction gam e t rule: typecheck.induct)
case tc_var
  thus ?case by simp
next case tc_lam
  thus ?case by simp
next case tc_appl
  thus ?case by (metis eval_appl_1 eval_appl_2 eval_appl_3 canonical_arrow)
next case tc_triv
  thus ?case by simp
next case tc_pair
  thus ?case by (metis eval_pair_1 eval_pair_2 is_val.simps(5))
next case tc_projl
  thus ?case by (metis eval_projl_1 eval_projl_2 canonical_prod)
next case tc_projr
  thus ?case by (metis eval_projr_1 eval_projr_2 canonical_prod)
next case tc_abort
  thus ?case by (metis eval_abort canonical_void)
next case tc_case
  thus ?case
  by (metis eval_case_1 eval_case_2 eval_case_3 is_val.simps(10) is_val.simps(11) canonical_sum)
next case tc_inl
  thus ?case by (metis eval_inl is_val.simps(10))
next case tc_inr
  thus ?case by (metis eval_inr is_val.simps(11))
next case tc_fix
  thus ?case by (metis eval_fix)
next case tc_fold
  thus ?case by (metis eval_fold is_val.simps(13))
next case tc_unfold
  thus ?case by (metis canonical_rec eval_unfold_1 eval_unfold_2 is_val.simps(13))
qed

end