(*******************************************************************************

  Project: Development of Security Protocols by Refinement

  Module:  Refinement/Atoms.thy (Isabelle/HOL 2016-1)
  ID:      $Id: Atoms.thy 132773 2016-12-09 15:30:22Z csprenge $
  Author:  Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Atomic messages for L1-L2 protocols

  Copyright (c) 2009-2016 Christoph Sprenger
  Licence: LGPL

*******************************************************************************)

section \<open>Atomic messages\<close>

theory Atoms imports Keys
begin

(******************************************************************************)
subsection \<open>Atoms datatype\<close>
(******************************************************************************)

datatype atom =
  aAgt "agent"
| aNon "nonce"
| aKey "key"
| aNum "nat"

(******************************************************************************)
subsection \<open>Long-term key setup (abstractly)\<close>
(******************************************************************************)

text \<open>Suppose an initial long-term key setup without looking into the
structure of long-term keys.

Remark: This setup is agnostic with respect to the structure of the
type @{typ "ltkey"}. Ideally, the type @{typ "ltkey"} should be a
parameter of the type @{typ "key"}, which is instantiated only at
Level 3.\<close>

consts
  ltkeySetup :: "(ltkey \<times> agent) set"  \<comment> \<open>LT key setup, for now unspecified\<close>

text \<open>The initial key setup contains static, long-term keys.\<close>

definition
  keySetup :: "(key \<times> agent) set" where
  "keySetup \<equiv> {(ltK K, A) | K A. (K, A) \<in> ltkeySetup}"

text \<open>Corrupted keys are the long-term keys known by bad agents.\<close>

definition
  corrKey :: "key set" where
  "corrKey \<equiv> keySetup\<inverse> `` bad"

lemma corrKey_Dom_keySetup [simp, intro]: "K \<in> corrKey \<Longrightarrow> K \<in> Domain keySetup"
by (auto simp add: corrKey_def)

lemma keySetup_noSessionKeys [simp]: "(sesK K, A) \<notin> keySetup"
by (simp add: keySetup_def)

lemma corrKey_noSessionKeys [simp]: "sesK K \<notin> corrKey"
by (auto simp add: keySetup_def corrKey_def)

end


section \<open>Simplied Version of Gordeev's Proof for Monotone Circuits\<close>

subsection \<open>Setup of Global Assumptions and Proofs of Approximations\<close>

theory Assumptions_and_Approximations
imports
  "HOL-Real_Asymp.Real_Asymp"
  Stirling_Formula.Stirling_Formula
  Preliminaries
begin

locale first_assumptions =
  fixes l p k :: nat
  assumes l2: "l > 2"
  and pl: "p > l"
  and kp: "k > p"
begin

lemma k2: "k > 2" using pl l2 kp by auto
lemma p: "p > 2" using pl l2 kp by auto
lemma k: "k > l" using pl l2 kp by auto

definition "m = k^4"

lemma km: "k < m"
  using power_strict_increasing_iff[of k 1 4] k2 unfolding m_def by auto

lemma lm: "l + 1 < m" using km k by simp

lemma m2: "m > 2" using k2 km by auto

lemma mp: "m > p" using km k kp by simp

definition "L = fact l * (p - 1) ^ l"

lemma kml: "k \<le> m - l"
proof -
  have "k \<le> k * k - k" using k2 by (cases k, auto)
  also have "\<dots> \<le> (k * k) * 1 - l" using k by simp
  also have "\<dots> \<le> (k * k) * (k * k) - l"
    by (intro diff_le_mono mult_left_mono, insert k2, auto)
  also have "(k * k) * (k * k) = m" unfolding m_def by algebra
  finally show ?thesis .
qed
end

locale second_assumptions = first_assumptions +
  assumes kl2: "k = l^2"
  and l8: "l \<ge> 8"
begin

lemma Lm: "L \<ge> m"
proof -
  have "m \<le> l ^ l"
    unfolding L_def m_def
    unfolding kl2 power_mult[symmetric]
    by (intro power_increasing, insert l8, auto)
  also have "\<dots> \<le> (p - 1) ^ l"
    by (rule power_mono, insert pl, auto)
  also have "\<dots> \<le> fact l * (p - 1) ^ l" by simp
  also have "\<dots> \<le> L" unfolding L_def by simp
  finally show ?thesis .
qed

lemma L3: "L > 3" using p Lp by auto
end

definition "eps = 1/(1000 :: real)"
lemma eps: "eps > 0" unfolding eps_def by simp

definition L0 :: nat where
  "L0 = (SOME l0. \<forall>l\<ge>l0. 1 / 3 < (1 + - 1 / real l) ^ l)"

definition M0 :: nat where
  "M0 = (SOME y. \<forall> x. x \<ge> y \<longrightarrow> (root 8 (real x) * log 2 (real x) + 1) / real x powr (1 / 8 + eps) \<le> 1)"

definition L0' :: nat where
  "L0' = (SOME l0. \<forall> n \<ge> l0. 6 * (real n)^16 * fact n < real (n\<^sup>2 ^ 4) powr (1 / 8 * real (n\<^sup>2 ^ 4) powr (1 / 8)))"

definition L0'' :: nat where "L0'' = (SOME l0. \<forall> l \<ge> l0. real l * log 2 (real (l\<^sup>2 ^ 4)) + 1 < real (l\<^sup>2))"

lemma L0'': assumes "l \<ge> L0''" shows "real l * log 2 (real (l\<^sup>2 ^ 4)) + 1 < real (l\<^sup>2)"
proof -
  have "(\<lambda> l :: nat. (real l * log 2 (real (l\<^sup>2 ^ 4)) + 1) / real (l\<^sup>2)) \<longlonglongrightarrow> 0" by real_asymp
  from LIMSEQ_D[OF this, of 1] obtain l0
    where "\<forall>l\<ge>l0. \<bar>1 + real l * log 2 (real l ^ 8)\<bar> / (real l)\<^sup>2 < 1" by (auto simp: field_simps)
  hence "\<forall> l \<ge> max 1 l0. real l * log 2 (real (l\<^sup>2 ^ 4)) + 1 < real (l\<^sup>2)"
    by (auto simp: field_simps)
  hence "\<exists> l0. \<forall> l \<ge> l0. real l * log 2 (real (l\<^sup>2 ^ 4)) + 1 < real (l\<^sup>2)" by blast
  from someI_ex[OF this, folded L0''_def, rule_format, OF assms]
  show ?thesis .
qed

definition M0' :: nat where
  "M0' = (SOME x0. \<forall> x \<ge> x0. real x powr (2 / 3) \<le> x powr (3 / 4) - 1)"

locale third_assumptions = second_assumptions +
  assumes pllog: "l * log 2 m \<le> p" "real p \<le> l * log 2 m + 1"
    and L0: "l \<ge> L0"
    and L0': "l \<ge> L0'"
    and M0': "m \<ge> M0'"
    and M0: "m \<ge> M0"
begin

lemma approximation1:
  "(real (k - 1)) ^ (m - l) * prod (\<lambda> i. real (k - 1 - i)) {0..<l}
   > (real (k - 1)) ^ m / 3"
proof -
have "real (k - 1) ^ (m - l) * (\<Prod>i = 0..<l. real (k - 1 - i)) =
    real (k - 1) ^ m *
    (inverse (real (k - 1)) ^ l * (\<Prod>i = 0..<l. real (k - 1 - i)))"
    by (subst power_diff_conv_inverse, insert k2 lm, auto)
  also have "\<dots> > (real (k - 1)) ^ m * (1/3)"
  proof (rule mult_strict_left_mono)
    define f where "f l = (1  + (-1) / real l) ^ l" for l
    define e1 :: real where "e1 = exp (- 1)"
    define lim :: real where "lim = 1 / 3"
    from tendsto_exp_limit_sequentially[of "-1", folded f_def]
    have f: "f \<longlonglongrightarrow> e1" by (simp add: e1_def)
    have "lim < (1 - 1 / real 6) ^ 6" unfolding lim_def by code_simp
    also have " \<dots> \<le> exp (- 1)"
      by (rule exp_ge_one_minus_x_over_n_power_n, auto)
    finally have "lim < e1" unfolding e1_def by auto
    with f have "\<exists> l0. \<forall> l. l \<ge> l0 \<longrightarrow> f l > lim"
      by (metis eventually_sequentially order_tendstoD(1))
    from someI_ex[OF this[unfolded f_def lim_def], folded L0_def] L0
    have fl: "f l > 1/3" unfolding f_def by auto
    define start where "start = inverse (real (k - 1)) ^ l * (\<Prod>i = 0..<l. real (k - 1 - i))"
    have "uminus start
      = uminus (prod (\<lambda> _. inverse (real (k - 1))) {0..<l} * prod (\<lambda> i. real (k - 1 - i)) {0 ..< l})"
      by (simp add: start_def)
    also have "\<dots> = uminus (prod (\<lambda> i. inverse (real (k - 1)) * real (k - 1 - i)) {0..<l})"
      by (subst prod.distrib, simp)
    also have "\<dots> \<le> uminus (prod (\<lambda> i. inverse (real (k - 1)) * real (k - 1 - (l - 1))) {0..<l})"
      unfolding neg_le_iff_le
      by (intro prod_mono conjI mult_left_mono, insert k2 l2, auto intro!: diff_le_mono2)
    also have "\<dots> = uminus ((inverse (real (k - 1)) * real (k - l)) ^ l)" by simp
    also have "inverse (real (k - 1)) * real (k - l) = inverse (real (k - 1)) * ((real (k - 1)) - (real l - 1))"
      using l2 k2 k by simp
    also have "\<dots> = 1 - (real l - 1) / (real (k - 1))" using l2 k2 k
      by (simp add: field_simps)
    also have "real (k - 1) = real k - 1" using k2 by simp
    also have "\<dots> = (real l - 1) * (real l + 1)" unfolding kl2 of_nat_power
      by (simp add: field_simps power2_eq_square)
    also have "(real l - 1) / \<dots> = inverse (real l + 1)"
      using l2 by (smt (verit, best) divide_divide_eq_left' divide_inverse nat_1_add_1 nat_less_real_le nonzero_mult_div_cancel_left of_nat_1 of_nat_add)
    also have "- ((1 - inverse (real l + 1)) ^ l) \<le> - ((1 - inverse (real l)) ^ l)"
      unfolding neg_le_iff_le
      by (intro power_mono, insert l2, auto simp: field_simps)
    also have "\<dots> < - (1/3)" using fl unfolding f_def by (auto simp: field_simps)
    finally have start: "start > 1 / 3" by simp
    thus "inverse (real (k - 1)) ^ l * (\<Prod>i = 0..<l. real (k - 1 - i)) > 1/3"
      unfolding start_def by simp
  qed (insert k2, auto)
  finally show ?thesis by simp
qed

lemma approximation2: fixes s :: nat
  assumes "m choose k \<le> s * L\<^sup>2 * (m - l - 1 choose (k - l - 1))"
  shows "((m - l) / k)^l / (6 * L^2) < s"
proof -
  let ?r = real
  define q where "q = (?r (L\<^sup>2) * ?r (m - l - 1 choose (k - l - 1)))"
  have q: "q > 0" unfolding q_def
    by (insert L3 km, auto)
  have "?r (m choose k) \<le> ?r (s * L\<^sup>2 * (m - l - 1 choose (k - l - 1)))"
    unfolding of_nat_le_iff using assms by simp
  hence "m choose k \<le> s * q" unfolding q_def by simp
  hence *: "s \<ge> (m choose k) / q" using q by (metis mult_imp_div_pos_le)
  have "(((m - l) / k)^l / (L^2)) / 6 < ((m - l) / k)^l / (L^2) / 1"
    by (rule divide_strict_left_mono, insert m2 L3 lm k, auto intro!: mult_pos_pos divide_pos_pos zero_less_power)
  also have "\<dots> =  ((m - l) / k)^l / (L^2)" by simp
  also have "\<dots> \<le> ((m choose k) / (m - l - 1 choose (k - l - 1))) / (L^2)"
  proof (rule divide_right_mono)
    define b where "b = ?r (m - l - 1 choose (k - l - 1))"
    define c where "c = (?r k)^l"
    have b0: "b > 0" unfolding b_def using km l2 by simp
    have c0: "c > 0" unfolding c_def using k by auto
    define aim where "aim = (((m - l) / k)^l \<le> (m choose k) / (m - l - 1 choose (k - l - 1)))"
    have "aim \<longleftrightarrow> ((m - l) / k)^l \<le> (m choose k) / b" unfolding b_def aim_def by simp
    also have "\<dots> \<longleftrightarrow> b * ((m - l) / k)^l \<le> (m choose k)" using b0
      by (simp add: mult.commute pos_le_divide_eq)
    also have "\<dots> \<longleftrightarrow> b * (m - l)^l / c \<le> (m choose k)"
      by (simp add: power_divide c_def)
    also have "\<dots> \<longleftrightarrow> b * (m - l)^l \<le> (m choose k) * c" using c0 b0
      by (auto simp add: mult.commute pos_divide_le_eq)
    also have "(m choose k) = fact m / (fact k * fact (m - k))"
      by (rule binomial_fact, insert km, auto)
    also have "b = fact (m - l - 1) / (fact (k - l - 1) * fact (m - l - 1 - (k - l - 1)))" unfolding b_def
      by (rule binomial_fact, insert k km, auto)
    finally have "aim \<longleftrightarrow>
          fact (m - l - 1) / fact (k - l - 1) * (m - l) ^ l / fact (m - l - 1 - (k - l - 1))
       \<le> (fact m / fact k) * (?r k)^l / fact (m - k)" unfolding c_def by simp
    also have "m - l - 1 - (k - l - 1) = m - k" using l2 k km by simp
    finally have "aim \<longleftrightarrow>
          fact (m - l - 1) / fact (k - l - 1) * ?r (m - l) ^ l
        \<le> fact m / fact k * ?r k ^ l" unfolding divide_le_cancel using km by simp
    also have "\<dots> \<longleftrightarrow> (fact (m - (l + 1)) * ?r (m - l) ^ l)  * fact k
                     \<le> (fact m / k) * (fact (k - (l + 1)) * (?r k * ?r k ^ l))"
      using k2
      by (simp add: field_simps)
    also have "\<dots>"
    proof (intro mult_mono)
      have "fact k \<le> fact (k - (l + 1)) * (?r k ^ (l + 1))"
        by (rule fact_approx_minus, insert k, auto)
      also have "\<dots> = (fact (k - (l + 1)) * ?r k ^ l)  * ?r k" by simp
      finally show "fact k \<le> fact (k - (l + 1)) * (?r k * ?r k ^ l)" by (simp add: field_simps)
      have "fact (m - (l + 1)) * real (m - l) ^ l \<le> fact m / k \<longleftrightarrow>
        (fact (m - (l + 1)) * ?r k) * real (m - l) ^ l \<le> fact m" using k2 by (simp add: field_simps)
      also have "\<dots>"
      proof -
        have "(fact (m - (l + 1)) * ?r k) * ?r (m - l) ^ l \<le>
              (fact (m - (l + 1)) * ?r (m - l)) * ?r (m - l) ^ l"
          by (intro mult_mono, insert kml, auto)
        also have "((fact (m - (l + 1)) * ?r (m - l)) * ?r (m - l) ^ l) =
              (fact (m - (l + 1)) * ?r (m - l) ^ (l + 1))" by simp
        also have "\<dots> \<le> fact m"
          by (rule fact_approx_upper_minus, insert km k, auto)
        finally show "fact (m - (l + 1)) * real k * real (m - l) ^ l \<le> fact m" .
      qed
      finally show "fact (m - (l + 1)) * real (m - l) ^ l \<le> fact m / k"  .
    qed auto
    finally show "((m - l) / k)^l \<le> (m choose k) / (m - l - 1 choose (k - l - 1))"
      unfolding aim_def .
  qed simp
  also have "\<dots> = (m choose k) / q"
    unfolding q_def by simp
  also have "\<dots> \<le> s" using q * by metis
  finally show "((m - l) / k)^l / (6 * L^2) < s" by simp
qed

lemma approximation3: fixes s :: nat
  assumes "(k - 1)^m / 3 < (s * (L\<^sup>2 * (k - 1) ^ m)) / 2 ^ (p - 1)"
  shows "((m - l) / k)^l / (6 * L^2) < s"
proof -
  define A where "A = real (L\<^sup>2 * (k - 1) ^ m)"
  have A0: "A > 0" unfolding A_def using L3 k2 m2 by simp
  from mult_strict_left_mono[OF assms, of "2 ^ (p - 1)"]
  have "2^(p - 1) * (k - 1)^m / 3 < s * A"
    by (simp add: A_def)
  from divide_strict_right_mono[OF this, of A] A0
  have "2^(p - 1) * (k - 1)^m / 3 / A < s"
    by simp
  also have "2^(p - 1) * (k - 1)^m / 3 / A = 2^(p - 1) / (3 * L^2)"
    unfolding A_def using k2 by simp
  also have "\<dots> = 2^p / (6 * L^2)" using p by (cases p, auto)
  also have "2^p = 2 powr p"
    by (simp add: powr_realpow)
  finally have *: "2 powr p / (6 * L\<^sup>2) < s" .
  have "m ^ l = m powr l" using m2 l2 powr_realpow by auto
  also have "\<dots> = 2 powr (log 2 m * l)"
    unfolding powr_powr[symmetric]
    by (subst powr_log_cancel, insert m2, auto)
  also have "\<dots> = 2 powr (l * log 2 m)" by (simp add: ac_simps)
  also have "\<dots> \<le> 2 powr p"
    by (rule powr_mono, insert pllog, auto)
  finally have "m ^ l \<le> 2 powr p" .
  from divide_right_mono[OF this, of "6 * L\<^sup>2"] *
  have "m ^ l / (6 * L\<^sup>2) < s" by simp
  moreover have "((m - l) / k)^l / (6 * L^2) \<le> m^l / (6 * L^2)"
  proof (rule divide_right_mono, unfold of_nat_power, rule power_mono)
    have "real (m - l) / real k \<le> real (m - l) / 1"
      using k2 lm by (intro divide_left_mono, auto)
    also have "\<dots> \<le> m" by simp
    finally show "(m - l) / k \<le> m" by simp
  qed auto
  ultimately show ?thesis by simp
qed

lemma identities: "k = root 4 m" "l = root 8 m"
proof -
  let ?r = real
  have "?r k ^ 4 = ?r m" unfolding m_def by simp
  from arg_cong[OF this, of "root 4"]
  show km_id: "k = root 4 m" by (simp add: real_root_pos2)
  have "?r l ^ 8 = ?r m" unfolding m_def using kl2 by simp
  from arg_cong[OF this, of "root 8"]
  show lm_id: "l = root 8 m" by (simp add: real_root_pos2)
qed

lemma identities2: "root 4 m = m powr (1/4)" "root 8 m = m powr (1/8)"
  by (subst root_powr_inverse, insert m2, auto)+

lemma appendix_A_1: assumes "x \<ge> M0'" shows "x powr (2/3) \<le> x powr (3/4) - 1"
proof -
  have "(\<lambda> x. x powr (2/3) / (x powr (3/4) - 1)) \<longlonglongrightarrow> 0"
    by real_asymp
  from LIMSEQ_D[OF this, of 1, simplified] obtain x0 :: nat where
    sub: "x \<ge> x0 \<Longrightarrow> x powr (2 / 3) / \<bar>x powr (3/4) - 1\<bar> < 1" for x
    by (auto simp: field_simps)
  have "(\<lambda> x :: real. 2 / (x powr (3/4))) \<longlonglongrightarrow> 0"
    by real_asymp
  from LIMSEQ_D[OF this, of 1, simplified] obtain x1 :: nat where
    sub2: "x \<ge> x1 \<Longrightarrow> 2 / x powr (3 / 4) < 1" for x by auto
  {
    fix x
    assume x: "x \<ge> x0" "x \<ge> x1" "x \<ge> 1"
    define a where "a = x powr (3/4) - 1"
    from sub[OF x(1)] have small: "x powr (2 / 3) / \<bar>a\<bar> \<le> 1"
      by (simp add: a_def)
    have 2: "2 \<le> x powr (3/4)" using sub2[OF x(2)] x(3) by simp
    hence a: "a > 0" by (simp add: a_def)
    from mult_left_mono[OF small, of a] a
    have "x powr (2 / 3) \<le> a"
      by (simp add: field_simps)
    hence "x powr (2 / 3) \<le> x powr (3 / 4) - 1" unfolding a_def by simp
  }
  hence "\<exists> x0 :: nat. \<forall> x \<ge> x0. x powr (2 / 3) \<le> x powr (3 / 4) - 1"
    by (intro exI[of _ "max x0 (max x1 1)"], auto)
  from someI_ex[OF this, folded M0'_def, rule_format, OF assms]
  show ?thesis .
qed

lemma appendix_A_2: "(p - 1)^l < m powr ((1 / 8 + eps) * l)"
proof -
  define f where "f (x :: nat) = (root 8 x * log 2 x + 1) / (x powr (1/8 + eps))" for x
  have "f \<longlonglongrightarrow> 0" using eps unfolding f_def by real_asymp
  from LIMSEQ_D[OF this, of 1]
  have ex: "\<exists> x. \<forall> y. y  \<ge> x \<longrightarrow> f y \<le> 1" by fastforce
  have lim: "root 8 m * log 2 m + 1 \<le> m powr (1 / 8 + eps)"
    using someI_ex[OF ex[unfolded f_def], folded M0_def, rule_format, OF M0] m2
    by (simp add: field_simps)
  define start where "start = real (p - 1)^l"
  have "(p - 1)^l < p ^ l"
    by (rule power_strict_mono, insert p l2, auto)
  hence "start < real (p ^ l)"
    using start_def of_nat_less_of_nat_power_cancel_iff by blast
  also have "\<dots> = p powr l"
    by (subst powr_realpow, insert p, auto)
  also have "\<dots> \<le> (l * log 2 m + 1) powr l"
    by (rule powr_mono2, insert pllog, auto)
  also have "l = root 8 m" unfolding identities by simp
  finally have "start < (root 8 m * log 2 m + 1) powr root 8 m"
    by (simp add: identities2)
  also have "\<dots> \<le> (m powr (1 / 8 + eps)) powr root 8 m"
    by (rule powr_mono2[OF _ _ lim], insert m2, auto)
  also have "\<dots> = m powr ((1 / 8 + eps) * l)" unfolding powr_powr identities ..
  finally show ?thesis unfolding start_def by simp
qed

lemma appendix_A_3: "6 * real l^16 * fact l < m powr (1 / 8 * l)"
proof -
  define f where "f = (\<lambda>n. 6 * (real n)^16 * (sqrt (2 * pi * real n) * (real n / exp 1) ^ n))"
  define g where "g = (\<lambda> n. 6 * (real n)^16 * (sqrt (2 * 4 * real n) * (real n / 2) ^ n))"
  define h where "h = (\<lambda> n. ((real (n\<^sup>2 ^ 4) powr (1 / 8 * (real (n\<^sup>2 ^ 4)) powr (1/8)))))"
  have e: "2 \<le> (exp 1 :: real)" using exp_ge_add_one_self[of 1] by simp
  from fact_asymp_equiv
  have 1: "(\<lambda> n. 6 * (real n)^16 * fact n / h n) \<sim>[sequentially] (\<lambda> n. f n / h n)" unfolding f_def
    by (intro asymp_equiv_intros)
  have 2: "f n \<le> g n" for n unfolding f_def g_def
    by (intro mult_mono power_mono divide_left_mono real_sqrt_le_mono, insert pi_less_4 e, auto)
  have 2: "abs (f n / h n) \<le> abs (g n / h n)" for n
    unfolding abs_le_square_iff power2_eq_square
    by (intro mult_mono divide_right_mono 2, auto simp: h_def f_def g_def)
  have 2: "abs (g n / h n) < e \<Longrightarrow> abs (f n / h n) < e" for n e using 2[of n] by simp
  have "(\<lambda>n. g n / h n) \<longlonglongrightarrow> 0"
    unfolding g_def h_def by real_asymp
  from LIMSEQ_D[OF this] 2
  have "(\<lambda>n. f n / h n) \<longlonglongrightarrow> 0"
    by (intro LIMSEQ_I, fastforce)
  with 1 have "(\<lambda>n. 6 * (real n)^16 * fact n / h n) \<longlonglongrightarrow> 0"
    using tendsto_asymp_equiv_cong by blast
  from LIMSEQ_D[OF this, of 1] obtain n0 where 3: "n \<ge> n0 \<Longrightarrow> norm (6 * (real n)^16 * fact n / h n) < 1" for n by auto
  {
    fix n
    assume n: "n \<ge> max 1 n0"
    hence hn: "h n > 0" unfolding h_def by auto
    from n have "n \<ge> n0" by simp
    from 3[OF this] have "6 * n ^ 16 * fact n / abs (h n) < 1" by auto
    with hn have "6 * (real n) ^ 16 * fact n < h n" by simp
  }
  hence "\<exists> n0. \<forall> n. n \<ge> n0 \<longrightarrow> 6 * n ^ 16 * fact n < h n" by blast
  from someI_ex[OF this[unfolded h_def], folded L0'_def, rule_format, OF L0']
  have "6 * real l^16 * fact l < real (l\<^sup>2 ^ 4) powr (1 / 8 * real (l\<^sup>2 ^ 4) powr (1 / 8))" by simp
  also have "\<dots> = m powr (1 / 8 * l)" using identities identities2 kl2
    by (metis m_def)
  finally show ?thesis .
qed

lemma appendix_A_4: "12 * L^2 \<le> m powr (m powr (1 / 8) * 0.51)"
proof -
  let ?r = real
  define Lappr where "Lappr = m * m * fact l * p ^ l / 2"
  have "L = (fact l * (p - 1) ^ l)" unfolding L_def by simp
  hence "?r L \<le> (fact l * (p - 1) ^ l)" by linarith
  also have "\<dots> = (1 * ?r (fact l)) * (?r (p - 1) ^ l)" by simp
  also have "\<dots> \<le> ((m * m / 2) * ?r (fact l)) * (?r (p - 1) ^ l)"
    by (intro mult_right_mono, insert m2, cases m; cases "m - 1", auto)
  also have "\<dots> = (6 * real (m * m) * fact l) * (?r (p - 1) ^ l) / 12" by simp
  also have "real (m * m) = real l^16" unfolding m_def unfolding kl2 by simp
  also have "(6 * real l^16 * fact l) * (?r (p - 1) ^ l) / 12
    \<le> (m powr (1 / 8 * l) * (m powr ((1 / 8 + eps) * l))) / 12"
    by (intro divide_right_mono mult_mono, insert appendix_A_2 appendix_A_3, auto)
  also have "\<dots> = (m powr (1 / 8 * l + (1 / 8 + eps) * l)) / 12"
    by (simp add: powr_add)
  also have "1 / 8 * l + (1 / 8 + eps) * l = l * (1/4 + eps)" by (simp add: field_simps)
  also have "l = m powr (1/8)" unfolding identities identities2 ..
  finally have LL: "?r L \<le> m powr (m powr (1 / 8) * (1 / 4 + eps)) / 12" .
  from power_mono[OF this, of 2]
  have "L^2 \<le> (m powr (m powr (1 / 8) * (1 / 4 + eps)) / 12)^2"
    by simp
  also have "\<dots> = (m powr (m powr (1 / 8) * (1 / 4 + eps)))^2 / 144"
    by (simp add: power2_eq_square)
  also have "\<dots> = (m powr (m powr (1 / 8) * (1 / 4 + eps) * 2)) / 144"
    by (subst powr_realpow[symmetric], (use m2 in force), unfold powr_powr, simp)
  also have "\<dots> = (m powr (m powr (1 / 8) * (1 / 2 + 2 * eps))) / 144"
    by (simp add: algebra_simps)
  also have "\<dots> \<le> (m powr (m powr (1 / 8) * 0.51)) / 144"
    by (intro divide_right_mono powr_mono mult_left_mono, insert m2, auto simp: eps_def)
  finally have "L^2 \<le> m powr (m powr (1 / 8) * 0.51) / 144" by simp
  from mult_left_mono[OF this, of 12]
  have "12 * L^2 \<le> 12 * m powr (m powr (1 / 8) * 0.51) / 144" by simp
  also have "\<dots> = m powr (m powr (1 / 8) * 0.51) / 12" by simp
  also have "\<dots> \<le> m powr (m powr (1 / 8) * 0.51) / 1"
    by (rule divide_left_mono, auto)
  finally show ?thesis by simp
qed

lemma approximation4: fixes s :: nat
  assumes "s > ((m - l) / k)^l / (6 * L^2)"
  shows "s > 2 * k powr (4 / 7 * sqrt k)"
proof -
  let ?r = real
  have diff: "?r (m - l) = ?r m - ?r l" using lm by simp
  have "m powr (2/3) \<le> m powr (3/4) - 1" using appendix_A_1[OF M0'] by auto
  also have "\<dots> \<le> (m - m powr (1/8)) / m powr (1/4)"
    unfolding diff_divide_distrib
    by (rule diff_mono, insert m2, auto simp: divide_powr_uminus powr_mult_base powr_add[symmetric],
      auto simp: powr_minus_divide intro!: ge_one_powr_ge_zero)
  also have "\<dots> = (m - root 8 m) / root 4 m" using m2
    by (simp add: root_powr_inverse)
  also have "\<dots> = (m - l) / k" unfolding identities diff by simp
  finally have "m powr (2/3) \<le> (m - l) / k" by simp
  from power_mono[OF this, of l]
  have ineq1: "(m powr (2 / 3)) ^ l \<le> ((m - l) / k) ^ l"  using m2 by auto
  have "(m powr (l / 7)) \<le> (m powr (2 / 3 * l - l * 0.51))"
    by (intro powr_mono, insert m2, auto)
  also have "\<dots> = (m powr (2 / 3)) powr l / (m powr (m powr (1 / 8) * 0.51))"
    unfolding powr_diff powr_powr identities identities2 by simp
  also have "\<dots> = (m powr (2 / 3)) ^ l / (m powr (m powr (1 / 8) * 0.51))"
    by (subst powr_realpow, insert m2, auto)
  also have "\<dots> \<le> (m powr (2 / 3)) ^ l / (12 * L\<^sup>2)"
    by (rule divide_left_mono[OF appendix_A_4], insert L3 m2, auto intro!: mult_pos_pos)
  also have "\<dots> = (m powr (2 / 3)) ^ l / (?r 12 * L\<^sup>2)" by simp
  also have "\<dots> \<le> ((m - l) / k) ^ l / (?r 12 * L\<^sup>2)"
    by (rule divide_right_mono[OF ineq1], insert L3, auto)
  also have "\<dots> < s / 2" using assms by simp
  finally have "2 * m powr (real l / 7) < s" by simp
  also have "m powr (real l / 7) = m powr (root 8 m / 7)"
    unfolding identities by simp
  finally have "s > 2 * m powr (root 8 m / 7)" by simp
  also have "root 8 m = root 2 k" using m2
    by (metis identities(2) kl2 of_nat_0_le_iff of_nat_power pos2 real_root_power_cancel)
  also have "?r m = k powr 4" unfolding m_def by simp
  also have "(k powr 4) powr ((root 2 k) / 7)
     = k powr (4 * (root 2 k) / 7)" unfolding powr_powr by simp
  also have "\<dots> = k powr (4 / 7 * sqrt k)" unfolding sqrt_def by simp
  finally show "s > 2 * k powr (4 / 7 * sqrt k)" .
qed

end

end


subsection \<open>Secure multiplication protocol\<close>

theory Secure_Multiplication imports
  CryptHOL.Cyclic_Group_SPMF
  Uniform_Sampling
  Semi_Honest
begin

locale secure_mult =
  fixes q :: nat
  assumes q_gt_0: "q > 0"
begin

type_synonym real_view = "nat list \<Rightarrow> ((nat \<times> nat \<times> nat)) spmf"
type_synonym sim = "nat \<Rightarrow> nat \<Rightarrow> ((nat \<times> nat \<times> nat)) spmf"

lemma samp_uni_set_spmf [simp]: "set_spmf (sample_uniform q) = {..< q}"
  by(simp add: sample_uniform_def)

fun funct :: "nat list \<Rightarrow> (nat list) spmf"
  where "funct [x, y] = do {
    s \<leftarrow> sample_uniform q;
    return_spmf [s, (x*y + (q - s)) mod q]}"

definition TI :: "((nat \<times> nat) \<times> (nat \<times> nat)) spmf"
  where "TI = do {
    a \<leftarrow> sample_uniform q;
    b \<leftarrow> sample_uniform q;
    r \<leftarrow> sample_uniform q;
    return_spmf ((a, r), (b, ((a*b + (q - r)) mod q)))}"

lemma party1_view_e1_c2:
  assumes e: "e1 = (y + (q - c2)) mod q" and c: "c2 < q" and "y < q"
  shows "c2 = (y + q - e1) mod q"
proof-
  have "[e1 = (y + (q - c2))] (mod q)"
    using assms cong_def by simp
  hence *: "[e1 + c2 = y + q] (mod q)"
    by (smt ab_semigroup_add_class.add_ac(1) add.commute assms(2) cong_add_lcancel_nat le_add_diff_inverse order_less_imp_le)
  hence "[c2 = (y + q) - e1] (mod q)"
  proof-
    have "(y + q) - e1 > 0"
      by (metis e add_gr_0 mod_le_divisor mod_less_divisor ordered_cancel_comm_monoid_diff_class.diff_add_assoc q_gt_0 zero_less_diff)
    thus ?thesis
    proof -
      have "[e1 = e1] (mod q)"
        by simp
      then show ?thesis
        by (metis (no_types) \<open>0 < y + q - e1\<close> \<open>[e1 + c2 = y + q] (mod q)\<close> cong_diff_nat diff_add_inverse le_add_same_cancel1 order_less_imp_le zero_le zero_less_diff)
    qed
  qed
  thus ?thesis
    by (metis mod_if cong_def c)
qed

fun outputs1 :: "nat list \<Rightarrow> (nat \<times> nat \<times> nat) \<Rightarrow> (nat list) spmf"
  where "outputs1 [x, y] view = do {
    let (c1, d1, e1) = view;
    let c2 = (y + q - e1) mod q;
    let d2 = ((c1*c2 + (q - d1)) mod q);
    let e2 = (x + c1) mod q;
    return_spmf [((x*e1 + (q - d1)) mod q), ((e2 * c2 + (q - d2)) mod q)]}"

fun R1 :: "real_view"
  where "R1 [x, y] = do {
    ((c1, d1), (c2, d2)) \<leftarrow> TI;
    let e2 = (x + c1) mod q;
    let e1 = (y + (q - c2)) mod q;
    let s1 = (x*e1 + (q - d1)) mod q;
    let s2 = (e2 * c2 + (q - d2)) mod q;
    return_spmf ((c1, d1, e1))}"

definition S1 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<times> nat) spmf"
  where "S1 x s1 = do {
    a :: nat \<leftarrow> sample_uniform q;
    e1 \<leftarrow> sample_uniform q;
    let d1 = (x*e1 + (q - s1)) mod q;
    return_spmf (a, d1, e1)}"

lemma assumes e: "e2 = (x + a) mod q" and "d2 = (a*b + (q - r)) mod q" and "x < q" and  "a < q" and "b < q" and "r < q"
  shows "r = (((e2 + q - x) mod q) * b + q - d2) mod q"
proof-
  have d2_lt_q: "d2 < q" using assms by simp
  have "a = (e2 + q - x) mod q"
  proof-
    have "[e2 + q = x + a] (mod q)" using e cong_def by force
    hence "[e2 + q - x = a] (mod q)"
    proof-
      have "e2 + q - x > 0"
        using assms(3) by linarith
      thus ?thesis sorry
    qed
    thus ?thesis using cong_def assms by(metis mod_if)
  qed
  moreover have "r = (a*b + q - d2) mod q"
  proof-
    have "[d2 = a*b + (q - r)] (mod q)" using assms cong_def by force
    hence "[d2 + r = a*b + q] (mod q)"
      by(smt ab_semigroup_add_class.add_ac(1) add.commute assms cong_add_lcancel_nat le_add_diff_inverse order_less_imp_le)
    hence "[r = a*b + q - d2] (mod q)"
      by (metis Nat.add_diff_assoc d2_lt_q cong_add_lcancel_nat le_add_diff_inverse less_or_eq_imp_le neq0_conv not_add_less1 zero_less_diff)
    thus ?thesis  using cong_def assms by(metis mod_if)
  qed
  ultimately show ?thesis by blast
qed

fun outputs2 :: "nat list \<Rightarrow> (nat \<times> nat \<times> nat) \<Rightarrow> (nat list) spmf"
  where "outputs2 [x, y] view = do {
    let (c2, d2, e2) = view;
    let d1 = (((e2 + q - x) mod q) * c2 + q - d2) mod q;
    let e1 = (y + (q - c2)) mod q;
    let s1 = (x*e1 + (q - d1)) mod q;
    let s2 = (e2 * c2 + (q - d2)) mod q;
    return_spmf [s1,s2]}"

fun R2 :: "real_view"
  where "R2 [x, y] = do {
    ((c1, d1), (c2, d2)) \<leftarrow> TI;
    let e2 = (x + c1) mod q;
    return_spmf (c2, d2, e2)}"

definition S2 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat \<times> nat) spmf"
  where "S2 y s2 = do {
    b \<leftarrow> sample_uniform q;
    e2 \<leftarrow> sample_uniform q;
    let d2 = (e2*b + (q - s2)) mod q;
    return_spmf (b, d2, e2)}"

definition Out2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) spmf"
  where "Out2 y x s2 = do {
    let s1 = (x*y + (q - s2)) mod q;
    return_spmf (s1,s2)}"

definition Ideal2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ((nat \<times> nat \<times> nat) \<times> (nat \<times> nat)) spmf"
  where "Ideal2 y x out2 = do {
    view2 :: (nat \<times> nat \<times> nat) \<leftarrow> S2 y out2;
    out2 \<leftarrow> Out2 y x out2;
    return_spmf (view2, out2)}"

fun valid_inputs where "valid_inputs [x,y] \<longleftrightarrow> (x < q \<and> y < q)"

sublocale party1: semi_honest_prob 0 funct outputs1 R1 S1 valid_inputs .

sublocale party2: semi_honest_prob 1 funct outputs2 R2 S2 valid_inputs .

lemma minus_mod:
  assumes "a > b"
  shows "[a - b mod q = a - b] (mod q)"
  by(metis cong_diff_nat  cong_def le_trans less_or_eq_imp_le assms mod_less_eq_dividend mod_mod_trivial)

lemma q_cong:"[a = q + a] (mod q)"
  by (simp add: cong_def)

lemma q_cong_reverse: "[q + a = a] (mod q)"
  by (simp add: cong_def)

lemma qq_cong: "[a = q*q + a] (mod q)"
  by (simp add: cong_def)

lemma minus_q_mult_cancel:
  assumes "[a = e + b - q * c - d] (mod q)"
    and "e + b - d > 0"
    and "e + b - q * c - d > 0"
  shows  "[a = e + b  - d] (mod q)"
proof-
  have "a mod q = (e + b - q * c - d) mod q"
    using assms(1) cong_def by blast
  then have "a mod q = (e + b - d) mod q"
    by (metis (no_types) add_cancel_left_left assms(3) diff_commute diff_is_0_eq' linordered_semidom_class.add_diff_inverse mod_add_left_eq mod_mult_self1_is_0 nat_less_le)
  then show ?thesis
    using cong_def by blast
qed

lemma s1_s2:
  assumes "x < q" "a < q" "b < q" and r:"r < q" "y < q"
  shows "((x + a) mod q * b + q - (a * b + q - r) mod q) mod q =
          (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q"
proof-
  have s: "(x * y + (q - (x * ((y + (q - b)) mod q) + (q - r)) mod q)) mod q
                 = ((x + a) mod q * b + (q - (a * b + (q - r)) mod q)) mod q"
  proof-
    have lhs: "(x * y + (q - (x * ((y + (q - b)) mod q) + (q - r)) mod q)) mod q = (x*b + r) mod q"
    proof-
      let ?h = "(x * y + (q - (x * ((y + (q - b)) mod q) + (q - r)) mod q)) mod q"
      have "[?h = x * y + q - (x * ((y + (q - b)) mod q) + (q - r)) mod q] (mod q)"
        by(simp add: assms(1) cong_def q_gt_0)
      then have "[?h = x * y + q - (x * (y + (q - b)) + (q - r)) mod q] (mod q)"
        by (metis mod_add_left_eq mod_mult_right_eq)
      then have no_qq: "[?h = x * y + q - (x * y + x * (q - b) + (q - r)) mod q] (mod q)"
        by(metis distrib_left)
      then have "[?h = q*q + x * y + q - (x * y + x * (q - b) + (q - r)) mod q] (mod q)"
      proof-
        have "[x * y + q - (x * y + x * (q - b) + (q - r)) mod q = q*q + x * y + q - (x * y + x * (q - b) + (q - r)) mod q] (mod q)"
          by (smt qq_cong  add.assoc cong_diff_nat cong_def le_add2 le_trans mod_le_divisor q_gt_0)
        then show ?thesis using cong_trans no_qq by blast
      qed
      then have mod: "[?h = q + q*q + x * y + q - (x * y + x * (q - b) + (q - r)) mod q] (mod q)"
        by (smt Nat.add_diff_assoc cong_def add.assoc add.commute le_add2 le_trans mod_add_self2 mod_le_divisor q_gt_0)
      then have "[?h = q + q*q + x * y + q - (x * y + x * (q - b) + (q - r))] (mod q)"
      proof-
        have 1: "q \<ge> q - b" using assms by simp
        then have  "q*q \<ge> x*(q-b)" "q \<ge> q - r" using 1  assms
           apply (auto simp add: mult_strict_mono)
          by (simp add: mult_le_mono)
        then have "q + q*q + x * y + q  > x * y + x * (q - b) + (q - r)"
          using assms(5) by linarith
        then have "[q + q*q + x * y + q - (x * y + x * (q - b) + (q - r)) mod q = q + q*q + x * y + q - (x * y + x * (q - b) + (q - r))] (mod q)"
          using minus_mod by blast
        then show ?thesis using mod using cong_trans by blast
      qed
      then have "[?h = q + q*q + x * y + q - (x * y + (x * q - x*b) + (q - r))] (mod q)"
        by (simp add: right_diff_distrib')
      then have "[?h = q + q*q + x * y + q - x * y - (x * q - x*b) - (q - r)] (mod q)"
        by simp
      then have mod': "[?h = q + q*q + q - (x * q - x*b) - (q - r)] (mod q)"
        by(simp add: add.commute)
      then have neg: "[?h = q + q*q + q - x * q +  x*b - (q - r)] (mod q)"
      proof-
        have "[q + q*q + q - (x * q - x*b) - (q - r) = q + q*q + q - x * q + x*b - (q - r)] (mod q)"
        proof(cases "x = 0")
          case True
          then show ?thesis by simp
        next
          case False
          have "x * q - x*b > 0" using False assms by simp
          also have "q + q*q + q - x * q > 0"
            by (metis assms(1) add.commute diff_mult_distrib2 less_Suc_eq mult.commute mult_Suc_right nat_0_less_mult_iff q_gt_0 zero_less_diff)
          ultimately show ?thesis by simp
        qed
        then show ?thesis using mod' cong_trans by blast
      qed
      then have "[?h = q + q*q + q +  x*b - (q - r)] (mod q)"
      proof-
        have "[q + q*q + q - x * q +  x*b - (q - r) = q + q*q + q +  x*b - (q - r)] (mod q)"
        proof(cases "x = 0")
          case True
          then show ?thesis by simp
        next
          case False
          have "q*q > x*q"
            using False assms
            by (simp add: mult_strict_mono)
          then have 1: "q + q*q + q - x * q +  x*b - (q - r) > 0"
            by linarith
          then have 2: "q + q*q + q +  x*b - (q - r) > 0" by simp
          then show ?thesis
            by (smt 1 2 Nat.add_diff_assoc2 \<open>x * q < q * q\<close> add_cancel_left_left add_diff_inverse_nat
                le_add1 le_add2 le_trans less_imp_add_positive less_numeral_extra(3) minus_mod
                minus_q_mult_cancel mod_if mult.commute q_gt_0)
        qed
        then show ?thesis using cong_trans neg by blast
      qed
      then have "[?h = q + q*q + q +  x*b - q + r] (mod q)"
        by (metis r(1) Nat.add_diff_assoc2 Nat.diff_diff_right le_add2 less_imp_le_nat semiring_normalization_rules(23))
      then have "[?h = q + q*q + q +  x*b + r] (mod q)"
        apply(simp add: cong_def)
        by (metis (no_types, lifting) add.assoc add.commute add_diff_cancel_right' diff_is_0_eq' mod_if mod_le_divisor q_gt_0)
      then have "[?h = x*b + r] (mod q)"
        apply(simp add: cong_def)
        by (metis mod_add_cong mod_add_self1 mod_mult_self1)
      then show ?thesis by (simp add: cong_def assms)
    qed
    also have rhs: "((x + a) mod q * b + (q - (a * b + (q - r)) mod q)) mod q = (x*b + r) mod q"
    proof-
      let ?h = "((x + a) mod q * b + (q - (a * b + (q - r)) mod q)) mod q"
      have "[?h =  (x + a) mod q * b + q - (a * b + (q - r)) mod q] (mod q)"
        by (simp add: q_gt_0  assms(1) cong_def)
      then have "[?h = (x + a) * b + q - (a * b + (q - r)) mod q] (mod q)"
        by (smt Nat.add_diff_assoc cong_def mod_add_cong mod_le_divisor mod_mult_left_eq q_gt_0 assms)
      then have "[?h = x*b + a*b + q - (a * b + (q - r)) mod q] (mod q)"
        by(metis distrib_right)
      then have mod: "[?h = q + x*b + a*b + q - (a * b + (q - r)) mod q] (mod q)"
        by (smt Nat.add_diff_assoc cong_def add.assoc add.commute le_add2 le_trans mod_add_self2 mod_le_divisor q_gt_0)
      then have "[?h =  q + x*b + a*b + q - (a * b + (q - r))] (mod q)" using  q_cong assms(1)
      proof-
        have ge: "q + x*b + a*b + q  > (a * b + (q - r))" using assms by simp
        then have "[ q + x*b + a*b + q - (a * b + (q - r)) mod q =  q + x*b + a*b + q - (a * b + (q - r))] (mod q)"
          using Divides.mod_less_eq_dividend cong_diff_nat  cong_def le_trans less_not_refl2
                  less_or_eq_imp_le q_gt_0 minus_mod by presburger
        then show ?thesis using mod cong_trans by blast
      qed
      then have "[?h =  q + x*b + q - (q - r)] (mod q)"
        by (simp add: add.commute)
      then have "[?h =  q + x*b + q - q + r] (mod q)"
        by (metis Nat.add_diff_assoc2 Nat.diff_diff_right r(1) le_add2 less_imp_le_nat)
      then have "[?h = q + x*b + r] (mod q)" by simp
      then have "[?h = q + (x*b + r)] (mod q)"
        using add.assoc by metis
      then have "[?h = x*b + r] (mod q)"
        using cong_def q_cong_reverse by metis
      then show ?thesis by (simp add: cong_def assms(1))
    qed
    ultimately show ?thesis by simp
  qed
  have lhs:"((x + a) mod q * b + q - (a * b + q - r) mod q) mod q = ((x + a) mod q * b + (q - (a * b + (q - r)) mod q)) mod q"
    using assms by simp
  have rhs: "(x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q = (x * y + (q - (x * ((y + (q - b)) mod q) + (q - r)) mod q)) mod q "
    using assms by simp
  have " ((x + a) mod q * b + (q - (a * b + (q - r)) mod q)) mod q = (x * y + (q - (x * ((y + (q - b)) mod q) + (q - r)) mod q)) mod q"
    using assms s[symmetric] by blast
  then show ?thesis using lhs rhs
    by metis
qed

lemma s1_s2_P2:
  assumes "x < q" "xa < q" "xb < q" "xc < q" "y < q"
  shows "((y, xa, (xb * xa + q - xc) mod q, (x + xb) mod q), (x * ((y + q - xa) mod q) + q - xc) mod q, ((x + xb) mod q * xa + q - (xb * xa + q - xc) mod q) mod q) =
         ((y, xa, (xb * xa + q - xc) mod q, (x + xb) mod q), (x * ((y + q - xa) mod q) + q - xc) mod q, (x * y + q - (x * ((y + q - xa) mod q) + q - xc) mod q) mod q)"
  using assms s1_s2 by metis

lemma c1:
  assumes "e2 = (x + c1) mod q"
    and  "x < q" "c1 < q"
  shows "c1 = (e2 + q - x) mod q"
proof-
  have "[e2 + q = x + c1] (mod q)" by(simp add: assms cong_def)
  then have "[e2 + q - x  =  c1] (mod q)"
  proof-
    have "e2 + q \<ge> x" using assms by simp
    then show ?thesis
      by (metis \<open>[e2 + q = x + c1] (mod q)\<close> cong_add_lcancel_nat le_add_diff_inverse)
  qed
  then show ?thesis by(simp add: cong_def assms)
qed

lemma c1_P2:
  assumes "xb < q" "xa < q" "xc < q" "x < q"
  shows "((y, xa, (xb * xa + q - xc) mod q, (x + xb) mod q), (x * ((y + q - xa) mod q) + q - xc) mod q, (x * y + q - (x * ((y + q - xa) mod q) + q - xc) mod q) mod q) =
          ((y, xa, (((x + xb) mod q + q - x) mod q * xa + q - xc) mod q, (x + xb) mod q), (x * ((y + q - xa) mod q) + q - xc) mod q, (x * y + q - (x * ((y + q - xa) mod q) + q - xc) mod q) mod q)"
proof-
  have "(xb * xa + q - xc) mod q = (((x + xb) mod q + q - x) mod q * xa + q - xc) mod q"
    using assms c1 by simp
  then show ?thesis
    using assms by metis
qed

lemma minus_mod_cancel:
  assumes "a - b > 0" "a - b mod q > 0"
  shows "[a - b + c = a - b mod q + c] (mod q)"
proof-
  have "(b - b mod q + (a - b)) mod q = (0 + (a - b)) mod q"
    using  cong_def mod_add_cong neq0_conv q_gt_0
    by (simp add: minus_mod_eq_mult_div)
  then show ?thesis
    by (metis (no_types) Divides.mod_less_eq_dividend Nat.add_diff_assoc2 add_diff_inverse_nat assms(1) cong_def diff_is_0_eq' less_or_eq_imp_le mod_add_cong neq0_conv)
qed

lemma d2:
  assumes d2: "d2 = (((e2 + q - x) mod q)*b + (q - r)) mod q"
    and s1: "s1 = (x*((y + (q - b)) mod q) + (q - r)) mod q"
    and s2: "s2 = (x*y + (q - s1)) mod q"
    and x: "x < q"
    and y: "y < q"
    and r: "r < q"
    and b: "b < q"
    and e2: "e2 < q"
  shows "d2  = (e2*b + (q - s2)) mod q"
proof-
  have s1_le_q: "s1 < q"
    using s1 q_gt_0 by simp
  have s2_le_q: "s2 < q"
    using s2 q_gt_0 by simp
  have xb: "(x*b) mod q = (s2  + (q - r)) mod q"
  proof-
    have "s1 = (x*(y + (q - b)) + (q - r)) mod q" using s1 b
      by (metis mod_add_left_eq mod_mult_right_eq)
    then have s1_dist: "s1 = (x*y + x*(q - b) + (q - r)) mod q"
      by(metis distrib_left)
    then have "s1 = (x*y + x*q - x*b + (q - r)) mod q"
      using distrib_left b diff_mult_distrib2 by auto
    then have "[s1 = x*y + x*q - x*b + (q - r)] (mod q)"
      by(simp add: cong_def)
    then have "[s1 + x * b = x*y + x*q - x*b + x*b + (q - r)] (mod q)"
      by (metis add.commute add.left_commute cong_add_lcancel_nat)
    then have "[s1 + x*b = x*y + x*q + (q - r)] (mod q)"
      using b by (simp add: algebra_simps)
        (metis add_diff_inverse_nat diff_diff_left diff_mult_distrib2 less_imp_add_positive mult.commute not_add_less1 zero_less_diff)
    then have s1_xb: "[s1 + x*b = q + x*y + x*q + (q - r)] (mod q)"
      by (smt mod_add_cong mod_add_self1 cong_def)
    then have "[x*b = q + x*y + x*q + (q - r) - s1] (mod q)"
    proof-
      have "q + x*y + x*q + (q - r) - s1 > 0" using s1_le_q by simp
      then show ?thesis
        by (metis add_diff_inverse_nat less_numeral_extra(3) s1_xb cong_add_lcancel_nat nat_diff_split)
    qed
    then have "[x*b = x*y + x*q + (q - r) + q - s1] (mod q)"
      by (metis add.assoc add.commute)
    then have "[x*b = x*y + (q - r) + q - s1] (mod q)"
      by (smt Nat.add_diff_assoc cong_def less_imp_le_nat mod_mult_self1 s1_le_q semiring_normalization_rules(23))
    then have "(x*b) mod q = (x*y  + (q - r) + q - s1) mod q"
      by(simp add: cong_def)
    then have "(x*b) mod q = (x*y  + (q - r) + (q - s1)) mod q"
      using add.assoc s1_le_q by auto
    then have "(x*b) mod q = (x*y  + (q - s1) + (q - r)) mod q"
      using add.commute by presburger
    then show ?thesis using s2 by presburger
  qed
  have "d2 = (((e2 + q - x) mod q)*b + (q - r)) mod q"
    using d2 by simp
  then have "d2 = (((e2 + q - x))*b + (q - r)) mod q"
    using mod_add_cong mod_mult_left_eq by blast
  then have "d2 = (e2*b + q*b - x*b + (q - r)) mod q"
    by (simp add: distrib_right diff_mult_distrib)
  then have a: "[d2 = e2*b + q*b - x*b + (q - r)] (mod q)"
    by(simp add: cong_def)
  then have b:"[d2 = q + q + e2*b + q*b - x*b + (q - r)] (mod q)"
  proof-
    have "[e2*b + q*b - x*b + (q - r) = q + q + e2*b + q*b - x*b + (q - r)] (mod q)"
      by (smt assms Nat.add_diff_assoc add.commute cong_def less_imp_le_nat mod_add_self2
          mult.commute nat_mult_le_cancel_disj semiring_normalization_rules(23))
    then show ?thesis using cong_trans a by blast
  qed
  then have "[d2 = q + q + e2*b + q*b - (x*b) mod q + (q - r)] (mod q)"
  proof-
    have "[q + q + e2*b + q*b - (x*b)  + (q - r) = q + q + e2*b + q*b - (x*b) mod q + (q - r)] (mod q)"
    proof(cases "b = 0")
      case True
      then show ?thesis by simp
    next
      case False
      have "q*b - (x*b) > 0"
        using False x by simp
      then have 1: "q + q + e2*b + q*b - (x*b) > 0" by linarith
      then have 2:"q + q + e2*b + q*b - (x*b) mod q > 0"
        by (simp add: q_gt_0 trans_less_add1)
      then show ?thesis using 1 2 minus_mod_cancel by simp
    qed
    then show ?thesis using cong_trans b by blast
  qed
  then have c: "[d2 = q + q + e2*b + q*b - (s2  + (q - r)) mod q + (q - r)] (mod q)"
    using xb by simp
  then have "[d2 = q + q + e2*b + q*b - (s2  + (q - r)) + (q - r)] (mod q)"
  proof-
    have "[q + q + e2*b + q*b - (s2  + (q - r)) mod q + (q - r) = q + q + e2*b + q*b - (s2  + (q - r)) + (q - r)] (mod q)"
    proof-
      have "q + q + e2*b + q*b - (s2  + (q - r)) mod q > 0"
        by (metis diff_is_0_eq gr0I le_less_trans mod_less_divisor not_add_less1 q_gt_0 semiring_normalization_rules(23) trans_less_add2)
      moreover have"q + q + e2*b + q*b - (s2  + (q - r)) > 0"
        using s2_le_q by simp
      ultimately show ?thesis
        using minus_mod_cancel cong_sym by blast
    qed
    then show ?thesis using cong_trans c by blast
  qed
  then have d: "[d2 = q + q + e2*b + q*b - s2 - (q - r) + (q - r)] (mod q)" by simp
  then have "[d2 = q + q + e2*b + q*b - s2 ] (mod q)"
  proof-
    have "q + q + e2*b + q*b - s2 - (q - r) > 0"
      using s2_le_q by simp
    then show ?thesis using d cong_trans by simp
  qed
  then have "[d2 = q + q + e2*b - s2] (mod q)"
    by (smt Nat.add_diff_assoc2 cong_def less_imp_le_nat mod_mult_self1 mult.commute s2_le_q semiring_normalization_rules(23) trans_less_add2)
  then have "[d2 = q + e2*b + q - s2] (mod q)"
    by(simp add: add.commute add.assoc)
  then have "[d2 = e2*b + q - s2] (mod q)"
    by (smt Nat.add_diff_assoc2 add.commute cong_def less_imp_le_nat mod_add_self2 s2_le_q trans_less_add2)
  then have "[d2 = e2*b + (q - s2)] (mod q)"
    by (simp add: less_imp_le_nat s2_le_q)
  then show ?thesis by(simp add: cong_def d2)
qed

lemma d2':
  assumes x: "x < q"
    and y: "y < q"
    and r: "r < q"
    and b: "b < q"
    and e2: "e2 < q"
  shows "(((e2 + q - x) mod q)*b + (q - r)) mod q = (e2*b + (q - ((x*y + (q - ((x*((y + (q - b)) mod q) + (q - r)) mod q))) mod q))) mod q"
  using assms d2 by blast

lemma d2_P2:
  assumes x: "x < q" and y: "y < q" and r: "b < q" and b: "e2 < q" and e2: "r < q"
  shows "((y, b, ((e2 + q - x) mod q * b + q - r) mod q, e2), (x * ((y + q - b) mod q) + q - r) mod q, (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q) =
                ((y, b, (e2 * b + q - (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q) mod q, e2), (x * ((y + q - b) mod q) + q - r) mod q,
                      (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q)"
proof-
  have "((e2 + q - x) mod q * b + q - r) mod q = (e2 * b + q - (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q) mod q"
    (is "?lhs = ?rhs")
  proof-
    have d2: "(((e2 + q - x) mod q)*b + (q - r)) mod q  = (e2*b + (q - ((x*y + (q - ((x*((y + (q - b)) mod q) + (q - r)) mod q))) mod q))) mod q"
      using assms d2 by blast
    have "?lhs = (((e2 + q - x) mod q)*b + (q - r)) mod q"
      using assms by simp
    also have "?rhs = (e2*b + (q - ((x*y + (q - ((x*((y + (q - b)) mod q) + (q - r)) mod q))) mod q))) mod q"
      using assms by simp
    ultimately show ?thesis using assms d2 by metis
  qed
  then show ?thesis using assms by metis
qed

lemma s1:
  assumes s2: "s2 = (x*y + q - s1) mod q"
    and x: "x < q"
    and y: "y < q"
    and s1: "s1 < q"
  shows "s1 = (x*y + q - s2) mod q"
proof-
  have s2_le_q:"s2 < q" using s2 q_gt_0 by simp
  have "[s2 = x*y + q - s1] (mod q)" by(simp add: cong_def s2)
  then have "[s2 = x*y + q - s1] (mod q)" using add.assoc
    by (simp add: less_imp_le_nat s1)
  then have s1_s2: "[s2 + s1 = x*y + q] (mod q)"
    by (metis (mono_tags, lifting) cong_def le_add2 le_add_diff_inverse2 le_trans mod_add_left_eq order.strict_implies_order s1)
  then have "[s1 = x*y + q - s2] (mod q)"
  proof-
    have "x*y + q - s2 > 0" using s2_le_q by simp
    then show ?thesis
      by (metis s1_s2 add_diff_cancel_left' cong_diff_nat cong_def le_add1 less_imp_le_nat zero_less_diff)
  qed
  then show ?thesis by(simp add: cong_def s1)
qed

lemma s1_P2:
  assumes x: "x < q"
    and y: "y < q"
    and "b < q"
    and "e2 < q"
    and "r < q"
    and "s1 < q"
  shows "((y, b, (e2 * b + q - (x * y + q - r) mod q) mod q, e2), r, (x * y + q - r) mod q) =
                ((y, b, (e2 * b + q - (x * y + q - r) mod q) mod q, e2), (x * y + q - (x * y + q - r) mod q) mod q, (x * y + q - r) mod q)"
proof-
  have "s1 = (x*y + q - ((x*y + q - s1) mod q)) mod q"
    using assms secure_mult.s1 secure_mult_axioms by blast
  then show ?thesis using assms s1 by blast
qed

lemma party2_views_equal:
  assumes "valid_inputs [x,y]"
  shows "party2.real_view [x,y] = party2.ideal_view [x,y]"
proof-
  have x_lt_q: "x < q" and y_lt_q: "y < q"
    using assms by auto
  have "party2.real_view [x,y] = do {
    a \<leftarrow> sample_uniform q;
    b \<leftarrow> sample_uniform q;
    r \<leftarrow> sample_uniform q;
    let c1 = a;
    let c2 = b;
    let d2 = (a*b + (q - r)) mod q;
    let e2 = (x + c1) mod q;
    let view = (c2, d2, e2);
    let d1 = (((e2 + q - x) mod q) * c2 + q - d2) mod q;
    let e1 = (y + (q - c2)) mod q;
    let s1 = (x*e1 + (q - d1)) mod q;
    let s2 = (e2 * c2 + (q - d2)) mod q;
    let outputs = [s1,s2];
    return_spmf (y,view, outputs)}"
    unfolding semi_honest_prob.real_view_def
    by(simp add: party2.real_view_def split_def Let_def TI_def)
  also have "... = do {
    a \<leftarrow> sample_uniform q;
    b \<leftarrow> sample_uniform q;
    r \<leftarrow> sample_uniform q;
    let c1 = a;
    let c2 = b;
    let d2 = (a*b + (q - r)) mod q;
    let e2 = (x + c1) mod q;
    let view = (c2, d2, e2);
    let d1 = r;
    let e1 = (y + (q - c2)) mod q;
    let s1 = (x*e1 + (q - r)) mod q;
    let s2 = (e2 * c2 + (q - d2)) mod q;
    let outputs = [s1,s2];
    return_spmf (y, view, outputs)}"
    apply(simp add: Let_def)
      apply(intro bind_spmf_cong bind_spmf_cong[OF refl]; clarsimp)+
    using c1 s1 x_lt_q by auto
  also have "... = do {
    a \<leftarrow> sample_uniform q;
    b \<leftarrow> sample_uniform q;
    r \<leftarrow> sample_uniform q;
    let c1 = a;
    let d1 = r;
    let c2 = b;
    let e2 = (x + c1) mod q;
    let d2 = ((((e2 + q - x) mod q)*b + (q - r)) mod q);
    let e1 = (y + (q - c2)) mod q;
    let s1 = (x*((y + (q - c2)) mod q) + (q - r)) mod q;
    let s2 = (x*y + (q - s1)) mod q;
    let outputs = [s1,s2];
    return_spmf (y, (c2, d2, e2), outputs)}"
    apply(simp add: Let_def)
    apply(intro bind_spmf_cong bind_spmf_cong[OF refl]; clarsimp)+
    by (metis c1 s1_s2 x_lt_q y_lt_q )
  also have "... = do {
    b \<leftarrow> sample_uniform q;
    r \<leftarrow> sample_uniform q;
    let d1 = r;
    let c2 = b;
    e2 \<leftarrow> map_spmf (\<lambda> c1. (x + c1) mod q) (sample_uniform q);
    let d2 = ((((e2 + q - x) mod q)*b + (q - r)) mod q);
    let s1 = (x*((y + (q - c2)) mod q) + (q - r)) mod q;
    let s2 = (x*y + (q - s1)) mod q;
    let outputs = [s1,s2];
    return_spmf (y, (c2, d2, e2), outputs)}"
    including monad_normalisation
    by(simp add: bind_map_spmf o_def Let_def)
  also have "... = do {
    b \<leftarrow> sample_uniform q;
    r \<leftarrow> sample_uniform q;
    let d1 = r;
    let c2 = b;
    e2 \<leftarrow> sample_uniform q;
    let d2 = ((((e2 + q - x) mod q)*b + (q - r)) mod q);
    let s1 = (x*((y + (q - c2)) mod q) + (q - r)) mod q;
    let s2 = (x*y + (q - s1)) mod q;
    let outputs = [s1,s2];
    return_spmf (y, (c2, d2, e2), outputs)}"
    by(simp add: samp_uni_plus_one_time_pad)
  also have "... = do {
    b \<leftarrow> sample_uniform q;
    r \<leftarrow> sample_uniform q;
    let d1 = r;
    let c2 = b;
    e2 \<leftarrow> sample_uniform q;
    let s1 = (x*((y + (q - b)) mod q) + (q - r)) mod q;
    let s2 = (x*y + (q - s1)) mod q;
    let d2 = (e2*b + (q - s2)) mod q;
    let outputs = [s1,s2];
    return_spmf (y, (c2, d2, e2), outputs)}"
    apply(simp add: Let_def)
    apply(intro bind_spmf_cong bind_spmf_cong[OF refl]; clarsimp)+
    by (smt d2' y_lt_q x_lt_q mod_le_divisor order_less_imp_le ordered_cancel_comm_monoid_diff_class.diff_add_assoc q_gt_0)
  also have "... = do {
    b \<leftarrow> sample_uniform q;
    let c2 = b;
    e2 \<leftarrow> sample_uniform q;
    s1 \<leftarrow> map_spmf (\<lambda> r. (x*((y + (q - b)) mod q) + (q - r)) mod q) (sample_uniform q);
    let s2 = (x*y + (q - s1)) mod q;
    let d2 = (e2*b + (q - s2)) mod q;
    let outputs = [s1,s2];
    return_spmf (y, (c2, d2, e2), outputs)}"
    including monad_normalisation
    by(simp add: bind_map_spmf o_def Let_def)
  also have "... = do {
    b \<leftarrow> sample_uniform q;
    let c2 = b;
    e2 \<leftarrow> sample_uniform q;
    s1 \<leftarrow> sample_uniform q;
    let s2 = (x*y + (q - s1)) mod q;
    let d2 = (e2*b + (q - s2)) mod q;
    let outputs = [s1,s2];
    return_spmf (y, (c2, d2, e2), outputs)}"
    by(simp add: samp_uni_minus_one_time_pad)
  also have "... = do {
    outputs \<leftarrow> funct [x,y];
    view \<leftarrow> S2 y (nth outputs 1);
    return_spmf (y, view, outputs)}"
    including monad_normalisation
    by(simp add: Let_def S2_def)
  ultimately show ?thesis
    by(simp add: party2.ideal_view_def semi_honest_prob.ideal_view_def)
qed

theorem party2_perfect_security:
  shows "party2.perfect_security [x,y]"
  unfolding party2.perfect_security_def using party2_views_equal by blast

lemma s1_s2_P1:  assumes "x < q" "xa < q" "xb < q" "xc < q" "y < q"
  shows "((x, xa, xb, (y + q - xc) mod q), (x * ((y + q - xc) mod q) + q - xb) mod q, ((x + xa) mod q * xc + q - (xa * xc + q - xb) mod q) mod q) =
         ((x, xa, xb, (y + q - xc) mod q), (x * ((y + q - xc) mod q) + q - xb) mod q, (x * y + q - (x * ((y + q - xc) mod q) + q - xb) mod q) mod q)"
  using assms s1_s2 by metis

lemma mod_minus: assumes "a - b > 0" and "c - d > 0"
  shows "(a - b + (c - d mod q)) mod q = (a - b + (c - d)) mod q"
  using assms
  by (metis cong_def minus_mod mod_add_cong zero_less_diff)

lemma r:
  assumes e1: "e1 = (y + (q - b)) mod q"
    and s1: "s1 = (x*((y + (q - b)) mod q) + (q - r)) mod q"
    and b: "b < q"
    and x: "x < q"
    and y: "y < q"
    and r: "r < q"
  shows "r = (x*e1 + (q - s1)) mod q"
    (is "?lhs = ?rhs")
proof-
  have "s1 = (x*((y + (q - b))) + (q - r)) mod q" using s1 b
    by (metis mod_add_left_eq mod_mult_right_eq)
  then have s1_dist: "s1 = (x*y + x*(q - b) + (q - r)) mod q"
    by(metis distrib_left)
  then have "?rhs = (x*((y + (q - b)) mod q) + (q - (x*y + x*(q - b) + (q - r)) mod q)) mod q"
    using e1  by simp
  then have "?rhs = (x*((y + (q - b))) + (q - (x*y + x*(q - b) + (q - r)) mod q)) mod q"
    by (metis mod_add_left_eq mod_mult_right_eq)
  then have "?rhs = (x*y + x*(q - b) + (q - (x*y + x*(q - b) + (q - r)) mod q)) mod q"
    by(metis distrib_left)
  then have a: "?rhs = (x*y + x*q - x*b + (q - (x*y + x*(q - b) + (q - r)) mod q)) mod q"
    using distrib_left b diff_mult_distrib2 by auto
  then have b: "?rhs = (x*y + x*q - x*b + (q*q + q*q + q  - (x*y + x*(q - b) + (q - r)) mod q)) mod q"
  proof -
    have "(x*y + x*q - x*b + (q - (x*y + x*(q - b) + (q - r)) mod q)) mod q = (x*y + x*q - x*b + (q*q + q*q + q - (x*y + x*(q - b) + (q - r)) mod q)) mod q"
    proof -
      have f1: "\<forall>n na nb nc nd. (n::nat) mod na \<noteq> nb mod na \<or> nc mod na \<noteq> nd mod na \<or> (n + nc) mod na = (nb + nd) mod na"
        by (meson mod_add_cong)
      then have "(q - (x * y + x*(q - b) + (q - r)) mod q) mod q = (q * q + q * q + q - (x * y + x*(q - b) + (q - r)) mod q) mod q"
        by (metis Nat.diff_add_assoc mod_le_divisor q_gt_0 mod_mult_self4)
      then show ?thesis
        using f1 by blast
    qed
    then show ?thesis using a by simp
  qed
  then have "?rhs = (x*y + x*q - x*b + (q*q + q*q + q  - (x*y + x*(q - b) + (q - r)))) mod q"
  proof-
    have "(x*y + x*q - x*b + (q*q + q*q + q - (x*y + x*(q - b) + (q - r)) mod q)) mod q =
         (x*y + x*q - x*b + (q*q + q*q + q - (x*y + x*(q - b)+ (q - r)))) mod q"
    proof(cases "x = 0")
      case True
      then show ?thesis
        by (metis (no_types, lifting) assms(2) assms(4) True Nat.add_diff_assoc add.left_neutral
            cong_def diff_le_self minus_mod mult_is_0 not_gr_zero zero_eq_add_iff_both_eq_0 zero_less_diff)
    next
      case False
      have qb: "q - b \<le> q"
        using b by simp
      then have qb':"x*(q - b) < q*q"
        using x by (metis mult_less_le_imp_less nat_0_less_mult_iff nat_less_le neq0_conv)
      have a: "x*y + x*(q - b) > 0"
        using False assms by simp
      have 1: "q*q > x*y"
        using False by (simp add: mult_strict_mono q_gt_0 x y)
      have 2: "q*q > x*q" using False
        by (simp add: mult_strict_mono q_gt_0 x y)
      have b: "(q*q + q*q + q - (x*y + x*(q - b) + (q - r))) > 0"
        using 1 qb' by simp
      then show ?thesis using a b mod_minus[of "x*y + x*q" "x*b" "q*q + q*q + q" "x*y + x*(q - b) + (q - r)"]
        by (smt add.left_neutral cong_def gr0I minus_mod zero_less_diff)
    qed
    then show ?thesis using b by simp
  qed
  then have d: "?rhs = (x*y + x*q - x*b + (q*q + q*q + q - x*y - x*(q - b) - (q - r))) mod q"
    by simp
  then have e: "?rhs = (x*y + x*q - x*b + q*q + q*q + q - x*y - x*(q - b) - (q - r)) mod q"
  proof(cases "x = 0")
    case True
    then show ?thesis using True d by simp
  next
    case False
    have qb: "q - b \<le> q" using b by simp
    then have qb':"x*(q - b) < q*q"
      using x by (metis mult_less_le_imp_less nat_0_less_mult_iff nat_less_le neq0_conv)
    have a: "x*y + x*(q - b) > 0" using False assms by simp
    have 1: "q*q > x*y" using False
      by (simp add: mult_strict_mono q_gt_0 x y)
    have 2: "q*q > x*q" using False
      by (simp add: mult_strict_mono q_gt_0 x y)
    have b: "q*q + q*q + q  - x*y - x*(q - b) - (q - r) > 0" using 1 qb' by simp
    then show ?thesis using b d
      by (smt Nat.add_diff_assoc add.assoc diff_diff_left less_imp_le_nat zero_less_diff)
  qed
  then have "?rhs = (x*q - x*b + q*q + q*q + q - x*(q - b) - (q - r)) mod q"
  proof-
    have "(x*y + x*q - x*b + q*q + q*q + q - x*y - x*(q - b) - (q - r)) mod q = (x*q - x*b + q*q + q*q + q - x*(q - b) - (q - r)) mod q"
    proof -
      have 1: "q + n - b = q - b + n" for n
        by (simp add: assms(3) less_imp_le)
      have 2: "(c::nat) * b + (c * a + n) = c * (b + a) + n"
        for n a b c by (simp add: distrib_left)
      have "(c::nat) + (b + a) - (n + a) = c + b - n" for n a b c
        by auto
      then have "(q + (q * q + (q * q + x * (q + y - b))) - (q - r + x * (y + (q - b)))) mod q = (q + (q * q + (q * q + x * (q - b))) - (q - r + x * (q - b))) mod q"
        by (metis (no_types) add.commute 1 2)
      then show ?thesis
        by (simp add: add.commute diff_mult_distrib2 distrib_left)
    qed
    then show ?thesis using e by simp
  qed
  then have "?rhs = (x*(q - b) + q*q + q*q + q - x*(q - b) - (q - r)) mod q"
    by(metis diff_mult_distrib2)
  then have "?rhs = (q*q + q*q + q - (q - r)) mod q"
    using assms(6) by simp
  then have "?rhs = (q*q + q*q + q - q + r) mod q"
    using assms(6) by(simp add: Nat.diff_add_assoc2 less_imp_le)
  then have "?rhs = (q*q + q*q  + r) mod q"
    by simp
  then have "?rhs = r mod q"
    by (metis add.commute distrib_right mod_mult_self1)
  then show ?thesis using assms(6) by simp
qed

lemma r_P2:
  assumes b: "b < q" and x: "x < q" and y: "y < q" and r: "r < q"
  shows
    "((x, a, r, (y + q - b) mod q), (x * ((y + q - b) mod q) + q - r) mod q, (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q) =
              ((x, a, (x * ((y + q - b) mod q) + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q, (y + q - b) mod q), (x * ((y + q - b) mod q) + q - r) mod q,
                      (x * y + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q)"
proof-
  have  "(x * ((y + q - b) mod q) + q - (x * ((y + q - b) mod q) + q - r) mod q) mod q = r"
    (is "?lhs = ?rhs")
  proof-
    have 1:"r = (x*((y + (q - b)) mod q) + (q - ((x*((y + (q - b)) mod q) + (q - r)) mod q))) mod q"
      using assms secure_mult.r secure_mult_axioms by blast
    also have "?rhs = (x*((y + (q - b)) mod q) + (q - ((x*((y + (q - b)) mod q) + (q - r)) mod q))) mod q" using assms 1 by blast
    ultimately show ?thesis using assms 1 by simp
  qed
  then show ?thesis using assms by simp
qed

lemma party1_equal_views:
  assumes "valid_inputs [x,y]"
  shows "party1.real_view [x,y] = party1.ideal_view [x,y]"
proof-
  have x_lt_q: "x < q" and y_lt_q: "y < q"
    using assms by auto
  have "party1.real_view [x,y] = do {
    a :: nat \<leftarrow> sample_uniform q;
    b :: nat \<leftarrow> sample_uniform q;
    r :: nat \<leftarrow> sample_uniform q;
    let c1 = a;
    let d1 = r;
    let c2 = b;
    let e1 = (y + (q - c2)) mod q;
    let d2 = ((c1*((y + q - e1) mod q) + (q - r)) mod q);
    let e2 = (x + c1) mod q;
    let s1 = (x*e1 + (q - d1)) mod q;
    let s2 = (e2 *((y + q - e1) mod q) + (q - d2)) mod q;
    let outputs = [s1, s2];
    return_spmf (x, (c1, d1, e1), outputs)}"
    including monad_normalisation
    by(auto simp add: party1.real_view_def split_def TI_def Let_def)
  also have "... = do {
    a :: nat \<leftarrow> sample_uniform q;
    b :: nat \<leftarrow> sample_uniform q;
    r :: nat \<leftarrow> sample_uniform q;
    let c1 = a;
    let d1 = r;
    let c2 = b;
    let d2 = ((c1*c2 + (q - r)) mod q);
    let e2 = (x + c1) mod q;
    let e1 = (y + (q - c2)) mod q;
    let s1 = (x*e1 + (q - d1)) mod q;
    let s2 = (e2 *c2 + (q - d2)) mod q;
    let outputs = [s1, s2];
    return_spmf (x, (c1, d1, e1), outputs)}"
    apply simp
      apply(intro bind_spmf_cong bind_spmf_cong[OF refl]; clarsimp)+
    using party1_view_e1_c2 x_lt_q y_lt_q by simp
    also have "... = do {
    a :: nat \<leftarrow> sample_uniform q;
    b :: nat \<leftarrow> sample_uniform q;
    r :: nat \<leftarrow> sample_uniform q;
    let c1 = a;
    let c2 = b;
    let e1 = (y + (q - b)) mod q;
    let s1 = (x*((y + (q - b)) mod q) + (q - r)) mod q;
    let d1 = (x*e1 + (q - s1)) mod q;
    let s2 = (x*y + (q - s1)) mod q;
    let outputs = [s1, s2];
    return_spmf (x, (c1, d1, e1), outputs)}"
      apply(simp add: Let_def)
      apply(intro bind_spmf_cong bind_spmf_cong[OF refl]; clarsimp)+
      apply auto
      using x_lt_q y_lt_q mod_less_divisor q_gt_0 s1 apply blast
      using s1_s2 x_lt_q y_lt_q by blast
    also have "... = do {
    a :: nat \<leftarrow> sample_uniform q;
    b :: nat \<leftarrow> sample_uniform q;
    let c1 = a;
    let c2 = b;
    let e1 = (y + (q - b)) mod q;
    s1 \<leftarrow> map_spmf (\<lambda> r. (x*((y + (q - b)) mod q) + (q - r)) mod q) (sample_uniform q);
    let d1 = (x*e1 + (q - s1)) mod q;
    let s2 = (x*y + (q - s1)) mod q;
    let outputs = [s1, s2];
    return_spmf (x, (c1, d1, e1), outputs)}"
      by(simp add: bind_map_spmf Let_def o_def)
    also have "... = do {
    a :: nat \<leftarrow> sample_uniform q;
    b :: nat \<leftarrow> sample_uniform q;
    let c1 = a;
    let c2 = b;
    let e1 = (y + (q - b)) mod q;
    s1 \<leftarrow> sample_uniform q;
    let d1 = (x*e1 + (q - s1)) mod q;
    let s2 = (x*y + (q - s1)) mod q;
    let outputs = [s1, s2];
    return_spmf (x, (c1, d1, e1), outputs)}"
      by(simp add: samp_uni_minus_one_time_pad)
    also have "... = do {
    a :: nat \<leftarrow> sample_uniform q;
    let c1 = a;
    e1 \<leftarrow> map_spmf (\<lambda> b. (y + (q - b)) mod q) (sample_uniform q);
    s1 \<leftarrow> sample_uniform q;
    let d1 = (x*e1 + (q - s1)) mod q;
    let s2 = (x*y + (q - s1)) mod q;
    let outputs = [s1, s2];
    return_spmf (x, (c1, d1, e1), outputs)}"
      by(simp add: bind_map_spmf Let_def o_def)
    also have "... = do {
    a :: nat \<leftarrow> sample_uniform q;
    let c1 = a;
    e1 \<leftarrow> sample_uniform q;
    s1 \<leftarrow> sample_uniform q;
    let d1 = (x*e1 + (q - s1)) mod q;
    let s2 = (x*y + (q - s1)) mod q;
    let outputs = [s1, s2];
    return_spmf (x, (c1, d1, e1), outputs)}"
      by(simp add: samp_uni_minus_one_time_pad)
    also have "... = do {
    outputs \<leftarrow> funct [x, y];
    view \<leftarrow> S1 x (nth outputs 0);
    return_spmf (x, view, outputs)}"
    including monad_normalisation
    by(simp add: S1_def)
  ultimately show ?thesis by(simp add: party1.ideal_view_def)
qed

theorem party1_perfect_security:
  shows "party1.perfect_security [x,y]"
  unfolding party1.perfect_security_def using party1_equal_views by auto

end

locale secure_mult_asymp =
  fixes q :: "nat \<Rightarrow> nat"
  assumes "\<And> n. secure_mult (q n)"
begin

sublocale secure_mult "q n" for n
  using secure_mult_asymp_axioms secure_mult_asymp_def by blast

theorem P1_secure:
  shows "party1.perfect_security n [x, y]"
  by (rule party1_perfect_security)

theorem P2_secure:
  assumes "x < q n" "y < q n"
  shows "party2.perfect_security n [x, y]"
  by(rule party2_perfect_security)

end

end


(*  Title:      HOL/Analysis/Norm_Arith.thy
    Author:     Amine Chaieb, University of Cambridge
*)

section \<open>Linear Decision Procedure for Normed Spaces\<close>

theory Norm_Arith
imports "HOL-Library.Sum_of_Squares"
begin

(* FIXME: move elsewhere *)
lemma sum_sqs_eq:
  fixes x::"'a::idom" shows "x * x + y * y = x * (y * 2) \<Longrightarrow> y = x"
  by algebra

lemma norm_cmul_rule_thm:
  fixes x :: "'a::real_normed_vector"
  shows "b \<ge> norm x \<Longrightarrow> \<bar>c\<bar> * b \<ge> norm (scaleR c x)"
  unfolding norm_scaleR
  apply (erule mult_left_mono)
  apply simp
  done

(* FIXME: Move all these theorems into the ML code using lemma antiquotation *)
lemma norm_add_rule_thm:
  fixes x1 x2 :: "'a::real_normed_vector"
  shows "norm x1 \<le> b1 \<Longrightarrow> norm x2 \<le> b2 \<Longrightarrow> norm (x1 + x2) \<le> b1 + b2"
  by (rule order_trans [OF norm_triangle_ineq add_mono])

lemma ge_iff_diff_ge_0:
  fixes a :: "'a::linordered_ring"
  shows "a \<ge> b \<equiv> a - b \<ge> 0"
  by (simp add: field_simps)

lemma pth_1:
  fixes x :: "'a::real_normed_vector"
  shows "x \<equiv> scaleR 1 x" by simp

lemma pth_2:
  fixes x :: "'a::real_normed_vector"
  shows "x - y \<equiv> x + -y"
  by (atomize (full)) simp

lemma pth_3:
  fixes x :: "'a::real_normed_vector"
  shows "- x \<equiv> scaleR (-1) x"
  by simp

lemma pth_4:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR 0 x \<equiv> 0"
    and "scaleR c 0 = (0::'a)"
  by simp_all

lemma pth_5:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c (scaleR d x) \<equiv> scaleR (c * d) x"
  by simp

lemma pth_6:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c (x + y) \<equiv> scaleR c x + scaleR c y"
  by (simp add: scaleR_right_distrib)

lemma pth_7:
  fixes x :: "'a::real_normed_vector"
  shows "0 + x \<equiv> x"
    and "x + 0 \<equiv> x"
  by simp_all

lemma pth_8:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c x + scaleR d x \<equiv> scaleR (c + d) x"
  by (simp add: scaleR_left_distrib)

lemma pth_9:
  fixes x :: "'a::real_normed_vector"
  shows "(scaleR c x + z) + scaleR d x \<equiv> scaleR (c + d) x + z"
    and "scaleR c x + (scaleR d x + z) \<equiv> scaleR (c + d) x + z"
    and "(scaleR c x + w) + (scaleR d x + z) \<equiv> scaleR (c + d) x + (w + z)"
  by (simp_all add: algebra_simps)

lemma pth_a:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR 0 x + y \<equiv> y"
  by simp

lemma pth_b:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c x + scaleR d y \<equiv> scaleR c x + scaleR d y"
    and "(scaleR c x + z) + scaleR d y \<equiv> scaleR c x + (z + scaleR d y)"
    and "scaleR c x + (scaleR d y + z) \<equiv> scaleR c x + (scaleR d y + z)"
    and "(scaleR c x + w) + (scaleR d y + z) \<equiv> scaleR c x + (w + (scaleR d y + z))"
  by (simp_all add: algebra_simps)

lemma pth_c:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c x + scaleR d y \<equiv> scaleR d y + scaleR c x"
    and "(scaleR c x + z) + scaleR d y \<equiv> scaleR d y + (scaleR c x + z)"
    and "scaleR c x + (scaleR d y + z) \<equiv> scaleR d y + (scaleR c x + z)"
    and "(scaleR c x + w) + (scaleR d y + z) \<equiv> scaleR d y + ((scaleR c x + w) + z)"
  by (simp_all add: algebra_simps)

lemma pth_d:
  fixes x :: "'a::real_normed_vector"
  shows "x + 0 \<equiv> x"
  by simp

lemma norm_imp_pos_and_ge:
  fixes x :: "'a::real_normed_vector"
  shows "norm x \<equiv> n \<Longrightarrow> norm x \<ge> 0 \<and> n \<ge> norm x"
  by atomize auto

lemma real_eq_0_iff_le_ge_0:
  fixes x :: real
  shows "x = 0 \<equiv> x \<ge> 0 \<and> - x \<ge> 0"
  by arith

lemma norm_pths:
  fixes x :: "'a::real_normed_vector"
  shows "x = y \<longleftrightarrow> norm (x - y) \<le> 0"
    and "x \<noteq> y \<longleftrightarrow> \<not> (norm (x - y) \<le> 0)"
  using norm_ge_zero[of "x - y"] by auto

lemmas arithmetic_simps =
  arith_simps
  add_numeral_special
  add_neg_numeral_special
  mult_1_left
  mult_1_right

ML_file \<open>normarith.ML\<close>

method_setup\<^marker>\<open>tag important\<close> norm = \<open>
  Scan.succeed (SIMPLE_METHOD' o NormArith.norm_arith_tac)
\<close> "prove simple linear statements about vector norms"

text \<open>Hence more metric properties.\<close>
text\<^marker>\<open>tag important\<close> \<open>%whitespace\<close>
proposition dist_triangle_add:
  fixes x y x' y' :: "'a::real_normed_vector"
  shows "dist (x + y) (x' + y') \<le> dist x x' + dist y y'"
  by norm

lemma dist_triangle_add_half:
  fixes x x' y y' :: "'a::real_normed_vector"
  shows "dist x x' < e / 2 \<Longrightarrow> dist y y' < e / 2 \<Longrightarrow> dist(x + y) (x' + y') < e"
  by norm

end


section \<open>The Proof System\<close>

theory OG_Hoare imports OG_Tran begin

primrec assertions :: "'a ann_com \<Rightarrow> ('a assn) set" where
  "assertions (AnnBasic r f) = {r}"
| "assertions (AnnSeq c1 c2) = assertions c1 \<union> assertions c2"
| "assertions (AnnCond1 r b c1 c2) = {r} \<union> assertions c1 \<union> assertions c2"
| "assertions (AnnCond2 r b c) = {r} \<union> assertions c"
| "assertions (AnnWhile r b i c) = {r, i} \<union> assertions c"
| "assertions (AnnAwait r b c) = {r}"

primrec atomics :: "'a ann_com \<Rightarrow> ('a assn \<times> 'a com) set" where
  "atomics (AnnBasic r f) = {(r, Basic f)}"
| "atomics (AnnSeq c1 c2) = atomics c1 \<union> atomics c2"
| "atomics (AnnCond1 r b c1 c2) = atomics c1 \<union> atomics c2"
| "atomics (AnnCond2 r b c) = atomics c"
| "atomics (AnnWhile r b i c) = atomics c"
| "atomics (AnnAwait r b c) = {(r \<inter> b, c)}"

primrec com :: "'a ann_triple_op \<Rightarrow> 'a ann_com_op" where
  "com (c, q) = c"

primrec post :: "'a ann_triple_op \<Rightarrow> 'a assn" where
  "post (c, q) = q"

definition interfree_aux :: "('a ann_com_op \<times> 'a assn \<times> 'a ann_com_op) \<Rightarrow> bool" where
  "interfree_aux \<equiv> \<lambda>(co, q, co'). co'= None \<or>
                    (\<forall>(r,a) \<in> atomics (the co'). \<parallel>= (q \<inter> r) a q \<and>
                    (co = None \<or> (\<forall>p \<in> assertions (the co). \<parallel>= (p \<inter> r) a p)))"

definition interfree :: "(('a ann_triple_op) list) \<Rightarrow> bool" where
  "interfree Ts \<equiv> \<forall>i j. i < length Ts \<and> j < length Ts \<and> i \<noteq> j \<longrightarrow>
                         interfree_aux (com (Ts!i), post (Ts!i), com (Ts!j)) "

inductive
  oghoare :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a assn \<Rightarrow> bool"  ("(3\<parallel>- _//_//_)" [90,55,90] 50)
  and ann_hoare :: "'a ann_com \<Rightarrow> 'a assn \<Rightarrow> bool"  ("(2\<turnstile> _// _)" [60,90] 45)
where
  AnnBasic: "r \<subseteq> {s. f s \<in> q} \<Longrightarrow> \<turnstile> (AnnBasic r f) q"

| AnnSeq:   "\<lbrakk> \<turnstile> c0 pre c1; \<turnstile> c1 q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnSeq c0 c1) q"

| AnnCond1: "\<lbrakk> r \<inter> b \<subseteq> pre c1; \<turnstile> c1 q; r \<inter> -b \<subseteq> pre c2; \<turnstile> c2 q\<rbrakk>
              \<Longrightarrow> \<turnstile> (AnnCond1 r b c1 c2) q"
| AnnCond2: "\<lbrakk> r \<inter> b \<subseteq> pre c; \<turnstile> c q; r \<inter> -b \<subseteq> q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnCond2 r b c) q"

| AnnWhile: "\<lbrakk> r \<subseteq> i; i \<inter> b \<subseteq> pre c; \<turnstile> c i; i \<inter> -b \<subseteq> q \<rbrakk>
              \<Longrightarrow> \<turnstile> (AnnWhile r b i c) q"

| AnnAwait:  "\<lbrakk> atom_com c; \<parallel>- (r \<inter> b) c q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r b c) q"

| AnnConseq: "\<lbrakk>\<turnstile> c q; q \<subseteq> q' \<rbrakk> \<Longrightarrow> \<turnstile> c q'"

| Parallel: "\<lbrakk> \<forall>i<length Ts. \<exists>c q. Ts!i = (Some c, q) \<and> \<turnstile> c q; interfree Ts \<rbrakk>
           \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts!i))))
                     Parallel Ts
                  (\<Inter>i\<in>{i. i<length Ts}. post(Ts!i))"

| Basic:   "\<parallel>- {s. f s \<in>q} (Basic f) q"

| Seq:    "\<lbrakk> \<parallel>- p c1 r; \<parallel>- r c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Seq c1 c2) q "

| Cond:   "\<lbrakk> \<parallel>- (p \<inter> b) c1 q; \<parallel>- (p \<inter> -b) c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Cond b c1 c2) q"

| While:  "\<lbrakk> \<parallel>- (p \<inter> b) c p \<rbrakk> \<Longrightarrow> \<parallel>- p (While b i c) (p \<inter> -b)"

| Conseq: "\<lbrakk> p' \<subseteq> p; \<parallel>- p c q ; q \<subseteq> q' \<rbrakk> \<Longrightarrow> \<parallel>- p' c q'"

section \<open>Soundness\<close>
(* In the version Isabelle-10-Sep-1999: HOL: The THEN and ELSE
parts of conditional expressions (if P then x else y) are no longer
simplified.  (This allows the simplifier to unfold recursive
functional programs.)  To restore the old behaviour, we declare
@{text "lemmas [cong del] = if_weak_cong"}. *)

lemmas [cong del] = if_weak_cong

lemmas ann_hoare_induct = oghoare_ann_hoare.induct [THEN conjunct2]
lemmas oghoare_induct = oghoare_ann_hoare.induct [THEN conjunct1]

lemmas AnnBasic = oghoare_ann_hoare.AnnBasic
lemmas AnnSeq = oghoare_ann_hoare.AnnSeq
lemmas AnnCond1 = oghoare_ann_hoare.AnnCond1
lemmas AnnCond2 = oghoare_ann_hoare.AnnCond2
lemmas AnnWhile = oghoare_ann_hoare.AnnWhile
lemmas AnnAwait = oghoare_ann_hoare.AnnAwait
lemmas AnnConseq = oghoare_ann_hoare.AnnConseq

lemmas Parallel = oghoare_ann_hoare.Parallel
lemmas Basic = oghoare_ann_hoare.Basic
lemmas Seq = oghoare_ann_hoare.Seq
lemmas Cond = oghoare_ann_hoare.Cond
lemmas While = oghoare_ann_hoare.While
lemmas Conseq = oghoare_ann_hoare.Conseq

subsection \<open>Soundness of the System for Atomic Programs\<close>

lemma Basic_ntran [rule_format]:
 "(Basic f, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow> t = f s"
apply(induct "n")
 apply(simp (no_asm))
apply(fast dest: relpow_Suc_D2 Parallel_empty_lemma elim: transition_cases)
done

lemma SEM_fwhile: "SEM S (p \<inter> b) \<subseteq> p \<Longrightarrow> SEM (fwhile b S k) p \<subseteq> (p \<inter> -b)"
apply (induct "k")
 apply(simp (no_asm) add: L3_5v_lemma3)
apply(simp (no_asm) add: L3_5iv L3_5ii Parallel_empty)
apply(rule conjI)
 apply (blast dest: L3_5i)
apply(simp add: SEM_def sem_def id_def)
apply (auto dest: Basic_ntran rtrancl_imp_UN_relpow)
apply blast
done

lemma atom_hoare_sound [rule_format]:
 " \<parallel>- p c q \<longrightarrow> atom_com(c) \<longrightarrow> \<parallel>= p c q"
apply (unfold com_validity_def)
apply(rule oghoare_induct)
apply simp_all
\<comment> \<open>Basic\<close>
    apply(simp add: SEM_def sem_def)
    apply(fast dest: rtrancl_imp_UN_relpow Basic_ntran)
\<comment> \<open>Seq\<close>
   apply(rule impI)
   apply(rule subset_trans)
    prefer 2 apply simp
   apply(simp add: L3_5ii L3_5i)
\<comment> \<open>Cond\<close>
  apply(simp add: L3_5iv)
\<comment> \<open>While\<close>
 apply (force simp add: L3_5v dest: SEM_fwhile)
\<comment> \<open>Conseq\<close>
apply(force simp add: SEM_def sem_def)
done

subsection \<open>Soundness of the System for Component Programs\<close>

inductive_cases ann_transition_cases:
    "(None,s) -1\<rightarrow> (c', s')"
    "(Some (AnnBasic r f),s) -1\<rightarrow> (c', s')"
    "(Some (AnnSeq c1 c2), s) -1\<rightarrow> (c', s')"
    "(Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (c', s')"
    "(Some (AnnCond2 r b c), s) -1\<rightarrow> (c', s')"
    "(Some (AnnWhile r b I c), s) -1\<rightarrow> (c', s')"
    "(Some (AnnAwait r b c),s) -1\<rightarrow> (c', s')"

text \<open>Strong Soundness for Component Programs:\<close>

lemma ann_hoare_case_analysis [rule_format]: "\<turnstile> C q' \<longrightarrow>
  ((\<forall>r f. C = AnnBasic r f \<longrightarrow> (\<exists>q. r \<subseteq> {s. f s \<in> q} \<and> q \<subseteq> q')) \<and>
  (\<forall>c0 c1. C = AnnSeq c0 c1 \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and> \<turnstile> c0 pre c1 \<and> \<turnstile> c1 q)) \<and>
  (\<forall>r b c1 c2. C = AnnCond1 r b c1 c2 \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and>
  r \<inter> b \<subseteq> pre c1 \<and> \<turnstile> c1 q \<and> r \<inter> -b \<subseteq> pre c2 \<and> \<turnstile> c2 q)) \<and>
  (\<forall>r b c. C = AnnCond2 r b c \<longrightarrow>
  (\<exists>q. q \<subseteq> q' \<and> r \<inter> b \<subseteq> pre c  \<and> \<turnstile> c q \<and> r \<inter> -b \<subseteq> q)) \<and>
  (\<forall>r i b c. C = AnnWhile r b i c \<longrightarrow>
  (\<exists>q. q \<subseteq> q' \<and> r \<subseteq> i \<and> i \<inter> b \<subseteq> pre c \<and> \<turnstile> c i \<and> i \<inter> -b \<subseteq> q)) \<and>
  (\<forall>r b c. C = AnnAwait r b c \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and> \<parallel>- (r \<inter> b) c q)))"
apply(rule ann_hoare_induct)
apply simp_all
 apply(rule_tac x=q in exI,simp)+
apply(rule conjI,clarify,simp,clarify,rule_tac x=qa in exI,fast)+
apply(clarify,simp,clarify,rule_tac x=qa in exI,fast)
done

lemma Help: "(transition \<inter> {(x,y). True}) = (transition)"
apply force
done

lemma Strong_Soundness_aux_aux [rule_format]:
 "(co, s) -1\<rightarrow> (co', t) \<longrightarrow> (\<forall>c. co = Some c \<longrightarrow> s\<in> pre c \<longrightarrow>
 (\<forall>q. \<turnstile> c q \<longrightarrow> (if co' = None then t\<in>q else t \<in> pre(the co') \<and> \<turnstile> (the co') q )))"
apply(rule ann_transition_transition.induct [THEN conjunct1])
apply simp_all
\<comment> \<open>Basic\<close>
         apply clarify
         apply(frule ann_hoare_case_analysis)
         apply force
\<comment> \<open>Seq\<close>
        apply clarify
        apply(frule ann_hoare_case_analysis,simp)
        apply(fast intro: AnnConseq)
       apply clarify
       apply(frule ann_hoare_case_analysis,simp)
       apply clarify
       apply(rule conjI)
        apply force
       apply(rule AnnSeq,simp)
       apply(fast intro: AnnConseq)
\<comment> \<open>Cond1\<close>
      apply clarify
      apply(frule ann_hoare_case_analysis,simp)
      apply(fast intro: AnnConseq)
     apply clarify
     apply(frule ann_hoare_case_analysis,simp)
     apply(fast intro: AnnConseq)
\<comment> \<open>Cond2\<close>
    apply clarify
    apply(frule ann_hoare_case_analysis,simp)
    apply(fast intro: AnnConseq)
   apply clarify
   apply(frule ann_hoare_case_analysis,simp)
   apply(fast intro: AnnConseq)
\<comment> \<open>While\<close>
  apply clarify
  apply(frule ann_hoare_case_analysis,simp)
  apply force
 apply clarify
 apply(frule ann_hoare_case_analysis,simp)
 apply auto
 apply(rule AnnSeq)
  apply simp
 apply(rule AnnWhile)
  apply simp_all
\<comment> \<open>Await\<close>
apply(frule ann_hoare_case_analysis,simp)
apply clarify
apply(drule atom_hoare_sound)
 apply simp
apply(simp add: com_validity_def SEM_def sem_def)
apply(simp add: Help All_None_def)
apply force
done

lemma Strong_Soundness_aux: "\<lbrakk> (Some c, s) -*\<rightarrow> (co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
  \<Longrightarrow> if co = None then t \<in> q else t \<in> pre (the co) \<and> \<turnstile> (the co) q"
apply(erule rtrancl_induct2)
 apply simp
apply(case_tac "a")
 apply(fast elim: ann_transition_cases)
apply(erule Strong_Soundness_aux_aux)
 apply simp
apply simp_all
done

lemma Strong_Soundness: "\<lbrakk> (Some c, s)-*\<rightarrow>(co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
  \<Longrightarrow> if co = None then t\<in>q else t \<in> pre (the co)"
apply(force dest:Strong_Soundness_aux)
done

lemma ann_hoare_sound: "\<turnstile> c q  \<Longrightarrow> \<Turnstile> c q"
apply (unfold ann_com_validity_def ann_SEM_def ann_sem_def)
apply clarify
apply(drule Strong_Soundness)
apply simp_all
done

subsection \<open>Soundness of the System for Parallel Programs\<close>

lemma Parallel_length_post_P1: "(Parallel Ts,s) -P1\<rightarrow> (R', t) \<Longrightarrow>
  (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
  (\<forall>i. i<length Ts \<longrightarrow> post(Rs ! i) = post(Ts ! i)))"
apply(erule transition_cases)
apply simp
apply clarify
apply(case_tac "i=ia")
apply simp+
done

lemma Parallel_length_post_PStar: "(Parallel Ts,s) -P*\<rightarrow> (R',t) \<Longrightarrow>
  (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
  (\<forall>i. i<length Ts \<longrightarrow> post(Ts ! i) = post(Rs ! i)))"
apply(erule rtrancl_induct2)
 apply(simp_all)
apply clarify
apply simp
apply(drule Parallel_length_post_P1)
apply auto
done

lemma assertions_lemma: "pre c \<in> assertions c"
apply(rule ann_com_com.induct [THEN conjunct1])
apply auto
done

lemma interfree_aux1 [rule_format]:
  "(c,s) -1\<rightarrow> (r,t)  \<longrightarrow> (interfree_aux(c1, q1, c) \<longrightarrow> interfree_aux(c1, q1, r))"
apply (rule ann_transition_transition.induct [THEN conjunct1])
apply(safe)
prefer 13
apply (rule TrueI)
apply (simp_all add:interfree_aux_def)
apply force+
done

lemma interfree_aux2 [rule_format]:
  "(c,s) -1\<rightarrow> (r,t) \<longrightarrow> (interfree_aux(c, q, a)  \<longrightarrow> interfree_aux(r, q, a) )"
apply (rule ann_transition_transition.induct [THEN conjunct1])
apply(force simp add:interfree_aux_def)+
done

lemma interfree_lemma: "\<lbrakk> (Some c, s) -1\<rightarrow> (r, t);interfree Ts ; i<length Ts;
           Ts!i = (Some c, q) \<rbrakk> \<Longrightarrow> interfree (Ts[i:= (r, q)])"
apply(simp add: interfree_def)
apply clarify
apply(case_tac "i=j")
 apply(drule_tac t = "ia" in not_sym)
 apply simp_all
apply(force elim: interfree_aux1)
apply(force elim: interfree_aux2 simp add:nth_list_update)
done

text \<open>Strong Soundness Theorem for Parallel Programs:\<close>

lemma Parallel_Strong_Soundness_Seq_aux:
  "\<lbrakk>interfree Ts; i<length Ts; com(Ts ! i) = Some(AnnSeq c0 c1) \<rbrakk>
  \<Longrightarrow>  interfree (Ts[i:=(Some c0, pre c1)])"
apply(simp add: interfree_def)
apply clarify
apply(case_tac "i=j")
 apply(force simp add: nth_list_update interfree_aux_def)
apply(case_tac "i=ia")
 apply(erule_tac x=ia in allE)
 apply(force simp add:interfree_aux_def assertions_lemma)
apply simp
done

lemma Parallel_Strong_Soundness_Seq [rule_format (no_asm)]:
 "\<lbrakk> \<forall>i<length Ts. (if com(Ts!i) = None then b \<in> post(Ts!i)
  else b \<in> pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i));
  com(Ts ! i) = Some(AnnSeq c0 c1); i<length Ts; interfree Ts \<rbrakk> \<Longrightarrow>
 (\<forall>ia<length Ts. (if com(Ts[i:=(Some c0, pre c1)]! ia) = None
  then b \<in> post(Ts[i:=(Some c0, pre c1)]! ia)
 else b \<in> pre(the(com(Ts[i:=(Some c0, pre c1)]! ia))) \<and>
 \<turnstile> the(com(Ts[i:=(Some c0, pre c1)]! ia)) post(Ts[i:=(Some c0, pre c1)]! ia)))
  \<and> interfree (Ts[i:= (Some c0, pre c1)])"
apply(rule conjI)
 apply safe
 apply(case_tac "i=ia")
  apply simp
  apply(force dest: ann_hoare_case_analysis)
 apply simp
apply(fast elim: Parallel_Strong_Soundness_Seq_aux)
done

lemma Parallel_Strong_Soundness_aux_aux [rule_format]:
 "(Some c, b) -1\<rightarrow> (co, t) \<longrightarrow>
  (\<forall>Ts. i<length Ts \<longrightarrow> com(Ts ! i) = Some c \<longrightarrow>
  (\<forall>i<length Ts. (if com(Ts ! i) = None then b\<in>post(Ts!i)
  else b\<in>pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i))) \<longrightarrow>
 interfree Ts \<longrightarrow>
  (\<forall>j. j<length Ts \<and> i\<noteq>j \<longrightarrow> (if com(Ts!j) = None then t\<in>post(Ts!j)
  else t\<in>pre(the(com(Ts!j))) \<and> \<turnstile> the(com(Ts!j)) post(Ts!j))) )"
apply(rule ann_transition_transition.induct [THEN conjunct1])
apply safe
prefer 11
apply(rule TrueI)
apply simp_all
\<comment> \<open>Basic\<close>
   apply(erule_tac x = "i" in all_dupE, erule (1) notE impE)
   apply(erule_tac x = "j" in allE , erule (1) notE impE)
   apply(simp add: interfree_def)
   apply(erule_tac x = "j" in allE,simp)
   apply(erule_tac x = "i" in allE,simp)
   apply(drule_tac t = "i" in not_sym)
   apply(case_tac "com(Ts ! j)=None")
    apply(force intro: converse_rtrancl_into_rtrancl
          simp add: interfree_aux_def com_validity_def SEM_def sem_def All_None_def)
   apply(simp add:interfree_aux_def)
   apply clarify
   apply simp
   apply(erule_tac x="pre y" in ballE)
    apply(force intro: converse_rtrancl_into_rtrancl
          simp add: com_validity_def SEM_def sem_def All_None_def)
   apply(simp add:assertions_lemma)
\<comment> \<open>Seqs\<close>
  apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
  apply(drule  Parallel_Strong_Soundness_Seq,simp+)
 apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
 apply(drule  Parallel_Strong_Soundness_Seq,simp+)
\<comment> \<open>Await\<close>
apply(rule_tac x = "i" in allE , assumption , erule (1) notE impE)
apply(erule_tac x = "j" in allE , erule (1) notE impE)
apply(simp add: interfree_def)
apply(erule_tac x = "j" in allE,simp)
apply(erule_tac x = "i" in allE,simp)
apply(drule_tac t = "i" in not_sym)
apply(case_tac "com(Ts ! j)=None")
 apply(force intro: converse_rtrancl_into_rtrancl simp add: interfree_aux_def
        com_validity_def SEM_def sem_def All_None_def Help)
apply(simp add:interfree_aux_def)
apply clarify
apply simp
apply(erule_tac x="pre y" in ballE)
 apply(force intro: converse_rtrancl_into_rtrancl
       simp add: com_validity_def SEM_def sem_def All_None_def Help)
apply(simp add:assertions_lemma)
done

lemma Parallel_Strong_Soundness_aux [rule_format]:
 "\<lbrakk>(Ts',s) -P*\<rightarrow> (Rs',t);  Ts' = (Parallel Ts); interfree Ts;
 \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. (Ts ! i) = (Some c, q) \<and> s\<in>(pre c) \<and> \<turnstile> c q ) \<rbrakk> \<Longrightarrow>
  \<forall>Rs. Rs' = (Parallel Rs) \<longrightarrow> (\<forall>j. j<length Rs \<longrightarrow>
  (if com(Rs ! j) = None then t\<in>post(Ts ! j)
  else t\<in>pre(the(com(Rs ! j))) \<and> \<turnstile> the(com(Rs ! j)) post(Ts ! j))) \<and> interfree Rs"
apply(erule rtrancl_induct2)
 apply clarify
\<comment> \<open>Base\<close>
 apply force
\<comment> \<open>Induction step\<close>
apply clarify
apply(drule Parallel_length_post_PStar)
apply clarify
apply (ind_cases "(Parallel Ts, s) -P1\<rightarrow> (Parallel Rs, t)" for Ts s Rs t)
apply(rule conjI)
 apply clarify
 apply(case_tac "i=j")
  apply(simp split del:if_split)
  apply(erule Strong_Soundness_aux_aux,simp+)
   apply force
  apply force
 apply(simp split del: if_split)
 apply(erule Parallel_Strong_Soundness_aux_aux)
 apply(simp_all add: split del:if_split)
 apply force
apply(rule interfree_lemma)
apply simp_all
done

lemma Parallel_Strong_Soundness:
 "\<lbrakk>(Parallel Ts, s) -P*\<rightarrow> (Parallel Rs, t); interfree Ts; j<length Rs;
  \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. Ts ! i = (Some c, q) \<and> s\<in>pre c \<and> \<turnstile> c q) \<rbrakk> \<Longrightarrow>
  if com(Rs ! j) = None then t\<in>post(Ts ! j) else t\<in>pre (the(com(Rs ! j)))"
apply(drule  Parallel_Strong_Soundness_aux)
apply simp+
done

lemma oghoare_sound [rule_format]: "\<parallel>- p c q \<longrightarrow> \<parallel>= p c q"
apply (unfold com_validity_def)
apply(rule oghoare_induct)
apply(rule TrueI)+
\<comment> \<open>Parallel\<close>
      apply(simp add: SEM_def sem_def)
      apply(clarify, rename_tac x y i Ts')
      apply(frule Parallel_length_post_PStar)
      apply clarify
      apply(drule_tac j=i in Parallel_Strong_Soundness)
         apply clarify
        apply simp
       apply force
      apply simp
      apply(erule_tac V = "\<forall>i. P i" for P in thin_rl)
      apply(drule_tac s = "length Rs" in sym)
      apply(erule allE, erule impE, assumption)
      apply(force dest: nth_mem simp add: All_None_def)
\<comment> \<open>Basic\<close>
    apply(simp add: SEM_def sem_def)
    apply(force dest: rtrancl_imp_UN_relpow Basic_ntran)
\<comment> \<open>Seq\<close>
   apply(rule subset_trans)
    prefer 2 apply assumption
   apply(simp add: L3_5ii L3_5i)
\<comment> \<open>Cond\<close>
  apply(simp add: L3_5iv)
\<comment> \<open>While\<close>
 apply(simp add: L3_5v)
 apply (blast dest: SEM_fwhile)
\<comment> \<open>Conseq\<close>
apply(auto simp add: SEM_def sem_def)
done

end