subsection \<open>1-out-of-2 OT to 1-out-of-4 OT\<close>

text \<open>Here we construct a protocol that achieves 1-out-of-4 OT from 1-out-of-2 OT. We follow the protocol
for constructing 1-out-of-n OT from 1-out-of-2 OT from \cite{DBLP:books/cu/Goldreich2004}. We assume the security
properties on 1-out-of-2 OT.\<close>

theory OT14 imports
  Semi_Honest
  OT_Functionalities
  Uniform_Sampling
begin

fun valid_inputs_ot12 :: "bool inputs_ot12 list \<Rightarrow> bool"
  where "valid_inputs_ot12 [M2 (b0, b1), C1 \<sigma>] = True"

fun valid_inputs_ot14 :: "bool inputs_ot14 list \<Rightarrow> bool"
  where "valid_inputs_ot14 [M4 (m00, m01, m10, m11), C2 (c0,c1)] = True"

type_synonym input1 = "bool \<times> bool \<times> bool \<times> bool"
type_synonym input2 = "bool \<times> bool"
type_synonym 'ot12_view1' view1 = "((bool \<times> bool \<times> bool \<times> bool \<times> bool \<times> bool) \<times> 'ot12_view1' \<times> 'ot12_view1' \<times> 'ot12_view1')"
type_synonym 'ot12_view2' view2 = "( (bool \<times> bool \<times> bool \<times> bool) \<times> 'ot12_view2' \<times> 'ot12_view2' \<times> 'ot12_view2')"

locale ot14_base =   ot12: semi_honest_det_correctness f_ot12 protocol_ot12 valid_inputs_ot12
  + ot12_1: semi_honest_det_security f_ot12 protocol_ot12 valid_inputs_ot12 0 R1_OT12 S1_OT12
  + ot12_2: semi_honest_det_security f_ot12 protocol_ot12 valid_inputs_ot12 1 R2_OT12 S2_OT12
  for R1_OT12 :: "bool inputs_ot12 list \<Rightarrow> 'ot12_view1 spmf"
    and S1_OT12
    and R2_OT12 :: "bool inputs_ot12 list \<Rightarrow> 'ot12_view2 spmf"
    and  S2_OT12  protocol_ot12
    +
  fixes ot12_adv_P1 :: real
  assumes ot12_advantage_P1: "ot12_1.advantage [M2 (m0,m1), C1 \<sigma>] D \<le> ot12_adv_P1"
    and ot12_perfect_security_P2: "ot12_2.perfect_security [M2 (m0,m1), C1 \<sigma>]"
    and ot12_correct: "ot12.correctness [M2 (m0,m1), C1 \<sigma>]"
begin

lemma OT_12_P1_assms_bound': "\<bar>spmf (ot12_1.real_view [M2 (m0,m1), C1 \<sigma>] \<bind> (\<lambda> view. ((D::bool inputs_ot12 \<times> 'ot12_view1 \<Rightarrow> bool spmf) view)))  True
                - spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ()) \<bind> (\<lambda> view. (D view))) True\<bar> \<le> ot12_adv_P1"
  using ot12_advantage_P1 unfolding ot12_1.advantage_def by simp

lemma OT_12_P2_assm: "R2_OT12 [M2 (m0,m1), C1 \<sigma>] = return_spmf (f_ot12 [M2 (m0,m1), C1 \<sigma>]) \<bind> (\<lambda> outputs. S2_OT12 (C1 \<sigma>) (nth outputs 1))"
  using ot12_perfect_security_P2 ot12_2.perfect_security_def ot12_2.perfect_sec_views_equal by simp

fun protocol_ot14 :: "bool inputs_ot14 list \<Rightarrow> (bool outputs_ot14 list) spmf"
  where "protocol_ot14 [M4 (m00, m01, m10, m11), C2 (c0,c1)] = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool\<leftarrow> coin_spmf;
    S2 :: bool\<leftarrow> coin_spmf;
    S3 :: bool\<leftarrow> coin_spmf;
    S4 :: bool\<leftarrow> coin_spmf;
    S5 :: bool\<leftarrow> coin_spmf;
    let a0 = S0 \<oplus> S2 \<oplus> m00;
    let a1 = S0 \<oplus> S3 \<oplus> m01;
    let a2 = S1 \<oplus> S4 \<oplus> m10;
    let a3 = S1 \<oplus> S5 \<oplus> m11;
    outputs_i :: bool outputs_ot12 list \<leftarrow> protocol_ot12 ([M2 (S0, S1), C1 c0] :: bool inputs_ot12 list);
    outputs_j :: bool outputs_ot12 list \<leftarrow> protocol_ot12 ([M2 (S2, S3), C1 c1] :: bool inputs_ot12 list);
    outputs_k :: bool outputs_ot12 list \<leftarrow> protocol_ot12 ([M2 (S4, S5), C1 c1] ::  bool inputs_ot12 list);
    let s2 = (xor_ot12 (nth outputs_i 1) (if c0 then (nth outputs_k 1) else (nth outputs_j 1))) \<oplus> (if c0 then (if c1 then a3 else a2) else (if c1 then a1 else a0)) ;
    return_spmf ([U_ot14 (), P_ot14 s2])}"

sublocale ot14_correct: semi_honest_det_correctness f_ot14 protocol_ot14 valid_inputs_ot14 .

lemma ot12_correct_unfold: "protocol_ot12 [M2 (S0, S1), C1 a] = return_spmf (f_ot12 [M2 (S0, S1), C1 a])" for a
  using ot12_correct[unfolded ot12.correctness_def] valid_inputs_ot12.simps by presburger

lemma ot14_correct_unfold:
  shows "return_spmf (f_ot14 [M4 (m0,m1,m2,m3), C2 (c0,c1)]) = protocol_ot14 [M4 (m0,m1,m2,m3), C2 (c0,c1)]"
proof-
  have "(S1 = (\<not> S5)) = (S1 = (S5 = (\<not> m))) = m" for S1 S5 m by blast
  thus ?thesis
    by(auto simp add: ot12_correct_unfold bind_spmf_const ot12_correct)
qed

lemma ot14_correct: "ot14_correct.correctness [M4 (m0,m1,m2,m3), C2 (c0,c1)]"
  unfolding ot14_correct.correctness_def
  using ot14_correct_unfold by simp

fun R1_14 :: "bool inputs_ot14 list \<Rightarrow> 'ot12_view1 view1 spmf"
  where "R1_14 [M4 (m00, m01, m10, m11), C2 (c0,c1)] = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a :: 'ot12_view1 \<leftarrow> R1_OT12 [M2 (S0, S1), C1 c0];
    b :: 'ot12_view1 \<leftarrow> R1_OT12 [M2 (S2, S3), C1 c1];
    c :: 'ot12_view1 \<leftarrow> R1_OT12 [M2 (S4, S5), C1 c1];
    return_spmf ((S0, S1, S2, S3, S4, S5), a, b, c)}"

fun R1_14_interm1 :: "bool inputs_ot14 list \<Rightarrow> 'ot12_view1 view1 spmf"
  where "R1_14_interm1 [M4 (m00, m01, m10, m11), C2 (c0,c1)] = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a :: 'ot12_view1 \<leftarrow> S1_OT12 (M2 (S0, S1)) (U_ot12 ());
    b :: 'ot12_view1 \<leftarrow> R1_OT12 [M2 (S2, S3), C1 c1];
    c :: 'ot12_view1 \<leftarrow> R1_OT12 [M2 (S4, S5), C1 c1];
    return_spmf ((S0, S1, S2, S3, S4, S5), a, b, c)}"

fun real_view1_14_interm1 :: "bool inputs_ot14 list \<Rightarrow> (bool inputs_ot14 \<times> 'ot12_view1 view1) spmf"
  where "real_view1_14_interm1 [M4 (m00, m01, m10, m11), C2 (c0,c1)] = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a :: 'ot12_view1 \<leftarrow> S1_OT12 (M2 (S0, S1)) (U_ot12 ());
    b :: 'ot12_view1 \<leftarrow> R1_OT12 [M2 (S2, S3), C1 c1];
    c :: 'ot12_view1 \<leftarrow> R1_OT12 [M2 (S4, S5), C1 c1];
    return_spmf (M4 (m00, m01, m10, m11), (S0, S1, S2, S3, S4, S5), a, b, c)}"

fun R1_14_interm2 :: "bool inputs_ot14 list \<Rightarrow> 'ot12_view1 view1 spmf"
  where "R1_14_interm2 [M4 (m00, m01, m10, m11), C2 (c0,c1)] = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a :: 'ot12_view1 \<leftarrow> S1_OT12 (M2 (S0, S1)) (U_ot12 ());
    b :: 'ot12_view1 \<leftarrow> S1_OT12 (M2 (S2, S3)) (U_ot12 ());
    c :: 'ot12_view1 \<leftarrow> R1_OT12 [M2 (S4, S5), C1 c1];
    return_spmf ((S0, S1, S2, S3, S4, S5), a, b, c)}"

fun real_view2_14_interm2 :: "bool inputs_ot14 list \<Rightarrow> (bool inputs_ot14 \<times> 'ot12_view1 view1) spmf"
  where "real_view2_14_interm2 [M4 (m00, m01, m10, m11), C2 (c0,c1)] = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a :: 'ot12_view1 \<leftarrow> S1_OT12 (M2 (S0, S1)) (U_ot12 ());
    b :: 'ot12_view1 \<leftarrow> S1_OT12 (M2 (S2, S3)) (U_ot12 ());
    c :: 'ot12_view1 \<leftarrow> R1_OT12 [M2 (S4, S5), C1 c1];
    return_spmf (M4 (m00, m01, m10, m11),(S0, S1, S2, S3, S4, S5), a, b, c)}"

fun S1_14 :: "bool inputs_ot14 \<Rightarrow> bool outputs_ot14 \<Rightarrow> 'ot12_view1 view1 spmf"
  where "S1_14 (M4 (m00, m01, m10, m11)) (U_ot14 ()) = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a :: 'ot12_view1 \<leftarrow> S1_OT12 (M2 (S0, S1)) (U_ot12 ());
    b :: 'ot12_view1 \<leftarrow> S1_OT12 (M2 (S2, S3)) (U_ot12 ());
    c :: 'ot12_view1 \<leftarrow> S1_OT12 (M2 (S4, S5)) (U_ot12 ());
    return_spmf ((S0, S1, S2, S3, S4, S5), a, b, c)}"

sublocale ot14_P1: semi_honest_det_security f_ot14 protocol_ot14 valid_inputs_ot14 0 R1_14 S1_14 .

lemma reduction_step1:
  shows "\<exists> A1. \<bar>spmf (bind_spmf (ot14_P1.real_view [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True - spmf (bind_spmf (real_view1_14_interm1 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True\<bar> =
              \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c0]) (\<lambda> view. (A1 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A1 view (m0,m1))))) True\<bar>"
  including monad_normalisation
proof-
  define A1' where "A1' == \<lambda> (view :: bool inputs_ot12 \<times> 'ot12_view1) (m0,m1). do {
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    b :: 'ot12_view1 \<leftarrow> R1_OT12 [M2 (S2, S3), C1 c1];
    c :: 'ot12_view1 \<leftarrow> R1_OT12 [M2 (S4, S5), C1 c1];
    let R = (M4 (m00, m01, m10, m11), (m0,m1, S2, S3, S4, S5), snd view, b, c);
    D1 R}"
  have "\<bar>spmf (bind_spmf (ot14_P1.real_view [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True - spmf (bind_spmf (real_view1_14_interm1 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True\<bar> =
              \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c0]) (\<lambda> view. (A1' view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A1' view (m0,m1))))) True\<bar>"
    unfolding ot14_P1.real_view_def ot12_1.ideal_view_def ot12_1.real_view_def
    by(auto simp add: pair_spmf_alt_def A1'_def Let_def split_def)
  then show ?thesis by auto
qed

lemma reduction_step1': "\<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c0]) (\<lambda> view. (A1 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A1 view (m0,m1))))) True\<bar>
            \<le> ot12_adv_P1"
  (is "?lhs \<le> ot12_adv_P1")
proof-
  have int1: "integrable (measure_spmf (pair_spmf coin_spmf coin_spmf)) (\<lambda>(m0,m1). spmf ((ot12_1.real_view [M2 (m0,m1), C1 c0]) \<bind> (\<lambda>view. A1 view (m0, m1))) True)"
    and int2: "integrable (measure_spmf (pair_spmf coin_spmf coin_spmf)) (\<lambda>(m0,m1). spmf ((ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) \<bind> (\<lambda> view. (A1 view (m0,m1)))) True)"
    by(rule measure_spmf.integrable_const_bound[where B=1]; simp add: pmf_le_1)+
  have "?lhs =
            \<bar>LINT (m0,m1)|measure_spmf (pair_spmf coin_spmf coin_spmf). spmf ((ot12_1.real_view [M2 (m0,m1), C1 c0]) \<bind> (\<lambda>view. A1 view (m0, m1))) True
              - spmf ((ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) \<bind> (\<lambda> view. (A1 view (m0,m1)))) True\<bar>"
    apply(subst (1 2) spmf_bind) using int1 int2 by(simp add: split_def)
  also have "... \<le> LINT (m0,m1)|measure_spmf (pair_spmf coin_spmf coin_spmf).
               \<bar>spmf ((ot12_1.real_view [M2 (m0,m1), C1 c0]) \<bind> (\<lambda>view. A1 view (m0, m1))) True - spmf ((ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) \<bind> (\<lambda> view. (A1 view (m0,m1)))) True\<bar>"
    by(rule integral_abs_bound[THEN order_trans]; simp add: split_def split_beta)
  ultimately have "?lhs \<le> LINT (m0,m1)|measure_spmf (pair_spmf coin_spmf coin_spmf).
                      \<bar>spmf ((ot12_1.real_view [M2 (m0,m1), C1 c0]) \<bind> (\<lambda>view. A1 view (m0, m1))) True - spmf ((ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) \<bind> (\<lambda> view. (A1 view (m0,m1)))) True\<bar>"
    by simp
  also have "LINT (m0,m1)|measure_spmf (pair_spmf coin_spmf coin_spmf).
                \<bar>spmf ((ot12_1.real_view [M2 (m0,m1), C1 c0]) \<bind> (\<lambda>view. A1 view (m0, m1))) True
                    - spmf ((ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) \<bind> (\<lambda> view. (A1 view (m0,m1)))) True\<bar> \<le> ot12_adv_P1"
    apply(rule integral_mono[THEN order_trans])
       apply(rule measure_spmf.integrable_const_bound[where B=2])
        apply clarsimp
        apply(rule abs_triangle_ineq4[THEN order_trans])
    subgoal for m0 m1
      using pmf_le_1[of "(ot12_1.real_view [M2 (m0,m1), C1 c0]) \<bind> (\<lambda>view. A1 view (m0, m1))" "Some True"]
        pmf_le_1[of "(ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) \<bind> (\<lambda> view. (A1 view (m0,m1)))" "Some True"]
      by simp
       apply simp
      apply(rule measure_spmf.integrable_const)
     apply clarify
     apply(rule OT_12_P1_assms_bound'[rule_format])
    by simp
  ultimately show ?thesis by simp
qed

lemma reduction_step2:
  shows "\<exists> A1. \<bar>spmf (bind_spmf (real_view1_14_interm1 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True - spmf (bind_spmf (real_view2_14_interm2 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True\<bar> =
          \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c1]) (\<lambda> view. (A1 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A1 view (m0,m1))))) True\<bar>"
  including monad_normalisation
proof-
  define A1' where "A1' == \<lambda> (view :: bool inputs_ot12 \<times> 'ot12_view1) (m0,m1). do {
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a :: 'ot12_view1 \<leftarrow> S1_OT12 (M2 (S2,S3)) (U_ot12 ());
    c :: 'ot12_view1 \<leftarrow> R1_OT12 [M2 (S4, S5), C1 c1];
    let R = (M4 (m00, m01, m10, m11), (S2,S3, m0, m1, S4, S5), a, snd view, c);
    D1 R}"
  have "\<bar>spmf (bind_spmf (real_view1_14_interm1 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True - spmf (bind_spmf (real_view2_14_interm2 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True\<bar> =
          \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c1]) (\<lambda> view. (A1' view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A1' view (m0,m1))))) True\<bar>"
  proof-
    have "(bind_spmf (real_view1_14_interm1 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) = (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c1]) (\<lambda> view. (A1' view (m0,m1)))))"
      unfolding  A1'_def Let_def split_def ot12_1.real_view_def ot12_1.ideal_view_def
      apply(simp add: pair_spmf_alt_def)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>"  in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      including monad_normalisation by simp
    also have "(bind_spmf (real_view2_14_interm2 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) =  (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A1' view (m0,m1)))))"
      unfolding A1'_def Let_def split_def ot12_1.ideal_view_def
      apply(simp add: pair_spmf_alt_def)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>"  in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>"  in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>"  in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>"  in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>"  in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>"  in "_ = \<hole>" bind_commute_spmf)
      by(simp)
    ultimately show ?thesis by simp
  qed
  then show ?thesis by auto
qed

lemma reduction_step3:
  shows "\<exists> A1. \<bar>spmf (bind_spmf (real_view2_14_interm2 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True - spmf (bind_spmf (ot14_P1.ideal_view (M4 (m00, m01, m10, m11)) (U_ot14 ())) D1) True\<bar> =
          \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c1]) (\<lambda> view. (A1 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A1 view (m0,m1))))) True\<bar>"
proof-
  define A1' where "A1' == \<lambda> (view :: bool inputs_ot12 \<times> 'ot12_view1) (m0,m1). do {
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a :: 'ot12_view1 \<leftarrow> S1_OT12 (M2 (S2,S3)) (U_ot12 ());
    b :: 'ot12_view1 \<leftarrow> S1_OT12 (M2 (S4, S5)) (U_ot12 ());
    let R = (M4 (m00, m01, m10, m11), (S2,S3, S4, S5,m0, m1), a, b, snd view);
    D1 R}"
  have "\<bar>spmf (bind_spmf (real_view2_14_interm2 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True - spmf (bind_spmf (ot14_P1.ideal_view (M4 (m00, m01, m10, m11)) (U_ot14 ())) D1) True\<bar> =
          \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c1]) (\<lambda> view. (A1' view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A1' view (m0,m1))))) True\<bar>"
  proof-
    have "(bind_spmf (real_view2_14_interm2 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1)
            = (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c1]) (\<lambda> view. (A1' view (m0,m1)))))"
      unfolding A1'_def Let_def split_def ot12_1.real_view_def
      apply(simp add: pair_spmf_alt_def)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>"  in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>"  in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>"  in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      including monad_normalisation by(simp)
    also have "(bind_spmf (ot14_P1.ideal_view (M4 (m00, m01, m10, m11)) (U_ot14 ())) D1)
                = (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A1' view (m0,m1)))))"
      unfolding Let_def A1'_def split_def ot14_P1.ideal_view_def ot12_1.ideal_view_def
      apply(simp add: pair_spmf_alt_def)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>"  in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>"  in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>"  in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "_ = \<hole>" bind_commute_spmf)
      apply(rewrite in "\<hole> = _" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "\<hole> = _" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "\<hole> = _" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "\<hole> = _" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "\<hole> = _" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "\<hole> = _" bind_commute_spmf)
      apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "\<hole> = _" bind_commute_spmf)
      including monad_normalisation by(simp)
    ultimately show ?thesis by simp
  qed
  then show ?thesis by auto
qed

lemma reduction_P1:
  shows "\<bar>spmf (bind_spmf (ot14_P1.real_view [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True
            - spmf (bind_spmf (ot14_P1.ideal_view (M4 (m00, m01, m10, m11)) (U_ot14 ())) D1) True\<bar>
                \<le> 3 * ot12_adv_P1"
    (is "?lhs \<le> ?rhs")
proof-
  have lhs: "?lhs \<le> \<bar>spmf (bind_spmf (ot14_P1.real_view [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True - spmf (bind_spmf (real_view1_14_interm1 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True\<bar> +
                     \<bar>spmf (bind_spmf (real_view1_14_interm1 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True - spmf (bind_spmf (real_view2_14_interm2 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True\<bar> +
                      \<bar>spmf (bind_spmf (real_view2_14_interm2 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True - spmf (bind_spmf (ot14_P1.ideal_view (M4 (m00, m01, m10, m11)) (U_ot14 ())) D1) True\<bar>"
    by simp
  obtain A1 where A1: "\<bar>spmf (bind_spmf (ot14_P1.real_view [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True - spmf (bind_spmf (real_view1_14_interm1 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True\<bar> =
              \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c0]) (\<lambda> view. (A1 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A1 view (m0,m1))))) True\<bar>"
    using reduction_step1 by blast
  obtain A2 where A2: "\<bar>spmf (bind_spmf (real_view1_14_interm1 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True - spmf (bind_spmf (real_view2_14_interm2 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True\<bar> =
          \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c1]) (\<lambda> view. (A2 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A2 view (m0,m1))))) True\<bar>"
    using reduction_step2 by blast
  obtain A3 where A3: "\<bar>spmf (bind_spmf (real_view2_14_interm2 [M4 (m00, m01, m10, m11), C2 (c0,c1)]) D1) True - spmf (bind_spmf (ot14_P1.ideal_view (M4 (m00, m01, m10, m11)) (U_ot14 ())) D1) True\<bar> =
          \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c1]) (\<lambda> view. (A3 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A3 view (m0,m1))))) True\<bar>"
    using reduction_step3 by blast
  have lhs_bound: "?lhs \<le> \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c0]) (\<lambda> view. (A1 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A1 view (m0,m1))))) True\<bar> +
                   \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c1]) (\<lambda> view. (A2 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A2 view (m0,m1))))) True\<bar> +
                     \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c1]) (\<lambda> view. (A3 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A3 view (m0,m1))))) True\<bar>"
    using A1 A2 A3 lhs by argo
  have bound1: "\<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c0]) (\<lambda> view. (A1 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A1 view (m0,m1))))) True\<bar>
                      \<le> ot12_adv_P1"
    and bound2:  "\<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c1]) (\<lambda> view. (A2 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A2 view (m0,m1))))) True\<bar>
                      \<le> ot12_adv_P1"
    and bound3: " \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.real_view [M2 (m0,m1), C1 c1]) (\<lambda> view. (A3 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (ot12_1.ideal_view (M2 (m0,m1)) (U_ot12 ())) (\<lambda> view. (A3 view (m0,m1))))) True\<bar> \<le> ot12_adv_P1"
    using reduction_step1' by auto
  thus ?thesis
    using reduction_step1' lhs_bound by argo
qed

text\<open>Party 2 security.\<close>

lemma coin_coin: "map_spmf (\<lambda> S0. S0 \<oplus> S3 \<oplus> m1) coin_spmf = coin_spmf"
  (is "?lhs = ?rhs")
proof-
  have lhs: "?lhs = map_spmf (\<lambda> S0. S0 \<oplus> (S3 \<oplus> m1)) coin_spmf" by blast
  also have op_eq: "... = map_spmf ((\<oplus>) (S3 \<oplus> m1)) coin_spmf"
    by (metis xor_bool_def)
  also have "... = ?rhs"
    using xor_uni_samp by fastforce
  ultimately show ?thesis
    using op_eq by auto
qed

lemma coin_coin': "map_spmf (\<lambda> S3. S0 \<oplus> S3 \<oplus> m1) coin_spmf = coin_spmf"
proof-
  have "map_spmf (\<lambda> S3. S0 \<oplus> S3 \<oplus> m1) coin_spmf = map_spmf (\<lambda> S3. S3 \<oplus> S0 \<oplus> m1) coin_spmf"
    by (metis xor_left_commute)
  thus ?thesis using coin_coin by simp
qed

fun R2_14:: "bool inputs_ot14 list \<Rightarrow> 'ot12_view2 view2 spmf"
  where "R2_14 [M4 (m0,m1,m2,m3), C2 (c0,c1)] = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    let a0 = S0 \<oplus> S2 \<oplus> m0;
    let a1 = S0 \<oplus> S3 \<oplus> m1;
    let a2 = S1 \<oplus> S4 \<oplus> m2;
    let a3 = S1 \<oplus> S5 \<oplus> m3;
    a :: 'ot12_view2 \<leftarrow> R2_OT12 [M2 (S0,S1), C1 c0];
    b :: 'ot12_view2 \<leftarrow> R2_OT12 [M2 (S2,S3), C1 c1];
    c :: 'ot12_view2 \<leftarrow> R2_OT12 [M2 (S4,S5), C1 c1];
    return_spmf ((a0,a1,a2,a3), a,b,c)}"

fun S2_14 :: "bool inputs_ot14 \<Rightarrow> bool outputs_ot14 \<Rightarrow> 'ot12_view2 view2 spmf"
  where "S2_14 (C2 (c0,c1)) (P_ot14 out) = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a0 :: bool \<leftarrow> coin_spmf;
    a1 :: bool \<leftarrow> coin_spmf;
    a2 :: bool \<leftarrow> coin_spmf;
    a3 :: bool \<leftarrow> coin_spmf;
    let a0' = (if ((\<not> c0) \<and> (\<not> c1)) then (S0 \<oplus> S2 \<oplus> out) else a0);
    let a1' = (if ((\<not> c0) \<and> c1) then (S0 \<oplus> S3 \<oplus> out) else a1);
    let a2' = (if (c0 \<and> (\<not> c1)) then (S1 \<oplus> S4 \<oplus> out) else a2);
    let a3' = (if (c0 \<and> c1) then (S1 \<oplus> S5 \<oplus> out) else a3);
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 c0) (if c0 then (P_ot12 S1) else (P_ot12 S0));
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 c1) (if c1 then (P_ot12 S3) else (P_ot12 S2));
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 c1) (if c1 then (P_ot12 S5) else (P_ot12 S4));
    return_spmf ((a0',a1',a2',a3'), a,b,c)}"

sublocale P2_security: semi_honest_det_security f_ot14 protocol_ot14 valid_inputs_ot14 1 R2_14 S2_14 .

(*lemma
  shows "P2_security.perfect_security [M4 (m00, m01, m10, m11), C2 (c0,c1)]"
  unfolding P2_security.perfect_security_def P2_security.real_view_def P2_security.ideal_view_def
  apply auto
  apply(simp add: bind_spmf_const)
     apply(intro bind_spmf_cong[OF refl]; clarsimp?)+

lemma
  assumes "valid_inputs_ot14 [M4 (m00, m01, m10, m11), C2 (c0,c1)]"
  shows "(P2_security.real_view [M4 (m0,m1,m2,m3), C2 (c0,c1)] \<bind> (D2 :: (bool inputs_ot14 \<times> (bool \<times> bool \<times> bool \<times> bool) \<times> 'ot12_view2 \<times> 'ot12_view2 \<times> 'ot12_view2) \<Rightarrow> bool spmf) )
                = (return_spmf (f_ot14 [M4 (m0,m1,m2,m3), C2 (c0,c1)]) \<bind> (\<lambda> outputs_ot12. P2_security.ideal_view (C2 (c0,c1)) (nth outputs_ot12 1) \<bind> D2))"

  unfolding P2_security.real_view_def P2_security.ideal_view_def

  apply auto
  apply(simp add: bind_spmf_const)
     apply(intro bind_spmf_cong[OF refl]; clarsimp?)+
  apply(simp add: bind_spmf_const)

lemma P2_OT_14_FT:
  shows "R2_14 [M4 (m0,m1,m2,m3), C2 (c0,c1)]
              = f_ot14 [M4 (m0,m1,m2,m3), C2 (c0,c1)] \<bind> (\<lambda> outputs. S2_14 (C2 (c0,c1)) (nth outputs 1))"
*)
lemma P2_OT_14_FT:
  shows "P2_security.real_view [M4 (m0,m1,m2,m3), C2 (False, True)]
              = return_spmf (f_ot14 [M4 (m0,m1,m2,m3), C2 (False, True)]) \<bind> (\<lambda> outputs. P2_security.ideal_view (C2 (False,True)) (nth outputs 1))"
  including monad_normalisation
proof-
  have "P2_security.real_view [M4 (m0,m1,m2,m3), C2 (False, True)] =  do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a0 :: bool \<leftarrow> map_spmf (\<lambda> S2. S0 \<oplus> S2 \<oplus> m0) coin_spmf;
    let a1 = S0 \<oplus> S3 \<oplus> m1;
    a2 \<leftarrow> map_spmf (\<lambda> S4. S1 \<oplus> S4 \<oplus> m2) coin_spmf;
    let a3 = S1 \<oplus> S5 \<oplus> m3;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S0);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S3);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S5);
    return_spmf (C2 (False,True), (a0,a1,a2,a3), a,b,c)}"
    by(simp add: bind_map_spmf o_def Let_def OT_12_P2_assm semi_honest_det_security.real_view_def)
  also have "... =  do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a0 :: bool \<leftarrow> coin_spmf;
    let a1 = S0 \<oplus> S3 \<oplus> m1;
    a2 \<leftarrow> coin_spmf;
    let a3 = S1 \<oplus> S5 \<oplus> m3;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S0);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S3);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S5);
    return_spmf (C2 (False,True), (a0,a1,a2,a3), a,b,c)}"
    using coin_coin' by simp
  also have "... =  do {
    S0 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a0 :: bool \<leftarrow> coin_spmf;
    let a1 = S0 \<oplus> S3 \<oplus> m1;
    a2 :: bool \<leftarrow> coin_spmf;
    a3 \<leftarrow> map_spmf (\<lambda> S1. S1 \<oplus> S5 \<oplus> m3) coin_spmf;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S0);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S3);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S5);
    return_spmf (C2 (False,True), (a0,a1,a2,a3), a,b,c)}"
    by(simp add: bind_map_spmf o_def Let_def)
  also have "... =  do {
    S0 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a0 :: bool \<leftarrow> coin_spmf;
    let a1 = S0 \<oplus> S3 \<oplus> m1;
    a2 :: bool \<leftarrow> coin_spmf;
    a3 \<leftarrow> coin_spmf;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S0);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S3);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S5);
    return_spmf (C2 (False,True), (a0,a1,a2,a3), a,b,c)}"
    using coin_coin by simp
  ultimately show ?thesis
    by(simp add: bind_spmf_const semi_honest_det_security.ideal_view_def)
qed

lemma P2_OT_14_TT:
  shows "P2_security.real_view [M4 (m0,m1,m2,m3), C2 (True,True)]
            = return_spmf (f_ot14 [M4 (m0,m1,m2,m3), C2 (True,True)])
              \<bind> (\<lambda> outputs. P2_security.ideal_view (C2 (True,True)) (nth outputs 1))"
  including monad_normalisation
proof-
  have "P2_security.real_view [M4 (m0,m1,m2,m3), C2 (True,True)] =  do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a0 :: bool \<leftarrow> map_spmf (\<lambda> S2. S0 \<oplus> S2 \<oplus> m0) coin_spmf;
    let a1 = S0 \<oplus> S3 \<oplus> m1;
    a2 \<leftarrow> map_spmf (\<lambda> S4. S1 \<oplus> S4 \<oplus> m2) coin_spmf;
    let a3 = S1 \<oplus> S5 \<oplus> m3;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S1);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S3);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S5);
    return_spmf (C2 (True,True), (a0,a1,a2,a3), a,b,c)}"
    by(simp add: bind_map_spmf o_def OT_12_P2_assm Let_def semi_honest_det_security.real_view_def)
  also have "... = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a0 :: bool \<leftarrow> coin_spmf;
    let a1 = S0 \<oplus> S3 \<oplus> m1;
    a2 \<leftarrow> coin_spmf;
    let a3 = S1 \<oplus> S5 \<oplus> m3;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S1);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S3);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S5);
    return_spmf (C2 (True,True), (a0,a1,a2,a3), a,b,c)}"
    using coin_coin' by simp
  also have "... = do {
    S1 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a0 :: bool \<leftarrow> coin_spmf;
    a1 :: bool \<leftarrow> map_spmf (\<lambda> S0. S0 \<oplus> S3 \<oplus> m1) coin_spmf;
    a2 \<leftarrow> coin_spmf;
    let a3 = S1 \<oplus> S5 \<oplus> m3;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S1);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S3);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S5);
    return_spmf (C2 (True,True), (a0,a1,a2,a3), a,b,c)}"
    by(simp add: bind_map_spmf o_def Let_def)
  also have "... = do {
    S1 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a0 :: bool \<leftarrow> coin_spmf;
    a1 :: bool \<leftarrow> coin_spmf;
    a2 \<leftarrow> coin_spmf;
    let a3 = S1 \<oplus> S5 \<oplus> m3;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S1);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S3);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S5);
    return_spmf (C2 (True,True), (a0,a1,a2,a3), a,b,c)}"
    using coin_coin by simp
  ultimately show ?thesis
    by(simp add: bind_spmf_const semi_honest_det_security.ideal_view_def)
qed

lemma P2_OT_14_FF:
  shows "P2_security.real_view [M4 (m0,m1,m2,m3), C2 (False, False)]
             = return_spmf (f_ot14 [M4 (m0,m1,m2,m3), C2 (False, False)])
                \<bind> (\<lambda> outputs. P2_security.ideal_view (C2 (False, False)) (nth outputs 1))"
  including monad_normalisation
proof-
  have "P2_security.real_view [M4 (m0,m1,m2,m3), C2 (False, False)] = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    let a0 = S0 \<oplus> S2 \<oplus> m0;
    a1 :: bool \<leftarrow> map_spmf (\<lambda> S3. S0 \<oplus> S3 \<oplus> m1) coin_spmf;
    let a2 = S1 \<oplus> S4 \<oplus> m2;
    a3 \<leftarrow> map_spmf (\<lambda> S5. S1 \<oplus> S5 \<oplus> m3) coin_spmf;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S0);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S2);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S4);
    return_spmf (C2 (False,False), (a0,a1,a2,a3), a,b,c)}"
    by(simp add: bind_map_spmf o_def OT_12_P2_assm Let_def semi_honest_det_security.real_view_def)
  also have "... = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    let a0 = S0 \<oplus> S2 \<oplus> m0;
    a1 :: bool \<leftarrow> coin_spmf;
    let a2 = S1 \<oplus> S4 \<oplus> m2;
    a3 \<leftarrow> coin_spmf;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S0);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S2);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S4);
    return_spmf (C2 (False,False), (a0,a1,a2,a3), a,b,c)}"
    using coin_coin' by simp
  also have "... = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    let a0 = S0 \<oplus> S2 \<oplus> m0;
    a1 :: bool \<leftarrow> coin_spmf;
    a2 :: bool \<leftarrow> map_spmf (\<lambda> S1. S1 \<oplus> S4 \<oplus> m2) coin_spmf;
    a3 \<leftarrow> coin_spmf;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S0);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S2);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S4);
    return_spmf (C2 (False,False), (a0,a1,a2,a3), a,b,c)}"
    by(simp add: bind_map_spmf o_def Let_def)
  also have "... = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    let a0 = S0 \<oplus> S2 \<oplus> m0;
    a1 :: bool \<leftarrow> coin_spmf;
    a2 :: bool \<leftarrow> coin_spmf;
    a3 \<leftarrow> coin_spmf;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S0);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S2);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S4);
    return_spmf (C2 (False,False), (a0,a1,a2,a3), a,b,c)}"
    using coin_coin by simp
  ultimately show ?thesis
    by(simp add: bind_spmf_const semi_honest_det_security.ideal_view_def)
qed

lemma P2_OT_14_TF: "P2_security.real_view [M4 (m0,m1,m2,m3), C2 (True,False)] = return_spmf (f_ot14 [M4 (m0,m1,m2,m3), C2 (True,False)])
          \<bind> (\<lambda> outputs. P2_security.ideal_view (C2 (True,False)) (nth outputs 1))"
  including monad_normalisation
proof-
  have "P2_security.real_view [M4 (m0,m1,m2,m3), C2 (True,False)] = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    let a0 = S0 \<oplus> S2 \<oplus> m0;
    a1 :: bool \<leftarrow> map_spmf (\<lambda> S3. S0 \<oplus> S3 \<oplus> m1) coin_spmf;
    let a2 = S1 \<oplus> S4 \<oplus> m2;
    a3 \<leftarrow> map_spmf (\<lambda> S5. S1 \<oplus> S5 \<oplus> m3) coin_spmf;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S1);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S2);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S4);
    return_spmf (C2 (True,False), (a0,a1,a2,a3), a,b,c)}"
    apply(simp add: OT_12_P2_assm Let_def semi_honest_det_security.real_view_def)
    apply(rewrite in "bind_spmf _ \<hole>" in "\<hole> = _" bind_commute_spmf)
    apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>" in "\<hole> = _" bind_commute_spmf)
    apply(rewrite in "bind_spmf _ \<hole>" in "bind_spmf _ \<hole>"  in "bind_spmf _ \<hole>" in "\<hole> = _" bind_commute_spmf)
    by(simp add: bind_map_spmf o_def Let_def)
  also have "... = do {
    S0 :: bool \<leftarrow> coin_spmf;
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    let a0 = S0 \<oplus> S2 \<oplus> m0;
    a1 :: bool \<leftarrow> coin_spmf;
    let a2 = S1 \<oplus> S4 \<oplus> m2;
    a3 \<leftarrow> coin_spmf;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S1);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S2);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S4);
    return_spmf (C2 (True,False), (a0,a1,a2,a3), a,b,c)}"
    using coin_coin' by simp
  also have "... = do {
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    a0 :: bool \<leftarrow> map_spmf (\<lambda> S0. S0 \<oplus> S2 \<oplus> m0) coin_spmf;
    a1 :: bool \<leftarrow> coin_spmf;
    let a2 = S1 \<oplus> S4 \<oplus> m2;
    a3 \<leftarrow> coin_spmf;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S1);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S2);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S4);
    return_spmf (C2 (True,False), (a0,a1,a2,a3), a,b,c)}"
    by(simp add: bind_map_spmf o_def Let_def)
  also have "... = do {
    S1 :: bool \<leftarrow> coin_spmf;
    S2 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    a0 :: bool \<leftarrow> coin_spmf;
    a1 :: bool \<leftarrow> coin_spmf;
    let a2 = S1 \<oplus> S4 \<oplus> m2;
    a3 \<leftarrow> coin_spmf;
    a :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 True) (P_ot12 S1);
    b :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S2);
    c :: 'ot12_view2 \<leftarrow> S2_OT12 (C1 False) (P_ot12 S4);
    return_spmf (C2 (True,False), (a0,a1,a2,a3), a,b,c)}"
    using coin_coin by simp
  ultimately show ?thesis
    by(simp add: bind_spmf_const semi_honest_det_security.ideal_view_def)
qed

lemma perfect_security_P2:
  shows "P2_security.real_view [M4 (m0,m1,m2,m3), C2 (c0,c1)]
            = return_spmf (f_ot14 [M4 (m0,m1,m2,m3), C2 (c0,c1)])
              \<bind> (\<lambda> outputs. P2_security.ideal_view (C2 (c0,c1)) (nth outputs 1))"
  apply(cases c0; cases c1)
  using P2_OT_14_FF P2_OT_14_TF P2_OT_14_FT P2_OT_14_TT by auto

lemma ot14_security_P1: "ot14_P1.advantage [M4 (m0,m1,m2,m3), C2 (c0,c1)] D \<le> 3 * ot12_adv_P1"
  unfolding ot14_P1.advantage_def
  using reduction_P1 by simp

lemma ot14_security_P2: "P2_security.perfect_security [M4 (m0,m1,m2,m3), C2 (c0,c1)]"
  unfolding P2_security.perfect_security_def
  using perfect_security_P2 by simp

end

locale OT_14_asymp =
  fixes R1_OT12 :: "nat \<Rightarrow> bool inputs_ot12 list \<Rightarrow> 'ot12_view1 spmf"
    and S1_OT12 :: "nat \<Rightarrow> bool inputs_ot12 \<Rightarrow> bool outputs_ot12 \<Rightarrow> 'ot12_view1 spmf"
    and R2_OT12 :: "nat \<Rightarrow> bool inputs_ot12 list \<Rightarrow> 'ot12_view2 spmf"
    and S2_OT12 :: "nat \<Rightarrow> bool inputs_ot12 \<Rightarrow> bool outputs_ot12 \<Rightarrow> 'ot12_view2 spmf"
    and protocol_ot12 :: "nat \<Rightarrow> bool inputs_ot12 list \<Rightarrow> bool outputs_ot12 list spmf"
    and ot12_adv_P1 :: "nat \<Rightarrow> real"
  assumes ot14_base: "\<And> (n::nat). ot14_base (R1_OT12 n) (S1_OT12 n) (R2_OT12 n) (S2_OT12 n) (protocol_ot12 n) (ot12_adv_P1 n)"
begin

sublocale ot14_base "(R1_OT12 n)" "(S1_OT12 n)" "(R2_OT12 n)" "(S2_OT12 n)" "(protocol_ot12 n)" "(ot12_adv_P1 n)"
  using local.ot14_base by simp

lemma bound_P1: "ot14_P1.advantage n [M4 (m0,m1,m2,m3), C2 (c0,c1)] D \<le> 3 * (ot12_adv_P1 n)"
  by(rule ot14_security_P1)

theorem OT_14_P1_asym_sec: "negligible (\<lambda> n. ot14_P1.advantage n [M4 (m0,m1,m2,m3), C2 (c0,c1)] D)" if "negligible (\<lambda> n. ot12_adv_P1 n)"
proof-
  have adv_neg: "negligible (\<lambda>n. 3 * ot12_adv_P1 n)" using that negligible_cmultI by simp
  have "\<bar>ot14_P1.advantage n [M4 (m0,m1,m2,m3), C2 (c0,c1)] D\<bar> \<le> \<bar>3 * (ot12_adv_P1 n)\<bar>" for n
  proof -
    have "\<bar>ot14_P1.advantage n [M4 (m0,m1,m2,m3), C2 (c0,c1)] D\<bar> \<le> 3 * ot12_adv_P1 n"
      using ot14_P1.advantage_def ot14_base.ot14_security_P1 ot14_base_axioms bound_P1 by auto
    then show ?thesis
      by (meson abs_ge_self order_trans)
  qed
  thus ?thesis using bound_P1 negligible_le adv_neg
    by (metis (no_types, lifting) negligible_absI)
qed

theorem ot14_: "P2_security.perfect_security n [M4 (m0,m1,m2,m3), C2 (c0,c1)]"
  by(rule ot14_security_P2)

theorem ot14_correct: "ot14_correct.correctness n [M4 (m0,m1,m2,m3), C2 (c0,c1)]"
  by(rule ot14_correct)

end

end


(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

header {* Semantics *}

theory Semantics
imports Sequence Intensional
begin

text {*
  This theory mechanises a \emph{shallow} embedding of \tlastar{} using the
  @{text Sequence} and @{text Intensional} theories. A shallow embedding
  represents \tlastar{} using Isabelle/HOL predicates, while a \emph{deep}
  embedding would represent \tlastar{} formulas and pre-formulas as mutually
  inductive datatypes\footnote{See e.g. \cite{Wildmoser04} for a discussion
  about deep vs. shallow embeddings in Isabelle/HOL.}.
  The choice of a shallow over a deep embedding is motivated by the following
  factors: a shallow embedding is usually less involved, and existing Isabelle
  theories and tools can be applied more directly to enhance automation; due to
  the lifting in the @{text Intensional} theory, a shallow embedding can reuse
  standard logical operators, whilst a deep embedding requires a different
  set of operators for both formulas and pre-formulas. Finally, since our
  target is system verification rather than proving meta-properties of \tlastar{},
  which requires a deep embedding, a shallow embedding is more fit for purpose.
*}

subsection "Types of Formulas"

text {*
  To mechanise the \tlastar{} semantics, the following
  type abbreviations are used:
*}

type_synonym ('a,'b) formfun = "'a seq \<Rightarrow> 'b"
type_synonym 'a formula = "('a,bool) formfun"
type_synonym ('a,'b) stfun = "'a \<Rightarrow> 'b"
type_synonym 'a stpred = "('a,bool) stfun"

instance
 "fun" :: (type,type) world ..

instance
 "prod" :: (type,type) world ..

text {*
  Pair and function are instantiated to be of type class world.
  This allows use of the lifted intensional logic for formulas, and
  standard logical connectives can therefore be used.
*}

subsection "Semantics of TLA*"

text {* The semantics of \tlastar{} is defined. *}

definition always :: "('a::world) formula \<Rightarrow> 'a formula"
where "always F \<equiv> \<lambda> s. \<forall> n. (s |\<^sub>s n) \<Turnstile> F"

definition nexts :: "('a::world) formula \<Rightarrow> 'a formula"
where "nexts F \<equiv> \<lambda> s. (tail s) \<Turnstile> F"

definition before :: "('a::world,'b) stfun \<Rightarrow> ('a,'b) formfun"
where "before f \<equiv> \<lambda> s. (first s) \<Turnstile> f"

definition after :: "('a::world,'b) stfun \<Rightarrow> ('a,'b) formfun"
where "after f \<equiv> \<lambda> s. (second s) \<Turnstile> f"

definition unch  :: "('a::world,'b) stfun \<Rightarrow> 'a formula"
where "unch v \<equiv> \<lambda> s. s \<Turnstile> (after v) = (before v)"

definition action :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "action P v \<equiv> \<lambda> s. \<forall> i. ((s |\<^sub>s i) \<Turnstile> P) \<or> ((s |\<^sub>s i) \<Turnstile> unch v)"

subsubsection "Concrete Syntax"

text{* This is the concrete syntax for the (abstract) operators above. *}

syntax
 "_always" :: "lift \<Rightarrow> lift" ("([]_)" [90] 90)
 "_nexts" :: "lift \<Rightarrow> lift" ("(Next _)" [90] 90)
 "_action" :: "[lift,lift] \<Rightarrow> lift" ("([][_]'_(_))" [20,1000] 90)
 "_before"    :: "lift \<Rightarrow> lift"  ("($_)" [100] 99)
 "_after"     :: "lift \<Rightarrow> lift"  ("(_$)" [100] 99)
 "_prime"     :: "lift \<Rightarrow> lift"  ("(_`)" [100] 99)
 "_unch"     :: "lift \<Rightarrow> lift"  ("(Unchanged _)" [100] 99)
 "TEMP"  :: "lift \<Rightarrow> 'b" ("(TEMP _)")

translations
 "_always" \<rightleftharpoons> "CONST always"
 "_nexts" \<rightleftharpoons> "CONST nexts"
 "_action" \<rightleftharpoons> "CONST action"
 "_before"    \<rightleftharpoons> "CONST before"
 "_after"     \<rightleftharpoons> "CONST after"
 "_prime"     \<rightharpoonup> "CONST after"
 "_unch"     \<rightleftharpoons> "CONST unch"
 "TEMP F" \<rightharpoonup> "(F:: (nat \<Rightarrow> _) \<Rightarrow> _)"

syntax (xsymbols)
 "_always" :: "lift \<Rightarrow> lift" ("(\<box>_)" [90] 90)
 "_nexts" :: "lift \<Rightarrow> lift" ("(\<circ>_)" [90] 90)
 "_action" :: "[lift,lift] \<Rightarrow> lift" ("(\<box>[_]'_(_))" [20,1000] 90)

subsection "Abbreviations"

text {* Some standard temporal abbreviations, with their concrete syntax. *}

definition actrans :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "actrans P v \<equiv> TEMP(P \<or> unch v)"

definition eventually :: "('a::world) formula \<Rightarrow> 'a formula"
where "eventually F \<equiv> LIFT(\<not>\<box>(\<not>F))"

definition angle_action :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "angle_action P v \<equiv> LIFT(\<not>\<box>[\<not>P]_v)"

definition angle_actrans :: "('a::world) formula \<Rightarrow> ('a,'b) stfun \<Rightarrow> 'a formula"
where "angle_actrans P v \<equiv> TEMP (\<not> actrans (LIFT(\<not>P)) v)"

definition leadsto :: "('a::world) formula \<Rightarrow> 'a formula \<Rightarrow> 'a formula"
where "leadsto P Q \<equiv> LIFT \<box>(P \<longrightarrow> eventually Q)"

subsubsection "Concrete Syntax"

syntax
  "_actrans" :: "[lift,lift] \<Rightarrow> lift" ("([_]'_(_))"  [20,1000] 90)
  "_eventually" :: "lift \<Rightarrow> lift" ("(<>_)" [90] 90)
  "_angle_action" :: "[lift,lift] \<Rightarrow> lift" ("(<><_>'_(_))" [20,1000] 90)
  "_angle_actrans" :: "[lift,lift] \<Rightarrow> lift" ("(<_>'_(_))" [20,1000] 90)
  "_leadsto" :: "[lift,lift] \<Rightarrow> lift" ("(_ ~> _)" [26,25] 25)

translations
  "_actrans" \<rightleftharpoons> "CONST actrans"
  "_eventually" \<rightleftharpoons> "CONST eventually"
  "_angle_action" \<rightleftharpoons> "CONST angle_action"
  "_angle_actrans" \<rightleftharpoons> "CONST angle_actrans"
  "_leadsto" \<rightleftharpoons> "CONST leadsto"

syntax (xsymbols)
  "_eventually" :: "lift \<Rightarrow> lift" ("(\<diamond>_)" [90] 90)
  "_angle_action" :: "[lift,lift] \<Rightarrow> lift" ("(\<diamond>\<langle>_\<rangle>'_(_))" [20,1000] 90)
  "_angle_actrans" :: "[lift,lift] \<Rightarrow> lift" ("(\<langle>_\<rangle>'_(_))" [20,1000] 90)
  "_leadsto" :: "[lift,lift] \<Rightarrow> lift" ("(_ \<leadsto> _)" [26,25] 25)

subsection "Properties of Operators"

text {* The following lemmas show that these operators have the expected semantics. *}

lemma eventually_defs: "(w \<Turnstile> \<diamond> F) = (\<exists> n. (w |\<^sub>s n) \<Turnstile> F)"
  by (simp add: eventually_def always_def)

lemma angle_action_defs: "(w \<Turnstile> \<diamond>\<langle>P\<rangle>_v) = (\<exists> i. ((w |\<^sub>s i) \<Turnstile> P) \<and> ((w |\<^sub>s i) \<Turnstile> v$ \<noteq> $v))"
  by (simp add: angle_action_def action_def unch_def)

lemma unch_defs: "(w \<Turnstile> Unchanged v) = (((second w) \<Turnstile> v) = ((first w) \<Turnstile> v))"
  by (simp add: unch_def before_def nexts_def after_def tail_def suffix_def first_def second_def)

lemma linalw:
  assumes h1: "a \<le> b" and h2: "(w |\<^sub>s a) \<Turnstile> \<box>A"
  shows "(w |\<^sub>s b) \<Turnstile> \<box>A"
proof (clarsimp simp: always_def)
  fix n
  from h1 obtain k where g1: "b = a + k" by (auto simp: le_iff_add)
  with h2 show "(w |\<^sub>s b |\<^sub>s n) \<Turnstile> A" by (auto simp: always_def suffix_plus ac_simps)
qed

subsection "Invariance Under Stuttering"

text {*
  A key feature of \tlastar{} is that specification at different abstraction
  levels can be compared. The soundness of this relies on the stuttering invariance
  of formulas. Since the embedding is shallow, it cannot be shown that a generic
  \tlastar{} formula is stuttering invariant. However, this section will show that
  each operator is stuttering invariant or preserves stuttering invariance in an
  appropriate sense, which can be used to show stuttering invariance
  for given specifications.

  Formula @{text F} is stuttering invariant if for any two similar behaviours
  (i.e., sequences of states), @{text F} holds in one iff it holds in the other.
  The definition is generalised to arbitrary expressions, and not just predicates.
*}

definition stutinv :: "('a,'b) formfun \<Rightarrow> bool"
where "stutinv F \<equiv> \<forall> \<sigma> \<tau>. \<sigma> \<approx> \<tau> \<longrightarrow> (\<sigma> \<Turnstile> F) = (\<tau> \<Turnstile> F)"

text{*
  The requirement for stuttering invariance is too strong for pre-formulas.
  For example, an action formula specifies a relation between the first two states
  of a behaviour, and will rarely be satisfied by a stuttering step. This is why
  pre-formulas are ``protected'' by (square or angle) brackets in \tlastar{}:
  the only place a pre-formula @{text P} can be used is inside an action:
  @{text "\<box>[P]_v"}.
  To show that @{text "\<box>[P]_v"} is stuttering invariant, is must be shown that a
  slightly weaker predicate holds for @{term P}. For example, if @{term P} contains
  a term of the form @{text "\<circ>\<circ>Q"}, then it is not a well-formed pre-formula, thus
  @{text "\<box>[P]_v"} is not stuttering invariant. This weaker version of
  stuttering invariance has been named \emph{near stuttering invariance}.
*}

definition nstutinv :: "('a,'b) formfun \<Rightarrow> bool"
where "nstutinv P \<equiv> \<forall> \<sigma> \<tau>. (first \<sigma> = first \<tau>) \<and> (tail \<sigma>) \<approx> (tail \<tau>) \<longrightarrow> (\<sigma> \<Turnstile> P) = (\<tau> \<Turnstile> P)"

syntax
  "_stutinv" :: "lift \<Rightarrow> bool" ("(STUTINV _)" [40] 40)
  "_nstutinv" :: "lift \<Rightarrow> bool" ("(NSTUTINV _)" [40] 40)

translations
  "_stutinv" \<rightleftharpoons> "CONST stutinv"
  "_nstutinv" \<rightleftharpoons> "CONST nstutinv"

text {*
  Predicate @{term "stutinv F"} formalises stuttering invariance for
  formula @{term F}. That is if two sequences are similar @{term "s \<approx> t"} (equal up
  to stuttering) then the validity of @{term F} under both @{term s} and @{term t}
  are equivalent. Predicate @{term "nstutinv P"} should be read as \emph{nearly
  stuttering invariant} -- and is required for some stuttering invariance proofs.
*}

lemma stutinv_strictly_stronger:
  assumes h: "STUTINV F" shows "NSTUTINV F"
  unfolding nstutinv_def
proof (clarify)
  fix s t :: "nat \<Rightarrow> 'a"
  assume a1: "first s = first t" and a2: "(tail s) \<approx> (tail t)"
  have "s \<approx> t"
  proof -
    have tg1: "(first s) ## (tail s) = s" by (rule seq_app_first_tail)
    have tg2: "(first t) ## (tail t) = t" by (rule seq_app_first_tail)
    with a1 have tg2': "(first s) ## (tail t) = t" by simp
    from a2 have "(first s) ## (tail s) \<approx> (first s) ## (tail t)" by (rule app_seqsimilar)
    with tg1 tg2' show ?thesis by simp
  qed
  with h show "(s \<Turnstile> F) = (t \<Turnstile> F)" by (simp add: stutinv_def)
qed

subsubsection "Properties of @{term stutinv}"

text {*
  This subsection proves stuttering invariance, preservation of stuttering invariance
  and introduction of stuttering invariance for different formulas.
  First, state predicates are stuttering invariant.
*}

theorem stut_before: "STUTINV $F"
proof (clarsimp simp: stutinv_def)
  fix s t :: "'a seq"
  assume a1: "s \<approx> t"
  hence "(first s) = (first t)" by (rule sim_first)
  thus "(s \<Turnstile> $F) = (t \<Turnstile> $F)" by (simp add: before_def)
qed

lemma nstut_after: "NSTUTINV F$"
proof (clarsimp simp: nstutinv_def)
  fix s t :: "'a seq"
  assume a1: "tail s \<approx> tail t"
  thus "(s \<Turnstile> F$) = (t \<Turnstile> F$)" by (simp add: after_def tail_sim_second)
qed

text{* The always operator preserves stuttering invariance. *}

theorem stut_always: assumes H:"STUTINV F" shows "STUTINV \<box>F"
proof (clarsimp simp: stutinv_def)
  fix s t :: "'a seq"
  assume a2: "s \<approx> t"
  show "(s \<Turnstile> (\<box> F)) = (t \<Turnstile> (\<box> F))"
  proof
    assume a1: "t \<Turnstile> \<box> F"
    show "s \<Turnstile> \<box> F"
    proof (clarsimp simp: always_def)
      fix n
      from a2[THEN sim_step] obtain m where m: "s |\<^sub>s n \<approx> t |\<^sub>s m" by blast
      from a1 have "(t |\<^sub>s m) \<Turnstile> F" by (simp add: always_def)
      with H m show "(s |\<^sub>s n) \<Turnstile> F" by (simp add: stutinv_def)
    qed
  next
    assume a1: "s \<Turnstile> (\<box> F)"
    show "t \<Turnstile> (\<box> F)"
    proof (clarsimp simp: always_def)
      fix n
      from a2[THEN seqsim_sym, THEN sim_step] obtain m where m: "t |\<^sub>s n \<approx> s |\<^sub>s m" by blast
      from a1 have "(s |\<^sub>s m) \<Turnstile> F" by (simp add: always_def)
      with H m show "(t |\<^sub>s n) \<Turnstile> F" by (simp add: stutinv_def)
    qed
  qed
qed

text {*
  Assuming that formula @{term P} is nearly suttering invariant
  then @{text "\<box>[P]_v"} will be stuttering invariant.
*}

lemma stut_action_lemma:
  assumes H: "NSTUTINV P" and st: "s \<approx> t" and P: "t \<Turnstile> \<box>[P]_v"
  shows "s \<Turnstile> \<box>[P]_v"
proof (clarsimp simp: action_def)
  fix n
  assume "\<not> ((s |\<^sub>s n) \<Turnstile> Unchanged v)"
  hence v: "v (s (Suc n)) \<noteq> v (s n)"
    by (simp add: unch_defs first_def second_def suffix_def)
  from st[THEN sim_step] obtain m where
    a2': "s |\<^sub>s n \<approx> t |\<^sub>s m
          \<and> (s |\<^sub>s Suc n \<approx> t |\<^sub>s Suc m \<or> s |\<^sub>s Suc n \<approx> t |\<^sub>s m)" ..
  hence g1: "(s |\<^sub>s n \<approx> t |\<^sub>s m)" by simp
  hence g1'': "first (s |\<^sub>s n) = first (t |\<^sub>s m)" by (simp add: sim_first)
  hence g1': "s n = t m" by (simp add: suffix_def first_def)
  from a2' have g2: "s |\<^sub>s Suc n \<approx> t |\<^sub>s Suc m \<or> s |\<^sub>s Suc n \<approx> t |\<^sub>s m" by simp
  from P have a1': "((t |\<^sub>s m) \<Turnstile> P) \<or> ((t |\<^sub>s m) \<Turnstile> Unchanged v)" by (simp add: action_def)
  from g2 show "(s |\<^sub>s n) \<Turnstile> P"
  proof
    assume "s |\<^sub>s Suc n \<approx> t |\<^sub>s m"
    hence "first (s |\<^sub>s Suc n) = first (t |\<^sub>s m)" by (simp add: sim_first)
    hence "s (Suc n) = t m" by (simp add: suffix_def first_def)
    with g1' v show ?thesis by simp  -- {* by contradiction *}
  next
    assume a3: "s |\<^sub>s Suc n \<approx> t |\<^sub>s Suc m"
    hence "first (s |\<^sub>s Suc n) = first (t |\<^sub>s Suc m)" by (simp add: sim_first)
    hence a3': "s (Suc n) = t (Suc m)" by (simp add: suffix_def first_def)
    from a1' show ?thesis
    proof
      assume "(t |\<^sub>s m) \<Turnstile> Unchanged v"
      hence "v (t (Suc m)) = v (t m)"
        by (simp add: unch_defs first_def second_def suffix_def)
      with g1' a3' v show ?thesis by simp  -- {* again, by contradiction *}
    next
      assume a4: "(t |\<^sub>s m) \<Turnstile> P"
      from a3 have "tail (s |\<^sub>s n) \<approx> tail (t |\<^sub>s m)" by (simp add: tail_def suffix_plus)
      with H g1'' a4 show ?thesis by (auto simp: nstutinv_def)
    qed
  qed
qed

theorem stut_action: assumes H: "NSTUTINV P" shows "STUTINV \<box>[P]_v"
proof (clarsimp simp: stutinv_def)
  fix s t :: "'a seq"
  assume st: "s \<approx> t"
  show "(s \<Turnstile> \<box>[P]_v) = (t \<Turnstile> \<box>[P]_v)"
  proof
    assume "t \<Turnstile> \<box>[P]_v"
    with H st show "s \<Turnstile> \<box>[P]_v" by (rule stut_action_lemma)
  next
    assume "s \<Turnstile> \<box>[P]_v"
    with H st[THEN seqsim_sym] show "t \<Turnstile> \<box>[P]_v" by (rule stut_action_lemma)
  qed
qed

text {*
  The lemmas below shows that propositional and predicate operators
  preserve stuttering invariance.
*}

lemma stut_and: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<and> G)"
  by (simp add: stutinv_def)

lemma stut_or: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<or> G)"
  by (simp add: stutinv_def)

lemma stut_imp: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<longrightarrow> G)"
  by (simp add: stutinv_def)

lemma stut_eq: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F = G)"
  by (simp add: stutinv_def)

lemma stut_noteq: "\<lbrakk>STUTINV F;STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<noteq> G)"
  by (simp add: stutinv_def)

lemma stut_not: "STUTINV F \<Longrightarrow> STUTINV (\<not> F)"
  by (simp add: stutinv_def)

lemma stut_all: "(\<And>x. STUTINV (F x)) \<Longrightarrow> STUTINV (\<forall> x. F x)"
  by (simp add: stutinv_def)

lemma stut_ex: "(\<And>x. STUTINV (F x)) \<Longrightarrow> STUTINV (\<exists> x. F x)"
  by (simp add: stutinv_def)

lemma stut_const: "STUTINV #c"
  by (simp add: stutinv_def)

lemma stut_fun1: "STUTINV X \<Longrightarrow> STUTINV (f <X>)"
  by (simp add: stutinv_def)

lemma stut_fun2: "\<lbrakk>STUTINV X;STUTINV Y\<rbrakk> \<Longrightarrow> STUTINV (f <X,Y>)"
  by (simp add: stutinv_def)

lemma stut_fun3: "\<lbrakk>STUTINV X;STUTINV Y;STUTINV Z\<rbrakk> \<Longrightarrow> STUTINV (f <X,Y,Z>)"
  by (simp add: stutinv_def)

lemma stut_fun4: "\<lbrakk>STUTINV X;STUTINV Y;STUTINV Z; STUTINV W\<rbrakk> \<Longrightarrow> STUTINV (f <X,Y,Z,W>)"
  by (simp add: stutinv_def)

lemma stut_plus: "\<lbrakk>STUTINV x;STUTINV y\<rbrakk> \<Longrightarrow> STUTINV (x+y)"
  by (simp add: stutinv_def)

subsubsection "Properties of @{term nstutinv}"

text {*
  This subsection shows analogous properties about near stuttering
  invariance.

  If a formula @{term F} is stuttering invariant then @{text "\<circ>F"} is
  nearly stuttering invariant.
*}

lemma nstut_nexts: assumes H: "STUTINV F" shows "NSTUTINV \<circ>F"
using H by (simp add: stutinv_def nstutinv_def nexts_def)

text {*
  The lemmas below shows that propositional and predicate operators
  preserves near stuttering invariance.
*}

lemma nstut_and: "\<lbrakk>NSTUTINV F;NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F \<and> G)"
  by (auto simp: nstutinv_def)

lemma nstut_or: "\<lbrakk>NSTUTINV F;NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F \<or> G)"
  by (auto simp: nstutinv_def)

lemma nstut_imp: "\<lbrakk>NSTUTINV F;NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F \<longrightarrow> G)"
  by (auto simp: nstutinv_def)

lemma nstut_eq: "\<lbrakk>NSTUTINV F; NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F = G)"
  by (force simp: nstutinv_def)

lemma nstut_not: "NSTUTINV F \<Longrightarrow> NSTUTINV (\<not> F)"
  by (auto simp: nstutinv_def)

lemma nstut_noteq: "\<lbrakk>NSTUTINV F; NSTUTINV G\<rbrakk> \<Longrightarrow> NSTUTINV (F \<noteq> G)"
  by (simp add: nstut_eq nstut_not)

lemma nstut_all: "(\<And>x. NSTUTINV (F x)) \<Longrightarrow> NSTUTINV (\<forall> x. F x)"
  by (auto simp: nstutinv_def)

lemma nstut_ex: "(\<And>x. NSTUTINV (F x)) \<Longrightarrow> NSTUTINV (\<exists> x. F x)"
  by (auto simp: nstutinv_def)

lemma nstut_const: "NSTUTINV #c"
  by (auto simp: nstutinv_def)

lemma nstut_fun1: "NSTUTINV X \<Longrightarrow> NSTUTINV (f <X>)"
  by (force simp: nstutinv_def)

lemma nstut_fun2: "\<lbrakk>NSTUTINV X; NSTUTINV Y\<rbrakk> \<Longrightarrow> NSTUTINV (f <X,Y>)"
  by (force simp: nstutinv_def)

lemma nstut_fun3: "\<lbrakk>NSTUTINV X; NSTUTINV Y; NSTUTINV Z\<rbrakk> \<Longrightarrow> NSTUTINV (f <X,Y,Z>)"
  by (force simp: nstutinv_def)

lemma nstut_fun4: "\<lbrakk>NSTUTINV X; NSTUTINV Y; NSTUTINV Z; NSTUTINV W\<rbrakk> \<Longrightarrow> NSTUTINV (f <X,Y,Z,W>)"
  by (force simp: nstutinv_def)

lemma nstut_plus: "\<lbrakk>NSTUTINV x;NSTUTINV y\<rbrakk> \<Longrightarrow> NSTUTINV (x+y)"
  by (simp add: nstut_fun2)

subsubsection "Abbreviations"

text {*
  We show the obvious fact that the same properties holds for abbreviated
  operators.
*}

lemmas nstut_before = stut_before[THEN stutinv_strictly_stronger]

lemma nstut_unch: "NSTUTINV (Unchanged v)"
proof (unfold unch_def)
  have g1: "NSTUTINV v$" by (rule nstut_after)
  have "NSTUTINV $v" by (rule stut_before[THEN stutinv_strictly_stronger])
  with g1 show "NSTUTINV (v$ = $v)" by (rule nstut_eq)
qed

text{*
  Formulas @{text "[P]_v"} are not \tlastar{} formulas by themselves,
  but we need to reason about them when they appear wrapped
  inside @{text "\<box>[-]_v"}. We only require that it preserves nearly
  stuttering invariance. Observe that @{text "[P]_v"} trivially holds for
  a stuttering step, so it cannot be stuttering invariant.
*}

lemma nstut_actrans: "NSTUTINV P \<Longrightarrow> NSTUTINV [P]_v"
  by (simp add: actrans_def nstut_unch nstut_or)

lemma stut_eventually: "STUTINV F \<Longrightarrow> STUTINV \<diamond>F"
  by (simp add: eventually_def stut_not stut_always)

lemma stut_leadsto: "\<lbrakk>STUTINV F; STUTINV G\<rbrakk> \<Longrightarrow> STUTINV (F \<leadsto> G)"
  by (simp add: leadsto_def stut_always stut_eventually stut_imp)

lemma stut_angle_action: "NSTUTINV P \<Longrightarrow> STUTINV \<diamond>\<langle>P\<rangle>_v"
  by (simp add: angle_action_def nstut_not stut_action stut_not)

lemma nstut_angle_acttrans: "NSTUTINV P \<Longrightarrow> NSTUTINV \<langle>P\<rangle>_v"
  by (simp add: angle_actrans_def nstut_not nstut_actrans)

lemmas stutinvs = stut_before stut_always stut_action
  stut_and stut_or stut_imp stut_eq stut_noteq stut_not
  stut_all stut_ex stut_eventually stut_leadsto stut_angle_action stut_const
  stut_fun1 stut_fun2 stut_fun3 stut_fun4

lemmas nstutinvs =  nstut_after nstut_nexts nstut_actrans
  nstut_unch nstut_and nstut_or nstut_imp nstut_eq nstut_noteq nstut_not
  nstut_all nstut_ex nstut_angle_acttrans stutinv_strictly_stronger
  nstut_fun1 nstut_fun2 nstut_fun3 nstut_fun4 stutinvs[THEN stutinv_strictly_stronger]

lemmas bothstutinvs = stutinvs nstutinvs

end


theory ImpCtl_Ghost
  imports "../Gensyn" "../Gensyn_Descend" "../Mergeable/Mergeable" "../Mergeable/MergeableInstances"
          "../Lifting/LiftUtils" "../Lifting/LiftInstances"
          "../Lifting/AutoLift" "../Hoare/Hoare_Ghost" "../Lifting/LangCompFull"
          "Utils"
          "./Seq"
begin

(* conditional/boolean expressions *)
datatype cond_syn' =
  Seqz
  | Sltz
  | Sgtz
  | Sskip_cond

type_synonym cond_state' = "bool * int"

definition cond_sem :: "cond_syn' \<Rightarrow> cond_state' \<Rightarrow> cond_state'" where
"cond_sem x s =
  (case s of (b, i) \<Rightarrow>
    (case x of
      Seqz \<Rightarrow> ((i = 0), i)
      | Sltz \<Rightarrow> ((i < 0), i)
      | Sgtz \<Rightarrow> ((i > 0), i)
      | Sskip_cond \<Rightarrow> s))"

(* Imp control
- IF
- WHILE
- SKIP
*)

datatype syn' =
  Sif
  | Sskip
  | Swhile
  | SwhileC

(* now, we include ghost state as concrete state. *)
type_synonym 'x imp_state' = "'x gensyn list * int * bool"

type_synonym 'x state' = "'x gensyn list * bool * int * int"

(* TODO: finish while case *)
(* TODO: error? *)
(*
while ==
- push condition
- push while [body]
- push while [cond, body]
*)

(* while [body] \<Longrightarrow> check condition *)

definition imp_ctl_sem :: "syn' \<Rightarrow> 'x imp_state' \<Rightarrow> 'x imp_state'" where
"imp_ctl_sem x st =
  (case st of
    ([], b) \<Rightarrow> ([], b)
    | ((G z l)#t, b) \<Rightarrow>
      ((case x of
        Sskip \<Rightarrow> t
        | Sif \<Rightarrow>
        (case l of
          [body] \<Rightarrow> (if b then body#t else t)
          | [cond, body] \<Rightarrow> cond# ((G z [body])#t)
          | _ \<Rightarrow> [] \<comment>\<open> error \<close>)
        | Swhile \<Rightarrow>
        (case l of
         [cond, body] \<Rightarrow> cond # (G z [cond, cond, body]) # t
         | [cond, _, body] \<Rightarrow> (if b then body # (G z [cond, body]) # t else t)
         | _ \<Rightarrow> [] \<comment> \<open> error \<close>)
        | SwhileC \<Rightarrow>
        (case l of [body] \<Rightarrow> (if b then body # (G z [body]) # t else t)
         | _ \<Rightarrow> []))
      , b))"

(*
while (full - boolean  on stack)
if b then body # while # t else t

*)

datatype syn =
  Simp syn'
  | Scond cond_syn'
  | Seq "Seq.syn"

type_synonym ('s, 'x) state =
  "('s, (bool md_triv option md_prio * int md_triv option md_prio * 'x)) control"

type_synonym ('s) cstate =
  "('s, unit option) state"

definition imp_trans :: "ImpCtl_Ghost.syn \<Rightarrow> ImpCtl_Ghost.syn'" where
"imp_trans s =
  (case s of
    Simp s' \<Rightarrow> s'
    | _ \<Rightarrow> Sskip)"

definition cond_trans :: "syn \<Rightarrow> cond_syn'" where
"cond_trans s =
  (case s of
    Scond x \<Rightarrow> x
    | _ \<Rightarrow> Sskip_cond)"

definition seq_trans :: "syn \<Rightarrow> Seq.syn" where
"seq_trans s =
  (case s of
    Seq x \<Rightarrow> x
    | _ \<Rightarrow> Seq.Sskip)"

definition imp_prio :: "(syn' \<Rightarrow> nat)" where
"imp_prio x =
(case x of
    Sskip \<Rightarrow> 0
    | _ \<Rightarrow> 2)"

(* failed experiments in trying to coax the auto-lifter *)

(*
definition imp_sem_l :: "syn \<Rightarrow> 'x state \<Rightarrow> 'x state" where
"imp_sem_l =
  lift_map_s imp_trans
    (schem_lift (SP NA (SP NB NC))
                (SP (SPRC imp_prio (SO NA)) (SP (SPRK (SO NB)) (SPRK (SO NC)))))
  imp_ctl_sem"
*)
(*
definition imp_sem_lifting_gen_huh ::  "(ImpCtl.syn', 'x gensyn list * int,
                                      ('a :: Pordb ) *
                                      ('x gensyn list md_triv option md_prio * int md_triv option md_prio)) lifting" where
"imp_sem_lifting_gen_huh =
 (schem_lift (SP NA NB) (SP NX (SP (SPRI (SO NA)) (SPRI (SO NB)))))"
*)

(*
definition imp_sem_lifting_gen_huh ::  "(ImpCtl.syn', 'x gensyn list,
                                      ('x gensyn list md_triv option md_prio *
                                           ('a :: Pordb ))) lifting" where
"imp_sem_lifting_gen_huh =
 (schem_lift NA (SP (SPRI (SO NA)) NX))"
*)

definition imp_sem_lifting_gen :: "(ImpCtl_Ghost.syn', 'x imp_state',
                                   ('x, _ ) state) lifting" where
"imp_sem_lifting_gen =
 (schem_lift (SP NA NB)
             (SP (SPRC imp_prio (SO NA)) (SP NX (SP (SPRK (SO NB)) NX))))"

definition imp_sem_l_gen :: "('s \<Rightarrow> ImpCtl_Ghost.syn') \<Rightarrow> 's \<Rightarrow> ('x, 'z :: Mergeableb) state \<Rightarrow> ('x, 'z) state" where
"imp_sem_l_gen lfts =
  lift_map_s lfts
    imp_sem_lifting_gen
  imp_ctl_sem"

definition seq_sem_l' :: "syn \<Rightarrow> ('x, 'z :: Mergeableb) state \<Rightarrow> ('x, 'z) state" where
"seq_sem_l' = seq_sem_l_gen seq_trans"

definition sems :: "(syn \<Rightarrow> ('x, 'z :: Mergeableb) state \<Rightarrow> ('x, 'z :: Mergeableb) state) list" where
"sems = [seq_sem_l_gen seq_trans, imp_sem_l_gen imp_trans]"

definition sem_final :: "(syn, 'x, bool md_triv option md_prio *
                                           int md_triv option md_prio
                                    * unit option) sem" where
"sem_final = \<lparr> s_sem = (pcomps' sems) \<rparr>"

definition prog where
"prog = (G (Seq Sseq) [(G (Seq Sseq) []),
                        (G (Simp Sif) [(G (Seq Sseq) []), (G (Seq Sseq) [])])])"

(* TODO: correctness theorem would be cleaner if we had a way to say that
   boolean expressions can't affect control flow (also in terms of domination?)
*)

definition get_cond ::
"bool md_triv option md_prio *
  int md_triv option md_prio *
  (_ :: Pordb) \<Rightarrow> bool option" where
"get_cond st =
  (case st of
    (b, _, _) \<Rightarrow>
    (case b of
      (mdp _ (Some (mdt b'))) \<Rightarrow> Some b'
      | _ \<Rightarrow> None))"

(*
do we need to take into account "separation" between imp and cond?
we probably need to model cond running for possibly multiple steps.
*)
(* can we eliminate P2? *)
(* probably not, unless we require P2 to be an expression language.
   besides this should be fine. *)
(* we need to enforce that the initial state is valid.
that is, that it falls into the valid set given by the imp lifting. *)
lemma HIf_gen :
  assumes H0 : "gs = \<lparr> s_sem = pcomps' fs \<rparr>"
  (*assumes H1 : "seq_sem_l_gen lfts \<in> set fs" *)
  assumes HF : "f = imp_sem_l_gen lfts"
  assumes Hpres : "sups_pres (set fs)"
  assumes Hnemp : "g \<in> set fs"
  assumes Hdom : "(f \<downharpoonleft> (set fs) Sif')"
  assumes Hsyn : "lfts Sif' = Sif"
  (* TODO: generalize. these should be expressed using valid-sets *)
  assumes P1_valid : "\<And> st.  P1 st \<Longrightarrow> get_cond st \<noteq> None"
  assumes P2_valid : "\<And> st . P2 st \<Longrightarrow> get_cond st \<noteq> None"

  assumes Hcond : "|gs| {- P1 -} [cond] {- P2 -}"
  assumes Htrue : "|gs| {- (\<lambda> st . P2 st \<and> get_cond st = Some True) -} [body]
                        {- P3 -}"
  assumes Hfalse : "|gs| {- (\<lambda> st . P2 st \<and> get_cond st = Some False) -} [] {-P3-}"
  shows "|gs| {- P1 -} [G Sif' [cond, body]] {- P3 -}"
proof
  fix c'
  assume Guard : "|gs| {P3} c'"

(* need to think about how we are structuring states. *)
(* where will the data of interest be *)
  have Gtrue : "|gs| {\<lambda>st. P2 st \<and> get_cond st = Some True} [body] @ c'"
    using HTE[OF Htrue Guard] by auto

  have Gfalse : "|gs| {\<lambda>st. P2 st \<and> get_cond st = Some False} [] @ c'"
    using HTE[OF Hfalse Guard] by auto

  show "|gs| {P1} [G Sif' [cond, body]] @ c'"
  proof
    fix m :: "('a, 'b) state"

    assume M : "P1 (payload m)"
    assume CM : "s_cont m = Inl ([G Sif' [cond, body]] @ c')"

    show "(safe gs m)"
    proof(cases "(sem_step gs m)")
      case (Inr bad)

      then have False using CM H0
        by(auto simp add: sem_step_def)

      then show ?thesis by auto
    next
      case (Inl m')

      have F_eq : "sem_step \<lparr> s_sem = f \<rparr> m = Inl m'"
        using sym[OF dominant_pcomps'[OF Hpres Hnemp Hdom]] CM Inl H0
        by(simp add: sem_step_def)

      have CM' : "s_cont m' = Inl ([cond] @ ([ G Sif' [body]] @ c'))"
        using CM Hsyn F_eq unfolding HF
        by(cases m; cases m'; auto simp add: s_cont_def sem_step_def imp_sem_l_gen_def imp_ctl_sem_def imp_sem_lifting_gen_def
           schem_lift_defs
          merge_l_def fst_l_def snd_l_def prio_l_def triv_l_def option_l_def
          split: md_prio.splits md_triv.splits option.splits)

      (* this will need to be shown using valid-sets. *)
      have M'_valid : "\<And> p . fst (payload m) \<noteq> mdp p None" using P1_valid[OF M]
        by(auto simp add: get_cond_def split:prod.splits)

      have Sm' : "payload m = payload m'"
        using CM Hsyn F_eq M'_valid  unfolding HF
        by(cases m; cases m'; auto simp add: s_cont_def sem_step_def imp_sem_l_gen_def imp_ctl_sem_def imp_sem_lifting_gen_def
           schem_lift_defs
          merge_l_def fst_l_def snd_l_def prio_l_def triv_l_def option_l_def LNew_def
          split: md_prio.splits md_triv.splits option.splits)

      hence P1sm' : "P1 (payload m')" using M unfolding Sm' by auto

      (* next: step to the end of cond. *)

      have Sub : "|gs| {P2} [G Sif' [body]] @ c'"
      proof
        fix mp2 :: "('a, 'b) state"

        assume MP2 : "P2 (payload mp2)"

        assume Cont2 : "s_cont mp2 = Inl ([G Sif' [body]] @ c')"

        show "safe gs mp2"
        proof(cases "get_cond (payload mp2)")
          case None

          then have False using P2_valid[OF MP2]
            by(auto simp add: get_cond_def split: prod.splits md_prio.splits md_triv.splits option.splits)
          then show ?thesis by auto

        next
          case Some' : (Some cnd)
          then show ?thesis
          proof(cases "sem_step gs mp2")
            case (Inr bad)

            then have False using Cont2 H0
              by(auto simp add: sem_step_def)

            then show ?thesis by auto

          next
            case (Inl mp2')

            have F_eq' : "sem_step \<lparr> s_sem = f \<rparr> mp2 = Inl mp2'"
              using sym[OF dominant_pcomps'[OF Hpres Hnemp Hdom]] Cont2 Inl H0
              by(simp add: sem_step_def)

            have Mp2'_p2 : "P2 (payload mp2')"
              using Cont2 Hsyn H0 MP2 F_eq' P2_valid[OF MP2] Some' unfolding HF
              by(cases mp2; cases mp2';
                  auto simp add: s_cont_def sem_step_def imp_sem_l_gen_def imp_ctl_sem_def imp_sem_lifting_gen_def
                  schem_lift_defs
                  merge_l_def fst_l_def snd_l_def prio_l_def triv_l_def option_l_def LNew_def
                  get_cond_def
                  split: md_prio.splits md_triv.splits option.splits)

            show ?thesis
            proof(cases cnd)
              case True

              have Mp2'_cond : "get_cond (payload mp2') = Some True"
                using Cont2 Hsyn H0 MP2 F_eq' P2_valid[OF MP2] True Some' unfolding HF
                by(cases mp2; cases mp2';
                    auto simp add: s_cont_def sem_step_def imp_sem_l_gen_def imp_ctl_sem_def imp_sem_lifting_gen_def
                    schem_lift_defs
                    merge_l_def fst_l_def snd_l_def prio_l_def triv_l_def option_l_def LNew_def
                    get_cond_def
                    split: md_prio.splits md_triv.splits option.splits)

              have Mp2'_p2_true :  "P2 (payload mp2') \<and> get_cond (payload mp2') = Some True"
                using Mp2'_p2 Mp2'_cond
                by auto

              have Mp2'_cont : "s_cont mp2' = Inl ([body] @ c')"
                using Cont2 Hsyn H0 MP2 F_eq' P2_valid[OF MP2] True Some' unfolding HF
                by(cases mp2; cases mp2';
                    auto simp add: s_cont_def sem_step_def imp_sem_l_gen_def imp_ctl_sem_def imp_sem_lifting_gen_def
                    schem_lift_defs
                    merge_l_def fst_l_def snd_l_def prio_l_def triv_l_def option_l_def LNew_def
                    get_cond_def
                    split: md_prio.splits md_triv.splits option.splits)

              have Mp2'_safe : "safe gs mp2'"
                using guardedD[OF Gtrue Mp2'_p2_true Mp2'_cont] by auto

              show ?thesis
              proof
                fix mz
                assume Exec : "sem_exec_p gs mp2 mz"

                show "imm_safe gs mz" using Exec unfolding sem_exec_p_def
                proof(cases rule: rtranclp.cases)
                  case rtrancl_refl

                  then have "(\<exists>m'. sem_step gs mz = Inl m')"
                    using Inl unfolding imm_safe_def sem_step_p_eq
                    by(cases mp2'; auto)

                  then show ?thesis unfolding imm_safe_def sem_step_p_eq by auto
                next
                  case (rtrancl_into_rtrancl b)

                  have Step : "sem_step_p gs mp2 mp2'" using Inl
                    unfolding sem_step_p_eq
                    by auto

                  have Exec_final : "sem_exec_p gs mp2' mz"
                    using rtranclp_bisect1
                      [OF sem_step_determ rtrancl_into_rtrancl(1)
                          Step rtrancl_into_rtrancl(2)]
                    unfolding sem_exec_p_def
                    by auto

                  show ?thesis using safeD[OF Mp2'_safe Exec_final] by auto
                qed
              qed

            next
              case False

              have Mp2'_cond : "get_cond (payload mp2') = Some False"
                using Cont2 Hsyn H0 MP2 F_eq' P2_valid[OF MP2] False Some' unfolding HF
                by(cases mp2; cases mp2';
                    auto simp add: s_cont_def sem_step_def imp_sem_l_gen_def imp_ctl_sem_def imp_sem_lifting_gen_def
                    schem_lift_defs
                    merge_l_def fst_l_def snd_l_def prio_l_def triv_l_def option_l_def LNew_def
                    get_cond_def
                    split: md_prio.splits md_triv.splits option.splits)

              have Mp2'_p2_false :  "P2 (payload mp2') \<and> get_cond (payload mp2') = Some False"
                using Mp2'_p2 Mp2'_cond
                by auto

              have Mp2'_cont : "s_cont mp2' = Inl ([] @ c')"
                using Cont2 Hsyn H0 MP2 F_eq' P2_valid[OF MP2] False Some' unfolding HF
                by(cases mp2; cases mp2';
                    auto simp add: s_cont_def sem_step_def imp_sem_l_gen_def imp_ctl_sem_def imp_sem_lifting_gen_def
                    schem_lift_defs
                    merge_l_def fst_l_def snd_l_def prio_l_def triv_l_def option_l_def LNew_def
                    get_cond_def
                    split: md_prio.splits md_triv.splits option.splits)

              have Mp2'_safe : "safe gs mp2'"
                using guardedD[OF Gfalse Mp2'_p2_false Mp2'_cont] by auto

              show ?thesis
              proof
                fix mz
                assume Exec : "sem_exec_p gs mp2 mz"

                show "imm_safe gs mz" using Exec unfolding sem_exec_p_def
                proof(cases rule: rtranclp.cases)
                  case rtrancl_refl

                  then have "(\<exists>m'. sem_step gs mz = Inl m')"
                    using Inl unfolding imm_safe_def sem_step_p_eq
                    by(cases mp2'; auto)

                  then show ?thesis unfolding imm_safe_def sem_step_p_eq by auto
                next
                  case (rtrancl_into_rtrancl b)

                  have Step : "sem_step_p gs mp2 mp2'" using Inl
                    unfolding sem_step_p_eq
                    by auto

                  have Exec_final : "sem_exec_p gs mp2' mz"
                    using rtranclp_bisect1
                      [OF sem_step_determ rtrancl_into_rtrancl(1)
                          Step rtrancl_into_rtrancl(2)]
                    unfolding sem_exec_p_def
                    by auto

                  show ?thesis using safeD[OF Mp2'_safe Exec_final] by auto
                qed
              qed
            qed
          qed
        qed
      qed

      have Guard' : "|gs| {P1} [cond] @ ([G Sif' [body]] @ c')"
        using HTE[OF Hcond Sub] by auto

      have Safe' : "safe gs m'" using guardedD[OF Guard' P1sm' CM'] by auto

      show "safe gs m"
      proof
        fix mz

        assume Z: "sem_exec_p gs m mz"

        then show "imm_safe gs mz" unfolding sem_exec_p_def
        proof(cases rule: rtranclp.cases)
          case rtrancl_refl

          then have "(\<exists>m'. sem_step gs mz = Inl m')"
            using Inl unfolding imm_safe_def sem_step_p_eq
            by(cases m'; auto)

          then show ?thesis using Inl unfolding imm_safe_def sem_step_p_eq
            by(auto)
        next
          case (rtrancl_into_rtrancl b)

          have Step : "sem_step_p gs m m'" using Inl
            unfolding sem_step_p_eq
            by auto

          have Exec_final : "sem_exec_p gs m' mz"
            using rtranclp_bisect1
              [OF sem_step_determ rtrancl_into_rtrancl(1)
                  Step rtrancl_into_rtrancl(2)]
            unfolding sem_exec_p_def
            by auto

          show ?thesis using safeD[OF Safe' Exec_final] by auto
        qed
      qed
    qed
  qed
qed

(* ok, if we were to define a step-counting version? *)

(*
another concept.

- start with while cond do body
- will not crash in cond
- will not crash in body

*)
(*
lemma HWhile_gen_ind :
  assumes H0 : "gs = \<lparr> s_sem = pcomps' fs \<rparr>"
  assumes HF : "f = imp_sem_l_gen lfts"
  assumes Hpres : "sups_pres (set fs)"
  assumes Hnemp : "g \<in> set fs"
  assumes Hdom : "(f \<downharpoonleft> (set fs) Swhile')"
  assumes Hsyn : "lfts Swhile' = Swhile"
  (* TODO: generalize. these should be expressed using valid-sets *)
  assumes P1_valid : "\<And> st.  P1 st \<Longrightarrow> get_cond st \<noteq> None"

  assumes Hcond : "|gs| {- P1 -} [cond] {- P1 -}"
  assumes Htrue : "|gs| {- (\<lambda> st . P1 st \<and> get_cond st = Some True) -} [body]
                        {- P1 -}"

  assumes Hexec :

  shows "|gs| {- P1 -} [G Swhile' [cond, body]] {- (\<lambda> st . P1 st \<and> get_cond st = Some False) -}"
*)

(*
lemma HWhile_gen' :
  assumes H0 : "gs = \<lparr> s_sem = pcomps' fs \<rparr>"
  (*assumes H1 : "seq_sem_l_gen lfts \<in> set fs" *)
  assumes HF : "f = imp_sem_l_gen lfts"
  assumes Hpres : "sups_pres (set fs)"
  assumes Hnemp : "g \<in> set fs"
  assumes Hdom : "(f \<downharpoonleft> (set fs) Swhile')"
  assumes Hsyn : "lfts Swhile' = Swhile"
  (* TODO: generalize. these should be expressed using valid-sets *)
  assumes P1_valid : "\<And> st.  P1 st \<Longrightarrow> get_cond st \<noteq> None"

  assumes Hcond : "|gs| {- P1 -} [cond] {- P2 -}"
  assumes Htrue : "|gs| {- (\<lambda> st . P2 st \<and> get_cond st = Some True) -} [body]
                        {- P1 -}"
  assumes Hfalse : "|gs| {- (\<lambda> st . P2 st \<and> get_cond st = Some False) -} []
                        {- P1 -}"

  shows "|gs| {- \<lambda> st . P1 st -} (concat (replicate n [cond, body]) @ (G Swhile' [cond, body])) {- (\<lambda> st . P1 st \<and> get_cond st = Some False) -}"
proof(induction n)
case 0
  then show ?case
  proof
    fix c'

    assume Guard : "|gs| {\<lambda>st. P1 st \<and> get_cond st = Some False} c'"

    then show "|gs| {\<lambda>st. P1 st \<and> get_cond st = Some False} replicate 0 (G Swhile' [cond, body]) @ c'"
      unfolding replicate.simps append.simps by auto
  qed
next
  case (Suc n)
  show ?case
  proof
    fix c'
    assume Guard : "|gs| {\<lambda>st. P1 st \<and> get_cond st = Some False} c'"

    show "|gs| {\<lambda>st. P1 st \<and> get_cond st = Some False} replicate (Suc n) (G Swhile' [cond, body]) @ c'"
      unfolding replicate.simps
    proof
      fix m :: "('a, 'b) state"
      assume HM_1 : "P1 (payload m) \<and> get_cond (payload m) = Some False"
      assume HM_Cont : "s_cont m = Inl ((G Swhile' [cond, body] # replicate n (G Swhile' [cond, body])) @ c')"

      show "safe gs m"
      proof(cases "(sem_step gs m)")
        case (Inr bad)

        then have False using HM_1 HM_Cont
          by(auto simp add: sem_step_def)

        then show ?thesis by auto
      next
        case (Inl m')

        have F_eq : "sem_step \<lparr> s_sem = f \<rparr> m = Inl m'"
          using sym[OF dominant_pcomps'[OF Hpres Hnemp Hdom]] HM_1 Inl H0 HM_Cont
          by(simp add: sem_step_def)

        have HM' : "s_cont m' = Inl ([cond] @ ( G Swhile' [cond, cond, body]  # replicate n (G Swhile' [cond, body])) @ c')"
          using HM_1 HM_Cont Hsyn F_eq unfolding HF
          by(cases m; cases m'; auto simp add: s_cont_def sem_step_def imp_sem_l_gen_def imp_ctl_sem_def imp_sem_lifting_gen_def
             schem_lift_defs
            merge_l_def fst_l_def snd_l_def prio_l_def triv_l_def option_l_def
            split: md_prio.splits md_triv.splits option.splits)

        have P1_M : "P1 (payload m)" using HM_1 by auto

        (* this will need to be shown using valid-sets. *)
        have M'_valid : "\<And> p . fst (payload m) \<noteq> mdp p None" using P1_valid[OF P1_M]
          by(auto simp add: get_cond_def split:prod.splits)

        have Sm' : "payload m = payload m'"
          using HM_1 HM' HM_Cont Hsyn F_eq M'_valid  unfolding HF
          by(cases m; cases m'; auto simp add: s_cont_def sem_step_def imp_sem_l_gen_def imp_ctl_sem_def imp_sem_lifting_gen_def
             schem_lift_defs
            merge_l_def fst_l_def snd_l_def prio_l_def triv_l_def option_l_def LNew_def
            split: md_prio.splits md_triv.splits option.splits)

        hence P1sm' : "P1 (payload m')" using P1_M unfolding Sm' by auto

        show ?thesis using Suc.IH

qed
*)

lemma rtranclp_induct_alt :
  assumes H : "rtranclp r a b"
  assumes Ha : "P a"
  assumes Hsteps : "(\<And> y z . rtranclp r a y \<Longrightarrow> rtranclp r y z \<Longrightarrow> P y \<Longrightarrow> P z)"
  shows "P b" using assms
proof(induction rule: rtranclp_induct)
  case base
  then show ?case by auto
next
  case (step y z)

  have Py : "P y" using step.IH[OF step.prems(1) step.prems(2)]
    by auto

  have Rz : "rtranclp r y z" using step.hyps
    by(auto)

  show ?case using step.prems(2)[OF step.hyps(1) Rz Py] by auto
qed

(*
lemma rtranclp_induct_alt_stronger :
  "rtranclp r a b \<Longrightarrow> P a \<Longrightarrow>
   (\<And> y z . rtranclp r a y \<Longrightarrow> rtranclp r y z \<Longrightarrow> P y \<Longrightarrow> P z) \<Longrightarrow> P b"
proof(induction rule: rtranclp_induct)
  case base
  then show ?case by auto
next
  case (step y z)

  have Py : "P y" using step.IH[OF step.prems(1) step.prems(2)]
    by auto

  have Rz : "rtranclp r y z" using step.hyps
    by(auto)

  show ?case using step.prems(2)[OF step.hyps(1) Rz Py] by auto
qed
*)

(* the issue here is that we don't really have any way of describing what might happen after
executing a prefix before the loop, since that prefix might do all kinds of crazy stuff
to the continuation

*)

definition fuel_bound :: "('syn, 'mstate) semc \<Rightarrow> ('syn gensyn list) \<Rightarrow> nat \<Rightarrow> bool" where
"fuel_bound gs cont n =
  (\<forall> st n' st' . s_cont st = Inl cont \<longrightarrow>
     sem_exec_c_p gs st n' st' \<longrightarrow>
     s_cont st' = Inl [] \<longrightarrow>
     n' \<le> n)"

lemma fuel_boundI :
  assumes "\<And> st n' st' . s_cont st = Inl cont \<Longrightarrow>
     sem_exec_c_p gs st n' st' \<Longrightarrow>
     s_cont st' = Inl [] \<Longrightarrow>
     n' \<le> n"
  shows "fuel_bound gs cont n" using assms
  unfolding fuel_bound_def by blast

lemma fuel_boundD :
  assumes H : "fuel_bound gs cont n"
  assumes H1 : "s_cont st = Inl cont"
  assumes H2 : "sem_exec_c_p gs st n' st'"
  assumes H3 : "s_cont st' = Inl []"
  shows "n' \<le> n" using assms
  unfolding fuel_bound_def by blast

(* TODO: I think finiteness is necessary, but there is probably
a way to avoid this requirement if we introduce ghost variables or similar
(the reason it arises is that we need to pick a single fuel bound
for the entire state space (of terminating executions), but this is
possible only if the state is finite (?)
*)

lemma HWhileC_gen :
  assumes H0 : "gs = \<lparr> s_sem = pcomps' fs \<rparr>"
  (*assumes H1 : "seq_sem_l_gen lfts \<in> set fs" *)
  assumes HF : "f = imp_sem_l_gen lfts"
  assumes Hpres : "sups_pres (set fs)"
  assumes Hnemp : "g \<in> set fs"
  assumes Hdom : "(f \<downharpoonleft> (set fs) SwhileC')"
  assumes Hsyn : "lfts Swhile' = SwhileC"
  (* TODO: generalize. these should be expressed using valid-sets *)
  assumes PX_valid : "\<And> n st.  PX n st \<Longrightarrow> get_cond st \<noteq> None"
  assumes Htrue : "\<And> n .  |gs| {-(\<lambda> st . PX n st)-} [body] {-(\<lambda> st . PX (n - 1) st)-}"
  assumes PX_P1 : "\<And> n st . PX n st \<Longrightarrow> P1 st"
  assumes PX_P1' : "\<And> st . P1 st \<Longrightarrow> PX ni st"
  assumes Donefor : "\<And> stx c . PX 0 (payload stx) \<Longrightarrow> s_cont stx = Inl ([G SwhileC' [body]] @ c) \<Longrightarrow> safe gs stx"
  shows "|gs| {- PX (ni :: nat)  -} [G SwhileC' [body]] {- (\<lambda> st . (\<exists> n . n \<le> ni \<and> PX n st \<and> get_cond st = Some False) ) -}"
proof
  fix c'
  assume Guard : "|gs| {\<lambda>st. (\<exists> n . n \<le> ni \<and> PX n st \<and> get_cond st = Some False)} c'"

  show "|gs| {PX ni} [G SwhileC' [body]] @ c'" using Guard
  proof(induction ni arbitrary: c')
    case 0
    show ?case
    proof
      fix m :: "('a, 'b) state"
      assume P0 : "PX 0 (payload m)"
      assume C : "s_cont m = Inl ([G SwhileC' [body]] @ c')"
      show  "safe gs m" using Donefor[OF P0 C] by auto
    qed
  next
    case (Suc ni)
    show ?case
    proof
      fix m :: "('a, 'b) state"
      assume PX : "PX (Suc ni) (payload m)"
      assume C : "s_cont m = Inl ([G SwhileC' [body]] @ c')"
      show  "safe gs m"

      proof(cases "(sem_step gs m)")
        case (Inr bad)

        then have False using C H0
          by(auto simp add: sem_step_def)

        then show ?thesis by auto
      next
        case (Inl m')

        have F_eq : "sem_step \<lparr> s_sem = f \<rparr> m = Inl m'"
          using sym[OF dominant_pcomps'[OF Hpres Hnemp Hdom]] C Inl H0
          by(simp add: sem_step_def)

        have M_P1 : "PX (Suc ni) (payload m)" using PX C by auto

        have M'_valid : "\<And> p . fst (payload m) \<noteq> mdp p None" using PX_valid[OF M_P1]
          by(auto simp add: get_cond_def split:prod.splits)

        have Sm' : "payload m = payload m'"
          using C Hsyn F_eq M'_valid  unfolding HF
          by(cases m; cases m'; auto simp add: s_cont_def sem_step_def imp_sem_l_gen_def imp_ctl_sem_def imp_sem_lifting_gen_def
             schem_lift_defs
            merge_l_def fst_l_def snd_l_def prio_l_def triv_l_def option_l_def LNew_def
            split: md_prio.splits md_triv.splits option.splits)

        have M' : "PX (Suc ni) (payload m')" using Sm' M_P1 by auto

        show "safe gs m"
        proof(cases "get_cond (payload m)")
          case None

          then have False using PX_valid[OF M_P1]
            by(auto simp add: get_cond_def split: prod.splits md_prio.splits md_triv.splits option.splits)
          then show ?thesis by auto

        next
          case Some' : (Some cnd)
          then show ?thesis
          proof(cases cnd)
            case True

            have Mp2'_cont : "s_cont m' = Inl ([body, G SwhileC' [body]] @ c')" sorry

            have Haa : "|gs| {\<lambda>st. \<exists>n\<le>ni. PX n st \<and> get_cond st = Some False} c'"
            proof
              fix ml :: "('a, 'b) state"
              assume Hpay : "\<exists>n\<le>ni . PX n (payload ml) \<and> get_cond (payload ml) = Some False"
              assume Hcont : "s_cont ml = Inl c'"

              obtain nnew where Nnew_leq  : "nnew \<le> ni" and Nnew_spec : "PX nnew (payload ml) \<and> get_cond (payload ml) = Some False"
                using Hpay by auto

              have Nnew_leq' : "nnew \<le> Suc ni" using Nnew_leq by auto

              have Hpay' : "\<exists>n\<le>Suc ni . PX n (payload ml) \<and> get_cond (payload ml) = Some False"
                using Nnew_leq' Nnew_spec by auto

              show "safe gs ml" using guardedD[OF Suc.prems Hpay' Hcont]
                by auto
            qed

            have G1 : "|gs| {PX ni} [G SwhileC' [body]] @ c'"
              using Suc.IH[OF Haa]
              by auto

            hence G1' : "|gs| {PX (Suc ni - 1)} [G SwhileC' [body]] @ c'"
              by auto

            have Ggood : "|gs| {PX (Suc ni)} [body] @ [G SwhileC' [body]] @ c'"
              using HTE[OF Htrue G1'] by auto

            have Almost :  "safe gs m'" using guardedD[OF Ggood M'] Mp2'_cont
              by auto

            show "safe gs m"
            proof
              fix mfin

              assume "sem_exec_p gs m mfin"
              then show "imm_safe gs mfin" unfolding sem_exec_p_def
              proof(cases rule: rtranclp.cases)
                case rtrancl_refl
                then have "sem_step_p gs mfin m'" using Inl unfolding sem_step_p_eq by auto
                then show ?thesis unfolding imm_safe_def by blast
              next
                case (rtrancl_into_rtrancl b)

                have Step : "sem_step_p gs m m'" using Inl unfolding sem_step_p_eq by auto
                have Steps : "sem_exec_p gs m' mfin" using rtranclp_bisect1[OF sem_step_determ rtrancl_into_rtrancl(1) Step rtrancl_into_rtrancl(2)] unfolding sem_exec_p_def
                  by auto
                show ?thesis using safeD[OF Almost Steps] by auto
              qed
            qed
          qed
        qed
      qed
    qed
  qed
qed
*)

lemma HWhileC_gen :
  fixes PX :: "nat \<Rightarrow> (bool md_triv option md_prio \<times>
  int md_triv option md_prio \<times> 'b :: Mergeableb) \<Rightarrow> bool"
  assumes H0 : "gs = \<lparr> s_sem = pcomps' fs \<rparr>"
  (*assumes H1 : "seq_sem_l_gen lfts \<in> set fs" *)
  assumes HF : "f = imp_sem_l_gen lfts"
  assumes Hpres : "sups_pres (set fs)"
  assumes Hnemp : "g \<in> set fs"
  assumes Hdom : "(f \<downharpoonleft> (set fs) SwhileC')"
  assumes Hsyn : "lfts Swhile' = SwhileC"
  (* TODO: generalize. these should be expressed using valid-sets *)
  assumes PX_valid : "\<And> n st.  PX n st \<Longrightarrow> get_cond st \<noteq> None"
  assumes Htrue : "\<And> n .  |gs| {-(\<lambda> st . PX n st)-} [body] {-(\<lambda> st . PX (n - 1) st)-}"
  assumes PX_P1 : "\<And> n st . PX n st \<Longrightarrow> P1 st"
  assumes PX_P1' : "\<And> st . P1 st \<Longrightarrow> PX (getn st) st"
  assumes Donefor : "\<And> stx c . PX 0 (payload stx) \<Longrightarrow> s_cont stx = Inl ([G SwhileC' [body]] @ c) \<Longrightarrow> safe gs stx"
  shows "|gs| {- (\<lambda> st . PX (getn st) st)  -} [G SwhileC' [body]] {- (\<lambda> st . (\<exists> n . PX n st \<and> get_cond st = Some False) ) -}"
proof
  fix c'
  assume Guard : "|gs| {\<lambda>st. (\<exists> n .  PX n st \<and> get_cond st = Some False)} c'"

  show "|gs| {\<lambda>st. PX (getn st) st} [G SwhileC' [body]] @ c'"
  proof
    fix m :: "('a, 'b) state"
    assume HX : "PX (getn (payload m)) (payload m)"

    assume Hcont : "s_cont m = Inl ([G SwhileC' [body]] @ c')"

    show "safe gs m" using Guard HX Hcont
    proof(induction "getn (payload m)" arbitrary: c' m)
      case 0
      then show ?case using Donefor[OF _ "0"(4)] by auto
    next
      case (Suc x)
      then show ?case
    qed

(* Now, to finish the argument, we need to show that terminating programs will always have a maximum number of
fuel they consume before they terminate, and that nonterminating programs are safe anyway.

so, we can use this maximum fuel as an upper bound for ni, and we should be done. *)

end