header {* Helpers *}

theory Helpers imports
  "~~/src/HOL/Library/List_lexord"
begin

lemma Min_predicate: "finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> \<forall>x \<in> A. P x \<Longrightarrow> P (Min A)"
by auto

lemma fst_predicate: "P (fst p) \<Longrightarrow> (f, s) = p \<Longrightarrow> P f"
by auto

lemma Min_insert_leq: "finite A \<Longrightarrow> (x :: 'a :: linorder) \<le> y \<Longrightarrow> Min (insert x A) \<le> y"
by (cases "A = {}") (auto simp add: min_max.le_infI1)

lemma list_all2_Min:
  assumes "list_all2 less_eq xs ys"
    shows "Min (set (xs :: 'a :: linorder list)) \<le> Min (set ys)"
using assms apply (induct rule: list_all2_induct)
  using Min_insert_leq by auto (metis (no_types) List.finite_set List.set.simps(2)
    Min.coboundedI Min_in eq_iff insertCI list_all2_Nil min_def min_le_iff_disj set_empty)

lemma list_all2_map:
  assumes "\<forall>x \<in> set l. P (f x) (g x)"
    shows "list_all2 P (map f l) (map g l)"
using assms by (induct l) auto

(*****************************************************************************
  filter and partition lemmata
 *****************************************************************************)

lemma sum_length_filter_compl':
  "length (filter P l) + length (filter (Not \<circ> P) l) = length l"
by (induct l) simp_all

lemma partition_length: "(yes, no) = partition P l \<Longrightarrow> length l = length yes + length no"
by (auto simp add: sum_length_filter_compl')

lemma filter_length_smaller:
  assumes "yesh # yest = filter (P a) l"
    shows "length (filter (Not \<circ> P a) l) < length l"
proof -
  have S: "set (yesh # yest) \<subseteq> set l" using assms by auto

  have "P a yesh" using assms Cons_eq_filter_iff[of yesh] by auto
  then show ?thesis using S length_filter_less[of yesh] by auto
qed

lemma filter_one_empty_other_full: "(filter P l = []) \<Longrightarrow> (l = filter (Not \<circ> P) l)"
by (metis (mono_tags) Set.filter_def comp_apply filter_True in_set_member member_filter member_rec(2) set_filter)

lemma map_concat_len:
  "length (concat (map f l)) = (\<Sum>x\<leftarrow>l. length (f x))"
by (induct l) auto

lemma list_subset_trans:
  assumes "\<And>v. set v \<subseteq> A \<Longrightarrow> set v \<subseteq> B"
    shows "A \<subseteq> B" using assms
by (metis List.set_insert in_set_insert insert_Nil insert_subset not_Cons_self2 subsetI)

lemma list_smaller:
  assumes "length xs = length ys"
      and "\<forall>(x, y) \<in> set (zip xs ys). (x :: 'a :: order) \<le> y"
    shows "xs \<le> ys"
using assms by (induct rule: list_induct2) auto

end


(*
  File: RBTree.thy
  Author: Bohua Zhan
*)

section \<open>Red-black trees\<close>

theory RBTree
  imports Lists_Ex
begin

text \<open>
  Verification of functional red-black trees. For general technique,
  see Lists\_Ex.thy.
\<close>

subsection \<open>Definition of RBT\<close>

datatype color = R | B
datatype ('a, 'b) rbt =
    Leaf
  | Node (lsub: "('a, 'b) rbt") (cl: color) (key: 'a) (val: 'b) (rsub: "('a, 'b) rbt")
where
  "cl Leaf = B"

setup \<open>add_resolve_prfstep @{thm color.distinct(1)}\<close>
setup \<open>add_resolve_prfstep @{thm rbt.distinct(1)}\<close>
setup \<open>fold add_rewrite_rule @{thms rbt.sel}\<close>
setup \<open>add_forward_prfstep @{thm rbt.collapse}\<close>
setup \<open>add_var_induct_rule @{thm rbt.induct}\<close>

lemma not_R [forward]: "c \<noteq> R \<Longrightarrow> c = B" using color.exhaust by blast
lemma not_B [forward]: "c \<noteq> B \<Longrightarrow> c = R" using color.exhaust by blast
lemma red_not_leaf [forward]: "cl t = R \<Longrightarrow> t \<noteq> Leaf" by auto

subsection \<open>RBT invariants\<close>

fun black_depth :: "('a, 'b) rbt \<Rightarrow> nat" where
  "black_depth Leaf = 0"
| "black_depth (Node l R k v r) = black_depth l"
| "black_depth (Node l B k v r) = black_depth l + 1"
setup \<open>fold add_rewrite_rule @{thms black_depth.simps}\<close>

fun cl_inv :: "('a, 'b) rbt \<Rightarrow> bool" where
  "cl_inv Leaf = True"
| "cl_inv (Node l R k v r) = (cl_inv l \<and> cl_inv r \<and> cl l = B \<and> cl r = B)"
| "cl_inv (Node l B k v r) = (cl_inv l \<and> cl_inv r)"
setup \<open>fold add_rewrite_rule @{thms cl_inv.simps}\<close>

fun bd_inv :: "('a, 'b) rbt \<Rightarrow> bool" where
  "bd_inv Leaf = True"
| "bd_inv (Node l c k v r) = (bd_inv l \<and> bd_inv r \<and> black_depth l = black_depth r)"
setup \<open>fold add_rewrite_rule @{thms bd_inv.simps}\<close>

definition is_rbt :: "('a, 'b) rbt \<Rightarrow> bool" where [rewrite]:
  "is_rbt t = (cl_inv t \<and> bd_inv t)"

lemma cl_invI: "cl_inv l \<Longrightarrow> cl_inv r \<Longrightarrow> cl_inv (Node l B k v r)" by auto2
setup \<open>add_forward_prfstep_cond @{thm cl_invI} [with_term "Node ?l B ?k ?v ?r"]\<close>

lemma bd_invI: "bd_inv l \<Longrightarrow> bd_inv r \<Longrightarrow> black_depth l = black_depth r \<Longrightarrow> bd_inv (Node l c k v r)" by auto2
setup \<open>add_forward_prfstep_cond @{thm bd_invI} [with_term "Node ?l ?c ?k ?v ?r"]\<close>

lemma is_rbt_rec [forward]: "is_rbt (Node l c k v r) \<Longrightarrow> is_rbt l \<and> is_rbt r"
@proof @case "c = R" @qed

subsection \<open>Balancedness of RBT\<close>

(* TODO: remove after having general normalization procedure for nats. *)
lemma two_distrib [rewrite]: "(2::nat) * (a + 1) = 2 * a + 2" by simp

fun min_depth :: "('a, 'b) rbt \<Rightarrow> nat" where
  "min_depth Leaf = 0"
| "min_depth (Node l c k v r) = min (min_depth l) (min_depth r) + 1"
setup \<open>fold add_rewrite_rule @{thms min_depth.simps}\<close>

fun max_depth :: "('a, 'b) rbt \<Rightarrow> nat" where
  "max_depth Leaf = 0"
| "max_depth (Node l c k v r) = max (max_depth l) (max_depth r) + 1"
setup \<open>fold add_rewrite_rule @{thms max_depth.simps}\<close>

text \<open>Balancedness of red-black trees.\<close>
theorem rbt_balanced: "is_rbt t \<Longrightarrow> max_depth t \<le> 2 * min_depth t + 1"
@proof
  @induct t for "is_rbt t \<longrightarrow> black_depth t \<le> min_depth t" @with
    @subgoal "t = Node l c k v r" @case "c = R" @endgoal
  @end
  @induct t for "is_rbt t \<longrightarrow> (if cl t = R then max_depth t \<le> 2 * black_depth t + 1
                               else max_depth t \<le> 2 * black_depth t)" @with
    @subgoal "t = Node l c k v r" @case "c = R" @endgoal
  @end
  @have "max_depth t \<le> 2 * black_depth t + 1"
@qed

subsection \<open>Definition and basic properties of cl\_inv'\<close>

fun cl_inv' :: "('a, 'b) rbt \<Rightarrow> bool" where
  "cl_inv' Leaf = True"
| "cl_inv' (Node l c k v r) = (cl_inv l \<and> cl_inv r)"
setup \<open>fold add_rewrite_rule @{thms cl_inv'.simps}\<close>

lemma cl_inv'B [forward, backward1]:
  "cl_inv' t \<Longrightarrow> cl t = B \<Longrightarrow> cl_inv t"
@proof @case "t = Leaf" @qed

lemma cl_inv'R [forward]:
  "cl_inv' (Node l R k v r) \<Longrightarrow> cl l = B \<Longrightarrow> cl r = B \<Longrightarrow> cl_inv (Node l R k v r)" by auto2

lemma cl_inv_to_cl_inv' [forward]: "cl_inv t \<Longrightarrow> cl_inv' t"
@proof @case "t = Leaf" @case "cl t = R" @qed

lemma cl_inv'I [forward_arg]:
  "cl_inv l \<Longrightarrow> cl_inv r \<Longrightarrow> cl_inv' (Node l c k v r)" by auto

subsection \<open>Set of keys, sortedness\<close>

fun rbt_in_traverse :: "('a, 'b) rbt \<Rightarrow> 'a list" where
  "rbt_in_traverse Leaf = []"
| "rbt_in_traverse (Node l c k v r) = rbt_in_traverse l @ k # rbt_in_traverse r"
setup \<open>fold add_rewrite_rule @{thms rbt_in_traverse.simps}\<close>

fun rbt_set :: "('a, 'b) rbt \<Rightarrow> 'a set" where
  "rbt_set Leaf = {}"
| "rbt_set (Node l c k v r) = {k} \<union> rbt_set l \<union> rbt_set r"
setup \<open>fold add_rewrite_rule @{thms rbt_set.simps}\<close>

fun rbt_in_traverse_pairs :: "('a, 'b) rbt \<Rightarrow> ('a \<times> 'b) list" where
  "rbt_in_traverse_pairs Leaf = []"
| "rbt_in_traverse_pairs (Node l c k v r) = rbt_in_traverse_pairs l @ (k, v) # rbt_in_traverse_pairs r"
setup \<open>fold add_rewrite_rule @{thms rbt_in_traverse_pairs.simps}\<close>

lemma rbt_in_traverse_fst [rewrite]: "map fst (rbt_in_traverse_pairs t) = rbt_in_traverse t"
@proof @induct t @qed

definition rbt_map :: "('a, 'b) rbt \<Rightarrow> ('a, 'b) map" where
  "rbt_map t = map_of_alist (rbt_in_traverse_pairs t)"
setup \<open>add_rewrite_rule @{thm rbt_map_def}\<close>

fun rbt_sorted :: "('a::linorder, 'b) rbt \<Rightarrow> bool" where
  "rbt_sorted Leaf = True"
| "rbt_sorted (Node l c k v r) = ((\<forall>x\<in>rbt_set l. x < k) \<and> (\<forall>x\<in>rbt_set r. k < x) \<and> rbt_sorted l \<and> rbt_sorted r)"
setup \<open>fold add_rewrite_rule @{thms rbt_sorted.simps}\<close>

lemma rbt_sorted_lr [forward]:
  "rbt_sorted (Node l c k v r) \<Longrightarrow> rbt_sorted l \<and> rbt_sorted r" by auto2

lemma rbt_inorder_preserve_set [rewrite]:
  "rbt_set t = set (rbt_in_traverse t)"
@proof @induct t @qed

lemma rbt_inorder_sorted [rewrite]:
  "rbt_sorted t \<longleftrightarrow> strict_sorted (map fst (rbt_in_traverse_pairs t))"
@proof @induct t @qed

setup \<open>fold del_prfstep_thm (@{thms rbt_set.simps} @ @{thms rbt_sorted.simps})\<close>

subsection \<open>Balance function\<close>

definition balanceR :: "('a, 'b) rbt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where [rewrite]:
  "balanceR l k v r =
   (if cl r = R then
      let lr = lsub r; rr = rsub r in
      if cl lr = R then Node (Node l B k v (lsub lr)) R (key lr) (val lr) (Node (rsub lr) B (key r) (val r) rr)
      else if cl rr = R then Node (Node l B k v lr) R (key r) (val r) (Node (lsub rr) B (key rr) (val rr) (rsub rr))
      else Node l B k v r
    else Node l B k v r)"

definition balance :: "('a, 'b) rbt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where [rewrite]:
  "balance l k v r =
   (if cl l = R then
      let ll = lsub l; rl = rsub l in
      if cl ll = R then Node (Node (lsub ll) B (key ll) (val ll) (rsub ll)) R (key l) (val l) (Node (rsub l) B k v r)
      else if cl rl = R then Node (Node (lsub l) B (key l) (val l) (lsub rl)) R (key rl) (val rl) (Node (rsub rl) B k v r)
      else balanceR l k v r
    else balanceR l k v r)"
setup \<open>register_wellform_data ("balance l k v r", ["black_depth l = black_depth r"])\<close>
setup \<open>add_prfstep_check_req ("balance l k v r", "black_depth l = black_depth r")\<close>

lemma balance_non_Leaf [resolve]: "balance l k v r \<noteq> Leaf" by auto2

lemma balance_bdinv [forward_arg]:
  "bd_inv l \<Longrightarrow> bd_inv r \<Longrightarrow> black_depth l = black_depth r \<Longrightarrow> bd_inv (balance l k v r)"
@proof @have "bd_inv (balanceR l k v r)" @qed

lemma balance_bd [rewrite]:
  "bd_inv l \<Longrightarrow> bd_inv r \<Longrightarrow> black_depth l = black_depth r \<Longrightarrow>
   black_depth (balance l k v r) = black_depth l + 1"
@proof @have "black_depth (balanceR l k v r) = black_depth l + 1" @qed

lemma balance_cl1 [forward]:
  "cl_inv' l \<Longrightarrow> cl_inv r \<Longrightarrow> cl_inv (balance l k v r)" by auto2

lemma balance_cl2 [forward]:
  "cl_inv l \<Longrightarrow> cl_inv' r \<Longrightarrow> cl_inv (balance l k v r)" by auto2

lemma balanceR_inorder_pairs [rewrite]:
  "rbt_in_traverse_pairs (balanceR l k v r) = rbt_in_traverse_pairs l @ (k, v) # rbt_in_traverse_pairs r" by auto2

lemma balance_inorder_pairs [rewrite]:
  "rbt_in_traverse_pairs (balance l k v r) = rbt_in_traverse_pairs l @ (k, v) # rbt_in_traverse_pairs r" by auto2

setup \<open>fold del_prfstep_thm [@{thm balanceR_def}, @{thm balance_def}]\<close>

subsection \<open>ins function\<close>

fun ins :: "'a::order \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where
  "ins x v Leaf = Node Leaf R x v Leaf"
| "ins x v (Node l c y w r) =
   (if c = B then
     (if x = y then Node l B x v r
      else if x < y then balance (ins x v l) y w r
      else balance l y w (ins x v r))
    else
     (if x = y then Node l R x v r
      else if x < y then Node (ins x v l) R y w r
      else Node l R y w (ins x v r)))"
setup \<open>fold add_rewrite_rule @{thms ins.simps}\<close>

lemma ins_non_Leaf [resolve]: "ins x v t \<noteq> Leaf"
@proof @case "t = Leaf" @qed

lemma cl_inv_ins [forward]:
  "cl_inv t \<Longrightarrow> cl_inv' (ins x v t)"
@proof
  @induct t for "cl_inv t \<longrightarrow> (if cl t = B then cl_inv (ins x v t) else cl_inv' (ins x v t))"
@qed

lemma bd_inv_ins:
  "bd_inv t \<Longrightarrow> bd_inv (ins x v t) \<and> black_depth t = black_depth (ins x v t)"
@proof @induct t @qed
setup \<open>add_forward_prfstep_cond (conj_left_th @{thm bd_inv_ins}) [with_term "ins ?x ?v ?t"]\<close>

lemma ins_inorder_pairs [rewrite]:
  "rbt_sorted t \<Longrightarrow> rbt_in_traverse_pairs (ins x v t) = ordered_insert_pairs x v (rbt_in_traverse_pairs t)"
@proof @induct t @qed

subsection \<open>Paint function\<close>

fun paint :: "color \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where
  "paint c Leaf = Leaf"
| "paint c (Node l c' x v r) = Node l c x v r"
setup \<open>fold add_rewrite_rule @{thms paint.simps}\<close>
setup \<open>register_wellform_data ("paint c t", ["t \<noteq> Leaf"])\<close>
setup \<open>add_prfstep_check_req ("paint c t", "t \<noteq> Leaf")\<close>

lemma paint_cl_inv' [forward]: "cl_inv' t \<Longrightarrow> cl_inv' (paint c t)" by auto2

lemma paint_bd_inv [forward]: "bd_inv t \<Longrightarrow> bd_inv (paint c t)" by auto2

lemma paint_bd [rewrite]:
  "bd_inv t \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> cl t = B \<Longrightarrow> black_depth (paint R t) = black_depth t - 1" by auto2

lemma paint_in_traverse_pairs [rewrite]:
  "rbt_in_traverse_pairs (paint c t) = rbt_in_traverse_pairs t" by auto2

subsection \<open>Insert function\<close>

definition rbt_insert :: "'a::order \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where [rewrite]:
  "rbt_insert x v t = paint B (ins x v t)"

text \<open>Correctness results for insertion.\<close>
theorem insert_is_rbt [forward]:
  "is_rbt t \<Longrightarrow> is_rbt (rbt_insert x v t)" by auto2

theorem insert_sorted [forward]:
  "rbt_sorted t \<Longrightarrow> rbt_sorted (rbt_insert x v t)" by auto2

theorem insert_rbt_map [rewrite]:
  "rbt_sorted t \<Longrightarrow> rbt_map (rbt_insert x v t) = (rbt_map t) {x \<rightarrow> v}" by auto2

subsection \<open>Search on sorted trees and its correctness\<close>

fun rbt_search :: "('a::ord, 'b) rbt \<Rightarrow> 'a \<Rightarrow> 'b option" where
  "rbt_search Leaf x = None"
| "rbt_search (Node l c y w r) x =
  (if x = y then Some w
   else if x < y then rbt_search l x
   else rbt_search r x)"
setup \<open>fold add_rewrite_rule @{thms rbt_search.simps}\<close>

text \<open>Correctness of search\<close>
theorem rbt_search_correct [rewrite]:
  "rbt_sorted t \<Longrightarrow> rbt_search t x = (rbt_map t)\<langle>x\<rangle>"
@proof @induct t @qed

subsection \<open>balL and balR\<close>

definition balL :: "('a, 'b) rbt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where [rewrite]:
  "balL l k v r = (let lr = lsub r in
   if cl l = R then Node (Node (lsub l) B (key l) (val l) (rsub l)) R k v r
   else if r = Leaf then Node l R k v r
   else if cl r = B then balance l k v (Node (lsub r) R (key r) (val r) (rsub r))
   else if lr = Leaf then Node l R k v r
   else if cl lr = B then
     Node (Node l B k v (lsub lr)) R (key lr) (val lr) (balance (rsub lr) (key r) (val r) (paint R (rsub r)))
   else Node l R k v r)"
setup \<open>register_wellform_data ("balL l k v r", ["black_depth l + 1 = black_depth r"])\<close>
setup \<open>add_prfstep_check_req ("balL l k v r", "black_depth l + 1 = black_depth r")\<close>

definition balR :: "('a, 'b) rbt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where [rewrite]:
  "balR l k v r = (let rl = rsub l in
   if cl r = R then Node l R k v (Node (lsub r) B (key r) (val r) (rsub r))
   else if l = Leaf then Node l R k v r
   else if cl l = B then balance (Node (lsub l) R (key l) (val l) (rsub l)) k v r
   else if rl = Leaf then Node l R k v r
   else if cl rl = B then
     Node (balance (paint R (lsub l)) (key l) (val l) (lsub rl)) R (key rl) (val rl) (Node (rsub rl) B k v r)
   else Node l R k v r)"
setup \<open>register_wellform_data ("balR l k v r", ["black_depth l = black_depth r + 1"])\<close>
setup \<open>add_prfstep_check_req ("balR l k v r", "black_depth l = black_depth r + 1")\<close>

lemma balL_bd [forward_arg]:
  "bd_inv l \<Longrightarrow> bd_inv r \<Longrightarrow> cl r = B \<Longrightarrow> black_depth l + 1 = black_depth r \<Longrightarrow>
   bd_inv (balL l k v r) \<and> black_depth (balL l k v r) = black_depth l + 1" by auto2

lemma balL_bd' [forward_arg]:
  "bd_inv l \<Longrightarrow> bd_inv r \<Longrightarrow> cl_inv r \<Longrightarrow> black_depth l + 1 = black_depth r \<Longrightarrow>
   bd_inv (balL l k v r) \<and> black_depth (balL l k v r) = black_depth l + 1" by auto2

lemma balL_cl [forward_arg]:
  "cl_inv' l \<Longrightarrow> cl_inv r \<Longrightarrow> cl r = B \<Longrightarrow> cl_inv (balL l k v r)" by auto2

lemma balL_cl' [forward]:
  "cl_inv' l \<Longrightarrow> cl_inv r \<Longrightarrow> cl_inv' (balL l k v r)" by auto2

lemma balR_bd [forward_arg]:
  "bd_inv l \<Longrightarrow> bd_inv r \<Longrightarrow> cl_inv l \<Longrightarrow> black_depth l = black_depth r + 1 \<Longrightarrow>
   bd_inv (balR l k v r) \<and> black_depth (balR l k v r) = black_depth l" by auto2

lemma balR_cl [forward_arg]:
  "cl_inv l \<Longrightarrow> cl_inv' r \<Longrightarrow> cl l = B \<Longrightarrow> cl_inv (balR l k v r)" by auto2

lemma balR_cl' [forward]:
  "cl_inv l \<Longrightarrow> cl_inv' r \<Longrightarrow> cl_inv' (balR l k v r)" by auto2

lemma balL_in_traverse_pairs [rewrite]:
  "rbt_in_traverse_pairs (balL l k v r) = rbt_in_traverse_pairs l @ (k, v) # rbt_in_traverse_pairs r" by auto2

lemma balR_in_traverse_pairs [rewrite]:
  "rbt_in_traverse_pairs (balR l k v r) = rbt_in_traverse_pairs l @ (k, v) # rbt_in_traverse_pairs r" by auto2

setup \<open>fold del_prfstep_thm [@{thm balL_def}, @{thm balR_def}]\<close>

subsection \<open>Combine\<close>

fun combine :: "('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where
  "combine Leaf t = t"
| "combine t Leaf = t"
| "combine (Node l1 c1 k1 v1 r1) (Node l2 c2 k2 v2 r2) = (
   if c1 = R then
     if c2 = R then
       let tm = combine r1 l2 in
         if cl tm = R then
           Node (Node l1 R k1 v1 (lsub tm)) R (key tm) (val tm) (Node (rsub tm) R k2 v2 r2)
         else
           Node l1 R k1 v1 (Node tm R k2 v2 r2)
     else
       Node l1 R k1 v1 (combine r1 (Node l2 c2 k2 v2 r2))
   else
     if c2 = B then
       let tm = combine r1 l2 in
         if cl tm = R then
           Node (Node l1 B k1 v1 (lsub tm)) R (key tm) (val tm) (Node (rsub tm) B k2 v2 r2)
         else
           balL l1 k1 v1 (Node tm B k2 v2 r2)
     else
       Node (combine (Node l1 c1 k1 v1 r1) l2) R k2 v2 r2)"
setup \<open>fold add_rewrite_rule @{thms combine.simps(1,2)}\<close>

lemma combine_bd [forward_arg]:
  "bd_inv lt \<Longrightarrow> bd_inv rt \<Longrightarrow> black_depth lt = black_depth rt \<Longrightarrow>
   bd_inv (combine lt rt) \<and> black_depth (combine lt rt) = black_depth lt"
@proof @fun_induct "combine lt rt" @with
  @subgoal "(lt = Node l1 c1 k1 v1 r1, rt = Node l2 c2 k2 v2 r2)"
    @unfold "combine (Node l1 c1 k1 v1 r1) (Node l2 c2 k2 v2 r2)"
    @case "c1 = B" @with @case "c2 = B" @with @case "cl (combine r1 l2) = B" @with
      @have "cl (Node (combine r1 l2) B k2 v2 r2) = B" @end @end @end
  @endgoal @end
@qed

lemma combine_cl:
  "cl_inv lt \<Longrightarrow> cl_inv rt \<Longrightarrow>
   (cl lt = B \<longrightarrow> cl rt = B \<longrightarrow> cl_inv (combine lt rt)) \<and> cl_inv' (combine lt rt)"
@proof @fun_induct "combine lt rt" @with
  @subgoal "(lt = Node l1 c1 k1 v1 r1, rt = Node l2 c2 k2 v2 r2)"
    @unfold "combine (Node l1 c1 k1 v1 r1) (Node l2 c2 k2 v2 r2)"
    @case "c1 = B" @with @case "c2 = B" @with @case "cl (combine r1 l2) = B" @with
      @have "cl (Node (combine r1 l2) B k2 v2 r2) = B" @end @end @end
  @endgoal @end
@qed
setup \<open>add_forward_prfstep_cond @{thm combine_cl} [with_term "combine ?lt ?rt"]\<close>

lemma combine_in_traverse_pairs [rewrite]:
  "rbt_in_traverse_pairs (combine lt rt) = rbt_in_traverse_pairs lt @ rbt_in_traverse_pairs rt"
@proof @fun_induct "combine lt rt" @with
  @subgoal "(lt = Node l1 c1 k1 v1 r1, rt = Node l2 c2 k2 v2 r2)"
    @unfold "combine (Node l1 c1 k1 v1 r1) (Node l2 c2 k2 v2 r2)"
    @case "c1 = R" @with @case "c2 = R" @with @case "cl (combine r1 l2) = R" @with
      @have "rbt_in_traverse_pairs (combine (Node l1 c1 k1 v1 r1) (Node l2 c2 k2 v2 r2)) =
             rbt_in_traverse_pairs l1 @ (k1, v1) # rbt_in_traverse_pairs (combine r1 l2) @ (k2, v2) # rbt_in_traverse_pairs r2"
    @end @end @end
    @case "c1 = B" @with @case "c2 = B" @with @case "cl (combine r1 l2) = R" @with
      @have "rbt_in_traverse_pairs (combine (Node l1 c1 k1 v1 r1) (Node l2 c2 k2 v2 r2)) =
             rbt_in_traverse_pairs l1 @ (k1, v1) # rbt_in_traverse_pairs (combine r1 l2) @ (k2, v2) # rbt_in_traverse_pairs r2"
    @end @end @end
  @endgoal @end
@qed

subsection \<open>Deletion\<close>

fun del :: "'a::linorder \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where
  "del x Leaf = Leaf"
| "del x (Node l _ k v r) =
    (if x = k then combine l r
     else if x < k then
       if l = Leaf then Node Leaf R k v r
       else if cl l = B then balL (del x l) k v r
       else Node (del x l) R k v r
     else
       if r = Leaf then Node l R k v Leaf
       else if cl r = B then balR l k v (del x r)
       else Node l R k v (del x r))"
setup \<open>add_rewrite_rule @{thm del.simps(1)}\<close>

lemma del_cl:
  "cl_inv t \<Longrightarrow> if cl t = R then cl_inv (del x t) else cl_inv' (del x t)"
@proof @induct t @with
  @subgoal "t = Node l c k v r"
    @unfold "del x (Node l c k v r)"
    @case "x = k" @case "x < k"
  @endgoal @end
@qed
setup \<open>add_forward_prfstep_cond @{thm del_cl} [with_term "del ?x ?t"]\<close>

lemma del_in_traverse_pairs [rewrite]:
  "rbt_sorted t \<Longrightarrow> rbt_in_traverse_pairs (del x t) = remove_elt_pairs x (rbt_in_traverse_pairs t)"
@proof @induct t @with
  @subgoal "t = Node l c k v r"
    @unfold "del x (Node l c k v r)"
  @endgoal @end
@qed

definition delete :: "'a::linorder \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where [rewrite]:
  "delete x t = paint B (del x t)"

text \<open>Correctness results for deletion.\<close>
theorem delete_is_rbt [forward]:
  "is_rbt t \<Longrightarrow> is_rbt (delete x t)" by auto2

theorem delete_sorted [forward]:
  "rbt_sorted t \<Longrightarrow> rbt_sorted (delete x t)" by auto2

theorem delete_rbt_map [rewrite]:
  "rbt_sorted t \<Longrightarrow> rbt_map (delete x t) = delete_map x (rbt_map t)" by auto2

setup \<open>del_prfstep "RBTree.balance_case"\<close>
setup \<open>del_prfstep "RBTree.balL_case"\<close>
setup \<open>del_prfstep "RBTree.balR_case"\<close>
setup \<open>del_prfstep "RBTree.paint_case"\<close>

end


(*  Title:      HOL/SPARK/SPARK_Setup.thy
    Author:     Stefan Berghofer
    Copyright:  secunet Security Networks AG

Setup for SPARK/Ada verification environment.
*)

theory SPARK_Setup
imports "~~/src/HOL/Word/Word" "~~/src/HOL/Word/Bit_Comparison"
keywords
  "spark_open_vcg" :: thy_load ("vcg", "fdl", "rls") and
  "spark_open" :: thy_load ("siv", "fdl", "rls") and
  "spark_proof_functions" "spark_types" "spark_end" :: thy_decl and
  "spark_vc" :: thy_goal and
  "spark_status" :: diag
begin

ML_file "Tools/fdl_lexer.ML"
ML_file "Tools/fdl_parser.ML"

text \<open>
SPARK version of div, see section 4.4.1.1 of SPARK Proof Manual
\<close>

definition sdiv :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "sdiv" 70) where
  "a sdiv b = sgn a * sgn b * (\<bar>a\<bar> div \<bar>b\<bar>)"

lemma sdiv_minus_dividend: "- a sdiv b = - (a sdiv b)"
  by (simp add: sdiv_def sgn_if)

lemma sdiv_minus_divisor: "a sdiv - b = - (a sdiv b)"
  by (simp add: sdiv_def sgn_if)

text \<open>
Correspondence between HOL's and SPARK's version of div
\<close>

lemma sdiv_pos_pos: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a sdiv b = a div b"
  by (simp add: sdiv_def sgn_if)

lemma sdiv_pos_neg: "0 \<le> a \<Longrightarrow> b < 0 \<Longrightarrow> a sdiv b = - (a div - b)"
  by (simp add: sdiv_def sgn_if)

lemma sdiv_neg_pos: "a < 0 \<Longrightarrow> 0 \<le> b \<Longrightarrow> a sdiv b = - (- a div b)"
  by (simp add: sdiv_def sgn_if)

lemma sdiv_neg_neg: "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> a sdiv b = - a div - b"
  by (simp add: sdiv_def sgn_if)

text \<open>
Updating a function at a set of points. Useful for building arrays.
\<close>

definition fun_upds :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b" where
  "fun_upds f xs y z = (if z \<in> xs then y else f z)"

syntax
  "_updsbind" :: "['a, 'a] => updbind"             ("(2_ [:=]/ _)")

translations
  "f(xs[:=]y)" == "CONST fun_upds f xs y"

lemma fun_upds_in [simp]: "z \<in> xs \<Longrightarrow> (f(xs [:=] y)) z = y"
  by (simp add: fun_upds_def)

lemma fun_upds_notin [simp]: "z \<notin> xs \<Longrightarrow> (f(xs [:=] y)) z = f z"
  by (simp add: fun_upds_def)

lemma upds_singleton [simp]: "f({x} [:=] y) = f(x := y)"
  by (simp add: fun_eq_iff)

text \<open>Enumeration types\<close>

class spark_enum = ord + finite +
  fixes pos :: "'a \<Rightarrow> int"
  assumes range_pos: "range pos = {0..<int (card (UNIV::'a set))}"
  and less_pos: "(x < y) = (pos x < pos y)"
  and less_eq_pos: "(x \<le> y) = (pos x \<le> pos y)"
begin

definition "val = inv pos"

definition "succ x = val (pos x + 1)"

definition "pred x = val (pos x - 1)"

lemma inj_pos: "inj pos"
  using finite_UNIV
  by (rule eq_card_imp_inj_on) (simp add: range_pos)

lemma val_pos: "val (pos x) = x"
  unfolding val_def using inj_pos
  by (rule inv_f_f)

lemma pos_val: "z \<in> range pos \<Longrightarrow> pos (val z) = z"
  unfolding val_def
  by (rule f_inv_into_f)

subclass linorder
proof
  fix x::'a and y show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (simp add: less_pos less_eq_pos less_le_not_le)
next
  fix x::'a show "x \<le> x" by (simp add: less_eq_pos)
next
  fix x::'a and y z assume "x \<le> y" and "y \<le> z"
  then show "x \<le> z" by (simp add: less_eq_pos)
next
  fix x::'a and y assume "x \<le> y" and "y \<le> x"
  with inj_pos show "x = y"
    by (auto dest: injD simp add: less_eq_pos)
next
  fix x::'a and y show "x \<le> y \<or> y \<le> x"
    by (simp add: less_eq_pos linear)
qed

definition "first_el = val 0"

definition "last_el = val (int (card (UNIV::'a set)) - 1)"

lemma first_el_smallest: "first_el \<le> x"
proof -
  have "pos x \<in> range pos" by (rule rangeI)
  then have "pos (val 0) \<le> pos x"
    by (simp add: range_pos pos_val)
  then show ?thesis by (simp add: first_el_def less_eq_pos)
qed

lemma last_el_greatest: "x \<le> last_el"
proof -
  have "pos x \<in> range pos" by (rule rangeI)
  then have "pos x \<le> pos (val (int (card (UNIV::'a set)) - 1))"
    by (simp add: range_pos pos_val)
  then show ?thesis by (simp add: last_el_def less_eq_pos)
qed

lemma pos_succ:
  assumes "x \<noteq> last_el"
  shows "pos (succ x) = pos x + 1"
proof -
  have "x \<le> last_el" by (rule last_el_greatest)
  with assms have "x < last_el" by simp
  then have "pos x < pos last_el"
    by (simp add: less_pos)
  with rangeI [of pos x]
  have "pos x + 1 \<in> range pos"
    by (simp add: range_pos last_el_def pos_val)
  then show ?thesis
    by (simp add: succ_def pos_val)
qed

lemma pos_pred:
  assumes "x \<noteq> first_el"
  shows "pos (pred x) = pos x - 1"
proof -
  have "first_el \<le> x" by (rule first_el_smallest)
  with assms have "first_el < x" by simp
  then have "pos first_el < pos x"
    by (simp add: less_pos)
  with rangeI [of pos x]
  have "pos x - 1 \<in> range pos"
    by (simp add: range_pos first_el_def pos_val)
  then show ?thesis
    by (simp add: pred_def pos_val)
qed

lemma succ_val: "x \<in> range pos \<Longrightarrow> succ (val x) = val (x + 1)"
  by (simp add: succ_def pos_val)

lemma pred_val: "x \<in> range pos \<Longrightarrow> pred (val x) = val (x - 1)"
  by (simp add: pred_def pos_val)

end

lemma interval_expand:
  "x < y \<Longrightarrow> (z::int) \<in> {x..<y} = (z = x \<or> z \<in> {x+1..<y})"
  by auto

text \<open>Load the package\<close>

ML_file "Tools/spark_vcs.ML"
ML_file "Tools/spark_commands.ML"

end


(*
  File:     Newman_Ingham_Tauberian.thy
  Author:   Manuel Eberl (TU München)

  A proof of Newman's "analytic theorem", originally stated by Ingham
*)
section \<open>Ingham's Tauberian Theorem\<close>
theory Newman_Ingham_Tauberian
imports
  "HOL-Real_Asymp.Real_Asymp"
  Prime_Number_Theorem_Library
begin

text \<open>
  In his proof of the Prime Number Theorem, Newman~\<^cite>\<open>"newman1998analytic"\<close> uses a Tauberian
  theorem that was first proven by Ingham. Newman gives a nice and straightforward proof of this
  theorem based on contour integration. This section will be concerned with proving this theorem.

  This Tauberian theorem is probably the part of the Newman's proof of the Prime Number Theorem
  where most of the ``heavy lifting'' is done. Its purpose is to extend the summability of a
  Dirichlet series with bounded coefficients from the region $\mathfrak{R}(s)>1$ to
  $\mathfrak{R}(s)\geq 1$.

  In order to show it, we first require a number of auxiliary bounding lemmas.
\<close>
lemma newman_ingham_aux1:
  fixes R :: real and z :: complex
  assumes R: "R > 0" and z : "norm z = R"
  shows   "norm (1 / z + z / R\<^sup>2) = 2 * \<bar>Re z\<bar> / R\<^sup>2"
proof -
  from z and R have [simp]: "z \<noteq> 0" by auto
  have "1 / z + z / R\<^sup>2 = (R\<^sup>2 + z\<^sup>2) * (1 / R\<^sup>2 / z)" using R
    by (simp add: field_simps power2_eq_square)
  also have "norm \<dots> = norm (R\<^sup>2 + z\<^sup>2) / R ^ 3"
    by (simp add: numeral_3_eq_3 z norm_divide norm_mult power2_eq_square)
  also have "R\<^sup>2 + z\<^sup>2 = z * (z + cnj z)" using complex_norm_square[of z]
    by (simp add: z power2_eq_square algebra_simps)
  also have "norm \<dots> = 2 * \<bar>Re z\<bar> * R"
    by (subst complex_add_cnj) (simp_all add: z norm_mult)
  also have "\<dots> / R ^ 3 = 2 * \<bar>Re z\<bar> / R\<^sup>2"
    using R by (simp add: field_simps numeral_3_eq_3 power2_eq_square)
  finally show ?thesis .
qed

lemma newman_ingham_aux2:
  fixes m :: nat and w z :: complex
  assumes "1 \<le> m" "1 \<le> Re w" "0 < Re z" and f: "\<And>n. 1 \<le> n \<Longrightarrow> norm (f n) \<le> C"
  shows "norm (\<Sum>n=1..m. f n / n powr (w - z)) \<le> C * (m powr Re z) * (1 / m + 1 / Re z)"
proof -
  have [simp]: "C \<ge> 0" by (rule order.trans[OF _ f[of 1]]) auto
  have "norm (\<Sum>n=1..m. f n / n powr (w - z)) \<le> (\<Sum>n=1..m. C / n powr (1 - Re z))"
    by (rule sum_norm_le)
       (insert assms, auto simp: norm_divide norm_powr_real_powr intro!: frac_le assms powr_mono)
  also have "\<dots> = C * (\<Sum>n=1..m. n powr (Re z - 1))"
    by (subst sum_distrib_left) (simp_all add: powr_diff)
  also have "\<dots> \<le> C * (m powr Re z * (1 / Re z + 1 / m))"
    using zeta_partial_sum_le'[of "Re z" m] assms by (intro mult_left_mono) auto
  finally show ?thesis by (simp add: mult_ac add_ac)
qed

lemma hurwitz_zeta_real_bound_aux:
  fixes a x :: real
  assumes ax: "a > 0" "x > 1"
  shows "(\<Sum>i. (a + real (Suc i)) powr (-x)) \<le> a powr (1 - x) / (x - 1)"
proof (rule decreasing_sum_le_integral, goal_cases)
  have "((\<lambda>t. (a + t) powr -x) has_integral -(a powr (-x + 1)) / (-x + 1)) (interior {0..})"
    using powr_has_integral_at_top[of 0 a "-x"] using ax by (simp add: interior_real_atLeast)
  also have "-(a powr (- x + 1)) / (- x + 1) = a powr (1 - x) / (x - 1)"
    using ax by (simp add: field_simps)
  finally show "((\<lambda>t. (a + t) powr -x) has_integral a powr (1 - x) / (x - 1)) {0..}"
    by (subst (asm) has_integral_interior) auto
qed (insert ax, auto intro!: powr_mono2')

text \<open>
  Given a function that is analytic on some vertical line segment, we can find a rectangle
  around that line segment on which the function is also analytic.
\<close>
lemma analytic_on_axis_extend:
  fixes y1 y2 x :: real
  defines "S \<equiv> {z. Re z = x \<and> Im z \<in> {y1..y2}}"
  assumes "y1 \<le> y2"
  assumes "f analytic_on S"
  obtains x1 x2 :: real where "x1 < x" "x2 > x" "f analytic_on cbox (Complex x1 y1) (Complex x2 y2)"
proof -
  define C where "C = {box a b |a b z. f analytic_on box a b \<and> z \<in> box a b \<and> z \<in> S}"
  have "S = cbox (Complex x y1) (Complex x y2)"
    by (auto simp: S_def in_cbox_complex_iff)
  also have "compact \<dots>" by simp
  finally have 1: "compact S" .

  have 2: "S \<subseteq> \<Union>C"
  proof (intro subsetI)
    fix z assume "z \<in> S"
    from \<open>f analytic_on S\<close> and this obtain a b where "z \<in> box a b" "f analytic_on box a b"
      by (blast elim: analytic_onE_box)
    with \<open>z \<in> S\<close> show "z \<in> \<Union>C" unfolding C_def by blast
  qed

  have 3: "open X" if "X \<in> C" for X using that by (auto simp: C_def)
  from compactE[OF 1 2 3] obtain T where T: "T \<subseteq> C" "finite T" "S \<subseteq> \<Union>T"
    by blast

  define x1 where "x1 = Max (insert (x - 1) ((\<lambda>X. x + (Inf (Re ` X) - x) / 2) ` T))"
  define x2 where "x2 = Min (insert (x + 1) ((\<lambda>X. x + (Sup (Re ` X) - x) / 2) ` T))"

  have *: "x + (Inf (Re ` X) - x) / 2 < x \<and> x + (Sup (Re ` X) - x) / 2 > x" if "X \<in> T" for X
  proof -
    from that and T obtain a b s where [simp]: "X = box a b" and s: "s \<in> box a b" "s \<in> S"
      by (force simp: C_def)
    hence le: "Re a < Re b" "Im a < Im b" by (auto simp: in_box_complex_iff)
    show ?thesis using le s
      unfolding \<open>X = box a b\<close> Re_image_box[OF le] Im_image_box[OF le]
      by (auto simp: S_def in_box_complex_iff)
  qed
  from * T have "x1 < x" unfolding x1_def by (subst Max_less_iff) auto
  from * T have "x2 > x" unfolding x2_def by (subst Min_gr_iff) auto

  have "f analytic_on (\<Union>T)"
    using T by (subst analytic_on_Union) (auto simp: C_def)
  moreover have "z \<in> \<Union>T" if "z \<in> cbox (Complex x1 y1) (Complex x2 y2)" for z
  proof -
    from that have "Complex x (Im z) \<in> S"
      by (auto simp: in_cbox_complex_iff S_def)
    with T obtain X where X: "X \<in> T" "Complex x (Im z) \<in> X"
      by auto
    with T obtain a b where [simp]: "X = box a b" by (auto simp: C_def)
    from X have le: "Re a < Re b" "Im a < Im b" by (auto simp: in_box_complex_iff)

    from that have "Re z \<le> x2" by (simp add: in_cbox_complex_iff)
    also have "\<dots> \<le> x + (Sup (Re ` X) - x) / 2"
      unfolding x2_def by (rule Min.coboundedI)(use T X in auto)
    also have "\<dots> = (x + Re b) / 2"
      using le unfolding \<open>X = box a b\<close> Re_image_box[OF le] by (simp add: field_simps)
    also have "\<dots> < (Re b + Re b) / 2"
      using X by (intro divide_strict_right_mono add_strict_right_mono)
                 (auto simp: in_box_complex_iff)
    also have "\<dots> = Re b" by simp
    finally have [simp]: "Re z < Re b" .

    have "Re a = (Re a + Re a) / 2" by simp
    also have "\<dots> < (x + Re a) / 2"
      using X by (intro divide_strict_right_mono add_strict_right_mono)
                 (auto simp: in_box_complex_iff)
    also have "\<dots> = x + (Inf (Re ` X) - x) / 2"
      using le unfolding \<open>X = box a b\<close> Re_image_box[OF le] by (simp add: field_simps)
    also have "\<dots> \<le> x1" unfolding x1_def by (rule Max.coboundedI)(use T X in auto)
    also have "\<dots> \<le> Re z" using that by (simp add: in_cbox_complex_iff)
    finally have [simp]: "Re z > Re a" .

    from X have "z \<in> X" by (simp add: in_box_complex_iff)
    with T X show ?thesis by blast
  qed
  hence "cbox (Complex x1 y1) (Complex x2 y2) \<subseteq> \<Union>T" by blast
  ultimately have "f analytic_on cbox (Complex x1 y1) (Complex x2 y2)"
    by (rule analytic_on_subset)

  with \<open>x1 < x\<close> and \<open>x2 > x\<close> and that[of x1 x2] show ?thesis by blast
qed

text \<open>
  We will now prove the theorem. The precise setting is this:
  Consider a Dirichlet series $F(s) = \sum a_n n^{-s}$ with bounded coefficients. Clearly,
  this converges to an analytic function $f(s)$ on $\{s\mid \mathfrak R(s)>1\}$.

  If $f(s)$ is analytic on the larger set $\{s\mid \mathfrak R(s)\geq 1\}$, $F$ converges
  to $f(s)$ for all $\mathfrak R(s) \geq 1$.

  The proof follows Newman's argument very closely, but some of the precise bounds we use
  are a bit different from his. Also, like Harrison, we choose a combination of a semicircle
  and a rectangle as our contour, whereas Newman uses a circle with a vertical cut-off. The result
  of the Residue theorem is the same in both cases, but the bounding of the contributions of the
  different parts is somewhat different.

  The reason why we picked Harrison's contour over Newman's is because we could not understand how
  his bounding of the different contributions fits to his contour, and it seems likely that this
  is also the reason why Harrison altered the contour in the first place.
\<close>
lemma Newman_Ingham_1:
  fixes F :: "complex fds" and f :: "complex \<Rightarrow> complex"
  assumes coeff_bound:   "fds_nth F \<in> O(\<lambda>_. 1)"
  assumes f_analytic:    "f analytic_on {s. Re s \<ge> 1}"
  assumes F_conv_f:      "\<And>s. Re s > 1 \<Longrightarrow> eval_fds F s = f s"
  assumes w:             "Re w \<ge> 1"
  shows   "fds_converges F w" and "eval_fds F w = f w"
proof -
  \<comment> \<open>We get a bound on our coefficients and call it \<open>C\<close>.\<close>
  obtain C where C: "C \<ge> 1" "\<And>n. norm (fds_nth F n) \<le> C"
    using natfun_bigo_1E[OF coeff_bound, where lb = 1] by blast
  write contour_integral ("\<ointegral>[_]")

  \<comment> \<open>We show convergence directly by showing that the difference between the
      partial sums and the limit vanishes.\<close>
  have "(\<lambda>N. eval_fds (fds_truncate N F) w) \<longlonglongrightarrow> f w"
    unfolding tendsto_iff dist_norm norm_minus_commute[of "eval_fds F s" for F s]
  proof safe
    fix \<epsilon> :: real assume \<epsilon>: "\<epsilon> > 0"
    \<comment> \<open>We choose an integration radius that is big enough for the error to be sufficiently small.\<close>
    define R where "R = max 1 (3 * C / \<epsilon>)"
    have R: "R \<ge> 3 * C / \<epsilon>" "R \<ge> 1" by (auto simp: R_def)

    \<comment> \<open>Next, we extend the analyticity of \<open>f (w + z)\<close> to the left of the complex plane
        within a thin rectangle that is at least as high as the circle.\<close>
    obtain l where l: "l > 0"
      "(\<lambda>z. f (w + z)) analytic_on {s. Re s > 0 \<or> Im s \<in> {-R-1<..<R+1} \<and> Re s > -l}"
    proof -
      have f_analytic': "(\<lambda>z. f (w + z)) analytic_on {s. Re s \<ge> 0}"
        by (rule analytic_on_compose_gen[OF _ f_analytic, unfolded o_def])
           (insert w, auto intro: analytic_intros)
      hence "(\<lambda>z. f (w + z)) analytic_on {s. Re s = 0 \<and> Im s \<in> {-R-1..R+1}}"
        by (rule analytic_on_subset) auto
      from analytic_on_axis_extend[OF _ this] obtain x1 x2 where x12:
        "x1 < 0" "x2 > 0" "(\<lambda>z. f (w + z)) analytic_on cbox (Complex x1 (-R-1)) (Complex x2 (R+1))"
        using \<open>R \<ge> 1\<close> by auto
      from this(3) have "(\<lambda>z. f (w + z)) analytic_on {s. Re s \<in> {x1..0} \<and> Im s \<in> {-R-1..R+1}}"
        by (rule analytic_on_subset) (insert x12, auto simp: in_cbox_complex_iff)
      with f_analytic' have "(\<lambda>z. f (w + z)) analytic_on
                               ({s. Re s \<ge> 0} \<union> {s. Re s \<in> {x1..0} \<and> Im s \<in> {-R-1..R+1}})"
        by (subst analytic_on_Un) auto
      hence "(\<lambda>z. f (w + z)) analytic_on {s. Re s > 0 \<or> Im s \<in> {-R-1<..<R+1} \<and> Re s > x1}"
        by (rule analytic_on_subset) auto
      with \<open>x1 < 0\<close> and that[of "-x1"] show ?thesis by auto
    qed

    \<comment> \<open>The function \<open>f (w + z)\<close> is now analytic on the open box $(-l; R+1) + i(-R+1; R+1)$.
        We call this region \<open>X\<close>.\<close>
    define X where "X = box (Complex (-l) (-R-1)) (Complex (R+1) (R+1))"
    have [simp, intro]: "open X" "convex X" by (simp_all add: X_def open_box)
    from R l have [simp]: "0 \<in> X" by (auto simp: X_def in_box_complex_iff)
    have analytic: "(\<lambda>z. f (w + z)) analytic_on X"
      by (rule analytic_on_subset[OF l(2)]) (auto simp: X_def in_box_complex_iff)
    note f_analytic' [analytic_intros] = analytic_on_compose_gen[OF _ analytic, unfolded o_def]
    note f_holo [holomorphic_intros] =
      holomorphic_on_compose_gen[OF _ analytic_imp_holomorphic[OF analytic], unfolded o_def]
    note f_cont [continuous_intros] = continuous_on_compose2[OF
      holomorphic_on_imp_continuous_on[OF analytic_imp_holomorphic[OF analytic]]]

    \<comment> \<open>We now pick a smaller closed box \<open>X'\<close> inside the big open box \<open>X\<close>. This is because
        we need a compact set for the next step. our integration path still lies entirely
        within \<open>X'\<close>, and since \<open>X'\<close> is compact, \<open>f (w + z)\<close> is bounded on it,
        so we obtain such a bound and call it \<open>M\<close>.\<close>
    define \<delta> where "\<delta> = min (1/2) (l/2)"
    from l have \<delta>: "\<delta> > 0" "\<delta> \<le> 1/2" "\<delta> < l" by (auto simp: \<delta>_def)
    define X' where "X' = cbox (Complex (-\<delta>) (-R)) (Complex R R)"
    have "X' \<subseteq> X" unfolding X'_def X_def using l(1) R \<delta>
      by (intro subset_box_imp) (auto simp: Basis_complex_def)
    have [intro]: "compact X'" by (simp add: X'_def)
    moreover have "continuous_on X' (\<lambda>z. f (w + z))"
      using w \<open>X' \<subseteq> X\<close> by (auto intro!: continuous_intros)
    ultimately obtain M where M: "M \<ge> 0" "\<And>z. z \<in> X' \<Longrightarrow> norm (f (w + z)) \<le> M"
      using continuous_on_compact_bound by blast

    \<comment> \<open>Our objective is now to show that the difference between the \<open>N\<close>-th partial sum
        and the limit is below a certain bound (depending on \<open>N\<close>) which tends to \<open>0\<close>
        for \<open>N \<rightarrow> \<infinity>\<close>. We use the following bound:\<close>
    define bound where
      "bound = (\<lambda>N::nat. (2*C/R + C/N + 3*M / (pi*R*ln N) + 3*R*M / (\<delta>*pi * N powr \<delta>)))"
    have "2 * C / R < \<epsilon>" using M(1) R C(1) \<delta>(1) \<epsilon>
      by (auto simp: field_simps)
    \<comment> \<open>Evidently this is below @{term \<epsilon>} for sufficiently large \<open>N\<close>.\<close>
    hence "eventually (\<lambda>N::nat. bound N < \<epsilon>) at_top"
      using M(1) R C(1) \<delta>(1) \<epsilon> unfolding bound_def by real_asymp

    \<comment> \<open>It now only remains to show that the difference is indeed less than the claimed bound.\<close>
    thus "eventually (\<lambda>N. norm (f w - eval_fds (fds_truncate N F) w) < \<epsilon>) at_top"
      using eventually_gt_at_top[of 1]
    proof eventually_elim
      case (elim N)
      note N = this

      \<comment> \<open>Like Harrison (and unlike Newman), our integration path \<open>\<Gamma>\<close> consists of a semicircle \<open>A\<close>
          of radius \<open>R\<close> in the right-halfplane and a box of width \<open>\<delta>\<close> and height \<open>2R\<close> on
          the left halfplane. The latter consists of three straight lines, which we call \<open>B1\<close>
          to \<open>B3\<close>.\<close>
      define A where "A = part_circlepath 0 R (-pi/2) (pi/2)"
      define B2 where "B2 = linepath (Complex (-\<delta>) R) (Complex (-\<delta>) (-R))"
      define B1 where "B1 = linepath (R * \<i>) (R * \<i> - \<delta>)"
      define B3 where "B3 = linepath (-R * \<i> - \<delta>) (-R * \<i>)"
      define \<Gamma> where "\<Gamma> = A +++ B1 +++ B2 +++ B3"

      \<comment> \<open>We first need to show some basic facts about the geometry of our integration path.\<close>
      have [simp, intro]:
        "path A" "path B1" "path B3" "path B2"
        "valid_path A" "valid_path B1" "valid_path B3" "valid_path B2"
        "arc A" "arc B1" "arc B3" "arc B2"
        "pathstart A = -\<i> * R" "pathfinish A = \<i> * R"
        "pathstart B1 = \<i> * R" "pathfinish B1 = R * \<i> - \<delta>"
        "pathstart B3 = -R * \<i> - \<delta>" "pathfinish B3 = -\<i> * R"
        "pathstart B2 = R * \<i> - \<delta>" "pathfinish B2 = -R * \<i> - \<delta>" using R \<delta>
        by (simp_all add: A_def B1_def B3_def exp_eq_polar B2_def Complex_eq arc_part_circlepath)
      hence [simp, intro]: "valid_path \<Gamma>"
        by (simp add: \<Gamma>_def A_def B1_def B3_def B2_def exp_eq_polar Complex_eq)
      hence [simp, intro]: "path \<Gamma>" using valid_path_imp_path by blast
      have [simp]: "pathfinish \<Gamma> = pathstart \<Gamma>" by (simp add: \<Gamma>_def exp_eq_polar)

      have image_B2: "path_image B2 = {s. Re s = -\<delta> \<and> Im s \<in> {-R..R}}"
        using R by (auto simp: closed_segment_same_Re closed_segment_eq_real_ivl B2_def)
      have image_B1: "path_image B1 = {s. Re s \<in> {-\<delta>..0} \<and> Im s = R}"
       and image_B3: "path_image B3 = {s. Re s \<in> {-\<delta>..0} \<and> Im s = -R}"
        using \<delta> by (auto simp: B1_def B3_def closed_segment_same_Im closed_segment_eq_real_ivl)
      have image_A: "path_image A = {s. Re s \<ge> 0 \<and> norm s = R}"
        unfolding A_def using R by (subst path_image_semicircle_Re_ge) auto
      also have "z \<in> \<dots> \<longrightarrow> z \<in> X' - {0}" for z
        using complex_Re_le_cmod[of z] abs_Im_le_cmod[of z] \<delta> R
        by (auto simp: X'_def in_cbox_complex_iff)
      hence "{s. Re s \<ge> 0 \<and> norm s = R} \<subseteq> X' - {0}" by auto
      finally have "path_image B2 \<subseteq> X' - {0}" "path_image A \<subseteq> X' - {0}"
           "path_image B1 \<subseteq> X' - {0}" "path_image B3 \<subseteq> X' - {0}" using \<open>\<delta> > 0\<close>
        by (auto simp: X'_def in_cbox_complex_iff image_B2 image_B1 image_B3)
      note path_images = this \<open>X' \<subseteq> X\<close>

      \<comment> \<open>\<open>\<Gamma>\<close> is a simple path, which, combined with its simple geometric shape, makes
          reasoning about its winding numbers trivial.\<close>
      from R have "simple_path A" unfolding A_def
        by (subst simple_path_part_circlepath) auto
      have "simple_path \<Gamma>" unfolding \<Gamma>_def
      proof (intro simple_path_join_loop subsetI arc_join, goal_cases)
        fix z assume z: "z \<in> path_image A \<inter> path_image (B1 +++ B2 +++ B3)"
        with image_A have "Re z \<ge> 0" "norm z = R" by auto
        with z R \<delta> show "z \<in> {pathstart A, pathstart (B1 +++ B2 +++ B3)}"
          by (auto simp: path_image_join image_B1 image_B2 image_B3 complex_eq_iff)
      qed (insert R, auto simp: image_B1 image_B3 path_image_join image_B2 complex_eq_iff)

      \<comment> \<open>We define the integrands in the same fashion as Newman:\<close>
      define g where "g = (\<lambda>z::complex. f (w + z) * N powr z * (1 / z + z / R\<^sup>2))"
      define S where "S = eval_fds (fds_truncate N F)"
      define g_S where "g_S = (\<lambda>z::complex. S (w + z) * N powr z * (1 / z + z / R\<^sup>2))"
      define rem where "rem = (\<lambda>z::complex. f z - S z)"
      define g_rem where "g_rem = (\<lambda>z::complex. rem (w + z) * N powr z * (1 / z + z / R\<^sup>2))"

      have g_holo: "g holomorphic_on X - {0}" unfolding g_def
        by (auto intro!: holomorphic_intros analytic_imp_holomorphic'[OF analytic])

      have rem_altdef: "rem z = eval_fds (fds_remainder N F) z" if "Re z > 1" for z
      proof -
      have abscissa: "abs_conv_abscissa F \<le> 1"
        using assms by (intro bounded_coeffs_imp_abs_conv_abscissa_le_1)
                       (simp_all add: natfun_bigo_iff_Bseq)
        from assms and that have "f z = eval_fds F z" by auto
        also have "F = fds_truncate N F + fds_remainder N F"
          by (rule fds_truncate_plus_remainder [symmetric])
        also from that have "eval_fds \<dots> z = S z + eval_fds (fds_remainder N F) z" unfolding S_def
          by (subst eval_fds_add) (auto intro!: fds_abs_converges_imp_converges
                                                fds_abs_converges[OF le_less_trans[OF abscissa]])
        finally show ?thesis by (simp add: rem_def)
      qed

      \<comment> \<open>We now come to the first application of the residue theorem along the path \<open>\<Gamma>\<close>:\<close>
      have "\<ointegral>[\<Gamma>] g = 2 * pi * \<i> * winding_number \<Gamma> 0 * residue g 0"
      proof (subst Residue_theorem)
        show "g holomorphic_on X - {0}" by fact
        show "path_image \<Gamma> \<subseteq> X - {0}" using path_images
          by (auto simp: \<Gamma>_def path_image_join)
        thus "\<forall>z. z \<notin> X \<longrightarrow> winding_number \<Gamma> z = 0"
          by (auto intro!: simply_connected_imp_winding_number_zero[of X]
                           convex_imp_simply_connected)
      qed (insert path_images, auto intro: convex_connected)
      also have "winding_number \<Gamma> 0 = 1"
      proof (rule simple_closed_path_winding_number_pos)
        from R \<delta> have "\<forall>g\<in>{A, B1, B2, B3}. Re (winding_number g 0) > 0"
          unfolding A_def B1_def B2_def B3_def
          by (auto intro!: winding_number_linepath_pos_lt winding_number_part_circlepath_pos_less)
        hence "valid_path \<Gamma> \<and> 0 \<notin> path_image \<Gamma> \<and> Re (winding_number \<Gamma> 0) > 0"
          unfolding \<Gamma>_def using path_images(1-4) by (intro winding_number_join_pos_combined') auto
        thus "Re (winding_number \<Gamma> 0) > 0" by simp
      qed (insert path_images \<open>simple_path \<Gamma>\<close>, auto simp: \<Gamma>_def path_image_join)
      also have "residue g 0 = f w"
      proof -
        have "g = (\<lambda>z::complex. f (w + z) * N powr z * (1 + z\<^sup>2 / R\<^sup>2) / z)"
          by (auto simp: g_def divide_simps fun_eq_iff power2_eq_square
                   simp del: div_mult_self3 div_mult_self4 div_mult_self2 div_mult_self1)
        moreover from N have "residue \<dots> 0 = f w"
          by (subst residue_simple'[of X])
             (auto intro!: holomorphic_intros analytic_imp_holomorphic[OF analytic])
        ultimately show ?thesis by (simp only:)
      qed
      finally have "2 * pi * \<i> * f w = \<ointegral>[\<Gamma>] g" by simp
      also have "\<dots> = \<ointegral>[A] g + \<ointegral>[B2] g + \<ointegral>[B1] g + \<ointegral>[B3] g" unfolding \<Gamma>_def
        by (subst contour_integral_join, (insert path_images,
            auto intro!: contour_integral_join contour_integrable_holomorphic_simple g_holo)[4])+
           (simp_all add: add_ac)
      finally have integral1: "2 * pi * \<i> * f w = \<ointegral>[A] g + \<ointegral>[B2] g + \<ointegral>[B1] g + \<ointegral>[B3] g" .

      \<comment> \<open>Next, we apply the residue theorem along a circle of radius \<open>R\<close> to another
          integrand that is related to the partial sum:\<close>
      have "\<ointegral>[circlepath 0 R] g_S = 2 * pi * \<i> * residue g_S 0"
      proof (subst Residue_theorem)
        show "g_S holomorphic_on UNIV - {0}"
          by (auto simp: g_S_def S_def intro!: holomorphic_intros)
      qed (insert R, auto simp: winding_number_circlepath_centre)
      also have "residue g_S 0 = S w"
      proof -
        have "g_S = (\<lambda>z::complex. S (w + z) * N powr z * (1 + z\<^sup>2 / R\<^sup>2) / z)"
          by (auto simp: g_S_def divide_simps fun_eq_iff power2_eq_square
                   simp del: div_mult_self3 div_mult_self4 div_mult_self2 div_mult_self1)
        moreover from N have "residue \<dots> 0 = S w"
          by (subst residue_simple'[of X])
             (auto intro!: holomorphic_intros simp: S_def)
        ultimately show ?thesis by (simp only:)
      qed
      finally have "2 * pi * \<i> * S w = \<ointegral>[circlepath 0 R] g_S" ..

      \<comment> \<open>We split this integral into integrals along two semicircles in the left and right
          half-plane, respectively:\<close>
      also have "\<dots> = \<ointegral>[part_circlepath 0 R (-pi/2) (3*pi/2)] g_S"
      proof (rule Cauchy_theorem_homotopic_loops)
        show "homotopic_loops (-{0}) (circlepath 0 R)
                (part_circlepath 0 R (- pi / 2) (3 * pi / 2))" unfolding circlepath_def using R
          by (intro homotopic_loops_part_circlepath[where k = 1]) auto
      qed (auto simp: g_S_def S_def intro!: holomorphic_intros)
      also have "\<dots> = \<ointegral>[A +++ -A] g_S"
      proof (rule Cauchy_theorem_homotopic_paths)
        have *: "-A = part_circlepath 0 R (pi/2) (3*pi/2)" unfolding A_def
          by (intro part_circlepath_mirror[where k = 0]) auto
        from R show "homotopic_paths (-{0}) (part_circlepath 0 R (-pi/2) (3*pi/2)) (A +++ -A)"
          unfolding * unfolding A_def
          by (intro homotopic_paths_part_circlepath) (auto dest!: in_path_image_part_circlepath)
      qed (auto simp: g_S_def S_def A_def exp_eq_polar intro!: holomorphic_intros)
      also have "\<dots> = \<ointegral>[A] g_S + \<ointegral>[-A] g_S" using R
        by (intro contour_integral_join contour_integrable_holomorphic_simple[of _ "-{0}"])
           (auto simp: A_def g_S_def S_def path_image_mirror dest!: in_path_image_part_circlepath
                 intro!: holomorphic_intros)
      also have "\<ointegral>[-A] g_S = -\<ointegral>[A] (\<lambda>x. g_S (-x))"
        by (simp add: A_def contour_integral_mirror contour_integral_neg)
      finally have integral2: "2 * pi * \<i> * S w = \<ointegral>[A] g_S - \<ointegral>[A] (\<lambda>x. g_S (-x))"
        by simp

      \<comment> \<open>Next, we show a small bounding lemma that we will need for the final estimate:\<close>
      have circle_bound: "norm (1 / z + z / R\<^sup>2) \<le> 2 / R" if [simp]: "norm z = R" for z :: complex
      proof -
        have "norm (1 / z + z / R\<^sup>2) \<le> 1 / R + 1 / R"
          by (intro order.trans[OF norm_triangle_ineq] add_mono)
             (insert R, simp_all add: norm_divide norm_mult power2_eq_square)
        thus ?thesis by simp
      qed

      \<comment> \<open>The next bound differs somewhat from Newman's, but it works just as well.
          Its purpose is to bound the contribution of the two short horizontal line segments.\<close>
      have B12_bound: "norm (integral {- \<delta>..0} (\<lambda>x. g (x + R' * \<i>))) \<le> 3 * M / R / ln N"
        (is "?I \<le> _") if "\<bar>R'\<bar> = R" for R'
      proof -
        have "?I \<le> integral {-\<delta>..0} (\<lambda>x. 3 * M / R * N powr x)"
        proof (rule integral_norm_bound_integral)
          fix x assume x: "x \<in> {-\<delta>..0}"
          define z where "z = x + \<i> * R'"
          from R that have [simp]: "z \<noteq> 0" "Re z = x" "Im z = R'"
            by (auto simp: z_def complex_eq_iff)
          from x R that have "z \<in> X'" by (auto simp: z_def X'_def in_cbox_complex_iff)
          from x R that have "norm z \<le> \<delta> + R"
            by (intro order.trans[OF cmod_le add_mono]) auto

          hence "norm (1 / z + z / R\<^sup>2) \<le> 1 / R + (\<delta> / R + 1) / R"
            using R that abs_Im_le_cmod[of z]
            by (intro order.trans[OF norm_triangle_ineq add_mono])
               (auto simp: norm_divide norm_mult power2_eq_square field_simps )
          also have "\<delta> / R \<le> 1" using \<delta> R by auto
          finally have "norm (1 / z + z / R\<^sup>2) \<le> 3 / R"
            using R by (simp add: divide_right_mono)
          hence "norm (g z) \<le> M * N powr x * (3 / R)"
            unfolding g_def norm_mult using \<open>M \<ge> 0\<close> \<open>z \<in> X'\<close>
            by (intro mult_mono mult_nonneg_nonneg M) (auto simp: norm_powr_real_powr)
          thus "norm (g (x + R' * \<i>)) \<le> 3 * M / R * N powr x" by (simp add: mult_ac z_def)
        qed (insert N R l that \<delta>, auto intro!: integrable_continuous_real continuous_intros
                                  simp: g_def X_def complex_eq_iff in_box_complex_iff)
        also have "\<dots> = 3 * M / R * integral {-\<delta>..0} (\<lambda>x. N powr x)" by simp
        also have "((\<lambda>x. N powr x) has_integral (N powr 0 / ln N - N powr (-\<delta>) / ln N)) {-\<delta>..0}"
          using \<delta> N
          by (intro fundamental_theorem_of_calculus)
             (auto simp: has_real_derivative_iff_has_vector_derivative [symmetric] powr_def
                   intro!: derivative_eq_intros)
        hence "integral {-\<delta>..0} (\<lambda>x. N powr x) = 1 / ln (real N) - real N powr - \<delta> / ln (real N)"
          using N by (simp add: has_integral_iff)
        also have "\<dots> \<le> 1 / ln (real N)" using N by simp
        finally show ?thesis using M R by (simp add: mult_left_mono divide_right_mono)
      qed

      \<comment> \<open>We combine the two results from the residue theorem and obtain an integral
          representation of the difference between the partial sums and the limit:\<close>
      have "2 * pi * \<i> * (f w - S w) =
              \<ointegral>[A] g - \<ointegral>[A] g_S + \<ointegral>[A] (\<lambda>x. g_S (-x)) + \<ointegral>[B1] g + \<ointegral>[B3] g + \<ointegral>[B2] g"
        unfolding ring_distribs integral1 integral2 by (simp add: algebra_simps)
      also have "\<ointegral>[A] g - \<ointegral>[A] g_S = \<ointegral>[A] (\<lambda>x. g x - g_S x)" using path_images
        by (intro contour_integral_diff [symmetric])
           (auto intro!: contour_integrable_holomorphic_simple[of _ "X - {0}"] holomorphic_intros
                 simp: g_S_def g_holo S_def)
      also have "\<dots> = \<ointegral>[A] g_rem"
        by (simp add: g_rem_def g_def g_S_def algebra_simps rem_def)
      finally have "2 * pi * \<i> * (f w - S w) =
                      \<ointegral>[A] g_rem + \<ointegral>[A] (\<lambda>x. g_S (- x)) + \<ointegral>[B1] g + \<ointegral>[B3] g + \<ointegral>[B2] g" .

      \<comment> \<open>We now bound each of these integrals individually:\<close>
      also have "norm \<dots> \<le> 2 * C * pi / R  +  2 * C * pi * (1 / N + 1 / R)  +  3 * M / R / ln N  +
                             3 * M / R / ln N  +  6 * R * M * N powr (-\<delta>) / \<delta>"
      proof (rule order.trans[OF norm_triangle_ineq] add_mono)+
        have "\<ointegral>[B1] g = -\<ointegral>[reversepath B1] g" by (simp add: contour_integral_reversepath)
        also have "\<ointegral>[reversepath B1] g = integral {-\<delta>..0} (\<lambda>x. g (x + R * \<i>))"
          unfolding B1_def reversepath_linepath using \<delta>
          by (subst contour_integral_linepath_same_Im) auto
        also have "norm (-\<dots>) = norm \<dots>" by simp
        also have "\<dots> \<le> 3 * M / R / ln N" using R by (intro B12_bound) auto
        finally show "norm (\<ointegral>[B1] g) \<le> \<dots>" .
      next
        have "\<ointegral>[B3] g = integral {-\<delta>..0} (\<lambda>x. g (x + (-R) * \<i>))" unfolding B3_def using \<delta>
          by (subst contour_integral_linepath_same_Im) auto
        also have "norm \<dots> \<le> 3 * M / R / ln N" using R by (intro B12_bound) auto
        finally show "norm (\<ointegral>[B3] g) \<le> \<dots>" .
      next
        have "norm (\<ointegral>[B2] g) \<le> M * N powr (-\<delta>) * (3 / \<delta>) *
                norm (Complex (- \<delta>) (-R) - Complex (- \<delta>) R)" unfolding B2_def
        proof ((rule contour_integral_bound_linepath; (fold B2_def)?), goal_cases)
          case (3 z)
          from 3 \<delta> R have [simp]: "z \<noteq> 0" and Re_z: "Re z = -\<delta>" and Im_z: "Im z \<in> {-R..R}"
            by (auto simp: closed_segment_same_Re closed_segment_eq_real_ivl)
          from 3 have "z \<in> X'" using R \<delta> path_images by (auto simp: B2_def)
          from 3 \<delta> R have "norm z \<le> sqrt (\<delta>^2 + R^2)" unfolding cmod_def using Re_z Im_z
            by (intro real_sqrt_le_mono add_mono) (auto simp: power2_le_iff_abs_le)
          from power_mono[OF this, of 2] have norm_sqr: "norm z ^ 2 \<le> \<delta>\<^sup>2 + R\<^sup>2" by simp

          have "norm (1 / z + z / R\<^sup>2) \<le> (1 + (norm z)\<^sup>2 / R\<^sup>2) / \<delta>"
            unfolding add_divide_distrib using \<delta> R abs_Re_le_cmod[of z]
            by (intro order.trans[OF norm_triangle_ineq] add_mono)
               (auto simp: norm_divide norm_mult field_simps power2_eq_square Re_z)
          also have "\<dots> \<le> (1 + (1 + \<delta>\<^sup>2 / R\<^sup>2)) / \<delta>" using \<delta> R \<open>z \<in> X'\<close> norm_sqr unfolding X'_def
            by (intro divide_right_mono add_left_mono)
               (auto simp: field_simps in_cbox_complex_iff intro!: power_mono)
          also have "\<delta>\<^sup>2 / R\<^sup>2 \<le> 1"
            using \<delta> R by (auto simp: field_simps intro!: power_mono)
          finally have "norm (1 / z + z / R\<^sup>2) \<le> 3 / \<delta>" using \<delta> by(simp add: divide_right_mono)
          with \<open>z \<in> X'\<close> show "norm (g z) \<le> M * N powr (-\<delta>) * (3 / \<delta>)" unfolding g_def norm_mult
            by (intro mult_mono mult_nonneg_nonneg M) (auto simp: norm_powr_real_powr Re_z)
        qed (insert path_images M \<delta>, auto intro!: contour_integrable_holomorphic_simple[OF g_holo])
        thus "norm (\<ointegral>[B2] g) \<le> 6 * R * M * N powr (-\<delta>) / \<delta>"
          using R by (simp add: field_simps cmod_def real_sqrt_mult)
      next
        have "norm (\<ointegral>[A] (\<lambda>x. g_S (- x))) \<le> (2 * C / (real N * R) + 2 * C / R\<^sup>2) *
                                R * ((pi/2) - (-pi/2))" unfolding A_def
        proof ((rule contour_integral_bound_part_circlepath_strong[where k = "{R * \<i>, -R*\<i>}"];
               (fold A_def)?), goal_cases)
          case (6 z)
          hence [simp]: "z \<noteq> 0" and "norm z = R" using R
            by (auto simp: A_def dest!: in_path_image_part_circlepath)
          from 6 have "Re z \<noteq> 0"
            using \<open>norm z = R\<close> by (auto simp: cmod_def abs_if complex_eq_iff split: if_splits)
          with 6 have "Re z > 0" using image_A by auto
          have "S (w - z) = (\<Sum>k = 1..N. fds_nth F k / of_nat k powr (w - z))"
            by (simp add: S_def eval_fds_truncate)
          also have "norm \<dots> \<le> C * N powr Re z * (1 / N + 1 / Re z)"
            using \<open>Re z > 0\<close> w N by (intro newman_ingham_aux2 C) auto
          finally have "norm (S (w - z)) \<le> \<dots>" .
          hence "norm (g_S (-z)) \<le>
                   (C * N powr (Re z) * (1 / N + 1 / Re z)) * N powr (-Re z) * (2 * Re z / R\<^sup>2)"
            unfolding g_S_def norm_mult
            using newman_ingham_aux1[OF _ \<open>norm z = R\<close>] \<open>Re z > 0\<close> \<open>C \<ge> 1\<close> R
            by (intro mult_mono mult_nonneg_nonneg circle_bound)
               (auto simp: norm_powr_real_powr norm_uminus_minus)
          also have "\<dots> = 2 * C * (Re z / N + 1) / R\<^sup>2" using R N \<open>Re z > 0\<close>
            by (simp add: powr_minus algebra_simps)
          also have "\<dots> \<le> 2 * C / (N * R) + 2 * C / R\<^sup>2" unfolding add_divide_distrib ring_distribs
            using R N abs_Re_le_cmod[of z] \<open>norm z = R\<close> \<open>Re z > 0\<close> \<open>C \<ge> 1\<close>
            by (intro add_mono) (auto simp: power2_eq_square field_simps mult_mono)
          finally show ?case .
        qed (insert R N image_A C, auto intro!: contour_integrable_holomorphic_simple[of _ "-{0}"]
                                                holomorphic_intros simp: g_S_def S_def)
        also have "\<dots> = 2 * C * pi * (1 / N + 1 / R)" using R N
          by (simp add: power2_eq_square field_simps)
        finally show "norm (\<ointegral>[A] (\<lambda>x. g_S (- x))) \<le> \<dots>" .
      next
        have "norm (\<ointegral>[A] g_rem) \<le> (2 * C / R\<^sup>2) * R * ((pi/2) - (-pi/2))" unfolding A_def
        proof ((rule contour_integral_bound_part_circlepath_strong[where k = "{R * \<i>, -R*\<i>}"];
               (fold A_def)?), goal_cases)
          case (6 z)
          hence [simp]: "z \<noteq> 0" and "norm z = R" using R
            by (auto simp: A_def dest!: in_path_image_part_circlepath)
          from 6 have "Re z \<noteq> 0"
            using \<open>norm z = R\<close> by (auto simp: cmod_def abs_if complex_eq_iff split: if_splits)
          with 6 have "Re z > 0" using image_A by auto

          have summable: "summable (\<lambda>n. C * (1 / (Suc n + N) powr (Re w + Re z)))"
            using summable_hurwitz_zeta_real[of "Re w + Re z" "Suc N"] \<open>Re z > 0\<close> w
            unfolding powr_minus by (intro summable_mult) (auto simp: field_simps)
          have "rem (w + z) = (\<Sum>n. fds_nth F (Suc n + N) / (Suc n + N) powr (w + z))"
            using \<open>Re z > 0\<close> w by (simp add: rem_altdef eval_fds_remainder)
          also have "norm \<dots> \<le> (\<Sum>n. C / (Suc n + N) powr Re (w + z))" using summable
            by (intro norm_suminf_le)
               (auto simp: norm_divide norm_powr_real_powr intro!: divide_right_mono C)
          also have "\<dots> = (\<Sum>n. C * (Suc n + N) powr -Re (w + z))"
            unfolding powr_minus by (simp add: field_simps)
          also have "\<dots> = C * (\<Sum>n. (Suc n + N) powr -Re (w + z))"
            using summable_hurwitz_zeta_real[of "Re w + Re z" "Suc N"] \<open>Re z > 0\<close> w
            by (subst suminf_mult) (auto simp: add_ac)
          also have "(\<Sum>n. (Suc n + N) powr -Re (w + z)) \<le>
                       N powr (1 - Re (w + z)) / (Re (w + z) - 1)"
            using \<open>Re z > 0\<close> w N hurwitz_zeta_real_bound_aux[of N "Re (w + z)"]
            by (auto simp: add_ac)
          also have "\<dots> \<le> N powr -Re z / Re z"
            using w N \<open>Re z > 0\<close> by (intro frac_le powr_mono) auto
          finally have "norm (rem (w + z)) \<le> C / (Re z * N powr Re z)"
            using C by (simp add: mult_left_mono mult_right_mono powr_minus field_simps)
          hence "norm (g_rem z) \<le> (C / (Re z * N powr Re z)) * N powr (Re z) * (2 * Re z / R\<^sup>2)"
            unfolding g_rem_def norm_mult
            using newman_ingham_aux1[OF _ \<open>norm z = R\<close>] R \<open>Re z > 0\<close> C
            by (intro mult_mono mult_nonneg_nonneg circle_bound)
               (auto simp: norm_powr_real_powr norm_uminus_minus)
          also have "\<dots> = 2 * C / R\<^sup>2" using R N \<open>Re z > 0\<close>
            by (simp add: powr_minus field_simps)
          finally show ?case .
        next
          show "g_rem contour_integrable_on A" using path_images
            by (auto simp: g_rem_def rem_def S_def
                     intro!: contour_integrable_holomorphic_simple[of _ "X-{0}"] holomorphic_intros)
        qed (insert R N C, auto)
        also have "(2 * C / R\<^sup>2) * R * ((pi/2) - (-pi/2)) = 2 * C * pi / R"
          using R by (simp add: power2_eq_square field_simps)
        finally show "norm (\<ointegral>[A] g_rem) \<le> \<dots>" .
      qed
      also have "\<dots> = 4*C*pi/R + 2*C*pi/N + 6*M/R / ln N + 6*R*M*N powr - \<delta> / \<delta>"
        by (simp add: algebra_simps)
      also have "\<dots> = 2*pi * (2*C/R + C/N + 3*M / (pi*R*ln N) + 3*R*M / (\<delta>*pi * N powr \<delta>))"
        by (simp add: field_simps powr_minus )
      also have "norm (2 * pi * \<i> * (f w - S w)) = 2 * pi * norm (f w - S w)"
        by (simp add: norm_mult)
      finally have "norm (f w - S w) \<le> bound N" by (simp add: bound_def)
      also have "bound N < \<epsilon>" by fact
      finally show "norm (f w - S w) < \<epsilon>" .
    qed
  qed
  thus "fds_converges F w"
    by (auto simp: fds_converges_altdef2 intro: convergentI)
  thus "eval_fds F w = f w"
    using \<open>(\<lambda>N. eval_fds (fds_truncate N F) w) \<longlonglongrightarrow> f w\<close>
    by (intro tendsto_unique[OF _ tendsto_eval_fds_truncate]) auto
qed

text \<open>
  The theorem generalises in a trivial way; we can replace the requirement that the
  coefficients of $f(s)$ be $O(1)$ by $O(n^{\sigma-1})$ for some $\sigma\in\mathbb{R}$, then
  $f(s)$ converges for $\mathfrak{R}(s)>\sigma$. If it can be analytically continued to
  $\mathfrak{R}(s)\geq\sigma$, it is also convergent there.
\<close>
theorem Newman_Ingham:
  fixes F :: "complex fds" and f :: "complex \<Rightarrow> complex"
  assumes coeff_bound:   "fds_nth F \<in> O(\<lambda>n. n powr of_real (\<sigma> - 1))"
  assumes f_analytic:    "f analytic_on {s. Re s \<ge> \<sigma>}"
  assumes F_conv_f:      "\<And>s. Re s > \<sigma> \<Longrightarrow> eval_fds F s = f s"
  assumes w:             "Re w \<ge> \<sigma>"
  shows   "fds_converges F w" and "eval_fds F w = f w"
proof -
  define F' where "F' = fds_shift (-of_real (\<sigma> - 1)) F"
  define f' where "f' = f \<circ> (\<lambda>s. s + of_real (\<sigma> - 1))"

  have "fds_nth F' = (\<lambda>n. fds_nth F n * of_nat n powr -of_real(\<sigma> - 1))"
    by (auto simp: fun_eq_iff F'_def)
  also have "\<dots> \<in> O(\<lambda>n. of_nat n powr of_real (\<sigma> - 1) * of_nat n powr -of_real(\<sigma> - 1))"
    by (intro landau_o.big.mult_right assms)
  also have "(\<lambda>n. of_nat n powr of_real (\<sigma> - 1) * of_nat n powr -of_real (\<sigma> - 1)) \<in> \<Theta>(\<lambda>_. 1)"
    by (intro bigthetaI_cong eventually_mono[OF eventually_gt_at_top[of 0]])
       (auto simp: powr_minus powr_diff)
  finally have bigo: "fds_nth F' \<in> O(\<lambda>_. 1)" .

  from f_analytic have analytic: "f' analytic_on {s. Re s \<ge> 1}" unfolding f'_def
    by (intro analytic_on_compose_gen[OF _ f_analytic]) (auto intro!: analytic_intros)

  have F'_f: "eval_fds F' s = f' s" if "Re s > 1" for s
    using assms that by (auto simp: F'_def f'_def algebra_simps)

  have w': "1 \<le> Re (w - of_real (\<sigma> - 1))"
    using w by simp

  have 1: "fds_converges F' (w - of_real (\<sigma> - 1))"
    using bigo analytic F'_f w' by (rule Newman_Ingham_1)
  thus "fds_converges F w" by (auto simp: F'_def)

  have 2: "eval_fds F' (w - of_real (\<sigma> - 1)) = f' (w - of_real (\<sigma> - 1))"
    using bigo analytic F'_f w' by (rule Newman_Ingham_1)
  thus "eval_fds F w = f w"
    using assms by (simp add: F'_def f'_def)
qed

end


(*  Author:     Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)
section \<open>Sum of Powers\<close>

theory Sum_of_Powers
imports Complex_Main
begin

subsection \<open>Additions to @{theory Binomial} Theory\<close>

lemma (in field_char_0) one_plus_of_nat_neq_zero [simp]:
  "1 + of_nat n \<noteq> 0"
proof -
  have "of_nat (Suc n) \<noteq> of_nat 0"
    unfolding of_nat_eq_iff by simp
  then show ?thesis by simp
qed

lemma of_nat_binomial_eq_mult_binomial_Suc:
  assumes "k \<le> n"
  shows "(of_nat :: (nat \<Rightarrow> ('a :: field_char_0))) (n choose k) = of_nat (n + 1 - k) / of_nat (n + 1) * of_nat (Suc n choose k)"
proof (cases k)
  case 0 then show ?thesis by simp
next
  case (Suc l)
  have "of_nat (n + 1) * (\<Prod>i=0..<k. of_nat (n - i)) = (of_nat :: (nat \<Rightarrow> 'a)) (n + 1 - k) * (\<Prod>i=0..<k. of_nat (Suc n - i))"
    using prod.atLeast0_lessThan_Suc [where ?'a = 'a, symmetric, of "\<lambda>i. of_nat (Suc n - i)" k]
    by (simp add: ac_simps prod.atLeast0_lessThan_Suc_shift)
  also have "... = (of_nat :: (nat \<Rightarrow> 'a)) (Suc n - k) * (\<Prod>i=0..<k. of_nat (Suc n - i))"
    by (simp add: Suc atLeast0_atMost_Suc atLeastLessThanSuc_atLeastAtMost)
  also have "... = (of_nat :: (nat \<Rightarrow> 'a)) (n + 1 - k) * (\<Prod>i=0..<k. of_nat (Suc n - i))"
    by (simp only: Suc_eq_plus1)
  finally have "(\<Prod>i=0..<k. of_nat (n - i)) = (of_nat :: (nat \<Rightarrow> 'a)) (n + 1 - k) / of_nat (n + 1) * (\<Prod>i=0..<k. of_nat (Suc n - i))"
    by (simp add: field_simps)
  with assms show ?thesis
    by (simp add: binomial_altdef_of_nat prod_dividef)
qed

lemma real_binomial_eq_mult_binomial_Suc:
  assumes "k \<le> n"
  shows "(n choose k) = (n + 1 - k) / (n + 1) * (Suc n choose k)"
by (metis Suc_eq_plus1 add.commute assms le_SucI of_nat_Suc of_nat_binomial_eq_mult_binomial_Suc of_nat_diff)

subsection \<open>Preliminaries\<close>

lemma integrals_eq:
  assumes "f 0 = g 0"
  assumes "\<And> x. ((\<lambda>x. f x - g x) has_real_derivative 0) (at x)"
  shows "f x = g x"
proof -
  show "f x = g x"
  proof (cases "x \<noteq> 0")
    case True
    from assms DERIV_const_ratio_const[OF this, of "\<lambda>x. f x - g x" 0]
    show ?thesis by auto
  qed (simp add: assms)
qed

lemma sum_diff: "((\<Sum>i\<le>n::nat. f (i + 1) - f i)::'a::field) = f (n + 1) - f 0"
by (induct n) (auto simp add: field_simps)

declare One_nat_def [simp del]

subsection \<open>Bernoulli Numbers and Bernoulli Polynomials\<close>

declare sum.cong [fundef_cong]

fun bernoulli :: "nat \<Rightarrow> real"
where
  "bernoulli 0 = (1::real)"
| "bernoulli (Suc n) =  (-1 / (n + 2)) * (\<Sum>k \<le> n. ((n + 2 choose k) * bernoulli k))"

declare bernoulli.simps[simp del]

definition
  "bernpoly n = (\<lambda>x. \<Sum>k \<le> n. (n choose k) * bernoulli k * x ^ (n - k))"

subsection \<open>Basic Observations on Bernoulli Polynomials\<close>

lemma bernpoly_0: "bernpoly n 0 = bernoulli n"
proof (cases n)
  case 0
  then show "bernpoly n 0 = bernoulli n"
    unfolding bernpoly_def bernoulli.simps by auto
next
  case (Suc n')
  have "(\<Sum>k\<le>n'. real (Suc n' choose k) * bernoulli k * 0 ^ (Suc n' - k)) = 0"
    by (rule sum.neutral) auto
  with Suc show ?thesis
    unfolding bernpoly_def by simp
qed

lemma sum_binomial_times_bernoulli:
  "(\<Sum>k\<le>n. ((Suc n) choose k) * bernoulli k) = (if n = 0 then 1 else 0)"
proof (cases n)
  case 0
  then show ?thesis by (simp add: bernoulli.simps)
next
  case Suc
  then show ?thesis
  by (simp add: bernoulli.simps)
    (simp add: field_simps add_2_eq_Suc'[symmetric] del: add_2_eq_Suc add_2_eq_Suc')
qed

subsection \<open>Sum of Powers with Bernoulli Polynomials\<close>

lemma bernpoly_derivative [derivative_intros]:
  "(bernpoly (Suc n) has_real_derivative ((n + 1) * bernpoly n x)) (at x)"
proof -
  have "(bernpoly (Suc n) has_real_derivative (\<Sum>k\<le>n. real (Suc n - k) * x ^ (n - k) * (real (Suc n choose k) * bernoulli k))) (at x)"
    unfolding bernpoly_def by (rule DERIV_cong) (fast intro!: derivative_intros, simp)
  moreover have "(\<Sum>k\<le>n. real (Suc n - k) * x ^ (n - k) * (real (Suc n choose k) * bernoulli k)) = (n + 1) * bernpoly n x"
    unfolding bernpoly_def
    by (auto intro: sum.cong simp add: sum_distrib_left real_binomial_eq_mult_binomial_Suc[of _ n] Suc_eq_plus1 of_nat_diff)
  ultimately show ?thesis by auto
qed

lemma diff_bernpoly:
  "bernpoly n (x + 1) - bernpoly n x = n * x ^ (n - 1)"
proof (induct n arbitrary: x)
  case 0
  show ?case unfolding bernpoly_def by auto
next
  case (Suc n)
  have "bernpoly (Suc n) (0 + 1) - bernpoly (Suc n) 0 = (Suc n) * 0 ^ n"
    unfolding bernpoly_0 unfolding bernpoly_def by (simp add: sum_binomial_times_bernoulli zero_power)
  then have const: "bernpoly (Suc n) (0 + 1) - bernpoly (Suc n) 0 = real (Suc n) * 0 ^ n" by (simp add: power_0_left)
  have hyps': "\<And>x. (real n + 1) * bernpoly n (x + 1) - (real n + 1) * bernpoly n x = real n * x ^ (n - Suc 0) * real (Suc n)"
    unfolding right_diff_distrib[symmetric] by (simp add: Suc.hyps One_nat_def)
  note [derivative_intros] = DERIV_chain'[where f = "\<lambda>x::real. x + 1" and g = "bernpoly (Suc n)" and s="UNIV"]
  have derivative: "\<And>x. ((%x. bernpoly (Suc n) (x + 1) - bernpoly (Suc n) x - real (Suc n) * x ^ n) has_real_derivative 0) (at x)"
    by (rule DERIV_cong) (fast intro!: derivative_intros, simp add: hyps')
  from integrals_eq[OF const derivative] show ?case by simp
qed

lemma sum_of_powers: "(\<Sum>k\<le>n::nat. (real k) ^ m) = (bernpoly (Suc m) (n + 1) - bernpoly (Suc m) 0) / (m + 1)"
proof -
  from diff_bernpoly[of "Suc m", simplified] have "(m + (1::real)) * (\<Sum>k\<le>n. (real k) ^ m) = (\<Sum>k\<le>n. bernpoly (Suc m) (real k + 1) - bernpoly (Suc m) (real k))"
    by (auto simp add: sum_distrib_left intro!: sum.cong)
  also have "... = (\<Sum>k\<le>n. bernpoly (Suc m) (real (k + 1)) - bernpoly (Suc m) (real k))"
    by simp
  also have "... = bernpoly (Suc m) (n + 1) - bernpoly (Suc m) 0"
    by (simp only: sum_diff[where f="\<lambda>k. bernpoly (Suc m) (real k)"]) simp
  finally show ?thesis by (auto simp add: field_simps intro!: eq_divide_imp)
qed

subsection \<open>Instances for Square And Cubic Numbers\<close>

lemma binomial_unroll:
  "n > 0 \<Longrightarrow> (n choose k) = (if k = 0 then 1 else (n - 1) choose (k - 1) + ((n - 1) choose k))"
  by (auto simp add: gr0_conv_Suc)

lemma sum_unroll:
  "(\<Sum>k\<le>n::nat. f k) = (if n = 0 then f 0 else f n + (\<Sum>k\<le>n - 1. f k))"
by auto (metis One_nat_def Suc_pred add.commute sum_atMost_Suc)

lemma bernoulli_unroll:
  "n > 0 \<Longrightarrow> bernoulli n = - 1 / (real n + 1) * (\<Sum>k\<le>n - 1. real (n + 1 choose k) * bernoulli k)"
by (cases n) (simp add: bernoulli.simps One_nat_def)+

lemmas unroll = binomial_unroll
  bernoulli.simps(1) bernoulli_unroll sum_unroll bernpoly_def

lemma sum_of_squares: "(\<Sum>k\<le>n::nat. k ^ 2) = (2 * n ^ 3 + 3 * n ^ 2 + n) / 6"
proof -
  have "real (\<Sum>k\<le>n::nat. k ^ 2) = (\<Sum>k\<le>n::nat. (real k) ^ 2)" by simp
  also have "... = (bernpoly 3 (real (n + 1)) - bernpoly 3 0) / real (3 :: nat)"
    by (auto simp add: sum_of_powers)
  also have "... = (2 * n ^ 3 + 3 * n ^ 2 + n) / 6"
    by (simp add: unroll algebra_simps power2_eq_square power3_eq_cube One_nat_def[symmetric])
  finally show ?thesis by simp
qed

lemma sum_of_squares_nat: "(\<Sum>k\<le>n::nat. k ^ 2) = (2 * n ^ 3 + 3 * n ^ 2 + n) div 6"
proof -
  from sum_of_squares have "real (6 * (\<Sum>k\<le>n. k ^ 2)) = real (2 * n ^ 3 + 3 * n ^ 2 + n)"
    by (auto simp add: field_simps)
  then have "6 * (\<Sum>k\<le>n. k ^ 2) = 2 * n ^ 3 + 3 * n ^ 2 + n"
    using of_nat_eq_iff by blast
  then show ?thesis by auto
qed

lemma sum_of_cubes: "(\<Sum>k\<le>n::nat. k ^ 3) = (n ^ 2 + n) ^ 2 / 4"
proof -
  have two_plus_two: "2 + 2 = 4" by simp
  have power4_eq: "\<And>x::real. x ^ 4 = x * x * x * x"
    by (simp only: two_plus_two[symmetric] power_add power2_eq_square)
  have "real (\<Sum>k\<le>n::nat. k ^ 3) = (\<Sum>k\<le>n::nat. (real k) ^ 3)" by simp
  also have "... = ((bernpoly 4 (n + 1) - bernpoly 4 0)) / (real (4 :: nat))"
    by (auto simp add: sum_of_powers)
  also have "... = ((n ^ 2 + n) / 2) ^ 2"
    by (simp add: unroll algebra_simps power2_eq_square power4_eq power3_eq_cube)
  finally show ?thesis by (simp add: power_divide)
qed

lemma sum_of_cubes_nat: "(\<Sum>k\<le>n::nat. k ^ 3) = (n ^ 2 + n) ^ 2 div 4"
proof -
  from sum_of_cubes have "real (4 * (\<Sum>k\<le>n. k ^ 3)) = real ((n ^ 2 + n) ^ 2)"
    by (auto simp add: field_simps)
  then have "4 * (\<Sum>k\<le>n. k ^ 3) = (n ^ 2 + n) ^ 2"
    using of_nat_eq_iff by blast
  then show ?thesis by auto
qed

end


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

section\<open>Functions, Function Spaces, Lambda-Abstraction\<close>

theory func imports equalities Sum begin

subsection\<open>The Pi Operator: Dependent Function Space\<close>

lemma subset_Sigma_imp_relation: "r \<subseteq> Sigma(A,B) ==> relation(r)"
by (simp add: relation_def, blast)

lemma relation_converse_converse [simp]:
     "relation(r) ==> converse(converse(r)) = r"
by (simp add: relation_def, blast)

lemma relation_restrict [simp]:  "relation(restrict(r,A))"
by (simp add: restrict_def relation_def, blast)

lemma Pi_iff:
    "f \<in> Pi(A,B) \<longleftrightarrow> function(f) & f<=Sigma(A,B) & A<=domain(f)"
by (unfold Pi_def, blast)

(*For upward compatibility with the former definition*)
lemma Pi_iff_old:
    "f \<in> Pi(A,B) \<longleftrightarrow> f<=Sigma(A,B) & (\<forall>x\<in>A. \<exists>!y. <x,y>: f)"
by (unfold Pi_def function_def, blast)

lemma fun_is_function: "f \<in> Pi(A,B) ==> function(f)"
by (simp only: Pi_iff)

lemma function_imp_Pi:
     "[|function(f); relation(f)|] ==> f \<in> domain(f) -> range(f)"
by (simp add: Pi_iff relation_def, blast)

lemma functionI:
     "[| !!x y y'. [| <x,y>:r; <x,y'>:r |] ==> y=y' |] ==> function(r)"
by (simp add: function_def, blast)

(*Functions are relations*)
lemma fun_is_rel: "f \<in> Pi(A,B) ==> f \<subseteq> Sigma(A,B)"
by (unfold Pi_def, blast)

lemma Pi_cong:
    "[| A=A';  !!x. x \<in> A' ==> B(x)=B'(x) |] ==> Pi(A,B) = Pi(A',B')"
by (simp add: Pi_def cong add: Sigma_cong)

(*Sigma_cong, Pi_cong NOT given to Addcongs: they cause
  flex-flex pairs and the "Check your prover" error.  Most
  Sigmas and Pis are abbreviated as * or -> *)

(*Weakening one function type to another; see also Pi_type*)
lemma fun_weaken_type: "[| f \<in> A->B;  B<=D |] ==> f \<in> A->D"
by (unfold Pi_def, best)

subsection\<open>Function Application\<close>

lemma apply_equality2: "[| <a,b>: f;  <a,c>: f;  f \<in> Pi(A,B) |] ==> b=c"
by (unfold Pi_def function_def, blast)

lemma function_apply_equality: "[| <a,b>: f;  function(f) |] ==> f`a = b"
by (unfold apply_def function_def, blast)

lemma apply_equality: "[| <a,b>: f;  f \<in> Pi(A,B) |] ==> f`a = b"
apply (unfold Pi_def)
apply (blast intro: function_apply_equality)
done

(*Applying a function outside its domain yields 0*)
lemma apply_0: "a \<notin> domain(f) ==> f`a = 0"
by (unfold apply_def, blast)

lemma Pi_memberD: "[| f \<in> Pi(A,B);  c \<in> f |] ==> \<exists>x\<in>A.  c = <x,f`x>"
apply (frule fun_is_rel)
apply (blast dest: apply_equality)
done

lemma function_apply_Pair: "[| function(f);  a \<in> domain(f)|] ==> <a,f`a>: f"
apply (simp add: function_def, clarify)
apply (subgoal_tac "f`a = y", blast)
apply (simp add: apply_def, blast)
done

lemma apply_Pair: "[| f \<in> Pi(A,B);  a \<in> A |] ==> <a,f`a>: f"
apply (simp add: Pi_iff)
apply (blast intro: function_apply_Pair)
done

(*Conclusion is flexible -- use rule_tac or else apply_funtype below!*)
lemma apply_type [TC]: "[| f \<in> Pi(A,B);  a \<in> A |] ==> f`a \<in> B(a)"
by (blast intro: apply_Pair dest: fun_is_rel)

(*This version is acceptable to the simplifier*)
lemma apply_funtype: "[| f \<in> A->B;  a \<in> A |] ==> f`a \<in> B"
by (blast dest: apply_type)

lemma apply_iff: "f \<in> Pi(A,B) ==> <a,b>: f \<longleftrightarrow> a \<in> A & f`a = b"
apply (frule fun_is_rel)
apply (blast intro!: apply_Pair apply_equality)
done

(*Refining one Pi type to another*)
lemma Pi_type: "[| f \<in> Pi(A,C);  !!x. x \<in> A ==> f`x \<in> B(x) |] ==> f \<in> Pi(A,B)"
apply (simp only: Pi_iff)
apply (blast dest: function_apply_equality)
done

(*Such functions arise in non-standard datatypes, ZF/ex/Ntree for instance*)
lemma Pi_Collect_iff:
     "(f \<in> Pi(A, %x. {y \<in> B(x). P(x,y)}))
      \<longleftrightarrow>  f \<in> Pi(A,B) & (\<forall>x\<in>A. P(x, f`x))"
by (blast intro: Pi_type dest: apply_type)

lemma Pi_weaken_type:
        "[| f \<in> Pi(A,B);  !!x. x \<in> A ==> B(x)<=C(x) |] ==> f \<in> Pi(A,C)"
by (blast intro: Pi_type dest: apply_type)

(** Elimination of membership in a function **)

lemma domain_type: "[| <a,b> \<in> f;  f \<in> Pi(A,B) |] ==> a \<in> A"
by (blast dest: fun_is_rel)

lemma range_type: "[| <a,b> \<in> f;  f \<in> Pi(A,B) |] ==> b \<in> B(a)"
by (blast dest: fun_is_rel)

lemma Pair_mem_PiD: "[| <a,b>: f;  f \<in> Pi(A,B) |] ==> a \<in> A & b \<in> B(a) & f`a = b"
by (blast intro: domain_type range_type apply_equality)

subsection\<open>Lambda Abstraction\<close>

lemma lamI: "a \<in> A ==> <a,b(a)> \<in> (\<lambda>x\<in>A. b(x))"
apply (unfold lam_def)
apply (erule RepFunI)
done

lemma lamE:
    "[| p: (\<lambda>x\<in>A. b(x));  !!x.[| x \<in> A; p=<x,b(x)> |] ==> P
     |] ==>  P"
by (simp add: lam_def, blast)

lemma lamD: "[| <a,c>: (\<lambda>x\<in>A. b(x)) |] ==> c = b(a)"
by (simp add: lam_def)

lemma lam_type [TC]:
    "[| !!x. x \<in> A ==> b(x): B(x) |] ==> (\<lambda>x\<in>A. b(x)) \<in> Pi(A,B)"
by (simp add: lam_def Pi_def function_def, blast)

lemma lam_funtype: "(\<lambda>x\<in>A. b(x)) \<in> A -> {b(x). x \<in> A}"
by (blast intro: lam_type)

lemma function_lam: "function (\<lambda>x\<in>A. b(x))"
by (simp add: function_def lam_def)

lemma relation_lam: "relation (\<lambda>x\<in>A. b(x))"
by (simp add: relation_def lam_def)

lemma beta_if [simp]: "(\<lambda>x\<in>A. b(x)) ` a = (if a \<in> A then b(a) else 0)"
by (simp add: apply_def lam_def, blast)

lemma beta: "a \<in> A ==> (\<lambda>x\<in>A. b(x)) ` a = b(a)"
by (simp add: apply_def lam_def, blast)

lemma lam_empty [simp]: "(\<lambda>x\<in>0. b(x)) = 0"
by (simp add: lam_def)

lemma domain_lam [simp]: "domain(Lambda(A,b)) = A"
by (simp add: lam_def, blast)

(*congruence rule for lambda abstraction*)
lemma lam_cong [cong]:
    "[| A=A';  !!x. x \<in> A' ==> b(x)=b'(x) |] ==> Lambda(A,b) = Lambda(A',b')"
by (simp only: lam_def cong add: RepFun_cong)

lemma lam_theI:
    "(!!x. x \<in> A ==> \<exists>!y. Q(x,y)) ==> \<exists>f. \<forall>x\<in>A. Q(x, f`x)"
apply (rule_tac x = "\<lambda>x\<in>A. THE y. Q (x,y)" in exI)
apply simp
apply (blast intro: theI)
done

lemma lam_eqE: "[| (\<lambda>x\<in>A. f(x)) = (\<lambda>x\<in>A. g(x));  a \<in> A |] ==> f(a)=g(a)"
by (fast intro!: lamI elim: equalityE lamE)

(*Empty function spaces*)
lemma Pi_empty1 [simp]: "Pi(0,A) = {0}"
by (unfold Pi_def function_def, blast)

(*The singleton function*)
lemma singleton_fun [simp]: "{<a,b>} \<in> {a} -> {b}"
by (unfold Pi_def function_def, blast)

lemma Pi_empty2 [simp]: "(A->0) = (if A=0 then {0} else 0)"
by (unfold Pi_def function_def, force)

lemma  fun_space_empty_iff [iff]: "(A->X)=0 \<longleftrightarrow> X=0 & (A \<noteq> 0)"
apply auto
apply (fast intro!: equals0I intro: lam_type)
done

subsection\<open>Extensionality\<close>

(*Semi-extensionality!*)

lemma fun_subset:
    "[| f \<in> Pi(A,B);  g \<in> Pi(C,D);  A<=C;
        !!x. x \<in> A ==> f`x = g`x       |] ==> f<=g"
by (force dest: Pi_memberD intro: apply_Pair)

lemma fun_extension:
    "[| f \<in> Pi(A,B);  g \<in> Pi(A,D);
        !!x. x \<in> A ==> f`x = g`x       |] ==> f=g"
by (blast del: subsetI intro: subset_refl sym fun_subset)

lemma eta [simp]: "f \<in> Pi(A,B) ==> (\<lambda>x\<in>A. f`x) = f"
apply (rule fun_extension)
apply (auto simp add: lam_type apply_type beta)
done

lemma fun_extension_iff:
     "[| f \<in> Pi(A,B); g \<in> Pi(A,C) |] ==> (\<forall>a\<in>A. f`a = g`a) \<longleftrightarrow> f=g"
by (blast intro: fun_extension)

(*thm by Mark Staples, proof by lcp*)
lemma fun_subset_eq: "[| f \<in> Pi(A,B); g \<in> Pi(A,C) |] ==> f \<subseteq> g \<longleftrightarrow> (f = g)"
by (blast dest: apply_Pair
          intro: fun_extension apply_equality [symmetric])

(*Every element of Pi(A,B) may be expressed as a lambda abstraction!*)
lemma Pi_lamE:
  assumes major: "f \<in> Pi(A,B)"
      and minor: "!!b. [| \<forall>x\<in>A. b(x):B(x);  f = (\<lambda>x\<in>A. b(x)) |] ==> P"
  shows "P"
apply (rule minor)
apply (rule_tac [2] eta [symmetric])
apply (blast intro: major apply_type)+
done

subsection\<open>Images of Functions\<close>

lemma image_lam: "C \<subseteq> A ==> (\<lambda>x\<in>A. b(x)) `` C = {b(x). x \<in> C}"
by (unfold lam_def, blast)

lemma Repfun_function_if:
     "function(f)
      ==> {f`x. x \<in> C} = (if C \<subseteq> domain(f) then f``C else cons(0,f``C))"
apply simp
apply (intro conjI impI)
 apply (blast dest: function_apply_equality intro: function_apply_Pair)
apply (rule equalityI)
 apply (blast intro!: function_apply_Pair apply_0)
apply (blast dest: function_apply_equality intro: apply_0 [symmetric])
done

(*For this lemma and the next, the right-hand side could equivalently
  be written \<Union>x\<in>C. {f`x} *)
lemma image_function:
     "[| function(f);  C \<subseteq> domain(f) |] ==> f``C = {f`x. x \<in> C}"
by (simp add: Repfun_function_if)

lemma image_fun: "[| f \<in> Pi(A,B);  C \<subseteq> A |] ==> f``C = {f`x. x \<in> C}"
apply (simp add: Pi_iff)
apply (blast intro: image_function)
done

lemma image_eq_UN:
  assumes f: "f \<in> Pi(A,B)" "C \<subseteq> A" shows "f``C = (\<Union>x\<in>C. {f ` x})"
by (auto simp add: image_fun [OF f])

lemma Pi_image_cons:
     "[| f \<in> Pi(A,B);  x \<in> A |] ==> f `` cons(x,y) = cons(f`x, f``y)"
by (blast dest: apply_equality apply_Pair)

subsection\<open>Properties of @{term "restrict(f,A)"}\<close>

lemma restrict_subset: "restrict(f,A) \<subseteq> f"
by (unfold restrict_def, blast)

lemma function_restrictI:
    "function(f) ==> function(restrict(f,A))"
by (unfold restrict_def function_def, blast)

lemma restrict_type2: "[| f \<in> Pi(C,B);  A<=C |] ==> restrict(f,A) \<in> Pi(A,B)"
by (simp add: Pi_iff function_def restrict_def, blast)

lemma restrict: "restrict(f,A) ` a = (if a \<in> A then f`a else 0)"
by (simp add: apply_def restrict_def, blast)

lemma restrict_empty [simp]: "restrict(f,0) = 0"
by (unfold restrict_def, simp)

lemma restrict_iff: "z \<in> restrict(r,A) \<longleftrightarrow> z \<in> r & (\<exists>x\<in>A. \<exists>y. z = \<langle>x, y\<rangle>)"
by (simp add: restrict_def)

lemma restrict_restrict [simp]:
     "restrict(restrict(r,A),B) = restrict(r, A \<inter> B)"
by (unfold restrict_def, blast)

lemma domain_restrict [simp]: "domain(restrict(f,C)) = domain(f) \<inter> C"
apply (unfold restrict_def)
apply (auto simp add: domain_def)
done

lemma restrict_idem: "f \<subseteq> Sigma(A,B) ==> restrict(f,A) = f"
by (simp add: restrict_def, blast)

(*converse probably holds too*)
lemma domain_restrict_idem:
     "[| domain(r) \<subseteq> A; relation(r) |] ==> restrict(r,A) = r"
by (simp add: restrict_def relation_def, blast)

lemma domain_restrict_lam [simp]: "domain(restrict(Lambda(A,f),C)) = A \<inter> C"
apply (unfold restrict_def lam_def)
apply (rule equalityI)
apply (auto simp add: domain_iff)
done

lemma restrict_if [simp]: "restrict(f,A) ` a = (if a \<in> A then f`a else 0)"
by (simp add: restrict apply_0)

lemma restrict_lam_eq:
    "A<=C ==> restrict(\<lambda>x\<in>C. b(x), A) = (\<lambda>x\<in>A. b(x))"
by (unfold restrict_def lam_def, auto)

lemma fun_cons_restrict_eq:
     "f \<in> cons(a, b) -> B ==> f = cons(<a, f ` a>, restrict(f, b))"
apply (rule equalityI)
 prefer 2 apply (blast intro: apply_Pair restrict_subset [THEN subsetD])
apply (auto dest!: Pi_memberD simp add: restrict_def lam_def)
done

subsection\<open>Unions of Functions\<close>

(** The Union of a set of COMPATIBLE functions is a function **)

lemma function_Union:
    "[| \<forall>x\<in>S. function(x);
        \<forall>x\<in>S. \<forall>y\<in>S. x<=y | y<=x  |]
     ==> function(\<Union>(S))"
by (unfold function_def, blast)

lemma fun_Union:
    "[| \<forall>f\<in>S. \<exists>C D. f \<in> C->D;
             \<forall>f\<in>S. \<forall>y\<in>S. f<=y | y<=f  |] ==>
          \<Union>(S) \<in> domain(\<Union>(S)) -> range(\<Union>(S))"
apply (unfold Pi_def)
apply (blast intro!: rel_Union function_Union)
done

lemma gen_relation_Union [rule_format]:
     "\<forall>f\<in>F. relation(f) \<Longrightarrow> relation(\<Union>(F))"
by (simp add: relation_def)

(** The Union of 2 disjoint functions is a function **)

lemmas Un_rls = Un_subset_iff SUM_Un_distrib1 prod_Un_distrib2
                subset_trans [OF _ Un_upper1]
                subset_trans [OF _ Un_upper2]

lemma fun_disjoint_Un:
     "[| f \<in> A->B;  g \<in> C->D;  A \<inter> C = 0  |]
      ==> (f \<union> g) \<in> (A \<union> C) -> (B \<union> D)"
(*Prove the product and domain subgoals using distributive laws*)
apply (simp add: Pi_iff extension Un_rls)
apply (unfold function_def, blast)
done

lemma fun_disjoint_apply1: "a \<notin> domain(g) ==> (f \<union> g)`a = f`a"
by (simp add: apply_def, blast)

lemma fun_disjoint_apply2: "c \<notin> domain(f) ==> (f \<union> g)`c = g`c"
by (simp add: apply_def, blast)

subsection\<open>Domain and Range of a Function or Relation\<close>

lemma domain_of_fun: "f \<in> Pi(A,B) ==> domain(f)=A"
by (unfold Pi_def, blast)

lemma apply_rangeI: "[| f \<in> Pi(A,B);  a \<in> A |] ==> f`a \<in> range(f)"
by (erule apply_Pair [THEN rangeI], assumption)

lemma range_of_fun: "f \<in> Pi(A,B) ==> f \<in> A->range(f)"
by (blast intro: Pi_type apply_rangeI)

subsection\<open>Extensions of Functions\<close>

lemma fun_extend:
     "[| f \<in> A->B;  c\<notin>A |] ==> cons(<c,b>,f) \<in> cons(c,A) -> cons(b,B)"
apply (frule singleton_fun [THEN fun_disjoint_Un], blast)
apply (simp add: cons_eq)
done

lemma fun_extend3:
     "[| f \<in> A->B;  c\<notin>A;  b \<in> B |] ==> cons(<c,b>,f) \<in> cons(c,A) -> B"
by (blast intro: fun_extend [THEN fun_weaken_type])

lemma extend_apply:
     "c \<notin> domain(f) ==> cons(<c,b>,f)`a = (if a=c then b else f`a)"
by (auto simp add: apply_def)

lemma fun_extend_apply [simp]:
     "[| f \<in> A->B;  c\<notin>A |] ==> cons(<c,b>,f)`a = (if a=c then b else f`a)"
apply (rule extend_apply)
apply (simp add: Pi_def, blast)
done

lemmas singleton_apply = apply_equality [OF singletonI singleton_fun, simp]

(*For Finite.ML.  Inclusion of right into left is easy*)
lemma cons_fun_eq:
     "c \<notin> A ==> cons(c,A) -> B = (\<Union>f \<in> A->B. \<Union>b\<in>B. {cons(<c,b>, f)})"
apply (rule equalityI)
apply (safe elim!: fun_extend3)
(*Inclusion of left into right*)
apply (subgoal_tac "restrict (x, A) \<in> A -> B")
 prefer 2 apply (blast intro: restrict_type2)
apply (rule UN_I, assumption)
apply (rule apply_funtype [THEN UN_I])
  apply assumption
 apply (rule consI1)
apply (simp (no_asm))
apply (rule fun_extension)
  apply assumption
 apply (blast intro: fun_extend)
apply (erule consE, simp_all)
done

lemma succ_fun_eq: "succ(n) -> B = (\<Union>f \<in> n->B. \<Union>b\<in>B. {cons(<n,b>, f)})"
by (simp add: succ_def mem_not_refl cons_fun_eq)

subsection\<open>Function Updates\<close>

definition
  update  :: "[i,i,i] => i"  where
   "update(f,a,b) == \<lambda>x\<in>cons(a, domain(f)). if(x=a, b, f`x)"

nonterminal updbinds and updbind

syntax

  (* Let expressions *)

  "_updbind"    :: "[i, i] => updbind"               ("(2_ :=/ _)")
  ""            :: "updbind => updbinds"             ("_")
  "_updbinds"   :: "[updbind, updbinds] => updbinds" ("_,/ _")
  "_Update"     :: "[i, updbinds] => i"              ("_/'((_)')" [900,0] 900)

translations
  "_Update (f, _updbinds(b,bs))"  == "_Update (_Update(f,b), bs)"
  "f(x:=y)"                       == "CONST update(f,x,y)"

lemma update_apply [simp]: "f(x:=y) ` z = (if z=x then y else f`z)"
apply (simp add: update_def)
apply (case_tac "z \<in> domain(f)")
apply (simp_all add: apply_0)
done

lemma update_idem: "[| f`x = y;  f \<in> Pi(A,B);  x \<in> A |] ==> f(x:=y) = f"
apply (unfold update_def)
apply (simp add: domain_of_fun cons_absorb)
apply (rule fun_extension)
apply (best intro: apply_type if_type lam_type, assumption, simp)
done

(* [| f \<in> Pi(A, B); x \<in> A |] ==> f(x := f`x) = f *)
declare refl [THEN update_idem, simp]

lemma domain_update [simp]: "domain(f(x:=y)) = cons(x, domain(f))"
by (unfold update_def, simp)

lemma update_type: "[| f \<in> Pi(A,B);  x \<in> A;  y \<in> B(x) |] ==> f(x:=y) \<in> Pi(A, B)"
apply (unfold update_def)
apply (simp add: domain_of_fun cons_absorb apply_funtype lam_type)
done

subsection\<open>Monotonicity Theorems\<close>

subsubsection\<open>Replacement in its Various Forms\<close>

(*Not easy to express monotonicity in P, since any "bigger" predicate
  would have to be single-valued*)
lemma Replace_mono: "A<=B ==> Replace(A,P) \<subseteq> Replace(B,P)"
by (blast elim!: ReplaceE)

lemma RepFun_mono: "A<=B ==> {f(x). x \<in> A} \<subseteq> {f(x). x \<in> B}"
by blast

lemma Pow_mono: "A<=B ==> Pow(A) \<subseteq> Pow(B)"
by blast

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

lemma UN_mono:
    "[| A<=C;  !!x. x \<in> A ==> B(x)<=D(x) |] ==> (\<Union>x\<in>A. B(x)) \<subseteq> (\<Union>x\<in>C. D(x))"
by blast

(*Intersection is ANTI-monotonic.  There are TWO premises! *)
lemma Inter_anti_mono: "[| A<=B;  A\<noteq>0 |] ==> \<Inter>(B) \<subseteq> \<Inter>(A)"
by blast

lemma cons_mono: "C<=D ==> cons(a,C) \<subseteq> cons(a,D)"
by blast

lemma Un_mono: "[| A<=C;  B<=D |] ==> A \<union> B \<subseteq> C \<union> D"
by blast

lemma Int_mono: "[| A<=C;  B<=D |] ==> A \<inter> B \<subseteq> C \<inter> D"
by blast

lemma Diff_mono: "[| A<=C;  D<=B |] ==> A-B \<subseteq> C-D"
by blast

subsubsection\<open>Standard Products, Sums and Function Spaces\<close>

lemma Sigma_mono [rule_format]:
     "[| A<=C;  !!x. x \<in> A \<longrightarrow> B(x) \<subseteq> D(x) |] ==> Sigma(A,B) \<subseteq> Sigma(C,D)"
by blast

lemma sum_mono: "[| A<=C;  B<=D |] ==> A+B \<subseteq> C+D"
by (unfold sum_def, blast)

(*Note that B->A and C->A are typically disjoint!*)
lemma Pi_mono: "B<=C ==> A->B \<subseteq> A->C"
by (blast intro: lam_type elim: Pi_lamE)

lemma lam_mono: "A<=B ==> Lambda(A,c) \<subseteq> Lambda(B,c)"
apply (unfold lam_def)
apply (erule RepFun_mono)
done

subsubsection\<open>Converse, Domain, Range, Field\<close>

lemma converse_mono: "r<=s ==> converse(r) \<subseteq> converse(s)"
by blast

lemma domain_mono: "r<=s ==> domain(r)<=domain(s)"
by blast

lemmas domain_rel_subset = subset_trans [OF domain_mono domain_subset]

lemma range_mono: "r<=s ==> range(r)<=range(s)"
by blast

lemmas range_rel_subset = subset_trans [OF range_mono range_subset]

lemma field_mono: "r<=s ==> field(r)<=field(s)"
by blast

lemma field_rel_subset: "r \<subseteq> A*A ==> field(r) \<subseteq> A"
by (erule field_mono [THEN subset_trans], blast)

subsubsection\<open>Images\<close>

lemma image_pair_mono:
    "[| !! x y. <x,y>:r ==> <x,y>:s;  A<=B |] ==> r``A \<subseteq> s``B"
by blast

lemma vimage_pair_mono:
    "[| !! x y. <x,y>:r ==> <x,y>:s;  A<=B |] ==> r-``A \<subseteq> s-``B"
by blast

lemma image_mono: "[| r<=s;  A<=B |] ==> r``A \<subseteq> s``B"
by blast

lemma vimage_mono: "[| r<=s;  A<=B |] ==> r-``A \<subseteq> s-``B"
by blast

lemma Collect_mono:
    "[| A<=B;  !!x. x \<in> A ==> P(x) \<longrightarrow> Q(x) |] ==> Collect(A,P) \<subseteq> Collect(B,Q)"
by blast

(*Used in intr_elim.ML and in individual datatype definitions*)
lemmas basic_monos = subset_refl imp_refl disj_mono conj_mono ex_mono
                     Collect_mono Part_mono in_mono

(* Useful with simp; contributed by Clemens Ballarin. *)

lemma bex_image_simp:
  "[| f \<in> Pi(X, Y); A \<subseteq> X |]  ==> (\<exists>x\<in>f``A. P(x)) \<longleftrightarrow> (\<exists>x\<in>A. P(f`x))"
  apply safe
   apply rule
    prefer 2 apply assumption
   apply (simp add: apply_equality)
  apply (blast intro: apply_Pair)
  done

lemma ball_image_simp:
  "[| f \<in> Pi(X, Y); A \<subseteq> X |]  ==> (\<forall>x\<in>f``A. P(x)) \<longleftrightarrow> (\<forall>x\<in>A. P(f`x))"
  apply safe
   apply (blast intro: apply_Pair)
  apply (drule bspec) apply assumption
  apply (simp add: apply_equality)
  done

end