theory Semi_Honest imports
  CryptHOL.CryptHOL
begin

locale semi_honest_det_correctness =
  fixes funct :: "'input list \<Rightarrow> 'output list"
    and protocol :: "'input list \<Rightarrow> 'output list spmf"
    and valid_inputs :: "'input list \<Rightarrow> bool"
begin

definition "correctness inputs \<equiv> (valid_inputs inputs \<longrightarrow> return_spmf (funct inputs) = protocol inputs)"

end

locale semi_honest_det_security = protocol: semi_honest_det_correctness funct protocol valid_inputs
  for funct :: "'input list \<Rightarrow> 'output list"
    and protocol :: "'input list \<Rightarrow> 'output list spmf"
    and valid_inputs :: "'input list \<Rightarrow> bool"
    +
  fixes i :: nat
    and R :: "'input list \<Rightarrow> 'view spmf"
    \<comment> \<open>the randomness and messages of the ith party, the real view without the inputs appended to start\<close>
    and S :: "'input \<Rightarrow> 'output \<Rightarrow> 'view spmf"
    \<comment> \<open>the randomness and messages of the ith party conostructed by the simulator\<close>
begin

definition real_view :: "'input list \<Rightarrow> ('input \<times> 'view) spmf"
  where "real_view inputs = do {
            view \<leftarrow> R inputs;
            return_spmf (inputs ! i, view)}"

definition ideal_view :: "'input \<Rightarrow> 'output \<Rightarrow> ('input \<times> 'view) spmf"
  where "ideal_view input out = do {
          view \<leftarrow> S input out;
          return_spmf (input, view)}"

sublocale protocol: semi_honest_det_correctness funct protocol valid_inputs .

definition advantage :: "'input list \<Rightarrow> (('input \<times> 'view) \<Rightarrow> bool spmf) \<Rightarrow> real"
  where "advantage inputs D \<equiv> \<bar>spmf (real_view inputs \<bind> D) True
              - spmf (return_spmf (funct inputs) \<bind> (\<lambda> outputs. ideal_view (nth inputs i) (nth outputs i) \<bind> D)) True\<bar>"

definition "perfect_security inputs \<equiv>
                (valid_inputs inputs \<longrightarrow> real_view inputs
                    = return_spmf (funct inputs) \<bind> (\<lambda> outputs. ideal_view (nth inputs i) (nth outputs i)))"

lemma view_equal:
  assumes
    "R inputs \<bind> (\<lambda>view :: 'view. return_spmf (inputs ! i, view))
      = S (inputs ! i) (funct inputs ! i) \<bind> (\<lambda>view. return_spmf (inputs ! i, view))"
  shows "R inputs = S (inputs ! i) (funct inputs ! i)"
proof -
  have "R inputs = map_spmf snd (R inputs \<bind> (\<lambda>view :: 'view. return_spmf (inputs ! i, view)))"
    by(simp add: map_bind_spmf o_def)
  also note assms
  also have "map_spmf snd (S (inputs ! i) (funct inputs ! i) \<bind> (\<lambda>view. return_spmf (inputs ! i, view))) = S (inputs ! i) (funct inputs ! i)"
    by(simp add: map_bind_spmf o_def)
  finally show ?thesis .
qed

lemma perfect_sec_views_equal:
  shows "perfect_security inputs \<longrightarrow> valid_inputs inputs
             \<longrightarrow> R inputs  = return_spmf (funct inputs) \<bind> (\<lambda>  outputs. S (inputs ! i) (outputs ! i))"
  unfolding perfect_security_def ideal_view_def real_view_def by(auto simp add: view_equal)

lemma views_equal_all: shows
"\<forall> inputs. perfect_security inputs \<longrightarrow> valid_inputs inputs \<longrightarrow> R inputs  = return_spmf (funct inputs) \<bind> (\<lambda>  outputs. S (inputs ! i) (outputs ! i))"
  using perfect_sec_views_equal by blast

lemma perfect_security_imp_advanage_0:
  assumes "valid_inputs inputs"
    and "perfect_security inputs"
  shows "advantage inputs = 0"
  unfolding advantage_def using assms
  by(auto simp add: perfect_security_def advantage_def assms)

end

locale semi_honest_prob =
  fixes i :: nat
    and funct :: "'input list \<Rightarrow> ('output list) spmf"
    and outputs :: "'input list \<Rightarrow> 'view \<Rightarrow> ('output list) spmf"
    and R :: "'input list \<Rightarrow> 'view spmf"
    \<comment> \<open>the randomness and messages of the ith party, the real view without the inputs appended to start\<close>
    and S :: "'input \<Rightarrow> 'output \<Rightarrow> 'view spmf"
    \<comment> \<open>the randomness and messages of the ith party conostructed by the simulator\<close>
    and valid_inputs :: "'input list \<Rightarrow> bool"
begin

definition real_view :: "'input list \<Rightarrow> ('input \<times> 'view \<times> 'output list) spmf"
  where "real_view inputs = do {
    view \<leftarrow> R inputs;
    outputs :: 'output list \<leftarrow> outputs inputs view;
    return_spmf (inputs ! i, view, outputs)}"

definition ideal_view :: "'input list \<Rightarrow> ('input \<times> 'view \<times> 'output list) spmf"
  where "ideal_view inputs = do {
   outputs :: 'output list \<leftarrow> funct inputs;
   view  \<leftarrow> S (nth inputs i) (nth outputs i);
   return_spmf (inputs ! i, view, outputs)}"

definition "perfect_security inputs \<equiv> (valid_inputs inputs \<longrightarrow> real_view inputs = ideal_view inputs)"

definition advantage :: "'input list \<Rightarrow> (('input \<times> 'view \<times> 'output list) \<Rightarrow> bool spmf) \<Rightarrow> real"
  where "advantage inputs D \<equiv> \<bar>spmf (real_view inputs \<bind> D) True - spmf (ideal_view inputs \<bind> D) True\<bar>"

end

locale semi_honest_det_imp_non_det =
  det_protocol_correctness: semi_honest_det_correctness funct protocol valid_inputs +
  det_protocol_security: semi_honest_det_security funct protocol valid_inputs i real_view ideal_view
  for funct :: "'input list \<Rightarrow> 'output list"
    and protocol :: "'input list \<Rightarrow> 'output list spmf"
    and valid_inputs :: "'input list \<Rightarrow> bool"
    and i :: nat
    and real_view :: "'input list \<Rightarrow> 'view spmf"
    and ideal_view :: "'input \<Rightarrow> 'output \<Rightarrow> 'view spmf"
    +
  assumes correct: "det_protocol_correctness.correctness inputs"
begin

definition funct_non_det :: "'input list \<Rightarrow> 'output list spmf"
  where "funct_non_det inputs = return_spmf (funct inputs)"

definition outputs :: "'input list \<Rightarrow> 'a \<Rightarrow> 'output list spmf"
  where "outputs inputs view = protocol inputs"

sublocale semi_honest_prob: semi_honest_prob i funct_non_det outputs real_view ideal_view valid_inputs .

lemma correct_sym: "valid_inputs inputs \<longrightarrow> protocol inputs = return_spmf (funct inputs)"
  using correct[unfolded det_protocol_correctness.correctness_def] by simp

(*quote Lindell, p8 (How to simulate it)
"observe that the distinguisher is given the indices x,y [inputs] of the ensemble and so can compute f(x,y) by itself"*)

definition adversary :: "'input list \<Rightarrow> ('input \<times> 'view \<times> 'output list \<Rightarrow> bool spmf) \<Rightarrow> ('input \<times> 'view) \<Rightarrow> bool spmf"
  where
    "adversary inputs D view = do {
      let (input,  v) = view;
      D (input, v, funct inputs)}"

lemma det_secure_imp_non_det_secure:
  fixes inputs
  assumes "valid_inputs inputs"
  shows "det_protocol_security.advantage inputs (adversary inputs D) = semi_honest_prob.advantage inputs D"
  unfolding semi_honest_prob.advantage_def det_protocol_security.advantage_def semi_honest_prob.real_view_def
            semi_honest_prob.ideal_view_def funct_non_det_def outputs_def det_protocol_security.real_view_def
            det_protocol_security.ideal_view_def adversary_def
  using correct_sym[of inputs] assms by auto

end

subsubsection \<open> Secret sharing schemes \<close>

locale secret_sharing_scheme =
  fixes share :: "'input_out \<Rightarrow> ('share \<times> 'share) spmf"
    and reconstruct :: "('share \<times> 'share) \<Rightarrow> 'input_out spmf"
    and F :: "('input_out \<Rightarrow> 'input_out \<Rightarrow> 'input_out spmf) set"
begin

definition "sharing_correct input \<equiv> (share input \<bind> (\<lambda> (s1,s2). reconstruct (s1,s2)) = return_spmf input)"

definition "correct_share_eval input1 input2 \<equiv> (\<forall> gate_eval \<in> F.
              \<exists> gate_protocol :: ('share \<times> 'share) \<Rightarrow> ('share \<times> 'share) \<Rightarrow> ('share \<times> 'share) spmf.
                  share input1 \<bind> (\<lambda> (s1,s2). share input2
                      \<bind> (\<lambda> (s3,s4). gate_protocol (s1,s3) (s2,s4)
                          \<bind> (\<lambda> (S1,S2). reconstruct (S1,S2)))) = gate_eval input1 input2)"

end

end


section "Soundness"

theory Soundness imports Completeness begin

lemma permutation_validS: "mset fs = mset gs --> (validS fs = validS gs)"
  apply(simp add: validS_def)
  apply(simp add: evalS_def)
  using mset_eq_setD apply blast
  done

lemma modelAssigns_vblcase: "phi \<in> modelAssigns M \<Longrightarrow>  x \<in> objects M \<Longrightarrow> vblcase x phi \<in> modelAssigns M"
  apply (simp add: modelAssigns_def, rule)
  apply(erule_tac rangeE)
  apply(case_tac xaa rule: vbl_casesE, auto)
  done

lemma tmp: "(!x : A. P x | Q) ==> (! x : A. P x) | Q " by blast

lemma soundnessFAll: "!!Gamma.
  [| u ~: freeVarsFL (FAll Pos A # Gamma);
  validS (instanceF u A # Gamma) |]
  ==> validS (FAll Pos A # Gamma)"
  apply (simp add: validS_def, rule)
  apply (drule_tac x=M in spec, rule)
  apply(simp add: evalF_instance)
  apply (rule tmp, rule)
  apply(drule_tac x="% y. if y = u then x else phi y" in bspec)
   apply(simp add: modelAssigns_def) apply force
  apply(erule disjE)
   apply (rule disjI1, simp)
   apply(subgoal_tac "evalF M (vblcase x (\<lambda>y. if y = u then x else phi y)) A = evalF M (vblcase x phi) A")
    apply force
   apply(rule evalF_equiv)
   apply(rule equalOn_vblcaseI)
    apply(rule,rule)
   apply(simp add: freeVarsFL_cons)
   apply (rule equalOnI, force)
  apply(rule disjI2)
  apply(subgoal_tac "evalS M (\<lambda>y. if y = u then x else phi y) Gamma = evalS M phi Gamma")
   apply force
  apply(rule evalS_equiv)
  apply(rule equalOnI)
  apply(force simp: freeVarsFL_cons)
  done

lemma soundnessFEx: "validS (instanceF x A # Gamma) ==> validS (FAll Neg A # Gamma)"
  apply(simp add: validS_def)
  apply (simp add: evalF_instance, rule, rule)
  apply(drule_tac x=M in spec)
  apply (drule_tac x=phi in bspec, assumption)
  apply(erule disjE)
  apply(rule disjI1)
  apply (rule_tac x="phi x" in bexI, assumption)
  apply(force dest: modelAssignsD subsetD)
  apply (rule disjI2, assumption)
  done

lemma soundnessFCut: "[| validS (C # Gamma); validS (FNot C # Delta) |] ==> validS (Gamma @ Delta)"
(*  apply(force simp: validS_def evalS_append evalS_cons evalF_FNot)*)
  apply (simp add: validS_def, rule, rule)
  apply(drule_tac x=M in spec)
  apply(drule_tac x=M in spec)
  apply(drule_tac x=phi in bspec) apply assumption
  apply(drule_tac x=phi in bspec) apply assumption
  apply (simp add: evalS_append evalF_FNot, blast)
  done

lemma completeness: "fs : deductions (PC) = validS fs"
  apply rule
   apply(rule soundness) apply assumption
  apply(subgoal_tac "fs : deductions CutFreePC")
   apply(rule subsetD) prefer 2 apply assumption
   apply(rule mono_deductions)
   apply(simp add: PC_def CutFreePC_def) apply blast
  apply(rule adequacy)
  by assumption

end


(*  Title:      HOL/Library/Quotient_List.thy
    Author:     Cezary Kaliszyk and Christian Urban
*)

section {* Quotient infrastructure for the list type *}

theory Quotient_List
imports Main Quotient_Set Quotient_Product Quotient_Option
begin

subsection {* Rules for the Quotient package *}

lemma map_id [id_simps]:
  "map id = id"
  by (fact List.map.id)

lemma list_all2_eq [id_simps]:
  "list_all2 (op =) = (op =)"
proof (rule ext)+
  fix xs ys
  show "list_all2 (op =) xs ys \<longleftrightarrow> xs = ys"
    by (induct xs ys rule: list_induct2') simp_all
qed

lemma reflp_list_all2:
  assumes "reflp R"
  shows "reflp (list_all2 R)"
proof (rule reflpI)
  from assms have *: "\<And>xs. R xs xs" by (rule reflpE)
  fix xs
  show "list_all2 R xs xs"
    by (induct xs) (simp_all add: *)
qed

lemma list_symp:
  assumes "symp R"
  shows "symp (list_all2 R)"
proof (rule sympI)
  from assms have *: "\<And>xs ys. R xs ys \<Longrightarrow> R ys xs" by (rule sympE)
  fix xs ys
  assume "list_all2 R xs ys"
  then show "list_all2 R ys xs"
    by (induct xs ys rule: list_induct2') (simp_all add: *)
qed

lemma list_transp:
  assumes "transp R"
  shows "transp (list_all2 R)"
proof (rule transpI)
  from assms have *: "\<And>xs ys zs. R xs ys \<Longrightarrow> R ys zs \<Longrightarrow> R xs zs" by (rule transpE)
  fix xs ys zs
  assume "list_all2 R xs ys" and "list_all2 R ys zs"
  then show "list_all2 R xs zs"
    by (induct arbitrary: zs) (auto simp: list_all2_Cons1 intro: *)
qed

lemma list_equivp [quot_equiv]:
  "equivp R \<Longrightarrow> equivp (list_all2 R)"
  by (blast intro: equivpI reflp_list_all2 list_symp list_transp elim: equivpE)

lemma list_quotient3 [quot_thm]:
  assumes "Quotient3 R Abs Rep"
  shows "Quotient3 (list_all2 R) (map Abs) (map Rep)"
proof (rule Quotient3I)
  from assms have "\<And>x. Abs (Rep x) = x" by (rule Quotient3_abs_rep)
  then show "\<And>xs. map Abs (map Rep xs) = xs" by (simp add: comp_def)
next
  from assms have "\<And>x y. R (Rep x) (Rep y) \<longleftrightarrow> x = y" by (rule Quotient3_rel_rep)
  then show "\<And>xs. list_all2 R (map Rep xs) (map Rep xs)"
    by (simp add: list_all2_map1 list_all2_map2 list_all2_eq)
next
  fix xs ys
  from assms have "\<And>x y. R x x \<and> R y y \<and> Abs x = Abs y \<longleftrightarrow> R x y" by (rule Quotient3_rel)
  then show "list_all2 R xs ys \<longleftrightarrow> list_all2 R xs xs \<and> list_all2 R ys ys \<and> map Abs xs = map Abs ys"
    by (induct xs ys rule: list_induct2') auto
qed

declare [[mapQ3 list = (list_all2, list_quotient3)]]

lemma cons_prs [quot_preserve]:
  assumes q: "Quotient3 R Abs Rep"
  shows "(Rep ---> (map Rep) ---> (map Abs)) (op #) = (op #)"
  by (auto simp add: fun_eq_iff comp_def Quotient3_abs_rep [OF q])

lemma cons_rsp [quot_respect]:
  assumes q: "Quotient3 R Abs Rep"
  shows "(R ===> list_all2 R ===> list_all2 R) (op #) (op #)"
  by auto

lemma nil_prs [quot_preserve]:
  assumes q: "Quotient3 R Abs Rep"
  shows "map Abs [] = []"
  by simp

lemma nil_rsp [quot_respect]:
  assumes q: "Quotient3 R Abs Rep"
  shows "list_all2 R [] []"
  by simp

lemma map_prs_aux:
  assumes a: "Quotient3 R1 abs1 rep1"
  and     b: "Quotient3 R2 abs2 rep2"
  shows "(map abs2) (map ((abs1 ---> rep2) f) (map rep1 l)) = map f l"
  by (induct l)
     (simp_all add: Quotient3_abs_rep[OF a] Quotient3_abs_rep[OF b])

lemma map_prs [quot_preserve]:
  assumes a: "Quotient3 R1 abs1 rep1"
  and     b: "Quotient3 R2 abs2 rep2"
  shows "((abs1 ---> rep2) ---> (map rep1) ---> (map abs2)) map = map"
  and   "((abs1 ---> id) ---> map rep1 ---> id) map = map"
  by (simp_all only: fun_eq_iff map_prs_aux[OF a b] comp_def)
    (simp_all add: Quotient3_abs_rep[OF a] Quotient3_abs_rep[OF b])

lemma map_rsp [quot_respect]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "((R1 ===> R2) ===> (list_all2 R1) ===> list_all2 R2) map map"
  and   "((R1 ===> op =) ===> (list_all2 R1) ===> op =) map map"
  unfolding list_all2_eq [symmetric] by (rule list.map_transfer)+

lemma foldr_prs_aux:
  assumes a: "Quotient3 R1 abs1 rep1"
  and     b: "Quotient3 R2 abs2 rep2"
  shows "abs2 (foldr ((abs1 ---> abs2 ---> rep2) f) (map rep1 l) (rep2 e)) = foldr f l e"
  by (induct l) (simp_all add: Quotient3_abs_rep[OF a] Quotient3_abs_rep[OF b])

lemma foldr_prs [quot_preserve]:
  assumes a: "Quotient3 R1 abs1 rep1"
  and     b: "Quotient3 R2 abs2 rep2"
  shows "((abs1 ---> abs2 ---> rep2) ---> (map rep1) ---> rep2 ---> abs2) foldr = foldr"
  apply (simp add: fun_eq_iff)
  by (simp only: fun_eq_iff foldr_prs_aux[OF a b])
     (simp)

lemma foldl_prs_aux:
  assumes a: "Quotient3 R1 abs1 rep1"
  and     b: "Quotient3 R2 abs2 rep2"
  shows "abs1 (foldl ((abs1 ---> abs2 ---> rep1) f) (rep1 e) (map rep2 l)) = foldl f e l"
  by (induct l arbitrary:e) (simp_all add: Quotient3_abs_rep[OF a] Quotient3_abs_rep[OF b])

lemma foldl_prs [quot_preserve]:
  assumes a: "Quotient3 R1 abs1 rep1"
  and     b: "Quotient3 R2 abs2 rep2"
  shows "((abs1 ---> abs2 ---> rep1) ---> rep1 ---> (map rep2) ---> abs1) foldl = foldl"
  by (simp add: fun_eq_iff foldl_prs_aux [OF a b])

(* induct_tac doesn't accept 'arbitrary', so we manually 'spec' *)
lemma foldl_rsp[quot_respect]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "((R1 ===> R2 ===> R1) ===> R1 ===> list_all2 R2 ===> R1) foldl foldl"
  by (rule foldl_transfer)

lemma foldr_rsp[quot_respect]:
  assumes q1: "Quotient3 R1 Abs1 Rep1"
  and     q2: "Quotient3 R2 Abs2 Rep2"
  shows "((R1 ===> R2 ===> R2) ===> list_all2 R1 ===> R2 ===> R2) foldr foldr"
  by (rule foldr_transfer)

lemma list_all2_rsp:
  assumes r: "\<forall>x y. R x y \<longrightarrow> (\<forall>a b. R a b \<longrightarrow> S x a = T y b)"
  and l1: "list_all2 R x y"
  and l2: "list_all2 R a b"
  shows "list_all2 S x a = list_all2 T y b"
  using l1 l2
  by (induct arbitrary: a b rule: list_all2_induct,
    auto simp: list_all2_Cons1 list_all2_Cons2 r)

lemma [quot_respect]:
  "((R ===> R ===> op =) ===> list_all2 R ===> list_all2 R ===> op =) list_all2 list_all2"
  by (rule list.rel_transfer)

lemma [quot_preserve]:
  assumes a: "Quotient3 R abs1 rep1"
  shows "((abs1 ---> abs1 ---> id) ---> map rep1 ---> map rep1 ---> id) list_all2 = list_all2"
  apply (simp add: fun_eq_iff)
  apply clarify
  apply (induct_tac xa xb rule: list_induct2')
  apply (simp_all add: Quotient3_abs_rep[OF a])
  done

lemma [quot_preserve]:
  assumes a: "Quotient3 R abs1 rep1"
  shows "(list_all2 ((rep1 ---> rep1 ---> id) R) l m) = (l = m)"
  by (induct l m rule: list_induct2') (simp_all add: Quotient3_rel_rep[OF a])

lemma list_all2_find_element:
  assumes a: "x \<in> set a"
  and b: "list_all2 R a b"
  shows "\<exists>y. (y \<in> set b \<and> R x y)"
  using b a by induct auto

lemma list_all2_refl:
  assumes a: "\<And>x y. R x y = (R x = R y)"
  shows "list_all2 R x x"
  by (induct x) (auto simp add: a)

end


section \<open>The Same Vote Model\<close>

theory Same_Vote
imports Voting
begin

context quorum_process begin

subsection \<open>Model definition\<close>
(******************************************************************************)

text \<open>The system state remains the same as in the Voting model, but the
  voting event is changed.\<close>

definition safe :: "v_state \<Rightarrow> round \<Rightarrow> val \<Rightarrow> bool" where
  safe_def': "safe s r v \<equiv>
    \<forall>r' < r. \<forall>Q \<in> Quorum. \<forall>w. (votes s r') ` Q = {Some w} \<longrightarrow> v = w"

text \<open>This definition of @{term safe} is easier to reason about in Isabelle.\<close>
lemma safe_def:
  "safe s r v =
    (\<forall>r' < r. \<forall>Q w. quorum_for Q w (votes s r')  \<longrightarrow> v = w)"
  by(auto simp add: safe_def' quorum_for_def' Ball_def)

definition sv_round :: "round \<Rightarrow> process set \<Rightarrow> val \<Rightarrow> (process, val)map \<Rightarrow> (v_state \<times> v_state) set" where
  "sv_round r S v r_decisions = {(s, s').
     \<comment> \<open>guards\<close>
     r = next_round s
     \<and> (S \<noteq> {} \<longrightarrow> safe s r v)
     \<and> d_guard r_decisions (const_map v S)
     \<and> \<comment> \<open>actions\<close>
     s' = s\<lparr>
       next_round := Suc r
       , votes := (votes s)(r := const_map v S)
       , decisions := (decisions s ++ r_decisions)
     \<rparr>
  }"

definition sv_trans :: "(v_state \<times> v_state) set" where
  "sv_trans = (\<Union>r S v D. sv_round r S v D) \<union> Id"

definition sv_TS :: "v_state TS" where
  "sv_TS = \<lparr> init = v_init, trans = sv_trans \<rparr>"

lemmas sv_TS_defs = sv_TS_def v_init_def sv_trans_def

subsection \<open>Refinement\<close>
(******************************************************************************)

lemma safe_imp_no_defection:
  "safe s (next_round s) v \<Longrightarrow> no_defection s (const_map v S) (next_round s)"
  by(auto simp add: safe_def no_defection_def restrict_map_def const_map_def)

lemma const_map_quorum_locked:
  "S \<in> Quorum \<Longrightarrow> locked_in_vf (const_map v S) v"
  by(auto simp add: locked_in_vf_def const_map_def quorum_for_def)

lemma sv_round_refines:
  "{Id} v_round r (const_map v S) r_decisions, sv_round r S v r_decisions {> Id}"
  by(auto simp add: PO_rhoare_defs sv_round_def v_round_def  no_defection_empty
    dest!: safe_imp_no_defection const_map_quorum_locked)

lemma Same_Vote_Refines:
  "PO_refines Id v_TS sv_TS"
  by(auto simp add: PO_refines_def sv_TS_def sv_trans_def v_TS_defs intro!:
    sv_round_refines relhoare_refl)

subsection \<open>Invariants\<close>
(******************************************************************************)

definition SV_inv3 where
  "SV_inv3 = {s. \<forall>r a b v w.
    votes s r a = Some v \<and> votes s r b = Some w \<longrightarrow> v = w
  }"

lemmas SV_inv3I = SV_inv3_def [THEN setc_def_to_intro, rule_format]
lemmas SV_inv3E [elim] = SV_inv3_def [THEN setc_def_to_elim, rule_format]
lemmas SV_inv3D = SV_inv3_def [THEN setc_def_to_dest, rule_format]

subsubsection \<open>Proof of invariants\<close>
(******************************************************************************)

lemma SV_inv3_v_round:
  "{SV_inv3} sv_round r S v D {> SV_inv3}"
  apply(clarsimp simp add: PO_hoare_defs intro!: SV_inv3I)
  apply(force simp add: sv_round_def const_map_def restrict_map_def SV_inv3_def)
  done

lemmas SV_inv3_event_pres = SV_inv3_v_round

lemma SV_inv3_inductive:
  "init sv_TS \<subseteq> SV_inv3"
  "{SV_inv3} trans sv_TS {> SV_inv3}"
  apply (simp add: sv_TS_defs SV_inv3_def)
  by (auto simp add: sv_TS_defs SV_inv3_event_pres)

lemma SV_inv3_invariant: "reach sv_TS \<subseteq> SV_inv3"
  by (auto intro!: inv_rule_basic SV_inv3_inductive del: subsetI)

text \<open>

This is a different characterization of @{term safe}, due to Lampson~\cite{lampson_abcds_2001}:
  @{term "safe' s r v = (\<forall>r'< r. (\<exists>Q \<in> Quorum. \<forall>a \<in> Q. \<forall>w. votes s r' a = Some w \<longrightarrow> w = v))"}

It is, however, strictly stronger than our characterization, since we do not at this point assume
the "completeness" of our quorum system (for any set S, either S or the complement of S is a
quorum), and the following is thus not provable: @{term "s \<in> SV_inv3 \<Longrightarrow> safe' s = safe s"}.

\<close>

subsubsection \<open>Transfer of abstract invariants\<close>
(******************************************************************************)

lemma SV_inv1_inductive:
  "init sv_TS \<subseteq> Vinv1"
  "{Vinv1} trans sv_TS {> Vinv1}"
  apply(rule abs_INV_init_transfer[OF Same_Vote_Refines Vinv1_inductive(1), simplified])
  apply(rule abs_INV_trans_transfer[OF Same_Vote_Refines Vinv1_inductive(2), simplified])
  done

lemma SV_inv1_invariant:
  "reach sv_TS \<subseteq> Vinv1"
  by(rule abs_INV_transfer[OF Same_Vote_Refines Vinv1_invariant, simplified])

lemma SV_inv2_inductive:
  "init sv_TS \<subseteq> Vinv2"
  "{Vinv2 \<inter> Vinv1} trans sv_TS {> Vinv2}"
  apply(rule abs_INV_init_transfer[OF Same_Vote_Refines Vinv2_inductive(1), simplified])
  apply(rule abs_INV_trans_transfer[OF Same_Vote_Refines Vinv2_inductive(2), simplified])
  done

lemma SV_inv2_invariant:
  "reach sv_TS \<subseteq> Vinv2"
  by(rule abs_INV_transfer[OF Same_Vote_Refines Vinv2_invariant, simplified])

subsubsection \<open>Additional invariants\<close>
(******************************************************************************)

text \<open>With Same Voting, the voted values are safe in the next round.\<close>

definition SV_inv4 :: "v_state set" where
  "SV_inv4 = {s. \<forall>v a r. votes s r a = Some v \<longrightarrow> safe s (Suc r) v }"

lemmas SV_inv4I = SV_inv4_def [THEN setc_def_to_intro, rule_format]
lemmas SV_inv4E [elim] = SV_inv4_def [THEN setc_def_to_elim, rule_format]
lemmas SV_inv4D = SV_inv4_def [THEN setc_def_to_dest, rule_format]

lemma SV_inv4_sv_round:
  "{SV_inv4 \<inter> (Vinv1 \<inter> Vinv2)} sv_round r S v D {> SV_inv4}"
proof(clarsimp simp add: PO_hoare_defs intro!: SV_inv4I)
  fix s v' a r' s'
  assume
    step: "(s, s') \<in> sv_round r S v D"
    and invs: "s \<in> SV_inv4" "s \<in> Vinv1" "s \<in> Vinv2"
    and vote: "votes s' r' a = Some v'"
  thus "safe s' (Suc r') v'"
  proof(cases "r=r'")
    case True
    moreover hence safe: "safe s' r' v'" using step vote
      by(force simp add: sv_round_def const_map_is_Some safe_def quorum_for_def)
    ultimately show ?thesis using step vote
      by(force simp add: safe_def less_Suc_eq sv_round_def quorum_for_def const_map_is_Some
        dest: quorum_non_empty)
  qed(clarsimp simp add: sv_round_def safe_def Vinv2_def Vinv1_def  SV_inv4_def
      intro: Quorum_not_empty)
qed

lemmas SV_inv4_event_pres = SV_inv4_sv_round

lemma SV_inv4_inductive:
  "init sv_TS \<subseteq> SV_inv4"
  "{SV_inv4 \<inter> (Vinv1 \<inter> Vinv2)} trans sv_TS {> SV_inv4}"
  apply(simp add: sv_TS_defs SV_inv4_def)
  by (auto simp add: sv_TS_defs SV_inv4_event_pres)

lemma SV_inv4_invariant: "reach sv_TS \<subseteq> SV_inv4"
  by (rule inv_rule_incr)
  (auto intro: SV_inv4_inductive SV_inv2_invariant SV_inv1_invariant del: subsetI)

end (* context quorum_process *)

end


header {* \isaheader{Generic Set Algorithms} *}
theory Gen_Set
imports "../Intf/Intf_Set" "../../Iterator/Iterator"
begin

  lemma foldli_union: "det_fold_set X (\<lambda>_. True) insert a (op \<union> a)"
  proof
    case (goal1 l) thus ?case
      by (induct l arbitrary: a) auto
  qed

  definition gen_union
    :: "_ \<Rightarrow> ('k \<Rightarrow> 's2 \<Rightarrow> 's2)
        \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> 's2"
    where
    "gen_union it ins A B \<equiv> it A (\<lambda>_. True) ins B"

  lemma gen_union[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes INS: "GEN_OP ins Set.insert (Rk\<rightarrow>\<langle>Rk\<rangle>Rs2\<rightarrow>\<langle>Rk\<rangle>Rs2)"
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 tsl)"
    shows "(gen_union (\<lambda>x. foldli (tsl x)) ins,op \<union>)
    \<in> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk\<rangle>Rs2) \<rightarrow> (\<langle>Rk\<rangle>Rs2)"
    apply (intro fun_relI)
    apply (subst Un_commute)
    unfolding gen_union_def
    apply (rule det_fold_set[OF
      foldli_union IT[unfolded autoref_tag_defs]])
    using INS
    unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_inter: "det_fold_set X (\<lambda>_. True)
    (\<lambda>x s. if x\<in>a then insert x s else s) {} (\<lambda>s. s\<inter>a)"
    (is "det_fold_set _ _ ?f _ _")
  proof -
    {
      fix l s0
      have "foldli l (\<lambda>_. True)
        (\<lambda>x s. if x\<in>a then insert x s else s) s0 = s0 \<union> (set l \<inter> a)"
        by (induct l arbitrary: s0) auto
    }
    from this[of _ "{}"] show ?thesis apply - by rule simp
  qed

  definition gen_inter :: "_ \<Rightarrow>
    ('k \<Rightarrow> 's2 \<Rightarrow> bool) \<Rightarrow> _"
    where "gen_inter it1 memb2 ins3 empty3 s1 s2
    \<equiv> it1 s1 (\<lambda>_. True)
      (\<lambda>x s. if memb2 x s2 then ins3 x s else s) empty3"

  lemma gen_inter[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 tsl)"
    assumes MEMB:
      "GEN_OP memb2 op \<in> (Rk \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id)"
    assumes INS:
      "GEN_OP ins3 Set.insert (Rk\<rightarrow>\<langle>Rk\<rangle>Rs3\<rightarrow>\<langle>Rk\<rangle>Rs3)"
    assumes EMPTY:
      "GEN_OP empty3 {} (\<langle>Rk\<rangle>Rs3)"
    shows "(gen_inter (\<lambda>x. foldli (tsl x)) memb2 ins3 empty3,op \<inter>)
    \<in> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk\<rangle>Rs2) \<rightarrow> (\<langle>Rk\<rangle>Rs3)"
    apply (intro fun_relI)
    unfolding gen_inter_def
    apply (rule det_fold_set[OF foldli_inter IT[unfolded autoref_tag_defs]])
    using MEMB INS EMPTY
    unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_diff:
    "det_fold_set X (\<lambda>_. True) (\<lambda>x s. op_set_delete x s) s (op - s)"
  proof
    case (goal1 l) thus ?case
      by (induct l arbitrary: s) auto
  qed

  definition gen_diff :: "('k\<Rightarrow>'s1\<Rightarrow>'s1) \<Rightarrow> _ \<Rightarrow> 's2 \<Rightarrow> _ "
    where "gen_diff del1 it2 s1 s2
    \<equiv> it2 s2 (\<lambda>_. True) (\<lambda>x s. del1 x s) s1"

  lemma gen_diff[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes DEL:
      "GEN_OP del1 op_set_delete (Rk \<rightarrow> \<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs1)"
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs2 it2)"
    shows "(gen_diff del1 (\<lambda>x. foldli (it2 x)),op -)
      \<in> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk\<rangle>Rs2) \<rightarrow> (\<langle>Rk\<rangle>Rs1)"
    apply (intro fun_relI)
    unfolding gen_diff_def
    apply (rule det_fold_set[OF foldli_diff IT[unfolded autoref_tag_defs]])
    using DEL
    unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_ball_aux:
    "foldli l (\<lambda>x. x) (\<lambda>x _. P x) b \<longleftrightarrow> b \<and> Ball (set l) P"
    by (induct l arbitrary: b) auto

  lemma foldli_ball: "det_fold_set X (\<lambda>x. x) (\<lambda>x _. P x) True (\<lambda>s. Ball s P)"
    apply rule using foldli_ball_aux[where b=True] by simp

  definition gen_ball :: "_ \<Rightarrow> 's \<Rightarrow> ('k \<Rightarrow> bool) \<Rightarrow> _ "
    where "gen_ball it s P \<equiv> it s (\<lambda>x. x) (\<lambda>x _. P x) True"

  lemma gen_ball[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_ball (\<lambda>x. foldli (it x)),Ball) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> (Rk\<rightarrow>Id) \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_ball_def
    apply (rule det_fold_set[OF foldli_ball IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma foldli_bex_aux: "foldli l (\<lambda>x. \<not>x) (\<lambda>x _. P x) b \<longleftrightarrow> b \<or> Bex (set l) P"
    by (induct l arbitrary: b) auto

  lemma foldli_bex: "det_fold_set X (\<lambda>x. \<not>x) (\<lambda>x _. P x) False (\<lambda>s. Bex s P)"
    apply rule using foldli_bex_aux[where b=False] by simp

  definition gen_bex :: "_ \<Rightarrow> 's \<Rightarrow> ('k \<Rightarrow> bool) \<Rightarrow> _ "
    where "gen_bex it s P \<equiv> it s (\<lambda>x. \<not>x) (\<lambda>x _. P x) False"

  lemma gen_bex[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_bex (\<lambda>x. foldli (it x)),Bex) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> (Rk\<rightarrow>Id) \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_bex_def
    apply (rule det_fold_set[OF foldli_bex IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma ball_subseteq:
    "(Ball s1 (\<lambda>x. x\<in>s2)) \<longleftrightarrow> s1 \<subseteq> s2"
    by blast

  definition gen_subseteq
    :: "('s1 \<Rightarrow> ('k \<Rightarrow> bool) \<Rightarrow> bool) \<Rightarrow> ('k \<Rightarrow> 's2 \<Rightarrow> bool) \<Rightarrow> _"
    where "gen_subseteq ball1 mem2 s1 s2 \<equiv> ball1 s1 (\<lambda>x. mem2 x s2)"

  lemma gen_subseteq[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP ball1 Ball (\<langle>Rk\<rangle>Rs1 \<rightarrow> (Rk\<rightarrow>Id) \<rightarrow> Id)"
    assumes "GEN_OP mem2 op \<in> (Rk \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id)"
    shows "(gen_subseteq ball1 mem2,op \<subseteq>) \<in> \<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_subseteq_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst ball_subseteq[symmetric])
    apply parametricity
    done

  definition "gen_equal ss1 ss2 s1 s2 \<equiv> ss1 s1 s2 \<and> ss2 s2 s1"

  lemma gen_equal[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP ss1 op \<subseteq> (\<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id)"
    assumes "GEN_OP ss2 op \<subseteq> (\<langle>Rk\<rangle>Rs2 \<rightarrow> \<langle>Rk\<rangle>Rs1 \<rightarrow> Id)"
    shows "(gen_equal ss1 ss2, op =) \<in> \<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_equal_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst set_eq_subset)
    apply (parametricity)
    done

  lemma foldli_card_aux: "distinct l \<Longrightarrow> foldli l (\<lambda>_. True)
    (\<lambda>_ n. Suc n) n = n + card (set l)"
    apply (induct l arbitrary: n)
    apply auto
    done

  lemma foldli_card: "det_fold_set X (\<lambda>_. True) (\<lambda>_ n. Suc n) 0 card"
    apply rule using foldli_card_aux[where n=0] by simp

  definition gen_card where
    "gen_card it s \<equiv> it s (\<lambda>x. True) (\<lambda>_ n. Suc n) 0"

  lemma gen_card[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_card (\<lambda>x. foldli (it x)),card) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_card_def
    apply (rule det_fold_set[OF foldli_card IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma fold_set: "fold Set.insert l s = s \<union> set l"
    by (induct l arbitrary: s) auto

  definition gen_set :: "'s \<Rightarrow> ('k \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> _" where
    "gen_set emp ins l = fold ins l emp"

  lemma gen_set[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes EMPTY:
      "GEN_OP emp {} (\<langle>Rk\<rangle>Rs)"
    assumes INS:
      "GEN_OP ins Set.insert (Rk\<rightarrow>\<langle>Rk\<rangle>Rs\<rightarrow>\<langle>Rk\<rangle>Rs)"
    shows "(gen_set emp ins,set)\<in>\<langle>Rk\<rangle>list_rel\<rightarrow>\<langle>Rk\<rangle>Rs"
    apply (intro fun_relI)
    unfolding gen_set_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst fold_set[where s="{}",simplified,symmetric])
    apply parametricity
    done

  lemma ball_isEmpty: "op_set_isEmpty s = (\<forall>x\<in>s. False)"
    by auto

  definition gen_isEmpty :: "('s \<Rightarrow> ('k \<Rightarrow> bool) \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" where
    "gen_isEmpty ball s \<equiv> ball s (\<lambda>_. False)"

  lemma gen_isEmpty[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP ball Ball (\<langle>Rk\<rangle>Rs \<rightarrow> (Rk\<rightarrow>Id) \<rightarrow> Id)"
    shows "(gen_isEmpty ball,op_set_isEmpty) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_isEmpty_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst ball_isEmpty)
    apply parametricity
    done

  lemma foldli_size_abort_aux:
    "\<lbrakk>n0\<le>m; distinct l\<rbrakk> \<Longrightarrow>
      foldli l (\<lambda>n. n<m) (\<lambda>_ n. Suc n) n0 = min m (n0 + card (set l))"
    apply (induct l arbitrary: n0)
    apply auto
    done

  lemma foldli_size_abort: "
    det_fold_set X (\<lambda>n. n<m) (\<lambda>_ n. Suc n) 0 (op_set_size_abort m)"
    apply rule
    using foldli_size_abort_aux[where ?n0.0=0]
    by simp

  definition gen_size_abort where
    "gen_size_abort it m s \<equiv> it s (\<lambda>n. n<m) (\<lambda>_ n. Suc n) 0"

  lemma gen_size_abort[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_size_abort (\<lambda>x. foldli (it x)),op_set_size_abort)
    \<in> Id \<rightarrow> \<langle>Rk\<rangle>Rs \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_size_abort_def
    apply (rule det_fold_set[OF foldli_size_abort IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma size_abort_isSng: "op_set_isSng s \<longleftrightarrow> op_set_size_abort 2 s = 1"
    by auto

  definition gen_isSng :: "(nat \<Rightarrow> 's \<Rightarrow> nat) \<Rightarrow> _" where
    "gen_isSng sizea s \<equiv> sizea 2 s = 1"

  lemma gen_isSng[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP sizea op_set_size_abort (Id \<rightarrow> (\<langle>Rk\<rangle>Rs) \<rightarrow> Id)"
    shows "(gen_isSng sizea,op_set_isSng) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_isSng_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst size_abort_isSng)
    apply parametricity
    done

  lemma foldli_disjoint_aux:
    "foldli l1 (\<lambda>x. x) (\<lambda>x _. \<not>x\<in>s2) b \<longleftrightarrow> b \<and> op_set_disjoint (set l1) s2"
    by (induct l1 arbitrary: b) auto

  lemma foldli_disjoint:
    "det_fold_set X (\<lambda>x. x) (\<lambda>x _. \<not>x\<in>s2) True (\<lambda>s1. op_set_disjoint s1 s2)"
    apply rule using foldli_disjoint_aux[where b=True] by simp

  definition gen_disjoint
    :: "_ \<Rightarrow> ('k\<Rightarrow>'s2\<Rightarrow>bool) \<Rightarrow> _"
    where "gen_disjoint it1 mem2 s1 s2
    \<equiv> it1 s1 (\<lambda>x. x) (\<lambda>x _. \<not>mem2 x s2) True"

  lemma gen_disjoint[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes MEM: "GEN_OP mem2 op \<in> (Rk \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id)"
    shows "(gen_disjoint (\<lambda>x. foldli (it1 x)) mem2,op_set_disjoint)
    \<in> \<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_disjoint_def
    apply (rule det_fold_set[OF foldli_disjoint IT[unfolded autoref_tag_defs]])
    using MEM unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_filter_aux:
    "foldli l (\<lambda>_. True) (\<lambda>x s. if P x then insert x s else s) s0
    = s0 \<union> op_set_filter P (set l)"
    by (induct l arbitrary: s0) auto

  lemma foldli_filter:
    "det_fold_set X (\<lambda>_. True) (\<lambda>x s. if P x then insert x s else s) {}
      (op_set_filter P)"
    apply rule using foldli_filter_aux[where ?s0.0="{}"] by simp

  definition gen_filter
    where "gen_filter it1 emp2 ins2 P s1 \<equiv>
      it1 s1 (\<lambda>_. True) (\<lambda>x s. if P x then ins2 x s else s) emp2"

  lemma gen_filter[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes INS:
      "GEN_OP ins2 Set.insert (Rk\<rightarrow>\<langle>Rk\<rangle>Rs2\<rightarrow>\<langle>Rk\<rangle>Rs2)"
    assumes EMPTY:
      "GEN_OP empty2 {} (\<langle>Rk\<rangle>Rs2)"
    shows "(gen_filter (\<lambda>x. foldli (it1 x)) empty2 ins2,op_set_filter)
    \<in> (Rk\<rightarrow>Id) \<rightarrow> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk\<rangle>Rs2)"
    apply (intro fun_relI)
    unfolding gen_filter_def
    apply (rule det_fold_set[OF foldli_filter IT[unfolded autoref_tag_defs]])
    using INS EMPTY unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_image_aux:
    "foldli l (\<lambda>_. True) (\<lambda>x s. insert (f x) s) s0
    = s0 \<union> f`(set l)"
    by (induct l arbitrary: s0) auto

  lemma foldli_image:
    "det_fold_set X (\<lambda>_. True) (\<lambda>x s. insert (f x) s) {}
      (op ` f)"
    apply rule using foldli_image_aux[where ?s0.0="{}"] by simp

  definition gen_image
    where "gen_image it1 emp2 ins2 f s1 \<equiv>
      it1 s1 (\<lambda>_. True) (\<lambda>x s. ins2 (f x) s) emp2"

  lemma gen_image[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes INS:
      "GEN_OP ins2 Set.insert (Rk'\<rightarrow>\<langle>Rk'\<rangle>Rs2\<rightarrow>\<langle>Rk'\<rangle>Rs2)"
    assumes EMPTY:
      "GEN_OP empty2 {} (\<langle>Rk'\<rangle>Rs2)"
    shows "(gen_image (\<lambda>x. foldli (it1 x)) empty2 ins2,op `)
    \<in> (Rk\<rightarrow>Rk') \<rightarrow> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk'\<rangle>Rs2)"
    apply (intro fun_relI)
    unfolding gen_image_def
    apply (rule det_fold_set[OF foldli_image IT[unfolded autoref_tag_defs]])
    using INS EMPTY unfolding autoref_tag_defs
    apply (parametricity)+
    done

  (* TODO: Also do sel! *)

  lemma foldli_pick:
    assumes "l\<noteq>[]"
    obtains x where "x\<in>set l"
    and "(foldli l (case_option True (\<lambda>_. False)) (\<lambda>x _. Some x) None) = Some x"
    using assms by (cases l) auto

  definition gen_pick where
    "gen_pick it s \<equiv>
      (the (it s (case_option True (\<lambda>_. False)) (\<lambda>x _. Some x) None))"

context begin interpretation autoref_syn .
  lemma gen_pick[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    assumes SV: "PREFER single_valued Rk"
    assumes NE: "SIDE_PRECOND (s'\<noteq>{})"
    assumes SREF: "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    shows "(RETURN (gen_pick (\<lambda>x. foldli (it x)) s),
      (OP op_set_pick ::: \<langle>Rk\<rangle>Rs\<rightarrow>\<langle>Rk\<rangle>nres_rel)$s')\<in>\<langle>Rk\<rangle>nres_rel"
  proof -
    obtain tsl' where
      [param]: "(it s,tsl') \<in> \<langle>Rk\<rangle>list_rel"
      and IT': "RETURN tsl' \<le> it_to_sorted_list (\<lambda>_ _. True) s'"
      using IT[unfolded autoref_tag_defs is_set_to_list_def] SREF
      by (rule is_set_to_sorted_listE)

    from IT' NE have "tsl'\<noteq>[]" and [simp]: "s'=set tsl'"
      unfolding it_to_sorted_list_def by simp_all
    then obtain x where "x\<in>s'" and
      "(foldli tsl' (case_option True (\<lambda>_. False)) (\<lambda>x _. Some x) None) = Some x"
      (is "?fld = _")
      by (blast elim: foldli_pick)
    moreover
    have "(RETURN (gen_pick (\<lambda>x. foldli (it x)) s), RETURN (the ?fld))
      \<in> \<langle>Rk\<rangle>nres_rel"
      unfolding gen_pick_def
      using SV[unfolded autoref_tag_defs]
      apply (parametricity add: the_paramR)
      using `?fld = Some x`
      by simp
    ultimately show ?thesis
      apply (simp add: nres_rel_def)
      apply (erule ref_two_step)
      by simp
  qed
end

  term Sigma

  definition gen_Sigma
    where "gen_Sigma it1 it2 empX insX s1 f2 \<equiv>
      it1 s1 (\<lambda>_. True) (\<lambda>x s.
        it2 (f2 x) (\<lambda>_. True) (\<lambda>y s. insX (x,y) s) s
      ) empX
    "

  lemma foldli_Sigma_aux:
    fixes s :: "'s1_impl" and s':: "'k set"
    fixes f :: "'k_impl \<Rightarrow> 's2_impl" and f':: "'k \<Rightarrow> 'l set"
    fixes s0 :: "'kl_impl" and s0' :: "('k\<times>'l) set"
    assumes IT1: "is_set_to_list Rk Rs1 it1"
    assumes IT2: "is_set_to_list Rl Rs2 it2"
    assumes INS:
      "(insX, Set.insert) \<in>
        (\<langle>Rk,Rl\<rangle>prod_rel\<rightarrow>\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3\<rightarrow>\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3)"
    assumes S0R: "(s0, s0') \<in> \<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3"
    assumes SR: "(s, s') \<in> \<langle>Rk\<rangle>Rs1"
    assumes FR: "(f, f') \<in> Rk \<rightarrow> \<langle>Rl\<rangle>Rs2"
    shows "(foldli (it1 s) (\<lambda>_. True) (\<lambda>x s.
        foldli (it2 (f x)) (\<lambda>_. True) (\<lambda>y s. insX (x,y) s) s
      ) s0,s0' \<union> Sigma s' f')
      \<in> \<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3"
  proof -
    have S: "\<And>x s f. Sigma (insert x s) f = ({x}\<times>f x) \<union> Sigma s f"
      by auto

    obtain l' where
      IT1L: "(it1 s,l')\<in>\<langle>Rk\<rangle>list_rel"
      and SL: "s' = set l'"
      apply (rule
        is_set_to_sorted_listE[OF IT1[unfolded is_set_to_list_def] SR])
      by (auto simp: it_to_sorted_list_def)

    show ?thesis
      unfolding SL
      using IT1L S0R
    proof (induct arbitrary: s0 s0' rule: list_rel_induct)
      case Nil thus ?case by simp
    next
      case (Cons x x' l l')

      obtain l2' where
        IT2L: "(it2 (f x),l2')\<in>\<langle>Rl\<rangle>list_rel"
        and FXL: "f' x' = set l2'"
        apply (rule
          is_set_to_sorted_listE[
            OF IT2[unfolded is_set_to_list_def], of "f x" "f' x'"
          ])
        apply (parametricity add: Cons.hyps(1) FR)
        by (auto simp: it_to_sorted_list_def)

      have "(foldli (it2 (f x)) (\<lambda>_. True) (\<lambda>y. insX (x, y)) s0,
        s0' \<union> {x'}\<times>f' x') \<in> \<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3"
        unfolding FXL
        using IT2L `(s0, s0') \<in> \<langle>\<langle>Rk, Rl\<rangle>prod_rel\<rangle>Rs3`
        apply (induct  arbitrary: s0 s0' rule: list_rel_induct)
        apply simp
        apply simp
        apply (subst Un_insert_left[symmetric])
        apply (rprems)
        apply (parametricity add: INS `(x,x')\<in>Rk`)
        done

      show ?case
        apply simp
        apply (subst S)
        apply (subst Un_assoc[symmetric])
        apply (rule Cons.hyps)
        apply fact
        done
    qed
  qed

  lemma gen_Sigma[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT1: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes IT2: "SIDE_GEN_ALGO (is_set_to_list Rl Rs2 it2)"
    assumes EMPTY:
      "GEN_OP empX {} (\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3)"
    assumes INS:
      "GEN_OP insX Set.insert
         (\<langle>Rk,Rl\<rangle>prod_rel\<rightarrow>\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3\<rightarrow>\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3)"
    shows "(gen_Sigma (\<lambda>x. foldli (it1 x)) (\<lambda>x. foldli (it2 x)) empX insX,Sigma)
      \<in> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (Rk \<rightarrow> \<langle>Rl\<rangle>Rs2) \<rightarrow> \<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3"
    apply (intro fun_relI)
    unfolding gen_Sigma_def
    using foldli_Sigma_aux[OF
      IT1[unfolded autoref_tag_defs]
      IT2[unfolded autoref_tag_defs]
      INS[unfolded autoref_tag_defs]
      EMPTY[unfolded autoref_tag_defs]
    ]
    by simp

lemma gen_cart:
  assumes PRIO_TAG_GEN_ALGO
  assumes [param]: "(sigma, Sigma) \<in> (\<langle>Rx\<rangle>Rsx \<rightarrow> (Rx \<rightarrow> \<langle>Ry\<rangle>Rsy) \<rightarrow> \<langle>Rx \<times>\<^sub>r Ry\<rangle>Rsp)"
  shows "(\<lambda>x y. sigma x (\<lambda>_. y), op_set_cart) \<in> \<langle>Rx\<rangle>Rsx \<rightarrow> \<langle>Ry\<rangle>Rsy \<rightarrow> \<langle>Rx \<times>\<^sub>r Ry\<rangle>Rsp"
  unfolding op_set_cart_def[abs_def]
  by parametricity
lemmas [autoref_rules] = gen_cart[OF _ GEN_OP_D]

context begin interpretation autoref_syn .

  lemma op_set_to_sorted_list_autoref[autoref_rules]:
    assumes "PREFER single_valued Rk"
    assumes "SIDE_GEN_ALGO (is_set_to_sorted_list ordR Rk Rs tsl)"
    shows "(\<lambda>si. RETURN (tsl si),  OP (op_set_to_sorted_list ordR))
      \<in> \<langle>Rk\<rangle>Rs \<rightarrow> \<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
    using assms
    apply (intro fun_relI nres_relI)
    apply simp
    apply (rule RETURN_SPEC_refine_sv)
    apply tagged_solver
    apply (auto simp: is_set_to_sorted_list_def it_to_sorted_list_def)
    done

  lemma op_set_to_list_autoref[autoref_rules]:
    assumes "PREFER single_valued Rk"
    assumes "SIDE_GEN_ALGO (is_set_to_sorted_list ordR Rk Rs tsl)"
    shows "(\<lambda>si. RETURN (tsl si), op_set_to_list)
      \<in> \<langle>Rk\<rangle>Rs \<rightarrow> \<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
    using assms
    apply (intro fun_relI nres_relI)
    apply simp
    apply (rule RETURN_SPEC_refine_sv)
    apply tagged_solver
    apply (auto simp: is_set_to_sorted_list_def it_to_sorted_list_def)
    done

end

lemma foldli_Union: "det_fold_set X (\<lambda>_. True) (op \<union>) {} Union"
proof
  case (goal1 l)
  have "\<forall>a. foldli l (\<lambda>_. True) op \<union> a = a \<union> \<Union>set l"
    by (induct l) auto
  thus ?case by auto
qed

definition gen_Union
  :: "_ \<Rightarrow> 's3 \<Rightarrow> ('s2 \<Rightarrow> 's3 \<Rightarrow> 's3)
      \<Rightarrow> 's1 \<Rightarrow> 's3"
  where
  "gen_Union it emp un X \<equiv> it X (\<lambda>_. True) un emp"

lemma gen_Union[autoref_rules_raw]:
  assumes PRIO_TAG_GEN_ALGO
  assumes EMP: "GEN_OP emp {} (\<langle>Rk\<rangle>Rs3)"
  assumes UN: "GEN_OP un (op \<union>) (\<langle>Rk\<rangle>Rs2\<rightarrow>\<langle>Rk\<rangle>Rs3\<rightarrow>\<langle>Rk\<rangle>Rs3)"
  assumes IT: "SIDE_GEN_ALGO (is_set_to_list (\<langle>Rk\<rangle>Rs2) Rs1 tsl)"
  shows "(gen_Union (\<lambda>x. foldli (tsl x)) emp un,Union) \<in> \<langle>\<langle>Rk\<rangle>Rs2\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs3"
  apply (intro fun_relI)
  unfolding gen_Union_def
  apply (rule det_fold_set[OF
    foldli_Union IT[unfolded autoref_tag_defs]])
  using EMP UN
  unfolding autoref_tag_defs
  apply (parametricity)+
  done

definition "atLeastLessThan_impl a b \<equiv> do {
  (_,r) \<leftarrow> WHILET (\<lambda>(i,r). i<b) (\<lambda>(i,r). RETURN (i+1, insert i r)) (a,{});
  RETURN r
}"

lemma atLeastLessThan_impl_correct:
  "atLeastLessThan_impl a b \<le> SPEC (\<lambda>r. r = {a..<b::nat})"
  unfolding atLeastLessThan_impl_def
  apply (refine_rcg refine_vcg WHILET_rule[where
    I = "\<lambda>(i,r). r = {a..<i} \<and> a\<le>i \<and> ((a<b \<longrightarrow> i\<le>b) \<and> (\<not>a<b \<longrightarrow> i=a))"
    and R = "measure (\<lambda>(i,_). b - i)"
    ])
  by auto

schematic_lemma atLeastLessThan_code_aux:
  notes [autoref_rules] = IdI[of a] IdI[of b]
  assumes [autoref_rules]: "(emp,{})\<in>Rs"
  assumes [autoref_rules]: "(ins,insert)\<in>nat_rel \<rightarrow> Rs \<rightarrow> Rs"
  assumes [relator_props]: "single_valued Rs"
  shows "(?c, atLeastLessThan_impl)
  \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>Rs\<rangle>nres_rel"
  unfolding atLeastLessThan_impl_def[abs_def]
  apply (autoref (keep_goal))
  done
concrete_definition atLeastLessThan_code uses atLeastLessThan_code_aux

schematic_lemma atLeastLessThan_tr_aux:
  "RETURN ?c \<le> atLeastLessThan_code emp ins a b"
  unfolding atLeastLessThan_code_def
  by (refine_transfer (post))
concrete_definition atLeastLessThan_tr
  for emp ins a b uses atLeastLessThan_tr_aux

lemma atLeastLessThan_gen[autoref_rules]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP emp {} Rs"
  assumes "GEN_OP ins insert (nat_rel \<rightarrow> Rs \<rightarrow> Rs)"
  assumes "PREFER single_valued Rs"
  shows "(atLeastLessThan_tr emp ins, atLeastLessThan)
    \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> Rs"
proof (intro fun_relI, simp)
  fix a b
  from assms have GEN:
    "(emp,{})\<in>Rs" "(ins,insert)\<in>nat_rel \<rightarrow> Rs \<rightarrow> Rs" "single_valued Rs"
    by auto

  note atLeastLessThan_tr.refine[of emp ins a b]
  also note
    atLeastLessThan_code.refine[OF GEN,param_fo, OF IdI IdI, THEN nres_relD]
  also note atLeastLessThan_impl_correct
  finally show "(atLeastLessThan_tr emp ins a b, {a..<b}) \<in> Rs"
    by (auto simp: pw_le_iff refine_pw_simps)
qed

end