header {* \isaheader{CFG} *}

theory CFG imports BasicDefs begin

subsection {* The abstract CFG *}

locale CFG =
  fixes sourcenode :: "'edge \<Rightarrow> 'node"
  fixes targetnode :: "'edge \<Rightarrow> 'node"
  fixes kind :: "'edge \<Rightarrow> 'state edge_kind"
  fixes valid_edge :: "'edge \<Rightarrow> bool"
  fixes Entry::"'node" ("'('_Entry'_')")
  assumes Entry_target [dest]: "\<lbrakk>valid_edge a; targetnode a = (_Entry_)\<rbrakk> \<Longrightarrow> False"
  and edge_det:
  "\<lbrakk>valid_edge a; valid_edge a'; sourcenode a = sourcenode a';
    targetnode a = targetnode a'\<rbrakk> \<Longrightarrow> a = a'"

begin

definition valid_node :: "'node \<Rightarrow> bool"
  where "valid_node n \<equiv>
  (\<exists>a. valid_edge a \<and> (n = sourcenode a \<or> n = targetnode a))"

lemma [simp]: "valid_edge a \<Longrightarrow> valid_node (targetnode a)"
  by(fastforce simp:valid_node_def)

subsection {* CFG paths and lemmas *}

inductive path :: "'node \<Rightarrow> 'edge list \<Rightarrow> 'node \<Rightarrow> bool"
  ("_ -_\<rightarrow>* _" [51,0,0] 80)
where
  empty_path:"valid_node n \<Longrightarrow> n -[]\<rightarrow>* n"

  | Cons_path:
  "\<lbrakk>n'' -as\<rightarrow>* n'; valid_edge a; sourcenode a = n; targetnode a = n''\<rbrakk>
    \<Longrightarrow> n -a#as\<rightarrow>* n'"

lemma path_valid_node:
  assumes "n -as\<rightarrow>* n'" shows "valid_node n" and "valid_node n'"
  using `n -as\<rightarrow>* n'`
  by(induct rule:path.induct,auto)

lemma empty_path_nodes [dest]:"n -[]\<rightarrow>* n' \<Longrightarrow> n = n'"
  by(fastforce elim:path.cases)

lemma path_valid_edges:"n -as\<rightarrow>* n' \<Longrightarrow> \<forall>a \<in> set as. valid_edge a"
by(induct rule:path.induct) auto

lemma path_edge:"valid_edge a \<Longrightarrow> sourcenode a -[a]\<rightarrow>* targetnode a"
  by(fastforce intro:Cons_path empty_path)

lemma path_Entry_target [dest]:
  assumes "n -as\<rightarrow>* (_Entry_)"
  shows "n = (_Entry_)" and "as = []"
using `n -as\<rightarrow>* (_Entry_)`
proof(induct n as n'\<equiv>"(_Entry_)" rule:path.induct)
  case (Cons_path n'' as a n)
  from `targetnode a = n''` `valid_edge a` `n'' = (_Entry_)` have False
    by -(rule Entry_target,simp_all)
  { case 1
    with `False` show ?case ..
  next
    case 2
    with `False` show ?case ..
  }
qed simp_all

lemma path_Append:"\<lbrakk>n -as\<rightarrow>* n''; n'' -as'\<rightarrow>* n'\<rbrakk>
  \<Longrightarrow> n -as@as'\<rightarrow>* n'"
by(induct rule:path.induct,auto intro:Cons_path)

lemma path_split:
  assumes "n -as@a#as'\<rightarrow>* n'"
  shows "n -as\<rightarrow>* sourcenode a" and "valid_edge a" and "targetnode a -as'\<rightarrow>* n'"
  using `n -as@a#as'\<rightarrow>* n'`
proof(induct as arbitrary:n)
  case Nil case 1
  thus ?case by(fastforce elim:path.cases intro:empty_path)
next
  case Nil case 2
  thus ?case by(fastforce elim:path.cases intro:path_edge)
next
  case Nil case 3
  thus ?case by(fastforce elim:path.cases)
next
  case (Cons ax asx)
  note IH1 = `\<And>n. n -asx@a#as'\<rightarrow>* n' \<Longrightarrow> n -asx\<rightarrow>* sourcenode a`
  note IH2 = `\<And>n. n -asx@a#as'\<rightarrow>* n' \<Longrightarrow> valid_edge a`
  note IH3 = `\<And>n. n -asx@a#as'\<rightarrow>* n' \<Longrightarrow> targetnode a -as'\<rightarrow>* n'`
  { case 1
    hence "sourcenode ax = n" and "targetnode ax -asx@a#as'\<rightarrow>* n'" and "valid_edge ax"
      by(auto elim:path.cases)
    from IH1[OF ` targetnode ax -asx@a#as'\<rightarrow>* n'`]
    have "targetnode ax -asx\<rightarrow>* sourcenode a" .
    with `sourcenode ax = n` `valid_edge ax` show ?case by(fastforce intro:Cons_path)
  next
    case 2 hence "targetnode ax -asx@a#as'\<rightarrow>* n'" by(auto elim:path.cases)
    from IH2[OF this] show ?case .
  next
    case 3 hence "targetnode ax -asx@a#as'\<rightarrow>* n'" by(auto elim:path.cases)
    from IH3[OF this] show ?case .
  }
qed

lemma path_split_Cons:
  assumes "n -as\<rightarrow>* n'" and "as \<noteq> []"
  obtains a' as' where "as = a'#as'" and "n = sourcenode a'"
  and "valid_edge a'" and "targetnode a' -as'\<rightarrow>* n'"
proof -
  from `as \<noteq> []` obtain a' as' where "as = a'#as'" by(cases as) auto
  with `n -as\<rightarrow>* n'` have "n -[]@a'#as'\<rightarrow>* n'" by simp
  hence "n -[]\<rightarrow>* sourcenode a'" and "valid_edge a'" and "targetnode a' -as'\<rightarrow>* n'"
    by(rule path_split)+
  from `n -[]\<rightarrow>* sourcenode a'` have "n = sourcenode a'" by fast
  with `as = a'#as'` `valid_edge a'` `targetnode a' -as'\<rightarrow>* n'` that show ?thesis
    by fastforce
qed

lemma path_split_snoc:
  assumes "n -as\<rightarrow>* n'" and "as \<noteq> []"
  obtains a' as' where "as = as'@[a']" and "n -as'\<rightarrow>* sourcenode a'"
  and "valid_edge a'" and "n' = targetnode a'"
proof -
  from `as \<noteq> []` obtain a' as' where "as = as'@[a']" by(cases as rule:rev_cases) auto
  with `n -as\<rightarrow>* n'` have "n -as'@a'#[]\<rightarrow>* n'" by simp
  hence "n -as'\<rightarrow>* sourcenode a'" and "valid_edge a'" and "targetnode a' -[]\<rightarrow>* n'"
    by(rule path_split)+
  from `targetnode a' -[]\<rightarrow>* n'` have "n' = targetnode a'" by fast
  with `as = as'@[a']` `valid_edge a'` `n -as'\<rightarrow>* sourcenode a'` that show ?thesis
    by fastforce
qed

lemma path_split_second:
  assumes "n -as@a#as'\<rightarrow>* n'" shows "sourcenode a -a#as'\<rightarrow>* n'"
proof -
  from `n -as@a#as'\<rightarrow>* n'` have "valid_edge a" and "targetnode a -as'\<rightarrow>* n'"
    by(auto intro:path_split)
  thus ?thesis by(fastforce intro:Cons_path)
qed

lemma path_Entry_Cons:
  assumes "(_Entry_) -as\<rightarrow>* n'" and "n' \<noteq> (_Entry_)"
  obtains n a where "sourcenode a = (_Entry_)" and "targetnode a = n"
  and "n -tl as\<rightarrow>* n'" and "valid_edge a" and "a = hd as"
proof -
  from `(_Entry_) -as\<rightarrow>* n'` `n' \<noteq> (_Entry_)` have "as \<noteq> []"
    by(cases as,auto elim:path.cases)
  with `(_Entry_) -as\<rightarrow>* n'` obtain a' as' where "as = a'#as'"
    and "(_Entry_) = sourcenode a'" and "valid_edge a'" and "targetnode a' -as'\<rightarrow>* n'"
    by(erule path_split_Cons)
  with that show ?thesis by fastforce
qed

lemma path_det:
  "\<lbrakk>n -as\<rightarrow>* n'; n -as\<rightarrow>* n''\<rbrakk> \<Longrightarrow> n' = n''"
proof(induct as arbitrary:n)
  case Nil thus ?case by(auto elim:path.cases)
next
  case (Cons a' as')
  note IH = `\<And>n. \<lbrakk>n -as'\<rightarrow>* n'; n -as'\<rightarrow>* n''\<rbrakk> \<Longrightarrow> n' = n''`
  from `n -a'#as'\<rightarrow>* n'` have "targetnode a' -as'\<rightarrow>* n'"
    by(fastforce elim:path_split_Cons)
  from `n -a'#as'\<rightarrow>* n''` have "targetnode a' -as'\<rightarrow>* n''"
    by(fastforce elim:path_split_Cons)
  from IH[OF `targetnode a' -as'\<rightarrow>* n'` this] show ?thesis .
qed

definition
  sourcenodes :: "'edge list \<Rightarrow> 'node list"
  where "sourcenodes xs \<equiv> map sourcenode xs"

definition
  kinds :: "'edge list \<Rightarrow> 'state edge_kind list"
  where "kinds xs \<equiv> map kind xs"

definition
  targetnodes :: "'edge list \<Rightarrow> 'node list"
  where "targetnodes xs \<equiv> map targetnode xs"

lemma path_sourcenode:
  "\<lbrakk>n -as\<rightarrow>* n'; as \<noteq> []\<rbrakk> \<Longrightarrow> hd (sourcenodes as) = n"
by(fastforce elim:path_split_Cons simp:sourcenodes_def)

lemma path_targetnode:
  "\<lbrakk>n -as\<rightarrow>* n'; as \<noteq> []\<rbrakk> \<Longrightarrow> last (targetnodes as) = n'"
by(fastforce elim:path_split_snoc simp:targetnodes_def)

lemma sourcenodes_is_n_Cons_butlast_targetnodes:
  "\<lbrakk>n -as\<rightarrow>* n'; as \<noteq> []\<rbrakk> \<Longrightarrow>
  sourcenodes as = n#(butlast (targetnodes as))"
proof(induct as arbitrary:n)
  case Nil thus ?case by simp
next
  case (Cons a' as')
  note IH = `\<And>n. \<lbrakk>n -as'\<rightarrow>* n'; as' \<noteq> []\<rbrakk>
            \<Longrightarrow> sourcenodes as' = n#(butlast (targetnodes as'))`
  from `n -a'#as'\<rightarrow>* n'` have "n = sourcenode a'" and "targetnode a' -as'\<rightarrow>* n'"
    by(auto elim:path_split_Cons)
  show ?case
  proof(cases "as' = []")
    case True
    with `targetnode a' -as'\<rightarrow>* n'` have "targetnode a' = n'" by fast
    with True `n = sourcenode a'` show ?thesis
      by(simp add:sourcenodes_def targetnodes_def)
  next
    case False
    from IH[OF `targetnode a' -as'\<rightarrow>* n'` this]
    have "sourcenodes as' = targetnode a' # butlast (targetnodes as')" .
    with `n = sourcenode a'` False show ?thesis
      by(simp add:sourcenodes_def targetnodes_def)
  qed
qed

lemma targetnodes_is_tl_sourcenodes_App_n':
  "\<lbrakk>n -as\<rightarrow>* n'; as \<noteq> []\<rbrakk> \<Longrightarrow>
    targetnodes as = (tl (sourcenodes as))@[n']"
proof(induct as arbitrary:n' rule:rev_induct)
  case Nil thus ?case by simp
next
  case (snoc a' as')
  note IH = `\<And>n'. \<lbrakk>n -as'\<rightarrow>* n'; as' \<noteq> []\<rbrakk>
    \<Longrightarrow> targetnodes as' = tl (sourcenodes as') @ [n']`
  from `n -as'@[a']\<rightarrow>* n'` have "n -as'\<rightarrow>* sourcenode a'" and "n' = targetnode a'"
    by(auto elim:path_split_snoc)
  show ?case
  proof(cases "as' = []")
    case True
    with `n -as'\<rightarrow>* sourcenode a'` have "n = sourcenode a'" by fast
    with True `n' = targetnode a'` show ?thesis
      by(simp add:sourcenodes_def targetnodes_def)
  next
    case False
    from IH[OF `n -as'\<rightarrow>* sourcenode a'` this]
    have "targetnodes as' = tl (sourcenodes as')@[sourcenode a']" .
    with `n' = targetnode a'` False show ?thesis
      by(simp add:sourcenodes_def targetnodes_def)
  qed
qed

lemma Entry_sourcenode_hd:
  assumes "n -as\<rightarrow>* n'" and "(_Entry_) \<in> set (sourcenodes as)"
  shows "n = (_Entry_)" and "(_Entry_) \<notin> set (sourcenodes (tl as))"
  using `n -as\<rightarrow>* n'` `(_Entry_) \<in> set (sourcenodes as)`
proof(induct rule:path.induct)
  case (empty_path n) case 1
  thus ?case by(simp add:sourcenodes_def)
next
  case (empty_path n) case 2
  thus ?case by(simp add:sourcenodes_def)
next
  case (Cons_path n'' as n' a n)
  note IH1 = `(_Entry_) \<in> set(sourcenodes as) \<Longrightarrow> n'' = (_Entry_)`
  note IH2 = `(_Entry_) \<in> set(sourcenodes as) \<Longrightarrow> (_Entry_) \<notin> set(sourcenodes(tl as))`
  have "(_Entry_) \<notin> set (sourcenodes(tl(a#as)))"
  proof
    assume "(_Entry_) \<in> set (sourcenodes (tl (a#as)))"
    hence "(_Entry_) \<in> set (sourcenodes as)" by simp
    from IH1[OF this] have "n'' = (_Entry_)" by simp
    with `targetnode a = n''` `valid_edge a` show False by -(erule Entry_target,simp)
  qed
  hence "(_Entry_) \<notin> set (sourcenodes(tl(a#as)))" by fastforce
  { case 1
    with `(_Entry_) \<notin> set (sourcenodes(tl(a#as)))` `sourcenode a = n`
    show ?case by(simp add:sourcenodes_def)
  next
    case 2
    with `(_Entry_) \<notin> set (sourcenodes(tl(a#as)))` `sourcenode a = n`
    show ?case by(simp add:sourcenodes_def)
  }
qed

end

end


(*
  File:   Banach_Steinhaus.thy
  Author: Dominique Unruh, University of Tartu
  Author: Jose Manuel Rodriguez Caballero, University of Tartu
*)
section \<open>Banach-Steinhaus theorem\<close>

theory Banach_Steinhaus
  imports Banach_Steinhaus_Missing
begin

text \<open>
  We formalize Banach-Steinhaus theorem as theorem @{text banach_steinhaus}. This theorem was
  originally proved in Banach-Steinhaus's paper~\<^cite>\<open>"banach1927principe"\<close>. For the proof, we follow
  Sokal's approach~\<^cite>\<open>"sokal2011really"\<close>. Furthermore, we prove as a corollary a result about
  pointwise convergent sequences of bounded operators whose domain is a Banach space.
\<close>

subsection \<open>Preliminaries for Sokal's proof of Banach-Steinhaus theorem\<close>

lemma linear_plus_norm:
  includes notation_norm
  assumes \<open>linear f\<close>
  shows \<open>\<parallel>f \<xi>\<parallel> \<le> max \<parallel>f (x + \<xi>)\<parallel> \<parallel>f (x - \<xi>)\<parallel>\<close>
  text \<open>
  Explanation: For arbitrary \<^term>\<open>x\<close> and a linear operator \<^term>\<open>f\<close>,
  \<^term>\<open>norm (f \<xi>)\<close> is upper bounded by the maximum of the norms
  of the shifts of \<^term>\<open>f\<close> (i.e., \<^term>\<open>f (x + \<xi>)\<close> and \<^term>\<open>f (x - \<xi>)\<close>).
\<close>
proof-
  have \<open>norm (f \<xi>) = norm ( (inverse (of_nat 2)) *\<^sub>R (f (x + \<xi>) - f (x - \<xi>)) )\<close>
    by (smt add_diff_cancel_left' assms diff_add_cancel diff_diff_add linear_diff midpoint_def
        midpoint_plus_self of_nat_1 of_nat_add one_add_one scaleR_half_double)
  also have \<open>\<dots> = inverse (of_nat 2) * norm (f (x + \<xi>) - f (x - \<xi>))\<close>
    using Real_Vector_Spaces.real_normed_vector_class.norm_scaleR by simp
  also have \<open>\<dots> \<le> inverse (of_nat 2) * (norm (f (x + \<xi>)) + norm (f (x - \<xi>)))\<close>
    by (simp add: norm_triangle_ineq4)
  also have \<open>\<dots> \<le>  max (norm (f (x + \<xi>))) (norm (f (x - \<xi>)))\<close>
    by auto
  finally show ?thesis by blast
qed

lemma onorm_Sup_on_ball:
  includes notation_norm
  assumes \<open>r > 0\<close>
  shows "\<parallel>f\<parallel> \<le> Sup ( (\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball x r) ) / r"
  text \<open>
  Explanation: Let \<^term>\<open>f\<close> be a bounded operator and let \<^term>\<open>x\<close> be a point. For any \<^term>\<open>r > 0\<close>,
  the operator norm of \<^term>\<open>f\<close> is bounded above by the supremum of $f$ applied to the open ball of
  radius \<^term>\<open>r\<close> around \<^term>\<open>x\<close>, divided by \<^term>\<open>r\<close>.
\<close>
proof-
  have bdd_above_3: \<open>bdd_above ((\<lambda>x. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 r))\<close>
  proof -
    obtain M where \<open>\<And> \<xi>.  \<parallel>f *\<^sub>v \<xi>\<parallel> \<le> M * norm \<xi>\<close> and \<open>M \<ge> 0\<close>
      using norm_blinfun norm_ge_zero by blast
    hence \<open>\<And> \<xi>. \<xi> \<in> ball 0 r \<Longrightarrow> \<parallel>f *\<^sub>v \<xi>\<parallel> \<le> M * r\<close>
      using \<open>r > 0\<close> by (smt mem_ball_0 mult_left_mono)
    thus ?thesis by (meson bdd_aboveI2)
  qed
  have bdd_above_2: \<open>bdd_above ((\<lambda> \<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` (ball 0 r))\<close>
  proof-
    have \<open>bdd_above ((\<lambda> \<xi>. \<parallel>f *\<^sub>v x\<parallel>) ` (ball 0 r))\<close>
      by auto
    moreover have \<open>bdd_above ((\<lambda> \<xi>. \<parallel>f *\<^sub>v \<xi>\<parallel>) ` (ball 0 r))\<close>
      using bdd_above_3 by blast
    ultimately have \<open>bdd_above ((\<lambda> \<xi>. \<parallel>f *\<^sub>v x\<parallel> + \<parallel>f *\<^sub>v \<xi>\<parallel>) ` (ball 0 r))\<close>
      by (rule bdd_above_plus)
    then obtain M where \<open>\<And> \<xi>. \<xi> \<in> ball 0 r \<Longrightarrow> \<parallel>f *\<^sub>v x\<parallel> + \<parallel>f *\<^sub>v \<xi>\<parallel> \<le> M\<close>
      unfolding bdd_above_def by (meson image_eqI)
    moreover have \<open>\<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<le> \<parallel>f *\<^sub>v x\<parallel> + \<parallel>f *\<^sub>v \<xi>\<parallel>\<close> for \<xi>
      by (simp add: blinfun.add_right norm_triangle_ineq)
    ultimately have \<open>\<And> \<xi>. \<xi> \<in> ball 0 r \<Longrightarrow> \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<le> M\<close>
      by (simp add: blinfun.add_right norm_triangle_le)
    thus ?thesis by (meson bdd_aboveI2)
  qed
  have bdd_above_4: \<open>bdd_above ((\<lambda> \<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r))\<close>
  proof-
    obtain K where K_def: \<open>\<And> \<xi>. \<xi> \<in> ball 0 r \<Longrightarrow> \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<le> K\<close>
      using  \<open>bdd_above ((\<lambda> \<xi>. norm (f (x + \<xi>))) ` (ball 0 r))\<close> unfolding bdd_above_def
      by (meson image_eqI)
    have \<open>\<xi> \<in> ball (0::'a) r \<Longrightarrow> -\<xi> \<in> ball 0 r\<close> for \<xi>
      by auto
    thus ?thesis by (metis K_def ab_group_add_class.ab_diff_conv_add_uminus bdd_aboveI2)
  qed
  have bdd_above_1: \<open>bdd_above ((\<lambda> \<xi>. max \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>  \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r))\<close>
  proof-
    have \<open>bdd_above ((\<lambda> \<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` (ball 0 r))\<close>
      using bdd_above_2 by blast
    moreover have \<open>bdd_above ((\<lambda> \<xi>.  \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r))\<close>
      using bdd_above_4 by blast
    ultimately show ?thesis
      unfolding max_def apply auto apply (meson bdd_above_Int1 bdd_above_mono image_Int_subset)
      by (meson bdd_above_Int1 bdd_above_mono image_Int_subset)
  qed
  have bdd_above_6: \<open>bdd_above ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball x r)\<close>
  proof-
    have \<open>bounded (ball x r)\<close>
      by simp
    hence \<open>bounded ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball x r)\<close>
      by (metis (no_types) add.left_neutral bdd_above_2 bdd_above_norm bounded_norm_comp
          image_add_ball image_image)
    thus ?thesis
      by (simp add: bounded_imp_bdd_above)
  qed
  have norm_1: \<open>(\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` ball 0 r = (\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball x r\<close>
    by (metis add.right_neutral ball_translation image_image)
  have bdd_above_5: \<open>bdd_above ((\<lambda>\<xi>. norm (f (x + \<xi>))) ` ball 0 r)\<close>
    by (simp add: bdd_above_2)
  have norm_2: \<open>\<parallel>\<xi>\<parallel> < r \<Longrightarrow> \<parallel>f *\<^sub>v (x - \<xi>)\<parallel> \<in> (\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` ball 0 r\<close> for \<xi>
  proof-
    assume \<open>\<parallel>\<xi>\<parallel> < r\<close>
    hence \<open>\<xi> \<in> ball (0::'a) r\<close>
      by auto
    hence \<open>-\<xi> \<in> ball (0::'a) r\<close>
      by auto
    thus ?thesis
      by (metis (no_types, lifting) ab_group_add_class.ab_diff_conv_add_uminus image_iff)
  qed
  have norm_2': \<open>\<parallel>\<xi>\<parallel> < r \<Longrightarrow> \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<in> (\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` ball 0 r\<close> for \<xi>
  proof-
    assume \<open>norm \<xi> < r\<close>
    hence \<open>\<xi> \<in> ball (0::'a) r\<close>
      by auto
    hence \<open>-\<xi> \<in> ball (0::'a) r\<close>
      by auto
    thus ?thesis
      by (metis (no_types, lifting) diff_minus_eq_add image_iff)
  qed
  have bdd_above_6: \<open>bdd_above ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` ball 0 r)\<close>
    by (simp add: bdd_above_4)
  have Sup_2: \<open>(SUP \<xi>\<in>ball 0 r. max \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) =
                 max (SUP \<xi>\<in>ball 0 r. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) (SUP \<xi>\<in>ball 0 r. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>)\<close>
  proof-
    have \<open>ball (0::'a) r \<noteq> {}\<close>
      using \<open>r > 0\<close> by auto
    moreover have \<open>bdd_above ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` ball 0 r)\<close>
      using bdd_above_5 by blast
    moreover have \<open>bdd_above ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` ball 0 r)\<close>
      using bdd_above_6 by blast
    ultimately show ?thesis
      using max_Sup
      by (metis (mono_tags, lifting) Banach_Steinhaus_Missing.pointwise_max_def image_cong)
  qed
  have Sup_3': \<open>\<parallel>\<xi>\<parallel> < r \<Longrightarrow> \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<in> (\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` ball 0 r\<close> for \<xi>::'a
    by (simp add: norm_2')
  have Sup_3'': \<open>\<parallel>\<xi>\<parallel> < r \<Longrightarrow> \<parallel>f *\<^sub>v (x - \<xi>)\<parallel> \<in> (\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` ball 0 r\<close> for \<xi>::'a
    by (simp add: norm_2)
  have Sup_3: \<open>max (SUP \<xi>\<in>ball 0 r. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) (SUP \<xi>\<in>ball 0 r.  \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) =
        (SUP \<xi>\<in>ball 0 r. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>)\<close>
  proof-
    have \<open>(\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` (ball 0 r) = (\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r)\<close>
      apply auto using Sup_3' apply auto using Sup_3'' by blast
    hence \<open>Sup ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` (ball 0 r))=Sup ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r))\<close>
      by simp
    thus ?thesis by simp
  qed
  have Sup_1: \<open>Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 r)) \<le> Sup ( (\<lambda>\<xi>. \<parallel>f *\<^sub>v \<xi>\<parallel>) ` (ball x r) )\<close>
  proof-
    have \<open>(\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) \<xi> \<le> max \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>\<close> for \<xi>
      apply(rule linear_plus_norm) apply (rule bounded_linear.linear)
      by (simp add: blinfun.bounded_linear_right)
    moreover have \<open>bdd_above ((\<lambda> \<xi>. max \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>  \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r))\<close>
      using bdd_above_1 by blast
    moreover have \<open>ball (0::'a) r \<noteq> {}\<close>
      using \<open>r > 0\<close> by auto
    ultimately have \<open>Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 r)) \<le>
                     Sup ((\<lambda>\<xi>. max \<parallel>f *\<^sub>v (x + \<xi>)\<parallel> \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r))\<close>
      using cSUP_mono by smt
    also have \<open>\<dots> = max (Sup ((\<lambda>\<xi>.  \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` (ball 0 r)))
                        (Sup ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x - \<xi>)\<parallel>) ` (ball 0 r)))\<close>
      using Sup_2 by blast
    also have \<open>\<dots> = Sup ((\<lambda>\<xi>. \<parallel>f *\<^sub>v (x + \<xi>)\<parallel>) ` (ball 0 r))\<close>
      using Sup_3 by blast
    also have \<open>\<dots> = Sup ((\<lambda>\<xi>. \<parallel>f *\<^sub>v \<xi>\<parallel>) ` (ball x r))\<close>
      by (metis  add.right_neutral ball_translation image_image)
    finally show ?thesis by blast
  qed
  have \<open>\<parallel>f\<parallel> = (SUP x\<in>ball 0 r. \<parallel>f *\<^sub>v x\<parallel>) / r\<close>
    using \<open>0 < r\<close> onorm_r by blast
  moreover have \<open>Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` (ball 0 r)) / r \<le> Sup ((\<lambda>\<xi>. \<parallel>f *\<^sub>v \<xi>\<parallel>) ` (ball x r)) / r\<close>
    using Sup_1 \<open>0 < r\<close> divide_right_mono by fastforce
  ultimately have \<open>\<parallel>f\<parallel> \<le> Sup ((\<lambda>t. \<parallel>f *\<^sub>v t\<parallel>) ` ball x r) / r\<close>
    by simp
  thus ?thesis by simp
qed

lemma onorm_Sup_on_ball':
  includes notation_norm
  assumes \<open>r > 0\<close> and \<open>\<tau> < 1\<close>
  shows \<open>\<exists>\<xi>\<in>ball x r.  \<tau> * r * \<parallel>f\<parallel> \<le> \<parallel>f *\<^sub>v \<xi>\<parallel>\<close>
  text \<open>
  In the proof of Banach-Steinhaus theorem, we will use this variation of the
  lemma @{text onorm_Sup_on_ball}.

  Explanation: Let \<^term>\<open>f\<close> be a bounded operator, let \<^term>\<open>x\<close> be a point and let \<^term>\<open>r\<close> be a
  positive real number. For any real number \<^term>\<open>\<tau> < 1\<close>, there is a point \<^term>\<open>\<xi>\<close> in the open ball
  of radius \<^term>\<open>r\<close> around \<^term>\<open>x\<close> such that \<^term>\<open>\<tau> * r * \<parallel>f\<parallel> \<le> \<parallel>f *\<^sub>v \<xi>\<parallel>\<close>.
\<close>
proof(cases  \<open>f = 0\<close>)
  case True
  thus ?thesis by (metis assms(1) centre_in_ball mult_zero_right norm_zero order_refl
        zero_blinfun.rep_eq)
next
  case False
  have bdd_above_1: \<open>bdd_above ((\<lambda>t. \<parallel>(*\<^sub>v) f t\<parallel>) ` ball x r)\<close> for f::\<open>'a \<Rightarrow>\<^sub>L 'b\<close>
    using assms(1) bounded_linear_image by (simp add: bounded_linear_image
        blinfun.bounded_linear_right bounded_imp_bdd_above bounded_norm_comp)
  have  \<open>norm f > 0\<close>
    using \<open>f \<noteq> 0\<close> by auto
  have \<open>norm f \<le>  Sup ( (\<lambda>\<xi>.  \<parallel>(*\<^sub>v) f \<xi>\<parallel>) ` (ball x r) ) / r\<close>
    using \<open>r > 0\<close> by (simp add: onorm_Sup_on_ball)
  hence \<open>r * norm f \<le>  Sup ( (\<lambda>\<xi>.  \<parallel>(*\<^sub>v) f \<xi>\<parallel>) ` (ball x r) )\<close>
    using \<open>0 < r\<close> by (smt divide_strict_right_mono nonzero_mult_div_cancel_left)
  moreover have \<open>\<tau> * r * norm f < r * norm f\<close>
    using  \<open>\<tau> < 1\<close> using \<open>0 < norm f\<close> \<open>0 < r\<close> by auto
  ultimately have \<open>\<tau> * r * norm f < Sup ( (norm \<circ> ((*\<^sub>v) f)) ` (ball x r) )\<close>
    by simp
  moreover have \<open>(norm \<circ> ( (*\<^sub>v) f)) ` (ball x r) \<noteq> {}\<close>
    using \<open>0 < r\<close> by auto
  moreover have \<open>bdd_above ((norm \<circ> ( (*\<^sub>v) f)) ` (ball x r))\<close>
    using bdd_above_1 apply transfer by simp
  ultimately have \<open>\<exists>t \<in> (norm \<circ> ( (*\<^sub>v) f)) ` (ball x r). \<tau> * r * norm f < t\<close>
    by (simp add: less_cSup_iff)
  thus ?thesis by (smt comp_def image_iff)
qed

subsection \<open>Banach-Steinhaus theorem\<close>

theorem banach_steinhaus:
  fixes f::\<open>'c \<Rightarrow> ('a::banach \<Rightarrow>\<^sub>L 'b::real_normed_vector)\<close>
  assumes \<open>\<And>x. bounded (range (\<lambda>n. (f n) *\<^sub>v x))\<close>
  shows  \<open>bounded (range f)\<close>
  text\<open>
  This is Banach-Steinhaus Theorem.

  Explanation: If a family of bounded operators on a Banach space
  is pointwise bounded, then it is uniformly bounded.
\<close>
proof(rule classical)
  assume \<open>\<not>(bounded (range f))\<close>
  have sum_1: \<open>\<exists>K. \<forall>n. sum (\<lambda>k. inverse (real_of_nat 3^k)) {0..n} \<le> K\<close>
  proof-
    have \<open>summable (\<lambda>n. inverse ((3::real) ^ n))\<close>
      by (simp flip: power_inverse)
    hence \<open>bounded (range (\<lambda>n. sum (\<lambda> k. inverse (real 3 ^ k)) {0..<n}))\<close>
      using summable_imp_sums_bounded[where f = "(\<lambda>n. inverse (real_of_nat 3^n))"]
        lessThan_atLeast0 by auto
    hence \<open>\<exists>M. \<forall>h\<in>(range (\<lambda>n. sum (\<lambda> k. inverse (real 3 ^ k)) {0..<n})). norm h \<le> M\<close>
      using bounded_iff by blast
    then obtain M where \<open>h\<in>range (\<lambda>n. sum (\<lambda> k. inverse (real 3 ^ k)) {0..<n}) \<Longrightarrow> norm h \<le> M\<close>
      for h
      by blast
    have sum_2: \<open>sum (\<lambda>k. inverse (real_of_nat 3^k)) {0..n} \<le> M\<close> for n
    proof-
      have  \<open>norm (sum (\<lambda> k. inverse (real 3 ^ k)) {0..< Suc n}) \<le> M\<close>
        using \<open>\<And>h. h\<in>(range (\<lambda>n. sum (\<lambda> k. inverse (real 3 ^ k)) {0..<n})) \<Longrightarrow> norm h \<le> M\<close>
        by blast
      hence  \<open>norm (sum (\<lambda> k. inverse (real 3 ^ k)) {0..n}) \<le> M\<close>
        by (simp add: atLeastLessThanSuc_atLeastAtMost)
      hence  \<open>(sum (\<lambda> k. inverse (real 3 ^ k)) {0..n}) \<le> M\<close>
        by auto
      thus ?thesis  by blast
    qed
    have \<open>sum (\<lambda>k. inverse (real_of_nat 3^k)) {0..n} \<le> M\<close> for n
      using sum_2 by blast
    thus ?thesis  by blast
  qed
  have \<open>of_rat 2/3 < (1::real)\<close>
    by auto
  hence \<open>\<forall>g::'a \<Rightarrow>\<^sub>L 'b. \<forall>x. \<forall>r. \<exists>\<xi>. g \<noteq> 0 \<and> r > 0
               \<longrightarrow> (\<xi>\<in>ball x r \<and> (of_rat 2/3) * r * norm g \<le> norm ((*\<^sub>v) g \<xi>))\<close>
    using onorm_Sup_on_ball' by blast
  hence \<open>\<exists>\<xi>. \<forall>g::'a \<Rightarrow>\<^sub>L 'b. \<forall>x. \<forall>r. g \<noteq> 0 \<and> r > 0
           \<longrightarrow> ((\<xi> g x r)\<in>ball x r \<and> (of_rat 2/3) * r * norm g \<le> norm ((*\<^sub>v) g (\<xi> g x r)))\<close>
    by metis
  then obtain \<xi> where f1: \<open>\<lbrakk>g \<noteq> 0; r > 0\<rbrakk> \<Longrightarrow>
        \<xi> g x r \<in> ball x r \<and>  (of_rat 2/3) * r * norm g \<le> norm ((*\<^sub>v) g (\<xi> g x r))\<close>
    for g::\<open>'a \<Rightarrow>\<^sub>L 'b\<close> and x and r
    by blast
  have \<open>\<forall>n. \<exists>k. norm (f k) \<ge> 4^n\<close>
    using \<open>\<not>(bounded (range f))\<close> by (metis (mono_tags, opaque_lifting) boundedI image_iff linear)
  hence  \<open>\<exists>k. \<forall>n. norm (f (k n)) \<ge> 4^n\<close>
    by metis
  hence  \<open>\<exists>k. \<forall>n. norm ((f \<circ> k) n) \<ge> 4^n\<close>
    by simp
  then obtain k where \<open>norm ((f \<circ> k) n) \<ge> 4^n\<close> for n
    by blast
  define T where \<open>T = f \<circ> k\<close>
  have \<open>T n \<in> range f\<close> for n
    unfolding T_def by simp
  have \<open>norm (T n) \<ge> of_nat (4^n)\<close> for n
    unfolding T_def using \<open>\<And> n. norm ((f \<circ> k) n) \<ge> 4^n\<close> by auto
  hence \<open>T n \<noteq> 0\<close> for n
    by (smt T_def \<open>\<And>n. 4 ^ n \<le> norm ((f \<circ> k) n)\<close> norm_zero power_not_zero zero_le_power)
  have \<open>inverse (of_nat 3^n) > (0::real)\<close> for n
    by auto
  define y::\<open>nat \<Rightarrow> 'a\<close> where \<open>y = rec_nat 0 (\<lambda>n x. \<xi> (T n) x (inverse (of_nat 3^n)))\<close>
  have \<open>y (Suc n) \<in> ball (y n) (inverse (of_nat 3^n))\<close> for n
    using f1 \<open>\<And> n. T n \<noteq> 0\<close> \<open>\<And> n. inverse (of_nat 3^n) > 0\<close> unfolding y_def by auto
  hence \<open>norm (y (Suc n) - y n) \<le> inverse (of_nat 3^n)\<close> for n
    unfolding ball_def apply auto using dist_norm by (smt norm_minus_commute)
  moreover have \<open>\<exists>K. \<forall>n. sum (\<lambda>k. inverse (real_of_nat 3^k)) {0..n} \<le> K\<close>
    using sum_1 by blast
  moreover have \<open>Cauchy y\<close>
    using convergent_series_Cauchy[where a = "\<lambda>n. inverse (of_nat 3^n)" and \<phi> = y] dist_norm
    by (metis calculation(1) calculation(2))
  hence \<open>\<exists> x. y \<longlonglongrightarrow> x\<close>
    by (simp add: convergent_eq_Cauchy)
  then obtain x where \<open>y \<longlonglongrightarrow> x\<close>
    by blast
  have norm_2: \<open>norm (x - y (Suc n)) \<le> (inverse (of_nat 2))*(inverse (of_nat 3^n))\<close> for n
  proof-
    have \<open>inverse (real_of_nat 3) < 1\<close>
      by simp
    moreover have \<open>y 0 = 0\<close>
      using y_def by auto
    ultimately have \<open>norm (x - y (Suc n))
    \<le> (inverse (of_nat 3)) * inverse (1 - (inverse (of_nat 3))) * ((inverse (of_nat 3)) ^ n)\<close>
      using bound_Cauchy_to_lim[where c = "inverse (of_nat 3)" and y = y and x = x]
        power_inverse semiring_norm(77)  \<open>y \<longlonglongrightarrow> x\<close>
        \<open>\<And> n. norm (y (Suc n) - y n) \<le> inverse (of_nat 3^n)\<close> by (metis divide_inverse)
    moreover have \<open>inverse (real_of_nat 3) * inverse (1 - (inverse (of_nat 3)))
                   = inverse (of_nat 2)\<close>
      by auto
    ultimately show ?thesis
      by (metis power_inverse)
  qed
  have \<open>norm (x - y (Suc n)) \<le> (inverse (of_nat 2))*(inverse (of_nat 3^n))\<close> for n
    using norm_2 by blast
  have \<open>\<exists> M. \<forall> n. norm ((*\<^sub>v) (T n) x) \<le> M\<close>
    unfolding T_def apply auto
    by (metis \<open>\<And>x. bounded (range (\<lambda>n. (*\<^sub>v) (f n) x))\<close> bounded_iff rangeI)
  then obtain M where \<open>norm ((*\<^sub>v) (T n) x) \<le> M\<close> for n
    by blast
  have norm_1: \<open>norm (T n) * norm (y (Suc n) - x) + norm ((*\<^sub>v) (T n) x)
       \<le> inverse (real 2) * inverse (real 3 ^ n) * norm (T n) + norm ((*\<^sub>v) (T n) x)\<close> for n
  proof-
    have \<open>norm (y (Suc n) - x) \<le> (inverse (of_nat 2))*(inverse (of_nat 3^n))\<close>
      using \<open>norm (x - y (Suc n)) \<le> (inverse (of_nat 2))*(inverse (of_nat 3^n))\<close>
      by (simp add: norm_minus_commute)
    moreover have \<open>norm (T n) \<ge> 0\<close>
      by auto
    ultimately have \<open>norm (T n) * norm (y (Suc n) - x)
                     \<le> (inverse (of_nat 2))*(inverse (of_nat 3^n))*norm (T n)\<close>
      by (simp add: \<open>\<And>n. T n \<noteq> 0\<close>)
    thus ?thesis by simp
  qed
  have inverse_2: \<open>(inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n)
                  \<le> norm ((*\<^sub>v) (T n) x)\<close> for n
  proof-
    have \<open>(of_rat 2/3)*(inverse (of_nat 3^n))*norm (T n) \<le> norm ((*\<^sub>v) (T n) (y (Suc n)))\<close>
      using f1 \<open>\<And> n. T n \<noteq> 0\<close> \<open>\<And> n. inverse (of_nat 3^n) > 0\<close> unfolding y_def by auto
    also have \<open>\<dots> = norm ((*\<^sub>v) (T n) ((y (Suc n) - x) + x))\<close>
      by auto
    also have \<open>\<dots> = norm ((*\<^sub>v) (T n) (y (Suc n) - x) + (*\<^sub>v) (T n) x)\<close>
      apply transfer apply auto by (metis diff_add_cancel linear_simps(1))
    also have \<open>\<dots> \<le> norm ((*\<^sub>v) (T n) (y (Suc n) - x)) + norm ((*\<^sub>v) (T n) x)\<close>
      by (simp add: norm_triangle_ineq)
    also have \<open>\<dots> \<le> norm (T n) * norm (y (Suc n) - x) + norm ((*\<^sub>v) (T n) x)\<close>
      apply transfer apply auto using onorm by auto
    also have \<open>\<dots> \<le> (inverse (of_nat 2))*(inverse (of_nat 3^n))*norm (T n)
                + norm ((*\<^sub>v) (T n) x)\<close>
      using norm_1 by blast
    finally have \<open>(of_rat 2/3) * inverse (real 3 ^ n) * norm (T n)
                \<le> inverse (real 2) * inverse (real 3 ^ n) * norm (T n)
                + norm ((*\<^sub>v) (T n) x)\<close>
      by blast
    hence \<open>(of_rat 2/3) * inverse (real 3 ^ n) * norm (T n)
             - inverse (real 2) * inverse (real 3 ^ n) * norm (T n) \<le> norm ((*\<^sub>v) (T n) x)\<close>
      by linarith
    moreover have \<open>(of_rat 2/3) * inverse (real 3 ^ n) * norm (T n)
             - inverse (real 2) * inverse (real 3 ^ n) * norm (T n)
             = (inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n)\<close>
      by fastforce
    ultimately show \<open>(inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n) \<le> norm ((*\<^sub>v) (T n) x)\<close>
      by linarith
  qed
  have inverse_3: \<open>(inverse (of_nat 6)) * (of_rat (4/3)^n)
                    \<le> (inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n)\<close> for n
  proof-
    have \<open>of_rat (4/3)^n = inverse (real 3 ^ n) * (of_nat 4^n)\<close>
      apply auto by (metis divide_inverse_commute of_rat_divide power_divide of_rat_numeral_eq)
    also have \<open>\<dots> \<le>  inverse (real 3 ^ n) * norm (T n)\<close>
      using \<open>\<And>n. norm (T n) \<ge> of_nat (4^n)\<close> by simp
    finally have \<open>of_rat (4/3)^n \<le> inverse (real 3 ^ n) * norm (T n)\<close>
      by blast
    moreover have \<open>inverse (of_nat 6) > (0::real)\<close>
      by auto
    ultimately show ?thesis by auto
  qed
  have inverse_1: \<open>(inverse (of_nat 6)) * (of_rat (4/3)^n) \<le> M\<close> for n
  proof-
    have \<open>(inverse (of_nat 6)) * (of_rat (4/3)^n)
          \<le> (inverse (of_nat 6)) * inverse (real 3 ^ n) * norm (T n)\<close>
      using inverse_3 by blast
    also have \<open>\<dots> \<le> norm ((*\<^sub>v) (T n) x)\<close>
      using inverse_2 by blast
    finally have \<open>(inverse (of_nat 6)) * (of_rat (4/3)^n) \<le> norm ((*\<^sub>v) (T n) x)\<close>
      by auto
    thus ?thesis using \<open>\<And> n. norm ((*\<^sub>v) (T n) x) \<le> M\<close> by smt
  qed
  have \<open>\<exists>n. M < (inverse (of_nat 6)) * (of_rat (4/3)^n)\<close>
    using Real.real_arch_pow by auto
  moreover have \<open>(inverse (of_nat 6)) * (of_rat (4/3)^n) \<le> M\<close> for n
    using inverse_1 by blast
  ultimately show ?thesis by smt
qed

subsection \<open>A consequence of Banach-Steinhaus theorem\<close>

corollary bounded_linear_limit_bounded_linear:
  fixes f::\<open>nat \<Rightarrow> ('a::banach \<Rightarrow>\<^sub>L 'b::real_normed_vector)\<close>
  assumes \<open>\<And>x. convergent (\<lambda>n. (f n) *\<^sub>v x)\<close>
  shows  \<open>\<exists>g. (\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> (*\<^sub>v) g\<close>
  text\<open>
  Explanation: If a sequence of bounded operators on a Banach space converges
  pointwise, then the limit is also a bounded operator.
\<close>
proof-
  have \<open>\<exists>l. (\<lambda>n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> l\<close> for x
    by (simp add:  \<open>\<And>x. convergent (\<lambda>n. (*\<^sub>v) (f n) x)\<close> convergentD)
  hence \<open>\<exists>F. (\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> F\<close>
    unfolding pointwise_convergent_to_def by metis
  obtain F where \<open>(\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> F\<close>
    using \<open>\<exists>F. (\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> F\<close> by auto
  have \<open>\<And>x. (\<lambda> n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> F x\<close>
    using \<open>(\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> F\<close> apply transfer
    by (simp add: pointwise_convergent_to_def)
  have \<open>bounded (range f)\<close>
    using \<open>\<And>x. convergent (\<lambda>n. (*\<^sub>v) (f n) x)\<close> banach_steinhaus
      \<open>\<And>x. \<exists>l. (\<lambda>n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> l\<close> convergent_imp_bounded by blast
  have norm_f_n: \<open>\<exists> M. \<forall> n. norm (f n) \<le> M\<close>
    unfolding bounded_def
    by (meson UNIV_I \<open>bounded (range f)\<close> bounded_iff image_eqI)
  have \<open>isCont (\<lambda> t::'b. norm t) y\<close> for y::'b
    using Limits.isCont_norm by simp
  hence \<open>(\<lambda> n. norm ((*\<^sub>v) (f n) x)) \<longlonglongrightarrow> (norm (F x))\<close> for x
    using \<open>\<And> x::'a. (\<lambda> n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> F x\<close> by (simp add: tendsto_norm)
  hence norm_f_n_x: \<open>\<exists> M. \<forall> n. norm ((*\<^sub>v) (f n) x) \<le> M\<close> for x
    using Elementary_Metric_Spaces.convergent_imp_bounded
    by (metis UNIV_I \<open>\<And> x::'a. (\<lambda> n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> F x\<close> bounded_iff image_eqI)
  have norm_f: \<open>\<exists>K. \<forall>n. \<forall>x. norm ((*\<^sub>v) (f n) x) \<le> norm x * K\<close>
  proof-
    have \<open>\<exists> M. \<forall> n. norm ((*\<^sub>v) (f n) x) \<le> M\<close> for x
      using norm_f_n_x  \<open>\<And>x. (\<lambda>n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> F x\<close> by blast
    hence \<open>\<exists> M. \<forall> n. norm (f n) \<le> M\<close>
      using norm_f_n by simp
    then obtain M::real where \<open>\<exists> M. \<forall> n. norm (f n) \<le> M\<close>
      by blast
    have \<open>\<forall> n. \<forall>x. norm ((*\<^sub>v) (f n) x) \<le> norm x * norm (f n)\<close>
      apply transfer apply auto by (metis mult.commute onorm)
    thus  ?thesis using \<open>\<exists> M. \<forall> n. norm (f n) \<le> M\<close>
      by (metis (no_types, opaque_lifting) dual_order.trans norm_eq_zero order_refl
          mult_le_cancel_iff2 vector_space_over_itself.scale_zero_left zero_less_norm_iff)
  qed
  have norm_F_x: \<open>\<exists>K. \<forall>x. norm (F x) \<le> norm x * K\<close>
  proof-
    have "\<exists>K. \<forall>n. \<forall>x. norm ((*\<^sub>v) (f n) x) \<le> norm x * K"
      using norm_f \<open>\<And>x. (\<lambda>n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> F x\<close> by auto
    thus ?thesis
      using  \<open>\<And> x::'a. (\<lambda> n. (*\<^sub>v) (f n)  x) \<longlonglongrightarrow> F x\<close> apply transfer
      by (metis Lim_bounded tendsto_norm)
  qed
  have \<open>linear F\<close>
  proof(rule linear_limit_linear)
    show \<open>linear ((*\<^sub>v) (f n))\<close> for n
      apply transfer apply auto by (simp add: bounded_linear.linear)
    show \<open>f \<midarrow>pointwise\<rightarrow> F\<close>
      using \<open>(\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> F\<close> by auto
  qed
  moreover have \<open>bounded_linear_axioms F\<close>
    using norm_F_x by (simp add: \<open>\<And>x. (\<lambda>n. (*\<^sub>v) (f n) x) \<longlonglongrightarrow> F x\<close> bounded_linear_axioms_def)
  ultimately have \<open>bounded_linear F\<close>
    unfolding bounded_linear_def by blast
  hence \<open>\<exists>g. (*\<^sub>v) g = F\<close>
    using bounded_linear_Blinfun_apply by auto
  thus ?thesis using \<open>(\<lambda>n. (*\<^sub>v) (f n)) \<midarrow>pointwise\<rightarrow> F\<close> apply transfer by auto
qed

end


section{* Verification Component Based on KAD *}

theory VC_KAD_scratch
  imports Main GCD Binomial (*"$ISABELLE_HOME/src/HOL/Eisbach/Eisbach"*)

begin

subsection {* KAD: Definitions and Basic Properties *}

notation times (infixl "\<cdot>" 70)

class plus_ord = plus + ord +
  assumes less_eq_def: "x \<le> y \<longleftrightarrow> x + y = y"
  and less_def: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"

class dioid = semiring + one + zero + plus_ord +
  assumes add_idem [simp]: "x + x = x"
  and mult_onel [simp]: "1 \<cdot> x = x"
  and mult_oner [simp]: "x \<cdot> 1 = x"
  and add_zerol [simp]: "0 + x = x"
  and annil [simp]: "0 \<cdot> x = 0"
  and annir [simp]: "x \<cdot> 0 = 0"

begin

subclass monoid_mult
  by (standard, simp_all)

subclass order
  by (standard, simp_all add: less_def less_eq_def add_commute, auto, metis add_assoc)

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (metis distrib_right less_eq_def)

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  by (metis distrib_left less_eq_def)

lemma add_iso: "x \<le> y \<Longrightarrow> z + x \<le> z + y"
  by (metis add.semigroup_axioms add_idem less_eq_def semigroup.assoc)

lemma add_ub: "x \<le> x + y"
  by (metis add_assoc add_idem less_eq_def)

lemma add_lub: "x + y \<le> z \<longleftrightarrow> x \<le> z \<and> y \<le> z"
  by (metis add_assoc add_commute less_eq_def order.ordering_axioms ordering.refl)

end

class kleene_algebra  = dioid +
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [101] 100)
  assumes star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and star_unfoldr: "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  and star_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and star_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

begin

lemma star_sim: "x \<cdot> y \<le> z \<cdot> x \<Longrightarrow> x \<cdot> y\<^sup>\<star> \<le> z\<^sup>\<star> \<cdot> x"
(*  by (smt add_commute add_assoc add_idem distrib_left distrib_right less_eq_def mult_onel star_inductr star_unfoldr mult_assoc) *)
proof -
  assume "x \<cdot> y \<le> z \<cdot> x"
  hence "x + z\<^sup>\<star> \<cdot> x \<cdot> y \<le> x + z\<^sup>\<star> \<cdot> z \<cdot> x"
    by (metis add_lub distrib_left eq_refl less_eq_def mult_assoc)
  also have  "... \<le> z\<^sup>\<star> \<cdot> x"
    using add_lub mult_isor star_unfoldr by fastforce
  finally show ?thesis
    by (simp add: star_inductr)
qed

end

class antidomain_kleene_algebra = kleene_algebra +
  fixes ad :: "'a \<Rightarrow> 'a" ("ad")
  assumes as1 [simp]: "ad x \<cdot> x = 0"
  and as2 [simp]: "ad (x \<cdot> y) + ad (x \<cdot> ad (ad y)) = ad (x \<cdot> ad (ad y))"
  and as3 [simp]: "ad (ad x) + ad x = 1"

begin

definition dom_op :: "'a \<Rightarrow> 'a" ("d") where
  "d x = ad (ad x)"

lemma a_subid_aux: "ad x \<cdot> y \<le> y"
  by (metis add_commute add_ub as3 mult_1_left mult_isor)

lemma d1_a [simp]: "d x \<cdot> x = x"
  by (metis add_commute dom_op_def add_zerol as1 as3 distrib_right mult_1_left)

lemma a_idem [simp]: "ad x \<cdot> ad x = ad x"
  by (metis a_d_closed d1_a)

lemma meet_ord: "ad x \<le> ad y \<longleftrightarrow> ad x \<cdot> ad y = ad x"
  by (metis a_d_closed a_subid_aux d1_a antisym mult_1_right mult_isol)

lemma d_wloc: "x \<cdot> y = 0 \<longleftrightarrow> x \<cdot> d y = 0"
  by (metis a_subid_aux d1_a dom_op_def add_ub antisym as1 as2 mult_1_right mult_assoc)

lemma gla_1: "ad x \<cdot> y = 0 \<Longrightarrow> ad x \<le> ad y"
  by (metis a_subid_aux d_wloc dom_op_def add_zerol as3 distrib_left mult_1_right)

lemma a2_eq [simp]: "ad (x \<cdot> d y) = ad (x \<cdot> y)"
  by (metis a_mul_d d1_a dom_op_def gla_1 add_ub antisym as1 as2 mult_assoc)

lemma a_supdist: "ad (x + y) \<le> ad x"
  by (metis add_commute gla_1 add_ub add_zerol as1 distrib_left less_eq_def)

lemma a_antitone: "x \<le> y \<Longrightarrow> ad y \<le> ad x"
  by (metis a_supdist less_eq_def)

lemma a_comm: "ad x \<cdot> ad y = ad y \<cdot> ad x"
proof -
{ fix x y
  have "ad x \<cdot> ad y = d (ad x \<cdot> ad y) \<cdot> ad x \<cdot> ad y"
    by (simp add: mult_assoc)
  also have "... \<le> d (ad y) \<cdot> ad x"
    by (metis a_antitone a_d_closed a_subid_aux mult_oner a_subid_aux dom_op_def mult_isol mult_isor meet_ord)
  finally have "ad x \<cdot> ad y \<le> ad y \<cdot> ad x"
    by simp }
  thus ?thesis
    by (simp add: antisym)
qed

lemma a_closed [simp]: "d (ad x \<cdot> ad y) = ad x \<cdot> ad y"
proof -
  have f1: "\<And>x y. ad x \<le> ad (ad y \<cdot> x)"
    by (simp add: a_antitone a_subid_aux)
  have "\<And>x y. d (ad x \<cdot> y) \<le> ad x"
    by (metis a2_eq a_antitone a_comm a_d_closed dom_op_def f1)
  hence "\<And>x y. d (ad x \<cdot> y) \<cdot> y = ad x \<cdot> y"
    by (metis d1_a dom_op_def meet_ord mult_assoc)
  thus ?thesis
    by (metis a_comm a_idem dom_op_def)
qed

lemma d1_sum_var: "x + y \<le> (d x + d y) \<cdot> (x + y)"
proof -
  have "x + y = d x \<cdot> x + d y \<cdot> y"
    by simp
  also have "... \<le> (d x + d y) \<cdot> x + (d x + d y) \<cdot> y"
    by (metis add_commute add_lub add_ub combine_common_factor)
  finally show ?thesis
    by (simp add: distrib_left)
qed

lemma a4: "ad (x + y) = ad x \<cdot> ad y"
proof (rule antisym)
  show "ad (x + y) \<le> ad x \<cdot> ad y"
    by (metis a_supdist add_commute mult_isor meet_ord)
  hence "ad x \<cdot> ad y = ad x \<cdot> ad y + ad (x + y)"
    using less_eq_def add_commute by simp
  also have "... = ad (ad (ad x \<cdot> ad y) \<cdot> (x + y))"
    by (metis a_closed a_exp)
  finally show "ad x \<cdot> ad y \<le> ad (x + y)"
    using a_antitone d1_sum_var dom_op_def by auto
qed

lemma kat_prop: "d x \<cdot> y \<le> y \<cdot> d z \<longleftrightarrow> d x \<cdot> y \<cdot> ad z = 0"
proof
  show  "d x \<cdot> y \<le> y \<cdot> d z \<Longrightarrow> d x \<cdot> y \<cdot> ad z = 0"
    by (metis add_commute dom_op_def add_zerol annir as1 less_eq_def mult_isor mult_assoc)
next
  assume h: "d x \<cdot> y \<cdot> ad z = 0"
  hence "d x \<cdot> y = d x \<cdot> y \<cdot> d z + d x \<cdot> y \<cdot> ad z"
    by (metis dom_op_def as3 distrib_left mult_1_right)
  thus  "d x \<cdot> y \<le> y \<cdot> d z"
    by (metis a_subid_aux add_commute dom_op_def h add_zerol mult_assoc)
qed

lemma shunt: "ad x \<le> ad y + ad z \<longleftrightarrow> ad x \<cdot> d y \<le> ad z"
proof
  assume "ad x \<le> ad y + ad z"
  hence "ad x \<cdot> d y \<le> ad y \<cdot> d y + ad z \<cdot> d y"
    by (metis distrib_right mult_isor)
  thus " ad x \<cdot> d y \<le> ad z"
    by (metis a_closed a_d_closed a_exp a_mul_d a_supdist dom_op_def dual_order.trans less_eq_def)
next
  assume h: "ad x \<cdot> d y \<le> ad z"
  have "ad x = ad x \<cdot> ad y + ad x \<cdot> d y"
    by (metis add_commute dom_op_def as3 distrib_left mult_1_right)
  also have "... \<le> ad x \<cdot> ad y + ad z"
    using h add_lub dual_order.trans by blast
  also have "... \<le> ad y + ad z"
    by (metis a_subid_aux add_commute add_lub add_ub dual_order.trans)
  finally show "ad x \<le> ad y + ad z"
    by simp
qed

subsection {* wp Calculus *}

definition if_then_else :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63) where
  "if p then x else y fi = d p \<cdot> x + ad p \<cdot> y"

definition while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ do _ od" [64,64] 63) where
  "while p do x od = (d p \<cdot> x)\<^sup>\<star> \<cdot> ad p"

definition while_inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _ od" [64,64,64] 63) where
  "while p inv i do x od = while p do x od"

definition wp :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "wp x p = ad (x \<cdot> ad p)"

lemma demod: " d p \<le> wp x q \<longleftrightarrow> d p \<cdot> x \<le> x \<cdot> d q"
  by (metis as1 dom_op_def gla_1 kat_prop meet_ord mult_assoc wp_def)

lemma wp_weaken: "wp x p \<le> wp (x \<cdot> ad q) (d p \<cdot> ad q)"
  by (metis a4 a_antitone a_d_closed a_mul_d dom_op_def gla_1 mult_isol mult_assoc wp_def)

lemma wp_seq [simp]: "wp (x \<cdot> y) q = wp x (wp y q)"
  using a2_eq dom_op_def mult_assoc wp_def by auto

lemma wp_seq_var: "p \<le> wp x r \<Longrightarrow> r \<le> wp y q \<Longrightarrow> p \<le> wp (x \<cdot> y) q"
proof -
  assume a1: "p \<le> wp x r"
  assume a2: "r \<le> wp y q"
  have "\<forall>z. \<not> wp x r \<le> z \<or> p \<le> z"
    using a1 dual_order.trans by blast
  then show ?thesis
    using a2 a_antitone mult_isol wp_def wp_seq by auto
qed

lemma wp_cond_var [simp]: "wp (if p then x else y fi) q = (ad p + wp x q) \<cdot> (d p + wp y q)"
  using a4 a_d_closed dom_op_def if_then_else_def distrib_right mult_assoc wp_def by auto

lemma wp_cond_aux1 [simp]: "d p \<cdot> wp (if p then x else y fi) q = d p \<cdot> wp x q"
proof -
  have "d p \<cdot> wp (if p then x else y fi) q = ad (ad p) \<cdot> (ad p + wp x q) \<cdot> (d p + wp y q)"
    using dom_op_def mult.semigroup_axioms semigroup.assoc wp_cond_var by fastforce
  also have "... = wp x q \<cdot> d p \<cdot> (d p + d (wp y q))"
    using a_comm a_d_closed dom_op_def distrib_left wp_def by auto
  also have "... = wp x q \<cdot> d p"
    by (metis a_exp dom_op_def add_ub meet_ord mult_assoc)
  finally show ?thesis
    by (simp add: a_comm dom_op_def wp_def)
qed

lemma wp_cond_aux2 [simp]: "ad p \<cdot> wp (if p then x else y fi) q = ad p \<cdot> wp y q"
  by (metis (no_types) abel_semigroup.commute if_then_else_def a_d_closed add.abel_semigroup_axioms dom_op_def wp_cond_aux1)

lemma wp_cond [simp]: "wp (if p then x else y fi) q = (d p \<cdot> wp x q) + (ad p \<cdot> wp y q)"
  by (metis as3 distrib_right dom_op_def mult_1_left wp_cond_aux2 wp_cond_aux1)

lemma wp_star_induct_var: "d q \<le> wp x q \<Longrightarrow> d q \<le> wp (x\<^sup>\<star>) q"
  using demod star_sim by blast

lemma wp_while: "d p \<cdot> d r \<le> wp x p \<Longrightarrow> d p \<le> wp (while r do x od) (d p \<cdot> ad r)"
proof -
  assume "d p \<cdot> d r \<le> wp x p"
  hence "d p \<le> wp (d r \<cdot> x) p"
    using dom_op_def mult.semigroup_axioms semigroup.assoc shunt wp_def by fastforce
  hence "d p \<le> wp ((d r \<cdot> x)\<^sup>\<star>) p"
    using wp_star_induct_var by blast
  thus ?thesis
    by (metis order.ordering_axioms ordering.trans while_def wp_weaken)
qed

lemma wp_while_inv: "d p \<le> d i \<Longrightarrow> d i \<cdot> ad r \<le> d q \<Longrightarrow> d i \<cdot> d r \<le> wp x i \<Longrightarrow> d p \<le> wp (while r inv i do x od) q"
proof -
  assume a1: "d p \<le> d i" and a2: "d i \<cdot> ad r \<le> d q" and "d i \<cdot> d r \<le> wp x i"
  hence "d i \<le> wp (while r inv i do x od) (d i \<cdot> ad r)"
    by (simp add: while_inv_def wp_while)
  also have "... \<le>  wp (while r inv i do x od) q"
    by (metis a2 a_antitone a_d_closed dom_op_def mult_isol wp_def)
  finally show ?thesis
    using a1 dual_order.trans by blast
qed

lemma wp_while_inv_break: "d p \<le> wp y i \<Longrightarrow> d i \<cdot> ad r \<le> d q \<Longrightarrow> d i \<cdot> d r \<le> wp x i \<Longrightarrow> d p \<le> wp (y \<cdot> (while r inv i do x od)) q"
  by (metis dom_op_def eq_refl mult_1_left mult_1_right wp_def wp_seq wp_seq_var wp_while_inv)

end

subsection {* Soundness *}

notation relcomp (infixl ";" 70)

interpretation rel_d: dioid Id "{}" "op \<union>" "op ;" "op \<subseteq>" "op \<subset>"
  by (standard, auto)

lemma (in dioid) pow_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x ^ i \<cdot> z \<le> y"
  by (induct i, simp add: add_lub, smt add_lub distrib_left less_eq_def power.power_Suc mult_assoc)

lemma (in dioid) pow_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ i \<le> y"
  by (induct i, simp add: add_lub, smt add_lub combine_common_factor less_eq_def power_Suc2 mult_assoc)

lemma power_is_relpow: "rel_d.power X i = X ^^ i"
  by (induct i, simp_all add: relpow_commute)

lemma rel_star_def: "X^* = (\<Union>i. rel_d.power X i)"
  by (simp add: power_is_relpow rtrancl_is_UN_relpow)

lemma rel_star_contl: "X ; Y^* = (\<Union>i. X ; rel_d.power Y i)"
  by (simp add: rel_star_def relcomp_UNION_distrib)

lemma rel_star_contr: "X^* ; Y = (\<Union>i. (rel_d.power X i) ; Y)"
  by (simp add: rel_star_def relcomp_UNION_distrib2)

definition rel_ad :: "'a rel \<Rightarrow> 'a rel" where
  "rel_ad R = {(x,x) | x. \<not> (\<exists>y. (x,y) \<in> R)}"

interpretation rel_aka: antidomain_kleene_algebra Id "{}" "op \<union>"  "op ;" "op \<subseteq>" "op \<subset>" rtrancl rel_ad
  apply standard
  apply auto[2]
  by (auto simp: rel_star_contr rel_d.pow_inductl rel_star_contl SUP_least rel_d.pow_inductr rel_ad_def)

subsection {* Embedding Predicates in Relations *}

type_synonym 'a pred = "'a \<Rightarrow> bool"

abbreviation p2r :: "'a pred \<Rightarrow> 'a rel" ("\<lceil>_\<rceil>") where
  "\<lceil>P\<rceil> \<equiv> {(s,s) |s. P s}"

lemma d_p2r [simp]: "rel_aka.dom_op \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (auto simp: rel_aka.dom_op_def rel_ad_def)

lemma p2r_neg_hom [simp]: "rel_ad \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<not>P s\<rceil>"
  by (auto simp: rel_ad_def)

lemma p2r_conj_hom [simp]: "\<lceil>P\<rceil> \<inter> \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>"
  by auto

lemma p2r_conj_hom_var [simp]: "\<lceil>P\<rceil> ; \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>"
  by auto

lemma p2r_disj_hom [simp]: "\<lceil>P\<rceil> \<union> \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<or> Q s\<rceil>"
  by auto

subsection {* Store and Assignment *}

type_synonym 'a store = "string  \<Rightarrow> 'a"

definition gets :: "string \<Rightarrow> ('a store \<Rightarrow> 'a) \<Rightarrow> 'a store rel" ("_ ::= _" [70, 65] 61) where
  "v ::= e = {(s,s (v := e s)) |s. True}"

lemma wp_assign [simp]: "rel_aka.wp (v ::= e) \<lceil>Q\<rceil> = \<lceil>\<lambda>s. Q (s (v := e s))\<rceil>"
  by (auto simp: rel_aka.wp_def gets_def rel_ad_def)

subsection {* Simplifications *}

abbreviation spec_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a pred \<Rightarrow> bool" ("PRE _ _ POST _" [64,64,64] 63) where
  "PRE P X POST Q \<equiv> rel_aka.dom_op \<lceil>P\<rceil> \<subseteq> rel_aka.wp X \<lceil>Q\<rceil>"

abbreviation if_then_else_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("IF _ THEN _ ELSE _ FI" [64,64,64] 63) where
  "IF P THEN X ELSE Y FI \<equiv> rel_aka.if_then_else \<lceil>P\<rceil> X Y"

abbreviation while_inv_sugar :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("WHILE _ INV _ DO _ OD" [64,64,64] 63) where
  "WHILE P INV I DO X OD \<equiv> rel_aka.while_inv \<lceil>P\<rceil> \<lceil>I\<rceil> X"

subsection {* Examples *}

lemma euclid:
  "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (rule rel_aka.wp_while_inv, simp_all) using gcd_red_nat by auto
(*
lemma euclid_diff:
   "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y \<and> x > 0 \<and> y > 0)
    (WHILE (\<lambda>s. s ''x''\<noteq> s ''y'') INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
     DO
        (IF (\<lambda>s. s ''x'' >  s ''y'')
         THEN (''x'' ::= (\<lambda>s. s ''x'' - s ''y''))
         ELSE (''y'' ::= (\<lambda>s. s ''y'' - s ''x''))
         FI)
    OD)
    POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (rule rel_aka.wp_while_inv, simp_all)
  apply (auto simp: gcd_diff1_nat)
  by (metis gcd.commute gcd_diff1_nat le_cases le_imp_less_or_eq)

lemma varible_swap:
  "PRE (\<lambda>s. s ''x'' = a \<and> s ''y'' = b)
    (''z'' ::= (\<lambda>s. s ''x''));
    (''x'' ::= (\<lambda>s. s ''y''));
    (''y'' ::= (\<lambda>s. s ''z''))
   POST (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)"
  by auto

lemma maximum:
  "PRE (\<lambda>s:: nat store. True)
   (IF (\<lambda>s. s ''x'' \<ge> s ''y'')
    THEN (''z'' ::= (\<lambda>s. s ''x''))
    ELSE (''z'' ::= (\<lambda>s. s ''y''))
    FI)
   POST (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))"
  by (auto simp: max_def rel_aka.dom_op_def rel_ad_def)

lemma integer_division:
  "PRE (\<lambda>s::nat store. x \<ge> 0)
    (''q'' ::= (\<lambda>s. 0));
    (''r'' ::= (\<lambda>s. x));
    (WHILE (\<lambda>s. y \<le> s ''r'') INV (\<lambda>s. x = s ''q'' * y + s ''r'' \<and> s ''r'' \<ge> 0)
     DO
      (''q'' ::= (\<lambda>s. s ''q'' + 1));
      (''r'' ::= (\<lambda>s. s ''r'' - y))
      OD)
   POST (\<lambda>s. x = s ''q'' * y + s ''r'' \<and> s ''r'' \<ge> 0 \<and> s ''r'' < y)"
  by (rule rel_aka.wp_while_inv_break, auto simp: rel_aka.dom_op_def rel_ad_def)

lemma factorial:
  "PRE (\<lambda>s::nat store. True)
   (''x'' ::= (\<lambda>s. 0));
   (''y'' ::= (\<lambda>s. 1));
   (WHILE (\<lambda>s. s ''x'' \<noteq> x0) INV (\<lambda>s. s ''y'' = fact (s ''x''))
   DO
     (''x'' ::= (\<lambda>s. s ''x'' + 1));
     (''y'' ::= (\<lambda>s. s ''y'' \<cdot> s ''x''))
   OD)
   POST (\<lambda>s. s ''y'' = fact x0)"
  by (rule rel_aka.wp_while_inv_break, auto simp: rel_aka.dom_op_def rel_ad_def)

lemma my_power:
  "PRE (\<lambda>s::nat store. True)
   (''i'' ::= (\<lambda>s. 0));
   (''y'' ::= (\<lambda>s. 1));
   (WHILE (\<lambda>s. s ''i'' < n) INV (\<lambda>s. s ''y'' = x ^ (s ''i'') \<and> s ''i'' \<le> n)
     DO
       (''y'' ::= (\<lambda>s. (s ''y'') * x));
       (''i'' ::= (\<lambda>s. s ''i'' + 1))
     OD)
   POST (\<lambda>s. s ''y'' = x ^ n)"
  by (rule rel_aka.wp_while_inv_break, auto simp: rel_aka.dom_op_def rel_ad_def)

lemma imp_reverse:
  "PRE (\<lambda>s:: 'a list store. s ''x'' = X)
   (''y'' ::= (\<lambda>s. []));
   (WHILE (\<lambda>s. s ''x'' \<noteq> []) INV (\<lambda>s. rev (s ''x'') @ s ''y'' = rev X)
    DO
     (''y'' ::= (\<lambda>s. hd (s ''x'') # s ''y''));
     (''x'' ::= (\<lambda>s. tl (s ''x'')))
    OD)
   POST (\<lambda>s. s ''y''= rev X )"
  by (rule rel_aka.wp_while_inv_break, auto, metis append.simps append_assoc hd_Cons_tl rev.simps(2))
*)
context antidomain_kleene_algebra
begin

subsection{* Propositional Hoare Logic *}

definition H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "H p x q \<longleftrightarrow> d p \<le> wp x q"

lemma H_skip: "H p 1 p"
  by (simp add: H_def dom_op_def wp_def)

lemma H_cons: "d p \<le> d p' \<Longrightarrow> d q' \<le> d q \<Longrightarrow> H p' x q' \<Longrightarrow> H p x q"
  by (meson H_def demod mult_isol order_trans)

lemma H_seq: "H p x r \<Longrightarrow> H r y q \<Longrightarrow> H p (x \<cdot> y) q"
  by (metis H_def a_d_closed demod dom_op_def wp_seq_var)

lemma H_cond: "H (d p \<cdot> d r) x q \<Longrightarrow> H (d p \<cdot> ad r) y q \<Longrightarrow> H p (if r then x else y fi) q"
proof -
  assume  h1: "H (d p \<cdot> d r) x q" and h2: "H (d p \<cdot> ad r) y q"
  hence h3: "d p \<cdot> d r \<le> wp x q" and h4: "d p \<cdot> ad r \<le> wp y q"
    using H_def a_closed dom_op_def apply auto[1]
    using H_def h2 a_closed dom_op_def by auto
  hence h5: "d p  \<le> ad r + wp x q" and h6: "d p  \<le> d r + wp y q"
    apply (simp add: dom_op_def shunt wp_def)
    using h4 a_d_closed dom_op_def shunt wp_def by auto
  hence "d p \<le> d p  \<cdot> (d r + wp y q)"
    by (metis a_idem distrib_left dom_op_def less_eq_def)
  also have  "... \<le> (ad r + wp x q) \<cdot> (d r + wp y q)"
    by (simp add: h5 mult_isor)
  finally show ?thesis
    by (simp add: H_def)
qed

lemma H_loop: "H (d p \<cdot> d r) x p \<Longrightarrow> H p (while r do x od) (d p \<cdot> ad r)"
  by (metis (full_types) H_def a_closed dom_op_def wp_while)

lemma H_while_inv: "d p \<le> d i \<Longrightarrow> d i \<cdot> ad r \<le> d q \<Longrightarrow> H (d i \<cdot> d r) x i \<Longrightarrow> H p (while r inv i do x od) q"
  using H_def a_closed dom_op_def wp_while_inv by auto

end

section {* Refinement Component Based on KAD *}

subsection{* Definition of RKAD *}

class rkad = antidomain_kleene_algebra +
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes R_def: "x \<le> R p q \<longleftrightarrow> d p \<le> wp x q"

begin

subsection {* Refinement Laws *}

lemma HR: "H p x q \<longleftrightarrow> x \<le> R p q"
  by (simp add: H_def R_def)

lemma wp_R2: "x \<le> R (wp x q) q"
  by (simp add: R_def wp_def)

lemma wp_R3: "d p \<le> wp x q \<Longrightarrow> x \<le> R p q"
  by (simp add: R_def)

lemma H_R1: "H p (R p q) q"
  by (simp add: HR)

lemma R_skip: "1 \<le> R p p"
  by (simp add: H_R2 H_skip)

lemma R_cons: "d p \<le> d p' \<Longrightarrow> d q' \<le> d q \<Longrightarrow> R p' q' \<le> R p q"
  by (simp add: H_R1 H_R2 H_cons)

lemma R_seq: "(R p r) \<cdot> (R r q) \<le> R p q"
  using H_R1 H_R2 H_seq by blast

lemma R_cond: "if v then (R (d v \<cdot> d p) q) else (R (ad v \<cdot> d p) q) fi \<le> R p q"
  by (simp add: H_R1 H_R2 H_cond a_comm dom_op_def)

lemma R_loop: "while q do (R (d p \<cdot> d q) p) od \<le> R p (d p \<cdot> ad q)"
  by (simp add: H_R1 H_R2 H_loop)

end

subsection {* Soundness *}

definition rel_R :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" where
  "rel_R P Q = \<Union>{X. rel_aka.dom_op P \<subseteq> rel_aka.wp X Q}"

interpretation rel_rkad: rkad Id "{}" "op \<union>"  "op ;" "op \<subseteq>" "op \<subset>" rtrancl rel_ad rel_R
  by (standard, auto simp: rel_R_def rel_aka.dom_op_def rel_ad_def rel_aka.wp_def, blast)

subsection {* Assignment Laws *}

lemma R_assign: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (auto simp: rel_rkad.R_def)

lemma H_assign_var: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> rel_aka.H \<lceil>P\<rceil> (v ::= e) \<lceil>Q\<rceil>"
  by (auto simp: rel_aka.H_def rel_aka.dom_op_def rel_ad_def gets_def rel_aka.wp_def)

lemma R_assignr: "(\<forall>s. Q' s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (rel_R \<lceil>P\<rceil> \<lceil>Q'\<rceil>) ; (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply (subst rel_rkad.HR[symmetric], rule rel_aka.H_seq) defer
  by (erule H_assign_var, simp add: rel_rkad.H_R1)

lemma R_assignl: "(\<forall>s. P s \<longrightarrow> P' (s (v := e s))) \<Longrightarrow> (v ::= e) ; (rel_R \<lceil>P'\<rceil> \<lceil>Q\<rceil>) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (subst rel_rkad.HR[symmetric], rule rel_aka.H_seq, erule H_assign_var, simp add: rel_rkad.H_R1)

subsection {* Examples *}

lemma var_swap_ref1:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref2:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''x'' ::= (\<lambda>s. s ''y'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref3:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''y'' ::= (\<lambda>s. s ''z'')); rel_R \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref_var:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); (''x'' ::= (\<lambda>s. s ''y'')); (''y'' ::= (\<lambda>s. s ''z''))"
  using var_swap_ref1 var_swap_ref2 var_swap_ref3 rel_rkad.R_skip  by fastforce

end


(*  Title:      Sequents/LK/Quantifiers.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge

Classical sequent calculus: examples with quantifiers.
*)

theory Quantifiers
imports "../LK"
begin

lemma "|- (ALL x. P)  <->  P"
  by fast

lemma "|- (ALL x y. P(x,y))  <->  (ALL y x. P(x,y))"
  by fast

lemma "ALL u. P(u), ALL v. Q(v) |- ALL u v. P(u) & Q(v)"
  by fast

text "Permutation of existential quantifier."

lemma "|- (EX x y. P(x,y)) <-> (EX y x. P(x,y))"
  by fast

lemma "|- (ALL x. P(x) & Q(x)) <-> (ALL x. P(x)) & (ALL x. Q(x))"
  by fast

(*Converse is invalid*)
lemma "|- (ALL x. P(x)) | (ALL x. Q(x)) --> (ALL x. P(x)|Q(x))"
  by fast

text "Pushing ALL into an implication."

lemma "|- (ALL x. P --> Q(x))  <->  (P --> (ALL x. Q(x)))"
  by fast

lemma "|- (ALL x. P(x)-->Q)  <->  ((EX x. P(x)) --> Q)"
  by fast

lemma "|- (EX x. P)  <->  P"
  by fast

text "Distribution of EX over disjunction."

lemma "|- (EX x. P(x) | Q(x)) <-> (EX x. P(x))  |  (EX x. Q(x))"
  by fast

(*Converse is invalid*)
lemma "|- (EX x. P(x) & Q(x))  -->  (EX x. P(x))  &  (EX x. Q(x))"
  by fast

text "Harder examples: classical theorems."

lemma "|- (EX x. P-->Q(x))  <->  (P --> (EX x. Q(x)))"
  by fast

lemma "|- (EX x. P(x)-->Q)  <->  (ALL x. P(x)) --> Q"
  by fast

lemma "|- (ALL x. P(x)) | Q  <->  (ALL x. P(x) | Q)"
  by fast

text "Basic test of quantifier reasoning"

lemma "|- (EX y. ALL x. Q(x,y)) --> (ALL x. EX y. Q(x,y))"
  by fast

lemma "|- (ALL x. Q(x))  -->  (EX x. Q(x))"
  by fast

text "The following are invalid!"

(*INVALID*)
lemma "|- (ALL x. EX y. Q(x,y))  -->  (EX y. ALL x. Q(x,y))"
  apply fast?
  apply (rule _)
  oops

(*INVALID*)
lemma "|- (EX x. Q(x))  -->  (ALL x. Q(x))"
  apply fast?
  apply (rule _)
  oops

(*INVALID*)
schematic_lemma "|- P(?a) --> (ALL x. P(x))"
  apply fast?
  apply (rule _)
  oops

(*INVALID*)
schematic_lemma "|- (P(?a) --> (ALL x. Q(x))) --> (ALL x. P(x) --> Q(x))"
  apply fast?
  apply (rule _)
  oops

text "Back to things that are provable..."

lemma "|- (ALL x. P(x)-->Q(x)) & (EX x. P(x)) --> (EX x. Q(x))"
  by fast

(*An example of why exR should be delayed as long as possible*)
lemma "|- (P--> (EX x. Q(x))) & P--> (EX x. Q(x))"
  by fast

text "Solving for a Var"

schematic_lemma "|- (ALL x. P(x)-->Q(f(x))) & (ALL x. Q(x)-->R(g(x))) & P(d) --> R(?a)"
  by fast

text "Principia Mathematica *11.53"

lemma "|- (ALL x y. P(x) --> Q(y)) <-> ((EX x. P(x)) --> (ALL y. Q(y)))"
  by fast

text "Principia Mathematica *11.55"

lemma "|- (EX x y. P(x) & Q(x,y)) <-> (EX x. P(x) & (EX y. Q(x,y)))"
  by fast

text "Principia Mathematica *11.61"

lemma "|- (EX y. ALL x. P(x) --> Q(x,y)) --> (ALL x. P(x) --> (EX y. Q(x,y)))"
  by fast

(*21 August 88: loaded in 45.7 secs*)
(*18 September 2005: loaded in 0.114 secs*)

end