theory Interval_Newton_Method
  imports Interval_Help Complex_Main "HOL-Decision_Procs.Approximation" "HOL-Library.Monad_Syntax"
          "HOL-Analysis.Derivative"

begin

section "Preparation of the Proof"

subsection "Lemmas on Derivatives"

lemma mvt_very_simple':
  fixes f :: "real \<Rightarrow> real"
  assumes "l \<le> u"
    and derf: "\<And>x. \<lbrakk>l \<le> x; x \<le> u\<rbrakk> \<Longrightarrow> (f has_field_derivative f' x) (at x within {l..u})"
  shows "\<exists>s \<in> {l..u}. f u - f l = f' s * (u - l)"
  using mvt_very_simple[of l u f "\<lambda>x y. f' x * y"] assms
  by (auto simp: has_field_derivative_def)

lemma deriv_is_zero:
  fixes f :: "real \<Rightarrow> real"
  assumes "l \<le> u"
    and derf: "\<And>x. \<lbrakk>l \<le> x; x \<le> u\<rbrakk> \<Longrightarrow> (f has_field_derivative (\<lambda>x. 0) x) (at x within {l..u})"
  shows "\<forall>x \<in> {l..u}. \<forall>x' \<in> {l..u}. f x = f x'"
  by (metis atLeastAtMost_iff convex_real_interval(5) derf has_field_derivative_zero_constant)

subsection "f(m) is a Value"

locale newton_step_locale =
  fixes f f' :: "real \<Rightarrow> real"
  fixes X F' :: "real interval"
  fixes m :: real
  assumes f': "x \<in> set_of X \<Longrightarrow> (f has_field_derivative f' x)(at x within set_of X)"
  assumes f'_enclosure: "x \<in> set_of X \<Longrightarrow> f' x \<in> set_of F'"
  assumes m: "m \<in> set_of X"

begin

lemma transfer_field_derivative:
  assumes "c \<in> set_of X" "d \<in> set_of X" "x \<in> {c..d}"
  shows "(f has_field_derivative f' x)(at x within {c..d})"
proof -
  have subset: "{c..d} \<subseteq> set_of X" using assms(1-2) by (simp add: set_of_eq)
  have "x \<in> set_of X" by (meson assms(1-3) atLeastAtMost_iff connectedD_interval connected_set_of)
  then have "(f has_field_derivative f' x)(at x within set_of X)" using f' by simp
  then show ?thesis using subset has_field_derivative_subset by blast
qed

lemma transfer_mvt: "c \<in> set_of X \<and> d \<in> set_of X \<and> c < d \<Longrightarrow> \<exists>s \<in> {c..d}. f d - f c = f' s * (d - c)"
  using transfer_field_derivative mvt_very_simple' by auto

lemma transfer_enclosure: "c \<in> set_of X \<and> d \<in> set_of X \<Longrightarrow> x \<in> {c..d} \<Longrightarrow> f' x \<in> set_of F'"
  using f'_enclosure by (auto simp add: set_of_eq)

lemma f_transformed:
  assumes "x \<in> set_of X" "y \<in> set_of X" "x < y"
  shows "\<exists>s \<in> {x..y}. f x = f y + f' s * (x - y)"
  using assms by (smt (verit) assms right_diff_distrib' transfer_mvt)

lemma unequal_values:
  assumes "x \<in> set_of X" "y \<in> set_of X" "x < y" "0 \<notin> set_of F'"
  shows "f x \<noteq> f y"
proof -
  obtain s where s: "s \<in> {x..y} \<and> f y - f x = f' s * (y - x)" using transfer_mvt assms(1-3) by blast
  have "f' s \<noteq> 0" using assms transfer_enclosure s by metis
  then show ?thesis using assms(3) s by auto
qed

lemma f_transformed_with_unequal_values:
  assumes "x \<in> set_of X" "f x = 0" "y \<in> set_of X" "x < y" "f x \<noteq> f y"
  shows "\<exists>s \<in> {x..y}. x = y - f y / f' s"
proof -
  obtain s where s: "s \<in> {x..y} \<and> f x = f y + f' s * (x - y)" and f's_nz: "f' s \<noteq> 0"
    by (metis add.commute add.left_neutral assms f_transformed mult_zero_left)
  then have "f x = f y + f' s * (x - y)" by auto
  then have "f y + f' s * (x - y) = 0" using assms by auto
  then have "f y / f' s + (x - y) = 0"
    using f's_nz by (simp add: add.commute add_num_frac mult.commute)
  then have "x = y - f y / f' s" by auto
  then show ?thesis using s by blast
qed

lemma f_transformed_with_unequal_values':
  assumes "x \<in> set_of X" "f x = 0" "y \<in> set_of X" "y < x" "f x \<noteq> f y"
  shows "\<exists>s \<in> {y..x}. x = y - f y / f' s"
proof -
  obtain s where s: "s \<in> {y..x} \<and> f x = f y + f' s * (x - y)" and f's_nz: "f' s \<noteq> 0"
    using assms(1,3-5) transfer_mvt by force
  then have "f x = f y + f' s * (x - y)" by auto
  then have "f y + f' s * (x - y) = 0" using assms by auto
  then have "f y / f' s + (x - y) = 0"
    using f's_nz by (simp add: add.commute add_num_frac mult.commute)
  then have "x = y - f y / f' s" by auto
  then show ?thesis using s by blast
qed

lemma enclosure_not_zero:
  assumes "x \<in> set_of X" "f x = 0" "0 \<notin> set_of F'"
  shows "x \<in> set_of (interval_of m - interval_of (f m) * inverse_interval' F')"
proof -
  have "x < m \<or> x = m \<or> x > m" by auto
  then show ?thesis
  proof (elim disjE)
    assume "x < m"
    then obtain s where s: "s \<in> {x..m} \<and> x = m - f m / f' s"
      using f_transformed_with_unequal_values unequal_values assms m by blast
    then have "f' s \<in> set_of F'" using assms(1) m transfer_enclosure by auto
    then have "inverse (f' s) \<in> set_of (inverse_interval' F')"
      by (simp add: assms(3) inverse_in_inverse_interval')
    then have "m - f m / f' s \<in> set_of (interval_of m - interval_of (f m ) * inverse_interval' F')"
      by (simp add: times_in_intervalI field_class.field_divide_inverse minus_in_intervalI
          in_interval_to_interval)
    then show ?thesis by (simp add: s)
  next
    assume "x = m"
    then show ?thesis
      using assms(2) minus_in_intervalI set_of_mul_contains_zero by force
  next
    assume "x > m"
    then obtain s where s: "s \<in> {m..x} \<and> x = m - f m / f' s"
      using f_transformed_with_unequal_values' unequal_values assms m by metis
    then have "f' s \<in> set_of F'" using assms(1) m transfer_enclosure by auto
    then have "inverse (f' s) \<in> set_of (inverse_interval' F')"
      by (simp add: assms(3) inverse_in_inverse_interval')
    then have "m - f m / f' s \<in> set_of (interval_of m - interval_of (f m) * inverse_interval' F')"
      by (simp add: times_in_intervalI field_class.field_divide_inverse minus_in_intervalI
          in_interval_to_interval)
    then show ?thesis by (simp add: s)
  qed
qed

lemma enclosure_with_upper_zero: (* x \<in> (-\<infinity>, m - f m / \<down>F'] *)
  assumes "x \<in> set_of X" "f x = 0" "lower F' < 0 \<and> upper F' = 0" "f m < 0"
  shows "x \<le> m - f m / lower F'"
proof -
  have "x < m \<or> x = m \<or> x > m" by auto
  then show ?thesis
  proof (elim disjE)
    assume l: "x < m"
    then obtain s where s: "s \<in> {x..m}" "x = m - f m / f' s"
      by (metis assms(1,2,4) f_transformed_with_unequal_values m mult_eq_0_iff not_real_square_gt_zero)
    then show ?thesis using set_of_eq
      by (smt (z3) assms(1,4) atLeastAtMost_iff divide_left_mono_neg l m mult_neg_neg
          transfer_enclosure zero_less_divide_iff)
  next
    assume "x = m"
    then show ?thesis using assms(2) by auto
  next
    assume g: "x > m"
    then obtain s where s: "s \<in> {m..x} \<and> x = m - f m / f' s"
      using assms(1,2,4) f_transformed_with_unequal_values' m by fastforce
    then show ?thesis using set_of_eq
      by (smt assms(1,3,4) atLeastAtMost_iff divide_nonpos_nonpos g m transfer_enclosure)
  qed
qed

lemma enclosure_with_upper_zero': (* x \<in> [m - f m / \<down>F', \<infinity>) *)
  assumes "x \<in> set_of X" "f x = 0" "lower F' < 0 \<and> upper F' = 0" "f m > 0"
  shows "x \<ge> m - f m / lower F'"
proof -
  have "x < m \<or> x = m \<or> x > m" by auto
  then show ?thesis
  proof (elim disjE)
    assume l: "x < m"
    then obtain s where s: "s \<in> {x..m} \<and> x = m - f m / f' s"
      using assms(1,2,4) f_transformed_with_unequal_values m by fastforce
    then show ?thesis using set_of_eq
      by (smt assms(1,3,4) atLeastAtMost_iff divide_nonneg_nonpos l m transfer_enclosure)
  next
    assume "x = m"
    then show ?thesis using assms(2) by auto
  next
    assume g: "x > m"
    then obtain s where s: "s \<in> {m..x}" "x = m - f m / f' s"
      by (metis assms(1,2,4) f_transformed_with_unequal_values' m powr_eq_0_iff powr_gt_zero)
    then show ?thesis using set_of_eq
      by (smt (z3) assms(1,3) atLeastAtMost_iff divide_left_mono divide_less_0_iff g m
          mult_neg_neg transfer_enclosure)
  qed
qed

lemma enclosure_with_inside_zero: (* x \<in> (-\<infinity>, m - f m / \<down>F'] \<union> [m - f m / \<up>F', \<infinity>) *)
  assumes "x \<in> set_of X" "f x = 0" "lower F' < 0 \<and> 0 < upper F'" "f m < 0"
  shows "x \<le> m - f m / lower F' \<or> x \<ge> m - f m / upper F'"
proof -
  have "x < m \<or> x = m \<or> x > m" by auto
  then show ?thesis
  proof (elim disjE)
    assume l: "x < m"
    then obtain s where s: "s \<in> {x..m}" "x = m - f m / f' s"
      by (metis assms(1,2,4) f_transformed_with_unequal_values m powr_eq_0_iff powr_gt_zero)
    have "f' s < 0" using assms(4) divide_nonpos_nonneg[of "f m" "f' s"] l s(2)
      by (smt divide_nonneg_nonneg)
    then have "x \<le> m - f m / lower F' \<or> x \<ge> m - f m / upper F'"
      using assms s transfer_enclosure[where x = s, of x m] m
      by (smt (z3) atLeastAtMost_iff divide_left_mono_neg mult_neg_neg set_of_eq)
    with s(2) show ?thesis by simp
  next
    assume "x = m"
    then show ?thesis using assms(2) by auto
  next
    assume g: "x > m"
    then obtain s where s: "s \<in> {m..x} \<and> x = m - f m / f' s"
      using assms(1,2,4) f_transformed_with_unequal_values' m by fastforce
    then show ?thesis using set_of_eq
      by (smt assms(1,4) atLeastAtMost_iff diff_divide_distrib divide_right_mono_neg frac_less2 g m
          transfer_enclosure)
  qed
qed

lemma enclosure_with_inside_zero': (* x \<in> (-\<infinity>, m - f m / \<up>F'] \<union> [m - f m / \<down>F', \<infinity>) *)
  assumes "x \<in> set_of X" "f x = 0" "lower F' < 0 \<and> 0 < upper F'" "f m > 0"
  shows "x \<le> m - f m / upper F' \<or> x \<ge> m - f m / lower F'"
proof -
  have "x < m \<or> x = m \<or> x > m" by auto
  then show ?thesis
  proof (elim disjE)
    assume l: "x < m"
    then obtain s where s: "s \<in> {x..m} \<and> x = m - f m / f' s"
      using assms(1,2,4) f_transformed_with_unequal_values m by fastforce
    then show ?thesis using set_of_eq
      by (smt assms(1,4) atLeastAtMost_iff diff_divide_distrib divide_right_mono_neg frac_less2 l m
          transfer_enclosure)
  next
    assume "x = m"
    then show ?thesis using assms(2) by auto
  next
    assume g: "x > m"
    then obtain s where s: "s \<in> {m..x}" "x = m - f m / f' s"
      by (metis assms(1,2,4) f_transformed_with_unequal_values' m powr_eq_0_iff powr_gt_zero)
    have "f' s < 0" using assms(4) divide_nonpos_nonneg[of "f m" "f' s"] g s(2)
      by (smt divide_nonneg_nonneg)
    then have "x \<le> m - f m / upper F' \<or> x \<ge> m - f m / lower F'"
      using assms s transfer_enclosure[where x = s, of x m] m
      by (smt (z3) atLeastAtMost_iff divide_left_mono mult_neg_neg set_of_eq transfer_enclosure)
    with s(2) show ?thesis by simp
  qed
qed

lemma enclosure_with_lower_zero: (* x \<in> [m - f m / \<up>F', \<infinity>) *)
  assumes "x \<in> set_of X" "f x = 0" "lower F' = 0 \<and> 0 < upper F'" "f m < 0"
  shows "x \<ge> m - f m / upper F'"
proof -
  have "x < m \<or> x = m \<or> x > m" by auto
  then show ?thesis
  proof (elim disjE)
    assume l: "x < m"
    then obtain s where s: "s \<in> {x..m} \<and> x = m - f m / f' s"
      using assms(1,2,4) f_transformed_with_unequal_values m by fastforce
    then show ?thesis using set_of_eq
      by (smt assms(1,3,4) atLeastAtMost_iff divide_nonpos_nonneg l m transfer_enclosure)
  next
    assume "x = m"
    then show ?thesis using assms(2) by auto
  next
    assume g: "x > m"
    then obtain s where s: "s \<in> {m..x} \<and> x = m - f m / f' s"
      using assms(1,2,4) f_transformed_with_unequal_values' m by fastforce
    then show ?thesis using set_of_eq
      by (smt (z3) assms(1,3) atLeastAtMost_iff divide_left_mono_neg divide_less_0_iff g m
          mult_pos_pos transfer_enclosure)
  qed
qed

lemma enclosure_with_lower_zero': (* x \<in> (-\<infinity>, m - f m / \<up>F'] *)
  assumes "x \<in> set_of X" "f x = 0" "lower F' = 0 \<and> 0 < upper F'" "f m > 0"
  shows "x \<le> m - f m / upper F'"
proof -
  have "x < m \<or> x = m \<or> x > m" by auto
  then show ?thesis
  proof (elim disjE)
    assume l: "x < m"
    then obtain s where s: "s \<in> {x..m} \<and> x = m - f m / f' s"
      using assms(1,2,4) f_transformed_with_unequal_values m by fastforce
    then show ?thesis using set_of_eq
      by (smt assms(1,4) atLeastAtMost_iff divide_nonneg_nonpos frac_le l m transfer_enclosure)
  next
    assume "x = m"
    then show ?thesis using assms(2) by auto
  next
    assume g: "x > m"
    then obtain s where s: "s \<in> {m..x} \<and> x = m - f m / f' s"
      using assms(1,2,4) f_transformed_with_unequal_values' m by fastforce
    then show ?thesis using set_of_eq
      by (smt assms(1,3,4) atLeastAtMost_iff divide_nonneg_nonneg g m transfer_enclosure)
  qed
qed

end

subsection "f(m) is an Interval"

locale newton_step_locale' = newton_step_locale +
  fixes F :: "real interval"
  assumes f_enclosure: "f m \<in> set_of F"

begin

lemma f'enclosure_not_zero:
  assumes "x \<in> set_of X" "f x = 0" "0 \<notin> set_of F'"
  shows "x \<in> set_of (interval_of m - F * inverse_interval' F')"
proof -
  have subset: "set_of (interval_of m - interval_of (f m) * inverse_interval' F')
                \<subseteq> set_of (interval_of m - F * inverse_interval' F')"
  proof -
    have "set_of (interval_of (f m)) \<subseteq> set_of F" using f_enclosure by (auto simp: set_of_eq)
    then show ?thesis by (simp add: set_of_mul_inc_left set_of_sub_inc_right)
  qed
  have "x \<in> set_of (interval_of m - interval_of (f m) * inverse_interval' F')"
    using assms(1-3) enclosure_not_zero m by auto
  then show ?thesis using subset by auto
qed

lemma f'enclosure_with_upper_zero: (* x \<in> (-\<infinity>, m - \<up>F / \<down>F'] *)
  assumes "x \<in> set_of X" "f x = 0" "lower F' < 0 \<and> upper F' = 0" "upper F < 0"
  shows "x \<le> m - upper F / lower F'"
proof -
  have x: "x \<le> m - f m / lower F'"
    using assms enclosure_with_upper_zero f_enclosure sign_of_element by auto
  have "m - f m / lower F' \<le> m - upper F / lower F'"
    by (metis assms(3) atLeastAtMost_iff diff_left_mono divide_right_mono_neg f_enclosure
        lower_le_upper set_of_eq)
  then show ?thesis using x by simp
qed

lemma f'enclosure_with_upper_zero': (* x \<in> [m - \<down>F / \<up>F, \<infinity>) *)
  assumes "x \<in> set_of X" "f x = 0" "lower F' < 0 \<and> upper F' = 0" "0 < lower F"
  shows "x \<ge> m - lower F / lower F'"
proof -
  have x: "x \<ge> m - f m / lower F'"
    using assms enclosure_with_upper_zero' f_enclosure sign_of_element' by auto
  have "m - f m / lower F' \<ge> m - lower F / lower F'"
    by (metis assms(3) atLeastAtMost_iff diff_left_mono divide_right_mono_neg f_enclosure
        lower_le_upper set_of_eq)
  then show ?thesis using x by simp
qed

lemma f'enclosure_with_inside_zero: (* x \<in> (-\<infinity>, m - \<up>F / \<down>F'] \<union> [m - \<up>F / \<up>F', \<infinity>) *)
  assumes "x \<in> set_of X" "f x = 0" "lower F' < 0 \<and> 0 < upper F'" "upper F < 0"
  shows "x \<le> m - upper F / lower F' \<or> x \<ge> m - upper F / upper F'"
proof -
  have x: "x \<le> m - f m / lower F' \<or> x \<ge> m - f m / upper F'"
    using assms f_enclosure enclosure_with_inside_zero newton_step_locale_axioms sign_of_element by blast
  have "m - f m / lower F' \<le> m - upper F / lower F' \<and> m - f m / upper F' \<ge> m - upper F / upper F'"
    by (metis assms(3) atLeastAtMost_iff diff_left_mono divide_right_mono divide_right_mono_neg
        f_enclosure le_less set_of_eq)
  then show ?thesis using x by auto
qed

lemma f'enclosure_with_inside_zero': (* x \<in> (-\<infinity>, m - \<down>F / \<up>F'] \<union> [m - \<down>F / \<down>F', \<infinity>) *)
  assumes "x \<in> set_of X" "f x = 0" "lower F' < 0 \<and> 0 < upper F'" "0 < lower F"
  shows "x \<le> m - lower F / upper F' \<or> x \<ge> m - lower F / lower F'"
proof -
  have x: "x \<le> m - f m / upper F' \<or> x \<ge> m - f m / lower F'"
    using assms f_enclosure enclosure_with_inside_zero' newton_step_locale_axioms sign_of_element' by blast
  have "m - f m / lower F' \<ge> m - lower F / lower F' \<and> m - f m / upper F' \<le> m - lower F / upper F'"
    by (metis assms(3) atLeastAtMost_iff diff_left_mono divide_right_mono divide_right_mono_neg
        f_enclosure le_less set_of_eq)
  then show ?thesis using x by auto
qed

lemma f'enclosure_with_lower_zero: (* x \<in> m - fm / F' = [m - \<up>F / \<up>F', \<infinity>) *)
  assumes "x \<in> set_of X" "f x = 0" "lower F' = 0 \<and> 0 < upper F'" "upper F < 0"
  shows "x \<ge> m - upper F / upper F'"
proof -
  have x: "x \<ge> m - f m / upper F'"
    using assms enclosure_with_lower_zero f_enclosure sign_of_element by auto
  have "m - f m / upper F' \<ge> m - upper F / upper F'"
    by (metis assms(3) atLeastAtMost_iff diff_left_mono divide_le_cancel f_enclosure le_cases set_of_eq)
  then show ?thesis using x by simp
qed

lemma f'enclosure_with_lower_zero': (* x \<in> (-\<infinity>, m - \<down>F / \<up>F'] *)
  assumes "x \<in> set_of X" "f x = 0" "lower F' = 0 \<and> 0 < upper F'" "0 < lower F"
  shows "x \<le> m - lower F / upper F'"
proof -
  have x: "x \<le> m - f m / upper F'"
    using assms enclosure_with_lower_zero' f_enclosure sign_of_element' by auto
  have "m - f m / upper F' \<le> m - lower F / upper F'"
    by (metis assms(3) atLeastAtMost_iff diff_left_mono divide_le_cancel f_enclosure le_cases set_of_eq)
  then show ?thesis using x by simp
qed

end

section "Newton Steps"

subsection "newton_step (real)"

text "In the thesis, this proof is not used, as we are working on floats.
However, for possible future work, the proof is left in here.
Also, it makes understanding the following proof of the Newton step on floats easier."

definition newton_step:: "real interval \<Rightarrow> real interval \<Rightarrow> real interval \<Rightarrow> real \<Rightarrow> real interval list" where
"newton_step X F F' m  = (
  if lower F' = 0 \<and> upper F' = 0 then (if 0 \<in> set_of F then [X] else [])
  else if 0 < lower F' \<or> upper F' < 0 then interval_intersection X (interval_of m - F * inverse_interval' F')
  else if upper F' = 0 then (
    if upper F < 0 then interval_intersection_unbounded_lower X (m - upper F / lower F')
    else if 0 < lower F then interval_intersection_unbounded_upper X (m - lower F / lower F')
    else split_interval X m
  )
  else if lower F' = 0 then (
    if upper F < 0 then interval_intersection_unbounded_upper X (m - upper F / upper F')
    else if 0 < lower F then interval_intersection_unbounded_lower X (m - lower F / upper F')
    else split_interval X m
  )
  else (
    if upper F < 0 then interval_intersection_unbounded_lower X (m - upper F / lower F')
      @ interval_intersection_unbounded_upper X (m - upper F / upper F')
    else if 0 < lower F then interval_intersection_unbounded_lower X (m - lower F / upper F')
      @ interval_intersection_unbounded_upper X (m - lower F / lower F')
    else split_interval X m
  )
)"

locale newton_step_locale_real =
  fixes f f' :: "real \<Rightarrow> real"
  fixes X F' F :: "real interval"
  fixes m :: "real"
  assumes f' : "x \<in> set_of X \<Longrightarrow> (f has_field_derivative f' x)(at x within set_of X)"
  assumes f'_enclosure : "x \<in> set_of X \<Longrightarrow> f' x \<in> set_of F'"
  assumes m : "m \<in> set_of X"
  assumes f_enclosure : "f m \<in> set_of F"

begin

interpretation newton_step_locale' f f' X F' m F
proof
  show "\<And>x. x \<in>\<^sub>i X \<Longrightarrow> (f has_real_derivative f' x) (at x within set_of X)" by (simp add: f')
  show "\<And>x. x \<in>\<^sub>i X \<Longrightarrow> f' x \<in>\<^sub>i F'" by (simp add: f'_enclosure)
  show "m \<in>\<^sub>i X" by (simp add: m)
  show "f m \<in>\<^sub>i F " by (simp add: f_enclosure)
qed

lemma newton_step_correctness:
  fixes x::real
  assumes "x \<in> set_of X" "f x = 0"
  shows "x \<in> set_of_interval_list (newton_step X F F' m)"
proof -
  consider (z) "lower F' = 0" "upper F' = 0" | (nz) "lower F' > 0 \<or> upper F' < 0"
    | (upz) "lower F' < 0" "upper F' = 0" | (lwz) "lower F' = 0" "upper F' > 0"
    | (btw) "lower F' < 0" "upper F' > 0" by linarith
  then show ?thesis
  proof cases
    case z
    then show ?thesis
    proof (cases "0 \<in> set_of F")
      case True
      then show ?thesis using z True newton_step_def assms(1) by simp
    next
      case False
      have "\<forall>x \<in> set_of X. f' x = 0"
        by (smt (z3) atLeastAtMost_iff f'_enclosure set_of_eq z)
      then have "\<forall>x \<in> set_of X. \<forall> x' \<in> set_of X. f x = f x'" using deriv_is_zero
        by (smt (z3) atLeastAtMost_iff mult_eq_0_iff set_of_eq transfer_mvt)
      then have "\<forall>x \<in> set_of X. f x \<noteq> 0" using False f_enclosure m by fastforce
      then show ?thesis using z False newton_step_def assms(1,2) by auto
    qed
  next
    case nz
    then have "x \<in> set_of (interval_of m - F * inverse_interval' F')"
      using f'enclosure_not_zero assms sign_of_element sign_of_element' by blast
    then have "x \<in> set_of_interval_list (interval_intersection X (interval_of m - F * inverse_interval' F'))"
      by (simp add: assms(1) in_both_intervals_in_intersection)
    then show ?thesis using newton_step_def nz by auto
  next
    case upz
    then have "upper F < 0 \<or> 0 < lower F \<or> 0 \<in> set_of F" by (auto simp: set_of_eq)
    then show ?thesis
    proof (elim disjE)
      assume fneg: "upper F < 0"
      then have "x \<le> m - upper F / lower F'"
        using f'enclosure_with_upper_zero assms upz by (simp add: set_of_eq)
      then have "x \<in> set_of_interval_list (interval_intersection_unbounded_lower X (m - upper F / lower F'))"
        using in_both_intervals_in_ul_intersection assms by (simp add: set_of_eq)
      then show ?thesis using upz fneg newton_step_def by auto
    next
      assume fpos: "0 < lower F"
      then have "m - lower F / lower F' \<le> x"
        using f'enclosure_with_upper_zero' assms upz by (simp add: set_of_eq)
      then have "x \<in> set_of_interval_list (interval_intersection_unbounded_upper X (m - lower F / lower F'))"
        using in_both_intervals_in_uu_intersection assms by (simp add: set_of_eq)
      then show ?thesis using upz fpos newton_step_def f_enclosure sign_of_element sign_of_element'
        by fastforce
    next
      assume fz: "0 \<in> set_of F"
      then show ?thesis using upz newton_step_def assms(1) split_same_set by (simp add: set_of_eq)
    qed
  next
    case lwz
    then have "upper F < 0 \<or> 0 < lower F \<or> 0 \<in> set_of F" by (auto simp: set_of_eq)
    then show ?thesis
    proof (elim disjE)
      assume fneg: "upper F < 0"
      then have "m - upper F / upper F' \<le> x"
        using f'enclosure_with_lower_zero assms lwz by (simp add: set_of_eq)
      then have "x \<in> set_of_interval_list (interval_intersection_unbounded_upper X (m - upper F / upper F'))"
        using in_both_intervals_in_uu_intersection assms by (simp add: set_of_eq)
      then show ?thesis using lwz fneg newton_step_def by auto
    next
      assume fpos: "0 < lower F"
      then have "x \<le> m - lower F / upper F'"
        using f'enclosure_with_lower_zero' assms lwz by (simp add: set_of_eq)
      then have "x \<in> set_of_interval_list (interval_intersection_unbounded_lower X (m - lower F / upper F'))"
        using in_both_intervals_in_ul_intersection assms by (simp add: set_of_eq)
      then show ?thesis using lwz fpos newton_step_def f_enclosure sign_of_element sign_of_element'
        by fastforce
    next
      assume fz: "0 \<in> set_of F"
      then show ?thesis using lwz fz newton_step_def assms(1) split_same_set by (simp add: set_of_eq)
    qed
  next
    case btw
    then have "upper F < 0 \<or> 0 < lower F \<or> 0 \<in> set_of F" by (auto simp: set_of_eq)
    then show ?thesis
    proof (elim disjE)
      assume fneg: "upper F < 0"
      then have "m - upper F / upper F' \<le> x \<or> x \<le> m - upper F / lower F'"
        using f'enclosure_with_inside_zero assms btw set_of_eq by blast
      then have "x \<in> set_of_interval_list (interval_intersection_unbounded_lower X (m - upper F / lower F')
          @ interval_intersection_unbounded_upper X (m - upper F / upper F'))"
        using in_both_intervals_in_ul_intersection in_both_intervals_in_uu_intersection assms
              in_larger_interval_list_set_l in_larger_interval_list_set_r by auto
      then show ?thesis using btw fneg newton_step_def by auto
    next
      assume fpos: "0 < lower F"
      then have "m - lower F / lower F' \<le> x \<or> x \<le> m - lower F / upper F'"
        using f'enclosure_with_inside_zero' assms btw set_of_eq by blast
      then have "x \<in> set_of_interval_list (interval_intersection_unbounded_lower X (m - lower F / upper F')
          @ interval_intersection_unbounded_upper X (m - lower F / lower F'))"
        using in_both_intervals_in_ul_intersection in_both_intervals_in_uu_intersection assms
          in_larger_interval_list_set_l in_larger_interval_list_set_r by auto
      then show ?thesis using btw fpos newton_step_def f_enclosure sign_of_element sign_of_element'
        by fastforce
    next
      assume fz: "0 \<in> set_of F"
      then show ?thesis using btw fz newton_step_def assms(1) split_same_set by (simp add: set_of_eq)
    qed
  qed
qed

end

subsection "newton_step_float"

definition newton_step_float:: "nat \<Rightarrow> float interval \<Rightarrow> float interval \<Rightarrow> float interval
  \<Rightarrow> float \<Rightarrow> float interval list" where
"newton_step_float prec X F F' m = (
  if lower F' = 0 \<and> upper F' = 0 then (if 0 \<in> set_of F then [X] else [])
  else if 0 < lower F' \<or> upper F' < 0 then
    float_interval_intersection X (plus_float_interval prec (interval_of m) (
      - mult_float_interval prec F (inverse_float_interval' prec F'))
    )
  else if upper F' = 0 then (
    if upper F < 0 then float_interval_intersection_unbounded_lower X (
      float_plus_up prec m (- float_divl prec (upper F) (lower F'))
    )
    else if 0 < lower F then float_interval_intersection_unbounded_upper X (
      float_plus_down prec m (- float_divr prec (lower F) (lower F'))
    )
    else split_float_interval X m
  )
  else if lower F' = 0 then (
    if upper F < 0 then float_interval_intersection_unbounded_upper X (
      float_plus_down prec m (- float_divr prec (upper F) (upper F'))
    )
    else if 0 < lower F then float_interval_intersection_unbounded_lower X (
      float_plus_up prec m (- float_divl prec (lower F) (upper F'))
    )
    else split_float_interval X m
  )
  else (
    if upper F < 0 then float_interval_intersection_unbounded_lower X (
      float_plus_up prec m (- float_divl prec (upper F) (lower F'))
    ) @ float_interval_intersection_unbounded_upper X (
      float_plus_down prec m (- float_divr prec (upper F) (upper F'))
    )
    else if 0 < lower F then float_interval_intersection_unbounded_lower X (
      float_plus_up prec m (- float_divl prec (lower F) (upper F'))
    ) @ float_interval_intersection_unbounded_upper X (
      float_plus_down prec m (- float_divr prec (lower F) (lower F'))
    )
    else split_float_interval X m
  )
)"

locale newton_step_locale_float =
  fixes f f' :: "real \<Rightarrow> real"
  fixes X F F' :: "float interval"
  fixes m :: "float"
  assumes f': "x \<in> set_of (real_interval X) \<Longrightarrow> (f has_field_derivative f' x)(at x within set_of (real_interval X))"
  assumes f'_enclosure: "x \<in> set_of (real_interval X) \<Longrightarrow> f' x \<in> set_of (real_interval F')"
  assumes m: "m \<in> set_of X"
  assumes f_enclosure: "f m \<in> set_of (real_interval F)"

begin

interpretation newton_step_locale_real f f' "real_interval X" "real_interval F'" "real_interval F" "real_of_float m"
proof
  show "\<And>x. x \<in>\<^sub>r X \<Longrightarrow> (f has_real_derivative f' x) (at x within set_of (real_interval X))" using f' by simp
  show "\<And>x. x \<in>\<^sub>r X \<Longrightarrow> f' x \<in>\<^sub>r F'" using f'_enclosure by simp
  show "real_of_float m \<in>\<^sub>r X" by (metis atLeastAtMost_iff in_real_intervalI less_eq_float.rep_eq m set_of_eq)
  show "f (real_of_float m) \<in>\<^sub>r F" by (simp add: f_enclosure)
qed

interpretation newton_step_locale' f f' "real_interval X" "real_interval F'" "real_of_float m" "real_interval F"
proof
  show "\<And>x. x \<in>\<^sub>r X \<Longrightarrow> (f has_real_derivative f' x) (at x within set_of (real_interval X))"
    by (simp add: f')
  show "\<And>x. x \<in>\<^sub>r X \<Longrightarrow> f' x \<in>\<^sub>r F'" by (simp add: f'_enclosure)
  show "real_of_float m \<in>\<^sub>r X" by (simp add: m)
  show "f (real_of_float m) \<in>\<^sub>r F" by (simp add: f_enclosure)
qed

lemma newton_step_float_correctness:
  fixes x :: real
  assumes "x \<in> set_of (real_interval X)" "f x = 0"
  shows "x \<in> real_set_of_float_interval_list (newton_step_float prec X F F' m)"
proof -
  consider (z) "lower F' = 0" "upper F' = 0" | (nz) "0 < lower F' \<or> upper F' < 0"
    | (upz) "lower F' < 0" "upper F' = 0"    | (lwz) "lower F' = 0" "upper F' > 0"
    | (btw) "lower F' < 0" "0 < upper F'" by linarith
  then show ?thesis
  proof cases
    case z
    then show ?thesis
    proof (cases "0 \<in> set_of F")
      case True
      then show ?thesis using z True newton_step_float_def assms(1) by simp
    next
      case False
      have "\<forall>x \<in> set_of (real_interval X). f' x = 0"
        by (smt (z3) atLeastAtMost_iff f'_enclosure lower_real_interval set_of_eq
            upper_real_interval z zero_float.rep_eq)
      then have const: "f x = f x'" if "x \<in> set_of (real_interval X)" "x' \<in> set_of (real_interval X)" for x x'
        using deriv_is_zero that by (smt (z3) atLeastAtMost_iff mult_eq_0_iff set_of_eq transfer_mvt)
      have "f m \<noteq> 0"
        using m f_enclosure False by (metis atLeastAtMost_iff less_eq_float.rep_eq
            lower_real_interval set_of_eq upper_real_interval zero_float.rep_eq)
      also have "f m = f x"
        using m assms(1) by (intro const) (auto simp: set_of_eq)
      also have "f x = 0"
        using assms(2) .
      finally show ?thesis by simp
    qed
  next
    case nz
    then have "x \<in> set_of (interval_of m - real_interval F * inverse_interval' (real_interval F'))"
      using f'enclosure_not_zero assms sign_of_element sign_of_element'
      by (smt (z3) less_float.rep_eq lower_real_interval upper_real_interval zero_float.rep_eq)
    also have "0 \<notin> set_of F'"
      using nz by (metis atLeastAtMost_iff not_le set_of_eq)
    hence "interval_of (real_of_float m) - real_interval F * inverse_interval' (real_interval F') \<le>
           real_interval (interval_of m - mult_float_interval prec F (inverse_float_interval' prec F'))"
      by (intro diff_mono_real_interval mult_float_interval_mono order.refl inverse_float_interval'_mono) auto
    hence "set_of (interval_of m - real_interval F * inverse_interval' (real_interval F')) \<subseteq>
           set_of (real_interval (interval_of m - mult_float_interval prec F (inverse_float_interval' prec F')))"
      by (meson less_eq_interval_def set_of_subset_iff)
    finally have "x \<in> set_of (real_interval (interval_of m - mult_float_interval prec F (inverse_float_interval' prec F')))"
      by (simp add: set_of_eq)
    then have "x \<in> set_of (real_interval (plus_float_interval prec (interval_of m) (
      - mult_float_interval prec F (inverse_float_interval' prec F'))))"
      using minus_float_interval_monotonic real_interval_subset by (meson set_of_subset_iff' subset_iff)
    then show ?thesis unfolding newton_step_float_def
      using nz assms(1) in_both_float_intervals_in_float_intersection' by auto
  next
    case upz
    then have "upper F < 0 \<or> 0 < lower F \<or> 0 \<in> set_of F" by (auto simp: set_of_eq)
    then show ?thesis
    proof (elim disjE)
      assume fneg: "upper F < 0"
      then have "x \<le> m - upper F / lower F'"
        using f'enclosure_with_upper_zero assms upz by (simp add: set_of_eq)
      then have "x \<le> m - float_divl prec (upper F) (lower F')"
        by (smt float_divl less_eq_float.rep_eq minus_float.rep_eq)
      then have "x \<le> float_plus_up prec m (- float_divl prec (upper F) (lower F'))"
        using float_plus_up_le by auto
      then have "x \<in> real_set_of_float_interval_list (float_interval_intersection_unbounded_lower X (
          float_plus_up prec m (- float_divl prec (upper F) (lower F'))))"
        using in_both_float_intervals_in_ul_intersection' assms by (auto simp: set_of_eq)
      then show ?thesis using upz fneg newton_step_float_def by auto
    next
      assume fpos: "0 < lower F"
      then have "m - lower F / lower F' \<le> x"
        using f'enclosure_with_upper_zero' assms upz by (simp add: set_of_eq)
      then have "m - float_divr prec (lower F) (lower F') \<le> x"
        by (smt float_divr less_eq_float.rep_eq minus_float.rep_eq)
      then have "float_plus_down prec m (- float_divr prec (lower F) (lower F')) \<le> x"
        using float_plus_down_le by auto
      then have "x \<in> real_set_of_float_interval_list (float_interval_intersection_unbounded_upper X (
        float_plus_down prec m (- float_divr prec (lower F) (lower F'))))"
        using in_both_float_intervals_in_uu_intersection' assms by (simp add: set_of_eq)
      then show ?thesis using upz fpos newton_step_float_def
        by (smt (z3) less_eq_float.rep_eq less_float.rep_eq lower_le_upper)
    next
      assume fz: "0 \<in> set_of F"
      then show ?thesis using upz split_float_same_set' newton_step_float_def assms(1)
        by (simp add: set_of_eq)
    qed
  next
    case lwz
    then have "upper F < 0 \<or> 0 < lower F \<or> 0 \<in> set_of F" by (auto simp: set_of_eq)
    then show ?thesis
    proof (elim disjE)
      assume fneg: "upper F < 0"
      then have "m - upper F / upper F' \<le> x"
        using f'enclosure_with_lower_zero assms lwz by (simp add: set_of_eq)
      then have "m - float_divr prec (upper F) (upper F') \<le> x"
        by (smt float_divr less_eq_float.rep_eq minus_float.rep_eq)
      then have "float_plus_down prec m (- float_divr prec (upper F) (upper F')) \<le> x"
        using float_plus_down_le by auto
      then have "x \<in> real_set_of_float_interval_list (float_interval_intersection_unbounded_upper X (
        float_plus_down prec m (- float_divr prec (upper F) (upper F'))))"
        using in_both_float_intervals_in_uu_intersection' assms by (simp add: set_of_eq)
      then show ?thesis using lwz fneg newton_step_float_def by auto
    next
      assume fpos: "0 < lower F"
      then have "x \<le> m - lower F / upper F'"
        using f'enclosure_with_lower_zero' assms lwz by (simp add: set_of_eq)
      then have "x \<le> m - float_divl prec (lower F) (upper F')"
        by (smt float_divl less_eq_float.rep_eq minus_float.rep_eq)
      then have "x \<le> float_plus_up prec m (- float_divl prec (lower F) (upper F'))"
        using float_plus_up_le by auto
      then have "x \<in> real_set_of_float_interval_list (float_interval_intersection_unbounded_lower X (
        float_plus_up prec m (- float_divl prec (lower F) (upper F'))))"
        using in_both_float_intervals_in_ul_intersection' assms by (simp add: set_of_eq)
      then show ?thesis using lwz fpos newton_step_float_def
        by (smt (z3) less_eq_float.rep_eq less_float.rep_eq lower_le_upper)
    next
      assume fz: "0 \<in> set_of F"
      then show ?thesis using lwz split_float_same_set' newton_step_float_def assms(1)
        by (simp add: set_of_eq)
    qed
  next
    case btw
    then have "upper F < 0 \<or> 0 < lower F \<or> 0 \<in> set_of F" by (auto simp: set_of_eq)
    then show ?thesis
    proof (elim disjE)
      assume fneg: "upper F < 0"
      then have "m - upper F / upper F' \<le> x \<or> x \<le> m - upper F / lower F'"
        using f'enclosure_with_inside_zero assms btw by (auto simp: set_of_eq)
      then have "m - float_divr prec (upper F) (upper F') \<le> x \<or> x \<le> m - float_divl prec (upper F) (lower F')"
        by (smt float_divl float_divr less_eq_float.rep_eq minus_float.rep_eq)
      then have "float_plus_down prec m (- float_divr prec (upper F) (upper F')) \<le> x
        \<or> x \<le> float_plus_up prec m (- float_divl prec (upper F) (lower F'))"
        using float_plus_down_le float_plus_up_le by auto
      then have "x \<in> real_set_of_float_interval_list (float_interval_intersection_unbounded_lower X (
        float_plus_up prec m (- float_divl prec (upper F) (lower F')))
        @ float_interval_intersection_unbounded_upper X (
        float_plus_down prec m (- float_divr prec (upper F) (upper F'))))"
        using in_both_float_intervals_in_ul_intersection' in_both_float_intervals_in_uu_intersection' assms
              in_larger_real_set_of_float_interval_list_l in_larger_real_set_of_float_interval_list_r by auto
      then show ?thesis using btw fneg newton_step_float_def by auto
    next
      assume fpos: "0 < lower F"
      then have "m - lower F / lower F' \<le> x \<or> x \<le> m - lower F / upper F'"
        using f'enclosure_with_inside_zero' assms btw by (auto simp: set_of_eq)
      then have "m - float_divr prec (lower F) (lower F') \<le> x \<or> x \<le> m - float_divl prec (lower F) (upper F')"
        by (smt float_divl float_divr less_eq_float.rep_eq minus_float.rep_eq)
      then have "float_plus_down prec m (- float_divr prec (lower F) (lower F')) \<le> x
        \<or> x \<le> float_plus_up prec m (- float_divl prec (lower F) (upper F'))"
        using float_plus_down_le float_plus_up_le by auto
      then have "x \<in> real_set_of_float_interval_list (float_interval_intersection_unbounded_lower X (
        float_plus_up prec m (- float_divl prec (lower F) (upper F')))
        @ float_interval_intersection_unbounded_upper X (
        float_plus_down prec m (- float_divr prec (lower F) (lower F'))))"
        using in_both_float_intervals_in_ul_intersection' in_both_float_intervals_in_uu_intersection' assms
              in_larger_real_set_of_float_interval_list_l in_larger_real_set_of_float_interval_list_r by auto
      then show ?thesis using btw fpos newton_step_float_def
        by (smt (z3) less_eq_float.rep_eq less_float.rep_eq lower_le_upper)
    next
      assume fz: "0 \<in> set_of F"
      then show ?thesis using btw split_float_same_set' newton_step_float_def assms(1) by (simp add: set_of_eq)
    qed
  qed
qed

end

subsection "newton_step_floatarith"

definition newton_step_floatarith:: "floatarith \<Rightarrow> nat \<Rightarrow> float interval \<Rightarrow> float interval list option" where
"newton_step_floatarith f prec ivl = do {
  let m = float_down prec (mid ivl);
  let f' = DERIV_floatarith 0 f;
  F \<leftarrow> approx prec f [Some (interval_of m)];
  F' \<leftarrow> approx prec f' [Some ivl];
  if m \<le> lower ivl then Some [round_interval prec ivl]
  else if isDERIV_approx prec 0 f [Some ivl] then
     Some (map (round_interval prec) (newton_step_float prec ivl F F' m)) else None
}"

lemma newton_step_floatarith_correctness:
  fixes x :: real
  assumes "newton_step_floatarith f prec ivl = Some ivls"
    "interpret_floatarith f [x] = 0"
    "x \<in> set_of (real_interval ivl)"
  defines "m \<equiv> float_down prec (mid ivl)"
  shows "x \<in> real_set_of_float_interval_list ivls"
proof (cases "m \<le> lower ivl")
  case True
  then have "ivls = [round_interval prec ivl]"
    using assms unfolding newton_step_floatarith_def m_def by (simp add: bind_eq_Some_conv)
  then show ?thesis by (simp add: assms(3) in_round_intervalI)
next
  case False
  from False have m: "m > lower ivl"
    by (auto simp: not_le)
  define f' where "f' = DERIV_floatarith 0 f"
  obtain F' where F': "approx prec f' [Some ivl] = Some F'"
    using assms(1) by (force simp: newton_step_floatarith_def f'_def)
  obtain F where F: "approx prec f [Some (interval_of m)] = Some F"
    using assms(1) by (force simp: newton_step_floatarith_def m_def)
  have isDERIV_approx': "isDERIV_approx prec 0 f [Some ivl]"
    using assms(1) False F m unfolding newton_step_floatarith_def f'_def m_def
    by (auto simp: Let_def bind_eq_Some_conv split: if_splits)
  then show ?thesis
  proof -
    interpret newton_step_locale_float "\<lambda>x. interpret_floatarith f [x]" "\<lambda>x. interpret_floatarith f' [x]" ivl F F' m
    proof
      show "((\<lambda>x. interpret_floatarith f [x]) has_real_derivative interpret_floatarith f' [x])
            (at x within set_of (real_interval ivl))" if x: "x \<in>\<^sub>r ivl" for x
      proof -
        have "((\<lambda>x. interpret_floatarith f ([0][0 := x])) has_real_derivative interpret_floatarith f' ([0][0 := x]))(at x)"
          unfolding f'_def
          by (rule DERIV_floatarith[OF _ isDERIV_approx[OF _ isDERIV_approx']])
            (auto simp: bounded_by_def x)
        thus ?thesis by (auto intro: has_field_derivative_at_within)
      qed
      show "\<And>x. x \<in>\<^sub>r ivl \<Longrightarrow> interpret_floatarith f' [x] \<in>\<^sub>r F'"
        by (rule approx[OF _ F']) (auto simp: bounded_by_def)
      show "interpret_floatarith f [real_of_float m] \<in>\<^sub>r F"
        by (rule approx[OF _ F]) (auto simp: bounded_by_def)
      show "m \<in>\<^sub>i ivl"
      proof -
        have "float_down prec (mid ivl) \<le> upper ivl" using round_down mid_in_interval
          by (metis dual_order.trans float_down.rep_eq less_eq_float.rep_eq mid_le(2))
        then show ?thesis using False unfolding m_def by (metis assms(4) in_intervalI le_cases)
      qed
    qed
    have "x \<in> real_set_of_float_interval_list (newton_step_float prec ivl F F' m)"
      by (simp add: assms(2,3) newton_step_float_correctness)
    then have "x \<in> real_set_of_float_interval_list (map (round_interval prec) (newton_step_float prec ivl F F' m))"
      using in_rounded_interval_list by simp
    then show ?thesis using assms False F F' isDERIV_approx'
      unfolding newton_step_floatarith_def m_def f'_def by simp
  qed
qed

section "Recursive Method"

subsection "mapM"

fun mapM:: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b list option" where
"mapM f [] = Some []" |
"mapM f (x#xs) = do {
  y \<leftarrow> f x;
  ys \<leftarrow> mapM f xs;
  Some (y # ys)
}"

lemma mapM_None: "mapM f xs = None \<longleftrightarrow> (\<exists>x\<in>set xs. f x = None)"
proof (induct xs)
  case (Cons x xs) thus ?case
    by (cases "f x", simp, cases "mapM f xs", auto)
qed simp

lemma mapM_Some: "mapM f xs = Some ys \<Longrightarrow> ys = map (\<lambda>x. the (f x)) xs \<and> (\<forall>x\<in>set xs. f x \<noteq> None)"
proof (induct xs arbitrary: ys)
  case (Cons x xs ys) thus ?case
    by (cases "f x", simp, cases "mapM f xs", auto)
qed simp

lemma mapM_Some_idx:
  assumes some: "mapM f xs = Some ys" and i: "i < length xs"
  shows "\<exists>y. f (xs ! i) = Some y \<and> ys ! i = y"
proof -
  note m = mapM_Some [OF some]
  from m[unfolded set_conv_nth] i have "f (xs ! i) \<noteq> None" by auto
  then obtain y where "f (xs ! i) = Some y" by auto
  then have "f (xs ! i) = Some y \<and> ys ! i = y" unfolding m [THEN conjunct1] using i by auto
  then show ?thesis ..
qed

lemma mapM_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "mapM f xs = mapM g ys"
  unfolding assms(1) using assms(2) by (induct ys) auto

lemma mapM_map: "mapM f xs = (if (\<forall>x\<in>set xs. f x \<noteq> None) then Some (map (\<lambda>x. the (f x)) xs) else None)"
proof (cases "mapM f xs")
  case None
  thus ?thesis using mapM_None by auto
next
  case (Some ys)
  with mapM_Some [OF Some] show ?thesis by auto
qed

lemma mapM_mono [partial_function_mono]:
  fixes C :: "'a \<Rightarrow> ('b \<Rightarrow> 'c option) \<Rightarrow> 'd option"
  assumes C: "\<And>y. mono_option (C y)"
  shows "mono_option (\<lambda>f. mapM (\<lambda>y. C y f) B)"
proof (induct B)
  case Nil
  show ?case unfolding mapM.simps by (rule option.const_mono)
next
  case (Cons b B)
  show ?case unfolding mapM.simps
    by (rule bind_mono [OF C bind_mono [OF Cons option.const_mono]])
qed

lemma those_mono[partial_function_mono]:
  assumes "monotone option.le_fun (list_all2 option_ord) B"
  shows "mono_option (\<lambda>f. those (B f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b option" assume "option.le_fun f g"
  hence "list_all2 option_ord (B f) (B g)" using assms by (metis monotoneD)
  thus "option_ord (those (B f)) (those (B g))"
    by induction (auto simp: flat_ord_def split: option.splits)
qed

subsection "newton_floatarith"

partial_function (option) newton_floatarith::
  "nat \<Rightarrow> floatarith \<Rightarrow> nat \<Rightarrow> float interval \<Rightarrow> float interval list option" where
"newton_floatarith eps f prec ivl = (if width ivl < Float 1 (-eps) then Some [ivl] else do {
  ivls \<leftarrow> newton_step_floatarith f prec ivl;
  if ivls = [ivl] then Some [ivl]
  else do {
    ivls' \<leftarrow> mapM (newton_floatarith eps f prec) ivls;
    Some (concat ivls')
  }
})"

lemma Option_bind_altdef: "Option.bind x f = (case x of None \<Rightarrow> None | Some x' \<Rightarrow> f x')"
  by (cases x) auto

lemma newton_floatarith_correctness:
  fixes x :: real
  assumes "newton_floatarith eps f prec ivl = Some ivls"
          "interpret_floatarith f [x] = 0"
          "x \<in> set_of (real_interval ivl)"
  shows   "x \<in> real_set_of_float_interval_list ivls"
  using assms
proof (induction rule: newton_floatarith.raw_induct[rotated 1, consumes 1])
  case (1 newton_floatarith eps f prec ivl ivls)
  consider (stop) "ivls = [ivl]"
    | (rec) ivls' ivlss' where
        "newton_step_floatarith f prec ivl = Some ivls'"
        "mapM (newton_floatarith eps f prec) ivls' = Some ivlss'" "ivls = concat ivlss'"
    using 1(2) by (auto split: if_splits option.splits simp: Option_bind_altdef)
  thus ?case
  proof cases
    case stop
    thus ?thesis using 1 by auto
  next
    case (rec ivls' ivlss')
    then have "x \<in> real_set_of_float_interval_list ivls'"
      using "1.prems"(1,2) newton_step_floatarith_correctness by auto
    then obtain i where i: "x \<in> set_of (real_interval (ivls' ! i))" "i < length ivls'"
      using in_float_interval_list_in_set_of_float_interval' by blast
    obtain xivls where xivls: "newton_floatarith eps f prec (ivls' ! i) = Some xivls"
      using mapM_Some_idx local.rec(2) i(2) by blast
    then have x: "x \<in> real_set_of_float_interval_list xivls" using "1.IH" "1.prems"(1) i by auto
    have "Some ivlss' = Some (map (\<lambda>a. the ((newton_floatarith eps f prec) a)) ivls')"
      using mapM_Some by (metis local.rec(2))
    then have "xivls \<in> set ivlss'" by (metis xivls i(2) length_map nth_map nth_mem option.sel)
    then have "x \<in> real_set_of_float_interval_list (concat ivlss')"
      by (metis x concat.simps(2) concat_append in_larger_real_set_of_float_interval_list_l
          in_larger_real_set_of_float_interval_list_r in_set_conv_decomp)
    thus ?thesis by (simp add: local.rec(3))
  qed
qed

end


theory Closures2
imports
  Closures
  "../Well_Quasi_Orders/Well_Quasi_Orders"
begin

section {* Closure under @{text SUBSEQ} and @{text SUPSEQ} *}

text {* Properties about the embedding relation *}

lemma sublisteq_strict_length:
  assumes a: "sublisteq x y" "x \<noteq> y"
  shows "length x < length y"
using a
by (induct) (auto simp add: less_Suc_eq)

lemma sublisteq_wf:
  shows "wf {(x, y). sublisteq x y \<and> x \<noteq> y}"
proof -
  have "wf (measure length)" by simp
  moreover
  have "{(x, y). sublisteq x y \<and> x \<noteq> y} \<subseteq> measure length"
    unfolding measure_def by (auto simp add: sublisteq_strict_length)
  ultimately
  show "wf {(x, y). sublisteq x y \<and> x \<noteq> y}" by (rule wf_subset)
qed

lemma sublisteq_good:
  shows "good sublisteq (f :: nat \<Rightarrow> ('a::finite) list)"
using wqo_on_imp_good[where f="f", OF wqo_on_lists_over_finite_sets]
by simp

lemma sublisteq_Higman_antichains:
  assumes a: "\<forall>(x::('a::finite) list) \<in> A. \<forall>y \<in> A. x \<noteq> y \<longrightarrow> \<not>(sublisteq x y) \<and> \<not>(sublisteq y x)"
  shows "finite A"
proof (rule ccontr)
  assume "infinite A"
  then obtain f::"nat \<Rightarrow> 'a::finite list" where b: "inj f" and c: "range f \<subseteq> A"
    by (auto simp add: infinite_iff_countable_subset)
  from sublisteq_good[where f="f"]
  obtain i j where d: "i < j" and e: "sublisteq (f i) (f j) \<or> f i = f j"
    unfolding good_def
    by auto
  have "f i \<noteq> f j" using b d by (auto simp add: inj_on_def)
  moreover
  have "f i \<in> A" using c by auto
  moreover
  have "f j \<in> A" using c by auto
  ultimately have "\<not>(sublisteq (f i) (f j))" using a by simp
  with e show "False" by auto
qed

subsection {* Sub- and Supersequences *}

definition
 "SUBSEQ A \<equiv> {x::('a::finite) list. \<exists>y \<in> A. sublisteq x y}"

definition
 "SUPSEQ A \<equiv> {x::('a::finite) list. \<exists>y \<in> A. sublisteq y x}"

lemma SUPSEQ_atom [simp]:
  shows "SUPSEQ {[c]} = UNIV \<cdot> {[c]} \<cdot> UNIV"
unfolding SUPSEQ_def conc_def
by (auto dest: list_emb_ConsD)

lemma SUPSEQ_union [simp]:
  shows "SUPSEQ (A \<union> B) = SUPSEQ A \<union> SUPSEQ B"
unfolding SUPSEQ_def by auto

lemma SUPSEQ_conc [simp]:
  shows "SUPSEQ (A \<cdot> B) = SUPSEQ A \<cdot> SUPSEQ B"
unfolding SUPSEQ_def conc_def
apply(auto)
apply(drule list_emb_appendD)
apply(auto)
by (metis list_emb_append_mono)

lemma SUPSEQ_star [simp]:
  shows "SUPSEQ (A\<star>) = UNIV"
apply(subst star_unfold_left)
apply(simp only: SUPSEQ_union)
apply(simp)
done

subsection {* Regular expression that recognises every character *}

definition
  Allreg :: "'a::finite rexp"
where
  "Allreg \<equiv> \<Uplus>(Atom ` UNIV)"

lemma Allreg_lang [simp]:
  shows "lang Allreg = (\<Union>a. {[a]})"
unfolding Allreg_def by auto

lemma Star_Allreg_lang [simp]:
  shows "lang (Star Allreg) = UNIV"
by simp

fun
  UP :: "'a::finite rexp \<Rightarrow> 'a rexp"
where
  "UP (Zero) = Zero"
| "UP (One) = Star Allreg"
| "UP (Atom c) = Times (Star Allreg) (Times (Atom c) (Star Allreg))"
| "UP (Plus r1 r2) = Plus (UP r1) (UP r2)"
| "UP (Times r1 r2) = Times (UP r1) (UP r2)"
| "UP (Star r) = Star Allreg"

lemma lang_UP:
  fixes r::"'a::finite rexp"
  shows "lang (UP r) = SUPSEQ (lang r)"
by (induct r) (simp_all)

lemma SUPSEQ_regular:
  fixes A::"'a::finite lang"
  assumes "regular A"
  shows "regular (SUPSEQ A)"
proof -
  from assms obtain r::"'a::finite rexp" where "lang r = A" by auto
  then have "lang (UP r) = SUPSEQ A" by (simp add: lang_UP)
  then show "regular (SUPSEQ A)" by auto
qed

lemma SUPSEQ_subset:
  fixes A::"'a::finite list set"
  shows "A \<subseteq> SUPSEQ A"
unfolding SUPSEQ_def by auto

lemma SUBSEQ_complement:
  shows "- (SUBSEQ A) = SUPSEQ (- (SUBSEQ A))"
proof -
  have "- (SUBSEQ A) \<subseteq> SUPSEQ (- (SUBSEQ A))"
    by (rule SUPSEQ_subset)
  moreover
  have "SUPSEQ (- (SUBSEQ A)) \<subseteq> - (SUBSEQ A)"
  proof (rule ccontr)
    assume "\<not> (SUPSEQ (- (SUBSEQ A)) \<subseteq> - (SUBSEQ A))"
    then obtain x where
       a: "x \<in> SUPSEQ (- (SUBSEQ A))" and
       b: "x \<notin> - (SUBSEQ A)" by auto

    from a obtain y where c: "y \<in> - (SUBSEQ A)" and d: "sublisteq y x"
      by (auto simp add: SUPSEQ_def)

    from b have "x \<in> SUBSEQ A" by simp
    then obtain x' where f: "x' \<in> A" and e: "sublisteq x x'"
      by (auto simp add: SUBSEQ_def)

    from d e have "sublisteq y x'"
      by (rule sublisteq_trans)
    then have "y \<in> SUBSEQ A" using f
      by (auto simp add: SUBSEQ_def)
    with c show "False" by simp
  qed
  ultimately show "- (SUBSEQ A) = SUPSEQ (- (SUBSEQ A))" by simp
qed

definition
  minimal :: "'a::finite list \<Rightarrow> 'a lang \<Rightarrow> bool"
where
  "minimal x A \<equiv> (\<forall>y \<in> A. sublisteq y x \<longrightarrow> sublisteq x y)"

subsection {* Closure of @{const SUBSEQ} and @{const SUPSEQ} *}

lemma closure_SUPSEQ:
  fixes A::"'a::finite lang"
  shows "regular (SUPSEQ A)"
proof -
  obtain M where a: "finite M" and b: "SUPSEQ A = SUPSEQ M"
    using main_lemma by blast
  have "regular M" using a by (rule finite_regular)
  then have "regular (SUPSEQ M)" by (rule SUPSEQ_regular)
  then show "regular (SUPSEQ A)" using b by simp
qed

lemma closure_SUBSEQ:
  fixes A::"'a::finite lang"
  shows "regular (SUBSEQ A)"
proof -
  have "regular (SUPSEQ (- SUBSEQ A))" by (rule closure_SUPSEQ)
  then have "regular (- SUBSEQ A)" by (subst SUBSEQ_complement) (simp)
  then have "regular (- (- (SUBSEQ A)))" by (rule closure_complement)
  then show "regular (SUBSEQ A)" by simp
qed

end


(*  Title:      HOL/Metis_Examples/Message.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Jasmin Blanchette, TU Muenchen

Metis example featuring message authentication.
*)

section {* Metis Example Featuring Message Authentication *}

theory Message
imports Main
begin

declare [[metis_new_skolem]]

lemma strange_Un_eq [simp]: "A \<union> (B \<union> A) = B \<union> A"
by (metis Un_commute Un_left_absorb)

type_synonym key = nat

consts
  all_symmetric :: bool        --{*true if all keys are symmetric*}
  invKey        :: "key=>key"  --{*inverse of a symmetric key*}

specification (invKey)
  invKey [simp]: "invKey (invKey K) = K"
  invKey_symmetric: "all_symmetric --> invKey = id"
by (metis id_apply)

text{*The inverse of a symmetric key is itself; that of a public key
      is the private key and vice versa*}

definition symKeys :: "key set" where
  "symKeys == {K. invKey K = K}"

datatype  --{*We allow any number of friendly agents*}
  agent = Server | Friend nat | Spy

datatype
     msg = Agent  agent     --{*Agent names*}
         | Number nat       --{*Ordinary integers, timestamps, ...*}
         | Nonce  nat       --{*Unguessable nonces*}
         | Key    key       --{*Crypto keys*}
         | Hash   msg       --{*Hashing*}
         | MPair  msg msg   --{*Compound messages*}
         | Crypt  key msg   --{*Encryption, public- or shared-key*}

text{*Concrete syntax: messages appear as {|A,B,NA|}, etc...*}
syntax
  "_MTuple"      :: "['a, args] => 'a * 'b"       ("(2{|_,/ _|})")

syntax (xsymbols)
  "_MTuple"      :: "['a, args] => 'a * 'b"       ("(2\<lbrace>_,/ _\<rbrace>)")

translations
  "{|x, y, z|}"   == "{|x, {|y, z|}|}"
  "{|x, y|}"      == "CONST MPair x y"

definition HPair :: "[msg,msg] => msg" ("(4Hash[_] /_)" [0, 1000]) where
    --{*Message Y paired with a MAC computed with the help of X*}
    "Hash[X] Y == {| Hash{|X,Y|}, Y|}"

definition keysFor :: "msg set => key set" where
    --{*Keys useful to decrypt elements of a message set*}
  "keysFor H == invKey ` {K. \<exists>X. Crypt K X \<in> H}"

subsubsection{*Inductive Definition of All Parts" of a Message*}

inductive_set
  parts :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro]:               "X \<in> H ==> X \<in> parts H"
  | Fst:         "{|X,Y|}   \<in> parts H ==> X \<in> parts H"
  | Snd:         "{|X,Y|}   \<in> parts H ==> Y \<in> parts H"
  | Body:        "Crypt K X \<in> parts H ==> X \<in> parts H"

lemma parts_mono: "G \<subseteq> H ==> parts(G) \<subseteq> parts(H)"
apply auto
apply (erule parts.induct)
   apply (metis parts.Inj set_rev_mp)
  apply (metis parts.Fst)
 apply (metis parts.Snd)
by (metis parts.Body)

text{*Equations hold because constructors are injective.*}
lemma Friend_image_eq [simp]: "(Friend x \<in> Friend`A) = (x:A)"
by (metis agent.inject image_iff)

lemma Key_image_eq [simp]: "(Key x \<in> Key`A) = (x \<in> A)"
by (metis image_iff msg.inject(4))

lemma Nonce_Key_image_eq [simp]: "Nonce x \<notin> Key`A"
by (metis image_iff msg.distinct(23))

subsubsection{*Inverse of keys *}

lemma invKey_eq [simp]: "(invKey K = invKey K') = (K = K')"
by (metis invKey)

subsection{*keysFor operator*}

lemma keysFor_empty [simp]: "keysFor {} = {}"
by (unfold keysFor_def, blast)

lemma keysFor_Un [simp]: "keysFor (H \<union> H') = keysFor H \<union> keysFor H'"
by (unfold keysFor_def, blast)

lemma keysFor_UN [simp]: "keysFor (\<Union>i\<in>A. H i) = (\<Union>i\<in>A. keysFor (H i))"
by (unfold keysFor_def, blast)

text{*Monotonicity*}
lemma keysFor_mono: "G \<subseteq> H ==> keysFor(G) \<subseteq> keysFor(H)"
by (unfold keysFor_def, blast)

lemma keysFor_insert_Agent [simp]: "keysFor (insert (Agent A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Nonce [simp]: "keysFor (insert (Nonce N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Number [simp]: "keysFor (insert (Number N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Key [simp]: "keysFor (insert (Key K) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Hash [simp]: "keysFor (insert (Hash X) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_MPair [simp]: "keysFor (insert {|X,Y|} H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Crypt [simp]:
    "keysFor (insert (Crypt K X) H) = insert (invKey K) (keysFor H)"
by (unfold keysFor_def, auto)

lemma keysFor_image_Key [simp]: "keysFor (Key`E) = {}"
by (unfold keysFor_def, auto)

lemma Crypt_imp_invKey_keysFor: "Crypt K X \<in> H ==> invKey K \<in> keysFor H"
by (unfold keysFor_def, blast)

subsection{*Inductive relation "parts"*}

lemma MPair_parts:
     "[| {|X,Y|} \<in> parts H;
         [| X \<in> parts H; Y \<in> parts H |] ==> P |] ==> P"
by (blast dest: parts.Fst parts.Snd)

declare MPair_parts [elim!] parts.Body [dest!]
text{*NB These two rules are UNSAFE in the formal sense, as they discard the
     compound message.  They work well on THIS FILE.
  @{text MPair_parts} is left as SAFE because it speeds up proofs.
  The Crypt rule is normally kept UNSAFE to avoid breaking up certificates.*}

lemma parts_increasing: "H \<subseteq> parts(H)"
by blast

lemmas parts_insertI = subset_insertI [THEN parts_mono, THEN subsetD]

lemma parts_empty [simp]: "parts{} = {}"
apply safe
apply (erule parts.induct)
apply blast+
done

lemma parts_emptyE [elim!]: "X\<in> parts{} ==> P"
by simp

text{*WARNING: loops if H = {Y}, therefore must not be repeated!*}
lemma parts_singleton: "X\<in> parts H ==> \<exists>Y\<in>H. X\<in> parts {Y}"
apply (erule parts.induct)
apply fast+
done

subsubsection{*Unions *}

lemma parts_Un_subset1: "parts(G) \<union> parts(H) \<subseteq> parts(G \<union> H)"
by (intro Un_least parts_mono Un_upper1 Un_upper2)

lemma parts_Un_subset2: "parts(G \<union> H) \<subseteq> parts(G) \<union> parts(H)"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_Un [simp]: "parts(G \<union> H) = parts(G) \<union> parts(H)"
by (intro equalityI parts_Un_subset1 parts_Un_subset2)

lemma parts_insert: "parts (insert X H) = parts {X} \<union> parts H"
apply (subst insert_is_Un [of _ H])
apply (simp only: parts_Un)
done

lemma parts_insert2:
     "parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
by (metis Un_commute Un_empty_left Un_empty_right Un_insert_left Un_insert_right parts_Un)

lemma parts_UN_subset1: "(\<Union>x\<in>A. parts(H x)) \<subseteq> parts(\<Union>x\<in>A. H x)"
by (intro UN_least parts_mono UN_upper)

lemma parts_UN_subset2: "parts(\<Union>x\<in>A. H x) \<subseteq> (\<Union>x\<in>A. parts(H x))"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_UN [simp]: "parts(\<Union>x\<in>A. H x) = (\<Union>x\<in>A. parts(H x))"
by (intro equalityI parts_UN_subset1 parts_UN_subset2)

text{*Added to simplify arguments to parts, analz and synth.
  NOTE: the UN versions are no longer used!*}

text{*This allows @{text blast} to simplify occurrences of
  @{term "parts(G\<union>H)"} in the assumption.*}
lemmas in_parts_UnE = parts_Un [THEN equalityD1, THEN subsetD, THEN UnE]
declare in_parts_UnE [elim!]

lemma parts_insert_subset: "insert X (parts H) \<subseteq> parts(insert X H)"
by (blast intro: parts_mono [THEN [2] rev_subsetD])

subsubsection{*Idempotence and transitivity *}

lemma parts_partsD [dest!]: "X\<in> parts (parts H) ==> X\<in> parts H"
by (erule parts.induct, blast+)

lemma parts_idem [simp]: "parts (parts H) = parts H"
by blast

lemma parts_subset_iff [simp]: "(parts G \<subseteq> parts H) = (G \<subseteq> parts H)"
apply (rule iffI)
apply (metis Un_absorb1 Un_subset_iff parts_Un parts_increasing)
apply (metis parts_idem parts_mono)
done

lemma parts_trans: "[| X\<in> parts G;  G \<subseteq> parts H |] ==> X\<in> parts H"
by (blast dest: parts_mono)

lemma parts_cut: "[|Y\<in> parts (insert X G);  X\<in> parts H|] ==> Y\<in> parts(G \<union> H)"
by (metis (no_types) Un_insert_left Un_insert_right insert_absorb le_supE
          parts_Un parts_idem parts_increasing parts_trans)

subsubsection{*Rewrite rules for pulling out atomic messages *}

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

lemma parts_insert_Agent [simp]:
     "parts (insert (Agent agt) H) = insert (Agent agt) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Nonce [simp]:
     "parts (insert (Nonce N) H) = insert (Nonce N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Number [simp]:
     "parts (insert (Number N) H) = insert (Number N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Key [simp]:
     "parts (insert (Key K) H) = insert (Key K) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Hash [simp]:
     "parts (insert (Hash X) H) = insert (Hash X) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Crypt [simp]:
     "parts (insert (Crypt K X) H) =
          insert (Crypt K X) (parts (insert X H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Body)
done

lemma parts_insert_MPair [simp]:
     "parts (insert {|X,Y|} H) =
          insert {|X,Y|} (parts (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Fst parts.Snd)+
done

lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
apply auto
apply (erule parts.induct, auto)
done

lemma msg_Nonce_supply: "\<exists>N. \<forall>n. N\<le>n --> Nonce n \<notin> parts {msg}"
apply (induct_tac "msg")
apply (simp_all add: parts_insert2)
apply (metis Suc_n_not_le_n)
apply (metis le_trans linorder_linear)
done

subsection{*Inductive relation "analz"*}

text{*Inductive definition of "analz" -- what can be broken down from a set of
    messages, including keys.  A form of downward closure.  Pairs can
    be taken apart; messages decrypted with known keys.  *}

inductive_set
  analz :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro,simp] :    "X \<in> H ==> X \<in> analz H"
  | Fst:     "{|X,Y|} \<in> analz H ==> X \<in> analz H"
  | Snd:     "{|X,Y|} \<in> analz H ==> Y \<in> analz H"
  | Decrypt [dest]:
             "[|Crypt K X \<in> analz H; Key(invKey K): analz H|] ==> X \<in> analz H"

text{*Monotonicity; Lemma 1 of Lowe's paper*}
lemma analz_mono: "G\<subseteq>H ==> analz(G) \<subseteq> analz(H)"
apply auto
apply (erule analz.induct)
apply (auto dest: analz.Fst analz.Snd)
done

text{*Making it safe speeds up proofs*}
lemma MPair_analz [elim!]:
     "[| {|X,Y|} \<in> analz H;
             [| X \<in> analz H; Y \<in> analz H |] ==> P
          |] ==> P"
by (blast dest: analz.Fst analz.Snd)

lemma analz_increasing: "H \<subseteq> analz(H)"
by blast

lemma analz_subset_parts: "analz H \<subseteq> parts H"
apply (rule subsetI)
apply (erule analz.induct, blast+)
done

lemmas analz_into_parts = analz_subset_parts [THEN subsetD]

lemmas not_parts_not_analz = analz_subset_parts [THEN contra_subsetD]

lemma parts_analz [simp]: "parts (analz H) = parts H"
apply (rule equalityI)
apply (metis analz_subset_parts parts_subset_iff)
apply (metis analz_increasing parts_mono)
done

lemma analz_parts [simp]: "analz (parts H) = parts H"
apply auto
apply (erule analz.induct, auto)
done

lemmas analz_insertI = subset_insertI [THEN analz_mono, THEN [2] rev_subsetD]

subsubsection{*General equational properties *}

lemma analz_empty [simp]: "analz{} = {}"
apply safe
apply (erule analz.induct, blast+)
done

text{*Converse fails: we can analz more from the union than from the
  separate parts, as a key in one might decrypt a message in the other*}
lemma analz_Un: "analz(G) \<union> analz(H) \<subseteq> analz(G \<union> H)"
by (intro Un_least analz_mono Un_upper1 Un_upper2)

lemma analz_insert: "insert X (analz H) \<subseteq> analz(insert X H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsubsection{*Rewrite rules for pulling out atomic messages *}

lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]

lemma analz_insert_Agent [simp]:
     "analz (insert (Agent agt) H) = insert (Agent agt) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Nonce [simp]:
     "analz (insert (Nonce N) H) = insert (Nonce N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Number [simp]:
     "analz (insert (Number N) H) = insert (Number N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Hash [simp]:
     "analz (insert (Hash X) H) = insert (Hash X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

text{*Can only pull out Keys if they are not needed to decrypt the rest*}
lemma analz_insert_Key [simp]:
    "K \<notin> keysFor (analz H) ==>
          analz (insert (Key K) H) = insert (Key K) (analz H)"
apply (unfold keysFor_def)
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_MPair [simp]:
     "analz (insert {|X,Y|} H) =
          insert {|X,Y|} (analz (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct)
apply (blast intro: analz.Fst analz.Snd)+
done

text{*Can pull out enCrypted message if the Key is not known*}
lemma analz_insert_Crypt:
     "Key (invKey K) \<notin> analz H
      ==> analz (insert (Crypt K X) H) = insert (Crypt K X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)

done

lemma lemma1: "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) \<subseteq>
               insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule_tac x = x in analz.induct, auto)
done

lemma lemma2: "Key (invKey K) \<in> analz H ==>
               insert (Crypt K X) (analz (insert X H)) \<subseteq>
               analz (insert (Crypt K X) H)"
apply auto
apply (erule_tac x = x in analz.induct, auto)
apply (blast intro: analz_insertI analz.Decrypt)
done

lemma analz_insert_Decrypt:
     "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) =
               insert (Crypt K X) (analz (insert X H))"
by (intro equalityI lemma1 lemma2)

text{*Case analysis: either the message is secure, or it is not! Effective,
but can cause subgoals to blow up! Use with @{text "split_if"}; apparently
@{text "split_tac"} does not cope with patterns such as @{term"analz (insert
(Crypt K X) H)"} *}
lemma analz_Crypt_if [simp]:
     "analz (insert (Crypt K X) H) =
          (if (Key (invKey K) \<in> analz H)
           then insert (Crypt K X) (analz (insert X H))
           else insert (Crypt K X) (analz H))"
by (simp add: analz_insert_Crypt analz_insert_Decrypt)

text{*This rule supposes "for the sake of argument" that we have the key.*}
lemma analz_insert_Crypt_subset:
     "analz (insert (Crypt K X) H) \<subseteq>
           insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule analz.induct, auto)
done

lemma analz_image_Key [simp]: "analz (Key`N) = Key`N"
apply auto
apply (erule analz.induct, auto)
done

subsubsection{*Idempotence and transitivity *}

lemma analz_analzD [dest!]: "X\<in> analz (analz H) ==> X\<in> analz H"
by (erule analz.induct, blast+)

lemma analz_idem [simp]: "analz (analz H) = analz H"
by blast

lemma analz_subset_iff [simp]: "(analz G \<subseteq> analz H) = (G \<subseteq> analz H)"
apply (rule iffI)
apply (iprover intro: subset_trans analz_increasing)
apply (frule analz_mono, simp)
done

lemma analz_trans: "[| X\<in> analz G;  G \<subseteq> analz H |] ==> X\<in> analz H"
by (drule analz_mono, blast)

declare analz_trans[intro]

lemma analz_cut: "[| Y\<in> analz (insert X H);  X\<in> analz H |] ==> Y\<in> analz H"
by (metis analz_idem analz_increasing analz_mono insert_absorb insert_mono insert_subset)

text{*This rewrite rule helps in the simplification of messages that involve
  the forwarding of unknown components (X).  Without it, removing occurrences
  of X can be very complicated. *}
lemma analz_insert_eq: "X\<in> analz H ==> analz (insert X H) = analz H"
by (blast intro: analz_cut analz_insertI)

text{*A congruence rule for "analz" *}

lemma analz_subset_cong:
     "[| analz G \<subseteq> analz G'; analz H \<subseteq> analz H' |]
      ==> analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
apply simp
apply (metis Un_absorb2 Un_commute Un_subset_iff Un_upper1 Un_upper2 analz_mono)
done

lemma analz_cong:
     "[| analz G = analz G'; analz H = analz H'
               |] ==> analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)

lemma analz_insert_cong:
     "analz H = analz H' ==> analz(insert X H) = analz(insert X H')"
by (force simp only: insert_def intro!: analz_cong)

text{*If there are no pairs or encryptions then analz does nothing*}
lemma analz_trivial:
     "[| \<forall>X Y. {|X,Y|} \<notin> H;  \<forall>X K. Crypt K X \<notin> H |] ==> analz H = H"
apply safe
apply (erule analz.induct, blast+)
done

text{*These two are obsolete (with a single Spy) but cost little to prove...*}
lemma analz_UN_analz_lemma:
     "X\<in> analz (\<Union>i\<in>A. analz (H i)) ==> X\<in> analz (\<Union>i\<in>A. H i)"
apply (erule analz.induct)
apply (blast intro: analz_mono [THEN [2] rev_subsetD])+
done

lemma analz_UN_analz [simp]: "analz (\<Union>i\<in>A. analz (H i)) = analz (\<Union>i\<in>A. H i)"
by (blast intro: analz_UN_analz_lemma analz_mono [THEN [2] rev_subsetD])

subsection{*Inductive relation "synth"*}

text{*Inductive definition of "synth" -- what can be built up from a set of
    messages.  A form of upward closure.  Pairs can be built, messages
    encrypted with known keys.  Agent names are public domain.
    Numbers can be guessed, but Nonces cannot be.  *}

inductive_set
  synth :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj    [intro]:   "X \<in> H ==> X \<in> synth H"
  | Agent  [intro]:   "Agent agt \<in> synth H"
  | Number [intro]:   "Number n  \<in> synth H"
  | Hash   [intro]:   "X \<in> synth H ==> Hash X \<in> synth H"
  | MPair  [intro]:   "[|X \<in> synth H;  Y \<in> synth H|] ==> {|X,Y|} \<in> synth H"
  | Crypt  [intro]:   "[|X \<in> synth H;  Key(K) \<in> H|] ==> Crypt K X \<in> synth H"

text{*Monotonicity*}
lemma synth_mono: "G\<subseteq>H ==> synth(G) \<subseteq> synth(H)"
  by (auto, erule synth.induct, auto)

text{*NO @{text Agent_synth}, as any Agent name can be synthesized.
  The same holds for @{term Number}*}
inductive_cases Nonce_synth [elim!]: "Nonce n \<in> synth H"
inductive_cases Key_synth   [elim!]: "Key K \<in> synth H"
inductive_cases Hash_synth  [elim!]: "Hash X \<in> synth H"
inductive_cases MPair_synth [elim!]: "{|X,Y|} \<in> synth H"
inductive_cases Crypt_synth [elim!]: "Crypt K X \<in> synth H"

lemma synth_increasing: "H \<subseteq> synth(H)"
by blast

subsubsection{*Unions *}

text{*Converse fails: we can synth more from the union than from the
  separate parts, building a compound message using elements of each.*}
lemma synth_Un: "synth(G) \<union> synth(H) \<subseteq> synth(G \<union> H)"
by (intro Un_least synth_mono Un_upper1 Un_upper2)

lemma synth_insert: "insert X (synth H) \<subseteq> synth(insert X H)"
by (metis insert_iff insert_subset subset_insertI synth.Inj synth_mono)

subsubsection{*Idempotence and transitivity *}

lemma synth_synthD [dest!]: "X\<in> synth (synth H) ==> X\<in> synth H"
by (erule synth.induct, blast+)

lemma synth_idem: "synth (synth H) = synth H"
by blast

lemma synth_subset_iff [simp]: "(synth G \<subseteq> synth H) = (G \<subseteq> synth H)"
apply (rule iffI)
apply (iprover intro: subset_trans synth_increasing)
apply (frule synth_mono, simp add: synth_idem)
done

lemma synth_trans: "[| X\<in> synth G;  G \<subseteq> synth H |] ==> X\<in> synth H"
by (drule synth_mono, blast)

lemma synth_cut: "[| Y\<in> synth (insert X H);  X\<in> synth H |] ==> Y\<in> synth H"
by (metis insert_absorb insert_mono insert_subset synth_idem synth_increasing synth_mono)

lemma Agent_synth [simp]: "Agent A \<in> synth H"
by blast

lemma Number_synth [simp]: "Number n \<in> synth H"
by blast

lemma Nonce_synth_eq [simp]: "(Nonce N \<in> synth H) = (Nonce N \<in> H)"
by blast

lemma Crypt_synth_eq [simp]:
     "Key K \<notin> H ==> (Crypt K X \<in> synth H) = (Crypt K X \<in> H)"
by blast

lemma keysFor_synth [simp]:
    "keysFor (synth H) = keysFor H \<union> invKey`{K. Key K \<in> H}"
by (unfold keysFor_def, blast)

subsubsection{*Combinations of parts, analz and synth *}

lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct)
apply (metis UnCI)
apply (metis MPair_synth UnCI UnE insert_absorb insert_subset parts.Fst parts_increasing)
apply (metis MPair_synth UnCI UnE insert_absorb insert_subset parts.Snd parts_increasing)
apply (metis Body Crypt_synth UnCI UnE insert_absorb insert_subset parts_increasing)
apply (metis Un_subset_iff parts_increasing parts_mono synth_increasing)
done

lemma analz_analz_Un [simp]: "analz (analz G \<union> H) = analz (G \<union> H)"
apply (rule equalityI)
apply (metis analz_idem analz_subset_cong order_eq_refl)
apply (metis analz_increasing analz_subset_cong order_eq_refl)
done

declare analz_mono [intro] analz.Fst [intro] analz.Snd [intro] Un_least [intro]

lemma analz_synth_Un [simp]: "analz (synth G \<union> H) = analz (G \<union> H) \<union> synth G"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct)
apply (metis UnCI UnE Un_commute analz.Inj)
apply (metis MPair_synth UnCI UnE Un_commute analz.Fst analz.Inj)
apply (metis MPair_synth UnCI UnE Un_commute analz.Inj analz.Snd)
apply (blast intro: analz.Decrypt)
apply blast
done

lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
proof -
  have "\<forall>x\<^sub>2 x\<^sub>1. synth x\<^sub>1 \<union> analz (x\<^sub>1 \<union> x\<^sub>2) = analz (synth x\<^sub>1 \<union> x\<^sub>2)" by (metis Un_commute analz_synth_Un)
  hence "\<forall>x\<^sub>1. synth x\<^sub>1 \<union> analz x\<^sub>1 = analz (synth x\<^sub>1 \<union> {})" by (metis Un_empty_right)
  hence "\<forall>x\<^sub>1. synth x\<^sub>1 \<union> analz x\<^sub>1 = analz (synth x\<^sub>1)" by (metis Un_empty_right)
  hence "\<forall>x\<^sub>1. analz x\<^sub>1 \<union> synth x\<^sub>1 = analz (synth x\<^sub>1)" by (metis Un_commute)
  thus "analz (synth H) = analz H \<union> synth H" by metis
qed

subsubsection{*For reasoning about the Fake rule in traces *}

lemma parts_insert_subset_Un: "X \<in> G ==> parts(insert X H) \<subseteq> parts G \<union> parts H"
proof -
  assume "X \<in> G"
  hence "\<forall>x\<^sub>1. G \<subseteq> x\<^sub>1 \<longrightarrow> X \<in> x\<^sub>1 " by auto
  hence "\<forall>x\<^sub>1. X \<in> G \<union> x\<^sub>1" by (metis Un_upper1)
  hence "insert X H \<subseteq> G \<union> H" by (metis Un_upper2 insert_subset)
  hence "parts (insert X H) \<subseteq> parts (G \<union> H)" by (metis parts_mono)
  thus "parts (insert X H) \<subseteq> parts G \<union> parts H" by (metis parts_Un)
qed

lemma Fake_parts_insert:
     "X \<in> synth (analz H) ==>
      parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
proof -
  assume A1: "X \<in> synth (analz H)"
  have F1: "\<forall>x\<^sub>1. analz x\<^sub>1 \<union> synth (analz x\<^sub>1) = analz (synth (analz x\<^sub>1))"
    by (metis analz_idem analz_synth)
  have F2: "\<forall>x\<^sub>1. parts x\<^sub>1 \<union> synth (analz x\<^sub>1) = parts (synth (analz x\<^sub>1))"
    by (metis parts_analz parts_synth)
  have F3: "X \<in> synth (analz H)" using A1 by metis
  have "\<forall>x\<^sub>2 x\<^sub>1\<Colon>msg set. x\<^sub>1 \<le> sup x\<^sub>1 x\<^sub>2" by (metis inf_sup_ord(3))
  hence F4: "\<forall>x\<^sub>1. analz x\<^sub>1 \<subseteq> analz (synth x\<^sub>1)" by (metis analz_synth)
  have F5: "X \<in> synth (analz H)" using F3 by metis
  have "\<forall>x\<^sub>1. analz x\<^sub>1 \<subseteq> synth (analz x\<^sub>1)
         \<longrightarrow> analz (synth (analz x\<^sub>1)) = synth (analz x\<^sub>1)"
    using F1 by (metis subset_Un_eq)
  hence F6: "\<forall>x\<^sub>1. analz (synth (analz x\<^sub>1)) = synth (analz x\<^sub>1)"
    by (metis synth_increasing)
  have "\<forall>x\<^sub>1. x\<^sub>1 \<subseteq> analz (synth x\<^sub>1)" using F4 by (metis analz_subset_iff)
  hence "\<forall>x\<^sub>1. x\<^sub>1 \<subseteq> analz (synth (analz x\<^sub>1))" by (metis analz_subset_iff)
  hence "\<forall>x\<^sub>1. x\<^sub>1 \<subseteq> synth (analz x\<^sub>1)" using F6 by metis
  hence "H \<subseteq> synth (analz H)" by metis
  hence "H \<subseteq> synth (analz H) \<and> X \<in> synth (analz H)" using F5 by metis
  hence "insert X H \<subseteq> synth (analz H)" by (metis insert_subset)
  hence "parts (insert X H) \<subseteq> parts (synth (analz H))" by (metis parts_mono)
  hence "parts (insert X H) \<subseteq> parts H \<union> synth (analz H)" using F2 by metis
  thus "parts (insert X H) \<subseteq> synth (analz H) \<union> parts H" by (metis Un_commute)
qed

lemma Fake_parts_insert_in_Un:
     "[|Z \<in> parts (insert X H);  X: synth (analz H)|]
      ==> Z \<in>  synth (analz H) \<union> parts H"
by (blast dest: Fake_parts_insert [THEN subsetD, dest])

declare synth_mono [intro]

lemma Fake_analz_insert:
     "X \<in> synth (analz G) ==>
      analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
by (metis Un_commute Un_insert_left Un_insert_right Un_upper1 analz_analz_Un
          analz_mono analz_synth_Un insert_absorb)

lemma Fake_analz_insert_simpler:
     "X \<in> synth (analz G) ==>
      analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
apply (rule subsetI)
apply (subgoal_tac "x \<in> analz (synth (analz G) \<union> H) ")
apply (metis Un_commute analz_analz_Un analz_synth_Un)
by (metis Un_upper1 Un_upper2 analz_mono insert_absorb insert_subset)

end


(*  Title:       Isabelle Collections Framework
    Author:      Peter Lammich <lammich at in.tum.de>
    Maintainer:  Peter Lammich <lammich at in.tum.de>
*)
section {* \isaheader{More Generic Algorithms} *}
theory Algos
imports
  "../spec/SetSpec"
  "../spec/MapSpec"
  "../spec/ListSpec"
begin
text_raw {*\label{thy:Algos}*}

subsection "Injective Map to Naturals"

text "Whether a set is an initial segment of the natural numbers"
definition inatseg :: "nat set \<Rightarrow> bool"
  where "inatseg s == \<exists>k. s = {i::nat. i<k}"

lemma inatseg_simps[simp]:
  "inatseg {}"
  "inatseg {0}"
  by (unfold inatseg_def)
    auto

text "Compute an injective map from objects into an initial
    segment of the natural numbers"
locale map_to_nat_loc =
  s: StdSet s_ops +
  m: StdMap m_ops
  for s_ops :: "('x,'s,'more1) set_ops_scheme"
  and m_ops :: "('x,nat,'m,'more2) map_ops_scheme"
begin

  definition map_to_nat
    :: "'s \<Rightarrow> 'm" where
    "map_to_nat s ==
      snd (s.iterate s (\<lambda>x (c,m). (c+1,m.update x c m)) (0,m.empty ()))"

  lemma map_to_nat_correct:
    assumes INV[simp]: "s.invar s"
    shows
      -- "All elements have got a number"
      "dom (m.\<alpha> (map_to_nat s)) = s.\<alpha> s" (is ?T1) and
      -- "No two elements got the same number"
      [rule_format]: "inj_on (m.\<alpha> (map_to_nat s)) (s.\<alpha> s)" (is ?T2) and
      -- "Numbering is inatseg"
      [rule_format]: "inatseg (ran (m.\<alpha> (map_to_nat s)))" (is ?T3) and
      -- "The result satisfies the map invariant"
      "m.invar (map_to_nat s)" (is ?T4)
    proof -
      have i_aux: "!!m S S' k v. \<lbrakk>inj_on m S; S' = insert k S; v\<notin>ran m\<rbrakk>
                                 \<Longrightarrow> inj_on (m(k\<mapsto>v)) S'"
        apply (rule inj_onI)
        apply (simp split: split_if_asm)
        apply (simp add: ran_def)
        apply (simp add: ran_def)
        apply blast
        apply (blast dest: inj_onD)
        done

      have "?T1 \<and> ?T2 \<and> ?T3 \<and> ?T4"
        apply (unfold map_to_nat_def)
        apply (rule_tac I="\<lambda>it (c,m).
          m.invar m \<and>
          dom (m.\<alpha> m) = s.\<alpha> s - it \<and>
          inj_on (m.\<alpha> m) (s.\<alpha> s - it) \<and>
          (ran (m.\<alpha> m) = {i. i<c})
          " in s.iterate_rule_P)
        apply simp
        apply (simp add: m.empty_correct)
        apply (case_tac \<sigma>)
        apply (simp add: m.empty_correct m.update_correct)
        apply (intro conjI)
        apply blast
        apply clarify
        apply (rule_tac m2="m.\<alpha> ba" and
                        k2=x and v2=aa and
                        S'2="(s.\<alpha> s - (it - {x}))" and
                        S2="(s.\<alpha> s - it)"
                        in i_aux)
        apply auto [3]
        apply auto [1]
        apply (case_tac \<sigma>)
        apply (auto simp add: inatseg_def)
        done
      thus ?T1 ?T2 ?T3 ?T4 by auto
    qed

end

subsection "Map from Set"
text "Build a map using a set of keys and a function to compute the values."

locale it_dom_fun_to_map_loc =
  s: StdSet s_ops
+ m: StdMap m_ops
  for s_ops :: "('k,'s,'more1) set_ops_scheme"
  and m_ops :: "('k,'v,'m,'more2) map_ops_scheme"
begin

  definition it_dom_fun_to_map ::
    "'s \<Rightarrow> ('k \<Rightarrow> 'v) \<Rightarrow> 'm"
    where "it_dom_fun_to_map s f ==
           s.iterate s (\<lambda>k m. m.update_dj k (f k) m) (m.empty ())"

  lemma it_dom_fun_to_map_correct:
    assumes INV: "s.invar s"
    shows "m.\<alpha> (it_dom_fun_to_map s f) k
      = (if k \<in> s.\<alpha> s then Some (f k) else None)" (is ?G1)
    and "m.invar (it_dom_fun_to_map s f)" (is ?G2)
  proof -
    have "m.\<alpha> (it_dom_fun_to_map s f) k
      = (if k \<in> s.\<alpha> s then Some (f k) else None) \<and>
      m.invar (it_dom_fun_to_map s f)"
      unfolding it_dom_fun_to_map_def
      apply (rule s.iterate_rule_P[where
        I = "\<lambda>it res. m.invar res
        \<and> (\<forall>k. m.\<alpha> res k = (if (k \<in> (s.\<alpha> s) - it) then Some (f k) else None))"
        ])
        apply (simp add: INV)

        apply (simp add: m.empty_correct)

        apply (subgoal_tac "x\<notin>dom (m.\<alpha> \<sigma>)")

        apply (auto simp: INV m.empty_correct m.update_dj_correct) []

        apply auto [2]
      done
    thus ?G1 and ?G2
      by auto
  qed

end

locale set_to_list_defs_loc =
  s: StdSetDefs s_ops
+ l: StdListDefs l_ops
  for s_ops :: "('x,'s,'more1) set_ops_scheme"
  and l_ops :: "('x,'l,'more2) list_ops_scheme"
begin
  definition "g_set_to_listl s \<equiv> s.iterate s l.appendl (l.empty ())"
  definition "g_set_to_listr s \<equiv> s.iterate s l.appendr (l.empty ())"
end

locale set_to_list_loc = set_to_list_defs_loc s_ops l_ops
+ s: StdSet s_ops
+ l: StdList l_ops
  for s_ops :: "('x,'s,'more1) set_ops_scheme"
  and l_ops :: "('x,'l,'more2) list_ops_scheme"
begin
  lemma g_set_to_listl_correct:
    assumes I: "s.invar s"
    shows "List.set (l.\<alpha> (g_set_to_listl s)) = s.\<alpha> s"
    and "l.invar (g_set_to_listl s)"
    and "distinct (l.\<alpha> (g_set_to_listl s))"
    using I apply -
    unfolding g_set_to_listl_def
    apply (rule_tac I="\<lambda>it \<sigma>. l.invar \<sigma> \<and> List.set (l.\<alpha> \<sigma>) = it
      \<and> distinct (l.\<alpha> \<sigma>)"
      in s.iterate_rule_insert_P, auto simp: l.correct)+
    done

  lemma g_set_to_listr_correct:
    assumes I: "s.invar s"
    shows "List.set (l.\<alpha> (g_set_to_listr s)) = s.\<alpha> s"
    and "l.invar (g_set_to_listr s)"
    and "distinct (l.\<alpha> (g_set_to_listr s))"
    using I apply -
    unfolding g_set_to_listr_def
    apply (rule_tac I="\<lambda>it \<sigma>. l.invar \<sigma> \<and> List.set (l.\<alpha> \<sigma>) = it
      \<and> distinct (l.\<alpha> \<sigma>)"
      in s.iterate_rule_insert_P, auto simp: l.correct)+
    done

end

end