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>\<open>"DBLP:books/cu/Goldreich2004"\<close>. We assume the security
properties on 1-out-of-2 OT.\<close>

theory OT14 imports
  Semi_Honest_Def
  OT_Functionalities
  Uniform_Sampling
begin

type_synonym input1 = "bool \<times> bool \<times> bool \<times> bool"
type_synonym input2 = "bool \<times> bool"
type_synonym 'v_OT121' view1 = "(input1 \<times> (bool \<times> bool \<times> bool \<times> bool \<times> bool \<times> bool) \<times> 'v_OT121' \<times> 'v_OT121' \<times> 'v_OT121')"
type_synonym 'v_OT122' view2 = "(input2 \<times> (bool \<times> bool \<times> bool \<times> bool) \<times> 'v_OT122' \<times> 'v_OT122' \<times> 'v_OT122')"

locale ot14_base =
  fixes S1_OT12 :: "(bool \<times> bool) \<Rightarrow> unit \<Rightarrow> 'v_OT121 spmf" \<comment> \<open>simulator for party 1 in OT12\<close>
    and R1_OT12 :: "(bool \<times> bool) \<Rightarrow> bool \<Rightarrow> 'v_OT121 spmf" \<comment> \<open>real view for party 1 in OT12\<close>
    and adv_OT12 :: real
    and S2_OT12 :: "bool \<Rightarrow> bool \<Rightarrow> 'v_OT122 spmf"
    and R2_OT12 :: "(bool \<times> bool) \<Rightarrow> bool \<Rightarrow> 'v_OT122 spmf"
    and protocol_OT12 :: "(bool \<times> bool) \<Rightarrow> bool \<Rightarrow> (unit \<times> bool) spmf"
  assumes ass_adv_OT12: "sim_det_def.adv_P1 R1_OT12 S1_OT12 funct_OT12 (m0,m1) c D \<le> adv_OT12" \<comment> \<open>bound the advantage of OT12 for party 1\<close>
    and inf_th_OT12_P2:  "sim_det_def.perfect_sec_P2 R2_OT12 S2_OT12 funct_OT12 (m0,m1) \<sigma>" \<comment> \<open>information theoretic security for party 2\<close>
    and correct: "protocol_OT12 msgs b = funct_OT_12 msgs b"
    and lossless_R1_12: "lossless_spmf (R1_OT12 m c)"
    and lossless_S1_12: "lossless_spmf (S1_OT12 m out1)"
    and lossless_S2_12: "lossless_spmf (S2_OT12 c out2)"
    and lossless_R2_12: "lossless_spmf (R2_OT12 M c)"
    and lossless_funct_OT12: "lossless_spmf (funct_OT12 (m0,m1) c)"
    and lossless_protocol_OT12: "lossless_spmf (protocol_OT12 M C)"
begin

sublocale OT_12_sim: sim_det_def R1_OT12 S1_OT12 R2_OT12 S2_OT12 funct_OT_12 protocol_OT12
  unfolding sim_det_def_def
  by(simp add: lossless_R1_12 lossless_S1_12 lossless_funct_OT12 lossless_R2_12 lossless_S2_12)

lemma OT_12_P1_assms_bound': "\<bar>spmf (bind_spmf (R1_OT12 (m0,m1) c) (\<lambda> view. ((D::'v_OT121 \<Rightarrow> bool spmf) view ))) True
                - spmf (bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (D view ))) True\<bar> \<le> adv_OT12"
proof-
  have "sim_det_def.adv_P1 R1_OT12 S1_OT12 funct_OT_12 (m0,m1) c D =
                      \<bar>spmf (bind_spmf (R1_OT12 (m0,m1) c) (\<lambda> view. (D view ))) True
                                    - spmf (funct_OT_12 (m0,m1) c \<bind> (\<lambda> ((out1::unit), (out2::bool)).
                                              S1_OT12 (m0,m1) out1 \<bind> (\<lambda> view. D view))) True\<bar>"
    using sim_det_def.adv_P1_def
    using  OT_12_sim.adv_P1_def by auto
  also have "... = \<bar>spmf (bind_spmf (R1_OT12 (m0,m1) c) (\<lambda> view. ((D::'v_OT121 \<Rightarrow> bool spmf) view ))) True
                - spmf (bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (D view ))) True\<bar>"
    by(simp add: funct_OT_12_def)
  ultimately show ?thesis
    by(metis ass_adv_OT12)
qed

lemma OT_12_P2_assm: "R2_OT12 (m0,m1) \<sigma> = funct_OT_12 (m0,m1) \<sigma> \<bind> (\<lambda> (out1, out2). S2_OT12 \<sigma> out2)"
  using inf_th_OT12_P2 OT_12_sim.perfect_sec_P2_def by blast

definition protocol_14_OT :: "input1 \<Rightarrow> input2 \<Rightarrow> (unit \<times> bool) spmf"
  where "protocol_14_OT M C = do {
    let (c0,c1) = C;
    let (m00, m01, m10, m11) = M;
    S0 \<leftarrow> coin_spmf;
    S1 \<leftarrow> coin_spmf;
    S2 \<leftarrow> coin_spmf;
    S3 \<leftarrow> coin_spmf;
    S4 \<leftarrow> coin_spmf;
    S5 \<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;
    (_,Si) \<leftarrow> protocol_OT12 (S0, S1) c0;
    (_,Sj) \<leftarrow> protocol_OT12 (S2, S3) c1;
    (_,Sk) \<leftarrow> protocol_OT12 (S4, S5) c1;
    let s2 = Si \<oplus> (if c0 then Sk else Sj) \<oplus> (if c0 then (if c1 then a3 else a2) else (if c1 then a1 else a0));
    return_spmf ((), s2)}"

lemma lossless_protocol_14_OT: "lossless_spmf (protocol_14_OT M C)"
  by(simp add: protocol_14_OT_def lossless_protocol_OT12 split_def)

definition R1_14 :: "input1 \<Rightarrow> input2 \<Rightarrow> 'v_OT121 view1 spmf"
  where "R1_14 msgs choice = do {
    let (m00, m01, m10, m11) = msgs;
    let (c0, c1) = choice;
    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 :: 'v_OT121 \<leftarrow> R1_OT12 (S0, S1) c0;
    b :: 'v_OT121 \<leftarrow> R1_OT12 (S2, S3) c1;
    c :: 'v_OT121 \<leftarrow> R1_OT12 (S4, S5) c1;
    return_spmf (msgs, (S0, S1, S2, S3, S4, S5), a, b, c)}"

lemma lossless_R1_14: "lossless_spmf (R1_14 msgs C)"
  by(simp add: R1_14_def split_def lossless_R1_12)

definition R1_14_interm1 :: "input1 \<Rightarrow> input2 \<Rightarrow> 'v_OT121 view1 spmf"
  where "R1_14_interm1 msgs choice = do {
    let (m00, m01, m10, m11) = msgs;
    let (c0, c1) = choice;
    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 :: 'v_OT121 \<leftarrow> S1_OT12 (S0, S1) ();
    b :: 'v_OT121 \<leftarrow> R1_OT12 (S2, S3) c1;
    c :: 'v_OT121 \<leftarrow> R1_OT12 (S4, S5) c1;
    return_spmf (msgs, (S0, S1, S2, S3, S4, S5), a, b, c)}"

lemma lossless_R1_14_interm1: "lossless_spmf (R1_14_interm1 msgs C)"
  by(simp add: R1_14_interm1_def split_def lossless_R1_12 lossless_S1_12)

definition R1_14_interm2 :: "input1 \<Rightarrow> input2 \<Rightarrow> 'v_OT121 view1 spmf"
  where "R1_14_interm2 msgs choice = do {
    let (m00, m01, m10, m11) = msgs;
    let (c0, c1) = choice;
    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 :: 'v_OT121 \<leftarrow> S1_OT12 (S0, S1) ();
    b :: 'v_OT121 \<leftarrow> S1_OT12 (S2, S3) ();
    c :: 'v_OT121 \<leftarrow> R1_OT12 (S4, S5) c1;
    return_spmf (msgs, (S0, S1, S2, S3, S4, S5), a, b, c)}"

lemma lossless_R1_14_interm2: "lossless_spmf (R1_14_interm2 msgs C)"
  by(simp add: R1_14_interm2_def split_def lossless_R1_12 lossless_S1_12)

definition S1_14 :: "input1 \<Rightarrow> unit \<Rightarrow> 'v_OT121 view1 spmf"
  where "S1_14 msgs _ = do {
    let (m00, m01, m10, m11) = msgs;
    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 :: 'v_OT121 \<leftarrow> S1_OT12 (S0, S1) ();
    b :: 'v_OT121 \<leftarrow> S1_OT12 (S2, S3) ();
    c :: 'v_OT121 \<leftarrow> S1_OT12 (S4, S5) ();
    return_spmf (msgs, (S0, S1, S2, S3, S4, S5), a, b, c)}"

lemma lossless_S1_14: "lossless_spmf (S1_14 m out)"
  by(simp add: S1_14_def lossless_S1_12)

lemma reduction_step1:
  shows "\<exists> A1. \<bar>spmf (bind_spmf (R1_14 M (c0, c1)) D) True - spmf (bind_spmf (R1_14_interm1 M (c0, c1)) D) True\<bar> =
              \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c0) (\<lambda> view. (A1 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A1 view (m0,m1))))) True\<bar>"
  including monad_normalisation
proof-
  define A1' where "A1' == \<lambda> (view :: 'v_OT121) (m0,m1). do {
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    b :: 'v_OT121 \<leftarrow> R1_OT12 (S2, S3) c1;
    c :: 'v_OT121 \<leftarrow> R1_OT12 (S4, S5) c1;
    let R = (M, (m0,m1, S2, S3, S4, S5), view, b, c);
    D R}"
  have "\<bar>spmf (bind_spmf (R1_14 M (c0, c1)) D) True - spmf (bind_spmf (R1_14_interm1 M (c0, c1)) D) True\<bar> =
       \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c0) (\<lambda> view. (A1' view (m0,m1))))) True -
        spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A1' view (m0,m1))))) True\<bar>"
    apply(simp add: pair_spmf_alt_def R1_14_def R1_14_interm1_def A1'_def Let_def split_def)
    apply(subst bind_commute_spmf[of "S1_OT12 _ _"])
    apply(subst bind_commute_spmf[of "S1_OT12 _ _"])
    apply(subst bind_commute_spmf[of "S1_OT12 _ _"])
    apply(subst bind_commute_spmf[of "S1_OT12 _ _"])
    apply(subst bind_commute_spmf[of "S1_OT12 _ _"])
    by auto
  then show ?thesis by auto
qed

lemma reduction_step1':
  shows "\<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c0) (\<lambda> view. (A1 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A1 view (m0,m1))))) True\<bar>
                        \<le> adv_OT12"
  (is "?lhs \<le> adv_OT12")
proof-
  have int1: "integrable (measure_spmf (pair_spmf coin_spmf coin_spmf)) (\<lambda>x. spmf (case x of (m0, m1) \<Rightarrow> R1_OT12 (m0, m1) c0 \<bind> (\<lambda>view. A1 view (m0, m1))) True)"
    and int2: "integrable (measure_spmf (pair_spmf coin_spmf coin_spmf)) (\<lambda>x. spmf (case x of (m0, m1) \<Rightarrow> S1_OT12 (m0, m1) () \<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 x|measure_spmf (pair_spmf coin_spmf coin_spmf). spmf (case x of (m0, m1) \<Rightarrow> R1_OT12 (m0, m1) c0 \<bind> (\<lambda>view. A1 view (m0, m1))) True
              - spmf (case x of (m0, m1) \<Rightarrow> S1_OT12 (m0, m1) () \<bind> (\<lambda>view. A1 view (m0, m1))) True\<bar>"
    apply(subst (1 2) spmf_bind) using int1 int2 by simp
  also have "... \<le> LINT x|measure_spmf (pair_spmf coin_spmf coin_spmf).
               \<bar>spmf (R1_OT12 x c0 \<bind> (\<lambda>view. A1 view x)) True - spmf (S1_OT12 x () \<bind> (\<lambda>view. A1 view x)) True\<bar>"
    by(rule integral_abs_bound[THEN order_trans]; simp add: split_beta)
  ultimately have "?lhs \<le> LINT x|measure_spmf (pair_spmf coin_spmf coin_spmf).
                      \<bar>spmf (R1_OT12 x c0 \<bind> (\<lambda>view. A1 view x)) True - spmf (S1_OT12 x () \<bind> (\<lambda>view. A1 view x)) True\<bar>"
    by simp
  also have "LINT x|measure_spmf (pair_spmf coin_spmf coin_spmf).
                \<bar>spmf (R1_OT12 x c0 \<bind> (\<lambda>view::'v_OT121. A1 view x)) True
                    - spmf (S1_OT12 x () \<bind> (\<lambda>view::'v_OT121. A1 view x)) True\<bar> \<le> adv_OT12"
    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 "R1_OT12 (m0, m1) c0 \<bind> (\<lambda>view. A1 view (m0, m1))" "Some True"]
        pmf_le_1[of "S1_OT12 (m0, m1) () \<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 (R1_14_interm1 M (c0, c1)) D) True - spmf (bind_spmf (R1_14_interm2 M (c0, c1)) D) True\<bar> =
          \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c1) (\<lambda> view. (A1 view (m0,m1))))) True -
            spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A1 view (m0,m1))))) True\<bar>"
proof-
  define A1' where "A1' == \<lambda> (view :: 'v_OT121) (m0,m1). do {
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a :: 'v_OT121 \<leftarrow> S1_OT12 (S2,S3) ();
    c :: 'v_OT121 \<leftarrow> R1_OT12 (S4, S5) c1;
    let R = (M, (S2,S3, m0, m1, S4, S5), a, view, c);
    D R}"
  have "\<bar>spmf (bind_spmf (R1_14_interm1 M (c0, c1)) D) True - spmf (bind_spmf (R1_14_interm2 M (c0, c1)) D) True\<bar> =
       \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c1) (\<lambda> view. (A1' view (m0,m1))))) True -
        spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A1' view (m0,m1))))) True\<bar>"
  proof-
    have "(bind_spmf (R1_14_interm1 M (c0, c1)) D) = (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c1) (\<lambda> view. (A1' view (m0,m1)))))"
      unfolding R1_14_interm1_def R1_14_interm2_def A1'_def Let_def split_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 (R1_14_interm2 M (c0, c1)) D) =  (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A1' view (m0,m1)))))"
      unfolding R1_14_interm1_def R1_14_interm2_def A1'_def Let_def split_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 (R1_14_interm2 M (c0, c1)) D) True - spmf (bind_spmf (S1_14 M out) D) True\<bar> =
          \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c1) (\<lambda> view. (A1 view (m0,m1))))) True -
            spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A1 view (m0,m1))))) True\<bar>"
proof-
  define A1' where "A1' == \<lambda> (view :: 'v_OT121) (m0,m1). do {
    S2 :: bool \<leftarrow> coin_spmf;
    S3 :: bool \<leftarrow> coin_spmf;
    S4 :: bool \<leftarrow> coin_spmf;
    S5 :: bool \<leftarrow> coin_spmf;
    a :: 'v_OT121 \<leftarrow> S1_OT12 (S2,S3) ();
    b :: 'v_OT121 \<leftarrow> S1_OT12 (S4, S5) ();
    let R = (M, (S2,S3, S4, S5,m0, m1), a, b, view);
    D R}"
  have "\<bar>spmf (bind_spmf (R1_14_interm2 M (c0, c1)) D) True - spmf (bind_spmf (S1_14 M out) D) True\<bar> =
       \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c1) (\<lambda> view. (A1' view (m0,m1))))) True -
        spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A1' view (m0,m1))))) True\<bar>"
  proof-
    have "(bind_spmf (R1_14_interm2 M (c0, c1)) D) = (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c1) (\<lambda> view. (A1' view (m0,m1)))))"
      unfolding  R1_14_interm2_def A1'_def Let_def split_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 (S1_14 M out) D) = (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A1' view (m0,m1)))))"
      unfolding S1_14_def Let_def A1'_def split_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_interm:
  shows "\<bar>spmf (bind_spmf (R1_14 M (c0,c1)) (D)) True - spmf (bind_spmf (S1_14 M out) (D)) True\<bar> \<le> 3 * adv_OT12"
    (is "?lhs \<le> ?rhs")
proof-
  have lhs: "?lhs \<le> \<bar>spmf (bind_spmf (R1_14 M (c0, c1)) D) True - spmf (bind_spmf (R1_14_interm1 M (c0, c1)) D) True\<bar> +
                     \<bar>spmf (bind_spmf (R1_14_interm1 M (c0, c1)) D) True - spmf (bind_spmf (R1_14_interm2 M (c0, c1)) D) True\<bar> +
                      \<bar>spmf (bind_spmf (R1_14_interm2 M (c0, c1)) D) True - spmf (bind_spmf (S1_14 M out) D) True\<bar>"
    by simp
  obtain A1 where A1: "\<bar>spmf (bind_spmf (R1_14 M (c0, c1)) D) True - spmf (bind_spmf (R1_14_interm1 M (c0, c1)) D) True\<bar> =
                        \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c0) (\<lambda> view. (A1 view (m0,m1))))) True -
                          spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A1 view (m0,m1))))) True\<bar>"
    using reduction_step1 by blast
  obtain A2 where A2: "\<bar>spmf (bind_spmf (R1_14_interm1 M (c0, c1)) D) True - spmf (bind_spmf (R1_14_interm2 M (c0, c1)) D) True\<bar> =
                        \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c1) (\<lambda> view. (A2 view (m0,m1))))) True -
                          spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A2 view (m0,m1))))) True\<bar>"
    using reduction_step2 by blast
  obtain A3 where A3: "\<bar>spmf (bind_spmf (R1_14_interm2 M (c0, c1)) D) True - spmf (bind_spmf (S1_14 M out) D) True\<bar> =
                        \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c1) (\<lambda> view. (A3 view (m0,m1))))) True -
                          spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<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 (R1_OT12 (m0,m1) c0) (\<lambda> view. (A1 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A1 view (m0,m1))))) True\<bar> +
                   \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c1) (\<lambda> view. (A2 view (m0,m1))))) True -
                    spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A2 view (m0,m1))))) True\<bar> +
                     \<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c1) (\<lambda> view. (A3 view (m0,m1))))) True -
                      spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A3 view (m0,m1))))) True\<bar>"
    using A1 A2 A3 lhs by simp
  have bound1: "\<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c0) (\<lambda> view. (A1 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A1 view (m0,m1))))) True\<bar>
                      \<le> adv_OT12"
    and bound2: "\<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c1) (\<lambda> view. (A2 view (m0,m1))))) True -
                  spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A2 view (m0,m1))))) True\<bar>
                      \<le> adv_OT12"
    and bound3: "\<bar>spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (R1_OT12 (m0,m1) c1) (\<lambda> view. (A3 view (m0,m1))))) True -
        spmf (bind_spmf (pair_spmf coin_spmf coin_spmf) (\<lambda>(m0, m1). bind_spmf (S1_OT12 (m0,m1) ()) (\<lambda> view. (A3 view (m0,m1))))) True\<bar> \<le> adv_OT12"
    using reduction_step1' by auto
  thus ?thesis
    using reduction_step1' lhs_bound by argo
qed

lemma reduction_P1: "\<bar>spmf (bind_spmf (R1_14 M (c0,c1)) (D)) True
                        - spmf (funct_OT_14 M (c0,c1) \<bind> (\<lambda> (out1,out2). S1_14 M out1 \<bind> (\<lambda> view. D view))) True\<bar>
                              \<le> 3 * adv_OT12"
  by(simp add: funct_OT_14_def split_def Let_def reduction_P1_interm )

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

definition R2_14:: "input1 \<Rightarrow> input2 \<Rightarrow> 'v_OT122 view2 spmf"
  where "R2_14 M C = do {
    let (m0,m1,m2,m3) = M;
    let (c0,c1) = C;
    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 :: 'v_OT122 \<leftarrow> R2_OT12 (S0,S1) c0;
    b :: 'v_OT122 \<leftarrow> R2_OT12 (S2,S3) c1;
    c :: 'v_OT122 \<leftarrow> R2_OT12 (S4,S5) c1;
    return_spmf (C, (a0,a1,a2,a3), a,b,c)}"

lemma lossless_R2_14: "lossless_spmf (R2_14 M C)"
  by(simp add: R2_14_def split_def lossless_R2_12)

definition S2_14 :: "input2 \<Rightarrow> bool \<Rightarrow> 'v_OT122 view2 spmf"
  where "S2_14 C out = do {
    let ((c0::bool),(c1::bool)) = C;
    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 :: 'v_OT122 \<leftarrow> S2_OT12 (c0::bool) (if c0 then S1 else S0);
    b :: 'v_OT122 \<leftarrow> S2_OT12 (c1::bool) (if c1 then S3 else S2);
    c :: 'v_OT122 \<leftarrow> S2_OT12 (c1::bool) (if c1 then S5 else S4);
    return_spmf ((c0,c1), (a0',a1',a2',a3'), a,b,c)}"

lemma lossless_S2_14: "lossless_spmf (S2_14 c out)"
  by(simp add: S2_14_def lossless_S2_12 split_def)

lemma P2_OT_14_FT: "R2_14 (m0,m1,m2,m3) (False,True) = funct_OT_14 (m0,m1,m2,m3) (False,True) \<bind> (\<lambda> (out1, out2). S2_14 (False,True) out2)"
  including monad_normalisation
proof-
  have "R2_14 (m0,m1,m2,m3) (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 :: 'v_OT122 \<leftarrow> S2_OT12 False S0;
    b :: 'v_OT122 \<leftarrow> S2_OT12 True S3;
    c :: 'v_OT122 \<leftarrow> S2_OT12 True S5;
    return_spmf ((False,True), (a0,a1,a2,a3), a,b,c)}"
    by(simp add: bind_map_spmf o_def Let_def R2_14_def inf_th_OT12_P2 funct_OT_12_def OT_12_P2_assm)
  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 :: 'v_OT122 \<leftarrow> S2_OT12 False S0;
    b :: 'v_OT122 \<leftarrow> S2_OT12 True S3;
    c :: 'v_OT122 \<leftarrow> S2_OT12 True S5;
    return_spmf ((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 :: 'v_OT122 \<leftarrow> S2_OT12 False S0;
    b :: 'v_OT122 \<leftarrow> S2_OT12 True S3;
    c :: 'v_OT122 \<leftarrow> S2_OT12 True S5;
    return_spmf ((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 :: 'v_OT122 \<leftarrow> S2_OT12 False S0;
    b :: 'v_OT122 \<leftarrow> S2_OT12 True S3;
    c :: 'v_OT122 \<leftarrow> S2_OT12 True S5;
    return_spmf ((False,True), (a0,a1,a2,a3), a,b,c)}"
    using coin_coin by simp
  ultimately show ?thesis
    by(simp add: funct_OT_14_def S2_14_def bind_spmf_const)
qed

lemma P2_OT_14_TT: "R2_14 (m0,m1,m2,m3) (True,True) = funct_OT_14 (m0,m1,m2,m3) (True,True) \<bind> (\<lambda> (out1, out2). S2_14 (True,True) out2)"
  including monad_normalisation
proof-
  have "R2_14 (m0,m1,m2,m3) (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 :: 'v_OT122 \<leftarrow> S2_OT12 True S1;
    b :: 'v_OT122 \<leftarrow> S2_OT12 True S3;
    c :: 'v_OT122 \<leftarrow> S2_OT12 True S5;
    return_spmf ((True,True), (a0,a1,a2,a3), a,b,c)}"
    by(simp add: bind_map_spmf o_def R2_14_def inf_th_OT12_P2 funct_OT_12_def OT_12_P2_assm Let_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 :: 'v_OT122 \<leftarrow> S2_OT12 True S1;
    b :: 'v_OT122 \<leftarrow> S2_OT12 True S3;
    c :: 'v_OT122 \<leftarrow> S2_OT12 True S5;
    return_spmf ((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 :: 'v_OT122 \<leftarrow> S2_OT12 True S1;
    b :: 'v_OT122 \<leftarrow> S2_OT12 True S3;
    c :: 'v_OT122 \<leftarrow> S2_OT12 True S5;
    return_spmf ((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 :: 'v_OT122 \<leftarrow> S2_OT12 True S1;
    b :: 'v_OT122 \<leftarrow> S2_OT12 True S3;
    c :: 'v_OT122 \<leftarrow> S2_OT12 True S5;
    return_spmf ((True,True), (a0,a1,a2,a3), a,b,c)}"
    using coin_coin by simp
  ultimately show ?thesis
    by(simp add: funct_OT_14_def S2_14_def bind_spmf_const)
qed

lemma P2_OT_14_FF: "R2_14 (m0,m1,m2,m3) (False, False) = funct_OT_14 (m0,m1,m2,m3) (False, False) \<bind> (\<lambda> (out1, out2). S2_14 (False, False) out2)"
  including monad_normalisation
proof-
  have "R2_14 (m0,m1,m2,m3) (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 :: 'v_OT122 \<leftarrow> S2_OT12 False S0;
    b :: 'v_OT122 \<leftarrow> S2_OT12 False S2;
    c :: 'v_OT122 \<leftarrow> S2_OT12 False S4;
    return_spmf ((False,False), (a0,a1,a2,a3), a,b,c)}"
    by(simp add: bind_map_spmf o_def R2_14_def inf_th_OT12_P2 funct_OT_12_def OT_12_P2_assm 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 :: 'v_OT122 \<leftarrow> S2_OT12 False S0;
    b :: 'v_OT122 \<leftarrow> S2_OT12 False S2;
    c :: 'v_OT122 \<leftarrow> S2_OT12 False S4;
    return_spmf ((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 :: 'v_OT122 \<leftarrow> S2_OT12 False S0;
    b :: 'v_OT122 \<leftarrow> S2_OT12 False S2;
    c :: 'v_OT122 \<leftarrow> S2_OT12 False S4;
    return_spmf ((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 :: 'v_OT122 \<leftarrow> S2_OT12 False S0;
    b :: 'v_OT122 \<leftarrow> S2_OT12 False S2;
    c :: 'v_OT122 \<leftarrow> S2_OT12 False S4;
    return_spmf ((False,False), (a0,a1,a2,a3), a,b,c)}"
    using coin_coin by simp
  ultimately show ?thesis
    by(simp add: funct_OT_14_def S2_14_def bind_spmf_const)
qed

lemma P2_OT_14_TF: "R2_14 (m0,m1,m2,m3) (True,False) = funct_OT_14 (m0,m1,m2,m3) (True,False) \<bind> (\<lambda> (out1, out2). S2_14 (True,False) out2)"
  including monad_normalisation
proof-
  have "R2_14 (m0,m1,m2,m3) (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 :: 'v_OT122 \<leftarrow> S2_OT12 True S1;
    b :: 'v_OT122 \<leftarrow> S2_OT12 False S2;
    c :: 'v_OT122 \<leftarrow> S2_OT12 False S4;
    return_spmf ((True,False), (a0,a1,a2,a3), a,b,c)}"
    apply(simp add: R2_14_def inf_th_OT12_P2 OT_12_P2_assm funct_OT_12_def Let_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 :: 'v_OT122 \<leftarrow> S2_OT12 True S1;
    b :: 'v_OT122 \<leftarrow> S2_OT12 False S2;
    c :: 'v_OT122 \<leftarrow> S2_OT12 False S4;
    return_spmf ((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 :: 'v_OT122 \<leftarrow> S2_OT12 True S1;
    b :: 'v_OT122 \<leftarrow> S2_OT12 False S2;
    c :: 'v_OT122 \<leftarrow> S2_OT12 False S4;
    return_spmf ((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 :: 'v_OT122 \<leftarrow> S2_OT12 True S1;
    b :: 'v_OT122 \<leftarrow> S2_OT12 False S2;
    c :: 'v_OT122 \<leftarrow> S2_OT12 False S4;
    return_spmf ((True,False), (a0,a1,a2,a3), a,b,c)}"
    using coin_coin by simp
  ultimately show ?thesis
    apply(simp add: funct_OT_14_def S2_14_def bind_spmf_const)
    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
qed

lemma P2_sec_OT_14_split: "R2_14 (m0,m1,m2,m3) (c0,c1) = funct_OT_14 (m0,m1,m2,m3) (c0,c1) \<bind> (\<lambda> (out1, out2). S2_14 (c0,c1) out2)"
  by(cases c0; cases c1; auto simp add: P2_OT_14_FF P2_OT_14_TF P2_OT_14_FT P2_OT_14_TT)

lemma P2_sec_OT_14: "R2_14 M C = funct_OT_14 M C \<bind> (\<lambda> (out1, out2). S2_14 C out2)"
  by(metis P2_sec_OT_14_split surj_pair)

sublocale OT_14: sim_det_def R1_14 S1_14 R2_14 S2_14 funct_OT_14 protocol_14_OT
  unfolding sim_det_def_def
  by(simp add: lossless_R1_14 lossless_S1_14 lossless_funct_14_OT lossless_R2_14 lossless_S2_14 )

lemma correctness_OT_14:
  shows "funct_OT_14 M C = protocol_14_OT M C"
proof-
  have "S1 = (S5 = (S1 = (S5 = d))) = d" for S1 S5 d by auto
  thus ?thesis
    by(cases "fst C"; cases "snd C"; simp add: funct_OT_14_def protocol_14_OT_def correct funct_OT_12_def lossless_funct_OT_12 bind_spmf_const split_def)
qed

lemma OT_14_correct: "OT_14.correctness M C"
  unfolding OT_14.correctness_def
  using correctness_OT_14 by auto

lemma OT_14_P2_sec: "OT_14.perfect_sec_P2 m1 m2"
  unfolding OT_14.perfect_sec_P2_def
  using P2_sec_OT_14 by blast

lemma OT_14_P1_sec: "OT_14.adv_P1 m1 m2 D \<le> 3 * adv_OT12"
  unfolding OT_14.adv_P1_def
  by (metis reduction_P1 surj_pair)

end

locale OT_14_asymp = sim_det_def +
  fixes S1_OT12 :: "nat \<Rightarrow> (bool \<times> bool) \<Rightarrow> unit \<Rightarrow> 'v_OT121 spmf"
    and R1_OT12 :: "nat \<Rightarrow> (bool \<times> bool) \<Rightarrow> bool \<Rightarrow> 'v_OT121 spmf"
    and adv_OT12 :: "nat \<Rightarrow> real"
    and S2_OT12 :: "nat \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> 'v_OT122 spmf"
    and R2_OT12 :: "nat \<Rightarrow> (bool \<times> bool) \<Rightarrow> bool \<Rightarrow> 'v_OT122 spmf"
    and protocol_OT12 :: "(bool \<times> bool) \<Rightarrow> bool \<Rightarrow> (unit \<times> bool) spmf"
  assumes ot14_base: "\<And> (n::nat). ot14_base (S1_OT12 n) (R1_12_0T n) (adv_OT12 n) (S2_OT12 n) (R2_12OT n) (protocol_OT12)"
begin

sublocale ot14_base "(S1_OT12 n)" "(R1_12_0T n)" "(adv_OT12 n)" "(S2_OT12 n)" "(R2_12OT n)" using local.ot14_base by simp

lemma OT_14_P1_sec: "OT_14.adv_P1 (R1_12_0T n) n m1 m2 D \<le> 3 * (adv_OT12 n)"
  unfolding OT_14.adv_P1_def using reduction_P1 surj_pair by metis

theorem OT_14_P1_asym_sec: "negligible (\<lambda> n. OT_14.adv_P1 (R1_12_0T n) n m1 m2 D)" if "negligible (\<lambda> n. adv_OT12 n)"
proof-
  have adv_neg: "negligible (\<lambda>n. 3 * adv_OT12 n)" using that negligible_cmultI by simp
  have "\<bar>OT_14.adv_P1 (R1_12_0T n) n m1 m2 D\<bar> \<le> \<bar>3 * (adv_OT12 n)\<bar>" for n
  proof -
    have "\<bar>OT_14.adv_P1 (R1_12_0T n) n m1 m2 D\<bar> \<le> 3 * adv_OT12 n"
      using OT_14.adv_P1_def OT_14_P1_sec by auto
    then show ?thesis
      by (meson abs_ge_self order_trans)
  qed
  thus ?thesis using OT_14_P1_sec negligible_le adv_neg
    by (metis (no_types, lifting) negligible_absI)
qed

theorem OT_14_P2_asym_sec: "OT_14.perfect_sec_P2 R2_OT12 n m1 m2"
  using OT_14_P2_sec by simp

end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_nat_boring_min_idem
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

theorem property0 :
  "((if le x x then x else x) = x)"
  oops

end


theory CR
imports Lam_Funs
begin

text \<open>The Church-Rosser proof from Barendregt's book\<close>

lemma forget:
  assumes asm: "x\<sharp>L"
  shows "L[x::=P] = L"
using asm
proof (nominal_induct L avoiding: x P rule: lam.strong_induct)
  case (Var z)
  have "x\<sharp>Var z" by fact
  thus "(Var z)[x::=P] = (Var z)" by (simp add: fresh_atm)
next
  case (App M1 M2)
  have "x\<sharp>App M1 M2" by fact
  moreover
  have ih1: "x\<sharp>M1 \<Longrightarrow> M1[x::=P] = M1" by fact
  moreover
  have ih1: "x\<sharp>M2 \<Longrightarrow> M2[x::=P] = M2" by fact
  ultimately show "(App M1 M2)[x::=P] = (App M1 M2)" by simp
next
  case (Lam z M)
  have vc: "z\<sharp>x" "z\<sharp>P" by fact+
  have ih: "x\<sharp>M \<Longrightarrow>  M[x::=P] = M" by fact
  have asm: "x\<sharp>Lam [z].M" by fact
  then have "x\<sharp>M" using vc by (simp add: fresh_atm abs_fresh)
  then have "M[x::=P] = M" using ih by simp
  then show "(Lam [z].M)[x::=P] = Lam [z].M" using vc by simp
qed

lemma forget_automatic:
  assumes asm: "x\<sharp>L"
  shows "L[x::=P] = L"
  using asm
by (nominal_induct L avoiding: x P rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm)

lemma fresh_fact:
  fixes z::"name"
  assumes asms: "z\<sharp>N" "z\<sharp>L"
  shows "z\<sharp>(N[y::=L])"
using asms
proof (nominal_induct N avoiding: z y L rule: lam.strong_induct)
  case (Var u)
  have "z\<sharp>(Var u)" "z\<sharp>L" by fact+
  thus "z\<sharp>((Var u)[y::=L])" by simp
next
  case (App N1 N2)
  have ih1: "\<lbrakk>z\<sharp>N1; z\<sharp>L\<rbrakk> \<Longrightarrow> z\<sharp>N1[y::=L]" by fact
  moreover
  have ih2: "\<lbrakk>z\<sharp>N2; z\<sharp>L\<rbrakk> \<Longrightarrow> z\<sharp>N2[y::=L]" by fact
  moreover
  have "z\<sharp>App N1 N2" "z\<sharp>L" by fact+
  ultimately show "z\<sharp>((App N1 N2)[y::=L])" by simp
next
  case (Lam u N1)
  have vc: "u\<sharp>z" "u\<sharp>y" "u\<sharp>L" by fact+
  have "z\<sharp>Lam [u].N1" by fact
  hence "z\<sharp>N1" using vc by (simp add: abs_fresh fresh_atm)
  moreover
  have ih: "\<lbrakk>z\<sharp>N1; z\<sharp>L\<rbrakk> \<Longrightarrow> z\<sharp>(N1[y::=L])" by fact
  moreover
  have  "z\<sharp>L" by fact
  ultimately show "z\<sharp>(Lam [u].N1)[y::=L]" using vc by (simp add: abs_fresh)
qed

lemma fresh_fact_automatic:
  fixes z::"name"
  assumes asms: "z\<sharp>N" "z\<sharp>L"
  shows "z\<sharp>(N[y::=L])"
  using asms
by (nominal_induct N avoiding: z y L rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm)

lemma fresh_fact':
  fixes a::"name"
  assumes a: "a\<sharp>t2"
  shows "a\<sharp>t1[a::=t2]"
using a
by (nominal_induct t1 avoiding: a t2 rule: lam.strong_induct)
   (auto simp add: abs_fresh fresh_atm)

lemma substitution_lemma:
  assumes a: "x\<noteq>y"
  and     b: "x\<sharp>L"
  shows "M[x::=N][y::=L] = M[y::=L][x::=N[y::=L]]"
using a b
proof (nominal_induct M avoiding: x y N L rule: lam.strong_induct)
  case (Var z) (* case 1: Variables*)
  have "x\<noteq>y" by fact
  have "x\<sharp>L" by fact
  show "Var z[x::=N][y::=L] = Var z[y::=L][x::=N[y::=L]]" (is "?LHS = ?RHS")
  proof -
    { (*Case 1.1*)
      assume  "z=x"
      have "(1)": "?LHS = N[y::=L]" using \<open>z=x\<close> by simp
      have "(2)": "?RHS = N[y::=L]" using \<open>z=x\<close> \<open>x\<noteq>y\<close> by simp
      from "(1)" "(2)" have "?LHS = ?RHS"  by simp
    }
    moreover
    { (*Case 1.2*)
      assume "z=y" and "z\<noteq>x"
      have "(1)": "?LHS = L"               using \<open>z\<noteq>x\<close> \<open>z=y\<close> by simp
      have "(2)": "?RHS = L[x::=N[y::=L]]" using \<open>z=y\<close> by simp
      have "(3)": "L[x::=N[y::=L]] = L"    using \<open>x\<sharp>L\<close> by (simp add: forget)
      from "(1)" "(2)" "(3)" have "?LHS = ?RHS" by simp
    }
    moreover
    { (*Case 1.3*)
      assume "z\<noteq>x" and "z\<noteq>y"
      have "(1)": "?LHS = Var z" using \<open>z\<noteq>x\<close> \<open>z\<noteq>y\<close> by simp
      have "(2)": "?RHS = Var z" using \<open>z\<noteq>x\<close> \<open>z\<noteq>y\<close> by simp
      from "(1)" "(2)" have "?LHS = ?RHS" by simp
    }
    ultimately show "?LHS = ?RHS" by blast
  qed
next
  case (Lam z M1) (* case 2: lambdas *)
  have ih: "\<lbrakk>x\<noteq>y; x\<sharp>L\<rbrakk> \<Longrightarrow> M1[x::=N][y::=L] = M1[y::=L][x::=N[y::=L]]" by fact
  have "x\<noteq>y" by fact
  have "x\<sharp>L" by fact
  have fs: "z\<sharp>x" "z\<sharp>y" "z\<sharp>N" "z\<sharp>L" by fact+
  hence "z\<sharp>N[y::=L]" by (simp add: fresh_fact)
  show "(Lam [z].M1)[x::=N][y::=L] = (Lam [z].M1)[y::=L][x::=N[y::=L]]" (is "?LHS=?RHS")
  proof -
    have "?LHS = Lam [z].(M1[x::=N][y::=L])" using \<open>z\<sharp>x\<close> \<open>z\<sharp>y\<close> \<open>z\<sharp>N\<close> \<open>z\<sharp>L\<close> by simp
    also from ih have "\<dots> = Lam [z].(M1[y::=L][x::=N[y::=L]])" using \<open>x\<noteq>y\<close> \<open>x\<sharp>L\<close> by simp
    also have "\<dots> = (Lam [z].(M1[y::=L]))[x::=N[y::=L]]" using \<open>z\<sharp>x\<close> \<open>z\<sharp>N[y::=L]\<close> by simp
    also have "\<dots> = ?RHS" using  \<open>z\<sharp>y\<close> \<open>z\<sharp>L\<close> by simp
    finally show "?LHS = ?RHS" .
  qed
next
  case (App M1 M2) (* case 3: applications *)
  thus "(App M1 M2)[x::=N][y::=L] = (App M1 M2)[y::=L][x::=N[y::=L]]" by simp
qed

lemma substitution_lemma_automatic:
  assumes asm: "x\<noteq>y" "x\<sharp>L"
  shows "M[x::=N][y::=L] = M[y::=L][x::=N[y::=L]]"
  using asm
by (nominal_induct M avoiding: x y N L rule: lam.strong_induct)
   (auto simp add: fresh_fact forget)

section \<open>Beta Reduction\<close>

inductive
  "Beta" :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>\<beta> _" [80,80] 80)
where
    b1[intro]: "s1\<longrightarrow>\<^sub>\<beta>s2 \<Longrightarrow> (App s1 t)\<longrightarrow>\<^sub>\<beta>(App s2 t)"
  | b2[intro]: "s1\<longrightarrow>\<^sub>\<beta>s2 \<Longrightarrow> (App t s1)\<longrightarrow>\<^sub>\<beta>(App t s2)"
  | b3[intro]: "s1\<longrightarrow>\<^sub>\<beta>s2 \<Longrightarrow> (Lam [a].s1)\<longrightarrow>\<^sub>\<beta> (Lam [a].s2)"
  | b4[intro]: "a\<sharp>s2 \<Longrightarrow> (App (Lam [a].s1) s2)\<longrightarrow>\<^sub>\<beta>(s1[a::=s2])"

equivariance Beta

nominal_inductive Beta
  by (simp_all add: abs_fresh fresh_fact')

inductive
  "Beta_star"  :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>\<beta>\<^sup>* _" [80,80] 80)
where
    bs1[intro, simp]: "M \<longrightarrow>\<^sub>\<beta>\<^sup>* M"
  | bs2[intro]: "\<lbrakk>M1\<longrightarrow>\<^sub>\<beta>\<^sup>* M2; M2 \<longrightarrow>\<^sub>\<beta> M3\<rbrakk> \<Longrightarrow> M1 \<longrightarrow>\<^sub>\<beta>\<^sup>* M3"

equivariance Beta_star

lemma beta_star_trans:
  assumes a1: "M1\<longrightarrow>\<^sub>\<beta>\<^sup>* M2"
  and     a2: "M2\<longrightarrow>\<^sub>\<beta>\<^sup>* M3"
  shows "M1 \<longrightarrow>\<^sub>\<beta>\<^sup>* M3"
using a2 a1
by (induct) (auto)

section \<open>One-Reduction\<close>

inductive
  One :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>1 _" [80,80] 80)
where
    o1[intro!]:      "M\<longrightarrow>\<^sub>1M"
  | o2[simp,intro!]: "\<lbrakk>t1\<longrightarrow>\<^sub>1t2;s1\<longrightarrow>\<^sub>1s2\<rbrakk> \<Longrightarrow> (App t1 s1)\<longrightarrow>\<^sub>1(App t2 s2)"
  | o3[simp,intro!]: "s1\<longrightarrow>\<^sub>1s2 \<Longrightarrow> (Lam [a].s1)\<longrightarrow>\<^sub>1(Lam [a].s2)"
  | o4[simp,intro!]: "\<lbrakk>a\<sharp>(s1,s2); s1\<longrightarrow>\<^sub>1s2;t1\<longrightarrow>\<^sub>1t2\<rbrakk> \<Longrightarrow> (App (Lam [a].t1) s1)\<longrightarrow>\<^sub>1(t2[a::=s2])"

equivariance One

nominal_inductive One
  by (simp_all add: abs_fresh fresh_fact')

inductive
  "One_star"  :: "lam\<Rightarrow>lam\<Rightarrow>bool" (" _ \<longrightarrow>\<^sub>1\<^sup>* _" [80,80] 80)
where
    os1[intro, simp]: "M \<longrightarrow>\<^sub>1\<^sup>* M"
  | os2[intro]: "\<lbrakk>M1\<longrightarrow>\<^sub>1\<^sup>* M2; M2 \<longrightarrow>\<^sub>1 M3\<rbrakk> \<Longrightarrow> M1 \<longrightarrow>\<^sub>1\<^sup>* M3"

equivariance One_star

lemma one_star_trans:
  assumes a1: "M1\<longrightarrow>\<^sub>1\<^sup>* M2"
  and     a2: "M2\<longrightarrow>\<^sub>1\<^sup>* M3"
  shows "M1\<longrightarrow>\<^sub>1\<^sup>* M3"
using a2 a1
by (induct) (auto)

lemma one_fresh_preserv:
  fixes a :: "name"
  assumes a: "t\<longrightarrow>\<^sub>1s"
  and     b: "a\<sharp>t"
  shows "a\<sharp>s"
using a b
proof (induct)
  case o1 thus ?case by simp
next
  case o2 thus ?case by simp
next
  case (o3 s1 s2 c)
  have ih: "a\<sharp>s1 \<Longrightarrow>  a\<sharp>s2" by fact
  have c: "a\<sharp>Lam [c].s1" by fact
  show ?case
  proof (cases "a=c")
    assume "a=c" thus "a\<sharp>Lam [c].s2" by (simp add: abs_fresh)
  next
    assume d: "a\<noteq>c"
    with c have "a\<sharp>s1" by (simp add: abs_fresh)
    hence "a\<sharp>s2" using ih by simp
    thus "a\<sharp>Lam [c].s2" using d by (simp add: abs_fresh)
  qed
next
  case (o4 c t1 t2 s1 s2)
  have i1: "a\<sharp>t1 \<Longrightarrow> a\<sharp>t2" by fact
  have i2: "a\<sharp>s1 \<Longrightarrow> a\<sharp>s2" by fact
  have as: "a\<sharp>App (Lam [c].s1) t1" by fact
  hence c1: "a\<sharp>Lam [c].s1" and c2: "a\<sharp>t1" by (simp add: fresh_prod)+
  from c2 i1 have c3: "a\<sharp>t2" by simp
  show "a\<sharp>s2[c::=t2]"
  proof (cases "a=c")
    assume "a=c"
    thus "a\<sharp>s2[c::=t2]" using c3 by (simp add: fresh_fact')
  next
    assume d1: "a\<noteq>c"
    from c1 d1 have "a\<sharp>s1" by (simp add: abs_fresh)
    hence "a\<sharp>s2" using i2 by simp
    thus "a\<sharp>s2[c::=t2]" using c3 by (simp add: fresh_fact)
  qed
qed

lemma one_fresh_preserv_automatic:
  fixes a :: "name"
  assumes a: "t\<longrightarrow>\<^sub>1s"
  and     b: "a\<sharp>t"
  shows "a\<sharp>s"
using a b
apply(nominal_induct avoiding: a rule: One.strong_induct)
apply(auto simp add: abs_fresh fresh_atm fresh_fact)
done

lemma subst_rename:
  assumes a: "c\<sharp>t1"
  shows "t1[a::=t2] = ([(c,a)]\<bullet>t1)[c::=t2]"
using a
by (nominal_induct t1 avoiding: a c t2 rule: lam.strong_induct)
   (auto simp add: calc_atm fresh_atm abs_fresh)

lemma one_abs:
  assumes a: "Lam [a].t\<longrightarrow>\<^sub>1t'"
  shows "\<exists>t''. t'=Lam [a].t'' \<and> t\<longrightarrow>\<^sub>1t''"
proof -
  have "a\<sharp>Lam [a].t" by (simp add: abs_fresh)
  with a have "a\<sharp>t'" by (simp add: one_fresh_preserv)
  with a show ?thesis
    by (cases rule: One.strong_cases[where a="a" and aa="a"])
       (auto simp add: lam.inject abs_fresh alpha)
qed

lemma one_app:
  assumes a: "App t1 t2 \<longrightarrow>\<^sub>1 t'"
  shows "(\<exists>s1 s2. t' = App s1 s2 \<and> t1 \<longrightarrow>\<^sub>1 s1 \<and> t2 \<longrightarrow>\<^sub>1 s2) \<or>
         (\<exists>a s s1 s2. t1 = Lam [a].s \<and> t' = s1[a::=s2] \<and> s \<longrightarrow>\<^sub>1 s1 \<and> t2 \<longrightarrow>\<^sub>1 s2 \<and> a\<sharp>(t2,s2))"
using a by (erule_tac One.cases) (auto simp add: lam.inject)

lemma one_red:
  assumes a: "App (Lam [a].t1) t2 \<longrightarrow>\<^sub>1 M" "a\<sharp>(t2,M)"
  shows "(\<exists>s1 s2. M = App (Lam [a].s1) s2 \<and> t1 \<longrightarrow>\<^sub>1 s1 \<and> t2 \<longrightarrow>\<^sub>1 s2) \<or>
         (\<exists>s1 s2. M = s1[a::=s2] \<and> t1 \<longrightarrow>\<^sub>1 s1 \<and> t2 \<longrightarrow>\<^sub>1 s2)"
using a
by (cases rule: One.strong_cases [where a="a" and aa="a"])
   (auto dest: one_abs simp add: lam.inject abs_fresh alpha fresh_prod)

text \<open>first case in Lemma 3.2.4\<close>

lemma one_subst_aux:
  assumes a: "N\<longrightarrow>\<^sub>1N'"
  shows "M[x::=N] \<longrightarrow>\<^sub>1 M[x::=N']"
using a
proof (nominal_induct M avoiding: x N N' rule: lam.strong_induct)
  case (Var y)
  thus "Var y[x::=N] \<longrightarrow>\<^sub>1 Var y[x::=N']" by (cases "x=y") auto
next
  case (App P Q) (* application case - third line *)
  thus "(App P Q)[x::=N] \<longrightarrow>\<^sub>1  (App P Q)[x::=N']" using o2 by simp
next
  case (Lam y P) (* abstraction case - fourth line *)
  thus "(Lam [y].P)[x::=N] \<longrightarrow>\<^sub>1 (Lam [y].P)[x::=N']" using o3 by simp
qed

lemma one_subst_aux_automatic:
  assumes a: "N\<longrightarrow>\<^sub>1N'"
  shows "M[x::=N] \<longrightarrow>\<^sub>1 M[x::=N']"
using a
by (nominal_induct M avoiding: x N N' rule: lam.strong_induct)
   (auto simp add: fresh_prod fresh_atm)

lemma one_subst:
  assumes a: "M\<longrightarrow>\<^sub>1M'"
  and     b: "N\<longrightarrow>\<^sub>1N'"
  shows "M[x::=N]\<longrightarrow>\<^sub>1M'[x::=N']"
using a b
proof (nominal_induct M M' avoiding: N N' x rule: One.strong_induct)
  case (o1 M)
  thus ?case by (simp add: one_subst_aux)
next
  case (o2 M1 M2 N1 N2)
  thus ?case by simp
next
  case (o3 a M1 M2)
  thus ?case by simp
next
  case (o4 a N1 N2 M1 M2 N N' x)
  have vc: "a\<sharp>N" "a\<sharp>N'" "a\<sharp>x" "a\<sharp>N1" "a\<sharp>N2" by fact+
  have asm: "N\<longrightarrow>\<^sub>1N'" by fact
  show ?case
  proof -
    have "(App (Lam [a].M1) N1)[x::=N] = App (Lam [a].(M1[x::=N])) (N1[x::=N])" using vc by simp
    moreover have "App (Lam [a].(M1[x::=N])) (N1[x::=N]) \<longrightarrow>\<^sub>1 M2[x::=N'][a::=N2[x::=N']]"
      using o4 asm by (simp add: fresh_fact)
    moreover have "M2[x::=N'][a::=N2[x::=N']] = M2[a::=N2][x::=N']"
      using vc by (simp add: substitution_lemma fresh_atm)
    ultimately show "(App (Lam [a].M1) N1)[x::=N] \<longrightarrow>\<^sub>1 M2[a::=N2][x::=N']" by simp
  qed
qed

lemma one_subst_automatic:
  assumes a: "M\<longrightarrow>\<^sub>1M'"
  and     b: "N\<longrightarrow>\<^sub>1N'"
  shows "M[x::=N]\<longrightarrow>\<^sub>1M'[x::=N']"
using a b
by (nominal_induct M M' avoiding: N N' x rule: One.strong_induct)
   (auto simp add: one_subst_aux substitution_lemma fresh_atm fresh_fact)

lemma diamond[rule_format]:
  fixes    M :: "lam"
  and      M1:: "lam"
  assumes a: "M\<longrightarrow>\<^sub>1M1"
  and     b: "M\<longrightarrow>\<^sub>1M2"
  shows "\<exists>M3. M1\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3"
  using a b
proof (nominal_induct avoiding: M1 M2 rule: One.strong_induct)
  case (o1 M) (* case 1 --- M1 = M *)
  thus "\<exists>M3. M\<longrightarrow>\<^sub>1M3 \<and>  M2\<longrightarrow>\<^sub>1M3" by blast
next
  case (o4 x Q Q' P P') (* case 2 --- a beta-reduction occurs*)
  have vc: "x\<sharp>Q" "x\<sharp>Q'" "x\<sharp>M2" by fact+
  have i1: "\<And>M2. Q \<longrightarrow>\<^sub>1M2 \<Longrightarrow> (\<exists>M3. Q'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3)" by fact
  have i2: "\<And>M2. P \<longrightarrow>\<^sub>1M2 \<Longrightarrow> (\<exists>M3. P'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3)" by fact
  have "App (Lam [x].P) Q \<longrightarrow>\<^sub>1 M2" by fact
  hence "(\<exists>P' Q'. M2 = App (Lam [x].P') Q' \<and> P\<longrightarrow>\<^sub>1P' \<and> Q\<longrightarrow>\<^sub>1Q') \<or>
         (\<exists>P' Q'. M2 = P'[x::=Q'] \<and> P\<longrightarrow>\<^sub>1P' \<and> Q\<longrightarrow>\<^sub>1Q')" using vc by (simp add: one_red)
  moreover (* subcase 2.1 *)
  { assume "\<exists>P' Q'. M2 = App (Lam [x].P') Q' \<and> P\<longrightarrow>\<^sub>1P' \<and> Q\<longrightarrow>\<^sub>1Q'"
    then obtain P'' and Q'' where
      b1: "M2=App (Lam [x].P'') Q''" and b2: "P\<longrightarrow>\<^sub>1P''" and b3: "Q\<longrightarrow>\<^sub>1Q''" by blast
    from b2 i2 have "(\<exists>M3. P'\<longrightarrow>\<^sub>1M3 \<and> P''\<longrightarrow>\<^sub>1M3)" by simp
    then obtain P''' where
      c1: "P'\<longrightarrow>\<^sub>1P'''" and c2: "P''\<longrightarrow>\<^sub>1P'''" by force
    from b3 i1 have "(\<exists>M3. Q'\<longrightarrow>\<^sub>1M3 \<and> Q''\<longrightarrow>\<^sub>1M3)" by simp
    then obtain Q''' where
      d1: "Q'\<longrightarrow>\<^sub>1Q'''" and d2: "Q''\<longrightarrow>\<^sub>1Q'''" by force
    from c1 c2 d1 d2
    have "P'[x::=Q']\<longrightarrow>\<^sub>1P'''[x::=Q'''] \<and> App (Lam [x].P'') Q'' \<longrightarrow>\<^sub>1 P'''[x::=Q''']"
      using vc b3 by (auto simp add: one_subst one_fresh_preserv)
    hence "\<exists>M3. P'[x::=Q']\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" using b1 by blast
  }
  moreover (* subcase 2.2 *)
  { assume "\<exists>P' Q'. M2 = P'[x::=Q'] \<and> P\<longrightarrow>\<^sub>1P' \<and> Q\<longrightarrow>\<^sub>1Q'"
    then obtain P'' Q'' where
      b1: "M2=P''[x::=Q'']" and b2: "P\<longrightarrow>\<^sub>1P''" and  b3: "Q\<longrightarrow>\<^sub>1Q''" by blast
    from b2 i2 have "(\<exists>M3. P'\<longrightarrow>\<^sub>1M3 \<and> P''\<longrightarrow>\<^sub>1M3)" by simp
    then obtain P''' where
      c1: "P'\<longrightarrow>\<^sub>1P'''" and c2: "P''\<longrightarrow>\<^sub>1P'''" by blast
    from b3 i1 have "(\<exists>M3. Q'\<longrightarrow>\<^sub>1M3 \<and> Q''\<longrightarrow>\<^sub>1M3)" by simp
    then obtain Q''' where
      d1: "Q'\<longrightarrow>\<^sub>1Q'''" and d2: "Q''\<longrightarrow>\<^sub>1Q'''" by blast
    from c1 c2 d1 d2
    have "P'[x::=Q']\<longrightarrow>\<^sub>1P'''[x::=Q'''] \<and> P''[x::=Q'']\<longrightarrow>\<^sub>1P'''[x::=Q''']"
      by (force simp add: one_subst)
    hence "\<exists>M3. P'[x::=Q']\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" using b1 by blast
  }
  ultimately show "\<exists>M3. P'[x::=Q']\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" by blast
next
  case (o2 P P' Q Q') (* case 3 *)
  have i0: "P\<longrightarrow>\<^sub>1P'" by fact
  have i0': "Q\<longrightarrow>\<^sub>1Q'" by fact
  have i1: "\<And>M2. Q \<longrightarrow>\<^sub>1M2 \<Longrightarrow> (\<exists>M3. Q'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3)" by fact
  have i2: "\<And>M2. P \<longrightarrow>\<^sub>1M2 \<Longrightarrow> (\<exists>M3. P'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3)" by fact
  assume "App P Q \<longrightarrow>\<^sub>1 M2"
  hence "(\<exists>P'' Q''. M2 = App P'' Q'' \<and> P\<longrightarrow>\<^sub>1P'' \<and> Q\<longrightarrow>\<^sub>1Q'') \<or>
         (\<exists>x P' P'' Q'. P = Lam [x].P' \<and> M2 = P''[x::=Q'] \<and> P'\<longrightarrow>\<^sub>1 P'' \<and> Q\<longrightarrow>\<^sub>1Q' \<and> x\<sharp>(Q,Q'))"
    by (simp add: one_app[simplified])
  moreover (* subcase 3.1 *)
  { assume "\<exists>P'' Q''. M2 = App P'' Q'' \<and> P\<longrightarrow>\<^sub>1P'' \<and> Q\<longrightarrow>\<^sub>1Q''"
    then obtain P'' and Q'' where
      b1: "M2=App P'' Q''" and b2: "P\<longrightarrow>\<^sub>1P''" and b3: "Q\<longrightarrow>\<^sub>1Q''" by blast
    from b2 i2 have "(\<exists>M3. P'\<longrightarrow>\<^sub>1M3 \<and> P''\<longrightarrow>\<^sub>1M3)" by simp
    then obtain P''' where
      c1: "P'\<longrightarrow>\<^sub>1P'''" and c2: "P''\<longrightarrow>\<^sub>1P'''" by blast
    from b3 i1 have "\<exists>M3. Q'\<longrightarrow>\<^sub>1M3 \<and> Q''\<longrightarrow>\<^sub>1M3" by simp
    then obtain Q''' where
      d1: "Q'\<longrightarrow>\<^sub>1Q'''" and d2: "Q''\<longrightarrow>\<^sub>1Q'''" by blast
    from c1 c2 d1 d2
    have "App P' Q'\<longrightarrow>\<^sub>1App P''' Q''' \<and> App P'' Q'' \<longrightarrow>\<^sub>1 App P''' Q'''" by blast
    hence "\<exists>M3. App P' Q'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" using b1 by blast
  }
  moreover (* subcase 3.2 *)
  { assume "\<exists>x P1 P'' Q''. P = Lam [x].P1 \<and> M2 = P''[x::=Q''] \<and> P1\<longrightarrow>\<^sub>1 P'' \<and> Q\<longrightarrow>\<^sub>1Q'' \<and> x\<sharp>(Q,Q'')"
    then obtain x P1 P1'' Q'' where
      b0: "P = Lam [x].P1" and b1: "M2 = P1''[x::=Q'']" and
      b2: "P1\<longrightarrow>\<^sub>1P1''" and  b3: "Q\<longrightarrow>\<^sub>1Q''" and vc: "x\<sharp>(Q,Q'')" by blast
    from b0 i0 have "\<exists>P1'. P'=Lam [x].P1' \<and> P1\<longrightarrow>\<^sub>1P1'" by (simp add: one_abs)
    then obtain P1' where g1: "P'=Lam [x].P1'" and g2: "P1\<longrightarrow>\<^sub>1P1'" by blast
    from g1 b0 b2 i2 have "(\<exists>M3. (Lam [x].P1')\<longrightarrow>\<^sub>1M3 \<and> (Lam [x].P1'')\<longrightarrow>\<^sub>1M3)" by simp
    then obtain P1''' where
      c1: "(Lam [x].P1')\<longrightarrow>\<^sub>1P1'''" and c2: "(Lam [x].P1'')\<longrightarrow>\<^sub>1P1'''" by blast
    from c1 have "\<exists>R1. P1'''=Lam [x].R1 \<and> P1'\<longrightarrow>\<^sub>1R1" by (simp add: one_abs)
    then obtain R1 where r1: "P1'''=Lam [x].R1" and r2: "P1'\<longrightarrow>\<^sub>1R1" by blast
    from c2 have "\<exists>R2. P1'''=Lam [x].R2 \<and> P1''\<longrightarrow>\<^sub>1R2" by (simp add: one_abs)
    then obtain R2 where r3: "P1'''=Lam [x].R2" and r4: "P1''\<longrightarrow>\<^sub>1R2" by blast
    from r1 r3 have r5: "R1=R2" by (simp add: lam.inject alpha)
    from b3 i1 have "(\<exists>M3. Q'\<longrightarrow>\<^sub>1M3 \<and> Q''\<longrightarrow>\<^sub>1M3)" by simp
    then obtain Q''' where
      d1: "Q'\<longrightarrow>\<^sub>1Q'''" and d2: "Q''\<longrightarrow>\<^sub>1Q'''" by blast
    from g1 r2 d1 r4 r5 d2
    have "App P' Q'\<longrightarrow>\<^sub>1R1[x::=Q'''] \<and> P1''[x::=Q'']\<longrightarrow>\<^sub>1R1[x::=Q''']"
      using vc i0' by (simp add: one_subst one_fresh_preserv)
    hence "\<exists>M3. App P' Q'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" using b1 by blast
  }
  ultimately show "\<exists>M3. App P' Q'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" by blast
next
  case (o3 P P' x) (* case 4 *)
  have i1: "P\<longrightarrow>\<^sub>1P'" by fact
  have i2: "\<And>M2. P \<longrightarrow>\<^sub>1M2 \<Longrightarrow> (\<exists>M3. P'\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3)" by fact
  have "(Lam [x].P)\<longrightarrow>\<^sub>1 M2" by fact
  hence "\<exists>P''. M2=Lam [x].P'' \<and> P\<longrightarrow>\<^sub>1P''" by (simp add: one_abs)
  then obtain P'' where b1: "M2=Lam [x].P''" and b2: "P\<longrightarrow>\<^sub>1P''" by blast
  from i2 b1 b2 have "\<exists>M3. (Lam [x].P')\<longrightarrow>\<^sub>1M3 \<and> (Lam [x].P'')\<longrightarrow>\<^sub>1M3" by blast
  then obtain M3 where c1: "(Lam [x].P')\<longrightarrow>\<^sub>1M3" and c2: "(Lam [x].P'')\<longrightarrow>\<^sub>1M3" by blast
  from c1 have "\<exists>R1. M3=Lam [x].R1 \<and> P'\<longrightarrow>\<^sub>1R1" by (simp add: one_abs)
  then obtain R1 where r1: "M3=Lam [x].R1" and r2: "P'\<longrightarrow>\<^sub>1R1" by blast
  from c2 have "\<exists>R2. M3=Lam [x].R2 \<and> P''\<longrightarrow>\<^sub>1R2" by (simp add: one_abs)
  then obtain R2 where r3: "M3=Lam [x].R2" and r4: "P''\<longrightarrow>\<^sub>1R2" by blast
  from r1 r3 have r5: "R1=R2" by (simp add: lam.inject alpha)
  from r2 r4 have "(Lam [x].P')\<longrightarrow>\<^sub>1(Lam [x].R1) \<and> (Lam [x].P'')\<longrightarrow>\<^sub>1(Lam [x].R2)"
    by (simp add: one_subst)
  thus "\<exists>M3. (Lam [x].P')\<longrightarrow>\<^sub>1M3 \<and> M2\<longrightarrow>\<^sub>1M3" using b1 r5 by blast
qed

lemma one_lam_cong:
  assumes a: "t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t2"
  shows "(Lam [a].t1)\<longrightarrow>\<^sub>\<beta>\<^sup>*(Lam [a].t2)"
  using a
proof induct
  case bs1 thus ?case by simp
next
  case (bs2 y z)
  thus ?case by (blast dest: b3)
qed

lemma one_app_congL:
  assumes a: "t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t2"
  shows "App t1 s\<longrightarrow>\<^sub>\<beta>\<^sup>* App t2 s"
  using a
proof induct
  case bs1 thus ?case by simp
next
  case bs2 thus ?case by (blast dest: b1)
qed

lemma one_app_congR:
  assumes a: "t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t2"
  shows "App s t1 \<longrightarrow>\<^sub>\<beta>\<^sup>* App s t2"
using a
proof induct
  case bs1 thus ?case by simp
next
  case bs2 thus ?case by (blast dest: b2)
qed

lemma one_app_cong:
  assumes a1: "t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t2"
  and     a2: "s1\<longrightarrow>\<^sub>\<beta>\<^sup>*s2"
  shows "App t1 s1\<longrightarrow>\<^sub>\<beta>\<^sup>* App t2 s2"
proof -
  have "App t1 s1 \<longrightarrow>\<^sub>\<beta>\<^sup>* App t2 s1" using a1 by (rule one_app_congL)
  moreover
  have "App t2 s1 \<longrightarrow>\<^sub>\<beta>\<^sup>* App t2 s2" using a2 by (rule one_app_congR)
  ultimately show ?thesis by (rule beta_star_trans)
qed

lemma one_beta_star:
  assumes a: "(t1\<longrightarrow>\<^sub>1t2)"
  shows "(t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t2)"
  using a
proof(nominal_induct rule: One.strong_induct)
  case o1 thus ?case by simp
next
  case o2 thus ?case by (blast intro!: one_app_cong)
next
  case o3 thus ?case by (blast intro!: one_lam_cong)
next
  case (o4 a s1 s2 t1 t2)
  have vc: "a\<sharp>s1" "a\<sharp>s2" by fact+
  have a1: "t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t2" and a2: "s1\<longrightarrow>\<^sub>\<beta>\<^sup>*s2" by fact+
  have c1: "(App (Lam [a].t2) s2) \<longrightarrow>\<^sub>\<beta> (t2 [a::= s2])" using vc by (simp add: b4)
  from a1 a2 have c2: "App (Lam [a].t1 ) s1 \<longrightarrow>\<^sub>\<beta>\<^sup>* App (Lam [a].t2 ) s2"
    by (blast intro!: one_app_cong one_lam_cong)
  show ?case using c2 c1 by (blast intro: beta_star_trans)
qed

lemma one_star_lam_cong:
  assumes a: "t1\<longrightarrow>\<^sub>1\<^sup>*t2"
  shows "(Lam  [a].t1)\<longrightarrow>\<^sub>1\<^sup>* (Lam [a].t2)"
  using a
proof induct
  case os1 thus ?case by simp
next
  case os2 thus ?case by (blast intro: one_star_trans)
qed

lemma one_star_app_congL:
  assumes a: "t1\<longrightarrow>\<^sub>1\<^sup>*t2"
  shows "App t1 s\<longrightarrow>\<^sub>1\<^sup>* App t2 s"
  using a
proof induct
  case os1 thus ?case by simp
next
  case os2 thus ?case by (blast intro: one_star_trans)
qed

lemma one_star_app_congR:
  assumes a: "t1\<longrightarrow>\<^sub>1\<^sup>*t2"
  shows "App s t1 \<longrightarrow>\<^sub>1\<^sup>* App s t2"
  using a
proof induct
  case os1 thus ?case by simp
next
  case os2 thus ?case by (blast intro: one_star_trans)
qed

lemma beta_one_star:
  assumes a: "t1\<longrightarrow>\<^sub>\<beta>t2"
  shows "t1\<longrightarrow>\<^sub>1\<^sup>*t2"
  using a
proof(induct)
  case b1 thus ?case by (blast intro!: one_star_app_congL)
next
  case b2 thus ?case by (blast intro!: one_star_app_congR)
next
  case b3 thus ?case by (blast intro!: one_star_lam_cong)
next
  case b4 thus ?case by auto
qed

lemma trans_closure:
  shows "(M1\<longrightarrow>\<^sub>1\<^sup>*M2) = (M1\<longrightarrow>\<^sub>\<beta>\<^sup>*M2)"
proof
  assume "M1 \<longrightarrow>\<^sub>1\<^sup>* M2"
  then show "M1\<longrightarrow>\<^sub>\<beta>\<^sup>*M2"
  proof induct
    case (os1 M1) thus "M1\<longrightarrow>\<^sub>\<beta>\<^sup>*M1" by simp
  next
    case (os2 M1 M2 M3)
    have "M2\<longrightarrow>\<^sub>1M3" by fact
    then have "M2\<longrightarrow>\<^sub>\<beta>\<^sup>*M3" by (rule one_beta_star)
    moreover have "M1\<longrightarrow>\<^sub>\<beta>\<^sup>*M2" by fact
    ultimately show "M1\<longrightarrow>\<^sub>\<beta>\<^sup>*M3" by (auto intro: beta_star_trans)
  qed
next
  assume "M1 \<longrightarrow>\<^sub>\<beta>\<^sup>* M2"
  then show "M1\<longrightarrow>\<^sub>1\<^sup>*M2"
  proof induct
    case (bs1 M1) thus  "M1\<longrightarrow>\<^sub>1\<^sup>*M1" by simp
  next
    case (bs2 M1 M2 M3)
    have "M2\<longrightarrow>\<^sub>\<beta>M3" by fact
    then have "M2\<longrightarrow>\<^sub>1\<^sup>*M3" by (rule beta_one_star)
    moreover have "M1\<longrightarrow>\<^sub>1\<^sup>*M2" by fact
    ultimately show "M1\<longrightarrow>\<^sub>1\<^sup>*M3" by (auto intro: one_star_trans)
  qed
qed

lemma cr_one:
  assumes a: "t\<longrightarrow>\<^sub>1\<^sup>*t1"
  and     b: "t\<longrightarrow>\<^sub>1t2"
  shows "\<exists>t3. t1\<longrightarrow>\<^sub>1t3 \<and> t2\<longrightarrow>\<^sub>1\<^sup>*t3"
  using a b
proof (induct arbitrary: t2)
  case os1 thus ?case by force
next
  case (os2 t s1 s2 t2)
  have b: "s1 \<longrightarrow>\<^sub>1 s2" by fact
  have h: "\<And>t2. t \<longrightarrow>\<^sub>1 t2 \<Longrightarrow> (\<exists>t3. s1 \<longrightarrow>\<^sub>1 t3 \<and> t2 \<longrightarrow>\<^sub>1\<^sup>* t3)" by fact
  have c: "t \<longrightarrow>\<^sub>1 t2" by fact
  show "\<exists>t3. s2 \<longrightarrow>\<^sub>1 t3 \<and>  t2 \<longrightarrow>\<^sub>1\<^sup>* t3"
  proof -
    from c h have "\<exists>t3. s1 \<longrightarrow>\<^sub>1 t3 \<and> t2 \<longrightarrow>\<^sub>1\<^sup>* t3" by blast
    then obtain t3 where c1: "s1 \<longrightarrow>\<^sub>1 t3" and c2: "t2 \<longrightarrow>\<^sub>1\<^sup>* t3" by blast
    have "\<exists>t4. s2 \<longrightarrow>\<^sub>1 t4 \<and> t3 \<longrightarrow>\<^sub>1 t4" using b c1 by (blast intro: diamond)
    thus ?thesis using c2 by (blast intro: one_star_trans)
  qed
qed

lemma cr_one_star:
  assumes a: "t\<longrightarrow>\<^sub>1\<^sup>*t2"
      and b: "t\<longrightarrow>\<^sub>1\<^sup>*t1"
    shows "\<exists>t3. t1\<longrightarrow>\<^sub>1\<^sup>*t3\<and>t2\<longrightarrow>\<^sub>1\<^sup>*t3"
using a b
proof (induct arbitrary: t1)
  case (os1 t) then show ?case by force
next
  case (os2 t s1 s2 t1)
  have c: "t \<longrightarrow>\<^sub>1\<^sup>* s1" by fact
  have c': "t \<longrightarrow>\<^sub>1\<^sup>* t1" by fact
  have d: "s1 \<longrightarrow>\<^sub>1 s2" by fact
  have "t \<longrightarrow>\<^sub>1\<^sup>* t1 \<Longrightarrow> (\<exists>t3.  t1 \<longrightarrow>\<^sub>1\<^sup>* t3 \<and> s1 \<longrightarrow>\<^sub>1\<^sup>* t3)" by fact
  then obtain t3 where f1: "t1 \<longrightarrow>\<^sub>1\<^sup>* t3"
                   and f2: "s1 \<longrightarrow>\<^sub>1\<^sup>* t3" using c' by blast
  from cr_one d f2 have "\<exists>t4. t3\<longrightarrow>\<^sub>1t4 \<and> s2\<longrightarrow>\<^sub>1\<^sup>*t4" by blast
  then obtain t4 where g1: "t3\<longrightarrow>\<^sub>1t4"
                   and g2: "s2\<longrightarrow>\<^sub>1\<^sup>*t4" by blast
  have "t1\<longrightarrow>\<^sub>1\<^sup>*t4" using f1 g1 by (blast intro: one_star_trans)
  thus ?case using g2 by blast
qed

lemma cr_beta_star:
  assumes a1: "t\<longrightarrow>\<^sub>\<beta>\<^sup>*t1"
  and     a2: "t\<longrightarrow>\<^sub>\<beta>\<^sup>*t2"
  shows "\<exists>t3. t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t3\<and>t2\<longrightarrow>\<^sub>\<beta>\<^sup>*t3"
proof -
  from a1 have "t\<longrightarrow>\<^sub>1\<^sup>*t1" by (simp only: trans_closure)
  moreover
  from a2 have "t\<longrightarrow>\<^sub>1\<^sup>*t2" by (simp only: trans_closure)
  ultimately have "\<exists>t3. t1\<longrightarrow>\<^sub>1\<^sup>*t3 \<and> t2\<longrightarrow>\<^sub>1\<^sup>*t3" by (blast intro: cr_one_star)
  then obtain t3 where "t1\<longrightarrow>\<^sub>1\<^sup>*t3" and "t2\<longrightarrow>\<^sub>1\<^sup>*t3" by blast
  hence "t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t3" and "t2\<longrightarrow>\<^sub>\<beta>\<^sup>*t3" by (simp_all only: trans_closure)
  then show "\<exists>t3. t1\<longrightarrow>\<^sub>\<beta>\<^sup>*t3\<and>t2\<longrightarrow>\<^sub>\<beta>\<^sup>*t3" by blast
qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
 * Tactic for solving monadic equalities, such as:
 *
 * (liftE (return 3) = returnOk 3
 *
 * Theorems of the form:
 *
 *   ((a, s') \<in> fst (A s)) = P a s s'
 *
 * and
 *
 *   snd (A s) = P s
 *
 * are added to the "monad_eq" set.
 *)
theory MonadEq
imports "Monad_WP/NonDetMonadVCG"
begin

(* Setup "monad_eq" attributes. *)
ML \<open>
structure MonadEqThms = Named_Thms (
    val name = Binding.name "monad_eq"
    val description = "monad equality-prover theorems"
    )
\<close>
attribute_setup monad_eq = \<open>
  Attrib.add_del
    (Thm.declaration_attribute MonadEqThms.add_thm)
    (Thm.declaration_attribute MonadEqThms.del_thm)\<close>
  "Monad equality-prover theorems"

(* Setup tactic. *)

ML \<open>
fun monad_eq_tac ctxt =
let
  (* Set a simpset as being hidden, so warnings are not printed from it. *)
  val ctxt' = Context_Position.set_visible false ctxt
in
  CHANGED (clarsimp_tac (ctxt' addsimps (MonadEqThms.get ctxt')) 1)
end
\<close>

method_setup monad_eq = \<open>
    Method.sections Clasimp.clasimp_modifiers >> (K (SIMPLE_METHOD o monad_eq_tac))\<close>
  "prove equality on monads"

lemma monad_eq_simp_state [monad_eq]:
  "((A :: ('s, 'a) nondet_monad) s = B s') =
      ((\<forall>r t. (r, t) \<in> fst (A s) \<longrightarrow> (r, t) \<in> fst (B s'))
         \<and> (\<forall>r t. (r, t) \<in> fst (B s') \<longrightarrow> (r, t) \<in> fst (A s))
         \<and> (snd (A s) = snd (B s')))"
  apply (auto intro!: set_eqI prod_eqI)
  done

lemma monad_eq_simp [monad_eq]:
  "((A :: ('s, 'a) nondet_monad) = B) =
      ((\<forall>r t s. (r, t) \<in> fst (A s) \<longrightarrow> (r, t) \<in> fst (B s))
         \<and> (\<forall>r t s. (r, t) \<in> fst (B s) \<longrightarrow> (r, t) \<in> fst (A s))
         \<and> (\<forall>x. snd (A x) = snd (B x)))"
  apply (auto intro!: set_eqI prod_eqI)
  done

declare in_monad [monad_eq]
declare in_bindE [monad_eq]

(* Test *)
lemma "returnOk 3 = liftE (return 3)"
  apply monad_eq
  oops

end


header "Invariants for Promela data structures"
theory PromelaInvariants
imports PromelaDatastructures
begin

text {*
  The different data structures used in the Promela implementation require different invariants,
  which are specified in this file. As there is no (useful) way of specifying \emph{correctness} of the implementation,
those invariants are tailored towards proving the finitness of the generated state-space.
*}

(*<*)
(*subsection {* Auxiliary lemmas *}*)
lemma foldli_set:
  "set (foldli list (\<lambda>_. True) op # xs) = set xs \<union> set list"
  by (induct list arbitrary: xs) simp_all

lemma foldli_conj:
  "foldli list id (\<lambda>kv \<sigma>. P kv) b \<longleftrightarrow> b \<and> (\<forall>x \<in> set list. P x)"
  by (induct list arbitrary: b) simp_all

(* Destroy the evil border of abstraction... *)
lemma lm_ball_Assoc_List_set:
  "lm.ball m P \<longleftrightarrow> (\<forall>x \<in> Assoc_List.set m. P x)"
  unfolding Assoc_List.set_def
  by (simp add: icf_rec_unf lm_basic.g_ball_def
    poly_map_iteratei_defs.iteratei_def it_to_it_def Assoc_List.iteratei_def
    foldli_conj)

lemma lm_to_list_Assoc_List_set:
  "set (lm.to_list l) = Assoc_List.set l"
  unfolding Assoc_List.set_def
  by (simp add: icf_rec_unf lm_basic.g_to_list_def
    poly_map_iteratei_defs.iteratei_def it_to_it_def Assoc_List.iteratei_def
    foldli_set)

lemma dom_lm_\<alpha>_Assoc_List_set:
  "dom (lm.\<alpha> v) = fst ` (Assoc_List.set v)"
  by (simp add: icf_rec_unf Assoc_List.lookup_def Assoc_List.set_def
    dom_map_of_conv_image_fst)

lemma ran_lm_\<alpha>_Assoc_List_set:
  "ran (lm.\<alpha> v) = snd ` (Assoc_List.set v)"
  by (simp add: icf_rec_unf Assoc_List.lookup_def Assoc_List.set_def
    ran_distinct)

lemma lm_ball_eq_ran:
  "lm.ball v (\<lambda>(k,v). P v) \<longleftrightarrow> ran (lm.\<alpha> v) \<subseteq> Collect P"
  by (auto simp add: ran_lm_\<alpha>_Assoc_List_set lm_ball_Assoc_List_set)

lemma lm_ball_lm_to_map_map_weaken:
  "\<forall>x \<in> f ` set xs. P x \<Longrightarrow> lm.ball (lm.to_map (map f xs)) P"
  by (induct xs) (simp_all add: lm.correct)

lemma Assoc_List_set_eq_lookup:
  "(k,v) \<in> Assoc_List.set vs \<longleftrightarrow> Assoc_List.lookup vs k = Some v"
  by (simp add: Assoc_List.lookup_def Assoc_List.set_def)

(*>*)

subsection {* Bounds *}

text {*
  Finiteness requires that possible variable ranges are finite, as is the maximium number of processes.
  Currently, they are supplied here as constants. In a perfect world, they should be able to be set dynamically.
*}

(* NB! Make sure those values coincide with the bounds definied in @{const ppVarType} *)
definition min_var_value :: "integer" where
  "min_var_value = -(2^31)"
definition max_var_value :: "integer" where
  "max_var_value = (2^31) - 1"

lemma min_max_var_value_simps [simp, intro!]:
  "min_var_value < max_var_value"
  "min_var_value < 0"
  "min_var_value \<le> 0"
  "max_var_value > 0"
  "max_var_value \<ge> 0"
by (simp_all add: min_var_value_def max_var_value_def)

definition "max_procs \<equiv> 255"
definition "max_channels \<equiv> 65535"
definition "max_array_size = 65535"

subsection {* Variables and similar *}

fun varType_inv :: "varType \<Rightarrow> bool" where
  "varType_inv (VTBounded l h)
  \<longleftrightarrow> l \<ge> min_var_value \<and> h \<le> max_var_value \<and> l < h"
| "varType_inv VTChan \<longleftrightarrow> True"

fun variable_inv :: "variable \<Rightarrow> bool" where
  "variable_inv (Var t val)
  \<longleftrightarrow> varType_inv t \<and> val \<in> {min_var_value..max_var_value}"
| "variable_inv (VArray t sz ar)
  \<longleftrightarrow> varType_inv t
    \<and> sz \<le> max_array_size
    \<and> IArray.length ar = sz
    \<and> set (IArray.list_of ar) \<subseteq> {min_var_value..max_var_value}"

fun channel_inv :: "channel \<Rightarrow> bool" where
  "channel_inv (Channel cap ts q)
  \<longleftrightarrow> cap \<le> max_array_size
    \<and> cap \<ge> 0
    \<and> set ts \<subseteq> Collect varType_inv
    \<and> length ts \<le> max_array_size
    \<and> length q \<le> max_array_size
    \<and> (\<forall>x \<in> set q. length x = length ts
    \<and> set x \<subseteq> {min_var_value..max_var_value})"
| "channel_inv (HSChannel ts)
  \<longleftrightarrow> set ts \<subseteq> Collect varType_inv \<and> length ts \<le> max_array_size"
| "channel_inv InvChannel \<longleftrightarrow> True"

lemma varTypes_finite:
  "finite (Collect varType_inv)"
proof (rule finite_subset)
  show "Collect (varType_inv) \<subseteq>
      {VTChan}
    \<union> (\<lambda>(l,h). VTBounded l h)
      ` ({min_var_value..max_var_value} \<times> {min_var_value..max_var_value})"
    apply (rule subsetI)
    apply (case_tac x)
      apply auto
    done

  show "finite ..." by auto
qed

lemma variables_finite:
  "finite (Collect variable_inv)"
proof (rule finite_subset)
  let ?mm = "{min_var_value..max_var_value}"
  let ?V1 = "(\<lambda>(t,val). Var t val) ` ({vt. varType_inv vt} \<times> ?mm)"
  let ?V2 = "(\<lambda>(t,sz,ar). VArray t sz ar)
    ` ({vt. varType_inv vt}
      \<times> {0..max_array_size}
      \<times> {ar. IArray.length ar \<le> max_array_size
           \<and> set (IArray.list_of ar) \<subseteq> ?mm})"

  {
    fix A :: "'a set"
    let ?LS = "{xs. set xs \<subseteq> A \<and> length xs \<le> max_array_size }"
    let ?AS = "{ar. IArray.length ar \<le> max_array_size
      \<and> set (IArray.list_of ar) \<subseteq> A}"

    assume "finite A"
    hence "finite ?LS" by (simp add: finite_lists_length_le)
    moreover have "?AS \<subseteq> IArray ` ?LS"
      apply (auto simp: image_def)
      apply (rule_tac x = "IArray.list_of x" in exI)
      apply auto
      apply (metis iarray.exhaust list_of.simps)
      done
    ultimately have "finite ?AS" by (auto simp add: finite_subset)
  } note finite_arr = this

  show "Collect variable_inv \<subseteq> (?V1 \<union> ?V2)"
    apply (rule subsetI)
    apply (case_tac x)
      apply (auto simp add: image_def)
    done

  show "finite ..." by (blast intro: varTypes_finite finite_arr)
qed

lemma channels_finite:
  "finite (Collect channel_inv)"
proof (rule finite_subset)
  let ?C1 =
    "(\<lambda>(cap,ts,q). Channel cap ts q)
     ` ({0..max_array_size}
      \<times> {ts. set ts \<subseteq> Collect varType_inv \<and> length ts \<le> max_array_size}
      \<times> {q. set q \<subseteq> {x. set x \<subseteq> {min_var_value..max_var_value}
                        \<and> length x \<le> max_array_size}
            \<and> length q \<le> max_array_size})"
  let ?C2 =
    "HSChannel ` {ts. set ts \<subseteq> Collect varType_inv \<and> length ts \<le> max_array_size}"
  let ?C3 = "{InvChannel}"

  show "(Collect channel_inv) \<subseteq> ?C1 \<union> ?C2 \<union> ?C3"
    apply (rule subsetI)
    apply (case_tac x)
      apply (auto simp add: image_def)
    done

  show "finite ..." by (blast intro: finite_lists_length_le varTypes_finite)+
qed

text {* To give an upper bound of variable names, we need a way to calculate it. *}

primrec procArgName :: "procArg \<Rightarrow> String.literal" where
  "procArgName (ProcArg _ name) = name"

primrec varDeclName :: "varDecl \<Rightarrow> String.literal" where
  "varDeclName (VarDeclNum _ _ name _ _) = name"
| "varDeclName (VarDeclChan name _ _) = name"

primrec procVarDeclName :: "procVarDecl \<Rightarrow> String.literal" where
  "procVarDeclName (ProcVarDeclNum _ _ name _ _) = name"
| "procVarDeclName (ProcVarDeclChan name _) = name"

definition edgeDecls :: "edge \<Rightarrow> procVarDecl set" where
  "edgeDecls e = (
     case effect e of
      EEDecl p \<Rightarrow> {p}
    |  _ \<Rightarrow> {})"

lemma edgeDecls_finite:
  "finite (edgeDecls e)"
by (simp add: edgeDecls_def split: edgeEffect.split)

definition edgeSet :: "states \<Rightarrow> edge set" where
  "edgeSet s = set (concat (map snd (IArray.list_of s)))"

lemma edgeSet_finite:
  "finite (edgeSet s)"
by (simp add: edgeSet_def)

definition statesDecls :: "states \<Rightarrow> procVarDecl set" where
  "statesDecls s = UNION (edgeSet s) edgeDecls"

definition statesNames :: "states \<Rightarrow> String.literal set" where
  "statesNames s = procVarDeclName ` statesDecls s"

lemma statesNames_finite:
  "finite (statesNames s)"
by (simp add: edgeSet_finite edgeDecls_finite statesNames_def statesDecls_def)

fun process_names :: "states \<Rightarrow> process \<Rightarrow> String.literal set" where
  "process_names ss (_, _, args, decls) =
      statesNames ss
    \<union> procArgName ` set args
    \<union> varDeclName ` set decls
    \<union> {STR ''_'', STR ''__assert__'', STR ''_pid''}" (* dunno if this is ok as a fixed set ... *)

lemma process_names_finite:
  "finite (process_names ss p)"
by (cases p) (simp add: statesNames_finite)

definition vardict_inv :: "states \<Rightarrow> process \<Rightarrow> var_dict \<Rightarrow> bool" where
  "vardict_inv ss p vs
   \<longleftrightarrow> lm.ball vs (\<lambda>(k,v). k \<in> process_names ss p \<and> variable_inv v)"

lemma vardicts_finite:
  "finite (Collect (vardict_inv ss p))"
proof -
  have "Assoc_List.set ` Collect (vardict_inv ss p) \<subseteq>
           Pow (process_names ss p \<times> {v. variable_inv v})"
    by (auto simp add: lm_ball_Assoc_List_set vardict_inv_def)

  moreover have "finite ..."
    using process_names_finite variables_finite
    by simp
  ultimately show ?thesis by (metis finite_Assoc_List_set_image finite_subset)
qed

lemma lm_to_map_vardict_inv:
  assumes "\<forall>(k,v) \<in> set xs. k \<in> process_names ss proc \<and> variable_inv v"
  shows "vardict_inv ss proc (lm.to_map xs)"
using assms
unfolding vardict_inv_def
by (auto simp add: lm.correct dest: map_of_is_SomeD)

subsection {* Invariants of a process *}

(* The definition of a channel to be between -1 and max_channels definitly lacks the necessary abstraction ... *)
definition pState_inv :: "program \<Rightarrow> pState \<Rightarrow> bool" where
  "pState_inv prog p
  \<longleftrightarrow> pid p \<le> max_procs
    \<and> pState.idx p < IArray.length (states prog)
    \<and> IArray.length (states prog) = IArray.length (processes prog)
    \<and> pc p < IArray.length ((states prog) !! pState.idx p)
    \<and> set (pState.channels p) \<subseteq> {-1..<integer_of_nat max_channels}
    \<and> length (pState.channels p) \<le> max_channels
    \<and> vardict_inv ((states prog) !! pState.idx p)
                  ((processes prog) !! pState.idx p)
                  (pState.vars p)"

lemma pStates_finite:
  "finite (Collect (pState_inv prog))"
proof -
  let ?P1 = "{..max_procs::nat}"
  let ?P2 = "{..IArray.length (states prog)}"
  let ?P3 = "{..Max (IArray.length ` (set (IArray.list_of (states prog))))}"
  let ?P4 = "{cs. set cs \<subseteq> {-1..<integer_of_nat max_channels}
                  \<and> length cs \<le> max_channels}"
  let ?P5 = "\<Union>x\<in>{..IArray.length (states prog)}.
                Collect (vardict_inv (states prog !! x) (processes prog !! x))"
  let ?P = "?P1 \<times> ?P2 \<times> ?P3 \<times> ?P4 \<times> ?P5"

  have "{p. pState_inv prog p} \<subseteq>
    (\<lambda>(pid,idx,pc,channels,vars). pState.make pid vars pc channels idx) ` ?P"
    unfolding pState_inv_def image_def
    apply (clarsimp simp add: pState.defs)
    apply (tactic {* Record.split_simp_tac @{context} [] (K ~1) 1*})
    apply (auto)
    apply (rule order_trans[OF less_imp_le])
      apply (auto intro!: Max_ge)
      done

  moreover
  have "finite ?P4" by (fastforce intro: finite_lists_length_le)
  hence "finite ?P" by (auto intro: finite_cartesian_product simp: vardicts_finite)

  ultimately show ?thesis by (elim finite_subset) (rule finite_imageI)
qed

text {*
  Throughout the calculation of the semantic engine, a modified process is not necessarily part of @{term "procs g"}.
  Hence we need to establish an additional constraint for the relation between a global and a process state.  *}

definition cl_inv :: "('a gState_scheme * pState) \<Rightarrow> bool" where
  "cl_inv gp = (case gp of (g,p) \<Rightarrow>
      length (pState.channels p) \<le> length (gState.channels g))"

lemma cl_inv_lengthD:
  "cl_inv (g,p) \<Longrightarrow> length (pState.channels p) \<le> length (gState.channels g)"
unfolding cl_inv_def
by auto

lemma cl_invI:
  "length (pState.channels p) \<le> length (gState.channels g) \<Longrightarrow> cl_inv (g,p)"
unfolding cl_inv_def by auto

lemma cl_inv_trans:
  "length (channels g) \<le> length (channels g') \<Longrightarrow> cl_inv (g,p) \<Longrightarrow> cl_inv (g',p)"
by (simp add: cl_inv_def)

lemma cl_inv_vars_update[intro!]:
  "cl_inv (g,p) \<Longrightarrow> cl_inv (g, pState.vars_update vs p)"
  "cl_inv (g,p) \<Longrightarrow> cl_inv (gState.vars_update vs g, p)"
by (simp_all add: cl_inv_def)

lemma cl_inv_handshake_update[intro!]:
  "cl_inv (g,p) \<Longrightarrow> cl_inv (g\<lparr>handshake := h\<rparr>,p)"
by (simp add: cl_inv_def)

lemma cl_inv_procs_update[intro!]:
  "cl_inv (g,p) \<Longrightarrow> cl_inv (g\<lparr>procs := ps\<rparr>,p)"
by (simp add: cl_inv_def)

lemma cl_inv_channels_update:
  assumes "cl_inv (g,p)"
  shows "cl_inv (gState.channels_update (\<lambda>cs. cs[i:=c]) g, p)"
using assms unfolding cl_inv_def
by simp

subsection {* Invariants of the global state *}

text {* Note that @{term gState_inv} must be defined in a way to be applicable to both @{typ gState} and @{typ gState\<^sub>I}. *}

definition gState_inv :: "program \<Rightarrow> 'a gState_scheme \<Rightarrow> bool" where
  "gState_inv prog g
  \<longleftrightarrow> length (procs g) \<le> max_procs
    \<and> (\<forall>p \<in> set (procs g). pState_inv prog p \<and> cl_inv (g,p))
    \<and> length (channels g) \<le> max_channels
    \<and> set (channels g) \<subseteq> Collect channel_inv
    \<and> lm.ball (vars g) (\<lambda>(k,v). variable_inv v)"

text {* The set of global states adhering to the terms of @{const gState_inv} is not finite.
But the set of all global states that can be constructed by the semantic engine from one starting state is.
Thus we establish a progress relation, \ie all successors of a state @{term g} relate to @{term g} under this specification. *}

definition gState_progress_rel :: "program \<Rightarrow> ('a gState_scheme) rel" where
  "gState_progress_rel p = {(g,g'). gState_inv p g \<and> gState_inv p g'
                                  \<and> length (channels g) \<le> length (channels g')
                                  \<and> dom (lm.\<alpha> (vars g)) = dom (lm.\<alpha> (vars g'))}"

lemma gState_progress_rel_gState_invI1[intro]:
  "(g,g') \<in> gState_progress_rel prog \<Longrightarrow> gState_inv prog g"
by (simp add: gState_progress_rel_def)

lemma gState_progress_rel_gState_invI2[intro]:
  "(g,g') \<in> gState_progress_rel prog \<Longrightarrow> gState_inv prog g'"
by (simp add: gState_progress_rel_def)

lemma gState_progress_relI:
  assumes "gState_inv prog g"
  and "gState_inv prog g'"
  and "length (channels g) \<le> length (channels g')"
  and "dom (lm.\<alpha> (vars g)) = dom (lm.\<alpha> (vars g'))"
  shows "(g,g') \<in> gState_progress_rel prog"
unfolding gState_progress_rel_def
using assms
by auto

lemma gState_progress_refl[simp,intro!]:
  "gState_inv prog g \<Longrightarrow> (g,g) \<in> (gState_progress_rel prog)"
unfolding gState_progress_rel_def
by auto

lemma refl_on_gState_progress_rel:
  "refl_on (Collect (gState_inv prog)) (gState_progress_rel prog)"
by (auto intro!: refl_onI)

lemma trans_gState_progress_rel[simp]:
  "trans (gState_progress_rel prog)"
by (intro transI) (simp add: gState_progress_rel_def)

lemmas gState_progress_rel_trans [trans] = trans_gState_progress_rel[THEN transD]

lemma gState_progress_rel_trancl_id[simp]:
  "(gState_progress_rel prog)\<^sup>+ = gState_progress_rel prog"
by simp

lemma gState_progress_rel_rtrancl_absorb:
  assumes "gState_inv prog g"
  shows "(gState_progress_rel prog)\<^sup>* `` {g} = gState_progress_rel prog `` {g}"
using assms refl_on_gState_progress_rel
by (intro Image_absorb_rtrancl) auto

text {*
  The main theorem: The set of all global states reachable from an initial state, is finite.
*}
lemma gStates_finite:
  fixes g :: "gState"
  shows "finite ((gState_progress_rel prog)\<^sup>* `` {g})"
proof (cases "gState_inv prog g")
  case False hence "(gState_progress_rel prog)\<^sup>* `` {g} = {g}"
    by (intro Image_empty_rtrancl_Image_id)
       (auto simp add: gState_progress_rel_def)
  thus ?thesis by simp
next
  case True
  let ?G1 = "{m. dom (lm.\<alpha> m) = dom (lm.\<alpha> (vars g))
                 \<and> ran (lm.\<alpha> m) \<subseteq> Collect variable_inv }"
  let ?G2 = "{cs. set cs \<subseteq> Collect channel_inv
                  \<and> length cs \<le> max_channels}"
  let ?G3 = "{True, False}"
  let ?G4 = "{ps. set ps \<subseteq> Collect (pState_inv prog)
                  \<and> length ps \<le> max_procs}"

  let ?G = "?G1 \<times> ?G2 \<times> ?G3 \<times> ?G4"
  let ?G' = "(\<lambda>(vars,chans,t,ps). gState.make vars chans t ps) ` ?G"

  have G1: "finite ?G1"
  proof (rule finite_subset)
    show "?G1 \<subseteq> {v'. fst ` Assoc_List.set v' = fst ` Assoc_List.set (vars g)
                     \<and> snd ` Assoc_List.set v' \<subseteq> Collect variable_inv}"
      by (simp add: dom_lm_\<alpha>_Assoc_List_set ran_lm_\<alpha>_Assoc_List_set)
    show "finite ..." (is "finite ?X")
    proof (rule finite_Assoc_List_set_image, rule finite_subset)
      show "Assoc_List.set ` ?X \<subseteq>
             Pow (fst ` Assoc_List.set (vars g) \<times> Collect variable_inv)"
        by auto
      show "finite ..." by (auto simp add: variables_finite dom_lm_\<alpha>_Assoc_List_set[symmetric])
    qed
  qed

  have "finite ((gState_progress_rel prog) `` {g})"
  proof (rule finite_subset)
    show "(gState_progress_rel prog) `` {g} \<subseteq>
           (\<lambda>(vars,chans,t,ps). gState.make vars chans t ps) ` ?G"
      apply (clarsimp simp add: image_def gState_inv_def gState.defs gState_progress_rel_def)
      apply (rule_tac x = "vars x" in exI)
      apply (simp add: lm_ball_eq_ran)
      apply (rule_tac x = "channels x" in exI)
      apply (case_tac "timeout x")
        apply clarsimp
        apply (rule_tac x="procs x" in exI)
        apply auto
      done
    show "finite ..." using G1
      by (blast intro: finite_lists_length_le channels_finite pStates_finite)
  qed
  with gState_progress_rel_rtrancl_absorb[OF True] show ?thesis by simp
qed

lemma gState_progress_rel_channels_update:
  assumes "gState_inv prog g"
  and "channel_inv c"
  and "i < length (channels g)"
  shows "(g,gState.channels_update (\<lambda>cs. cs[i:=c]) g) \<in> gState_progress_rel prog"
using assms
by (auto intro!: gState_progress_relI
         simp add: gState_inv_def cl_inv_def
         dest!: subsetD[OF set_update_subset_insert])

lemma gState_progress_rel_channels_update_step:
  assumes "gState_inv prog g"
  and step: "(g,g') \<in> gState_progress_rel prog"
  and "channel_inv c"
  and "i < length (channels g')"
  shows "(g,gState.channels_update (\<lambda>cs. cs[i:=c]) g') \<in> gState_progress_rel prog"
proof -
  note step
  also hence "gState_inv prog g'" by blast
  note gState_progress_rel_channels_update[OF this assms(3,4)]
  finally show ?thesis .
qed

subsection {* Invariants of the program *}

text {*
  Naturally, we need our program to also adhere to certain invariants. Else we can't show, that
  the generated states are correct according to the invariants above.
*}

definition program_inv where
  "program_inv prog
  \<longleftrightarrow> IArray.length (states prog) > 0
    \<and> IArray.length (states prog) = IArray.length (processes prog)
    \<and> (\<forall>s \<in> set (IArray.list_of (states prog)). IArray.length s > 0)
    \<and> lm.ball (proc_data prog)
              (\<lambda>(_,sidx).
                    sidx < IArray.length (processes prog)
                  \<and> fst (processes prog !! sidx) = sidx)
    \<and> (\<forall>(sidx,start,procArgs,args) \<in> set (IArray.list_of (processes prog)).
        (\<exists>s. start = Index s \<and> s < IArray.length (states prog !! sidx)))"

lemma program_inv_length_states:
  assumes "program_inv prog"
  and "n < IArray.length (states prog)"
  shows "IArray.length (states prog !! n) > 0"
using assms by (simp add: program_inv_def)

lemma program_invI:
  assumes "0 < IArray.length (states prog)"
  and "IArray.length (states prog) = IArray.length (processes prog)"
  and "\<And>s. s \<in> set (IArray.list_of (states prog))
           \<Longrightarrow> 0 < IArray.length s"
  and "\<And>sidx. sidx \<in> ran (lm.\<alpha> (proc_data prog))
               \<Longrightarrow> sidx < IArray.length (processes prog)
                  \<and> fst (processes prog !! sidx) = sidx"
  and "\<And>sidx start procArgs args.
         (sidx,start,procArgs,args) \<in> set (IArray.list_of (processes prog))
         \<Longrightarrow> \<exists>s. start = Index s \<and> s < IArray.length (states prog !! sidx)"
  shows "program_inv prog"
unfolding program_inv_def
using assms
by (auto simp add: lm_ball_eq_ran)

end