section {* Concurrent programming *}

theory utp_concurrency
  imports "../hoare/AlgebraicLaws/Rel&Des/Algebraic_Laws" utp_tactics
begin

text {* In parallel-by-merge constructions, a merge predicate defines the behaviour following execution of
        of parallel processes, P || Q, as a relation that merges the output of P and Q. In order to achieve
        this we need to separate the variable values output from P and Q, and in addition the variable values
        before execution. The following three constructs do these separations. *}

definition [upred_defs]: "left_uvar x = x ;\<^sub>L fst\<^sub>L ;\<^sub>L snd\<^sub>L"

definition [upred_defs]: "right_uvar x = x ;\<^sub>L snd\<^sub>L ;\<^sub>L snd\<^sub>L"

definition [upred_defs]: "pre_uvar x = x ;\<^sub>L fst\<^sub>L"

lemma left_uvar_indep_right_uvar [simp]:
  "left_uvar x \<bowtie> right_uvar y"
  apply (simp add: left_uvar_def right_uvar_def lens_comp_assoc[THEN sym])
  apply (simp add: alpha_in_var alpha_out_var)
done

lemma right_uvar_indep_left_uvar [simp]:
  "right_uvar x \<bowtie> left_uvar y"
  by (simp add: lens_indep_sym)

lemma left_uvar [simp]: "vwb_lens x \<Longrightarrow> vwb_lens (left_uvar x)"
  by (simp add: left_uvar_def )

lemma right_uvar [simp]: "vwb_lens x \<Longrightarrow> vwb_lens (right_uvar x)"
  by (simp add: right_uvar_def)

syntax
  "_svarpre"   :: "svid \<Rightarrow> svid" ("_\<^sub><" [999] 999)
  "_svarleft"  :: "svid \<Rightarrow> svid" ("0-_" [999] 999)
  "_svarright" :: "svid \<Rightarrow> svid" ("1-_" [999] 999)

translations
  "_svarpre x" == "CONST pre_uvar x"
  "_svarleft x" == "CONST left_uvar x"
  "_svarright x" == "CONST right_uvar x"

type_synonym '\<alpha> merge = "('\<alpha> \<times> ('\<alpha> \<times> '\<alpha>), '\<alpha>) rel"

text {* U0 and U1 are relations that index all input variables x to 0-x and 1-x, respectively. *}

definition [upred_defs]: "U0 = ($0-\<Sigma>\<acute> =\<^sub>u $\<Sigma>)"

definition [upred_defs]: "U1 = ($1-\<Sigma>\<acute> =\<^sub>u $\<Sigma>)"

text {* As shown below, separating simulations can also be expressed using the following two alphabet extrusions *}

definition U0\<alpha> where [upred_defs]: "U0\<alpha> = (1\<^sub>L \<times>\<^sub>L out_var fst\<^sub>L)"

definition U1\<alpha> where [upred_defs]: "U1\<alpha> = (1\<^sub>L \<times>\<^sub>L out_var snd\<^sub>L)"

abbreviation U0_alpha_lift ("\<lceil>_\<rceil>\<^sub>0") where "\<lceil>P\<rceil>\<^sub>0 \<equiv> P \<oplus>\<^sub>p U0\<alpha>"

abbreviation U1_alpha_lift ("\<lceil>_\<rceil>\<^sub>1") where "\<lceil>P\<rceil>\<^sub>1 \<equiv> P \<oplus>\<^sub>p U1\<alpha>"

text {* We implement the following useful abbreviation for separating of two parallel processes and
  copying of the before variables, all to act as input to the merge predicate. *}

abbreviation par_sep (infixl "\<parallel>\<^sub>s" 85) where
"P \<parallel>\<^sub>s Q \<equiv> (P ;; U0) \<and> (Q ;; U1) \<and> $\<Sigma>\<^sub><\<acute> =\<^sub>u $\<Sigma>"

text {* The following implementation of parallel by merge is less general than the book version, in
  that it does not properly partition the alphabet into two disjoint segments. We could actually
  achieve this specifying lenses into the larger alphabet, but this would complicate the definition
  of programs. May reconsider later. *}

definition par_by_merge  ("_ \<parallel>\<^bsub>_\<^esub> _" [85,0,86] 85)
where [upred_defs]: "P \<parallel>\<^bsub>M\<^esub> Q = (P \<parallel>\<^sub>s Q ;; M)"

text {* nil is the merge predicate which ignores the output of both parallel predicates *}

definition [upred_defs]: "nil\<^sub>m = ($\<Sigma>\<acute> =\<^sub>u $\<Sigma>\<^sub><)"

text {* swap is a predicate that the swaps the left and right indices; it is used to specify commutativity of the parallel operator *}

-- {* TODO: There is an ambiguity below due to list assignment and tuples. *}

definition [upred_defs]: "swap\<^sub>m = (0-\<Sigma>,1-\<Sigma> :== &1-\<Sigma>,&0-\<Sigma>)"

lemma U0_swap: "(U0 ;; swap\<^sub>m) = U1"
  by (rel_auto)+

lemma U1_swap: "(U1 ;; swap\<^sub>m) = U0"
  by (rel_auto)

text {* We can equivalently express separating simulations using alphabet extrusion *}

lemma U0_as_alpha: "(P ;; U0) = \<lceil>P\<rceil>\<^sub>0"
  by (rel_auto)

lemma U1_as_alpha: "(P ;; U1) = \<lceil>P\<rceil>\<^sub>1"
  by (rel_auto)

lemma U0\<alpha>_vwb_lens [simp]: "vwb_lens U0\<alpha>"
  by (simp add: U0\<alpha>_def id_vwb_lens prod_vwb_lens)

lemma U1\<alpha>_vwb_lens [simp]: "vwb_lens U1\<alpha>"
  by (simp add: U1\<alpha>_def id_vwb_lens prod_vwb_lens)

lemma U0_alpha_out_var [alpha]: "\<lceil>$x\<acute>\<rceil>\<^sub>0 = $0-x\<acute>"
  by (rel_auto)

lemma U1_alpha_out_var [alpha]: "\<lceil>$x\<acute>\<rceil>\<^sub>1 = $1-x\<acute>"
  by (rel_auto)

lemma U0\<alpha>_comp_in_var [alpha]: "(in_var x) ;\<^sub>L U0\<alpha> = in_var x"
  by (simp add: U0\<alpha>_def alpha_in_var in_var_prod_lens pre_uvar_def)

lemma U0\<alpha>_comp_out_var [alpha]: "(out_var x) ;\<^sub>L U0\<alpha> = out_var (left_uvar x)"
  by (simp add: U0\<alpha>_def alpha_out_var id_wb_lens left_uvar_def out_var_prod_lens)

lemma U1\<alpha>_comp_in_var [alpha]: "(in_var x) ;\<^sub>L U1\<alpha> = in_var x"
  by (simp add: U1\<alpha>_def alpha_in_var in_var_prod_lens pre_uvar_def)

lemma U1\<alpha>_comp_out_var [alpha]: "(out_var x) ;\<^sub>L U1\<alpha> = out_var (right_uvar x)"
  by (simp add: U1\<alpha>_def alpha_out_var id_wb_lens right_uvar_def out_var_prod_lens)

lemma U0_seq_subst: "(P ;; U0)\<lbrakk>\<guillemotleft>v\<guillemotright>/$0-x\<acute>\<rbrakk> = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; U0)"
  by (rel_auto)

lemma U1_seq_subst: "(P ;; U1)\<lbrakk>\<guillemotleft>v\<guillemotright>/$1-x\<acute>\<rbrakk> = (P\<lbrakk>\<guillemotleft>v\<guillemotright>/$x\<acute>\<rbrakk> ;; U1)"
  by (rel_auto)

lemma par_by_merge_false [simp]:
  "P \<parallel>\<^bsub>false\<^esub> Q = false"
  by (rel_auto)

lemma par_by_merge_left_false [simp]:
  "false \<parallel>\<^bsub>M\<^esub> Q = false"
  by (rel_auto)

lemma par_by_merge_right_false [simp]:
  "P \<parallel>\<^bsub>M\<^esub> false = false"
  by (rel_auto)

lemma par_by_merge_commute:
  assumes "(swap\<^sub>m ;; M) = M"
  shows "P \<parallel>\<^bsub>M\<^esub> Q = Q \<parallel>\<^bsub>M\<^esub> P"
proof -
  have "P \<parallel>\<^bsub>M\<^esub> Q = (((P ;; U0) \<and> (Q ;; U1) \<and> $\<Sigma>\<^sub><\<acute> =\<^sub>u $\<Sigma>) ;; M)"
    by (simp add: par_by_merge_def)
  also have "... = ((((P ;; U0) \<and> (Q ;; U1) \<and> $\<Sigma>\<^sub><\<acute> =\<^sub>u $\<Sigma>) ;; swap\<^sub>m) ;; M)"
    by (metis assms seqr_assoc)
  also have "... = (((P ;; U0 ;; swap\<^sub>m) \<and> (Q ;; U1 ;; swap\<^sub>m) \<and> $\<Sigma>\<^sub><\<acute> =\<^sub>u $\<Sigma>) ;; M)"
    by (rel_auto)
  also have "... = (((P ;; U1) \<and> (Q ;; U0) \<and> $\<Sigma>\<^sub><\<acute> =\<^sub>u $\<Sigma>) ;; M)"
    by (simp add: U0_swap U1_swap)
  also have "... = Q \<parallel>\<^bsub>M\<^esub> P"
    by (simp add: par_by_merge_def utp_pred.inf.left_commute)
  finally show ?thesis .
qed

lemma shEx_pbm_left: "((\<^bold>\<exists> x \<bullet> P x) \<parallel>\<^bsub>M\<^esub> Q) = (\<^bold>\<exists> x \<bullet> (P x \<parallel>\<^bsub>M\<^esub> Q))"
  by (rel_auto)

lemma shEx_pbm_right: "(P \<parallel>\<^bsub>M\<^esub> (\<^bold>\<exists> x \<bullet> Q x)) = (\<^bold>\<exists> x \<bullet> (P \<parallel>\<^bsub>M\<^esub> Q x))"
  by (rel_auto)

lemma par_by_merge_mono_1:
  assumes "P\<^sub>1 \<sqsubseteq> P\<^sub>2"
  shows "P\<^sub>1 \<parallel>\<^bsub>M\<^esub> Q \<sqsubseteq> P\<^sub>2 \<parallel>\<^bsub>M\<^esub> Q"
  using assms by (rel_auto)

lemma par_by_merge_mono_2:
  assumes "Q\<^sub>1 \<sqsubseteq> Q\<^sub>2"
  shows "(P \<parallel>\<^bsub>M\<^esub> Q\<^sub>1) \<sqsubseteq> (P \<parallel>\<^bsub>M\<^esub> Q\<^sub>2)"
  using assms by (rel_blast)

lemma zero_one_pbm_laws [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 0) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>0/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>0/$x\<^sub><\<rbrakk>\<^esub> (Q\<lbrakk>0/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s 1) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>1/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>1/$x\<^sub><\<rbrakk>\<^esub> (Q\<lbrakk>1/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 0) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>0/$x\<acute>\<rbrakk>\<^esub> Q)"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s 1) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>1/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (rel_auto)+

lemma numeral_pbm_laws [usubst]:
  fixes x :: "(_ \<Longrightarrow> '\<alpha>)"
  shows
    "\<And> P Q M \<sigma>. \<sigma>($x \<mapsto>\<^sub>s numeral n) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> ((P\<lbrakk>numeral n/$x\<rbrakk>) \<parallel>\<^bsub>M\<lbrakk>numeral n/$x\<^sub><\<rbrakk>\<^esub> (Q\<lbrakk>numeral n/$x\<rbrakk>))"
    "\<And> P Q M \<sigma>. \<sigma>($x\<acute> \<mapsto>\<^sub>s numeral n) \<dagger> (P \<parallel>\<^bsub>M\<^esub> Q) = \<sigma> \<dagger> (P \<parallel>\<^bsub>M\<lbrakk>numeral n/$x\<acute>\<rbrakk>\<^esub> Q)"
  by (rel_auto)+
end


section {* Parametricity Theorems for HOL *}
theory Param_HOL
imports Param_Tool
begin

lemma param_if[param]:
  assumes "(c,c')\<in>Id"
  assumes "\<lbrakk>c;c'\<rbrakk> \<Longrightarrow> (t,t')\<in>R"
  assumes "\<lbrakk>\<not>c;\<not>c'\<rbrakk> \<Longrightarrow> (e,e')\<in>R"
  shows "(If c t e, If c' t' e')\<in>R"
  using assms by auto

lemma param_Let[param]:
  "(Let,Let)\<in>Ra \<rightarrow> (Ra\<rightarrow>Rr) \<rightarrow> Rr"
  by (auto dest: fun_relD)

lemma param_id[param]: "(id,id)\<in>R\<rightarrow>R" unfolding id_def by parametricity

lemma param_fun_comp[param]: "(op o, op o) \<in> (Ra\<rightarrow>Rb) \<rightarrow> (Rc\<rightarrow>Ra) \<rightarrow> Rc\<rightarrow>Rb"
  unfolding comp_def[abs_def] by parametricity

lemma param_fun_upd[param]: "
  (op =, op =) \<in> Ra\<rightarrow>Ra\<rightarrow>Id
  \<Longrightarrow> (fun_upd,fun_upd) \<in> (Ra\<rightarrow>Rb) \<rightarrow> Ra \<rightarrow> Rb \<rightarrow> Ra \<rightarrow> Rb"
  unfolding fun_upd_def[abs_def]
  by (parametricity)

lemma param_unit[param]: "((),())\<in>unit_rel" by auto

lemma rec_bool_is_case: "old.rec_bool = case_bool"
  by (rule ext)+ (auto split: bool.split)

lemma param_bool[param]:
  "(True,True)\<in>Id"
  "(False,False)\<in>Id"
  "(conj,conj)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "(disj,disj)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "(Not,Not)\<in>Id\<rightarrow>Id"
  "(case_bool,case_bool)\<in>R\<rightarrow>R\<rightarrow>Id\<rightarrow>R"
  "(old.rec_bool,old.rec_bool)\<in>R\<rightarrow>R\<rightarrow>Id\<rightarrow>R"
  "(op \<longleftrightarrow>, op \<longleftrightarrow>)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "(op \<longrightarrow>, op \<longrightarrow>)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  by (auto split: bool.split simp: rec_bool_is_case)

lemma param_nat1[param]:
  "(0, 0::nat) \<in> Id"
  "(Suc, Suc) \<in> Id \<rightarrow> Id"
  "(1, 1::nat) \<in> Id"
  "(numeral n::nat,numeral n::nat) \<in> Id"
  "(op <, op <::nat \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> Id"
  "(op \<le>, op \<le>::nat \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> Id"
  "(op =, op =::nat \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> Id"
  "(op +::nat\<Rightarrow>_,op +)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "(op -::nat\<Rightarrow>_,op -)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "(op *::nat\<Rightarrow>_,op *)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "(op div::nat\<Rightarrow>_,op div)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "(op mod::nat\<Rightarrow>_,op mod)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  by auto

lemma param_case_nat[param]:
  "(case_nat,case_nat)\<in>Ra \<rightarrow> (Id \<rightarrow> Ra) \<rightarrow> Id \<rightarrow> Ra"
  apply (intro fun_relI)
  apply (auto split: nat.split dest: fun_relD)
  done

lemma param_rec_nat[param]:
  "(rec_nat,rec_nat) \<in> R \<rightarrow> (Id \<rightarrow> R \<rightarrow> R) \<rightarrow> Id \<rightarrow> R"
proof (intro fun_relI, goal_cases)
  case (1 s s' f f' n n') thus ?case
    apply (induct n' arbitrary: n s s')
    apply (fastforce simp: fun_rel_def)+
    done
qed

lemma param_int[param]:
  "(0, 0::int) \<in> Id"
  "(1, 1::int) \<in> Id"
  "(numeral n::int,numeral n::int) \<in> Id"
  "(op <, op <::int \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> Id"
  "(op \<le>, op \<le>::int \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> Id"
  "(op =, op =::int \<Rightarrow> _) \<in> Id \<rightarrow> Id \<rightarrow> Id"
  "(op +::int\<Rightarrow>_,op +)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "(op -::int\<Rightarrow>_,op -)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "(op *::int\<Rightarrow>_,op *)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "(op div::int\<Rightarrow>_,op div)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  "(op mod::int\<Rightarrow>_,op mod)\<in>Id\<rightarrow>Id\<rightarrow>Id"
  by auto

lemma rec_prod_is_case: "old.rec_prod = case_prod"
  by (rule ext)+ (auto split: bool.split)

lemma param_prod[param]:
  "(Pair,Pair)\<in>Ra \<rightarrow> Rb \<rightarrow> \<langle>Ra,Rb\<rangle>prod_rel"
  "(case_prod,case_prod) \<in> (Ra \<rightarrow> Rb \<rightarrow> Rr) \<rightarrow> \<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Rr"
  "(old.rec_prod,old.rec_prod) \<in> (Ra \<rightarrow> Rb \<rightarrow> Rr) \<rightarrow> \<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Rr"
  "(fst,fst)\<in>\<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Ra"
  "(snd,snd)\<in>\<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Rb"
  by (auto dest: fun_relD split: prod.split
    simp: prod_rel_def rec_prod_is_case)

lemma param_case_prod':
  "\<lbrakk> (p,p')\<in>\<langle>Ra,Rb\<rangle>prod_rel;
     \<And>a b a' b'. \<lbrakk> p=(a,b); p'=(a',b'); (a,a')\<in>Ra; (b,b')\<in>Rb \<rbrakk>
      \<Longrightarrow> (f a b, f' a' b')\<in>R
    \<rbrakk> \<Longrightarrow> (case_prod f p, case_prod f' p') \<in> R"
  by (auto split: prod.split)

lemma param_case_prod'': (* TODO: Really needed? *)
  "\<lbrakk>
    \<And>a b a' b'. \<lbrakk>p=(a,b); p'=(a',b')\<rbrakk> \<Longrightarrow> (f a b,f' a' b')\<in>R
  \<rbrakk> \<Longrightarrow> (case_prod f p, case_prod f' p')\<in>R"
  by (auto split: prod.split)

lemma param_map_prod[param]:
  "(map_prod, map_prod)
  \<in> (Ra\<rightarrow>Rb) \<rightarrow> (Rc\<rightarrow>Rd) \<rightarrow> \<langle>Ra,Rc\<rangle>prod_rel \<rightarrow> \<langle>Rb,Rd\<rangle>prod_rel"
  unfolding map_prod_def[abs_def]
  by parametricity

lemma param_apfst[param]:
  "(apfst,apfst)\<in>(Ra\<rightarrow>Rb)\<rightarrow>\<langle>Ra,Rc\<rangle>prod_rel\<rightarrow>\<langle>Rb,Rc\<rangle>prod_rel"
  unfolding apfst_def[abs_def] by parametricity

lemma param_apsnd[param]:
  "(apsnd,apsnd)\<in>(Rb\<rightarrow>Rc)\<rightarrow>\<langle>Ra,Rb\<rangle>prod_rel\<rightarrow>\<langle>Ra,Rc\<rangle>prod_rel"
  unfolding apsnd_def[abs_def] by parametricity

lemma param_curry[param]:
  "(curry,curry) \<in> (\<langle>Ra,Rb\<rangle>prod_rel \<rightarrow> Rc) \<rightarrow> Ra \<rightarrow> Rb \<rightarrow> Rc"
  unfolding curry_def by parametricity

context partial_function_definitions begin
  lemma
    assumes M: "monotone le_fun le_fun F"
    and M': "monotone le_fun le_fun F'"
    assumes ADM:
      "admissible (\<lambda>a. \<forall>x xa. (x, xa) \<in> Rb \<longrightarrow> (a x, fixp_fun F' xa) \<in> Ra)"
    assumes bot: "\<And>x xa. (x, xa) \<in> Rb \<Longrightarrow> (lub {}, fixp_fun F' xa) \<in> Ra"
    assumes F: "(F,F')\<in>(Rb\<rightarrow>Ra)\<rightarrow>Rb\<rightarrow>Ra"
    assumes A: "(x,x')\<in>Rb"
    shows "(fixp_fun F x, fixp_fun F' x')\<in>Ra"
    using A
    apply (induct arbitrary: x x' rule: ccpo.fixp_induct[OF ccpo _ M])
    apply (rule ADM)
    apply(simp add: fun_lub_def bot)
    apply (subst ccpo.fixp_unfold[OF ccpo M'])
    apply (parametricity add: F)
    done
end

lemma param_option[param]:
  "(None,None)\<in>\<langle>R\<rangle>option_rel"
  "(Some,Some)\<in>R \<rightarrow> \<langle>R\<rangle>option_rel"
  "(case_option,case_option)\<in>Rr\<rightarrow>(R \<rightarrow> Rr)\<rightarrow>\<langle>R\<rangle>option_rel \<rightarrow> Rr"
  "(rec_option,rec_option)\<in>Rr\<rightarrow>(R \<rightarrow> Rr)\<rightarrow>\<langle>R\<rangle>option_rel \<rightarrow> Rr"
  by (auto split: option.split
    simp: option_rel_def case_option_def[symmetric]
    dest: fun_relD)

lemma param_case_option':
  "\<lbrakk> (x,x')\<in>\<langle>Rv\<rangle>option_rel;
     \<lbrakk>x=None; x'=None \<rbrakk> \<Longrightarrow> (fn,fn')\<in>R;
     \<And>v v'. \<lbrakk> x=Some v; x'=Some v'; (v,v')\<in>Rv \<rbrakk> \<Longrightarrow> (fs v, fs' v')\<in>R
   \<rbrakk> \<Longrightarrow> (case_option fn fs x, case_option fn' fs' x') \<in> R"
  by (auto split: option.split)

lemma the_paramL: "\<lbrakk>l\<noteq>None; (l,r)\<in>\<langle>R\<rangle>option_rel\<rbrakk> \<Longrightarrow> (the l, the r)\<in>R"
  apply (cases l)
  by (auto elim: option_relE)

lemma the_paramR: "\<lbrakk>r\<noteq>None; (l,r)\<in>\<langle>R\<rangle>option_rel\<rbrakk> \<Longrightarrow> (the l, the r)\<in>R"
  apply (cases l)
  by (auto elim: option_relE)

lemma the_default_param[param]:
  "(the_default, the_default) \<in> R \<rightarrow> \<langle>R\<rangle>option_rel \<rightarrow> R"
  unfolding the_default_def
  by parametricity

lemma rec_sum_is_case: "old.rec_sum = case_sum"
  by (rule ext)+ (auto split: sum.split)

lemma param_sum[param]:
  "(Inl,Inl) \<in> Rl \<rightarrow> \<langle>Rl,Rr\<rangle>sum_rel"
  "(Inr,Inr) \<in> Rr \<rightarrow> \<langle>Rl,Rr\<rangle>sum_rel"
  "(case_sum,case_sum) \<in> (Rl \<rightarrow> R) \<rightarrow> (Rr \<rightarrow> R) \<rightarrow> \<langle>Rl,Rr\<rangle>sum_rel \<rightarrow> R"
  "(old.rec_sum,old.rec_sum) \<in> (Rl \<rightarrow> R) \<rightarrow> (Rr \<rightarrow> R) \<rightarrow> \<langle>Rl,Rr\<rangle>sum_rel \<rightarrow> R"
  by (fastforce split: sum.split dest: fun_relD
    simp: rec_sum_is_case)+

lemma param_case_sum':
  "\<lbrakk> (s,s')\<in>\<langle>Rl,Rr\<rangle>sum_rel;
     \<And>l l'. \<lbrakk> s=Inl l; s'=Inl l'; (l,l')\<in>Rl \<rbrakk> \<Longrightarrow> (fl l, fl' l')\<in>R;
     \<And>r r'. \<lbrakk> s=Inr r; s'=Inr r'; (r,r')\<in>Rr \<rbrakk> \<Longrightarrow> (fr r, fr' r')\<in>R
   \<rbrakk> \<Longrightarrow> (case_sum fl fr s, case_sum fl' fr' s')\<in>R"
  by (auto split: sum.split)

primrec is_Inl where "is_Inl (Inl _) = True" | "is_Inl (Inr _) = False"
primrec is_Inr where "is_Inr (Inr _) = True" | "is_Inr (Inl _) = False"

lemma is_Inl_param[param]: "(is_Inl,is_Inl) \<in> \<langle>Ra,Rb\<rangle>sum_rel \<rightarrow> bool_rel"
  unfolding is_Inl_def by parametricity
lemma is_Inr_param[param]: "(is_Inr,is_Inr) \<in> \<langle>Ra,Rb\<rangle>sum_rel \<rightarrow> bool_rel"
  unfolding is_Inr_def by parametricity

lemma sum_projl_param[param]:
  "\<lbrakk>is_Inl s; (s',s)\<in>\<langle>Ra,Rb\<rangle>sum_rel\<rbrakk>
  \<Longrightarrow> (Sum_Type.sum.projl s',Sum_Type.sum.projl s) \<in> Ra"
  apply (cases s)
  apply (auto elim: sum_relE)
  done

lemma sum_projr_param[param]:
  "\<lbrakk>is_Inr s; (s',s)\<in>\<langle>Ra,Rb\<rangle>sum_rel\<rbrakk>
  \<Longrightarrow> (Sum_Type.sum.projr s',Sum_Type.sum.projr s) \<in> Rb"
  apply (cases s)
  apply (auto elim: sum_relE)
  done

lemma list_rel_append1: "(as @ bs, l) \<in> \<langle>R\<rangle>list_rel
  \<longleftrightarrow> (\<exists>cs ds. l = cs@ds \<and> (as,cs)\<in>\<langle>R\<rangle>list_rel \<and> (bs,ds)\<in>\<langle>R\<rangle>list_rel)"
  apply (simp add: list_rel_def list_all2_append1)
  apply auto
  apply (metis list_all2_lengthD)
  done

lemma list_rel_append2: "(l,as @ bs) \<in> \<langle>R\<rangle>list_rel
  \<longleftrightarrow> (\<exists>cs ds. l = cs@ds \<and> (cs,as)\<in>\<langle>R\<rangle>list_rel \<and> (ds,bs)\<in>\<langle>R\<rangle>list_rel)"
  apply (simp add: list_rel_def list_all2_append2)
  apply auto
  apply (metis list_all2_lengthD)
  done

lemma param_append[param]:
  "(append, append)\<in>\<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
  by (auto simp: list_rel_def list_all2_appendI)

lemma param_list1[param]:
  "(Nil,Nil)\<in>\<langle>R\<rangle>list_rel"
  "(Cons,Cons)\<in>R \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
  "(case_list,case_list)\<in>Rr\<rightarrow>(R\<rightarrow>\<langle>R\<rangle>list_rel\<rightarrow>Rr)\<rightarrow>\<langle>R\<rangle>list_rel\<rightarrow>Rr"
  apply (force dest: fun_relD split: list.split)+
  done

lemma param_rec_list[param]:
  "(rec_list,rec_list)
  \<in> Ra \<rightarrow> (Rb \<rightarrow> \<langle>Rb\<rangle>list_rel \<rightarrow> Ra \<rightarrow> Ra) \<rightarrow> \<langle>Rb\<rangle>list_rel \<rightarrow> Ra"
proof (intro fun_relI, goal_cases)
  case prems: (1 a a' f f' l l')
  from prems(3) show ?case
    using prems(1,2)
    apply (induct arbitrary: a a')
    apply simp
    apply (fastforce dest: fun_relD)
    done
qed

lemma param_case_list':
  "\<lbrakk> (l,l')\<in>\<langle>Rb\<rangle>list_rel;
     \<lbrakk>l=[]; l'=[]\<rbrakk> \<Longrightarrow> (n,n')\<in>Ra;
     \<And>x xs x' xs'. \<lbrakk> l=x#xs; l'=x'#xs'; (x,x')\<in>Rb; (xs,xs')\<in>\<langle>Rb\<rangle>list_rel \<rbrakk>
     \<Longrightarrow> (c x xs, c' x' xs')\<in>Ra
   \<rbrakk> \<Longrightarrow> (case_list n c l, case_list n' c' l') \<in> Ra"
  by (auto split: list.split)

lemma param_map[param]:
  "(map,map)\<in>(R1\<rightarrow>R2) \<rightarrow> \<langle>R1\<rangle>list_rel \<rightarrow> \<langle>R2\<rangle>list_rel"
  unfolding map_rec[abs_def] by (parametricity)

lemma param_fold[param]:
  "(fold,fold)\<in>(Re\<rightarrow>Rs\<rightarrow>Rs) \<rightarrow> \<langle>Re\<rangle>list_rel \<rightarrow> Rs \<rightarrow> Rs"
  "(foldl,foldl)\<in>(Rs\<rightarrow>Re\<rightarrow>Rs) \<rightarrow> Rs \<rightarrow> \<langle>Re\<rangle>list_rel \<rightarrow> Rs"
  "(foldr,foldr)\<in>(Re\<rightarrow>Rs\<rightarrow>Rs) \<rightarrow> \<langle>Re\<rangle>list_rel \<rightarrow> Rs \<rightarrow> Rs"
  unfolding List.fold_def List.foldr_def List.foldl_def
  by (parametricity)+

schematic_goal param_take[param]: "(take,take)\<in>(?R::(_\<times>_) set)"
  unfolding take_def
  by (parametricity)

schematic_goal param_drop[param]: "(drop,drop)\<in>(?R::(_\<times>_) set)"
  unfolding drop_def
  by (parametricity)

schematic_goal param_length[param]:
  "(length,length)\<in>(?R::(_\<times>_) set)"
  unfolding size_list_overloaded_def size_list_def
  by (parametricity)

fun list_eq :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "list_eq eq [] [] \<longleftrightarrow> True"
| "list_eq eq (a#l) (a'#l')
     \<longleftrightarrow> (if eq a a' then list_eq eq l l' else False)"
| "list_eq _ _ _ \<longleftrightarrow> False"

lemma param_list_eq[param]: "
  (list_eq,list_eq) \<in>
    (R \<rightarrow> R \<rightarrow> Id) \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> Id"
proof (intro fun_relI, goal_cases)
  case prems: (1 eq eq' l1 l1' l2 l2')
  thus ?case
    apply -
    apply (induct eq' l1' l2' arbitrary: l1 l2 rule: list_eq.induct)
    apply (simp_all only: list_eq.simps |
      elim list_relE |
      parametricity)+
    done
qed

lemma id_list_eq_aux[simp]: "(list_eq op =) = (op =)"
proof (intro ext)
  fix l1 l2 :: "'a list"
  show "list_eq op = l1 l2 = (l1 = l2)"
    apply (induct "op = :: 'a \<Rightarrow> _" l1 l2 rule: list_eq.induct)
    apply simp_all
    done
qed

lemma param_list_equals[param]:
  "\<lbrakk> (op =, op =) \<in> R\<rightarrow>R\<rightarrow>Id \<rbrakk>
  \<Longrightarrow> (op =, op =) \<in> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> Id"
  unfolding id_list_eq_aux[symmetric]
  by (parametricity)

lemma param_tl[param]:
  "(tl,tl) \<in> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
  unfolding tl_def[abs_def]
  by (parametricity)

primrec list_all_rec where
  "list_all_rec P [] \<longleftrightarrow> True"
| "list_all_rec P (a#l) \<longleftrightarrow> P a \<and> list_all_rec P l"

primrec list_ex_rec where
  "list_ex_rec P [] \<longleftrightarrow> False"
| "list_ex_rec P (a#l) \<longleftrightarrow> P a \<or> list_ex_rec P l"

lemma list_all_rec_eq: "(\<forall>x\<in>set l. P x) = list_all_rec P l"
  by (induct l) auto

lemma list_ex_rec_eq: "(\<exists>x\<in>set l. P x) = list_ex_rec P l"
  by (induct l) auto

lemma param_list_ball[param]:
  "\<lbrakk>(P,P')\<in>(Ra\<rightarrow>Id); (l,l')\<in>\<langle>Ra\<rangle> list_rel\<rbrakk>
    \<Longrightarrow> (\<forall>x\<in>set l. P x, \<forall>x\<in>set l'. P' x) \<in> Id"
  unfolding list_all_rec_eq
  unfolding list_all_rec_def
  by (parametricity)

lemma param_list_bex[param]:
  "\<lbrakk>(P,P')\<in>(Ra\<rightarrow>Id); (l,l')\<in>\<langle>Ra\<rangle> list_rel\<rbrakk>
    \<Longrightarrow> (\<exists>x\<in>set l. P x, \<exists>x\<in>set l'. P' x) \<in> Id"
  unfolding list_ex_rec_eq[abs_def]
  unfolding list_ex_rec_def
  by (parametricity)

lemma param_rev[param]: "(rev,rev) \<in> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
  unfolding rev_def
  by (parametricity)

lemma param_Ball[param]: "(Ball,Ball)\<in>\<langle>Ra\<rangle>set_rel\<rightarrow>(Ra\<rightarrow>Id)\<rightarrow>Id"
  by (auto simp: set_rel_def dest: fun_relD)
lemma param_Bex[param]: "(Bex,Bex)\<in>\<langle>Ra\<rangle>set_rel\<rightarrow>(Ra\<rightarrow>Id)\<rightarrow>Id"
  apply (auto simp: set_rel_def dest: fun_relD)
  apply (drule (1) set_mp)
  apply (erule DomainE)
  apply (auto dest: fun_relD)
  done

lemma param_foldli[param]: "(foldli, foldli)
  \<in> \<langle>Re\<rangle>list_rel \<rightarrow> (Rs\<rightarrow>Id) \<rightarrow> (Re\<rightarrow>Rs\<rightarrow>Rs) \<rightarrow> Rs \<rightarrow> Rs"
  unfolding foldli_def
  by parametricity

lemma param_foldri[param]: "(foldri, foldri)
  \<in> \<langle>Re\<rangle>list_rel \<rightarrow> (Rs\<rightarrow>Id) \<rightarrow> (Re\<rightarrow>Rs\<rightarrow>Rs) \<rightarrow> Rs \<rightarrow> Rs"
  unfolding foldri_def[abs_def]
  by parametricity

lemma param_nth[param]:
  assumes I: "i'<length l'"
  assumes IR: "(i,i')\<in>nat_rel"
  assumes LR: "(l,l')\<in>\<langle>R\<rangle>list_rel"
  shows "(l!i,l'!i') \<in> R"
  using LR I IR
  by (induct arbitrary: i i' rule: list_rel_induct)
     (auto simp: nth.simps split: nat.split)

lemma param_replicate[param]:
  "(replicate,replicate) \<in> nat_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>list_rel"
  unfolding replicate_def by parametricity

term list_update
lemma param_list_update[param]:
  "(list_update,list_update) \<in> \<langle>Ra\<rangle>list_rel \<rightarrow> nat_rel \<rightarrow> Ra \<rightarrow> \<langle>Ra\<rangle>list_rel"
  unfolding list_update_def[abs_def] by parametricity

lemma param_zip[param]:
  "(zip, zip) \<in> \<langle>Ra\<rangle>list_rel \<rightarrow> \<langle>Rb\<rangle>list_rel \<rightarrow> \<langle>\<langle>Ra,Rb\<rangle>prod_rel\<rangle>list_rel"
    unfolding zip_def by parametricity

lemma param_upt[param]:
  "(upt, upt) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>list_rel"
   unfolding upt_def[abs_def] by parametricity

lemma param_concat[param]: "(concat, concat) \<in>
    \<langle>\<langle>R\<rangle>list_rel\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
unfolding concat_def[abs_def] by parametricity

lemma param_all_interval_nat[param]:
  "(List.all_interval_nat, List.all_interval_nat)
  \<in> (nat_rel \<rightarrow> bool_rel) \<rightarrow> nat_rel \<rightarrow> nat_rel \<rightarrow> bool_rel"
  unfolding List.all_interval_nat_def[abs_def]
  apply parametricity
  apply simp
  done

lemma param_dropWhile[param]:
  "(dropWhile, dropWhile) \<in> (a \<rightarrow> bool_rel) \<rightarrow> \<langle>a\<rangle>list_rel \<rightarrow> \<langle>a\<rangle>list_rel"
  unfolding dropWhile_def by parametricity

lemma param_takeWhile[param]:
  "(takeWhile, takeWhile) \<in> (a \<rightarrow> bool_rel) \<rightarrow> \<langle>a\<rangle>list_rel \<rightarrow> \<langle>a\<rangle>list_rel"
  unfolding takeWhile_def by parametricity

subsection {*Sets*}

lemma param_empty[param]:
  "({},{})\<in>\<langle>R\<rangle>set_rel" by (auto simp: set_rel_def)

lemma param_insert[param]:
  "single_valued R \<Longrightarrow> (insert,insert)\<in>R\<rightarrow>\<langle>R\<rangle>set_rel\<rightarrow>\<langle>R\<rangle>set_rel"
  by (auto simp: set_rel_def dest: single_valuedD)

lemma param_union[param]:
  "(op \<union>, op \<union>) \<in> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel"
  by (auto simp: set_rel_def)

lemma param_inter[param]:
  assumes "single_valued (R\<inverse>)"
  shows "(op \<inter>, op \<inter>) \<in> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel"
  using assms by (auto dest: single_valuedD simp: set_rel_def)

lemma param_diff[param]:
  assumes "single_valued (R\<inverse>)"
  shows "(op -, op -) \<in> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel"
  using assms
  by (auto dest: single_valuedD simp: set_rel_def)

lemma param_subseteq[param]:
  "\<lbrakk>single_valued (R\<inverse>)\<rbrakk> \<Longrightarrow> (op \<subseteq>, op \<subseteq>) \<in> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel \<rightarrow> bool_rel"
  by (clarsimp simp: set_rel_def single_valued_def) blast

lemma param_subset[param]:
  "\<lbrakk>single_valued (R\<inverse>)\<rbrakk> \<Longrightarrow> (op \<subset>, op \<subset>) \<in> \<langle>R\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel \<rightarrow> bool_rel"
  (* Fine-tuned proof for speed *)
  apply (simp add: set_rel_def single_valued_def)
  apply safe
  apply blast+
  done

lemma param_set[param]:
  "single_valued Ra \<Longrightarrow> (set,set)\<in>\<langle>Ra\<rangle>list_rel \<rightarrow> \<langle>Ra\<rangle>set_rel"
proof
  fix l l'
  assume A: "single_valued Ra"
  assume "(l,l')\<in>\<langle>Ra\<rangle>list_rel"
  thus "(set l, set l')\<in>\<langle>Ra\<rangle>set_rel"
    apply (induct)
    apply simp
    apply simp
    using A apply (parametricity)
    done
qed

end


(*
  File: Indexed_PQueue_Impl.thy
  Author: Bohua Zhan
*)

section \<open>Implementation of the indexed priority queue\<close>

theory Indexed_PQueue_Impl
  imports DynamicArray "../Functional/Indexed_PQueue"
begin

text \<open>
  Imperative implementation of indexed priority queue. The data structure
  is also verified in \cite{Refine_Imperative_HOL-AFP} by Peter Lammich.
\<close>

datatype 'a indexed_pqueue =
  Indexed_PQueue (pqueue: "(nat \<times> 'a) dynamic_array") (index: "nat option array")
setup \<open>add_simple_datatype "indexed_pqueue"\<close>

fun idx_pqueue :: "'a::heap idx_pqueue \<Rightarrow> 'a indexed_pqueue \<Rightarrow> assn" where
  "idx_pqueue (xs, m) (Indexed_PQueue pq idx) = (dyn_array xs pq * idx \<mapsto>\<^sub>a m)"
setup \<open>add_rewrite_ent_rule @{thm idx_pqueue.simps}\<close>

subsection \<open>Basic operations\<close>

definition idx_pqueue_empty :: "nat \<Rightarrow> 'a::heap indexed_pqueue Heap" where
  "idx_pqueue_empty k = do {
    pq \<leftarrow> dyn_array_new;
    idx \<leftarrow> Array.new k None;
    return (Indexed_PQueue pq idx) }"

lemma idx_pqueue_empty_rule [hoare_triple]:
  "<emp>
   idx_pqueue_empty n
   <idx_pqueue ([], replicate n None)>" by auto2

definition idx_pqueue_nth :: "'a::heap indexed_pqueue \<Rightarrow> nat \<Rightarrow> (nat \<times> 'a) Heap" where
  "idx_pqueue_nth p i = array_nth (pqueue p) i"

lemma idx_pqueue_nth_rule [hoare_triple]:
  "<idx_pqueue (xs, m) p * \<up>(i < length xs)>
   idx_pqueue_nth p i
   <\<lambda>r. idx_pqueue (xs, m) p * \<up>(r = xs ! i)>" by auto2

definition idx_nth :: "'a::heap indexed_pqueue \<Rightarrow> nat \<Rightarrow> nat option Heap" where
  "idx_nth p i = Array.nth (index p) i"

lemma idx_nth_rule [hoare_triple]:
  "<idx_pqueue (xs, m) p * \<up>(i < length m)>
   idx_nth p i
   <\<lambda>r. idx_pqueue (xs, m) p * \<up>(r = m ! i)>" by auto2

definition idx_pqueue_length :: "'a indexed_pqueue \<Rightarrow> nat Heap" where
  "idx_pqueue_length a = array_length (pqueue a)"

lemma idx_pqueue_length_rule [hoare_triple]:
  "<idx_pqueue (xs, m) p>
   idx_pqueue_length p
   <\<lambda>r. idx_pqueue (xs, m) p * \<up>(r = length xs)>" by auto2

definition idx_pqueue_swap ::
  "'a::{heap,linorder} indexed_pqueue \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "idx_pqueue_swap p i j = do {
     pr_i \<leftarrow> array_nth (pqueue p) i;
     pr_j \<leftarrow> array_nth (pqueue p) j;
     Array.upd (fst pr_i) (Some j) (index p);
     Array.upd (fst pr_j) (Some i) (index p);
     array_swap (pqueue p) i j
   }"

lemma idx_pqueue_swap_rule [hoare_triple]:
  "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   idx_pqueue_swap p i j
   <\<lambda>_. idx_pqueue (idx_pqueue_swap_fun (xs, m) i j) p>"
@proof @unfold "idx_pqueue_swap_fun (xs, m) i j" @qed

definition idx_pqueue_push :: "nat \<Rightarrow> 'a::heap \<Rightarrow> 'a indexed_pqueue \<Rightarrow> 'a indexed_pqueue Heap" where
  "idx_pqueue_push k v p = do {
     len \<leftarrow> array_length (pqueue p);
     d' \<leftarrow> push_array (k, v) (pqueue p);
     Array.upd k (Some len) (index p);
     return (Indexed_PQueue d' (index p))
   }"

lemma idx_pqueue_push_rule [hoare_triple]:
  "k < length m \<Longrightarrow> \<not>has_key_alist xs k \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   idx_pqueue_push k v p
   <idx_pqueue (idx_pqueue_push_fun k v (xs, m))>\<^sub>t"
@proof @unfold "idx_pqueue_push_fun k v (xs, m)" @qed

definition idx_pqueue_pop :: "'a::heap indexed_pqueue \<Rightarrow> ((nat \<times> 'a) \<times> 'a indexed_pqueue) Heap" where
  "idx_pqueue_pop p = do {
     (x, d') \<leftarrow> pop_array (pqueue p);
     Array.upd (fst x) None (index p);
     return (x, Indexed_PQueue d' (index p))
   }"

lemma idx_pqueue_pop_rule [hoare_triple]:
  "xs \<noteq> [] \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   idx_pqueue_pop p
   <\<lambda>(x, r). idx_pqueue (idx_pqueue_pop_fun (xs, m)) r * \<up>(x = last xs)>"
@proof @unfold "idx_pqueue_pop_fun (xs, m)" @qed

definition idx_pqueue_array_upd :: "nat \<Rightarrow> 'a \<Rightarrow> 'a::heap dynamic_array \<Rightarrow> unit Heap" where
  "idx_pqueue_array_upd i x d = array_upd i x d"

lemma array_upd_idx_pqueue_rule [hoare_triple]:
  "i < length xs \<Longrightarrow> k = fst (xs ! i) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   idx_pqueue_array_upd i (k, v) (pqueue p)
   <\<lambda>_. idx_pqueue (list_update xs i (k, v), m) p>" by auto2

definition has_key_idx_pqueue :: "nat \<Rightarrow> 'a::{heap,linorder} indexed_pqueue \<Rightarrow> bool Heap" where
  "has_key_idx_pqueue k p = do {
    i_opt \<leftarrow> Array.nth (index p) k;
    return (i_opt \<noteq> None) }"

lemma has_key_idx_pqueue_rule [hoare_triple]:
  "k < length m \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   has_key_idx_pqueue k p
   <\<lambda>r. idx_pqueue (xs, m) p * \<up>(r \<longleftrightarrow> has_key_alist xs k)>" by auto2

setup \<open>del_prfstep_thm @{thm idx_pqueue.simps}\<close>
setup \<open>del_simple_datatype "indexed_pqueue"\<close>

subsection \<open>Bubble up and down\<close>

partial_function (heap) idx_bubble_down :: "'a::{heap,linorder} indexed_pqueue \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "idx_bubble_down a k = do {
    len \<leftarrow> idx_pqueue_length a;
    (if s2 k < len then do {
      vk \<leftarrow> idx_pqueue_nth a k;
      vs1k \<leftarrow> idx_pqueue_nth a (s1 k);
      vs2k \<leftarrow> idx_pqueue_nth a (s2 k);
      (if snd vs1k \<le> snd vs2k then
         if snd vk > snd vs1k then
           do { idx_pqueue_swap a k (s1 k); idx_bubble_down a (s1 k) }
         else return ()
       else
         if snd vk > snd vs2k then
           do { idx_pqueue_swap a k (s2 k); idx_bubble_down a (s2 k) }
         else return ()) }
     else if s1 k < len then do {
       vk \<leftarrow> idx_pqueue_nth a k;
       vs1k \<leftarrow> idx_pqueue_nth a (s1 k);
       (if snd vk > snd vs1k then
          do { idx_pqueue_swap a k (s1 k); idx_bubble_down a (s1 k) }
        else return ()) }
     else return ()) }"

lemma idx_bubble_down_rule [hoare_triple]:
  "index_of_pqueue x \<Longrightarrow>
   <idx_pqueue x a>
   idx_bubble_down a k
   <\<lambda>_. idx_pqueue (idx_bubble_down_fun x k) a>"
@proof @fun_induct "idx_bubble_down_fun x k" @with
  @subgoal "(x = (xs, m), k = k)"
  @unfold "idx_bubble_down_fun (xs, m) k"
  @case "s2 k < length xs" @with
    @case "snd (xs ! s1 k) \<le> snd (xs ! s2 k)"
  @end
  @case "s1 k < length xs" @end
@qed

partial_function (heap) idx_bubble_up :: "'a::{heap,linorder} indexed_pqueue \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "idx_bubble_up a k =
    (if k = 0 then return () else do {
       len \<leftarrow> idx_pqueue_length a;
       (if k < len then do {
          vk \<leftarrow> idx_pqueue_nth a k;
          vpk \<leftarrow> idx_pqueue_nth a (par k);
          (if snd vk < snd vpk then
             do { idx_pqueue_swap a k (par k); idx_bubble_up a (par k) }
           else return ()) }
        else return ())})"

lemma idx_bubble_up_rule [hoare_triple]:
  "index_of_pqueue x \<Longrightarrow>
   <idx_pqueue x a>
   idx_bubble_up a k
   <\<lambda>_. idx_pqueue (idx_bubble_up_fun x k) a>"
@proof @fun_induct "idx_bubble_up_fun x k" @with
  @subgoal "(x = (xs, m), k = k)"
  @unfold "idx_bubble_up_fun (xs, m) k" @end
@qed

subsection \<open>Main operations\<close>

definition delete_min_idx_pqueue :: "'a::{heap,linorder} indexed_pqueue \<Rightarrow> ((nat \<times> 'a) \<times> 'a indexed_pqueue) Heap" where
  "delete_min_idx_pqueue p = do {
     len \<leftarrow> idx_pqueue_length p;
     if len = 0 then raise STR ''delete_min''
     else do {
       idx_pqueue_swap p 0 (len - 1);
       (x', r) \<leftarrow> idx_pqueue_pop p;
       idx_bubble_down r 0;
       return (x', r)
     }
   }"

lemma delete_min_idx_pqueue_rule [hoare_triple]:
  "xs \<noteq> [] \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   delete_min_idx_pqueue p
   <\<lambda>(x, r). idx_pqueue (snd (delete_min_idx_pqueue_fun (xs, m))) r *
       \<up>(x = fst (delete_min_idx_pqueue_fun (xs, m)))>"
@proof @unfold "delete_min_idx_pqueue_fun (xs, m)" @qed

definition insert_idx_pqueue :: "nat \<Rightarrow> 'a::{heap,linorder} \<Rightarrow> 'a indexed_pqueue \<Rightarrow> 'a indexed_pqueue Heap" where
  "insert_idx_pqueue k v p = do {
     p' \<leftarrow> idx_pqueue_push k v p;
     len \<leftarrow> idx_pqueue_length p';
     idx_bubble_up p' (len - 1);
     return p'
   }"

lemma insert_idx_pqueue_rule [hoare_triple]:
  "k < length m \<Longrightarrow> \<not>has_key_alist xs k \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   insert_idx_pqueue k v p
   <idx_pqueue (insert_idx_pqueue_fun k v (xs, m))>\<^sub>t"
@proof @unfold "insert_idx_pqueue_fun k v (xs, m)" @qed

definition update_idx_pqueue ::
  "nat \<Rightarrow> 'a::{heap,linorder} \<Rightarrow> 'a indexed_pqueue \<Rightarrow> 'a indexed_pqueue Heap" where
  "update_idx_pqueue k v p = do {
    i_opt \<leftarrow> idx_nth p k;
    case i_opt of
      None \<Rightarrow> insert_idx_pqueue k v p
    | Some i \<Rightarrow> do {
      x \<leftarrow> idx_pqueue_nth p i;
      idx_pqueue_array_upd i (k, v) (pqueue p);
      (if snd x \<le> v then do {idx_bubble_down p i; return p}
       else do {idx_bubble_up p i; return p}) }}"

lemma update_idx_pqueue_rule [hoare_triple]:
  "k < length m \<Longrightarrow> index_of_pqueue (xs, m) \<Longrightarrow>
   <idx_pqueue (xs, m) p>
   update_idx_pqueue k v p
   <idx_pqueue (update_idx_pqueue_fun k v (xs, m))>\<^sub>t"
@proof @unfold "update_idx_pqueue_fun k v (xs, m)" @qed

subsection \<open>Outer interface\<close>

text \<open>Express Hoare triples for indexed priority queue operations in terms of
  the mapping represented by the queue.\<close>
definition idx_pqueue_map :: "(nat, 'a::{heap,linorder}) map \<Rightarrow> nat \<Rightarrow> 'a indexed_pqueue \<Rightarrow> assn" where
  "idx_pqueue_map M n p = (\<exists>\<^sub>Axs m. idx_pqueue (xs, m) p *
      \<up>(index_of_pqueue (xs, m)) * \<up>(is_heap xs) * \<up>(M = map_of_alist xs) * \<up>(n = length m))"
setup \<open>add_rewrite_ent_rule @{thm idx_pqueue_map_def}\<close>

lemma heap_implies_hd_min2 [resolve]:
  "is_heap xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> (map_of_alist xs)\<langle>k\<rangle> = Some v \<Longrightarrow> snd (hd xs) \<le> v"
@proof
  @obtain i where "i < length xs" "xs ! i = (k, v)"
  @have "snd (hd xs) \<le> snd (xs ! i)"
@qed

theorem idx_pqueue_empty_map [hoare_triple]:
  "<emp>
   idx_pqueue_empty n
   <idx_pqueue_map empty_map n>" by auto2

theorem delete_min_idx_pqueue_map [hoare_triple]:
  "<idx_pqueue_map M n p * \<up>(M \<noteq> empty_map)>
   delete_min_idx_pqueue p
   <\<lambda>(x, r). idx_pqueue_map (delete_map (fst x) M) n r * \<up>(fst x < n) *
                \<up>(is_heap_min (fst x) M) * \<up>(M\<langle>fst x\<rangle> = Some (snd x))>" by auto2

theorem insert_idx_pqueue_map [hoare_triple]:
  "k < n \<Longrightarrow> k \<notin> keys_of M \<Longrightarrow>
   <idx_pqueue_map M n p>
   insert_idx_pqueue k v p
   <idx_pqueue_map (M {k \<rightarrow> v}) n>\<^sub>t" by auto2

theorem has_key_idx_pqueue_map [hoare_triple]:
  "k < n \<Longrightarrow>
   <idx_pqueue_map M n p>
   has_key_idx_pqueue k p
   <\<lambda>r. idx_pqueue_map M n p * \<up>(r \<longleftrightarrow> k \<in> keys_of M)>" by auto2

theorem update_idx_pqueue_map [hoare_triple]:
  "k < n \<Longrightarrow>
   <idx_pqueue_map M n p>
   update_idx_pqueue k v p
   <idx_pqueue_map (M {k \<rightarrow> v}) n>\<^sub>t" by auto2

setup \<open>del_prfstep_thm @{thm idx_pqueue_map_def}\<close>

end


(*
 * Copyright Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Examples
  imports
    Bit_Shifts_Infix_Syntax Next_and_Prev Signed_Division_Word Bitwise
begin

context
  includes bit_operations_syntax
begin

section \<open>\<^typ>\<open>nat\<close>\<close>

lemma
  \<open>bit (1705 :: nat) (Suc (Suc (Suc 0)))\<close>
  by simp

lemma
  \<open>bit (1705 :: nat) 3\<close>
  by simp

lemma
  \<open>\<not> bit (1 :: nat) (Suc (Suc (Suc 0)))\<close>
  by simp

lemma
  \<open>\<not> bit (1 :: nat) 3\<close>
  by simp

lemma
  \<open>(1705 :: nat) AND 42 = 40\<close>
  by simp

lemma
  \<open>(1705 :: nat) AND Suc 0 = 1\<close>
  by simp

lemma
  \<open>(1705 :: nat) OR 42 = 1707\<close>
  by simp

lemma
  \<open>(1705 :: nat) OR Suc 0 = 1705\<close>
  by simp

lemma
  \<open>(1705 :: nat) XOR 42 = 1667\<close>
  by simp

lemma
  \<open>(1705 :: nat) XOR 1 = 1704\<close>
  by simp

lemma
  \<open>push_bit 3 (1705 :: nat) = 13640\<close>
  by simp

lemma
  \<open>push_bit (Suc (Suc (Suc 0))) (1705 :: nat) = 13640\<close>
  by simp

lemma
  \<open>push_bit 3 (Suc 0) = 8\<close>
  by simp

lemma
  \<open>push_bit (Suc (Suc (Suc 0))) (Suc 0) = 8\<close>
  by simp

lemma
  \<open>(1705 :: nat) << 3 = 13640\<close>
  by simp

lemma
  \<open>(1705 :: nat) << Suc (Suc (Suc 0)) = 13640\<close>
  by simp

lemma
  \<open>Suc 0 << 3 = 8\<close>
  by simp

lemma
  \<open>Suc 0 << Suc (Suc (Suc 0)) = 8\<close>
  by simp

lemma
  \<open>drop_bit 3 (1705 :: nat) = 213\<close>
  by simp

lemma
  \<open>drop_bit (Suc (Suc (Suc 0))) (1705 :: nat) = 213\<close>
  by simp

lemma
  \<open>drop_bit 3 (Suc 0) = 0\<close>
  by simp

lemma
  \<open>drop_bit (Suc (Suc (Suc 0))) (Suc 0) = 0\<close>
  by simp

lemma
  \<open>(1705 :: nat) >> 3 = 213\<close>
  by simp

lemma
  \<open>(1705 :: nat) >> Suc (Suc (Suc 0)) = 213\<close>
  by simp

lemma
  \<open>Suc 0 >> 3 = 0\<close>
  by simp

lemma
  \<open>Suc 0 >> Suc (Suc (Suc 0)) = 0\<close>
  by simp

lemma
  \<open>take_bit 3 (1705 :: nat) = 1\<close>
  by simp

lemma
  \<open>take_bit (Suc (Suc (Suc 0))) (1705 :: nat) = 1\<close>
  by (simp flip: add_2_eq_Suc)

lemma
  \<open>take_bit 3 (Suc 0) = 1\<close>
  by simp

lemma
  \<open>take_bit (Suc (Suc (Suc 0))) (Suc 0) = 1\<close>
  by simp

section \<open>\<^typ>\<open>int\<close>\<close>

lemma
  \<open>bit (1705 :: int) (Suc (Suc (Suc 0)))\<close>
  by simp

lemma
  \<open>bit (1705 :: int) 3\<close>
  by simp

lemma
  \<open>\<not> bit (- 1705 :: int) (Suc (Suc (Suc 0)))\<close>
  by simp

lemma
  \<open>\<not> bit (- 1705 :: int) 3\<close>
  by simp

lemma
  \<open>\<not> bit (1 :: int) (Suc (Suc (Suc 0)))\<close>
  by simp

lemma
  \<open>\<not> bit (1 :: int) 3\<close>
  by simp

lemma
  \<open>(NOT 1705 :: int) = - 1706\<close>
  by simp

lemma
  \<open>(NOT (- 42 :: int)) = 41\<close>
  by simp

lemma
  \<open>(NOT 1 :: int) = - 2\<close>
  by simp

lemma
  \<open>(1705 :: int) AND 42 = 40\<close>
  by simp

lemma
  \<open>(1705 :: int) AND - 42 = 1664\<close>
  by simp

lemma
  \<open>(1705 :: int) AND 1 = 1\<close>
  by simp

lemma
  \<open>- (1705 :: int) AND 42 = 2\<close>
  by simp

lemma
  \<open>- (1705 :: int) AND - 42 = - 1706\<close>
  by simp

lemma
  \<open>- (1705 :: int) AND 1 = 1\<close>
  by simp

lemma
  \<open>(1705 :: int) OR 42 = 1707\<close>
  by simp

lemma
  \<open>(1705 :: int) OR - 42 = - 1\<close>
  by simp

lemma
  \<open>(1705 :: int) OR 1 = 1705\<close>
  by simp

lemma
  \<open>- (1705 :: int) OR 42 = - 1665\<close>
  by simp

lemma
  \<open>- (1705 :: int) OR - 42 = - 41\<close>
  by simp

lemma
  \<open>- (1705 :: int) OR 1 = - 1705\<close>
  by simp

lemma
  \<open>(1705 :: int) XOR 42 = 1667\<close>
  by simp

lemma
  \<open>(1705 :: int) XOR - 42 = - 1665\<close>
  by simp

lemma
  \<open>(1705 :: int) XOR 1 = 1704\<close>
  by simp

lemma
  \<open>- (1705 :: int) XOR 42 = - 1667\<close>
  by simp

lemma
  \<open>- (1705 :: int) XOR - 42 = 1665\<close>
  by simp

lemma
  \<open>- (1705 :: int) XOR 1 = - 1706\<close>
  by simp

lemma
  \<open>push_bit 3 (1705 :: int) = 13640\<close>
  by simp

lemma
  \<open>push_bit (Suc (Suc (Suc 0))) (1705 :: int) = 13640\<close>
  by simp

lemma
  \<open>push_bit 3 (- 1705 :: int) = - 13640\<close>
  by simp

lemma
  \<open>push_bit (Suc (Suc (Suc 0))) (- 1705 :: int) = - 13640\<close>
  by simp

lemma
  \<open>push_bit 3 (1 :: int) = 8\<close>
  by simp

lemma
  \<open>push_bit (Suc (Suc (Suc 0))) (1 :: int) = 8\<close>
  by simp

lemma
  \<open>push_bit 3 (- 1 :: int) = - 8\<close>
  by (simp add: mask_eq_exp_minus_1)

lemma
  \<open>push_bit (Suc (Suc (Suc 0))) (- 1 :: int) = - 8\<close>
  by (simp add: mask_eq_exp_minus_1)

lemma
  \<open>(1705 :: int) << 3  = 13640\<close>
  by simp

lemma
  \<open>(1705 :: int) << Suc (Suc (Suc 0)) = 13640\<close>
  by simp

lemma
  \<open>(- 1705 :: int) << 3 = - 13640\<close>
  by simp

lemma
  \<open>(- 1705 :: int) << Suc (Suc (Suc 0)) = - 13640\<close>
  by simp

lemma
  \<open>(1 :: int) << 3 = 8\<close>
  by simp

lemma
  \<open>(1 :: int) << Suc (Suc (Suc 0)) = 8\<close>
  by simp

lemma
  \<open>(- 1 :: int) << 3 = - 8\<close>
  by (simp add: mask_eq_exp_minus_1)

lemma
  \<open>(- 1 :: int) << Suc (Suc (Suc 0)) = - 8\<close>
  by simp

lemma
  \<open>drop_bit 3 (1705 :: int) = 213\<close>
  by simp

lemma
  \<open>drop_bit (Suc (Suc (Suc 0))) (1705 :: int) = 213\<close>
  by simp

lemma
  \<open>drop_bit 3 (- 1705 :: int) = - 214\<close>
  by simp

lemma
  \<open>drop_bit (Suc (Suc (Suc 0))) (- 1705 :: int) = - 214\<close>
  by simp

lemma
  \<open>drop_bit 3 (1 :: int) = 0\<close>
  by simp

lemma
  \<open>drop_bit (Suc (Suc (Suc 0))) (1 :: int) = 0\<close>
  by simp

lemma
  \<open>(1705 :: int) >> 3 = 213\<close>
  by simp

lemma
  \<open>(1705 :: int) >> Suc (Suc (Suc 0)) = 213\<close>
  by simp

lemma
  \<open>(- 1705 :: int) >> 3 = - 214\<close>
  by simp

lemma
  \<open>(- 1705 :: int) >> Suc (Suc (Suc 0)) = - 214\<close>
  by simp

lemma
  \<open>(1 :: int) >> 3 = 0\<close>
  by simp

lemma
  \<open>(1 :: int) >> Suc (Suc (Suc 0)) = 0\<close>
  by simp

lemma
  \<open>take_bit 3 (1705 :: int) = 1\<close>
  by simp

lemma
  \<open>take_bit (Suc (Suc (Suc 0))) (1705 :: int) = 1\<close>
  by (simp flip: add_2_eq_Suc)

lemma
  \<open>take_bit 3 (- 1705 :: int) = 7\<close>
  by simp

lemma
  \<open>take_bit (Suc (Suc (Suc 0))) (- 1705 :: int) = 7\<close>
  by (simp flip: add_2_eq_Suc)

lemma
  \<open>take_bit 3 (1 :: int) = 1\<close>
  by simp

lemma
  \<open>take_bit (Suc (Suc (Suc 0))) (1 :: int) = 1\<close>
  by simp

lemma
  \<open>take_bit 3 (- 1 :: int) = 7\<close>
  by (simp add: mask_eq_exp_minus_1)

lemma
  \<open>take_bit (Suc (Suc (Suc 0))) (- 1 :: int) = 7\<close>
  by (simp add: mask_eq_exp_minus_1)

lemma
  \<open>signed_take_bit 3 (1705 :: int) = - 7\<close>
  by simp

lemma
  \<open>signed_take_bit (Suc (Suc (Suc 0))) (1705 :: int) = - 7\<close>
  by simp

lemma
  \<open>signed_take_bit 3 (- 1705 :: int) = 7\<close>
  by simp

lemma
  \<open>signed_take_bit (Suc (Suc (Suc 0))) (- 1705 :: int) = 7\<close>
  by simp

lemma
  \<open>signed_take_bit 3 (1 :: int) = 1\<close>
  by simp

lemma
  \<open>signed_take_bit (Suc (Suc (Suc 0))) (1 :: int) = 1\<close>
  by simp

section \<open>\<^typ>\<open>'a word\<close>\<close>

lemma
  \<open>(1705 :: 8 word) = 169\<close>
  by simp

lemma
  \<open>(- 1705 :: 8 word) = 87\<close>
  by simp

lemma
  \<open>(257 :: 8 word) = 1\<close>
  by simp

lemma
  \<open>(42 :: 8 word) \<le> 1705\<close>
  by simp

lemma
  \<open>(- 42 :: 8 word) \<le> 230\<close>
  by simp

lemma
  \<open>(42 :: 8 word) \<le> - 1705\<close>
  by simp

lemma
  \<open>- (42 :: 8 word) \<le> 235\<close>
  by simp

lemma
  \<open>(1 :: 8 word) \<le> 1705\<close>
  by simp

lemma
  \<open>(- 1 :: 8 word) \<le> 65535\<close>
  by simp

lemma
  \<open>(42 :: 8 word) < 1705\<close>
  by simp

lemma
  \<open>(- 42 :: 8 word) < 230\<close>
  by simp

lemma
  \<open>(42 :: 8 word) < - 1705\<close>
  by simp

lemma
  \<open>- (42 :: 8 word) < 230\<close>
  by simp

lemma
  \<open>(1 :: 8 word) < 1705\<close>
  by simp

lemma
  \<open>(1705 :: 8 word) < - 1\<close>
  by simp

lemma
  \<open>(42 :: 8 word) \<le>s 1333\<close>
  by simp

lemma
  \<open>(- 42 :: 8 word) \<le>s 230\<close>
  by simp

lemma
  \<open>(42 :: 8 word) \<le>s - 1705\<close>
  by simp

lemma
  \<open>- (42 :: 8 word) \<le>s - 1705\<close>
  by simp

lemma
  \<open>(1 :: 8 word) \<le>s 42\<close>
  by simp

lemma
  \<open>(42 :: 8 word) <s 1333\<close>
  by simp

lemma
  \<open>(- 42 :: 8 word) <s 230\<close>
  by simp

lemma
  \<open>(42 :: 8 word) <s - 1705\<close>
  by simp

lemma
  \<open>- (42 :: 8 word) <s - 1705\<close>
  by simp

lemma
  \<open>(1 :: 8 word) <s 42\<close>
  by simp

lemma
  \<open>bit (1705 :: 16 word) (Suc (Suc (Suc 0)))\<close>
  by simp

lemma
  \<open>bit (1705 :: 16 word) 3\<close>
  by simp

lemma
  \<open>\<not> bit (- 1705 :: 16 word) (Suc (Suc (Suc 0)))\<close>
  by simp

lemma
  \<open>\<not> bit (- 1705 :: 16 word) 3\<close>
  by simp

lemma
  \<open>\<not> bit (1 :: 'a::len word) (Suc (Suc (Suc 0)))\<close>
  by simp

lemma
  \<open>\<not> bit (1 :: 'a::len word) 3\<close>
  by simp

lemma
  \<open>(NOT 1705 :: 'a::len word) = - 1706\<close>
  by simp

lemma
  \<open>(NOT (- 42 :: 'a::len word)) = 41\<close>
  by simp

lemma
  \<open>(NOT 1 :: 'a::len word) = - 2\<close>
  by simp

lemma
  \<open>(1705 :: 'a::len word) AND 42 = 40\<close>
  by simp

lemma
  \<open>(1705 :: 'a::len word) AND - 42 = 1664\<close>
  by simp

lemma
  \<open>(1705 :: 'a::len word) AND 1 = 1\<close>
  by simp

lemma
  \<open>- (1705 :: 'a::len word) AND 42 = 2\<close>
  by simp

lemma
  \<open>- (1705 :: 'a::len word) AND - 42 = - 1706\<close>
  by simp

lemma
  \<open>- (1705 :: 'a::len word) AND 1 = 1\<close>
  by simp

lemma
  \<open>(1705 :: 'a::len word) OR 42 = 1707\<close>
  by simp

lemma
  \<open>(1705 :: 'a::len word) OR - 42 = - 1\<close>
  by simp

lemma
  \<open>(1705 :: 'a::len word) OR 1 = 1705\<close>
  by simp

lemma
  \<open>- (1705 :: 'a::len word) OR 42 = - 1665\<close>
  by simp

lemma
  \<open>- (1705 :: 'a::len word) OR - 42 = - 41\<close>
  by simp

lemma
  \<open>- (1705 :: 'a::len word) OR 1 = - 1705\<close>
  by simp

lemma
  \<open>(1705 :: 'a::len word) XOR 42 = 1667\<close>
  by simp

lemma
  \<open>(1705 :: 'a::len word) XOR - 42 = - 1665\<close>
  by simp

lemma
  \<open>(1705 :: 'a::len word) XOR 1 = 1704\<close>
  by simp

lemma
  \<open>- (1705 :: 'a::len word) XOR 42 = - 1667\<close>
  by simp

lemma
  \<open>- (1705 :: 'a::len word) XOR - 42 = 1665\<close>
  by simp

lemma
  \<open>- (1705 :: 'a::len word) XOR 1 = - 1706\<close>
  by simp

lemma
  \<open>push_bit 3 (1705 :: 'a::len word) = 13640\<close>
  by simp

lemma
  \<open>push_bit (Suc (Suc (Suc 0))) (1705 :: 'a::len word) = 13640\<close>
  by simp

lemma
  \<open>push_bit 3 (- 1705 :: 'a::len word) = - 13640\<close>
  by simp

lemma
  \<open>push_bit (Suc (Suc (Suc 0))) (- 1705 :: 'a::len word) = - 13640\<close>
  by simp

lemma
  \<open>push_bit 3 (1 :: 'a::len word) = 8\<close>
  by simp

lemma
  \<open>push_bit (Suc (Suc (Suc 0))) (1 :: 'a::len word) = 8\<close>
  by simp

lemma
  \<open>push_bit 3 (- 1 :: 'a::len word) = - 8\<close>
  by (simp add: mask_eq_exp_minus_1)

lemma
  \<open>push_bit (Suc (Suc (Suc 0))) (- 1 :: 'a::len word) = - 8\<close>
  by (simp add: mask_eq_exp_minus_1)

lemma
  \<open>(1705 :: 'a::len word) << 3 = 13640\<close>
  by simp

lemma
  \<open>(1705 :: 'a::len word) << Suc (Suc (Suc 0)) = 13640\<close>
  by simp

lemma
  \<open>(- 1705 :: 'a::len word) << 3 = - 13640\<close>
  by simp

lemma
  \<open>(- 1705 :: 'a::len word) << Suc (Suc (Suc 0)) = - 13640\<close>
  by simp

lemma
  \<open>(1 :: 'a::len word) << 3 = 8\<close>
  by simp

lemma
  \<open>(1 :: 'a::len word) << Suc (Suc (Suc 0)) = 8\<close>
  by simp

lemma
  \<open>(- 1 :: 'a::len word) << 3 = - 8\<close>
  by (simp add: mask_eq_exp_minus_1)

lemma
  \<open>(- 1 :: 'a::len word) << Suc (Suc (Suc 0)) = - 8\<close>
  by simp

lemma
  \<open>drop_bit 3 (1705 :: 16 word) = 213\<close>
  by simp

lemma
  \<open>drop_bit (Suc (Suc (Suc 0))) (1705 :: 16 word) = 213\<close>
  by simp

lemma
  \<open>drop_bit 3 (- 1705 :: 16 word) = 7978\<close>
  by simp

lemma
  \<open>drop_bit (Suc (Suc (Suc 0))) (- 1705 :: 16 word) = 7978\<close>
  by simp

lemma
  \<open>drop_bit 3 (1 :: 16 word) = 0\<close>
  by simp

lemma
  \<open>drop_bit (Suc (Suc (Suc 0))) (1 :: 16 word) = 0\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) >> 3 = 213\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) >> Suc (Suc (Suc 0)) = 213\<close>
  by simp

lemma
  \<open>(- 1705 :: 16 word) >> 3 = 7978\<close>
  by simp

lemma
  \<open>(- 1705 :: 16 word) >> Suc (Suc (Suc 0)) = 7978\<close>
  by simp

lemma
  \<open>(1 :: 16 word) >> 3 = 0\<close>
  by simp

lemma
  \<open>(1 :: 16 word) >> Suc (Suc (Suc 0)) = 0\<close>
  by simp

lemma
  \<open>signed_drop_bit 3 (1705 :: 16 word) = 213\<close>
  by simp

lemma
  \<open>signed_drop_bit (Suc (Suc (Suc 0))) (1705 :: 16 word) = 213\<close>
  by simp

lemma
  \<open>signed_drop_bit 3 (- 1705 :: 16 word) = - 214\<close>
  by simp

lemma
  \<open>signed_drop_bit (Suc (Suc (Suc 0))) (- 1705 :: 16 word) = - 214\<close>
  by simp

lemma
  \<open>signed_drop_bit 3 (1 :: 16 word) = 0\<close>
  by simp

lemma
  \<open>signed_drop_bit (Suc (Suc (Suc 0))) (1 :: 16 word) = 0\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) >>> 3 = 213\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) >>> Suc (Suc (Suc 0)) = 213\<close>
  by simp

lemma
  \<open>(- 1705 :: 16 word) >>> 3 = - 214\<close>
  by simp

lemma
  \<open>(- 1705 :: 16 word) >>> Suc (Suc (Suc 0)) = - 214\<close>
  by simp

lemma
  \<open>(1 :: 16 word) >>> 3 = 0\<close>
  by simp

lemma
  \<open>(1 :: 16 word) >>> Suc (Suc (Suc 0)) = 0\<close>
  by simp

lemma
  \<open>take_bit 3 (1705 :: 16 word) = 1\<close>
  by simp

lemma
  \<open>take_bit (Suc (Suc (Suc 0))) (1705 :: 16 word) = 1\<close>
  by (simp flip: add_2_eq_Suc)

lemma
  \<open>take_bit 3 (- 1705 :: 16 word) = 7\<close>
  by simp

lemma
  \<open>take_bit (Suc (Suc (Suc 0))) (- 1705 :: 16 word) = 7\<close>
  by (simp flip: add_2_eq_Suc)

lemma
  \<open>take_bit 3 (1 :: 16 word) = 1\<close>
  by simp

lemma
  \<open>take_bit (Suc (Suc (Suc 0))) (1 :: 16 word) = 1\<close>
  by simp

lemma
  \<open>take_bit 3 (- 1 :: 16 word) = 7\<close>
  by (simp add: mask_eq_exp_minus_1)

lemma
  \<open>take_bit (Suc (Suc (Suc 0))) (- 1 :: 16 word) = 7\<close>
  by (simp add: mask_eq_exp_minus_1)

lemma
  \<open>signed_take_bit 3 (1705 :: 16 word) = - 7\<close>
  by simp

lemma
  \<open>signed_take_bit (Suc (Suc (Suc 0))) (1705 :: 16 word) = - 7\<close>
  by simp

lemma
  \<open>signed_take_bit 3 (- 1705 :: 16 word) = 7\<close>
  by simp

lemma
  \<open>signed_take_bit (Suc (Suc (Suc 0))) (- 1705 :: 16 word) = 7\<close>
  by simp

lemma
  \<open>signed_take_bit 3 (1 :: 16 word) = 1\<close>
  by simp

lemma
  \<open>signed_take_bit (Suc (Suc (Suc 0))) (1 :: 16 word) = 1\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) div 42 = 40\<close>
  by simp

lemma
  \<open>(- 1705 :: 16 word) div 42 = 1519\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) div - 42 = 0\<close>
  by simp

lemma
  \<open>(- 1705 :: 16 word) div - 42 = 0\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) div 1 = 1705\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) div - 1 = 0\<close>
  by simp

lemma
  \<open>(1 :: 16 word) div 42 = 0\<close>
  by simp

lemma
  \<open>(- 1 :: 16 word) div 42 = 1560\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) mod 42 = 25\<close>
  by simp

lemma
  \<open>(- 1705 :: 16 word) mod 42 = 33\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) mod - 42 = 1705\<close>
  by simp

lemma
  \<open>(- 1705 :: 16 word) mod - 42 = 63831\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) mod 1 = 0\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) mod - 1 = 1705\<close>
  by simp

lemma
  \<open>(1 :: 16 word) mod 42 = 1\<close>
  by simp

lemma
  \<open>(- 1 :: 16 word) mod 42 = 15\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) sdiv 42 = 40\<close>
  by simp

lemma
  \<open>(- 1705 :: 16 word) sdiv 42 = 65496\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) sdiv - 42 = 65496\<close>
  by simp

lemma
  \<open>(- 1705 :: 16 word) sdiv - 42 = 40\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) sdiv 1 = 1705\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) sdiv - 1 = 63831\<close>
  by simp

lemma
  \<open>(1 :: 16 word) sdiv 42 = 0\<close>
  by simp

lemma
  \<open>(- 1 :: 16 word) sdiv 42 = 0\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) smod 42 = 25\<close>
  by simp

lemma
  \<open>(- 1705 :: 16 word) smod 42 = 65511\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) smod - 42 = 25\<close>
  by simp

lemma
  \<open>(- 1705 :: 16 word) smod - 42 = 65511\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) smod 1 = 0\<close>
  by simp

lemma
  \<open>(1705 :: 16 word) smod - 1 = 0\<close>
  by simp

lemma
  \<open>(1 :: 16 word) smod 42 = 1\<close>
  by simp

lemma
  \<open>(- 1 :: 16 word) smod 42 = 65535\<close>
  by simp

text "modulus"

lemma "(27 :: 4 word) = -5" by simp

lemma "(27 :: 4 word) = 11" by simp

lemma "27 \<noteq> (11 :: 6 word)" by simp

text "signed"

lemma "(127 :: 6 word) = -1" by simp

text "number ring simps"

lemma
  "27 + 11 = (38::'a::len word)"
  "27 + 11 = (6::5 word)"
  "7 * 3 = (21::'a::len word)"
  "11 - 27 = (-16::'a::len word)"
  "- (- 11) = (11::'a::len word)"
  "-40 + 1 = (-39::'a::len word)"
  by simp_all

lemma "word_pred 2 = 1" by simp

lemma "word_succ (- 3) = -2" by simp

lemma "23 < (27::8 word)" by simp
lemma "23 \<le> (27::8 word)" by simp
lemma "\<not> 23 < (27::2 word)" by simp
lemma "0 < (4::3 word)" by simp
lemma "1 < (4::3 word)" by simp
lemma "0 < (1::3 word)" by simp

text "ring operations"

lemma "a + 2 * b + c - b = (b + c) + (a :: 32 word)" by simp

text "casting"

lemma "uint (234567 :: 10 word) = 71" by simp
lemma "uint (-234567 :: 10 word) = 953" by simp
lemma "sint (234567 :: 10 word) = 71" by simp
lemma "sint (-234567 :: 10 word) = -71" by simp
lemma "uint (1 :: 10 word) = 1" by simp

lemma "unat (-234567 :: 10 word) = 953" by simp
lemma "unat (1 :: 10 word) = 1" by simp

lemma "ucast (0b1010 :: 4 word) = (0b10 :: 2 word)" by simp
lemma "ucast (0b1010 :: 4 word) = (0b1010 :: 10 word)" by simp
lemma "scast (0b1010 :: 4 word) = (0b111010 :: 6 word)" by simp
lemma "ucast (1 :: 4 word) = (1 :: 2 word)" by simp

text "reducing goals to nat or int and arith:"
lemma "i < x \<Longrightarrow> i < i + 1" for i x :: "'a::len word"
  by unat_arith
lemma "i < x \<Longrightarrow> i < i + 1" for i x :: "'a::len word"
  by unat_arith

text "bit operations"

lemma "0b110 AND 0b101 = (0b100 :: 32 word)" by simp
lemma "0b110 OR 0b011 = (0b111 :: 8 word)" by simp
lemma "0xF0 XOR 0xFF = (0x0F :: 8 word)" by simp
lemma "NOT (0xF0 :: 16 word) = 0xFF0F" by simp
lemma "0 AND 5 = (0 :: 8 word)" by simp
lemma "1 AND 1 = (1 :: 8 word)" by simp
lemma "1 AND 0 = (0 :: 8 word)" by simp
lemma "1 AND 5 = (1 :: 8 word)" by simp
lemma "1 OR 6 = (7 :: 8 word)" by simp
lemma "1 OR 1 = (1 :: 8 word)" by simp
lemma "1 XOR 7 = (6 :: 8 word)" by simp
lemma "1 XOR 1 = (0 :: 8 word)" by simp
lemma "NOT 1 = (254 :: 8 word)" by simp
lemma "NOT 0 = (255 :: 8 word)" by simp

lemma "(-1 :: 32 word) = 0xFFFFFFFF" by simp

lemma "bit (0b0010 :: 4 word) 1" by simp
lemma "\<not> bit (0b0010 :: 4 word) 0" by simp
lemma "\<not> bit (0b1000 :: 3 word) 4" by simp
lemma "\<not> bit (1 :: 3 word) 2" by simp

lemma "bit (0b11000 :: 10 word) n = (n = 4 \<or> n = 3)"
  by (auto simp add: bit_numeral_rec bit_1_iff split: nat.splits)

lemma "set_bit 55 7 True = (183::'a::len word)" by simp
lemma "set_bit 0b0010 7 True = (0b10000010::'a::len word)" by simp
lemma "set_bit 0b0010 1 False = (0::'a::len word)" by simp
lemma "set_bit 1 3 True = (0b1001::'a::len word)" by simp
lemma "set_bit 1 0 False = (0::'a::len word)" by simp
lemma "set_bit 0 3 True = (0b1000::'a::len word)" by simp
lemma "set_bit 0 3 False = (0::'a::len word)" by simp

lemma "odd (0b0101::'a::len word)" by simp
lemma "even (0b1000::'a::len word)" by simp
lemma "odd (1::'a::len word)" by simp
lemma "even (0::'a::len word)" by simp

lemma "\<not> msb (0b0101::4 word)" by simp
lemma   "msb (0b1000::4 word)" by simp
lemma "\<not> msb (1::4 word)" by simp
lemma "\<not> msb (0::4 word)" by simp

lemma "word_cat (27::4 word) (27::8 word) = (2843::'a::len word)"
  by simp
lemma "word_cat (0b0011::4 word) (0b1111::6word) = (0b0011001111 :: 10 word)"
  by simp

lemma "0b1011 << 2 = (0b101100::'a::len word)" by simp
lemma "0b1011 >> 2 = (0b10::8 word)" by simp
lemma "0b1011 >>> 2 = (0b10::8 word)" by simp
lemma "1 << 2 = (0b100::'a::len word)" apply simp? oops

lemma "slice 3 (0b101111::6 word) = (0b101::3 word)" by simp
lemma "slice 3 (1::6 word) = (0::3 word)" apply simp? oops

lemma "word_rotr 2 0b0110 = (0b1001::4 word)" by simp
lemma "word_rotl 1 0b1110 = (0b1101::4 word)" by simp
lemma "word_roti 2 0b1110 = (0b1011::4 word)" by simp
lemma "word_roti (- 2) 0b0110 = (0b1001::4 word)" by simp
lemma "word_rotr 2 0 = (0::4 word)" by simp
lemma "word_rotr 2 1 = (0b0100::4 word)" apply simp? oops
lemma "word_rotl 2 1 = (0b0100::4 word)" apply simp? oops
lemma "word_roti (- 2) 1 = (0b0100::4 word)" apply simp? oops

lemma "(x AND 0xff00) OR (x AND 0x00ff) = (x::16 word)"
proof -
  have "(x AND 0xff00) OR (x AND 0x00ff) = x AND (0xff00 OR 0x00ff)"
    by (simp only: word_ao_dist2)
  also have "0xff00 OR 0x00ff = (-1::16 word)"
    by simp
  also have "x AND -1 = x"
    by simp
  finally show ?thesis .
qed

text \<open>singed division\<close>

lemma
  "( 4 :: 32 word) sdiv  4 =  1"
  "(-4 :: 32 word) sdiv  4 = -1"
  "(-3 :: 32 word) sdiv  4 =  0"
  "( 3 :: 32 word) sdiv -4 =  0"
  "(-3 :: 32 word) sdiv -4 =  0"
  "(-5 :: 32 word) sdiv -4 =  1"
  "( 5 :: 32 word) sdiv -4 = -1"
  by (simp_all add: sdiv_word_def signed_divide_int_def)

lemma
  "( 4 :: 32 word) smod  4 =   0"
  "( 3 :: 32 word) smod  4 =   3"
  "(-3 :: 32 word) smod  4 =  -3"
  "( 3 :: 32 word) smod -4 =   3"
  "(-3 :: 32 word) smod -4 =  -3"
  "(-5 :: 32 word) smod -4 =  -1"
  "( 5 :: 32 word) smod -4 =   1"
  by (simp_all add: smod_word_def signed_modulo_int_def signed_divide_int_def)

text \<open>comparison\<close>

lemma "1 < (1024::32 word) \<and> 1 \<le> (1024::32 word)"
  by simp

text "bool lists"

lemma "of_bl [True, False, True, True] = (0b1011::'a::len word)" by simp

lemma "to_bl (0b110::4 word) = [False, True, True, False]" by simp

lemma "of_bl (replicate 32 True) = (0xFFFFFFFF::32 word)"
  by (simp add: numeral_eq_Suc)

text "proofs using bitwise expansion"

lemma "(x AND 0xff00) OR (x AND 0x00ff) = (x::16 word)"
  by word_bitwise

lemma "(x AND NOT 3) >> 4 << 2 = ((x >> 2) AND NOT 3)"
  for x :: "10 word"
  by word_bitwise

lemma "((x AND -8) >> 3) AND 7 = (x AND 56) >> 3"
  for x :: "12 word"
  by word_bitwise

text "some problems require further reasoning after bit expansion"

lemma "x \<le> 42 \<Longrightarrow> x \<le> 89"
  for x :: "8 word"
  apply word_bitwise
  apply blast
  done

lemma "(x AND 1023) = 0 \<Longrightarrow> x \<le> -1024"
  for x :: \<open>32 word\<close>
  apply word_bitwise
  apply clarsimp
  done

text "operations like shifts by non-numerals will expose some internal list
 representations but may still be easy to solve"

lemma shiftr_overflow: "32 \<le> a \<Longrightarrow> b >> a = 0"
  for b :: \<open>32 word\<close>
  apply word_bitwise
  apply simp
  done

(* testing for presence of word_bitwise *)
lemma "((x :: 32 word) >> 3) AND 7 = (x AND 56) >> 3"
  by word_bitwise

end

end


theory Functions_option_manual
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"o_def\", \"id_def\", \"o_assoc\", \"id_neut\", \"inj\",
     \"surj\"]"

consts
X__o__X :: "('b => 'c partial) * ('a => 'b partial) => 'a => 'c partial"
X_id :: "'a => 'a partial" ("id''/'(_')" [3] 999)

axioms
o_def [rule_format] :
"ALL f.
 ALL g.
 X__o__X (f, g) =
 (% x. restrictOp ( f ((makeTotal o g) x)) (defOp (g x)))"

id_def [rule_format] : "X_id = makePartial o (% x. x)"

theorem restrict1 : "restrictOp (restrictOp a (defOp b)) c = restrictOp (restrictOp a c) (defOp (restrictOp b c))"
apply (case_tac c)
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def)
done

theorem restrict_trivial [simp]: "restrictOp t True = t"
apply (simp add: restrictOp_def)
done

theorem restrict_assoc[simp] : "restrictOp a (defOp (restrictOp b c)) = restrictOp (restrictOp a (defOp b)) c"
apply (case_tac c)
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def noneOp_def defOp.simps)
sorry

theorem restrict_out[simp] : "restrictOp (t b) b = restrictOp (t True) b"
apply (case_tac "b")
apply (simp add: restrictOp_def)
apply (simp add: restrictOp_def)
done

theorem mkpartial_cancel [simp]: "makeTotal(makePartial x) = x"
apply (simp add: makeTotal_def makePartial_def)
done

theorem mkpartial_cancel2 [simp]: "defOp(x) ==> makePartial(makeTotal x) = x"
apply (simp add: makeTotal_def makePartial_def)
apply (case_tac x)
apply (simp)
apply (simp)
done

theorem mkpartial_cancel3 [simp] : "((makePartial x) = (makePartial y)) = (x = y)"
apply (simp add: makePartial_def)
done

theorem defOp_trivial [simp]: "defOp(makePartial x) = True"
apply (simp add: makePartial_def makeTotal_def)
done

(* Some more stuff about removing extraneous restrictions *)

theorem total_restrict2 [simp]:
"(c ==> b) ==> restrictOp (t (makeTotal  (restrictOp a b))) c =
	   restrictOp (t (makeTotal a)) c"
apply (simp add: makeTotal_def restrictOp_def defOp.simps undefinedOp_def)
done

theorem def_restrict [simp]:
"defOp (restrictOp a b) = (defOp a & b)"
apply (simp add:  restrictOp_def defOp.simps undefinedOp_def split: split_if)
done

theorem total_restrict [simp]:
"restrictOp (t (makeTotal  (restrictOp a b))) (defOp (restrictOp a b)) =
	   restrictOp (t (makeTotal a)) (defOp a & b)"
apply simp
done

lemma restrictOp_cong [cong]:
  "b = b' ==> (b' ==> a = a') ==> restrictOp a b = restrictOp a' b'"
  apply (simp add: restrictOp_def defOp.simps undefinedOp_def)
done

thm total_restrict

theorem o_assoc :
"X__o__X (f, X__o__X (g, h)) = X__o__X (X__o__X (f, g), h)"
apply (rule ext)
apply (simp add: o_def comp_def)
apply (subst restrict_out [of _ "defOp (h x)"]) back
apply (subst restrict_trivial)
apply (simp)
done

theorem id_neut : "X__o__X (f', X_id) = f'"
by (simp add: o_def comp_def id_def)

theorem restrictOp_add_def: "(restrictOp f b) = (makePartial x) ==> b"
apply (simp add: makePartial_def restrictOp_def)
apply (simp only: noneOp_def)
apply (case_tac b)
apply (auto)
done

theorem restrictOp_mkpartial_defined: "(restrictOp f b) = (makePartial x) ==> f = (makePartial x)"
apply (simp add: makePartial_def restrictOp_def)
apply (simp only: noneOp_def)
apply (case_tac b)
apply (auto)
done

theorem inj  :
" X__o__X (f', f') = X_id ==>  f' x = f' y --> x = y"
apply (rule impI)
apply (rule injD [of X_id])
apply (rule injI)
apply (simp add: o_def comp_def id_def)
apply (drule_tac sym)
apply (frule_tac x = "x" in fun_cong)
apply (drule_tac x = "y" in fun_cong)
apply (simp)
apply (simp (no_asm_simp) add: o_def comp_def id_def)
done

lemma makepartial_intro : "(s=makePartial t) = (defOp(s) & (makeTotal(s)=t))"
apply (rule iffI)
apply (simp add: makePartial_def makeTotal_def)
apply (simp add: makePartial_def)
apply (case_tac "s")
apply (simp add: defOp.simps)
apply (simp add: makeTotal_def)
done

lemma inj_id : "id'(x)=id'(y) ==> x=y"
apply (simp add: id_def)
done

theorem surj  :
"X__o__X (f', f') = X_id --> (ALL x. EX y. f' y = makePartial x)"
apply (rule impI)
apply (rule allI)
apply (rule_tac x="makeTotal (f' x)" in exI)
apply (drule_tac x = "x" in fun_cong)
apply (simp add: o_def comp_def id_def restrictOp_mkpartial_defined)
done

end


theory Noar_Pinkas
imports Cyclic_Group_SPMF Uniform_Sampling
begin

locale Noar_Pinkas_AND_prot_views =
  fixes \<G> :: "'grp cyclic_group" (structure)
  assumes finite_group: "finite (carrier \<G>)"
  and or_gt_0: "0 < Coset.order \<G>"
  and order_q: "q = Coset.order \<G>"
  and prime_field: "a < q \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> coprime a q"
begin

type_synonym 'grp' ddh_ad = "('grp' \<times> 'grp' \<times> 'grp') \<Rightarrow> ('grp' \<times> 'grp' \<times> 'grp') \<Rightarrow> bool spmf"

definition ddh_0 :: "'grp ddh_ad \<Rightarrow>  bool spmf"
where "ddh_0 \<A> = do {
  a \<leftarrow> sample_uniform q;
  b \<leftarrow> sample_uniform q;
  c \<leftarrow> sample_uniform q;
  b \<leftarrow> \<A> (\<^bold>g (^) a, \<^bold>g (^) b, \<^bold>g (^) c) (\<^bold>g (^) a, \<^bold>g (^) b, \<^bold>g (^) (a*b));
  return_spmf b}"

definition ddh_1 :: "'grp ddh_ad \<Rightarrow>  bool spmf"
where "ddh_1 \<A> = do {
  a \<leftarrow> sample_uniform q;
  b \<leftarrow> sample_uniform q;
  c \<leftarrow> sample_uniform q;
  b \<leftarrow> \<A> (\<^bold>g (^) a, \<^bold>g (^) b, \<^bold>g (^) (a*b)) (\<^bold>g (^) a, \<^bold>g (^) b, \<^bold>g (^) c);
  return_spmf b}"

definition ad_ddh :: "'grp ddh_ad \<Rightarrow> real"
where "ad_ddh \<A> = \<bar>spmf (ddh_0 \<A>) True - spmf(ddh_1 \<A>) True\<bar>"

(*The view for the case v = 0*)
definition R1_v_eq_0 :: " ('grp \<times> 'grp \<times> 'grp \<times> 'grp) spmf"
where "R1_v_eq_0 = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  c\<^sub>1 :: nat \<leftarrow> sample_uniform q;
  return_spmf(\<^bold>g (^) a, \<^bold>g (^) b, \<^bold>g (^) (a*b), \<^bold>g (^) c\<^sub>1)}"

(*The view for the case v = 1*)
definition R1_v_eq_1 :: "('grp \<times> 'grp \<times> 'grp \<times> 'grp) spmf"
where "R1_v_eq_1 = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  c\<^sub>0 :: nat \<leftarrow> sample_uniform q;
  return_spmf(\<^bold>g (^) a, \<^bold>g (^) b, \<^bold>g (^) c\<^sub>0 , \<^bold>g (^) (a*b))}"

definition S1 :: " ('grp \<times> 'grp \<times> 'grp \<times> 'grp) spmf"
where "S1 = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  c\<^sub>1 :: nat \<leftarrow> sample_uniform q;
  let c\<^sub>0 = a*b;
  return_spmf(\<^bold>g (^) a, \<^bold>g (^) b, \<^bold>g (^) c\<^sub>0, \<^bold>g (^) c\<^sub>1)}"

(*create the views to give to the adversary to distinguish*)
definition S1_R1_comb_outputs :: " (('grp \<times> 'grp \<times> 'grp \<times> 'grp ) \<times> ('grp \<times> 'grp \<times> 'grp \<times> 'grp )) spmf"
where "S1_R1_comb_outputs = do {
  a \<leftarrow> sample_uniform q;
  b \<leftarrow> sample_uniform q;
  c \<leftarrow> sample_uniform q;
  return_spmf ((\<^bold>g (^) a, \<^bold>g (^) b, \<^bold>g (^) c, \<^bold>g (^) (a*b)), (\<^bold>g (^) a, \<^bold>g (^) b, \<^bold>g (^) (a*b), \<^bold>g (^) c))}"

definition R1_S1_comb_outputs :: " (('grp \<times> 'grp \<times> 'grp \<times> 'grp ) \<times> ('grp \<times> 'grp \<times> 'grp \<times> 'grp )) spmf"
where "R1_S1_comb_outputs = do {
  a \<leftarrow> sample_uniform q;
  b \<leftarrow> sample_uniform q;
  c \<leftarrow> sample_uniform q;
  return_spmf ((\<^bold>g (^) a, \<^bold>g (^) b, \<^bold>g (^) (a*b), \<^bold>g (^) c), (\<^bold>g (^) a, \<^bold>g (^) b, \<^bold>g (^) c, \<^bold>g (^) (a*b)))}"

type_synonym 'grp' dist_ad = "('grp' \<times> 'grp' \<times> 'grp' \<times> 'grp') \<Rightarrow> ('grp' \<times> 'grp' \<times> 'grp' \<times> 'grp') \<Rightarrow> bool spmf"

definition dist_S1_R1 :: "'grp dist_ad \<Rightarrow> bool spmf"
where "dist_S1_R1 \<A> = do {
  (a,b) \<leftarrow> S1_R1_comb_outputs;
  \<A> a b }"

definition dist_R1_S1 :: "'grp dist_ad \<Rightarrow> bool spmf"
where "dist_R1_S1 \<A> = do {
   (a,b) \<leftarrow> R1_S1_comb_outputs;
  \<A> a b }"

(*4-tuple advantage*)
definition ad_dist :: "'grp dist_ad \<Rightarrow> real"
where "ad_dist \<A> = \<bar>spmf (dist_S1_R1 \<A>) True - spmf(dist_R1_S1 \<A>) True\<bar>"

text{*Definitions for party 2 security of NP*}

definition  DDH_SR :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('grp \<times> 'grp \<times> 'grp \<times> 'grp) spmf"
where "DDH_SR x y z = do {
  a :: nat \<leftarrow> sample_uniform (q);
  c :: nat \<leftarrow> sample_uniform (q);
  let x1 = (x*a+c) mod q;
  let x2 = (y*x1 + ((z - y*x) mod q)*a) mod q;
  return_spmf(\<^bold>g, \<^bold>g (^) x1, \<^bold>g (^) y, \<^bold>g (^) x2)}"

definition DDH_SR_ran:: " nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('grp \<times> 'grp \<times> 'grp \<times> 'grp) spmf"
where "DDH_SR_ran x y z = do {
  x1 :: nat \<leftarrow> sample_uniform q;
  x2 \<leftarrow> sample_uniform q;
  return_spmf(\<^bold>g, \<^bold>g (^) x1, \<^bold>g (^) y, \<^bold>g (^) x2)}"

definition DDH_SR_ran':: " nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('grp \<times> 'grp \<times> 'grp \<times> 'grp) spmf"
where "DDH_SR_ran' x y z = do {
  x1 :: nat \<leftarrow> sample_uniform q;
  return_spmf(\<^bold>g, \<^bold>g (^) x1, \<^bold>g (^) y, \<^bold>g (^) ((y*x1 mod q)))}"

lemma DDH_ran'_eq: assumes 1: "(z - y*x) mod q = 0" shows "DDH_SR x y z = DDH_SR_ran' x y z"
proof-
have "DDH_SR x y z  =  do {
  a :: nat \<leftarrow> sample_uniform (q);
  x1 \<leftarrow> map_spmf (\<lambda> c. (x*a+c) mod q) (sample_uniform q);
  let x2 = (y*x1) mod q;
  return_spmf(\<^bold>g, \<^bold>g (^) x1, \<^bold>g (^) y, \<^bold>g (^) x2)}"
    by(simp add: DDH_SR_def 1 bind_map_spmf o_def Let_def)
also have "... =  do {
  a :: nat \<leftarrow> sample_uniform (q);
  x1 \<leftarrow> sample_uniform q;
  let x2 = (y*x1) mod q;
  return_spmf(\<^bold>g, \<^bold>g (^) x1, \<^bold>g (^) y, \<^bold>g (^) x2)}"
    by(simp add: samp_uni_plus_one_time_pad)
also have "... =  do {
  x1 \<leftarrow> sample_uniform q;
  let x2 = (y*x1) mod q;
  return_spmf(\<^bold>g, \<^bold>g (^) x1, \<^bold>g (^) y, \<^bold>g (^) x2)}"
    by(simp add: bind_spmf_const order_q or_gt_0)
ultimately show ?thesis by(simp add: DDH_SR_def DDH_SR_ran'_def)
qed

lemma DDH_ran_eq: assumes 1: "0 < (z - y*x) mod q" shows "DDH_SR x y z = DDH_SR_ran x y z"
proof-
have "DDH_SR x y z = do {
    a :: nat \<leftarrow> sample_uniform (q);
    x1 \<leftarrow> map_spmf(\<lambda> c. (x*a+c) mod q) (sample_uniform q);
    let x2 = (y*x1 + ((z - y*x) mod q)*a) mod q;
    return_spmf(\<^bold>g, \<^bold>g (^) x1, \<^bold>g (^) y, \<^bold>g (^) x2)}"
      by(simp add: Let_def DDH_SR_def or_gt_0 order_q bind_spmf_const map_spmf_conv_bind_spmf)
  also have "... = do {
    a :: nat \<leftarrow> sample_uniform (q);
    x1 \<leftarrow> sample_uniform q;
    let x2 = (y*x1 + ((z - y*x)mod q)*a) mod q;
    return_spmf(\<^bold>g, \<^bold>g (^) x1, \<^bold>g (^) y, \<^bold>g (^) x2)}"
      by(simp add: samp_uni_plus_one_time_pad)
  also have "... = do {
    x1 \<leftarrow> sample_uniform q;
    x2 \<leftarrow> map_spmf(\<lambda> a. (y*x1 + ((z - y*x) mod q)*a) mod q) (sample_uniform q);
    return_spmf(\<^bold>g, \<^bold>g (^) x1, \<^bold>g (^) y, \<^bold>g (^) x2)}"
      apply(simp add: Let_def or_gt_0 order_q bind_spmf_const map_spmf_conv_bind_spmf)
      apply(rewrite bind_commute_spmf[where q="sample_uniform _"])
      by(simp)
  also have "... = do {
    x1 \<leftarrow> sample_uniform q;
    x2 \<leftarrow> map_spmf(\<lambda> a. a) (sample_uniform q);
    return_spmf(\<^bold>g, \<^bold>g (^) x1, \<^bold>g (^) y, \<^bold>g (^) x2)}"
    proof-
      have 3: "(z - y*x) mod q < q"
        by (simp add: or_gt_0 order_q)
      also have 2: "(z - y*x) mod q < q \<Longrightarrow> (z - y*x) mod q \<noteq> 0 \<Longrightarrow> coprime ((z - y*x) mod q) q"
        using prime_field 1 by simp
      then have "coprime ((z - y*x) mod q) q" using 2 1 3 prime_field
        by simp
      ultimately show ?thesis by(simp add: add_mult_one_time_pad)
    qed
ultimately show ?thesis by(simp add: DDH_SR_def DDH_SR_ran_def)
qed

definition S2 :: "bool \<Rightarrow> (bool \<times> nat \<times> nat \<times> nat \<times> nat \<times> 'grp \<times> 'grp \<times> 'grp \<times> 'grp) spmf"
where "S2 v  = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (coprime b q);
  let c\<^sub>v = a*b;
  c\<^sub>v' :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (0 < (c\<^sub>v' - b*a) mod q);
  x1 \<leftarrow> sample_uniform q;
  x2 \<leftarrow> sample_uniform q;
  return_spmf(v, a, b, c\<^sub>v, c\<^sub>v', \<^bold>g (^) b, \<^bold>g (^) x1,  \<^bold>g (^) b,  \<^bold>g (^) x2)}"

definition R2 :: "'grp \<Rightarrow> 'grp \<Rightarrow> bool \<Rightarrow> (bool \<times> nat \<times> nat \<times> nat \<times> nat \<times> 'grp \<times> 'grp \<times> 'grp \<times> 'grp) spmf"
where "R2 m0 m1 v  = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (coprime b q);
  let c\<^sub>v = a*b;
  c\<^sub>v' :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf ( 0 <(c\<^sub>v' - b*a) mod q);
  (g, x, y\<^sub>0, z\<^sub>0') \<leftarrow> DDH_SR a b c\<^sub>v;
  (g, x, y\<^sub>1, z\<^sub>1') \<leftarrow> DDH_SR a b c\<^sub>v';
  let enc_m0 = z\<^sub>0' \<otimes> m0;
  let enc_m1 = z\<^sub>1' \<otimes> m1;
  return_spmf(v, a, b, c\<^sub>v, c\<^sub>v', y\<^sub>0, enc_m0, y\<^sub>1, enc_m1)}"

definition R2_DDH_SR_ran :: "'grp \<Rightarrow> 'grp \<Rightarrow> bool \<Rightarrow> (bool \<times> nat \<times> nat \<times> nat \<times> nat \<times> 'grp \<times> 'grp \<times> 'grp \<times> 'grp) spmf"
where "R2_DDH_SR_ran m0 m1 v  = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (coprime b q);
  let c\<^sub>v = a*b;
  c\<^sub>v' :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (0 < (c\<^sub>v' - b*a) mod q);
  (g, x, y\<^sub>0, z\<^sub>0') \<leftarrow> DDH_SR_ran' a b c\<^sub>v;
  (g, x, y\<^sub>1, z\<^sub>1') \<leftarrow> DDH_SR_ran a b c\<^sub>v';
  let enc_m0 = z\<^sub>0' \<otimes> m0;
  let enc_m1 = z\<^sub>1' \<otimes> m1;
  return_spmf(v, a, b, c\<^sub>v, c\<^sub>v', y\<^sub>0, enc_m0, y\<^sub>1, enc_m1)}"

lemma R2_eq_R2_DDH_SR_ran: "R2 m0 m1 v = R2_DDH_SR_ran m0 m1 v"
proof-
have "R2 m0 m1 v = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (coprime b q);
  let c\<^sub>v = a*b;
  c\<^sub>v' :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf ( 0 < (c\<^sub>v' - b*a) mod q);
  (g, x, y\<^sub>0, z\<^sub>0') \<leftarrow> DDH_SR_ran' a b c\<^sub>v;
  (g, x, y\<^sub>1, z\<^sub>1') \<leftarrow> DDH_SR_ran a b c\<^sub>v';
  let enc_m0 = z\<^sub>0' \<otimes> m0;
  let enc_m1 = z\<^sub>1' \<otimes> m1;
  return_spmf(v, a, b, c\<^sub>v, c\<^sub>v', y\<^sub>0, enc_m0, y\<^sub>1, enc_m1)}"
    by(simp add: R2_def DDH_ran'_eq DDH_ran_eq order_q cong: bind_spmf_cong_simp)
then show ?thesis by(simp add: R2_def R2_DDH_SR_ran_def)
qed

end

locale proofs = Noar_Pinkas_AND_prot_views + cyclic_group \<G>
begin

lemma inf_theoretic_P2: assumes 1: "m0 \<in> carrier \<G>" and 2: "m1 \<in> carrier \<G>" shows "R2 m0 m1 v = S2 v"
proof-
have "R2_DDH_SR_ran m0 m1 v  = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (coprime b q);
  let c\<^sub>v = a*b;
  c\<^sub>v' :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf ( 0 < (c\<^sub>v' - b*a) mod q);
  x1 \<leftarrow> sample_uniform q;
  let z\<^sub>0' =  \<^bold>g (^) (b*x1 mod q);
  x2 :: nat  \<leftarrow> sample_uniform q;
  x3 \<leftarrow> sample_uniform q;
  let z\<^sub>1' =  \<^bold>g (^) x3;
  let enc_m0 = z\<^sub>0' \<otimes> m0;
  let enc_m1 = z\<^sub>1' \<otimes> m1;
  return_spmf(v, a, b, c\<^sub>v, c\<^sub>v', \<^bold>g (^) b, enc_m0,  \<^bold>g (^) b, enc_m1)}"
    by(simp add: Let_def DDH_SR_ran'_def DDH_SR_ran_def R2_DDH_SR_ran_def)
also have "... = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (coprime b q);
  let c\<^sub>v = a*b;
  c\<^sub>v' :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf ( 0 < (c\<^sub>v' - b*a) mod q);
  t \<leftarrow> map_spmf (\<lambda> x1. (b*x1 mod q)) (sample_uniform q) ;
  let z\<^sub>0' =  \<^bold>g (^) t;
  x2 :: nat  \<leftarrow> sample_uniform q;
  x3 :: nat \<leftarrow> sample_uniform q;
  let z\<^sub>1' =  \<^bold>g (^) x3;
  let enc_m0 = z\<^sub>0' \<otimes> m0;
  let enc_m1 = z\<^sub>1' \<otimes> m1;
  return_spmf(v, a, b, c\<^sub>v, c\<^sub>v', \<^bold>g (^) b, enc_m0,  \<^bold>g (^) b, enc_m1)}"
    by(simp add: bind_map_spmf o_def)
also have "... = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (coprime b q);
  let c\<^sub>v = a*b;
  c\<^sub>v' :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf ( 0 < (c\<^sub>v' - b*a) mod q);
  t \<leftarrow> (sample_uniform q) ;
  let z\<^sub>0' =  \<^bold>g (^) t;
  x2 :: nat  \<leftarrow> sample_uniform q;
  x3 :: nat \<leftarrow> sample_uniform q;
  let z\<^sub>1' =  \<^bold>g (^) x3;
  let enc_m0 = z\<^sub>0' \<otimes> m0;
  let enc_m1 = z\<^sub>1' \<otimes> m1;
  return_spmf(v, a, b, c\<^sub>v, c\<^sub>v', \<^bold>g (^) b, enc_m0,  \<^bold>g (^) b, enc_m1)}"
    by(clarsimp simp add: mult_one_time_pad Let_def cong: bind_spmf_cong_simp)
also have "... = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (coprime b q);
  let c\<^sub>v = a*b;
  c\<^sub>v' :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf ( 0 < (c\<^sub>v' - b*a) mod q);
  enc_m0 \<leftarrow> map_spmf (\<lambda>t. \<^bold>g (^) t \<otimes> m0) (sample_uniform q);
  x2 :: nat  \<leftarrow> sample_uniform q;
  x3 :: nat \<leftarrow> sample_uniform q;
  let z\<^sub>1' =  \<^bold>g (^) x3;
  let enc_m1 = z\<^sub>1' \<otimes> m1;
  return_spmf(v, a, b, c\<^sub>v, c\<^sub>v', \<^bold>g (^) b, enc_m0,  \<^bold>g (^) b, enc_m1)}"
    by(simp add: bind_map_spmf o_def)
also have "... = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (coprime b q);
  let c\<^sub>v = a*b;
  c\<^sub>v' :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf ( 0 < (c\<^sub>v' - b*a) mod q);
  enc_m0 \<leftarrow> map_spmf (\<lambda>t. \<^bold>g (^) t ) (sample_uniform q);
  x2 :: nat  \<leftarrow> sample_uniform q;
  x3 :: nat \<leftarrow> sample_uniform q;
  let z\<^sub>1' =  \<^bold>g (^) x3;
  let enc_m1 = z\<^sub>1' \<otimes> m1;
  return_spmf(v, a, b, c\<^sub>v, c\<^sub>v', \<^bold>g (^) b, enc_m0,  \<^bold>g (^) b, enc_m1)}"
    using 1 by(simp add: sample_uniform_one_time_pad order_q)
also have "... = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (coprime b q);
  let c\<^sub>v = a*b;
  c\<^sub>v' :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf ( 0 < (c\<^sub>v' - b*a) mod q);
  t \<leftarrow> sample_uniform q;
  let enc_m0  =  \<^bold>g (^) t;
  x2 :: nat  \<leftarrow> sample_uniform q;
  enc_m1 \<leftarrow> map_spmf (\<lambda> x3. \<^bold>g (^) x3 \<otimes> m1) (sample_uniform q);
  return_spmf(v, a, b, c\<^sub>v, c\<^sub>v', \<^bold>g (^) b, enc_m0,  \<^bold>g (^) b, enc_m1)}"
    by(simp add: bind_map_spmf o_def)
also have "... = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (coprime b q);
  let c\<^sub>v = a*b;
  c\<^sub>v' :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf ( 0 < (c\<^sub>v' - b*a) mod q);
  t \<leftarrow> sample_uniform (Coset.order \<G>);
  let enc_m0  =  \<^bold>g (^) t;
  x2 :: nat  \<leftarrow> sample_uniform q;
  enc_m1 \<leftarrow> map_spmf (\<lambda> x3. \<^bold>g (^) x3) (sample_uniform q);
  return_spmf(v, a, b, c\<^sub>v, c\<^sub>v', \<^bold>g (^) b, enc_m0,  \<^bold>g (^) b, enc_m1)}"
    using 2 by(simp add: sample_uniform_one_time_pad order_q)
also have "... = do {
  a :: nat \<leftarrow> sample_uniform q;
  b :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf (coprime b q);
  let c\<^sub>v = a*b;
  c\<^sub>v' :: nat \<leftarrow> sample_uniform q;
  _ :: unit \<leftarrow> assert_spmf ( 0 < (c\<^sub>v' - b*a) mod q);
  t \<leftarrow> sample_uniform q;
  let enc_m0  =  \<^bold>g (^) t;
  x3 \<leftarrow> sample_uniform q;
  let enc_m1 =  \<^bold>g (^) x3;
  return_spmf(v, a, b, c\<^sub>v, c\<^sub>v', \<^bold>g (^) b, enc_m0,  \<^bold>g (^) b, enc_m1)}"
    by(simp add: bind_map_spmf o_def or_gt_0 bind_spmf_const order_q)
ultimately show ?thesis by(simp add: S2_def R2_eq_R2_DDH_SR_ran)
qed

(*Security for the case for v = 0*)
lemma sec_S1_R1_v_eq_0: "R1_v_eq_0 = S1"
by(simp add: R1_v_eq_0_def S1_def)

(*case v=1 -reduce to DDH assumption*)
type_synonym 'grp' adversary = "('grp' \<times> 'grp' \<times> 'grp' \<times> 'grp') \<Rightarrow> ('grp' \<times> 'grp' \<times> 'grp' \<times> 'grp') \<Rightarrow> bool spmf"

(*The adversary we use to 'break' the DDH assumption*)
fun A :: "'grp adversary \<Rightarrow> ('grp \<times> 'grp \<times> 'grp) \<Rightarrow> ('grp \<times> 'grp \<times> 'grp) \<Rightarrow> bool spmf"
where "A \<A> (a0, b0, c0) (a1, b1, c1) = do {
  b \<leftarrow> \<A> (a0, b0, c0, c1) (a1, b1, c1, c0);
  return_spmf(b)}"

lemma sec_sender: "ad_ddh (A \<A>) = ad_dist \<A>"
unfolding ad_ddh_def ad_dist_def ddh_0_def ddh_1_def dist_R1_S1_def dist_S1_R1_def S1_def R1_v_eq_1_def S1_R1_comb_outputs_def R1_S1_comb_outputs_def
by(simp)

end
end