(*  Title:      ZF/UNITY/UNITY.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section \<open>The Basic UNITY Theory\<close>

theory UNITY imports State begin

text\<open>The basic UNITY theory (revised version, based upon the "co" operator)
From Misra, "A Logic for Concurrent Programming", 1994.

This ZF theory was ported from its HOL equivalent.\<close>

definition
  program  :: i  where
  "program \<equiv> {<init, acts, allowed>:
               Pow(state) * Pow(Pow(state*state)) * Pow(Pow(state*state)).
               id(state) \<in> acts \<and> id(state) \<in> allowed}"

definition
  mk_program :: "[i,i,i]\<Rightarrow>i"  where
  \<comment> \<open>The definition yields a program thanks to the coercions
       init \<inter> state, acts \<inter> Pow(state*state), etc.\<close>
  "mk_program(init, acts, allowed) \<equiv>
    <init \<inter> state, cons(id(state), acts \<inter> Pow(state*state)),
              cons(id(state), allowed \<inter> Pow(state*state))>"

definition
  SKIP :: i  (\<open>\<bottom>\<close>) where
  "SKIP \<equiv> mk_program(state, 0, Pow(state*state))"

  (* Coercion from anything to program *)
definition
  programify :: "i\<Rightarrow>i"  where
  "programify(F) \<equiv> if F \<in> program then F else SKIP"

definition
  RawInit :: "i\<Rightarrow>i"  where
  "RawInit(F) \<equiv> fst(F)"

definition
  Init :: "i\<Rightarrow>i"  where
  "Init(F) \<equiv> RawInit(programify(F))"

definition
  RawActs :: "i\<Rightarrow>i"  where
  "RawActs(F) \<equiv> cons(id(state), fst(snd(F)))"

definition
  Acts :: "i\<Rightarrow>i"  where
  "Acts(F) \<equiv> RawActs(programify(F))"

definition
  RawAllowedActs :: "i\<Rightarrow>i"  where
  "RawAllowedActs(F) \<equiv> cons(id(state), snd(snd(F)))"

definition
  AllowedActs :: "i\<Rightarrow>i"  where
  "AllowedActs(F) \<equiv> RawAllowedActs(programify(F))"

definition
  Allowed :: "i \<Rightarrow>i"  where
  "Allowed(F) \<equiv> {G \<in> program. Acts(G) \<subseteq> AllowedActs(F)}"

definition
  initially :: "i\<Rightarrow>i"  where
  "initially(A) \<equiv> {F \<in> program. Init(F)\<subseteq>A}"

definition "constrains" :: "[i, i] \<Rightarrow> i"  (infixl \<open>co\<close> 60)  where
  "A co B \<equiv> {F \<in> program. (\<forall>act \<in> Acts(F). act``A\<subseteq>B) \<and> st_set(A)}"
    \<comment> \<open>the condition \<^term>\<open>st_set(A)\<close> makes the definition slightly
         stronger than the HOL one\<close>

definition unless :: "[i, i] \<Rightarrow> i"  (infixl \<open>unless\<close> 60)  where
  "A unless B \<equiv> (A - B) co (A \<union> B)"

definition
  stable     :: "i\<Rightarrow>i"  where
   "stable(A) \<equiv> A co A"

definition
  strongest_rhs :: "[i, i] \<Rightarrow> i"  where
  "strongest_rhs(F, A) \<equiv> \<Inter>({B \<in> Pow(state). F \<in> A co B})"

definition
  invariant :: "i \<Rightarrow> i"  where
  "invariant(A) \<equiv> initially(A) \<inter> stable(A)"

  (* meta-function composition *)
definition
  metacomp :: "[i\<Rightarrow>i, i\<Rightarrow>i] \<Rightarrow> (i\<Rightarrow>i)" (infixl \<open>comp\<close> 65)  where
  "f comp g \<equiv> \<lambda>x. f(g(x))"

definition
  pg_compl :: "i\<Rightarrow>i"  where
  "pg_compl(X)\<equiv> program - X"

text\<open>SKIP\<close>
lemma SKIP_in_program [iff,TC]: "SKIP \<in> program"
by (force simp add: SKIP_def program_def mk_program_def)

subsection\<open>The function \<^term>\<open>programify\<close>, the coercion from anything to
 program\<close>

lemma programify_program [simp]: "F \<in> program \<Longrightarrow> programify(F)=F"
by (force simp add: programify_def)

lemma programify_in_program [iff,TC]: "programify(F) \<in> program"
by (force simp add: programify_def)

text\<open>Collapsing rules: to remove programify from expressions\<close>
lemma programify_idem [simp]: "programify(programify(F))=programify(F)"
by (force simp add: programify_def)

lemma Init_programify [simp]: "Init(programify(F)) = Init(F)"
by (simp add: Init_def)

lemma Acts_programify [simp]: "Acts(programify(F)) = Acts(F)"
by (simp add: Acts_def)

lemma AllowedActs_programify [simp]:
     "AllowedActs(programify(F)) = AllowedActs(F)"
by (simp add: AllowedActs_def)

subsection\<open>The Inspectors for Programs\<close>

lemma id_in_RawActs: "F \<in> program \<Longrightarrow>id(state) \<in> RawActs(F)"
by (auto simp add: program_def RawActs_def)

lemma id_in_Acts [iff,TC]: "id(state) \<in> Acts(F)"
by (simp add: id_in_RawActs Acts_def)

lemma id_in_RawAllowedActs: "F \<in> program \<Longrightarrow>id(state) \<in> RawAllowedActs(F)"
by (auto simp add: program_def RawAllowedActs_def)

lemma id_in_AllowedActs [iff,TC]: "id(state) \<in> AllowedActs(F)"
by (simp add: id_in_RawAllowedActs AllowedActs_def)

lemma cons_id_Acts [simp]: "cons(id(state), Acts(F)) = Acts(F)"
by (simp add: cons_absorb)

lemma cons_id_AllowedActs [simp]:
     "cons(id(state), AllowedActs(F)) = AllowedActs(F)"
by (simp add: cons_absorb)

subsection\<open>Types of the Inspectors\<close>

lemma RawInit_type: "F \<in> program \<Longrightarrow> RawInit(F)\<subseteq>state"
by (auto simp add: program_def RawInit_def)

lemma RawActs_type: "F \<in> program \<Longrightarrow> RawActs(F)\<subseteq>Pow(state*state)"
by (auto simp add: program_def RawActs_def)

lemma RawAllowedActs_type:
     "F \<in> program \<Longrightarrow> RawAllowedActs(F)\<subseteq>Pow(state*state)"
by (auto simp add: program_def RawAllowedActs_def)

lemma Init_type: "Init(F)\<subseteq>state"
by (simp add: RawInit_type Init_def)

lemmas InitD = Init_type [THEN subsetD]

lemma st_set_Init [iff]: "st_set(Init(F))"
  unfolding st_set_def
apply (rule Init_type)
done

lemma Acts_type: "Acts(F)\<subseteq>Pow(state*state)"
by (simp add: RawActs_type Acts_def)

lemma AllowedActs_type: "AllowedActs(F) \<subseteq> Pow(state*state)"
by (simp add: RawAllowedActs_type AllowedActs_def)

text\<open>Needed in Behaviors\<close>
lemma ActsD: "\<lbrakk>act \<in> Acts(F); <s,s'> \<in> act\<rbrakk> \<Longrightarrow> s \<in> state \<and> s' \<in> state"
by (blast dest: Acts_type [THEN subsetD])

lemma AllowedActsD:
     "\<lbrakk>act \<in> AllowedActs(F); <s,s'> \<in> act\<rbrakk> \<Longrightarrow> s \<in> state \<and> s' \<in> state"
by (blast dest: AllowedActs_type [THEN subsetD])

subsection\<open>Simplification rules involving \<^term>\<open>state\<close>, \<^term>\<open>Init\<close>,
  \<^term>\<open>Acts\<close>, and \<^term>\<open>AllowedActs\<close>\<close>

text\<open>But are they really needed?\<close>

lemma state_subset_is_Init_iff [iff]: "state \<subseteq> Init(F) \<longleftrightarrow> Init(F)=state"
by (cut_tac F = F in Init_type, auto)

lemma Pow_state_times_state_is_subset_Acts_iff [iff]:
     "Pow(state*state) \<subseteq> Acts(F) \<longleftrightarrow> Acts(F)=Pow(state*state)"
by (cut_tac F = F in Acts_type, auto)

lemma Pow_state_times_state_is_subset_AllowedActs_iff [iff]:
     "Pow(state*state) \<subseteq> AllowedActs(F) \<longleftrightarrow> AllowedActs(F)=Pow(state*state)"
by (cut_tac F = F in AllowedActs_type, auto)

subsubsection\<open>Eliminating \<open>\<inter> state\<close> from expressions\<close>

lemma Init_Int_state [simp]: "Init(F) \<inter> state = Init(F)"
by (cut_tac F = F in Init_type, blast)

lemma state_Int_Init [simp]: "state \<inter> Init(F) = Init(F)"
by (cut_tac F = F in Init_type, blast)

lemma Acts_Int_Pow_state_times_state [simp]:
     "Acts(F) \<inter> Pow(state*state) = Acts(F)"
by (cut_tac F = F in Acts_type, blast)

lemma state_times_state_Int_Acts [simp]:
     "Pow(state*state) \<inter> Acts(F) = Acts(F)"
by (cut_tac F = F in Acts_type, blast)

lemma AllowedActs_Int_Pow_state_times_state [simp]:
     "AllowedActs(F) \<inter> Pow(state*state) = AllowedActs(F)"
by (cut_tac F = F in AllowedActs_type, blast)

lemma state_times_state_Int_AllowedActs [simp]:
     "Pow(state*state) \<inter> AllowedActs(F) = AllowedActs(F)"
by (cut_tac F = F in AllowedActs_type, blast)

subsubsection\<open>The Operator \<^term>\<open>mk_program\<close>\<close>

lemma mk_program_in_program [iff,TC]:
     "mk_program(init, acts, allowed) \<in> program"
by (auto simp add: mk_program_def program_def)

lemma RawInit_eq [simp]:
     "RawInit(mk_program(init, acts, allowed)) = init \<inter> state"
by (auto simp add: mk_program_def RawInit_def)

lemma RawActs_eq [simp]:
     "RawActs(mk_program(init, acts, allowed)) =
      cons(id(state), acts \<inter> Pow(state*state))"
by (auto simp add: mk_program_def RawActs_def)

lemma RawAllowedActs_eq [simp]:
     "RawAllowedActs(mk_program(init, acts, allowed)) =
      cons(id(state), allowed \<inter> Pow(state*state))"
by (auto simp add: mk_program_def RawAllowedActs_def)

lemma Init_eq [simp]: "Init(mk_program(init, acts, allowed)) = init \<inter> state"
by (simp add: Init_def)

lemma Acts_eq [simp]:
     "Acts(mk_program(init, acts, allowed)) =
      cons(id(state), acts  \<inter> Pow(state*state))"
by (simp add: Acts_def)

lemma AllowedActs_eq [simp]:
     "AllowedActs(mk_program(init, acts, allowed))=
      cons(id(state), allowed \<inter> Pow(state*state))"
by (simp add: AllowedActs_def)

text\<open>Init, Acts, and AlowedActs  of SKIP\<close>

lemma RawInit_SKIP [simp]: "RawInit(SKIP) = state"
by (simp add: SKIP_def)

lemma RawAllowedActs_SKIP [simp]: "RawAllowedActs(SKIP) = Pow(state*state)"
by (force simp add: SKIP_def)

lemma RawActs_SKIP [simp]: "RawActs(SKIP) = {id(state)}"
by (force simp add: SKIP_def)

lemma Init_SKIP [simp]: "Init(SKIP) = state"
by (force simp add: SKIP_def)

lemma Acts_SKIP [simp]: "Acts(SKIP) = {id(state)}"
by (force simp add: SKIP_def)

lemma AllowedActs_SKIP [simp]: "AllowedActs(SKIP) = Pow(state*state)"
by (force simp add: SKIP_def)

text\<open>Equality of UNITY programs\<close>

lemma raw_surjective_mk_program:
     "F \<in> program \<Longrightarrow> mk_program(RawInit(F), RawActs(F), RawAllowedActs(F))=F"
apply (auto simp add: program_def mk_program_def RawInit_def RawActs_def
            RawAllowedActs_def, blast+)
done

lemma surjective_mk_program [simp]:
  "mk_program(Init(F), Acts(F), AllowedActs(F)) = programify(F)"
by (auto simp add: raw_surjective_mk_program Init_def Acts_def AllowedActs_def)

lemma program_equalityI:
    "\<lbrakk>Init(F) = Init(G); Acts(F) = Acts(G);
       AllowedActs(F) = AllowedActs(G); F \<in> program; G \<in> program\<rbrakk> \<Longrightarrow> F = G"
apply (subgoal_tac "programify(F) = programify(G)")
apply simp
apply (simp only: surjective_mk_program [symmetric])
done

lemma program_equalityE:
 "\<lbrakk>F = G;
    \<lbrakk>Init(F) = Init(G); Acts(F) = Acts(G); AllowedActs(F) = AllowedActs(G)\<rbrakk>
    \<Longrightarrow> P\<rbrakk>
  \<Longrightarrow> P"
by force

lemma program_equality_iff:
    "\<lbrakk>F \<in> program; G \<in> program\<rbrakk> \<Longrightarrow>(F=G)  \<longleftrightarrow>
     (Init(F) = Init(G) \<and> Acts(F) = Acts(G) \<and> AllowedActs(F) = AllowedActs(G))"
by (blast intro: program_equalityI program_equalityE)

subsection\<open>These rules allow "lazy" definition expansion\<close>

lemma def_prg_Init:
     "F \<equiv> mk_program (init,acts,allowed) \<Longrightarrow> Init(F) = init \<inter> state"
by auto

lemma def_prg_Acts:
     "F \<equiv> mk_program (init,acts,allowed)
      \<Longrightarrow> Acts(F) = cons(id(state), acts \<inter> Pow(state*state))"
by auto

lemma def_prg_AllowedActs:
     "F \<equiv> mk_program (init,acts,allowed)
      \<Longrightarrow> AllowedActs(F) = cons(id(state), allowed \<inter> Pow(state*state))"
by auto

lemma def_prg_simps:
    "\<lbrakk>F \<equiv> mk_program (init,acts,allowed)\<rbrakk>
     \<Longrightarrow> Init(F) = init \<inter> state \<and>
         Acts(F) = cons(id(state), acts \<inter> Pow(state*state)) \<and>
         AllowedActs(F) = cons(id(state), allowed \<inter> Pow(state*state))"
by auto

text\<open>An action is expanded only if a pair of states is being tested against it\<close>
lemma def_act_simp:
     "\<lbrakk>act \<equiv> {<s,s'> \<in> A*B. P(s, s')}\<rbrakk>
      \<Longrightarrow> (<s,s'> \<in> act) \<longleftrightarrow> (<s,s'> \<in> A*B \<and> P(s, s'))"
by auto

text\<open>A set is expanded only if an element is being tested against it\<close>
lemma def_set_simp: "A \<equiv> B \<Longrightarrow> (x \<in> A) \<longleftrightarrow> (x \<in> B)"
by auto

subsection\<open>The Constrains Operator\<close>

lemma constrains_type: "A co B \<subseteq> program"
by (force simp add: constrains_def)

lemma constrainsI:
    "\<lbrakk>(\<And>act s s'. \<lbrakk>act: Acts(F);  <s,s'> \<in> act; s \<in> A\<rbrakk> \<Longrightarrow> s' \<in> A');
        F \<in> program; st_set(A)\<rbrakk>  \<Longrightarrow> F \<in> A co A'"
by (force simp add: constrains_def)

lemma constrainsD:
   "F \<in> A co B \<Longrightarrow> \<forall>act \<in> Acts(F). act``A\<subseteq>B"
by (force simp add: constrains_def)

lemma constrainsD2: "F \<in> A co B \<Longrightarrow> F \<in> program \<and> st_set(A)"
by (force simp add: constrains_def)

lemma constrains_empty [iff]: "F \<in> 0 co B \<longleftrightarrow> F \<in> program"
by (force simp add: constrains_def st_set_def)

lemma constrains_empty2 [iff]: "(F \<in> A co 0) \<longleftrightarrow> (A=0 \<and> F \<in> program)"
by (force simp add: constrains_def st_set_def)

lemma constrains_state [iff]: "(F \<in> state co B) \<longleftrightarrow> (state\<subseteq>B \<and> F \<in> program)"
apply (cut_tac F = F in Acts_type)
apply (force simp add: constrains_def st_set_def)
done

lemma constrains_state2 [iff]: "F \<in> A co state \<longleftrightarrow> (F \<in> program \<and> st_set(A))"
apply (cut_tac F = F in Acts_type)
apply (force simp add: constrains_def st_set_def)
done

text\<open>monotonic in 2nd argument\<close>
lemma constrains_weaken_R:
    "\<lbrakk>F \<in> A co A'; A'\<subseteq>B'\<rbrakk> \<Longrightarrow> F \<in> A co B'"
apply (unfold constrains_def, blast)
done

text\<open>anti-monotonic in 1st argument\<close>
lemma constrains_weaken_L:
    "\<lbrakk>F \<in> A co A'; B\<subseteq>A\<rbrakk> \<Longrightarrow> F \<in> B co A'"
apply (unfold constrains_def st_set_def, blast)
done

lemma constrains_weaken:
   "\<lbrakk>F \<in> A co A'; B\<subseteq>A; A'\<subseteq>B'\<rbrakk> \<Longrightarrow> F \<in> B co B'"
apply (drule constrains_weaken_R)
apply (drule_tac [2] constrains_weaken_L, blast+)
done

subsection\<open>Constrains and Union\<close>

lemma constrains_Un:
    "\<lbrakk>F \<in> A co A'; F \<in> B co B'\<rbrakk> \<Longrightarrow> F \<in> (A \<union> B) co (A' \<union> B')"
by (auto simp add: constrains_def st_set_def, force)

lemma constrains_UN:
     "\<lbrakk>\<And>i. i \<in> I \<Longrightarrow> F \<in> A(i) co A'(i); F \<in> program\<rbrakk>
      \<Longrightarrow> F \<in> (\<Union>i \<in> I. A(i)) co (\<Union>i \<in> I. A'(i))"
by (force simp add: constrains_def st_set_def)

lemma constrains_Un_distrib:
     "(A \<union> B) co C = (A co C) \<inter> (B co C)"
by (force simp add: constrains_def st_set_def)

lemma constrains_UN_distrib:
   "i \<in> I \<Longrightarrow> (\<Union>i \<in> I. A(i)) co B = (\<Inter>i \<in> I. A(i) co B)"
by (force simp add: constrains_def st_set_def)

subsection\<open>Constrains and Intersection\<close>

lemma constrains_Int_distrib: "C co (A \<inter> B) = (C co A) \<inter> (C co B)"
by (force simp add: constrains_def st_set_def)

lemma constrains_INT_distrib:
     "x \<in> I \<Longrightarrow> A co (\<Inter>i \<in> I. B(i)) = (\<Inter>i \<in> I. A co B(i))"
by (force simp add: constrains_def st_set_def)

lemma constrains_Int:
    "\<lbrakk>F \<in> A co A'; F \<in> B co B'\<rbrakk> \<Longrightarrow> F \<in> (A \<inter> B) co (A' \<inter> B')"
by (force simp add: constrains_def st_set_def)

lemma constrains_INT [rule_format]:
     "\<lbrakk>\<forall>i \<in> I. F \<in> A(i) co A'(i); F \<in> program\<rbrakk>
      \<Longrightarrow> F \<in> (\<Inter>i \<in> I. A(i)) co (\<Inter>i \<in> I. A'(i))"
apply (case_tac "I=0")
 apply (simp add: Inter_def)
apply (erule not_emptyE)
apply (auto simp add: constrains_def st_set_def, blast)
apply (drule bspec, assumption, force)
done

(* The rule below simulates the HOL's one for (\<Inter>z. A i) co (\<Inter>z. B i) *)
lemma constrains_All:
"\<lbrakk>\<forall>z. F:{s \<in> state. P(s, z)} co {s \<in> state. Q(s, z)}; F \<in> program\<rbrakk>\<Longrightarrow>
    F:{s \<in> state. \<forall>z. P(s, z)} co {s \<in> state. \<forall>z. Q(s, z)}"
by (unfold constrains_def, blast)

lemma constrains_imp_subset:
  "\<lbrakk>F \<in> A co A'\<rbrakk> \<Longrightarrow> A \<subseteq> A'"
by (unfold constrains_def st_set_def, force)

text\<open>The reasoning is by subsets since "co" refers to single actions
  only.  So this rule isn't that useful.\<close>

lemma constrains_trans: "\<lbrakk>F \<in> A co B; F \<in> B co C\<rbrakk> \<Longrightarrow> F \<in> A co C"
by (unfold constrains_def st_set_def, auto, blast)

lemma constrains_cancel:
"\<lbrakk>F \<in> A co (A' \<union> B); F \<in> B co B'\<rbrakk> \<Longrightarrow> F \<in> A co (A' \<union> B')"
apply (drule_tac A = B in constrains_imp_subset)
apply (blast intro: constrains_weaken_R)
done

subsection\<open>The Unless Operator\<close>

lemma unless_type: "A unless B \<subseteq> program"
by (force simp add: unless_def constrains_def)

lemma unlessI: "\<lbrakk>F \<in> (A-B) co (A \<union> B)\<rbrakk> \<Longrightarrow> F \<in> A unless B"
  unfolding unless_def
apply (blast dest: constrainsD2)
done

lemma unlessD: "F :A unless B \<Longrightarrow> F \<in> (A-B) co (A \<union> B)"
by (unfold unless_def, auto)

subsection\<open>The Operator \<^term>\<open>initially\<close>\<close>

lemma initially_type: "initially(A) \<subseteq> program"
by (unfold initially_def, blast)

lemma initiallyI: "\<lbrakk>F \<in> program; Init(F)\<subseteq>A\<rbrakk> \<Longrightarrow> F \<in> initially(A)"
by (unfold initially_def, blast)

lemma initiallyD: "F \<in> initially(A) \<Longrightarrow> Init(F)\<subseteq>A"
by (unfold initially_def, blast)

subsection\<open>The Operator \<^term>\<open>stable\<close>\<close>

lemma stable_type: "stable(A)\<subseteq>program"
by (unfold stable_def constrains_def, blast)

lemma stableI: "F \<in> A co A \<Longrightarrow> F \<in> stable(A)"
by (unfold stable_def, assumption)

lemma stableD: "F \<in> stable(A) \<Longrightarrow> F \<in> A co A"
by (unfold stable_def, assumption)

lemma stableD2: "F \<in> stable(A) \<Longrightarrow> F \<in> program \<and> st_set(A)"
by (unfold stable_def constrains_def, auto)

lemma stable_state [simp]: "stable(state) = program"
by (auto simp add: stable_def constrains_def dest: Acts_type [THEN subsetD])

lemma stable_unless: "stable(A)= A unless 0"
by (auto simp add: unless_def stable_def)

subsection\<open>Union and Intersection with \<^term>\<open>stable\<close>\<close>

lemma stable_Un:
    "\<lbrakk>F \<in> stable(A); F \<in> stable(A')\<rbrakk> \<Longrightarrow> F \<in> stable(A \<union> A')"
  unfolding stable_def
apply (blast intro: constrains_Un)
done

lemma stable_UN:
     "\<lbrakk>\<And>i. i\<in>I \<Longrightarrow> F \<in> stable(A(i)); F \<in> program\<rbrakk>
      \<Longrightarrow> F \<in> stable (\<Union>i \<in> I. A(i))"
  unfolding stable_def
apply (blast intro: constrains_UN)
done

lemma stable_Int:
    "\<lbrakk>F \<in> stable(A);  F \<in> stable(A')\<rbrakk> \<Longrightarrow> F \<in> stable (A \<inter> A')"
  unfolding stable_def
apply (blast intro: constrains_Int)
done

lemma stable_INT:
     "\<lbrakk>\<And>i. i \<in> I \<Longrightarrow> F \<in> stable(A(i)); F \<in> program\<rbrakk>
      \<Longrightarrow> F \<in> stable (\<Inter>i \<in> I. A(i))"
  unfolding stable_def
apply (blast intro: constrains_INT)
done

lemma stable_All:
    "\<lbrakk>\<forall>z. F \<in> stable({s \<in> state. P(s, z)}); F \<in> program\<rbrakk>
     \<Longrightarrow> F \<in> stable({s \<in> state. \<forall>z. P(s, z)})"
  unfolding stable_def
apply (rule constrains_All, auto)
done

lemma stable_constrains_Un:
     "\<lbrakk>F \<in> stable(C); F \<in> A co (C \<union> A')\<rbrakk> \<Longrightarrow> F \<in> (C \<union> A) co (C \<union> A')"
apply (unfold stable_def constrains_def st_set_def, auto)
apply (blast dest!: bspec)
done

lemma stable_constrains_Int:
     "\<lbrakk>F \<in> stable(C); F \<in>  (C \<inter> A) co A'\<rbrakk> \<Longrightarrow> F \<in> (C \<inter> A) co (C \<inter> A')"
by (unfold stable_def constrains_def st_set_def, blast)

(* \<lbrakk>F \<in> stable(C); F  \<in> (C \<inter> A) co A\<rbrakk> \<Longrightarrow> F \<in> stable(C \<inter> A) *)
lemmas stable_constrains_stable = stable_constrains_Int [THEN stableI]

subsection\<open>The Operator \<^term>\<open>invariant\<close>\<close>

lemma invariant_type: "invariant(A) \<subseteq> program"
  unfolding invariant_def
apply (blast dest: stable_type [THEN subsetD])
done

lemma invariantI: "\<lbrakk>Init(F)\<subseteq>A;  F \<in> stable(A)\<rbrakk> \<Longrightarrow> F \<in> invariant(A)"
  unfolding invariant_def initially_def
apply (frule stable_type [THEN subsetD], auto)
done

lemma invariantD: "F \<in> invariant(A) \<Longrightarrow> Init(F)\<subseteq>A \<and> F \<in> stable(A)"
by (unfold invariant_def initially_def, auto)

lemma invariantD2: "F \<in> invariant(A) \<Longrightarrow> F \<in> program \<and> st_set(A)"
  unfolding invariant_def
apply (blast dest: stableD2)
done

text\<open>Could also say
      \<^term>\<open>invariant(A) \<inter> invariant(B) \<subseteq> invariant (A \<inter> B)\<close>\<close>
lemma invariant_Int:
  "\<lbrakk>F \<in> invariant(A);  F \<in> invariant(B)\<rbrakk> \<Longrightarrow> F \<in> invariant(A \<inter> B)"
  unfolding invariant_def initially_def
apply (simp add: stable_Int, blast)
done

subsection\<open>The Elimination Theorem\<close>

(** The "free" m has become universally quantified!
 Should the premise be \<And>m instead of \<forall>m ? Would make it harder
 to use in forward proof. **)

text\<open>The general case is easier to prove than the special case!\<close>
lemma "elimination":
    "\<lbrakk>\<forall>m \<in> M. F \<in> {s \<in> A. x(s) = m} co B(m); F \<in> program\<rbrakk>
     \<Longrightarrow> F \<in> {s \<in> A. x(s) \<in> M} co (\<Union>m \<in> M. B(m))"
by (auto simp add: constrains_def st_set_def, blast)

text\<open>As above, but for the special case of A=state\<close>
lemma elimination2:
     "\<lbrakk>\<forall>m \<in> M. F \<in> {s \<in> state. x(s) = m} co B(m); F \<in> program\<rbrakk>
     \<Longrightarrow> F:{s \<in> state. x(s) \<in> M} co (\<Union>m \<in> M. B(m))"
by (rule UNITY.elimination, auto)

subsection\<open>The Operator \<^term>\<open>strongest_rhs\<close>\<close>

lemma constrains_strongest_rhs:
    "\<lbrakk>F \<in> program; st_set(A)\<rbrakk> \<Longrightarrow> F \<in> A co (strongest_rhs(F,A))"
by (auto simp add: constrains_def strongest_rhs_def st_set_def
              dest: Acts_type [THEN subsetD])

lemma strongest_rhs_is_strongest:
     "\<lbrakk>F \<in> A co B; st_set(B)\<rbrakk> \<Longrightarrow> strongest_rhs(F,A) \<subseteq> B"
by (auto simp add: constrains_def strongest_rhs_def st_set_def)

ML \<open>
fun simp_of_act def = def RS @{thm def_act_simp};
fun simp_of_set def = def RS @{thm def_set_simp};
\<close>

end


subsection \<open> Oblivious transfer constructed from ETPs \<close>

text\<open>Here we construct the OT protocol based on ETPs given in \cite{DBLP:books/sp/17/Lindell17} (Chapter 4) and prove
semi honest security for both parties. We show information theoretic security for Party 1 and reduce the security of
Party 2 to the HCP assumption.\<close>

theory ETP_OT imports
  "HOL-Number_Theory.Cong"
  ETP
  OT_Functionalities
  Semi_Honest_Def
begin

type_synonym 'range viewP1 = "((bool \<times> bool) \<times> 'range \<times> 'range) spmf"
type_synonym 'range dist1 = "((bool \<times> bool) \<times> 'range \<times> 'range) \<Rightarrow> bool spmf"
type_synonym 'index viewP2 = "(bool \<times> 'index \<times> (bool \<times> bool)) spmf"
type_synonym 'index dist2 = "(bool \<times> 'index \<times> bool \<times> bool) \<Rightarrow> bool spmf"
type_synonym ('index, 'range) advP2 = "'index \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> 'index dist2 \<Rightarrow> 'range \<Rightarrow> bool spmf"

lemma if_False_True: "(if x then False else \<not> False) \<longleftrightarrow> (if x then False else True)"
  by simp

lemma if_then_True [simp]: "(if b then True else x) \<longleftrightarrow> (\<not> b \<longrightarrow> x)"
  by simp

lemma if_else_True [simp]: "(if b then x else True) \<longleftrightarrow> (b \<longrightarrow> x)"
  by simp

lemma inj_on_Not [simp]: "inj_on Not A"
  by(auto simp add: inj_on_def)

locale ETP_base = etp: etp I domain range F F\<^sub>i\<^sub>n\<^sub>v B
  for I :: "('index \<times> 'trap) spmf" \<comment> \<open>samples index and trapdoor\<close>
    and domain :: "'index \<Rightarrow> 'range set"
    and range :: "'index \<Rightarrow> 'range set"
    and B :: "'index \<Rightarrow> 'range \<Rightarrow> bool" \<comment> \<open>hard core predicate\<close>
    and F :: "'index \<Rightarrow> 'range \<Rightarrow> 'range"
    and F\<^sub>i\<^sub>n\<^sub>v :: "'index \<Rightarrow> 'trap \<Rightarrow> 'range \<Rightarrow> 'range"
begin

text\<open>The probabilistic program that defines the protocol.\<close>

definition protocol :: "(bool \<times> bool) \<Rightarrow> bool \<Rightarrow> (unit \<times> bool) spmf"
  where "protocol input\<^sub>1 \<sigma> = do {
    let (b\<^sub>\<sigma>, b\<^sub>\<sigma>') = input\<^sub>1;
    (\<alpha> :: 'index, \<tau> :: 'trap) \<leftarrow> I;
    x\<^sub>\<sigma> :: 'range \<leftarrow> etp.S \<alpha>;
    y\<^sub>\<sigma>' :: 'range \<leftarrow> etp.S \<alpha>;
    let (y\<^sub>\<sigma> :: 'range) = F \<alpha> x\<^sub>\<sigma>;
    let (x\<^sub>\<sigma> :: 'range) = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>;
    let (x\<^sub>\<sigma>' :: 'range) = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>';
    let (\<beta>\<^sub>\<sigma> :: bool) = xor (B \<alpha> x\<^sub>\<sigma>) b\<^sub>\<sigma>;
    let (\<beta>\<^sub>\<sigma>' :: bool) = xor (B \<alpha> x\<^sub>\<sigma>') b\<^sub>\<sigma>';
    return_spmf ((), if \<sigma> then xor (B \<alpha> x\<^sub>\<sigma>') \<beta>\<^sub>\<sigma>' else xor (B \<alpha> x\<^sub>\<sigma>) \<beta>\<^sub>\<sigma>)}"

lemma correctness: "protocol (m0,m1) c = funct_OT_12 (m0,m1) c"
proof-
  have "(B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>') = (B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>') = m1)) = m1"
    for \<alpha> \<tau> y\<^sub>\<sigma>'  by auto
  then show ?thesis
    by(auto simp add: protocol_def funct_OT_12_def Let_def etp.B_F_inv_rewrite bind_spmf_const etp.lossless_S local.etp.lossless_I lossless_weight_spmfD split_def cong: bind_spmf_cong)
qed

text \<open> Party 1 views \<close>

definition R1 :: "(bool \<times> bool) \<Rightarrow> bool \<Rightarrow> 'range viewP1"
  where "R1 input\<^sub>1 \<sigma> = do {
    let (b\<^sub>0, b\<^sub>1) = input\<^sub>1;
    (\<alpha>, \<tau>) \<leftarrow> I;
    x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    y\<^sub>\<sigma>' \<leftarrow> etp.S \<alpha>;
    let y\<^sub>\<sigma> = F \<alpha> x\<^sub>\<sigma>;
    return_spmf ((b\<^sub>0, b\<^sub>1), if \<sigma> then y\<^sub>\<sigma>' else y\<^sub>\<sigma>, if \<sigma> then y\<^sub>\<sigma> else y\<^sub>\<sigma>')}"

definition S1 :: "(bool \<times> bool) \<Rightarrow> unit \<Rightarrow> 'range viewP1"
  where "S1 == (\<lambda> input\<^sub>1 (). do {
    let (b\<^sub>0, b\<^sub>1) = input\<^sub>1;
    (\<alpha>, \<tau>) \<leftarrow> I;
    y\<^sub>0 :: 'range \<leftarrow> etp.S \<alpha>;
    y\<^sub>1 \<leftarrow> etp.S \<alpha>;
    return_spmf ((b\<^sub>0, b\<^sub>1), y\<^sub>0, y\<^sub>1)})"

lemma lossless_S1: "lossless_spmf (S1 msgs ())"
  by(simp add: S1_def local.etp.lossless_I split_def etp.lossless_S)

text \<open> Party 2 views \<close>

definition R2 :: "(bool \<times> bool) \<Rightarrow> bool \<Rightarrow> 'index viewP2"
  where "R2 msgs \<sigma> = do {
    let (b0,b1) = msgs;
    (\<alpha>, \<tau>) \<leftarrow> I;
    x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    y\<^sub>\<sigma>' \<leftarrow> etp.S \<alpha>;
    let y\<^sub>\<sigma> = F \<alpha> x\<^sub>\<sigma>;
    let x\<^sub>\<sigma> = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>;
    let x\<^sub>\<sigma>' = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>';
    let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> (if \<sigma> then b1 else b0) ;
    let \<beta>\<^sub>\<sigma>' = (B \<alpha> x\<^sub>\<sigma>') \<oplus> (if \<sigma> then b0 else b1);
    return_spmf (\<sigma>, \<alpha>,(\<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>'))}"

lemma lossless_R2: "lossless_spmf (R2 msgs \<sigma>)"
  by(simp add: R2_def split_def local.etp.lossless_I etp.lossless_S)

definition S2 :: "bool \<Rightarrow> bool \<Rightarrow> 'index viewP2"
  where "S2 \<sigma> b\<^sub>\<sigma> = do {
    (\<alpha>, \<tau>) \<leftarrow> I;
    x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    y\<^sub>\<sigma>' \<leftarrow> etp.S \<alpha>;
    let x\<^sub>\<sigma>' = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>';
    let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
    let \<beta>\<^sub>\<sigma>' = B \<alpha> x\<^sub>\<sigma>';
    return_spmf (\<sigma>, \<alpha>, (\<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>'))}"

lemma lossless_S2: "lossless_spmf (S2 \<sigma> b\<^sub>\<sigma>)"
  by(simp add: S2_def local.etp.lossless_I etp.lossless_S split_def)

text \<open> Security for Party 1 \<close>

text\<open>We have information theoretic security for Party 1.\<close>

lemma P1_security: "R1 input\<^sub>1 \<sigma> = funct_OT_12 x y \<bind> (\<lambda> (s1, s2). S1 input\<^sub>1 s1)"
  including monad_normalisation
proof-
   have "R1 input\<^sub>1 \<sigma> =  do {
    let (b0,b1) = input\<^sub>1;
    (\<alpha>, \<tau>) \<leftarrow> I;
    y\<^sub>\<sigma>' :: 'range \<leftarrow> etp.S \<alpha>;
    y\<^sub>\<sigma> \<leftarrow> map_spmf (\<lambda> x\<^sub>\<sigma>. F \<alpha> x\<^sub>\<sigma>) (etp.S \<alpha>);
    return_spmf ((b0,b1), if \<sigma> then y\<^sub>\<sigma>' else y\<^sub>\<sigma>, if \<sigma> then y\<^sub>\<sigma> else y\<^sub>\<sigma>')}"
     by(simp add: bind_map_spmf o_def Let_def R1_def)
   also have "... = do {
    let (b0,b1) = input\<^sub>1;
    (\<alpha>, \<tau>) \<leftarrow> I;
    y\<^sub>\<sigma>' :: 'range \<leftarrow> etp.S \<alpha>;
    y\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    return_spmf ((b0,b1), if \<sigma> then y\<^sub>\<sigma>' else y\<^sub>\<sigma>, if \<sigma> then y\<^sub>\<sigma> else y\<^sub>\<sigma>')}"
     by(simp add: etp.uni_set_samp Let_def split_def cong: bind_spmf_cong)
   also have "... = funct_OT_12 x y \<bind> (\<lambda> (s1, s2). S1 input\<^sub>1 s1)"
     by(cases \<sigma>; simp add: S1_def R1_def Let_def funct_OT_12_def)
   ultimately show ?thesis by auto
qed

text \<open> The adversary used in proof of security for party 2 \<close>

definition \<A> :: "('index, 'range) advP2"
  where "\<A> \<alpha> \<sigma> b\<^sub>\<sigma> D2 x = do {
    \<beta>\<^sub>\<sigma>' \<leftarrow> coin_spmf;
    x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
    d \<leftarrow> D2(\<sigma>, \<alpha>, \<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
    return_spmf(if d then \<beta>\<^sub>\<sigma>' else \<not> \<beta>\<^sub>\<sigma>')}"

lemma lossless_\<A>:
  assumes "\<forall> view. lossless_spmf (D2 view)"
  shows "y \<in> set_spmf I \<longrightarrow>  lossless_spmf (\<A> (fst y) \<sigma> b\<^sub>\<sigma> D2 x)"
  by(simp add: \<A>_def etp.lossless_S assms)

lemma assm_bound_funct_OT_12:
  assumes "etp.HCP_adv \<A> \<sigma> (if \<sigma> then b1 else b0) D \<le> HCP_ad"
  shows "\<bar>spmf (funct_OT_12 (b0,b1) \<sigma> \<bind> (\<lambda> (out1,out2).
              etp.HCP_game \<A> \<sigma> out2 D)) True - 1/2\<bar> \<le> HCP_ad"
(is "?lhs \<le> HCP_ad")
proof-
  have "?lhs = \<bar>spmf (etp.HCP_game \<A> \<sigma> (if \<sigma> then b1 else b0) D) True - 1/2\<bar>"
    by(simp add: funct_OT_12_def)
  thus ?thesis using assms etp.HCP_adv_def by simp
qed

lemma assm_bound_funct_OT_12_collapse:
  assumes "\<forall> b\<^sub>\<sigma>. etp.HCP_adv \<A> \<sigma> b\<^sub>\<sigma> D \<le> HCP_ad"
  shows "\<bar>spmf (funct_OT_12 m1 \<sigma> \<bind> (\<lambda> (out1,out2). etp.HCP_game \<A> \<sigma> out2 D)) True - 1/2\<bar> \<le> HCP_ad"
  using assm_bound_funct_OT_12 surj_pair assms by metis

text \<open> To prove security for party 2 we split the proof on the cases on party 2's input \<close>

lemma R2_S2_False:
  assumes "((if \<sigma> then b0 else b1) = False)"
  shows "spmf (R2 (b0,b1) \<sigma> \<bind> (D2 :: (bool \<times> 'index \<times> bool \<times> bool) \<Rightarrow> bool spmf)) True
                = spmf (funct_OT_12 (b0,b1) \<sigma> \<bind> (\<lambda> (out1,out2). S2 \<sigma> out2 \<bind> D2)) True"
proof-
  have "\<sigma> \<Longrightarrow> \<not> b0" using assms by simp
  moreover have "\<not> \<sigma> \<Longrightarrow> \<not> b1" using assms by simp
  ultimately show ?thesis
    by(auto simp add: R2_def S2_def split_def local.etp.F_f_inv assms funct_OT_12_def cong: bind_spmf_cong_simp)
qed

lemma R2_S2_True:
  assumes "((if \<sigma> then b0 else b1) = True)"
    and lossless_D: "\<forall> a. lossless_spmf (D2 a)"
  shows "\<bar>(spmf (bind_spmf (R2 (b0,b1) \<sigma>) D2) True) - spmf (funct_OT_12 (b0,b1) \<sigma> \<bind> (\<lambda> (out1, out2). S2 \<sigma> out2 \<bind> (\<lambda> view. D2 view))) True\<bar>
                         = \<bar>2*((spmf (etp.HCP_game \<A> \<sigma> (if \<sigma> then b1 else b0) D2) True) - 1/2)\<bar>"
proof-
  have  "(spmf (funct_OT_12 (b0,b1) \<sigma> \<bind> (\<lambda> (out1, out2). S2 \<sigma> out2 \<bind> D2)) True
              - spmf (bind_spmf (R2 (b0,b1) \<sigma>) D2) True)
                    = 2 * ((spmf (etp.HCP_game \<A> \<sigma> (if \<sigma> then b1 else b0) D2) True) - 1/2)"
  proof-
    have  "((spmf (etp.HCP_game \<A> \<sigma> (if \<sigma> then b1 else b0) D2) True) - 1/2)  =
                  1/2*(spmf (bind_spmf (S2 \<sigma> (if \<sigma> then b1 else b0)) D2) True
                        - spmf (bind_spmf (R2 (b0,b1) \<sigma>) D2) True)"
      including monad_normalisation
    proof-
      have \<sigma>_true_b0_true: "\<sigma> \<Longrightarrow> b0 = True" using assms(1) by simp
      have \<sigma>_false_b1_true: "\<not> \<sigma> \<Longrightarrow> b1" using assms(1) by simp
      have return_True_False: "spmf (return_spmf (\<not> d)) True = spmf (return_spmf d) False"
        for d by(cases d; simp)
      define HCP_game_true where "HCP_game_true == \<lambda> \<sigma> b\<^sub>\<sigma>. do {
    (\<alpha>, \<tau>) \<leftarrow> I;
    x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    x \<leftarrow> (etp.S \<alpha>);
    let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
    let \<beta>\<^sub>\<sigma>' = B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
    d \<leftarrow> D2(\<sigma>, \<alpha>, \<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
    let b' = (if d then \<beta>\<^sub>\<sigma>' else \<not> \<beta>\<^sub>\<sigma>');
    let b = B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
    return_spmf (b = b')}"
      define HCP_game_false where "HCP_game_false == \<lambda> \<sigma> b\<^sub>\<sigma>. do {
    (\<alpha>, \<tau>) \<leftarrow> I;
    x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    x \<leftarrow> (etp.S \<alpha>);
    let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
    let \<beta>\<^sub>\<sigma>' = \<not> B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
    d \<leftarrow> D2(\<sigma>, \<alpha>, \<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
    let b' = (if d then \<beta>\<^sub>\<sigma>' else \<not> \<beta>\<^sub>\<sigma>');
    let b = B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
    return_spmf (b = b')}"
      define HCP_game_\<A> where "HCP_game_\<A> == \<lambda> \<sigma> b\<^sub>\<sigma>. do {
    \<beta>\<^sub>\<sigma>' \<leftarrow> coin_spmf;
    (\<alpha>, \<tau>) \<leftarrow> I;
    x \<leftarrow> etp.S \<alpha>;
    x' \<leftarrow> etp.S \<alpha>;
    d \<leftarrow> D2 (\<sigma>, \<alpha>, (B \<alpha> x) \<oplus> b\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
    let b' = (if d then  \<beta>\<^sub>\<sigma>' else \<not> \<beta>\<^sub>\<sigma>');
    return_spmf (B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x') = b')}"
      define S2D where "S2D == \<lambda> \<sigma> b\<^sub>\<sigma> . do {
      (\<alpha>, \<tau>) \<leftarrow> I;
      x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
      y\<^sub>\<sigma>' \<leftarrow> etp.S \<alpha>;
      let x\<^sub>\<sigma>' = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>';
      let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
      let \<beta>\<^sub>\<sigma>' = B \<alpha> x\<^sub>\<sigma>';
      d :: bool \<leftarrow> D2(\<sigma>, \<alpha>, \<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
      return_spmf d}"
      define R2D where "R2D == \<lambda> msgs \<sigma>.  do {
      let (b0,b1) = msgs;
      (\<alpha>, \<tau>) \<leftarrow> I;
      x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
      y\<^sub>\<sigma>' \<leftarrow> etp.S \<alpha>;
      let y\<^sub>\<sigma> = F \<alpha> x\<^sub>\<sigma>;
      let x\<^sub>\<sigma> = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>;
      let x\<^sub>\<sigma>' = F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> y\<^sub>\<sigma>';
      let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> (if \<sigma> then b1 else b0) ;
      let \<beta>\<^sub>\<sigma>' = (B \<alpha> x\<^sub>\<sigma>') \<oplus> (if \<sigma> then b0 else b1);
      b :: bool \<leftarrow> D2(\<sigma>, \<alpha>,(\<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>'));
      return_spmf b}"
      define D_true where "D_true  == \<lambda>\<sigma> b\<^sub>\<sigma>. do {
    (\<alpha>, \<tau>) \<leftarrow> I;
    x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    x \<leftarrow> (etp.S \<alpha>);
    let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
    let \<beta>\<^sub>\<sigma>' = B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
    d :: bool \<leftarrow> D2(\<sigma>, \<alpha>, \<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
    return_spmf d}"
      define D_false where "D_false == \<lambda> \<sigma> b\<^sub>\<sigma>. do {
    (\<alpha>, \<tau>) \<leftarrow> I;
    x\<^sub>\<sigma> \<leftarrow> etp.S \<alpha>;
    x \<leftarrow> etp.S \<alpha>;
    let \<beta>\<^sub>\<sigma> = (B \<alpha> x\<^sub>\<sigma>) \<oplus> b\<^sub>\<sigma>;
    let \<beta>\<^sub>\<sigma>' = \<not> B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x);
    d :: bool \<leftarrow> D2(\<sigma>, \<alpha>, \<beta>\<^sub>\<sigma>, \<beta>\<^sub>\<sigma>');
    return_spmf d}"
      have lossless_D_false: "lossless_spmf (D_false \<sigma> (if \<sigma> then b1 else b0))"
        apply(auto simp add: D_false_def lossless_D local.etp.lossless_I)
        using local.etp.lossless_S by auto
      have "spmf (etp.HCP_game \<A> \<sigma> (if \<sigma> then b1 else b0) D2) True =  spmf (HCP_game_\<A> \<sigma> (if \<sigma> then b1 else b0)) True"
        apply(simp add: etp.HCP_game_def HCP_game_\<A>_def \<A>_def split_def etp.F_f_inv)
        by(rewrite bind_commute_spmf[where q = "coin_spmf"]; rewrite bind_commute_spmf[where q = "coin_spmf"]; rewrite bind_commute_spmf[where q = "coin_spmf"]; auto)+
      also have "... = spmf (bind_spmf (map_spmf Not coin_spmf) (\<lambda>b. if b then HCP_game_true \<sigma> (if \<sigma> then b1 else b0) else HCP_game_false \<sigma> (if \<sigma> then b1 else b0))) True"
        unfolding HCP_game_\<A>_def HCP_game_true_def HCP_game_false_def \<A>_def Let_def
        apply(simp add: split_def cong: if_cong)
        supply [[simproc del: monad_normalisation]]
        apply(subst if_distrib[where f = "bind_spmf _" for f, symmetric]; simp cong: bind_spmf_cong add: if_distribR )+
        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 "\<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(fold map_spmf_conv_bind_spmf)
        apply(rule conjI; rule impI; simp)
         apply(simp only: spmf_bind)
         apply(rule Bochner_Integration.integral_cong[OF refl])+
         apply clarify
        subgoal for r r\<^sub>\<sigma> \<alpha> \<tau>
          apply(simp only: UNIV_bool spmf_of_set integral_spmf_of_set)
          apply(simp cong: if_cong split del: if_split)
          apply(cases "B r (F\<^sub>i\<^sub>n\<^sub>v r r\<^sub>\<sigma> \<tau>)")
          by auto
        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 "\<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(simp only: spmf_bind)
        apply(rule Bochner_Integration.integral_cong[OF refl])+
        apply clarify
        subgoal for r r\<^sub>\<sigma> \<alpha> \<tau>
          apply(simp only: UNIV_bool spmf_of_set integral_spmf_of_set)
          apply(simp cong: if_cong split del: if_split)
          apply(cases " B r (F\<^sub>i\<^sub>n\<^sub>v r r\<^sub>\<sigma> \<tau>)")
          by auto
        done
      also have "... = 1/2*(spmf (HCP_game_true \<sigma> (if \<sigma> then b1 else b0)) True) + 1/2*(spmf (HCP_game_false \<sigma> (if \<sigma> then b1 else b0)) True)"
        by(simp add: spmf_bind UNIV_bool spmf_of_set integral_spmf_of_set)
      also have "... = 1/2*(spmf (D_true \<sigma> (if \<sigma> then b1 else b0)) True) + 1/2*(spmf (D_false \<sigma> (if \<sigma> then b1 else b0)) False)"
      proof-
        have "spmf (I \<bind> (\<lambda>(\<alpha>, \<tau>). etp.S \<alpha> \<bind> (\<lambda>x\<^sub>\<sigma>. etp.S \<alpha> \<bind> (\<lambda>x. D2 (\<sigma>, \<alpha>, B \<alpha> x\<^sub>\<sigma> = (\<not> (if \<sigma> then b1 else b0)), \<not> B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x)) \<bind> (\<lambda>d. return_spmf (\<not> d)))))) True
                = spmf (I \<bind> (\<lambda>(\<alpha>, \<tau>). etp.S \<alpha> \<bind> (\<lambda>x\<^sub>\<sigma>. etp.S \<alpha> \<bind> (\<lambda>x. D2 (\<sigma>, \<alpha>, B \<alpha> x\<^sub>\<sigma> = (\<not> (if \<sigma> then b1 else b0)), \<not> B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x)))))) False"
          (is "?lhs = ?rhs")
        proof-
          have "?lhs = spmf (I \<bind> (\<lambda>(\<alpha>, \<tau>). etp.S \<alpha> \<bind> (\<lambda>x\<^sub>\<sigma>. etp.S \<alpha> \<bind> (\<lambda>x. D2 (\<sigma>, \<alpha>, B \<alpha> x\<^sub>\<sigma> = (\<not> (if \<sigma> then b1 else b0)), \<not> B \<alpha> (F\<^sub>i\<^sub>n\<^sub>v \<alpha> \<tau> x)) \<bind> (\<lambda>d. return_spmf (d)))))) False"
            by(simp only: split_def return_True_False spmf_bind)
          then show ?thesis by simp
        qed
        then show ?thesis  by(simp add: HCP_game_true_def HCP_game_false_def Let_def D_true_def D_false_def if_distrib[where f="(=) _"] cong: if_cong)
      qed
      also have "... =  1/2*((spmf (D_true \<sigma> (if \<sigma> then b1 else b0) ) True) + (1 - spmf (D_false \<sigma> (if \<sigma> then b1 else b0) ) True))"
        by(simp add: spmf_False_conv_True lossless_D_false)
      also have "... = 1/2 + 1/2* (spmf (D_true \<sigma> (if \<sigma> then b1 else b0)) True) - 1/2*(spmf (D_false \<sigma> (if \<sigma> then b1 else b0)) True)"
        by(simp)
      also have "... =  1/2 + 1/2* (spmf (S2D \<sigma> (if \<sigma> then b1 else b0) ) True) - 1/2*(spmf (R2D (b0,b1) \<sigma> ) True)"
        apply(auto  simp add: local.etp.F_f_inv S2D_def R2D_def D_true_def D_false_def  assms split_def cong: bind_spmf_cong_simp)
         apply(simp add: \<sigma>_true_b0_true)
        by(simp add: \<sigma>_false_b1_true)
      ultimately show ?thesis by(simp add: S2D_def R2D_def R2_def S2_def split_def)
    qed
    then show ?thesis by(auto simp add: funct_OT_12_def)
  qed
  thus ?thesis by simp
qed

lemma P2_adv_bound:
  assumes lossless_D: "\<forall> a. lossless_spmf (D2 a)"
  shows "\<bar>(spmf (bind_spmf (R2 (b0,b1) \<sigma>) D2) True) - spmf (funct_OT_12 (b0,b1) \<sigma> \<bind> (\<lambda> (out1, out2). S2 \<sigma> out2 \<bind> (\<lambda> view. D2 view))) True\<bar>
                         \<le> \<bar>2*((spmf (etp.HCP_game \<A> \<sigma> (if \<sigma> then b1 else b0) D2) True) - 1/2)\<bar>"
  by(cases "(if \<sigma> then b0 else b1)"; auto simp add: R2_S2_False R2_S2_True assms)

sublocale OT_12: sim_det_def R1 S1 R2 S2 funct_OT_12 protocol
  unfolding sim_det_def_def
  by(simp add: lossless_R1 lossless_S1 lossless_R2 lossless_S2 funct_OT_12_def)

lemma correct: "OT_12.correctness m1 m2"
  unfolding OT_12.correctness_def
  by (metis prod.collapse correctness)

lemma P1_security_inf_the: "OT_12.perfect_sec_P1 m1 m2"
  unfolding OT_12.perfect_sec_P1_def using P1_security by simp

lemma P2_security:
  assumes "\<forall> a. lossless_spmf (D a)"
  and "\<forall> b\<^sub>\<sigma>. etp.HCP_adv \<A> m2 b\<^sub>\<sigma> D \<le> HCP_ad"
  shows "OT_12.adv_P2 m1 m2 D \<le> 2 * HCP_ad"
proof-
  have "spmf (etp.HCP_game \<A> \<sigma> (if \<sigma> then b1 else b0) D) True = spmf (funct_OT_12 (b0,b1) \<sigma> \<bind> (\<lambda> (out1, out2). etp.HCP_game \<A> \<sigma> out2 D)) True"
    for \<sigma> b0 b1
  by(simp add: funct_OT_12_def)
  hence "OT_12.adv_P2 m1 m2 D \<le> \<bar>2*((spmf (funct_OT_12 m1 m2 \<bind> (\<lambda> (out1, out2). etp.HCP_game \<A> m2 out2 D)) True) - 1/2)\<bar>"
    unfolding OT_12.adv_P2_def using P2_adv_bound assms surj_pair prod.collapse by metis
  moreover have "\<bar>2*((spmf (funct_OT_12 m1 m2 \<bind> (\<lambda> (out1, out2). etp.HCP_game \<A> m2 out2 D)) True) - 1/2)\<bar> \<le> \<bar>2*HCP_ad\<bar>"
  proof -
    have "(\<exists>r. \<bar>(1::real) / r\<bar> \<noteq> 1 / \<bar>r\<bar>) \<or> 2 / \<bar>1 / (spmf (funct_OT_12 m1 m2
                \<bind> (\<lambda>(x, y). ((\<lambda>u b. etp.HCP_game \<A> m2 b D)::unit \<Rightarrow> bool \<Rightarrow> bool spmf) x y)) True - 1 / 2)\<bar>
                      \<le> HCP_ad / (1 / 2)"
      using assm_bound_funct_OT_12_collapse assms by auto
    then show ?thesis
      by fastforce
  qed
  moreover have "HCP_ad \<ge> 0"
    using assms(2)  local.etp.HCP_adv_def by auto
  ultimately show ?thesis by argo
qed

end

text \<open> We also consider the asymptotic case for security proofs \<close>

locale ETP_sec_para =
  fixes I :: "nat \<Rightarrow> ('index \<times> 'trap) spmf"
    and domain ::  "'index \<Rightarrow> 'range set"
    and range ::  "'index \<Rightarrow> 'range set"
    and f :: "'index \<Rightarrow> ('range \<Rightarrow> 'range)"
    and F :: "'index \<Rightarrow> 'range \<Rightarrow> 'range"
    and F\<^sub>i\<^sub>n\<^sub>v :: "'index \<Rightarrow> 'trap \<Rightarrow> 'range \<Rightarrow> 'range"
    and B :: "'index \<Rightarrow> 'range \<Rightarrow> bool"
  assumes ETP_base: "\<And> n. ETP_base (I n) domain range F F\<^sub>i\<^sub>n\<^sub>v"
begin

sublocale ETP_base "(I n)" domain range
  using ETP_base  by simp

lemma P1_sec_asym: "OT_12.perfect_sec_P1 n m1 m2"
  using P1_security_inf_the by simp

lemma P2_sec_asym:
  assumes "\<forall> a. lossless_spmf (D a)"
    and HCP_adv_neg: "negligible (\<lambda> n. etp_advantage n)"
    and etp_adv_bound: "\<forall> b\<^sub>\<sigma> n. etp.HCP_adv n \<A> m2 b\<^sub>\<sigma> D \<le> etp_advantage n"
  shows "negligible (\<lambda> n. OT_12.adv_P2 n m1 m2 D)"
proof-
  have "negligible (\<lambda> n. 2 * etp_advantage n)" using HCP_adv_neg
    by (simp add: negligible_cmultI)
  moreover have "\<bar>OT_12.adv_P2 n m1 m2 D\<bar> = OT_12.adv_P2 n m1 m2 D" for n unfolding OT_12.adv_P2_def by simp
  moreover have  "OT_12.adv_P2 n m1 m2 D \<le> 2 * etp_advantage n" for n using assms P2_security by blast
  ultimately show ?thesis
    using assms negligible_le HCP_adv_neg P2_security by presburger
qed

end

end


theory AnalBinds
imports "../Launchbury/Terms" "../Launchbury/HOLCF-Utils" "../Launchbury/Env"
begin

locale ExpAnalysis =
  fixes exp :: "exp \<Rightarrow> 'a::cpo \<rightarrow> 'b::pcpo"
begin

fun AnalBinds :: "heap \<Rightarrow> (var \<Rightarrow> 'a\<^sub>\<bottom>) \<rightarrow> (var \<Rightarrow> 'b)"
  where "AnalBinds [] = (\<Lambda> ae. \<bottom>)"
      | "AnalBinds ((x,e)#\<Gamma>) = (\<Lambda> ae. (AnalBinds \<Gamma>\<cdot>ae)(x := fup\<cdot>(exp e)\<cdot>(ae x)))"

lemma AnalBinds_Nil_simp[simp]: "AnalBinds []\<cdot>ae = \<bottom>" by simp

lemma AnalBinds_Cons[simp]:
  "AnalBinds ((x,e)#\<Gamma>)\<cdot>ae = (AnalBinds \<Gamma>\<cdot>ae)(x := fup\<cdot>(exp e)\<cdot>(ae x))"
  by simp

lemmas AnalBinds.simps[simp del]

lemma AnalBinds_not_there: "x \<notin> domA \<Gamma> \<Longrightarrow> (AnalBinds \<Gamma>\<cdot>ae) x = \<bottom>"
  by (induction \<Gamma> rule: AnalBinds.induct) auto

lemma AnalBinds_cong:
  assumes "ae f|` domA \<Gamma> = ae' f|` domA \<Gamma>"
  shows "AnalBinds \<Gamma>\<cdot>ae = AnalBinds \<Gamma>\<cdot>ae'"
using env_restr_eqD[OF assms]
by (induction \<Gamma> rule: AnalBinds.induct) (auto split: if_splits)

lemma AnalBinds_lookup: "(AnalBinds \<Gamma>\<cdot>ae) x = (case map_of \<Gamma> x of Some e \<Rightarrow> fup\<cdot>(exp e)\<cdot>(ae x) | None \<Rightarrow> \<bottom>)"
  by (induction \<Gamma> rule: AnalBinds.induct) auto

lemma AnalBinds_delete_bot: "ae x = \<bottom> \<Longrightarrow> AnalBinds (delete x \<Gamma>)\<cdot>ae = AnalBinds \<Gamma>\<cdot>ae"
  by (auto simp add: AnalBinds_lookup split:option.split simp add: delete_conv)

lemma AnalBinds_delete_below: "AnalBinds (delete x \<Gamma>)\<cdot>ae \<sqsubseteq> AnalBinds \<Gamma>\<cdot>ae"
  by (auto intro: fun_belowI simp add: AnalBinds_lookup split:option.split)

lemma AnalBinds_delete_lookup[simp]: "(AnalBinds (delete x \<Gamma>)\<cdot>ae) x = \<bottom>"
  by (auto  simp add: AnalBinds_lookup split:option.split)

lemma AnalBinds_delete_to_fun_upd: "AnalBinds (delete x \<Gamma>)\<cdot>ae = (AnalBinds \<Gamma>\<cdot>ae)(x := \<bottom>)"
  by (auto  simp add: AnalBinds_lookup split:option.split)

lemma edom_AnalBinds: "edom (AnalBinds \<Gamma>\<cdot>ae) \<subseteq> domA \<Gamma> \<inter> edom ae"
  by (induction \<Gamma> rule: AnalBinds.induct) (auto  simp add: edom_def)

end

end