theory Complex_Residues
  imports Complex_Singularities
begin

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

text\<open>Wenda Li and LC Paulson (2016). A Formal Proof of Cauchy's Residue Theorem.
    Interactive Theorem Proving\<close>

definition\<^marker>\<open>tag important\<close> residue :: "(complex \<Rightarrow> complex) \<Rightarrow> complex \<Rightarrow> complex" where
  "residue f z = (SOME int. \<exists>e>0. \<forall>\<epsilon>>0. \<epsilon><e
    \<longrightarrow> (f has_contour_integral 2*pi* \<i> *int) (circlepath z \<epsilon>))"

lemma Eps_cong:
  assumes "\<And>x. P x = Q x"
  shows   "Eps P = Eps Q"
  using ext[of P Q, OF assms] by simp

lemma residue_cong:
  assumes eq: "eventually (\<lambda>z. f z = g z) (at z)" and "z = z'"
  shows   "residue f z = residue g z'"
proof -
  from assms have eq': "eventually (\<lambda>z. g z = f z) (at z)"
    by (simp add: eq_commute)
  let ?P = "\<lambda>f c e. (\<forall>\<epsilon>>0. \<epsilon> < e \<longrightarrow>
   (f has_contour_integral of_real (2 * pi) * \<i> * c) (circlepath z \<epsilon>))"
  have "residue f z = residue g z" unfolding residue_def
  proof (rule Eps_cong)
    fix c :: complex
    have "\<exists>e>0. ?P g c e"
      if "\<exists>e>0. ?P f c e" and "eventually (\<lambda>z. f z = g z) (at z)" for f g
    proof -
      from that(1) obtain e where e: "e > 0" "?P f c e"
        by blast
      from that(2) obtain e' where e': "e' > 0" "\<And>z'. z' \<noteq> z \<Longrightarrow> dist z' z < e' \<Longrightarrow> f z' = g z'"
        unfolding eventually_at by blast
      have "?P g c (min e e')"
      proof (intro allI exI impI, goal_cases)
        case (1 \<epsilon>)
        hence "(f has_contour_integral of_real (2 * pi) * \<i> * c) (circlepath z \<epsilon>)"
          using e(2) by auto
        thus ?case
        proof (rule has_contour_integral_eq)
          fix z' assume "z' \<in> path_image (circlepath z \<epsilon>)"
          hence "dist z' z < e'" and "z' \<noteq> z"
            using 1 by (auto simp: dist_commute)
          with e'(2)[of z'] show "f z' = g z'" by simp
        qed
      qed
      moreover from e and e' have "min e e' > 0" by auto
      ultimately show ?thesis by blast
    qed
    from this[OF _ eq] and this[OF _ eq']
      show "(\<exists>e>0. ?P f c e) \<longleftrightarrow> (\<exists>e>0. ?P g c e)"
      by blast
  qed
  with assms show ?thesis by simp
qed

lemma contour_integral_circlepath_eq:
  assumes "open s" and f_holo:"f holomorphic_on (s-{z})" and "0<e1" "e1\<le>e2"
    and e2_cball:"cball z e2 \<subseteq> s"
  shows
    "f contour_integrable_on circlepath z e1"
    "f contour_integrable_on circlepath z e2"
    "contour_integral (circlepath z e2) f = contour_integral (circlepath z e1) f"
proof -
  define l where "l \<equiv> linepath (z+e2) (z+e1)"
  have [simp]:"valid_path l" "pathstart l=z+e2" "pathfinish l=z+e1" unfolding l_def by auto
  have "e2>0" using \<open>e1>0\<close> \<open>e1\<le>e2\<close> by auto
  have zl_img:"z\<notin>path_image l"
    proof
      assume "z \<in> path_image l"
      then have "e2 \<le> cmod (e2 - e1)"
        using segment_furthest_le[of z "z+e2" "z+e1" "z+e2",simplified] \<open>e1>0\<close> \<open>e2>0\<close> unfolding l_def
        by (auto simp add:closed_segment_commute)
      thus False using \<open>e2>0\<close> \<open>e1>0\<close> \<open>e1\<le>e2\<close>
        apply (subst (asm) norm_of_real)
        by auto
    qed
  define g where "g \<equiv> circlepath z e2 +++ l +++ reversepath (circlepath z e1) +++ reversepath l"
  show [simp]: "f contour_integrable_on circlepath z e2" "f contour_integrable_on (circlepath z e1)"
    proof -
      show "f contour_integrable_on circlepath z e2"
        apply (intro contour_integrable_continuous_circlepath[OF
                continuous_on_subset[OF holomorphic_on_imp_continuous_on[OF f_holo]]])
        using \<open>e2>0\<close> e2_cball by auto
      show "f contour_integrable_on (circlepath z e1)"
        apply (intro contour_integrable_continuous_circlepath[OF
                      continuous_on_subset[OF holomorphic_on_imp_continuous_on[OF f_holo]]])
        using \<open>e1>0\<close> \<open>e1\<le>e2\<close> e2_cball by auto
    qed
  have [simp]:"f contour_integrable_on l"
    proof -
      have "closed_segment (z + e2) (z + e1) \<subseteq> cball z e2" using \<open>e2>0\<close> \<open>e1>0\<close> \<open>e1\<le>e2\<close>
        by (intro closed_segment_subset,auto simp add:dist_norm)
      hence "closed_segment (z + e2) (z + e1) \<subseteq> s - {z}" using zl_img e2_cball unfolding l_def
        by auto
      then show "f contour_integrable_on l" unfolding l_def
        apply (intro contour_integrable_continuous_linepath[OF
                      continuous_on_subset[OF holomorphic_on_imp_continuous_on[OF f_holo]]])
        by auto
    qed
  let ?ig="\<lambda>g. contour_integral g f"
  have "(f has_contour_integral 0) g"
    proof (rule Cauchy_theorem_global[OF _ f_holo])
      show "open (s - {z})" using \<open>open s\<close> by auto
      show "valid_path g" unfolding g_def l_def by auto
      show "pathfinish g = pathstart g" unfolding g_def l_def by auto
    next
      have path_img:"path_image g \<subseteq> cball z e2"
        proof -
          have "closed_segment (z + e2) (z + e1) \<subseteq> cball z e2" using \<open>e2>0\<close> \<open>e1>0\<close> \<open>e1\<le>e2\<close>
            by (intro closed_segment_subset,auto simp add:dist_norm)
          moreover have "sphere z \<bar>e1\<bar> \<subseteq> cball z e2" using \<open>e2>0\<close> \<open>e1\<le>e2\<close> \<open>e1>0\<close> by auto
          ultimately show ?thesis unfolding g_def l_def using \<open>e2>0\<close>
            by (simp add: path_image_join closed_segment_commute)
        qed
      show "path_image g \<subseteq> s - {z}"
        proof -
          have "z\<notin>path_image g" using zl_img
            unfolding g_def l_def by (auto simp add: path_image_join closed_segment_commute)
          moreover note \<open>cball z e2 \<subseteq> s\<close> and path_img
          ultimately show ?thesis by auto
        qed
      show "winding_number g w = 0" when"w \<notin> s - {z}" for w
        proof -
          have "winding_number g w = 0" when "w\<notin>s" using that e2_cball
            apply (intro winding_number_zero_outside[OF _ _ _ _ path_img])
            by (auto simp add:g_def l_def)
          moreover have "winding_number g z=0"
            proof -
              let ?Wz="\<lambda>g. winding_number g z"
              have "?Wz g = ?Wz (circlepath z e2) + ?Wz l + ?Wz (reversepath (circlepath z e1))
                  + ?Wz (reversepath l)"
                using \<open>e2>0\<close> \<open>e1>0\<close> zl_img unfolding g_def l_def
                by (subst winding_number_join,auto simp add:path_image_join closed_segment_commute)+
              also have "... = ?Wz (circlepath z e2) + ?Wz (reversepath (circlepath z e1))"
                using zl_img
                apply (subst (2) winding_number_reversepath)
                by (auto simp add:l_def closed_segment_commute)
              also have "... = 0"
                proof -
                  have "?Wz (circlepath z e2) = 1" using \<open>e2>0\<close>
                    by (auto intro: winding_number_circlepath_centre)
                  moreover have "?Wz (reversepath (circlepath z e1)) = -1" using \<open>e1>0\<close>
                    apply (subst winding_number_reversepath)
                    by (auto intro: winding_number_circlepath_centre)
                  ultimately show ?thesis by auto
                qed
              finally show ?thesis .
            qed
          ultimately show ?thesis using that by auto
        qed
    qed
  then have "0 = ?ig g" using contour_integral_unique by simp
  also have "... = ?ig (circlepath z e2) + ?ig l + ?ig (reversepath (circlepath z e1))
      + ?ig (reversepath l)"
    unfolding g_def
    by (auto simp add:contour_integrable_reversepath_eq)
  also have "... = ?ig (circlepath z e2)  - ?ig (circlepath z e1)"
    by (auto simp add:contour_integral_reversepath)
  finally show "contour_integral (circlepath z e2) f = contour_integral (circlepath z e1) f"
    by simp
qed

lemma base_residue:
  assumes "open s" "z\<in>s" "r>0" and f_holo:"f holomorphic_on (s - {z})"
    and r_cball:"cball z r \<subseteq> s"
  shows "(f has_contour_integral 2 * pi * \<i> * (residue f z)) (circlepath z r)"
proof -
  obtain e where "e>0" and e_cball:"cball z e \<subseteq> s"
    using open_contains_cball[of s] \<open>open s\<close> \<open>z\<in>s\<close> by auto
  define c where "c \<equiv> 2 * pi * \<i>"
  define i where "i \<equiv> contour_integral (circlepath z e) f / c"
  have "(f has_contour_integral c*i) (circlepath z \<epsilon>)" when "\<epsilon>>0" "\<epsilon><e" for \<epsilon>
    proof -
      have "contour_integral (circlepath z e) f = contour_integral (circlepath z \<epsilon>) f"
          "f contour_integrable_on circlepath z \<epsilon>"
          "f contour_integrable_on circlepath z e"
        using \<open>\<epsilon><e\<close>
        by (intro contour_integral_circlepath_eq[OF \<open>open s\<close> f_holo \<open>\<epsilon>>0\<close> _ e_cball],auto)+
      then show ?thesis unfolding i_def c_def
        by (auto intro:has_contour_integral_integral)
    qed
  then have "\<exists>e>0. \<forall>\<epsilon>>0. \<epsilon><e \<longrightarrow> (f has_contour_integral c * (residue f z)) (circlepath z \<epsilon>)"
    unfolding residue_def c_def
    apply (rule_tac someI[of _ i],intro  exI[where x=e])
    by (auto simp add:\<open>e>0\<close> c_def)
  then obtain e' where "e'>0"
      and e'_def:"\<forall>\<epsilon>>0. \<epsilon><e' \<longrightarrow> (f has_contour_integral c * (residue f z)) (circlepath z \<epsilon>)"
    by auto
  let ?int="\<lambda>e. contour_integral (circlepath z e) f"
  define  \<epsilon> where "\<epsilon> \<equiv> Min {r,e'} / 2"
  have "\<epsilon>>0" "\<epsilon>\<le>r" "\<epsilon><e'" using \<open>r>0\<close> \<open>e'>0\<close> unfolding \<epsilon>_def by auto
  have "(f has_contour_integral c * (residue f z)) (circlepath z \<epsilon>)"
    using e'_def[rule_format,OF \<open>\<epsilon>>0\<close> \<open>\<epsilon><e'\<close>] .
  then show ?thesis unfolding c_def
    using contour_integral_circlepath_eq[OF \<open>open s\<close> f_holo \<open>\<epsilon>>0\<close> \<open>\<epsilon>\<le>r\<close> r_cball]
    by (auto elim: has_contour_integral_eqpath[of _ _ "circlepath z \<epsilon>" "circlepath z r"])
qed

lemma residue_holo:
  assumes "open s" "z \<in> s" and f_holo: "f holomorphic_on s"
  shows "residue f z = 0"
proof -
  define c where "c \<equiv> 2 * pi * \<i>"
  obtain e where "e>0" and e_cball:"cball z e \<subseteq> s" using \<open>open s\<close> \<open>z\<in>s\<close>
    using open_contains_cball_eq by blast
  have "(f has_contour_integral c*residue f z) (circlepath z e)"
    using f_holo
    by (auto intro: base_residue[OF \<open>open s\<close> \<open>z\<in>s\<close> \<open>e>0\<close> _ e_cball,folded c_def])
  moreover have "(f has_contour_integral 0) (circlepath z e)"
    using f_holo e_cball \<open>e>0\<close>
    by (auto intro: Cauchy_theorem_convex_simple[of _ "cball z e"])
  ultimately have "c*residue f z =0"
    using has_contour_integral_unique by blast
  thus ?thesis unfolding c_def  by auto
qed

lemma residue_const:"residue (\<lambda>_. c) z = 0"
  by (intro residue_holo[of "UNIV::complex set"],auto intro:holomorphic_intros)

lemma residue_add:
  assumes "open s" "z \<in> s" and f_holo: "f holomorphic_on s - {z}"
      and g_holo:"g holomorphic_on s - {z}"
  shows "residue (\<lambda>z. f z + g z) z= residue f z + residue g z"
proof -
  define c where "c \<equiv> 2 * pi * \<i>"
  define fg where "fg \<equiv> (\<lambda>z. f z+g z)"
  obtain e where "e>0" and e_cball:"cball z e \<subseteq> s" using \<open>open s\<close> \<open>z\<in>s\<close>
    using open_contains_cball_eq by blast
  have "(fg has_contour_integral c * residue fg z) (circlepath z e)"
    unfolding fg_def using f_holo g_holo
    apply (intro base_residue[OF \<open>open s\<close> \<open>z\<in>s\<close> \<open>e>0\<close> _ e_cball,folded c_def])
    by (auto intro:holomorphic_intros)
  moreover have "(fg has_contour_integral c*residue f z + c* residue g z) (circlepath z e)"
    unfolding fg_def using f_holo g_holo
    by (auto intro: has_contour_integral_add base_residue[OF \<open>open s\<close> \<open>z\<in>s\<close> \<open>e>0\<close> _ e_cball,folded c_def])
  ultimately have "c*(residue f z + residue g z) = c * residue fg z"
    using has_contour_integral_unique by (auto simp add:distrib_left)
  thus ?thesis unfolding fg_def
    by (auto simp add:c_def)
qed

lemma residue_lmul:
  assumes "open s" "z \<in> s" and f_holo: "f holomorphic_on s - {z}"
  shows "residue (\<lambda>z. c * (f z)) z= c * residue f z"
proof (cases "c=0")
  case True
  thus ?thesis using residue_const by auto
next
  case False
  define c' where "c' \<equiv> 2 * pi * \<i>"
  define f' where "f' \<equiv> (\<lambda>z. c * (f z))"
  obtain e where "e>0" and e_cball:"cball z e \<subseteq> s" using \<open>open s\<close> \<open>z\<in>s\<close>
    using open_contains_cball_eq by blast
  have "(f' has_contour_integral c' * residue f' z) (circlepath z e)"
    unfolding f'_def using f_holo
    apply (intro base_residue[OF \<open>open s\<close> \<open>z\<in>s\<close> \<open>e>0\<close> _ e_cball,folded c'_def])
    by (auto intro:holomorphic_intros)
  moreover have "(f' has_contour_integral c * (c' * residue f z)) (circlepath z e)"
    unfolding f'_def using f_holo
    by (auto intro: has_contour_integral_lmul
      base_residue[OF \<open>open s\<close> \<open>z\<in>s\<close> \<open>e>0\<close> _ e_cball,folded c'_def])
  ultimately have "c' * residue f' z  = c * (c' * residue f z)"
    using has_contour_integral_unique by auto
  thus ?thesis unfolding f'_def c'_def using False
    by (auto simp add:field_simps)
qed

lemma residue_rmul:
  assumes "open s" "z \<in> s" and f_holo: "f holomorphic_on s - {z}"
  shows "residue (\<lambda>z. (f z) * c) z= residue f z * c"
using residue_lmul[OF assms,of c] by (auto simp add:algebra_simps)

lemma residue_div:
  assumes "open s" "z \<in> s" and f_holo: "f holomorphic_on s - {z}"
  shows "residue (\<lambda>z. (f z) / c) z= residue f z / c "
using residue_lmul[OF assms,of "1/c"] by (auto simp add:algebra_simps)

lemma residue_neg:
  assumes "open s" "z \<in> s" and f_holo: "f holomorphic_on s - {z}"
  shows "residue (\<lambda>z. - (f z)) z= - residue f z"
using residue_lmul[OF assms,of "-1"] by auto

lemma residue_diff:
  assumes "open s" "z \<in> s" and f_holo: "f holomorphic_on s - {z}"
      and g_holo:"g holomorphic_on s - {z}"
  shows "residue (\<lambda>z. f z - g z) z= residue f z - residue g z"
using residue_add[OF assms(1,2,3),of "\<lambda>z. - g z"] residue_neg[OF assms(1,2,4)]
by (auto intro:holomorphic_intros g_holo)

lemma residue_simple:
  assumes "open s" "z\<in>s" and f_holo:"f holomorphic_on s"
  shows "residue (\<lambda>w. f w / (w - z)) z = f z"
proof -
  define c where "c \<equiv> 2 * pi * \<i>"
  define f' where "f' \<equiv> \<lambda>w. f w / (w - z)"
  obtain e where "e>0" and e_cball:"cball z e \<subseteq> s" using \<open>open s\<close> \<open>z\<in>s\<close>
    using open_contains_cball_eq by blast
  have "(f' has_contour_integral c * f z) (circlepath z e)"
    unfolding f'_def c_def using \<open>e>0\<close> f_holo e_cball
    by (auto intro!: Cauchy_integral_circlepath_simple holomorphic_intros)
  moreover have "(f' has_contour_integral c * residue f' z) (circlepath z e)"
    unfolding f'_def using f_holo
    apply (intro base_residue[OF \<open>open s\<close> \<open>z\<in>s\<close> \<open>e>0\<close> _ e_cball,folded c_def])
    by (auto intro!:holomorphic_intros)
  ultimately have "c * f z = c * residue f' z"
    using has_contour_integral_unique by blast
  thus ?thesis unfolding c_def f'_def  by auto
qed

lemma residue_simple':
  assumes s: "open s" "z \<in> s" and holo: "f holomorphic_on (s - {z})"
      and lim: "((\<lambda>w. f w * (w - z)) \<longlongrightarrow> c) (at z)"
  shows   "residue f z = c"
proof -
  define g where "g = (\<lambda>w. if w = z then c else f w * (w - z))"
  from holo have "(\<lambda>w. f w * (w - z)) holomorphic_on (s - {z})" (is "?P")
    by (force intro: holomorphic_intros)
  also have "?P \<longleftrightarrow> g holomorphic_on (s - {z})"
    by (intro holomorphic_cong refl) (simp_all add: g_def)
  finally have *: "g holomorphic_on (s - {z})" .

  note lim
  also have "(\<lambda>w. f w * (w - z)) \<midarrow>z\<rightarrow> c \<longleftrightarrow> g \<midarrow>z\<rightarrow> g z"
    by (intro filterlim_cong refl) (simp_all add: g_def [abs_def] eventually_at_filter)
  finally have **: "g \<midarrow>z\<rightarrow> g z" .

  have g_holo: "g holomorphic_on s"
    by (rule no_isolated_singularity'[where K = "{z}"])
       (insert assms * **, simp_all add: at_within_open_NO_MATCH)
  from s and this have "residue (\<lambda>w. g w / (w - z)) z = g z"
    by (rule residue_simple)
  also have "\<forall>\<^sub>F za in at z. g za / (za - z) = f za"
    unfolding eventually_at by (auto intro!: exI[of _ 1] simp: field_simps g_def)
  hence "residue (\<lambda>w. g w / (w - z)) z = residue f z"
    by (intro residue_cong refl)
  finally show ?thesis
    by (simp add: g_def)
qed

lemma residue_holomorphic_over_power:
  assumes "open A" "z0 \<in> A" "f holomorphic_on A"
  shows   "residue (\<lambda>z. f z / (z - z0) ^ Suc n) z0 = (deriv ^^ n) f z0 / fact n"
proof -
  let ?f = "\<lambda>z. f z / (z - z0) ^ Suc n"
  from assms(1,2) obtain r where r: "r > 0" "cball z0 r \<subseteq> A"
    by (auto simp: open_contains_cball)
  have "(?f has_contour_integral 2 * pi * \<i> * residue ?f z0) (circlepath z0 r)"
    using r assms by (intro base_residue[of A]) (auto intro!: holomorphic_intros)
  moreover have "(?f has_contour_integral 2 * pi * \<i> / fact n * (deriv ^^ n) f z0) (circlepath z0 r)"
    using assms r
    by (intro Cauchy_has_contour_integral_higher_derivative_circlepath)
       (auto intro!: holomorphic_on_subset[OF assms(3)] holomorphic_on_imp_continuous_on)
  ultimately have "2 * pi * \<i> * residue ?f z0 = 2 * pi * \<i> / fact n * (deriv ^^ n) f z0"
    by (rule has_contour_integral_unique)
  thus ?thesis by (simp add: field_simps)
qed

lemma residue_holomorphic_over_power':
  assumes "open A" "0 \<in> A" "f holomorphic_on A"
  shows   "residue (\<lambda>z. f z / z ^ Suc n) 0 = (deriv ^^ n) f 0 / fact n"
  using residue_holomorphic_over_power[OF assms] by simp

theorem residue_fps_expansion_over_power_at_0:
  assumes "f has_fps_expansion F"
  shows   "residue (\<lambda>z. f z / z ^ Suc n) 0 = fps_nth F n"
proof -
  from has_fps_expansion_imp_holomorphic[OF assms] guess s . note s = this
  have "residue (\<lambda>z. f z / (z - 0) ^ Suc n) 0 = (deriv ^^ n) f 0 / fact n"
    using assms s unfolding has_fps_expansion_def
    by (intro residue_holomorphic_over_power[of s]) (auto simp: zero_ereal_def)
  also from assms have "\<dots> = fps_nth F n"
    by (subst fps_nth_fps_expansion) auto
  finally show ?thesis by simp
qed

lemma residue_pole_order:
  fixes f::"complex \<Rightarrow> complex" and z::complex
  defines "n \<equiv> nat (- zorder f z)" and "h \<equiv> zor_poly f z"
  assumes f_iso:"isolated_singularity_at f z"
    and pole:"is_pole f z"
  shows "residue f z = ((deriv ^^ (n - 1)) h z / fact (n-1))"
proof -
  define g where "g \<equiv> \<lambda>x. if x=z then 0 else inverse (f x)"
  obtain e where [simp]:"e>0" and f_holo:"f holomorphic_on ball z e - {z}"
    using f_iso analytic_imp_holomorphic unfolding isolated_singularity_at_def by blast
  obtain r where "0 < n" "0 < r" and r_cball:"cball z r \<subseteq> ball z e" and h_holo: "h holomorphic_on cball z r"
      and h_divide:"(\<forall>w\<in>cball z r. (w\<noteq>z \<longrightarrow> f w = h w / (w - z) ^ n) \<and> h w \<noteq> 0)"
  proof -
    obtain r where r:"zorder f z < 0" "h z \<noteq> 0" "r>0" "cball z r \<subseteq> ball z e" "h holomorphic_on cball z r"
        "(\<forall>w\<in>cball z r - {z}. f w = h w / (w - z) ^ n \<and> h w \<noteq> 0)"
      using zorder_exist_pole[OF f_holo,simplified,OF \<open>is_pole f z\<close>,folded n_def h_def] by auto
    have "n>0" using \<open>zorder f z < 0\<close> unfolding n_def by simp
    moreover have "(\<forall>w\<in>cball z r. (w\<noteq>z \<longrightarrow> f w = h w / (w - z) ^ n) \<and> h w \<noteq> 0)"
      using \<open>h z\<noteq>0\<close> r(6) by blast
    ultimately show ?thesis using r(3,4,5) that by blast
  qed
  have r_nonzero:"\<And>w. w \<in> ball z r - {z} \<Longrightarrow> f w \<noteq> 0"
    using h_divide by simp
  define c where "c \<equiv> 2 * pi * \<i>"
  define der_f where "der_f \<equiv> ((deriv ^^ (n - 1)) h z / fact (n-1))"
  define h' where "h' \<equiv> \<lambda>u. h u / (u - z) ^ n"
  have "(h' has_contour_integral c / fact (n - 1) * (deriv ^^ (n - 1)) h z) (circlepath z r)"
    unfolding h'_def
    proof (rule Cauchy_has_contour_integral_higher_derivative_circlepath[of z r h z "n-1",
        folded c_def Suc_pred'[OF \<open>n>0\<close>]])
      show "continuous_on (cball z r) h" using holomorphic_on_imp_continuous_on h_holo by simp
      show "h holomorphic_on ball z r" using h_holo by auto
      show " z \<in> ball z r" using \<open>r>0\<close> by auto
    qed
  then have "(h' has_contour_integral c * der_f) (circlepath z r)" unfolding der_f_def by auto
  then have "(f has_contour_integral c * der_f) (circlepath z r)"
    proof (elim has_contour_integral_eq)
      fix x assume "x \<in> path_image (circlepath z r)"
      hence "x\<in>cball z r - {z}" using \<open>r>0\<close> by auto
      then show "h' x = f x" using h_divide unfolding h'_def by auto
    qed
  moreover have "(f has_contour_integral c * residue f z) (circlepath z r)"
    using base_residue[of \<open>ball z e\<close> z,simplified,OF \<open>r>0\<close> f_holo r_cball,folded c_def]
    unfolding c_def by simp
  ultimately have "c * der_f =  c * residue f z" using has_contour_integral_unique by blast
  hence "der_f = residue f z" unfolding c_def by auto
  thus ?thesis unfolding der_f_def by auto
qed

lemma residue_simple_pole:
  assumes "isolated_singularity_at f z0"
  assumes "is_pole f z0" "zorder f z0 = - 1"
  shows   "residue f z0 = zor_poly f z0 z0"
  using assms by (subst residue_pole_order) simp_all

lemma residue_simple_pole_limit:
  assumes "isolated_singularity_at f z0"
  assumes "is_pole f z0" "zorder f z0 = - 1"
  assumes "((\<lambda>x. f (g x) * (g x - z0)) \<longlongrightarrow> c) F"
  assumes "filterlim g (at z0) F" "F \<noteq> bot"
  shows   "residue f z0 = c"
proof -
  have "residue f z0 = zor_poly f z0 z0"
    by (rule residue_simple_pole assms)+
  also have "\<dots> = c"
    apply (rule zor_poly_pole_eqI)
    using assms by auto
  finally show ?thesis .
qed

lemma
  assumes f_holo:"f holomorphic_on s" and g_holo:"g holomorphic_on s"
          and "open s" "connected s" "z \<in> s"
  assumes g_deriv:"(g has_field_derivative g') (at z)"
  assumes "f z \<noteq> 0" "g z = 0" "g' \<noteq> 0"
  shows   porder_simple_pole_deriv: "zorder (\<lambda>w. f w / g w) z = - 1"
    and   residue_simple_pole_deriv: "residue (\<lambda>w. f w / g w) z = f z / g'"
proof -
  have [simp]:"isolated_singularity_at f z" "isolated_singularity_at g z"
    using isolated_singularity_at_holomorphic[OF _ \<open>open s\<close> \<open>z\<in>s\<close>] f_holo g_holo
    by (meson Diff_subset holomorphic_on_subset)+
  have [simp]:"not_essential f z" "not_essential g z"
    unfolding not_essential_def using f_holo g_holo assms(3,5)
    by (meson continuous_on_eq_continuous_at continuous_within holomorphic_on_imp_continuous_on)+
  have g_nconst:"\<exists>\<^sub>F w in at z. g w \<noteq>0 "
  proof (rule ccontr)
    assume "\<not> (\<exists>\<^sub>F w in at z. g w \<noteq> 0)"
    then have "\<forall>\<^sub>F w in nhds z. g w = 0"
      unfolding eventually_at eventually_nhds frequently_at using \<open>g z = 0\<close>
      by (metis open_ball UNIV_I centre_in_ball dist_commute mem_ball)
    then have "deriv g z = deriv (\<lambda>_. 0) z"
      by (intro deriv_cong_ev) auto
    then have "deriv g z = 0" by auto
    then have "g' = 0" using g_deriv DERIV_imp_deriv by blast
    then show False using \<open>g'\<noteq>0\<close> by auto
  qed

  have "zorder (\<lambda>w. f w / g w) z = zorder f z - zorder g z"
  proof -
    have "\<forall>\<^sub>F w in at z. f w \<noteq>0 \<and> w\<in>s"
      apply (rule non_zero_neighbour_alt)
      using assms by auto
    with g_nconst have "\<exists>\<^sub>F w in at z. f w * g w \<noteq> 0"
      by (elim frequently_rev_mp eventually_rev_mp,auto)
    then show ?thesis using zorder_divide[of f z g] by auto
  qed
  moreover have "zorder f z=0"
    apply (rule zorder_zero_eqI[OF f_holo \<open>open s\<close> \<open>z\<in>s\<close>])
    using \<open>f z\<noteq>0\<close> by auto
  moreover have "zorder g z=1"
    apply (rule zorder_zero_eqI[OF g_holo \<open>open s\<close> \<open>z\<in>s\<close>])
    subgoal using assms(8) by auto
    subgoal using DERIV_imp_deriv assms(9) g_deriv by auto
    subgoal by simp
    done
  ultimately show "zorder (\<lambda>w. f w / g w) z = - 1" by auto

  show "residue (\<lambda>w. f w / g w) z = f z / g'"
  proof (rule residue_simple_pole_limit[where g=id and F="at z",simplified])
    show "zorder (\<lambda>w. f w / g w) z = - 1" by fact
    show "isolated_singularity_at (\<lambda>w. f w / g w) z"
      by (auto intro: singularity_intros)
    show "is_pole (\<lambda>w. f w / g w) z"
    proof (rule is_pole_divide)
      have "\<forall>\<^sub>F x in at z. g x \<noteq> 0"
        apply (rule non_zero_neighbour)
        using g_nconst by auto
      moreover have "g \<midarrow>z\<rightarrow> 0"
        using DERIV_isCont assms(8) continuous_at g_deriv by force
      ultimately show "filterlim g (at 0) (at z)" unfolding filterlim_at by simp
      show "isCont f z"
        using assms(3,5) continuous_on_eq_continuous_at f_holo holomorphic_on_imp_continuous_on
        by auto
      show "f z \<noteq> 0" by fact
    qed
    show "filterlim id (at z) (at z)" by (simp add: filterlim_iff)
    have "((\<lambda>w. (f w * (w - z)) / g w) \<longlongrightarrow> f z / g') (at z)"
    proof (rule lhopital_complex_simple)
      show "((\<lambda>w. f w * (w - z)) has_field_derivative f z) (at z)"
        using assms by (auto intro!: derivative_eq_intros holomorphic_derivI[OF f_holo])
      show "(g has_field_derivative g') (at z)" by fact
    qed (insert assms, auto)
    then show "((\<lambda>w. (f w / g w) * (w - z)) \<longlongrightarrow> f z / g') (at z)"
      by (simp add: field_split_simps)
  qed
qed

subsection \<open>Poles and residues of some well-known functions\<close>

(* TODO: add more material here for other functions *)
lemma is_pole_Gamma: "is_pole Gamma (-of_nat n)"
  unfolding is_pole_def using Gamma_poles .

lemma Gamma_residue:
  "residue Gamma (-of_nat n) = (-1) ^ n / fact n"
proof (rule residue_simple')
  show "open (- (\<int>\<^sub>\<le>\<^sub>0 - {-of_nat n}) :: complex set)"
    by (intro open_Compl closed_subset_Ints) auto
  show "Gamma holomorphic_on (- (\<int>\<^sub>\<le>\<^sub>0 - {-of_nat n}) - {- of_nat n})"
    by (rule holomorphic_Gamma) auto
  show "(\<lambda>w. Gamma w * (w - (-of_nat n))) \<midarrow>(-of_nat n)\<rightarrow> (- 1) ^ n / fact n"
    using Gamma_residues[of n] by simp
qed auto

end


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

section \<open>Trees and forests, a mutually recursive type definition\<close>

theory Tree_Forest imports Main begin

subsection \<open>Datatype definition\<close>

consts
  tree :: "i => i"
  forest :: "i => i"
  tree_forest :: "i => i"

datatype "tree(A)" = Tcons ("a \<in> A", "f \<in> forest(A)")
  and "forest(A)" = Fnil | Fcons ("t \<in> tree(A)", "f \<in> forest(A)")

(* FIXME *)
lemmas tree'induct =
    tree_forest.mutual_induct [THEN conjunct1, THEN spec, THEN [2] rev_mp, of concl: _ t, consumes 1]
  and forest'induct =
    tree_forest.mutual_induct [THEN conjunct2, THEN spec, THEN [2] rev_mp, of concl: _ f, consumes 1]
  for t

declare tree_forest.intros [simp, TC]

lemma tree_def: "tree(A) == Part(tree_forest(A), Inl)"
  by (simp only: tree_forest.defs)

lemma forest_def: "forest(A) == Part(tree_forest(A), Inr)"
  by (simp only: tree_forest.defs)

text \<open>
  \medskip @{term "tree_forest(A)"} as the union of @{term "tree(A)"}
  and @{term "forest(A)"}.
\<close>

lemma tree_subset_TF: "tree(A) \<subseteq> tree_forest(A)"
  apply (unfold tree_forest.defs)
  apply (rule Part_subset)
  done

lemma treeI [TC]: "x \<in> tree(A) ==> x \<in> tree_forest(A)"
  by (rule tree_subset_TF [THEN subsetD])

lemma forest_subset_TF: "forest(A) \<subseteq> tree_forest(A)"
  apply (unfold tree_forest.defs)
  apply (rule Part_subset)
  done

lemma treeI' [TC]: "x \<in> forest(A) ==> x \<in> tree_forest(A)"
  by (rule forest_subset_TF [THEN subsetD])

lemma TF_equals_Un: "tree(A) \<union> forest(A) = tree_forest(A)"
  apply (insert tree_subset_TF forest_subset_TF)
  apply (auto intro!: equalityI tree_forest.intros elim: tree_forest.cases)
  done

lemma tree_forest_unfold:
  "tree_forest(A) = (A \<times> forest(A)) + ({0} + tree(A) \<times> forest(A))"
    \<comment> \<open>NOT useful, but interesting \dots\<close>
  supply rews = tree_forest.con_defs tree_def forest_def
  apply (unfold tree_def forest_def)
  apply (fast intro!: tree_forest.intros [unfolded rews, THEN PartD1]
    elim: tree_forest.cases [unfolded rews])
  done

lemma tree_forest_unfold':
  "tree_forest(A) =
    A \<times> Part(tree_forest(A), \<lambda>w. Inr(w)) +
    {0} + Part(tree_forest(A), \<lambda>w. Inl(w)) * Part(tree_forest(A), \<lambda>w. Inr(w))"
  by (rule tree_forest_unfold [unfolded tree_def forest_def])

lemma tree_unfold: "tree(A) = {Inl(x). x \<in> A \<times> forest(A)}"
  apply (unfold tree_def forest_def)
  apply (rule Part_Inl [THEN subst])
  apply (rule tree_forest_unfold' [THEN subst_context])
  done

lemma forest_unfold: "forest(A) = {Inr(x). x \<in> {0} + tree(A)*forest(A)}"
  apply (unfold tree_def forest_def)
  apply (rule Part_Inr [THEN subst])
  apply (rule tree_forest_unfold' [THEN subst_context])
  done

text \<open>
  \medskip Type checking for recursor: Not needed; possibly interesting?
\<close>

lemma TF_rec_type:
  "[| z \<in> tree_forest(A);
      !!x f r. [| x \<in> A;  f \<in> forest(A);  r \<in> C(f)
                |] ==> b(x,f,r) \<in> C(Tcons(x,f));
      c \<in> C(Fnil);
      !!t f r1 r2. [| t \<in> tree(A);  f \<in> forest(A);  r1 \<in> C(t); r2 \<in> C(f)
                    |] ==> d(t,f,r1,r2) \<in> C(Fcons(t,f))
   |] ==> tree_forest_rec(b,c,d,z) \<in> C(z)"
  by (induct_tac z) simp_all

lemma tree_forest_rec_type:
  "[| !!x f r. [| x \<in> A;  f \<in> forest(A);  r \<in> D(f)
                |] ==> b(x,f,r) \<in> C(Tcons(x,f));
      c \<in> D(Fnil);
      !!t f r1 r2. [| t \<in> tree(A);  f \<in> forest(A);  r1 \<in> C(t); r2 \<in> D(f)
                    |] ==> d(t,f,r1,r2) \<in> D(Fcons(t,f))
   |] ==> (\<forall>t \<in> tree(A).    tree_forest_rec(b,c,d,t) \<in> C(t)) \<and>
          (\<forall>f \<in> forest(A). tree_forest_rec(b,c,d,f) \<in> D(f))"
    \<comment> \<open>Mutually recursive version.\<close>
  apply (unfold Ball_def)
  apply (rule tree_forest.mutual_induct)
  apply simp_all
  done

subsection \<open>Operations\<close>

consts
  map :: "[i => i, i] => i"
  size :: "i => i"
  preorder :: "i => i"
  list_of_TF :: "i => i"
  of_list :: "i => i"
  reflect :: "i => i"

primrec
  "list_of_TF (Tcons(x,f)) = [Tcons(x,f)]"
  "list_of_TF (Fnil) = []"
  "list_of_TF (Fcons(t,tf)) = Cons (t, list_of_TF(tf))"

primrec
  "of_list([]) = Fnil"
  "of_list(Cons(t,l)) = Fcons(t, of_list(l))"

primrec
  "map (h, Tcons(x,f)) = Tcons(h(x), map(h,f))"
  "map (h, Fnil) = Fnil"
  "map (h, Fcons(t,tf)) = Fcons (map(h, t), map(h, tf))"

primrec
  "size (Tcons(x,f)) = succ(size(f))"
  "size (Fnil) = 0"
  "size (Fcons(t,tf)) = size(t) #+ size(tf)"

primrec
  "preorder (Tcons(x,f)) = Cons(x, preorder(f))"
  "preorder (Fnil) = Nil"
  "preorder (Fcons(t,tf)) = preorder(t) @ preorder(tf)"

primrec
  "reflect (Tcons(x,f)) = Tcons(x, reflect(f))"
  "reflect (Fnil) = Fnil"
  "reflect (Fcons(t,tf)) =
    of_list (list_of_TF (reflect(tf)) @ Cons(reflect(t), Nil))"

text \<open>
  \medskip \<open>list_of_TF\<close> and \<open>of_list\<close>.
\<close>

lemma list_of_TF_type [TC]:
    "z \<in> tree_forest(A) ==> list_of_TF(z) \<in> list(tree(A))"
  by (induct set: tree_forest) simp_all

lemma of_list_type [TC]: "l \<in> list(tree(A)) ==> of_list(l) \<in> forest(A)"
  by (induct set: list) simp_all

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

lemma
  assumes "!!x. x \<in> A ==> h(x): B"
  shows map_tree_type: "t \<in> tree(A) ==> map(h,t) \<in> tree(B)"
    and map_forest_type: "f \<in> forest(A) ==> map(h,f) \<in> forest(B)"
  using assms
  by (induct rule: tree'induct forest'induct) simp_all

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

lemma size_type [TC]: "z \<in> tree_forest(A) ==> size(z) \<in> nat"
  by (induct set: tree_forest) simp_all

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

lemma preorder_type [TC]: "z \<in> tree_forest(A) ==> preorder(z) \<in> list(A)"
  by (induct set: tree_forest) simp_all

text \<open>
  \medskip Theorems about \<open>list_of_TF\<close> and \<open>of_list\<close>.
\<close>

lemma forest_induct [consumes 1, case_names Fnil Fcons]:
  "[| f \<in> forest(A);
      R(Fnil);
      !!t f. [| t \<in> tree(A);  f \<in> forest(A);  R(f) |] ==> R(Fcons(t,f))
   |] ==> R(f)"
  \<comment> \<open>Essentially the same as list induction.\<close>
  apply (erule tree_forest.mutual_induct
      [THEN conjunct2, THEN spec, THEN [2] rev_mp])
    apply (rule TrueI)
   apply simp
  apply simp
  done

lemma forest_iso: "f \<in> forest(A) ==> of_list(list_of_TF(f)) = f"
  by (induct rule: forest_induct) simp_all

lemma tree_list_iso: "ts: list(tree(A)) ==> list_of_TF(of_list(ts)) = ts"
  by (induct set: list) simp_all

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

lemma map_ident: "z \<in> tree_forest(A) ==> map(\<lambda>u. u, z) = z"
  by (induct set: tree_forest) simp_all

lemma map_compose:
    "z \<in> tree_forest(A) ==> map(h, map(j,z)) = map(\<lambda>u. h(j(u)), z)"
  by (induct set: tree_forest) simp_all

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

lemma size_map: "z \<in> tree_forest(A) ==> size(map(h,z)) = size(z)"
  by (induct set: tree_forest) simp_all

lemma size_length: "z \<in> tree_forest(A) ==> size(z) = length(preorder(z))"
  by (induct set: tree_forest) (simp_all add: length_app)

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

lemma preorder_map:
    "z \<in> tree_forest(A) ==> preorder(map(h,z)) = List_ZF.map(h, preorder(z))"
  by (induct set: tree_forest) (simp_all add: map_app_distrib)

end


(*  Title:      HOL/Hoare/Pointer_Examples.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM

Examples of verifications of pointer programs.
*)

theory Pointer_Examples imports HeapSyntax begin

axiomatization where unproven: "PROP A"

section "Verifications"

subsection "List reversal"

text "A short but unreadable proof:"

lemma "VARS tl p q r
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                 rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {List tl q (rev Ps @ Qs)}"
apply vcg_simp
  apply fastforce
 apply(fastforce intro:notin_List_update[THEN iffD2])
(* explicit:
 apply clarify
 apply(rename_tac ps b qs)
 apply clarsimp
 apply(rename_tac ps')
 apply(fastforce intro:notin_List_update[THEN iffD2])
 apply(rule_tac x = ps' in exI)
 apply simp
 apply(rule_tac x = "b#qs" in exI)
 apply simp
*)
apply fastforce
done

text{* And now with ghost variables @{term ps} and @{term qs}. Even
``more automatic''. *}

lemma "VARS next p ps q qs r
  {List next p Ps \<and> List next q Qs \<and> set Ps \<inter> set Qs = {} \<and>
   ps = Ps \<and> qs = Qs}
  WHILE p \<noteq> Null
  INV {List next p ps \<and> List next q qs \<and> set ps \<inter> set qs = {} \<and>
       rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.next; r^.next := q; q := r;
     qs := (hd ps) # qs; ps := tl ps OD
  {List next q (rev Ps @ Qs)}"
apply vcg_simp
 apply fastforce
apply fastforce
done

text "A longer readable version:"

lemma "VARS tl p q r
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
               rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {List tl q (rev Ps @ Qs)}"
proof vcg
  fix tl p q r
  assume "List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}"
  thus "\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                rev ps @ qs = rev Ps @ Qs" by fastforce
next
  fix tl p q r
  assume "(\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                   rev ps @ qs = rev Ps @ Qs) \<and> p \<noteq> Null"
         (is "(\<exists>ps qs. ?I ps qs) \<and> _")
  then obtain ps qs a where I: "?I ps qs \<and> p = Ref a"
    by fast
  then obtain ps' where "ps = a # ps'" by fastforce
  hence "List (tl(p \<rightarrow> q)) (p^.tl) ps' \<and>
         List (tl(p \<rightarrow> q)) p       (a#qs) \<and>
         set ps' \<inter> set (a#qs) = {} \<and>
         rev ps' @ (a#qs) = rev Ps @ Qs"
    using I by fastforce
  thus "\<exists>ps' qs'. List (tl(p \<rightarrow> q)) (p^.tl) ps' \<and>
                  List (tl(p \<rightarrow> q)) p       qs' \<and>
                  set ps' \<inter> set qs' = {} \<and>
                  rev ps' @ qs' = rev Ps @ Qs" by fast
next
  fix tl p q r
  assume "(\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                   rev ps @ qs = rev Ps @ Qs) \<and> \<not> p \<noteq> Null"
  thus "List tl q (rev Ps @ Qs)" by fastforce
qed

text{* Finaly, the functional version. A bit more verbose, but automatic! *}

lemma "VARS tl p q r
  {islist tl p \<and> islist tl q \<and>
   Ps = list tl p \<and> Qs = list tl q \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {islist tl p \<and> islist tl q \<and>
       set(list tl p) \<inter> set(list tl q) = {} \<and>
       rev(list tl p) @ (list tl q) = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {islist tl q \<and> list tl q = rev Ps @ Qs}"
apply vcg_simp
  apply clarsimp
 apply clarsimp
apply clarsimp
done

subsection "Searching in a list"

text{*What follows is a sequence of successively more intelligent proofs that
a simple loop finds an element in a linked list.

We start with a proof based on the @{term List} predicate. This means it only
works for acyclic lists. *}

lemma "VARS tl p
  {List tl p Ps \<and> X \<in> set Ps}
  WHILE p \<noteq> Null \<and> p \<noteq> Ref X
  INV {\<exists>ps. List tl p ps \<and> X \<in> set ps}
  DO p := p^.tl OD
  {p = Ref X}"
apply vcg_simp
  apply blast
 apply clarsimp
apply clarsimp
done

text{*Using @{term Path} instead of @{term List} generalizes the correctness
statement to cyclic lists as well: *}

lemma "VARS tl p
  {Path tl p Ps X}
  WHILE p \<noteq> Null \<and> p \<noteq> X
  INV {\<exists>ps. Path tl p ps X}
  DO p := p^.tl OD
  {p = X}"
apply vcg_simp
  apply blast
 apply fastforce
apply clarsimp
done

text{*Now it dawns on us that we do not need the list witness at all --- it
suffices to talk about reachability, i.e.\ we can use relations directly. The
first version uses a relation on @{typ"'a ref"}: *}

lemma "VARS tl p
  {(p,X) \<in> {(Ref x,tl x) |x. True}^*}
  WHILE p \<noteq> Null \<and> p \<noteq> X
  INV {(p,X) \<in> {(Ref x,tl x) |x. True}^*}
  DO p := p^.tl OD
  {p = X}"
apply vcg_simp
 apply clarsimp
 apply(erule converse_rtranclE)
  apply simp
 apply(clarsimp elim:converse_rtranclE)
apply(fast elim:converse_rtranclE)
done

text{*Finally, a version based on a relation on type @{typ 'a}:*}

lemma "VARS tl p
  {p \<noteq> Null \<and> (addr p,X) \<in> {(x,y). tl x = Ref y}^*}
  WHILE p \<noteq> Null \<and> p \<noteq> Ref X
  INV {p \<noteq> Null \<and> (addr p,X) \<in> {(x,y). tl x = Ref y}^*}
  DO p := p^.tl OD
  {p = Ref X}"
apply vcg_simp
 apply clarsimp
 apply(erule converse_rtranclE)
  apply simp
 apply clarsimp
apply clarsimp
done

subsection "Splicing two lists"

lemma "VARS tl p q pp qq
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {} \<and> size Qs \<le> size Ps}
  pp := p;
  WHILE q \<noteq> Null
  INV {\<exists>as bs qs.
    distinct as \<and> Path tl p as pp \<and> List tl pp bs \<and> List tl q qs \<and>
    set bs \<inter> set qs = {} \<and> set as \<inter> (set bs \<union> set qs) = {} \<and>
    size qs \<le> size bs \<and> splice Ps Qs = as @ splice bs qs}
  DO qq := q^.tl; q^.tl := pp^.tl; pp^.tl := q; pp := q^.tl; q := qq OD
  {List tl p (splice Ps Qs)}"
apply vcg_simp
  apply(rule_tac x = "[]" in exI)
  apply fastforce
 apply clarsimp
 apply(rename_tac y bs qqs)
 apply(case_tac bs) apply simp
 apply clarsimp
 apply(rename_tac x bbs)
 apply(rule_tac x = "as @ [x,y]" in exI)
 apply simp
 apply(rule_tac x = "bbs" in exI)
 apply simp
 apply(rule_tac x = "qqs" in exI)
 apply simp
apply (fastforce simp:List_app)
done

subsection "Merging two lists"

text"This is still a bit rough, especially the proof."

definition cor :: "bool \<Rightarrow> bool \<Rightarrow> bool"
  where "cor P Q \<longleftrightarrow> (if P then True else Q)"

definition cand :: "bool \<Rightarrow> bool \<Rightarrow> bool"
  where "cand P Q \<longleftrightarrow> (if P then Q else False)"

fun merge :: "'a list * 'a list * ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list"
where
  "merge(x#xs,y#ys,f) = (if f x y then x # merge(xs,y#ys,f)
                                  else y # merge(x#xs,ys,f))"
| "merge(x#xs,[],f) = x # merge(xs,[],f)"
| "merge([],y#ys,f) = y # merge([],ys,f)"
| "merge([],[],f) = []"

text{* Simplifies the proof a little: *}

lemma "VARS hd tl p q r s
 {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {} \<and>
  (p \<noteq> Null \<or> q \<noteq> Null)}
 IF cor (q = Null) (cand (p \<noteq> Null) (p^.hd \<le> q^.hd))
 THEN r := p; p := p^.tl ELSE r := q; q := q^.tl FI;
 s := r;
 WHILE p \<noteq> Null \<or> q \<noteq> Null
 INV {EX rs ps qs a. Path tl r rs s \<and> List tl p ps \<and> List tl q qs \<and>
      distinct(a # ps @ qs @ rs) \<and> s = Ref a \<and>
      merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y) =
      rs @ a # merge(ps,qs,\<lambda>x y. hd x \<le> hd y) \<and>
      (tl a = p \<or> tl a = q)}
 DO IF cor (q = Null) (cand (p \<noteq> Null) (p^.hd \<le> q^.hd))
    THEN s^.tl := p; p := p^.tl ELSE s^.tl := q; q := q^.tl FI;
    s := s^.tl
 OD
 {List tl r (merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y))}"
apply vcg_simp
apply (simp_all add: cand_def cor_def)

apply (fastforce)

apply clarsimp
apply(rule conjI)
apply clarsimp
apply(rule conjI)
apply (fastforce intro!:Path_snoc intro:Path_upd[THEN iffD2] notin_List_update[THEN iffD2] simp:eq_sym_conv)
apply clarsimp
apply(rule conjI)
apply (clarsimp)
apply(rule_tac x = "rs @ [a]" in exI)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "bs" in exI)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "ya#bsa" in exI)
apply(simp)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "rs @ [a]" in exI)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "y#bs" in exI)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "bsa" in exI)
apply(simp)
apply (fastforce intro!:Path_snoc intro:Path_upd[THEN iffD2] notin_List_update[THEN iffD2] simp:eq_sym_conv)

apply(clarsimp simp add:List_app)
done

text{* And now with ghost variables: *}

lemma "VARS elem next p q r s ps qs rs a
 {List next p Ps \<and> List next q Qs \<and> set Ps \<inter> set Qs = {} \<and>
  (p \<noteq> Null \<or> q \<noteq> Null) \<and> ps = Ps \<and> qs = Qs}
 IF cor (q = Null) (cand (p \<noteq> Null) (p^.elem \<le> q^.elem))
 THEN r := p; p := p^.next; ps := tl ps
 ELSE r := q; q := q^.next; qs := tl qs FI;
 s := r; rs := []; a := addr s;
 WHILE p \<noteq> Null \<or> q \<noteq> Null
 INV {Path next r rs s \<and> List next p ps \<and> List next q qs \<and>
      distinct(a # ps @ qs @ rs) \<and> s = Ref a \<and>
      merge(Ps,Qs,\<lambda>x y. elem x \<le> elem y) =
      rs @ a # merge(ps,qs,\<lambda>x y. elem x \<le> elem y) \<and>
      (next a = p \<or> next a = q)}
 DO IF cor (q = Null) (cand (p \<noteq> Null) (p^.elem \<le> q^.elem))
    THEN s^.next := p; p := p^.next; ps := tl ps
    ELSE s^.next := q; q := q^.next; qs := tl qs FI;
    rs := rs @ [a]; s := s^.next; a := addr s
 OD
 {List next r (merge(Ps,Qs,\<lambda>x y. elem x \<le> elem y))}"
apply vcg_simp
apply (simp_all add: cand_def cor_def)

apply (fastforce)

apply clarsimp
apply(rule conjI)
apply(clarsimp)
apply(rule conjI)
apply(clarsimp simp:neq_commute)
apply(clarsimp simp:neq_commute)
apply(clarsimp simp:neq_commute)

apply(clarsimp simp add:List_app)
done

text{* The proof is a LOT simpler because it does not need
instantiations anymore, but it is still not quite automatic, probably
because of this wrong orientation business. *}

text{* More of the previous proof without ghost variables can be
automated, but the runtime goes up drastically. In general it is
usually more efficient to give the witness directly than to have it
found by proof.

Now we try a functional version of the abstraction relation @{term
Path}. Since the result is not that convincing, we do not prove any of
the lemmas.*}

axiomatization
  ispath :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" and
  path :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a ref \<Rightarrow> 'a list"

text"First some basic lemmas:"

lemma [simp]: "ispath f p p"
by (rule unproven)
lemma [simp]: "path f p p = []"
by (rule unproven)
lemma [simp]: "ispath f p q \<Longrightarrow> a \<notin> set(path f p q) \<Longrightarrow> ispath (f(a := r)) p q"
by (rule unproven)
lemma [simp]: "ispath f p q \<Longrightarrow> a \<notin> set(path f p q) \<Longrightarrow>
 path (f(a := r)) p q = path f p q"
by (rule unproven)

text"Some more specific lemmas needed by the example:"

lemma [simp]: "ispath (f(a := q)) p (Ref a) \<Longrightarrow> ispath (f(a := q)) p q"
by (rule unproven)
lemma [simp]: "ispath (f(a := q)) p (Ref a) \<Longrightarrow>
 path (f(a := q)) p q = path (f(a := q)) p (Ref a) @ [a]"
by (rule unproven)
lemma [simp]: "ispath f p (Ref a) \<Longrightarrow> f a = Ref b \<Longrightarrow>
 b \<notin> set (path f p (Ref a))"
by (rule unproven)
lemma [simp]: "ispath f p (Ref a) \<Longrightarrow> f a = Null \<Longrightarrow> islist f p"
by (rule unproven)
lemma [simp]: "ispath f p (Ref a) \<Longrightarrow> f a = Null \<Longrightarrow> list f p = path f p (Ref a) @ [a]"
by (rule unproven)

lemma [simp]: "islist f p \<Longrightarrow> distinct (list f p)"
by (rule unproven)

lemma "VARS hd tl p q r s
 {islist tl p & Ps = list tl p \<and> islist tl q & Qs = list tl q \<and>
  set Ps \<inter> set Qs = {} \<and>
  (p \<noteq> Null \<or> q \<noteq> Null)}
 IF cor (q = Null) (cand (p \<noteq> Null) (p^.hd \<le> q^.hd))
 THEN r := p; p := p^.tl ELSE r := q; q := q^.tl FI;
 s := r;
 WHILE p \<noteq> Null \<or> q \<noteq> Null
 INV {EX rs ps qs a. ispath tl r s & rs = path tl r s \<and>
      islist tl p & ps = list tl p \<and> islist tl q & qs = list tl q \<and>
      distinct(a # ps @ qs @ rs) \<and> s = Ref a \<and>
      merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y) =
      rs @ a # merge(ps,qs,\<lambda>x y. hd x \<le> hd y) \<and>
      (tl a = p \<or> tl a = q)}
 DO IF cor (q = Null) (cand (p \<noteq> Null) (p^.hd \<le> q^.hd))
    THEN s^.tl := p; p := p^.tl ELSE s^.tl := q; q := q^.tl FI;
    s := s^.tl
 OD
 {islist tl r & list tl r = (merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y))}"
apply vcg_simp

apply (simp_all add: cand_def cor_def)
  apply (fastforce)
 apply (fastforce simp: eq_sym_conv)
apply(clarsimp)
done

text"The proof is automatic, but requires a numbet of special lemmas."

subsection "Cyclic list reversal"

text{* We consider two algorithms for the reversal of circular lists.
*}

lemma circular_list_rev_I:
  "VARS next root p q tmp
  {root = Ref r \<and> distPath next root (r#Ps) root}
  p := root; q := root^.next;
  WHILE q \<noteq> root
  INV {\<exists> ps qs. distPath next p ps root \<and> distPath next q qs root \<and>
             root = Ref r \<and> r \<notin> set Ps  \<and> set ps \<inter> set qs = {} \<and>
             Ps = (rev ps) @ qs  }
  DO tmp := q; q := q^.next; tmp^.next := p; p:=tmp OD;
  root^.next := p
  { root = Ref r \<and> distPath next root (r#rev Ps) root}"
apply (simp only:distPath_def)
apply vcg_simp
  apply (rule_tac x="[]" in exI)
  apply auto
 apply (drule (2) neq_dP)
 apply clarsimp
 apply(rule_tac x="a # ps" in exI)
apply clarsimp
done

text{* In the beginning, we are able to assert @{term"distPath next
root as root"}, with @{term"as"} set to @{term"[]"} or
@{term"[r,a,b,c]"}. Note that @{term"Path next root as root"} would
additionally give us an infinite number of lists with the recurring
sequence @{term"[r,a,b,c]"}.

The precondition states that there exists a non-empty non-repeating
path \mbox{@{term "r # Ps"}} from pointer @{term root} to itself, given that
@{term root} points to location @{term r}. Pointers @{term p} and
@{term q} are then set to @{term root} and the successor of @{term
root} respectively. If @{term "q = root"}, we have circled the loop,
otherwise we set the @{term next} pointer field of @{term q} to point
to @{term p}, and shift @{term p} and @{term q} one step forward. The
invariant thus states that @{term p} and @{term q} point to two
disjoint lists @{term ps} and @{term qs}, such that @{term"Ps = rev ps
@ qs"}. After the loop terminates, one
extra step is needed to close the loop. As expected, the postcondition
states that the @{term distPath} from @{term root} to itself is now
@{term "r # (rev Ps)"}.

It may come as a surprise to the reader that the simple algorithm for
acyclic list reversal, with modified annotations, works for cyclic
lists as well: *}

lemma circular_list_rev_II:
"VARS next p q tmp
{p = Ref r \<and> distPath next p (r#Ps) p}
q:=Null;
WHILE p \<noteq> Null
INV
{ ((q = Null) \<longrightarrow> (\<exists>ps. distPath next p (ps) (Ref r) \<and> ps = r#Ps)) \<and>
  ((q \<noteq> Null) \<longrightarrow> (\<exists>ps qs. distPath next q (qs) (Ref r) \<and> List next p ps  \<and>
                   set ps \<inter> set qs = {} \<and> rev qs @ ps = Ps@[r])) \<and>
  \<not> (p = Null \<and> q = Null) }
DO tmp := p; p := p^.next; tmp^.next := q; q:=tmp OD
{q = Ref r \<and> distPath next q (r # rev Ps) q}"
apply (simp only:distPath_def)
apply vcg_simp
  apply clarsimp
  apply clarsimp
 apply (case_tac "(q = Null)")
  apply (fastforce intro: Path_is_List)
 apply clarsimp
 apply (rule_tac x= "bs" in exI)
 apply (rule_tac x= "y # qs" in exI)
 apply clarsimp
apply (auto simp:fun_upd_apply)
done

subsection "Storage allocation"

definition new :: "'a set \<Rightarrow> 'a"
  where "new A = (SOME a. a \<notin> A)"

lemma new_notin:
 "\<lbrakk> ~finite(UNIV::'a set); finite(A::'a set); B \<subseteq> A \<rbrakk> \<Longrightarrow> new (A) \<notin> B"
apply(unfold new_def)
apply(rule someI2_ex)
 apply (fast intro:ex_new_if_finite)
apply (fast)
done

lemma "~finite(UNIV::'a set) \<Longrightarrow>
  VARS xs elem next alloc p q
  {Xs = xs \<and> p = (Null::'a ref)}
  WHILE xs \<noteq> []
  INV {islist next p \<and> set(list next p) \<subseteq> set alloc \<and>
       map elem (rev(list next p)) @ xs = Xs}
  DO q := Ref(new(set alloc)); alloc := (addr q)#alloc;
     q^.next := p; q^.elem := hd xs; xs := tl xs; p := q
  OD
  {islist next p \<and> map elem (rev(list next p)) = Xs}"
apply vcg_simp
 apply (clarsimp simp: subset_insert_iff neq_Nil_conv fun_upd_apply new_notin)
apply fastforce
done

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_26
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun half :: "Nat => Nat" where
  "half (Z) = Z"
| "half (S (Z)) = Z"
| "half (S (S z)) = S (half z)"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

theorem property0 :
  "((half (t2 x y)) = (half (t2 y x)))"
  oops

end


theory PreferenceLogicTestsApp1 imports PreferenceLogicBasics (*** Benzmüller & Fuenmayor, 2021 ***)
begin (*****Application-specific tests for the value ontology****)
(* EE variant (\<and>)*)
lemma "\<lfloor>A \<^bold>\<prec>\<^sub>E\<^sub>E (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<^bold>\<prec>\<^sub>E\<^sub>E A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>E\<^sub>E B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>E\<^sub>E (C\<^bold>\<and>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>E\<^sub>E (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>E\<^sub>E B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>E\<^sub>E A)\<rfloor>" by blast
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>E\<^sub>E A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
(* EE variant (\<or>)*)
lemma "\<lfloor>A \<^bold>\<prec>\<^sub>E\<^sub>E (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<^bold>\<prec>\<^sub>E\<^sub>E A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>E\<^sub>E B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>E\<^sub>E (C\<^bold>\<or>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>E\<^sub>E (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>E\<^sub>E B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>E\<^sub>E A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>E\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>E\<^sub>E A)\<rfloor>" by blast
(* AE variant (\<and>)*)
lemma "\<lfloor>A \<^bold>\<prec>\<^sub>A\<^sub>E (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<^bold>\<prec>\<^sub>A\<^sub>E A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>E B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>E (C\<^bold>\<and>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>E (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>E B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>A\<^sub>E A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>A\<^sub>E A)\<rfloor>" by blast
(* AE variant (\<or>)*)
lemma "\<lfloor>A \<^bold>\<prec>\<^sub>A\<^sub>E (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<^bold>\<prec>\<^sub>A\<^sub>E A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>E B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>E (C\<^bold>\<or>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>E (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>E B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>A\<^sub>E A)\<rfloor>" by blast
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>A\<^sub>E A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>A\<^sub>E A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
(* AA variant (\<and>)*)
lemma "\<lfloor>A \<^bold>\<prec>\<^sub>A\<^sub>A (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<^bold>\<prec>\<^sub>A\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>A (C\<^bold>\<and>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>A B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>A\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>A\<^sub>A A)\<rfloor>" by blast
(* AA variant (\<or>)*)
lemma "\<lfloor>A \<^bold>\<prec>\<^sub>A\<^sub>A (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<^bold>\<prec>\<^sub>A\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>A (C\<^bold>\<or>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>A\<^sub>A (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>A\<^sub>A B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>A\<^sub>A A)\<rfloor>" by blast
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>A\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
(* EA variant (\<and>)*)
lemma "\<not>\<lfloor>A \<^bold>\<prec>\<^sub>E\<^sub>A (A\<^bold>\<and>B)\<rfloor>" using rBR by blast
lemma "\<lfloor>(A\<^bold>\<and>B) \<^bold>\<prec>\<^sub>E\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>E\<^sub>A (C\<^bold>\<and>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>E\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>E\<^sub>A B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>E\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<^bold>\<prec>\<^sub>E\<^sub>A A)\<rfloor>" by blast
(* EA variant (\<or>)*)
lemma "\<lfloor>A \<^bold>\<prec>\<^sub>E\<^sub>A (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<not>\<lfloor>(A\<^bold>\<or>B) \<^bold>\<prec>\<^sub>E\<^sub>A A\<rfloor>" using rBR by blast
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>E\<^sub>A (C\<^bold>\<or>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<^bold>\<prec>\<^sub>E\<^sub>A (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<^bold>\<prec>\<^sub>E\<^sub>A B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<^bold>\<prec>\<^sub>E\<^sub>A A)\<rfloor>" by blast
lemma "\<lfloor>(B \<^bold>\<prec>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<^bold>\<prec>\<^sub>E\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
end

(*
(*--------------------------------------------------*)
lemma "\<lfloor>A \<prec>\<^sub>A\<^sub>A (A\<^bold>\<and>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<and>B) \<prec>\<^sub>A\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<prec>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>A (C\<^bold>\<and>B))\<rfloor>" by blast
lemma "\<lfloor>(A \<prec>\<^sub>A\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>A B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>((C\<^bold>\<and>B) \<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<prec>\<^sub>A\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<prec>\<^sub>A\<^sub>A A)\<rfloor>" by blast

(*---------------------------------------------------*)
lemma "\<lfloor>A \<prec>\<^sub>A\<^sub>A (A\<^bold>\<or>B)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A\<^bold>\<or>B) \<prec>\<^sub>A\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<prec>\<^sub>A\<^sub>A B) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>A (C\<^bold>\<or>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<prec>\<^sub>A\<^sub>A (C\<^bold>\<or>B)) \<^bold>\<rightarrow> (A \<prec>\<^sub>A\<^sub>A B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<or>B) \<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> (B \<prec>\<^sub>A\<^sub>A A)\<rfloor>" by blast
lemma "\<lfloor>(B \<prec>\<^sub>A\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<or>B) \<prec>\<^sub>A\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)

(*--------------------------------------------*)
lemma "\<not>\<lfloor>A \<prec>\<^sub>E\<^sub>A (A\<^bold>\<and>B)\<rfloor>" using rBR SBR_def by blast
lemma "\<lfloor>(A\<^bold>\<and>B) \<prec>\<^sub>E\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<prec>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<prec>\<^sub>E\<^sub>A (C\<^bold>\<and>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<prec>\<^sub>E\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<prec>\<^sub>E\<^sub>A B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<and>B) \<prec>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<prec>\<^sub>E\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<prec>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<prec>\<^sub>E\<^sub>A A)\<rfloor>" by blast

(*--------------------------------------------*)
lemma "\<not>\<lfloor>A \<prec>\<^sub>E\<^sub>A (A\<^bold>\<and>B)\<rfloor>" using rBR SBR_def by blast
lemma "\<lfloor>(A\<^bold>\<and>B) \<prec>\<^sub>E\<^sub>A A\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<prec>\<^sub>E\<^sub>A B) \<^bold>\<rightarrow> (A \<prec>\<^sub>E\<^sub>A (C\<^bold>\<and>B))\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(A \<prec>\<^sub>E\<^sub>A (C\<^bold>\<and>B)) \<^bold>\<rightarrow> (A \<prec>\<^sub>E\<^sub>A B)\<rfloor>" by blast
lemma "\<lfloor>((C\<^bold>\<and>B) \<prec>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> (B \<prec>\<^sub>E\<^sub>A A)\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(B \<prec>\<^sub>E\<^sub>A A) \<^bold>\<rightarrow> ((C\<^bold>\<and>B) \<prec>\<^sub>E\<^sub>A A)\<rfloor>" by blast
*)


(*File: VS.thy*)
(*Authors: Lennart Beringer and Martin Hofmann, LMU Munich 2008*)
theory VS imports VDM begin
section\<open>Base-line noninterference\<close>

text\<open>\label{sec:BaseLineNI} We now show how to interprete the type
system of Volpano, Smith and Irvine~\cite{VolpanoSmithIrvine:JCS1996},
as described in Section 3 of our
paper~\cite{BeringerHofmann:CSF2007}.\<close>

subsection\<open>Basic definitions\<close>

text\<open>Muli-level security being treated in Section
\ref{sec:HuntSands}, we restrict our attention in the present section
to the two-point security lattice.\<close>

datatype TP = low | high

text\<open>A global context assigns a security type to each program
variable.\<close>

consts CONTEXT :: "Var \<Rightarrow> TP"

text\<open>Next, we define when two states are considered (low)
equivalent.\<close>

definition twiddle::"State \<Rightarrow> State \<Rightarrow> bool" (" _ \<approx> _ " [100,100] 100)
where "s \<approx> ss = (\<forall> x. CONTEXT x = low \<longrightarrow> s x = ss x)"

text\<open>A command $c$ is \emph{secure} if the low equivalence of any two
initial states entails the equivalence of the corresponding final
states.\<close>

definition secure::"IMP \<Rightarrow> bool"
where "secure c = (\<forall> s t ss tt . s \<approx> t \<longrightarrow> (s,c \<Down> ss) \<longrightarrow>
                          (t,c \<Down> tt) \<longrightarrow> ss \<approx> tt)"

text \<open>Here is the definition of the assertion transformer
that is called $\mathit{Sec}$ in the paper \ldots\<close>

definition Sec :: "((State \<times> State) \<Rightarrow> bool) \<Rightarrow> VDMAssn"
where "Sec \<Phi> s t = ((\<forall> r . s \<approx> r \<longrightarrow> \<Phi>(t, r)) \<and> (\<forall> r . \<Phi>(r ,s) \<longrightarrow> r \<approx> t))"

text\<open>\ldots and the proofs of two directions of its characteristic
property, Proposition 1.\<close>

lemma Prop1A:"\<Turnstile> c : (Sec \<Phi>) \<Longrightarrow> secure c"
(*<*)
by (simp add: VDM_valid_def secure_def Sec_def)
(*>*)

lemma Prop1B:
  "secure c \<Longrightarrow> \<Turnstile> c : Sec (\<lambda> (r, t) . \<exists> s . (s , c \<Down> r) \<and> s \<approx> t)"
(*<*)
apply (simp add: VDM_valid_def Sec_def)
apply clarsimp
apply (unfold secure_def)
apply rule
apply (rule, rule) apply (rule_tac x=s in exI) apply(rule, assumption+)
apply (rule, rule, erule exE, erule conjE) apply fast
done
(*>*)

lemma Prop1BB:"secure c \<Longrightarrow> \<exists> \<Phi> . \<Turnstile> c : Sec \<Phi>"
(*<*)
by (drule Prop1B, fast)
(*>*)

lemma Prop1:
"(secure c) = (\<Turnstile> c : Sec (\<lambda> (r, t) . \<exists> s . (s , c \<Down> r) \<and> s \<approx> t))"
(*<*)
apply rule
apply (erule Prop1B)
apply (erule Prop1A)
done
(*>*)

subsection\<open>Derivation of the LOW rules\<close>

text\<open>We now derive the interpretation of the LOW rules of Volpano et
al's paper according to the constructions given in the paper. (The
rules themselves are given later, since they are not yet needed).\<close>

lemma SKIP: "G \<rhd> Skip : Sec (\<lambda> (s,t) . s \<approx> t)"
(*<*)
apply (rule VDMConseq, rule VDMSkip)
apply (simp add: Sec_def twiddle_def)
done
(*>*)

lemma ASSIGN:
  "(\<forall> s ss. s \<approx> ss \<longrightarrow> evalE e s = evalE e ss) \<Longrightarrow>
   G \<rhd> (Assign x e)
     : (Sec (\<lambda> (s, t) . s \<approx> (update t x (evalE e t))))"
(*<*)
 apply (rule VDMConseq) apply(rule VDMAssign)
  apply clarsimp apply (simp add: Sec_def)
  apply clarsimp
  apply (erule_tac x=s in allE, erule_tac x=r in allE, clarsimp)
  apply (simp add: twiddle_def update_def)
done
(*>*)

lemma COMP:
  "\<lbrakk> G \<rhd> c1 : (Sec \<Phi>); G \<rhd> c2 : (Sec \<Psi>)\<rbrakk> \<Longrightarrow>
     G \<rhd> (Comp c1 c2) : (Sec (\<lambda> (s,t) . \<exists> r . \<Phi>(r, t) \<and>
                           (\<forall> w . (r \<approx> w \<longrightarrow> \<Psi>(s, w)))))"
(*<*)
apply (rule VDMConseq) apply (erule VDMComp) apply assumption
    apply (simp add: Sec_def, clarsimp)
    apply rule
      apply clarsimp apply (erule_tac x=ra in allE, clarsimp)
        apply (rule_tac x=r in exI, clarsimp)
     apply clarsimp
done
(*>*)

lemma IFF:
  "\<lbrakk> (\<forall> s ss. s \<approx> ss \<longrightarrow> evalB b s = evalB b ss);
     G \<rhd> c1 : (Sec \<Phi>); G \<rhd> c2 : (Sec \<Psi>)\<rbrakk> \<Longrightarrow>
     G \<rhd> (Iff b c1 c2) : Sec (\<lambda> (s, t) . (evalB b t \<longrightarrow> \<Phi>(s,t)) \<and>
                                        ((\<not> evalB b t) \<longrightarrow> \<Psi>(s,t)))"
(*<*)
 apply (rule VDMConseq) apply(rule VDMIff) apply assumption+
  apply clarsimp apply (simp add: Sec_def)
  apply clarsimp
  apply (case_tac "evalB b s")
  apply clarsimp
  apply clarsimp
done
(*>*)

text\<open>We introduce an explicit fixed point construction over the type
$TT$ of the invariants $\Phi$.\<close>

type_synonym TT = "(State \<times> State) \<Rightarrow> bool"

text\<open>We deliberately introduce a new type here since the agreement
with \<open>VDMAssn\<close> (modulo currying) is purely coincidental. In
particular, in the generalisation for objects in Section
\ref{sec:Objects} the type of invariants will differ from the
type of program logic assertions.\<close>

definition FIX::"(TT \<Rightarrow> TT) \<Rightarrow> TT"
where "FIX \<phi> = (\<lambda> (s,t). \<forall> \<Phi>. (\<forall> ss tt . \<phi> \<Phi> (ss,tt) \<longrightarrow> \<Phi> (ss,tt))
         \<longrightarrow> \<Phi> (s,t))"

definition Monotone::"(TT \<Rightarrow> TT) \<Rightarrow> bool"
where "Monotone \<phi> = (\<forall> \<Phi> \<Psi> . (\<forall> s t . \<Phi>(s,t) \<longrightarrow> \<Psi>(s,t)) \<longrightarrow>
                        (\<forall> s t . \<phi> \<Phi> (s,t) \<longrightarrow> \<phi> \<Psi> (s,t)))"

(*<*)
lemma Fix2: "\<lbrakk>Monotone \<phi>; \<phi> (FIX \<phi>) (s, t)\<rbrakk> \<Longrightarrow> FIX \<phi> (s,t)"
apply (simp add: FIX_def) apply clarsimp
apply (subgoal_tac "\<phi> \<Phi> (s,t)", simp)
apply (subgoal_tac "\<forall> r u . FIX \<phi> (r,u) \<longrightarrow> \<Phi>(r,u)")
prefer 2 apply (erule thin_rl) apply (simp add: FIX_def) apply clarsimp
  apply (erule_tac x=\<Phi> in allE, simp)
apply (unfold Monotone_def)
  apply (erule_tac x="FIX \<phi>" in allE, erule_tac x="\<Phi>" in allE)
  apply (erule impE) apply assumption
  apply (simp add: FIX_def)
done

lemma Fix1: "\<lbrakk>Monotone \<phi>; FIX \<phi> (s,t)\<rbrakk> \<Longrightarrow> \<phi> (FIX \<phi>) (s,t)"
apply (simp add: FIX_def)
apply (erule_tac x="\<phi>(FIX \<phi>)" in allE)
apply (erule impE)
prefer 2 apply (simp add: FIX_def)
apply (subgoal_tac "\<forall> r u .\<phi>(FIX \<phi>) (r,u) \<longrightarrow> (FIX \<phi>) (r,u)")
  prefer 2 apply clarsimp apply (erule Fix2) apply assumption
apply (unfold Monotone_def)
  apply (erule_tac x="\<phi>(FIX \<phi>)" in allE, erule_tac x="(FIX \<phi>)" in allE, erule impE) apply assumption
apply simp
done
(*>*)

text\<open>For monotone invariant transformers $\varphi$, the construction indeed
yields a fixed point.\<close>

lemma Fix_lemma:"Monotone \<phi> \<Longrightarrow> \<phi> (FIX \<phi>) = FIX \<phi>"
(*<*)
apply (rule ext, rule iffI)
apply clarsimp  apply (erule Fix2) apply assumption
apply clarsimp  apply (erule Fix1) apply assumption
done
(*>*)

text\<open>In order to derive the while rule we define the following
transfomer.\<close>

definition PhiWhileOp::"BExpr \<Rightarrow> TT \<Rightarrow> TT \<Rightarrow> TT"
where "PhiWhileOp b \<Phi> =
     (\<lambda> \<Psi> . (\<lambda>(s, t).
             (evalB b t \<longrightarrow> (\<exists>r. \<Phi> (r, t) \<and>
                                 (\<forall>w. r \<approx> w \<longrightarrow> \<Psi> (s, w)))) \<and>
             (\<not> evalB b t \<longrightarrow> s \<approx> t)))"

text\<open>Since this operator is monotone, \ldots\<close>

lemma PhiWhileOp_Monotone: "Monotone (PhiWhileOp b \<Phi>)"
(*<*)
apply (simp add: PhiWhileOp_def Monotone_def) apply clarsimp
  apply (rule_tac x=r in exI, simp)
done
(*>*)

text\<open>we may define its fixed point,\<close>

definition PhiWhile::"BExpr \<Rightarrow> TT \<Rightarrow> TT"
where "PhiWhile b \<Phi> = FIX (PhiWhileOp b \<Phi>)"

text\<open>which we can use to derive the following rule.\<close>

lemma WHILE:
  "\<lbrakk> (\<forall> s t. s \<approx> t \<longrightarrow> evalB b s = evalB b t); G \<rhd> c : (Sec \<Phi>)\<rbrakk> \<Longrightarrow>
   G \<rhd> (While b c) : (Sec (PhiWhile b \<Phi>))"
(*<*)
apply (rule VDMConseq)
apply (rule VDMWhile)
prefer 4 apply (subgoal_tac "\<forall>s t. (Sec (PhiWhileOp b \<Phi> (PhiWhile b \<Phi>))) s t \<and> \<not> evalB b t \<longrightarrow> Sec (PhiWhile b \<Phi>) s t") apply assumption
  apply clarsimp apply (subgoal_tac "PhiWhileOp b \<Phi> (PhiWhile b \<Phi>)= PhiWhile b \<Phi>", clarsimp)
                 apply (simp add: PhiWhile_def) apply (rule Fix_lemma) apply (rule PhiWhileOp_Monotone)
apply assumption
apply clarsimp apply (simp add: Sec_def)
  apply (rule, clarsimp) apply (simp add: PhiWhileOp_def)
  apply clarsimp apply (simp add: PhiWhileOp_def)
apply clarsimp apply (simp add: Sec_def)
  apply rule
  prefer 2 apply clarsimp
    apply (subgoal_tac "\<exists>r. \<Phi> (r, s) \<and> (\<forall>w. r \<approx> w \<longrightarrow> (PhiWhile b \<Phi>) (ra, w))")
    prefer 2 apply (simp add: PhiWhileOp_def)
    apply clarsimp apply (rotate_tac -3, erule thin_rl)
    apply (rotate_tac -1, erule_tac x=ra in allE, erule mp)
    apply (rotate_tac 1, erule_tac x=r in allE, erule impE) apply fast
    apply (subgoal_tac "PhiWhileOp b \<Phi> (PhiWhile b \<Phi>) = PhiWhile b \<Phi>", clarsimp)
    apply (simp add: PhiWhile_def)
    apply (rule Fix_lemma) apply (rule PhiWhileOp_Monotone)
  apply clarsimp
    apply (simp (no_asm_simp) add: PhiWhileOp_def)
    apply (rule_tac x=r in exI, rule) apply simp
    apply clarsimp
    apply (rotate_tac 5, erule_tac x=w in allE, clarsimp)
    apply (subgoal_tac "PhiWhileOp b \<Phi> (PhiWhile b \<Phi>) = PhiWhile b \<Phi>", clarsimp)
    apply (simp add: PhiWhile_def)
    apply (rule Fix_lemma) apply (rule PhiWhileOp_Monotone)
done
(*>*)

text\<open>The operator that given $\Phi$ returns the invariant
occurring in the conclusion of the rule is itself monotone - this is
the property required for the rule for procedure invocations.\<close>

lemma PhiWhileMonotone: "Monotone (\<lambda> \<Phi> . PhiWhile b \<Phi>)"
(*<*)
apply (simp add: Monotone_def) apply clarsimp
apply (simp add: PhiWhile_def)
apply (simp add: FIX_def) apply clarsimp
apply (erule_tac x=\<Phi>' in allE, erule mp)
apply (clarsimp) apply (erule_tac x=ss in allE, erule_tac x=tt in allE, erule mp)
apply (simp add: PhiWhileOp_def) apply clarsimp
apply (rule_tac x=r in exI, simp)
done
(*>*)

text\<open>We now derive an alternative while rule that employs an
inductive formulation of a variant that replaces the fixed point
construction. This version is given in the paper.\<close>

text\<open>First, the inductive definition of the $\mathit{var}$ relation.\<close>

inductive_set var::"(BExpr \<times> TT \<times> State \<times> State) set"
where
varFalse: "\<lbrakk>\<not> evalB b t; s \<approx> t\<rbrakk> \<Longrightarrow> (b,\<Phi>,s,t):var"
| varTrue:"\<lbrakk>evalB b t; \<Phi>(r,t); \<forall> w . r \<approx> w \<longrightarrow> (b,\<Phi>,s,w): var\<rbrakk>
           \<Longrightarrow> (b,\<Phi>,s,t):var"

text\<open>It is easy to prove the equivalence of $\mathit{var}$ and the
fixed point:\<close>

(*<*)
lemma varFIX: "(b,\<Phi>,s,t):var \<Longrightarrow> PhiWhile b \<Phi> (s,t)"
apply (erule var.induct)
apply (simp add: PhiWhile_def)
  apply (subgoal_tac "PhiWhileOp b \<Phi> (FIX (PhiWhileOp b \<Phi>)) (s,t)")
  apply (subgoal_tac "PhiWhileOp b \<Phi> (FIX (PhiWhileOp b \<Phi>)) = FIX (PhiWhileOp b \<Phi>)", clarsimp)
  apply (rule Fix_lemma) apply (rule PhiWhileOp_Monotone)
  apply (simp add: PhiWhileOp_def)
apply (simp (no_asm_simp) add: PhiWhile_def)
apply (subgoal_tac "PhiWhileOp b \<Phi> (FIX (PhiWhileOp b \<Phi>)) (s,t)")
  apply (subgoal_tac "PhiWhileOp b \<Phi> (FIX (PhiWhileOp b \<Phi>)) = FIX (PhiWhileOp b \<Phi>)", clarsimp)
  apply (rule Fix_lemma) apply (rule PhiWhileOp_Monotone)
  apply (simp add: PhiWhileOp_def)
  apply (rule_tac x=r in exI, simp)
  apply clarsimp
  apply (erule_tac x=w in allE, clarsimp)
  apply (simp add: PhiWhile_def)
  apply (simp add: PhiWhileOp_def)
done

lemma FIXvar: "PhiWhile b \<Phi> (s,t) \<Longrightarrow> (b,\<Phi>,s,t):var"
apply (simp add: PhiWhile_def)
apply (subgoal_tac "PhiWhileOp b \<Phi> (FIX (PhiWhileOp b \<Phi>)) (s, t)")
prefer 2
  apply (subgoal_tac "PhiWhileOp b \<Phi> (FIX (PhiWhileOp b \<Phi>)) = FIX (PhiWhileOp b \<Phi>)", clarsimp)
  apply (rule Fix_lemma) apply (rule PhiWhileOp_Monotone)
apply (erule thin_rl, simp add: PhiWhileOp_def) apply clarsimp
  apply (case_tac "evalB b t")
  prefer 2 apply clarsimp apply (rule varFalse) apply assumption+
  apply clarsimp apply (rule varTrue) apply assumption apply assumption
    apply clarsimp apply (erule_tac x=w in allE, clarsimp)
    apply (unfold FIX_def) apply clarify
    apply (erule_tac x="\<lambda> (x,y) . (b,\<Phi>,x,y):var" in allE, erule impE) prefer 2 apply simp
    apply clarsimp
    apply (case_tac "evalB b tt")
    prefer 2 apply clarsimp apply (rule varFalse) apply assumption+
    apply clarsimp apply (rule varTrue) apply assumption+
done

lemma varFIXvar: "(PhiWhile b \<Phi> (s,t)) = ((b,\<Phi>,s,t):var)"
apply rule
apply (erule FIXvar)
apply (erule varFIX)
done

lemma FIXvarFIX': "(PhiWhile b \<Phi>) = (\<lambda> (s,t) . (b,\<Phi>,s,t):var)"
apply (rule ext, rule iffI)
apply (case_tac x, clarsimp) apply (erule FIXvar)
apply (case_tac x, clarsimp) apply (simp add: varFIXvar)
done
(*>*)

lemma FIXvarFIX: "(PhiWhile b) = (\<lambda> \<Phi> . (\<lambda> (s,t) . (b,\<Phi>,s,t):var))"
(*<*)
by (rule, rule FIXvarFIX')
(*>*)

text\<open>From this rule and the rule WHILE above, one may derive the
while rule we gave in the paper.\<close>

lemma WHILE_IND:
  "\<lbrakk> (\<forall> s t. s \<approx> t \<longrightarrow> evalB b s = evalB b t); G \<rhd> c : (Sec \<Phi>)\<rbrakk> \<Longrightarrow>
   G \<rhd> (While b c) : (Sec (\<lambda> (s,t) . (b,\<Phi>,s,t):var))"
(*<*)
apply (rule VDMConseq)
apply (rule WHILE [of b G c \<Phi>]) apply assumption+
apply (simp add: FIXvarFIX)
done
(*>*)

text\<open>Not suprisingly, the construction $\mathit{var}$ can be shown to
be monotone in $\Phi$.\<close>
(*<*)
lemma varMonotoneAux[rule_format]:
  "(b, \<Phi>, s, t) \<in> var \<Longrightarrow>
   (\<forall>s t. \<Phi> (s, t) \<longrightarrow> \<Psi> (s, t)) \<longrightarrow> (b, \<Psi>, s, t) \<in> var"
apply (erule var.induct)
apply clarsimp apply (erule varFalse, simp)
apply clarsimp apply (erule varTrue) apply fast apply simp
done
(*>*)

lemma var_Monotone: "Monotone (\<lambda> \<Phi> . (\<lambda> (s,t) .(b,\<Phi>,s,t):var))"
(*<*)
apply (simp add: Monotone_def)
apply clarsimp
apply (rule varMonotoneAux) apply assumption apply simp
done
(*>*)

(*<*)
lemma varMonotone_byFIX: "Monotone (\<lambda> \<Phi> . (\<lambda> (s,t) .(b,\<Phi>,s,t):var))"
apply (subgoal_tac "Monotone (\<lambda> \<Phi> . PhiWhile b \<Phi>)")
apply (simp add: FIXvarFIX)
apply (rule PhiWhileMonotone)
done
(*>*)

text\<open>The call rule is formulated for an arbitrary fixed point of
a monotone transformer.\<close>

lemma CALL:
  "\<lbrakk> ({Sec(FIX \<Phi>)} \<union> G) \<rhd> body : Sec(\<Phi> (FIX \<Phi>)); Monotone \<Phi>\<rbrakk> \<Longrightarrow>
   G \<rhd> Call : Sec(FIX \<Phi>)"
(*<*)
apply (rule VDMCall)
apply (subgoal_tac "\<Phi> (FIX \<Phi>) = FIX \<Phi>", clarsimp)
apply (erule Fix_lemma)
done
(*>*)

subsection\<open>Derivation of the HIGH rules\<close>

text\<open>The HIGH rules are easy.\<close>

lemma HIGH_SKIP: "G \<rhd> Skip : twiddle"
(*<*)
apply (rule VDMConseq, rule VDMSkip)
apply (simp add: twiddle_def)
done
(*>*)

lemma HIGH_ASSIGN:
  "CONTEXT x = high \<Longrightarrow> G \<rhd> (Assign x e) : twiddle"
(*<*)
apply (rule VDMConseq, rule VDMAssign)
apply (simp add: update_def twiddle_def)
done
(*>*)

lemma HIGH_COMP:
  "\<lbrakk> G \<rhd> c1 : twiddle; G \<rhd> c2 : twiddle\<rbrakk>
  \<Longrightarrow> G \<rhd> (Comp c1 c2): twiddle"
(*<*)
apply (rule VDMConseq, rule VDMComp) apply assumption+
apply (simp add: twiddle_def)
apply clarsimp
done
(*>*)

lemma HIGH_IFF:
  "\<lbrakk> G \<rhd> c1 : twiddle; G \<rhd> c2 : twiddle \<rbrakk>
  \<Longrightarrow> G \<rhd> (Iff b c1 c2) : twiddle"
(*<*)
apply (rule VDMConseq, rule VDMIff) apply assumption+
apply (simp add: twiddle_def)
done
(*>*)

lemma HIGH_WHILE:
  "\<lbrakk> G \<rhd> c  : twiddle\<rbrakk> \<Longrightarrow> G \<rhd> (While b c)  : twiddle"
(*<*)
apply (rule VDMConseq)
  apply (rule VDMWhile)
  apply (subgoal_tac "G \<rhd> c : (\<lambda>s t. evalB b s \<longrightarrow> s \<approx> t)", erule thin_rl, assumption)
  apply (erule VDMConseq) apply simp
  prefer 3 apply (subgoal_tac "\<forall>s t. s \<approx> t \<and> \<not> evalB b t \<longrightarrow> s \<approx> t", assumption) apply simp
  apply (simp add: twiddle_def)
  apply (simp add: twiddle_def)
done
(*>*)

lemma HIGH_CALL:
  "({twiddle} \<union> G) \<rhd> body : twiddle \<Longrightarrow> G \<rhd> Call : twiddle"
(*<*)
by (erule VDMCall)
(*>*)

subsection\<open>The type system of Volpano, Smith and Irvine\<close>

text\<open>We now give the type system of Volpano et al.~and then prove its
embedding into the system of derived rules. First, type systems for
expressions and boolean expressions.\<close>

inductive_set VS_expr :: "(Expr \<times> TP) set"
where
VS_exprVar: "CONTEXT x = t \<Longrightarrow> (varE x, t) : VS_expr"
| VS_exprVal: "(valE v, low) : VS_expr"
| VS_exprOp: "\<lbrakk>(e1,t) : VS_expr; (e2,t):VS_expr\<rbrakk>
             \<Longrightarrow> (opE f e1 e2,t) : VS_expr"
| VS_exprHigh: "(e, high) : VS_expr"

inductive_set VS_Bexpr :: "(BExpr \<times> TP) set"
where
VS_BexprOp: "\<lbrakk>(e1,t) : VS_expr; (e2,t):VS_expr\<rbrakk>
             \<Longrightarrow> (compB f e1 e2,t) : VS_Bexpr"
| VS_BexprHigh: "(e,high) : VS_Bexpr"

text\<open>Next, the core of the type system, the rules for commands.\<close>

inductive_set VS_com :: "(TP \<times> IMP) set"
where

VS_comSkip: "(pc,Skip) : VS_com"

| VS_comAssHigh:
  "CONTEXT x = high \<Longrightarrow> (pc,Assign x e) : VS_com"

| VS_comAssLow:
  "\<lbrakk>CONTEXT x = low; pc = low; (e,low):VS_expr\<rbrakk> \<Longrightarrow>
   (pc,Assign x e) : VS_com"

| VS_comComp:
  "\<lbrakk> (pc,c1):VS_com; (pc,c2):VS_com\<rbrakk> \<Longrightarrow>
   (pc,Comp c1 c2) : VS_com"

| VS_comIf:
  "\<lbrakk> (b,pc):VS_Bexpr; (pc,c1):VS_com; (pc,c2):VS_com\<rbrakk> \<Longrightarrow>
   (pc,Iff b c1 c2):VS_com"

| VS_comWhile:
  "\<lbrakk>(b,pc):VS_Bexpr; (pc,c):VS_com\<rbrakk> \<Longrightarrow> (pc,While b c):VS_com"

| VS_comSub: "(high,c) : VS_com \<Longrightarrow> (low,c):VS_com"

text\<open>We define the interpretation of expression typings\ldots\<close>

primrec SemExpr::"Expr \<Rightarrow> TP \<Rightarrow> bool"
where
"SemExpr e low = (\<forall> s ss. s \<approx> ss \<longrightarrow> evalE e s = evalE e ss)" |
"SemExpr e high = True"

text\<open>\ldots and show the soundness of the typing rules.\<close>

lemma ExprSound: "(e,tp):VS_expr \<Longrightarrow> SemExpr e tp"
(*<*)
apply (erule VS_expr.induct)
apply (case_tac t,simp_all)
  apply (simp add: twiddle_def)
apply (case_tac t, simp_all)
done
(*>*)

text\<open>Likewise for the boolean expressions.\<close>

primrec SemBExpr::"BExpr \<Rightarrow> TP \<Rightarrow> bool"
where
"SemBExpr b low = (\<forall> s ss. s \<approx> ss \<longrightarrow> evalB b s = evalB b ss)" |
"SemBExpr b high = True"

lemma BExprSound: "(e,tp):VS_Bexpr \<Longrightarrow> SemBExpr e tp"
(*<*)
apply (erule VS_Bexpr.induct, simp_all)
apply (drule ExprSound)
apply (drule ExprSound)
apply (case_tac t, simp_all)
done
(*>*)

text\<open>The proof of the main theorem (called Theorem 2 in our paper)
proceeds by induction on $(t,c):VS\_com$.\<close>

theorem VS_com_VDM[rule_format]:
"(t,c):VS_com \<Longrightarrow> (t=high \<longrightarrow> G \<rhd> c : twiddle) \<and>
                  (t=low \<longrightarrow> (\<exists> A . G \<rhd> c : Sec A))"
(*<*)
apply (erule VS_com.induct)
apply rule
  apply clarsimp
  apply (rule HIGH_SKIP)
  apply clarsimp
  apply (rule, rule SKIP)
apply rule
  apply clarsimp
  apply (erule HIGH_ASSIGN)
  apply clarsimp
  apply (subgoal_tac "\<exists> t. (e,t):VS_expr", clarsimp) prefer 2 apply (rule, rule VS_exprHigh)
  apply (drule ExprSound)
  apply (case_tac t)
    apply clarsimp apply (rule, erule ASSIGN)
    apply clarsimp apply (rule_tac x="\<lambda> (s,t).  s \<approx> t" in exI, rule VDMConseq)
         apply (erule HIGH_ASSIGN) apply (simp add: Sec_def twiddle_def)
apply rule
  apply clarsimp
  apply (drule ExprSound)
    apply clarsimp apply (rule, erule ASSIGN)
apply rule
  apply clarsimp
  apply (rule HIGH_COMP) apply (assumption, assumption)
  apply clarsimp
  apply (rule, rule COMP) apply (assumption, assumption)
apply rule
  apply clarsimp
  apply (rule HIGH_IFF) apply (assumption, assumption)
  apply clarsimp
  apply (drule BExprSound)
  apply clarsimp
  apply (rule, erule IFF)  apply (assumption, assumption)
apply rule
  apply clarsimp
  apply (erule HIGH_WHILE)
  apply clarsimp
  apply (drule BExprSound)
  apply clarsimp
  apply (rule, erule WHILE) apply assumption
apply clarsimp
  apply (rule, erule CAST)
done
(*>*)

text\<open>The semantic of typing judgements for commands is now the
expected one: HIGH commands require initial and final state be low
equivalent (i.e.~the low variables in the final state can't depend on
the high variables of the initial state), while LOW commands must
respect the above mentioned security property.\<close>

primrec SemCom::"TP \<Rightarrow> IMP \<Rightarrow> bool"
where
"SemCom low c = (\<forall> s ss t tt. s \<approx> ss \<longrightarrow> (s,c \<Down> t) \<longrightarrow>
                               (ss,c \<Down> tt) \<longrightarrow> t \<approx> tt)" |
"SemCom high c = (\<forall> s t . (s,c \<Down> t) \<longrightarrow> s \<approx> t)"

text\<open>Combining theorem \<open>VS_com_VDM\<close> with the soundness result
of the program logic and the definition of validity yields the
soundness of Volpano et al.'s type system.\<close>

theorem VS_SOUND: "(t,c):VS_com \<Longrightarrow> SemCom t c"
(*<*)
apply (subgoal_tac "(t=high \<longrightarrow> {} \<rhd> c : twiddle) \<and> (t=low \<longrightarrow> (\<exists> A . {} \<rhd> c : Sec A))")
prefer 2 apply (erule VS_com_VDM)
apply (case_tac t)
apply clarsimp apply (drule VDM_Sound) apply (simp add: valid_def VDM_valid_def Ctxt_valid_def Sec_def)
apply clarsimp apply (drule VDM_Sound) apply (simp add: valid_def VDM_valid_def Ctxt_valid_def)
done
(*>*)

text\<open>As a further minor result, we prove that all judgements
interpreting the low rules indeed yield assertions $A$ of the form $A
= Sec(\Phi(FIX \Phi))$ for some monotone $\Phi$.\<close>

inductive_set Deriv ::"(VDMAssn set \<times> IMP \<times> VDMAssn) set"
where
D_CAST:
  "(G,c,twiddle):Deriv \<Longrightarrow> (G, c, Sec (\<lambda> (s,t) . s \<approx> t)) : Deriv"

| D_SKIP: "(G, Skip, Sec (\<lambda> (s,t) . s \<approx> t)) : Deriv"

| D_ASSIGN:
  "(\<forall> s ss. s \<approx> ss \<longrightarrow> evalE e s = evalE e ss) \<Longrightarrow>
   (G, Assign x e, Sec (\<lambda> (s, t) . s \<approx> (update t x (evalE e t)))):Deriv"

| D_COMP:
  "\<lbrakk> (G, c1, Sec \<Phi>):Deriv; (G, c2, Sec \<Psi>):Deriv\<rbrakk> \<Longrightarrow>
   (G, Comp c1 c2, Sec (\<lambda> (s,t) . \<exists> r . \<Phi>(r, t) \<and>
                           (\<forall> w . (r \<approx> w \<longrightarrow> \<Psi>(s, w))))):Deriv"

| C_IFF:
  "\<lbrakk> (\<forall> s ss. s \<approx> ss \<longrightarrow> evalB b s = evalB b ss);
     (G, c1, Sec \<Phi>):Deriv; (G,c2, Sec \<Psi>):Deriv\<rbrakk> \<Longrightarrow>
   (G, Iff b c1 c2, Sec (\<lambda> (s, t) . (evalB b t \<longrightarrow> \<Phi>(s,t)) \<and>
                                            ((\<not> evalB b t) \<longrightarrow> \<Psi>(s,t)))):Deriv"

| D_WHILE:
  "\<lbrakk> (\<forall> s ss. s \<approx> ss \<longrightarrow> evalB b s = evalB b ss);
     (G, c, Sec \<Phi>):Deriv\<rbrakk> \<Longrightarrow>
   (G, While b c, Sec (PhiWhile b \<Phi>)):Deriv"

| D_CALL:
  "\<lbrakk> ({Sec(FIX \<Phi>)} \<union> G, body, Sec(\<Phi>(FIX \<Phi>))):Deriv;
      Monotone \<Phi>\<rbrakk> \<Longrightarrow>
   (G, Call, Sec(FIX \<Phi>)):Deriv"

| D_HighSKIP:"(G, Skip, twiddle):Deriv"

| D_HighASSIGN:
  "CONTEXT x = high \<Longrightarrow> (G,Assign x e, twiddle):Deriv"

| D_HighCOMP:
  "\<lbrakk> (G,c1,twiddle):Deriv; (G,c2,twiddle):Deriv\<rbrakk> \<Longrightarrow>
   (G, Comp c1 c2, twiddle):Deriv"

| D_HighIFF:
  "\<lbrakk> (G,c1,twiddle):Deriv; (G,c2,twiddle):Deriv\<rbrakk> \<Longrightarrow>
   (G, Iff b c1 c2, twiddle):Deriv"

| D_HighWHILE:
  "(G, c, twiddle):Deriv \<Longrightarrow> (G, While b c, twiddle):Deriv"

| D_HighCALL:
  "({twiddle} \<union> G, body, twiddle):Deriv \<Longrightarrow> (G, Call, twiddle):Deriv"

(*<*)
definition DProp :: "VDMAssn \<Rightarrow> bool"
where "DProp A = (\<exists> \<phi> . A =  Sec (\<phi> (FIX \<phi>)) \<and> Monotone \<phi>)"

lemma DerivProp_Aux: "(X,c,A):Deriv \<Longrightarrow> DProp A"
apply (erule Deriv.induct)
apply (simp_all add: DProp_def)
  apply clarsimp
  apply (rule, rule) apply simp apply (simp add: Monotone_def)
  apply clarsimp?
  apply (rule, rule) apply simp apply (simp add: Monotone_def)
  apply clarsimp?
  apply (rule, rule) apply simp apply (simp add: Monotone_def)
  apply clarsimp?
  apply (rule, rule) apply simp apply (simp add: Monotone_def)
  apply clarsimp?
  apply (rule, rule) apply simp apply (simp add: Monotone_def)
  apply clarsimp?
  apply (rule, rule) apply simp apply (simp add: Monotone_def)
  apply clarsimp ?
  apply (rule, rule) apply simp apply (simp add: Monotone_def)
  apply clarsimp?
    apply (rule_tac x="\<lambda> \<Phi>. \<lambda> (s,t) . s \<approx> t" in exI)
    apply (subgoal_tac "Monotone (\<lambda> \<Phi>. \<lambda> (s,t) . s \<approx> t)", simp)
      apply (drule Fix_lemma) apply (erule thin_rl)
      apply (rule ext, rule ext, rule iffI)
      apply (simp add: twiddle_def Sec_def)
      apply (simp add: Sec_def) apply (simp only: twiddle_def) apply fast
    apply (simp add: Monotone_def)
  apply clarsimp?
    apply (rule_tac x="\<lambda> \<Phi>. \<lambda> (s,t) . s \<approx> t" in exI)
    apply (subgoal_tac "Monotone (\<lambda> \<Phi>. \<lambda> (s,t) . s \<approx> t)", simp)
      apply (drule Fix_lemma) apply (erule thin_rl)
      apply (rule ext, rule ext, rule iffI)
      apply (simp add: twiddle_def Sec_def)
      apply (simp add: Sec_def) apply (simp only: twiddle_def) apply fast
    apply (simp add: Monotone_def)
done
(*>*)

lemma DerivMono:
 "(X,c,A):Deriv \<Longrightarrow> \<exists> \<Phi> . A =  Sec (\<Phi> (FIX \<Phi>)) \<and> Monotone \<Phi>"
(*<*)
by (drule DerivProp_Aux, simp add: DProp_def)
(*>*)

text\<open>Also, all rules in the \<open>Deriv\<close> relation are indeed
derivable in the program logic.\<close>

lemma Deriv_derivable: "(G,c,A):Deriv \<Longrightarrow> G \<rhd> c: A"
(*<*)
apply (erule Deriv.induct)
apply (erule CAST)
apply (rule SKIP)
apply (erule ASSIGN)
apply (erule COMP) apply assumption
apply (erule IFF) apply assumption apply assumption
apply (erule WHILE) apply assumption
apply (erule CALL) apply assumption
apply (rule HIGH_SKIP)
apply (erule HIGH_ASSIGN)
apply (erule HIGH_COMP) apply assumption
apply (erule HIGH_IFF) apply assumption
apply (erule HIGH_WHILE)
apply (erule HIGH_CALL)
done
(*>*)
text\<open>End of theory VS\<close>
end