theory Dlist_finiteness

imports Main Enum
  "~~/src/HOL/Library/Dlist"
begin

(*TODO
lemma finite_dlists_length_le:
  "finite A \<Longrightarrow> finite { dl. set (list_of_dlist dl) \<subseteq> A \<and> Dlist.length dl \<le> n }"
using  finite_lists_length_le Dlist.length_def
sorry
*)

(*
definition
  formulas :: "'a set \<Rightarrow> 'a formula set"
where
  "formulas S =
    {x. \<forall>A B. (\<forall>i\<in>S. i \<in> A \<longleftrightarrow> i \<in> B) \<longrightarrow>
      A \<in> Rep_formula x \<longleftrightarrow> B \<in> Rep_formula x}"
*)

definition dlists2_pred :: "'a set \<Rightarrow> 'a dlist \<Rightarrow> bool" where
  "dlists2_pred A dl = (\<forall>X. (Dlist.set dl \<subseteq> X \<longrightarrow> X \<subseteq> A) \<longleftrightarrow> (Dlist.set dl \<subseteq> A ))"
(*
  "dlists2_pred A dl = (Dlist.set dl \<subseteq> A)"
*)
(*
  "dlists2_pred A dl = (\<forall> X Y. (\<forall> a \<in> A. a \<in> X \<longleftrightarrow> a \<in> Y) \<longrightarrow>
      Dlist.set dl \<subseteq> X \<longleftrightarrow> Dlist.set dl \<subseteq> Y)"
*)

definition dlists2 :: "'a set \<Rightarrow> 'a dlist set" where
  "dlists2 A \<equiv> Collect (dlists2_pred A)"

lemma "dlists2_pred A dl \<Longrightarrow> Dlist.set dl \<subseteq> A"
by (auto simp add: dlists2_pred_def)
(*
lemma "\<not> dlists2_pred A dl \<Longrightarrow> Dlist.set dl \<subseteq> A"
by (auto simp add: dlists2_pred_def)
*)

definition dlists :: "'a set \<Rightarrow> 'a dlist set" where
  "dlists A \<equiv> { dl . Dlist.set dl \<subseteq> A  }"

(*
lemma "dls \<subseteq> dlists2 A \<Longrightarrow> -dls \<subseteq> dlists2 A"
unfolding dlists2_def
apply auto
*)

definition lists_of_dlists :: "'a dlist set \<Rightarrow> 'a list set" where
  "lists_of_dlists dls \<equiv> { list_of_dlist dl | dl . dl \<in> dls  }"

definition dlists_of_lists :: "'a list set \<Rightarrow> 'a dlist set" where
  "dlists_of_lists ls \<equiv> { dlist_of_list l | l . distinct l \<and> l \<in> ls  }"

lemma dlists_all_distinct: "\<forall>dl \<in> dlists_of_lists ls. distinct (list_of_dlist l)"
by simp

lemma lists_and_dlists_belongs:
  "l \<in> lists_of_dlists dls \<Longrightarrow> distinct l \<and> dlist_of_list l \<in> dls"
  "distinct l \<and> dlist_of_list l \<in> dls \<Longrightarrow> l \<in> lists_of_dlists dls"
  "\<lbrakk> \<forall>l \<in> ls. distinct l ; dl \<in> dlists_of_lists ls \<rbrakk> \<Longrightarrow> list_of_dlist dl \<in> ls"
  "\<lbrakk> \<forall>l \<in> ls. distinct l ; list_of_dlist dl \<in> ls \<rbrakk> \<Longrightarrow> dl \<in> dlists_of_lists ls"
unfolding lists_of_dlists_def dlists_of_lists_def
apply auto
apply (metis list_of_dlist_Dlist remdups_id_iff_distinct)
apply (metis remdups_id_iff_distinct)
by force

lemma lists_and_dlists_inverse:
  "\<lbrakk> \<forall>l \<in> ls. distinct l; l \<in> lists_of_dlists (dlists_of_lists ls) \<rbrakk> \<Longrightarrow> l \<in> ls"
  "dl \<in> dlists_of_lists (lists_of_dlists dls) \<Longrightarrow> dl \<in> dls"
apply (metis dlist_of_list list_of_dlist_Dlist lists_and_dlists_belongs(1)
  lists_and_dlists_belongs(3) remdups_id_iff_distinct)
by (metis Dlist_list_of_dlist dlist_of_list lists_and_dlists_belongs(1)
  lists_and_dlists_belongs(3))

lemma lists_and_dlists_equiv_1:
  "dlists_of_lists (lists_of_dlists dls) = dls"
proof-
   have "dlists_of_lists (lists_of_dlists dls) =
    { dlist_of_list l | l. distinct l \<and> l \<in> lists_of_dlists dls}"
    unfolding dlists_of_lists_def  by simp
  moreover have "... = { dlist_of_list l | l. dlist_of_list l \<in> dls}"
    by (metis Dlist_list_of_dlist distinct_list_of_dlist dlist_of_list
       lists_and_dlists_belongs(1) lists_and_dlists_belongs(2))
  moreover have "... = { dl . dl \<in> dls }" by (metis Dlist_list_of_dlist dlist_of_list)
  ultimately show ?thesis by simp
qed

lemma lists_and_dlists_equiv_2:
  "\<forall>l \<in> ls. distinct l \<Longrightarrow> lists_of_dlists (dlists_of_lists ls) = ls"
proof-
  assume "\<forall>l \<in> ls. distinct l"
  moreover have "lists_of_dlists (dlists_of_lists ls) =
    { list_of_dlist dl | dl . dl \<in> dlists_of_lists ls }"
    unfolding dlists_of_lists_def lists_of_dlists_def by simp+
  moreover have "... = { list_of_dlist dl | dl . list_of_dlist dl \<in> ls  }"
    by (meson calculation(1) lists_and_dlists_belongs(3) lists_and_dlists_belongs(4))
  moreover have "... = { l . l \<in> ls }"
    by (metis Abs_dlist_inverse CollectI calculation(1))
  ultimately show ?thesis by simp
qed

lemma finite_lists_finite_distincts: "finite {xs. P xs} \<Longrightarrow> finite {xs. distinct xs \<and> P xs}"
by auto

lemma distinct_list_limit: "\<lbrakk> finite A; distinct l; set l \<subseteq> A \<rbrakk> \<Longrightarrow> length l \<le> card A"
by (metis card_mono distinct_card)

lemma dlist_limit: "\<lbrakk> finite A; Dlist.set dl \<subseteq> A \<rbrakk> \<Longrightarrow> Dlist.length dl \<le> card A"
by (simp add: Dlist.length_def distinct_list_limit set.rep_eq)

lemma distinct_list_finiteness: "finite A \<Longrightarrow> finite { l. distinct l \<and> set l \<subseteq> A }"
proof-
  assume 0: "finite A"
  hence "finite { l. set l \<subseteq> A \<and> length l \<le> card A }" by (simp add: finite_lists_length_le)
  hence "finite { l. distinct l \<and> set l \<subseteq> A \<and> length l \<le> card A }"
    using finite_lists_finite_distincts by simp
  hence "finite { l. distinct l \<and> set l \<subseteq> A \<and> length l \<le> card A }"
    using finite_lists_finite_distincts by simp
  thus ?thesis using 0 distinct_list_limit by (metis (no_types, lifting) Collect_cong)
qed

lemma dlists_finiteness_1: "finite A \<Longrightarrow> finite { list_of_dlist dl | dl. Dlist.set dl \<subseteq> A }"
proof-
  have 0: "{ list_of_dlist dl | dl. Dlist.set dl \<subseteq> A } = { l. distinct l \<and> set l \<subseteq> A }"
    by (metis distinct_list_of_dlist list_of_dlist_Dlist remdups_id_iff_distinct set.rep_eq)
  have 1: "{ dl . Dlist.set dl \<subseteq> A } = { dl. distinct (list_of_dlist dl) \<and> set (list_of_dlist dl) \<subseteq> A }"
    by (simp add: set.rep_eq)
  assume 1: "finite A"
  hence "finite { l. distinct l \<and> set l \<subseteq> A }" by (simp add: distinct_list_finiteness)
  thus ?thesis by (simp add: "0")
qed

lemma dlists_finiteness_2: "finite A \<Longrightarrow> finite (lists_of_dlists (dlists A))"
proof-
  assume "finite A"
  moreover hence "finite { list_of_dlist dl | dl. Dlist.set dl \<subseteq> A }"
    by (simp add: dlists_finiteness_1)
  moreover hence "finite { list_of_dlist dl | dl. dl \<in> { dl . Dlist.set dl \<subseteq> A } }"
    using CollectD CollectI Collect_cong by auto
  thus ?thesis by (simp add: dlists_def lists_of_dlists_def)
qed

lemma list_of_dlist_pred:
  "{list_of_dlist dl | dl. P (list_of_dlist dl)} = { l. distinct l \<and> P l }"
  "{ dl . P (list_of_dlist dl) } = { dlist_of_list l | l. distinct l \<and> P l }"
  "distinct l \<and> P l \<Longrightarrow> \<exists> dl. dl = dlist_of_list l \<and> P (list_of_dlist dl)"
apply (metis distinct_list_of_dlist list_of_dlist_Dlist remdups_id_iff_distinct)
apply (metis Dlist_list_of_dlist dlist_of_list list_of_dlist_Dlist remdups_id_iff_distinct)
by (metis dlist_of_list list_of_dlist_Dlist remdups_id_iff_distinct)

lemma lists_and_dlists_equiv_pred:
  "\<lbrakk> P ls ; \<forall> l\<in>ls. distinct l \<rbrakk> \<Longrightarrow> P (lists_of_dlists (dlists_of_lists ls))"
by (simp add: lists_and_dlists_equiv_2)

(* { l. distinct l \<and> set l \<subseteq> A } *)

lemma finite_over_pred_lists_and_dlists:
  "finite { l . distinct l \<and> P l } \<Longrightarrow> finite { dl . P (list_of_dlist dl) }"
by (simp add: list_of_dlist_pred(2))

lemma dlists_finiteness: "finite A \<Longrightarrow> finite (dlists A)"
proof-
  obtain P where 1: "P = (\<lambda>l. set l \<subseteq> A)" by simp
  assume 0: "finite A"
  hence "finite { l. distinct l \<and> P l }" by (simp add: 1 distinct_list_finiteness)
  hence "finite { dl . P (list_of_dlist dl) }" using finite_over_pred_lists_and_dlists by blast
  hence "finite { dl . Dlist.set dl \<subseteq> A }" by (metis "1" Collect_cong set.rep_eq)
  thus ?thesis by (simp add: dlists_def)
qed

lemma dlists_in_lists: "dlists A \<subseteq> dlists_of_lists (lists A)"
by (smt Dlist_list_of_dlist distinct_list_of_dlist dlist_of_list dlists_def dlists_of_lists_def
  lists_eq_set mem_Collect_eq set.rep_eq subsetI)

lemma lists_in_dlists: "\<forall>l \<in> lists A. distinct l \<Longrightarrow> dlists_of_lists (lists A) \<subseteq> dlists A"
by (smt Collect_mono dlist_of_list dlists_def dlists_of_lists_def in_listsD list_of_dlist_Dlist
  remdups_id_iff_distinct set.rep_eq subsetI)

lemma lists_equiv_dlists: "\<forall>l \<in> lists A. distinct l \<Longrightarrow> dlists_of_lists (lists A) = dlists A"
by (simp add: dlists_in_lists eq_iff lists_in_dlists)

lemma dlists_empty_set: "dlists {} = dlists_of_lists {[]}"
by (metis distinct.simps(1) lists_empty lists_equiv_dlists singletonD)

lemma singleton_in_lists_singleton: "[a] \<in> lists {a}"
by simp

(*
lemma dlists_singleton: "dlists {a} = dlists_of_lists {[], [a]}"
proof-
  have 0: "\<forall>l \<in> {[], [a]}. distinct l" by auto
  hence "\<forall>x \<in> dlists {a} . x = (dlist_of_list []) \<or> x = (dlist_of_list [a])" sorry
  thus ?thesis
qed

lemma singleton_list_in_dlists: "n \<in> A \<Longrightarrow> [n] \<in> dlists A"
by simp

lemma singleton_subseteq: "n \<in> A \<Longrightarrow> dlists {n} \<subseteq> dlists A"
unfolding dlists_singleton
by simp

lemma "n \<in> A \<Longrightarrow> \<forall>l \<in> dlists A. (remove1 n l) \<in> dlists A"

*)

(*
lemma dlists_insert_remove1: "\<lbrakk> l \<in> dlists (insert n A); n \<notin> set l \<rbrakk> \<Longrightarrow> remove1 n l \<in> dlists A"
apply (induct l)
apply simp
by (metis dlists.simps insertE list.inject list.set_intros(2) remove1.simps(2) remove1_idem)

lemma dlists_insert_remove2: "\<lbrakk> l \<in> dlists (insert n A); n \<in> set l \<rbrakk> \<Longrightarrow> remove1 n l \<in> dlists A"
apply (induct l)
apply simp
by (metis dlists.simps dlists_insert_remove1 in_set_remove1 insertE list.distinct(1) list.inject
  remove1.simps(2) remove1_idem)

lemma dlists_insert_remove: "l \<in> dlists (insert n A) \<Longrightarrow> remove1 n l \<in> dlists A"
by (meson dlists_insert_remove1 dlists_insert_remove2)
*)

(*
lemma dlists_insert_partition: "dlists (insert n A) = dlists {n} \<union> dlists A \<union>
  { l. set l \<subseteq> insert n A \<and> remove1 n l \<in> dlists A }"
proof (cases "n \<in> A")
  case True
  show ?thesis
qed

definition dlists_insert:: "'a \<Rightarrow> 'a set \<Rightarrow> 'a list set" where
  "dlists_insert n A \<equiv> { l. l \<in> dlists (insert n A) \<and> n \<in> set l \<longrightarrow> (remove1 n l) \<in> dlists A }"

lemma finite_dlists_insert: "finite A \<Longrightarrow> finite (dlists_insert n A)"
unfolding dlists_insert_def
sorry

lemma dlists_insert_equiv: "dlists_insert n A = dlists (insert n A)"
unfolding dlists_insert_def
using dlists_insert_remove
sorry

lemma dlists_insert_finite: "finite (dlists_insert n1 (insert n2 A)) \<Longrightarrow> finite (dlists_insert n1 A)"
unfolding dlists_insert_def
by (simp add: dlists_insert_remove2)

lemma dlists_insert_finite_2: "finite (dlists (insert n1 (insert n2 A))) \<Longrightarrow> finite (dlists (insert n1 A))"
using dlists_insert_equiv
by (metis dlists_insert_finite)

lemma finite_dlist_set: "finite A \<Longrightarrow> finite (dlists A)"
proof-
  fix n1 n2
  assume 0: "finite A"
  hence "finite (insert n1 (insert n2 A))" by simp
  hence "finite (dlists_insert n1 (insert n2 A))" by (simp add: finite_dlists_insert)
  hence "finite (dlists (insert n1 (insert n2 A)))" by (simp add: dlists_insert_equiv)
  hence "finite (dlists (insert n1 A))" by (meson dlists_insert_finite_2)
  thus ?thesis using 0
  by (metis Zero_neq_Suc card.insert card_eq_0_iff dlists_empty_set dlists_insert_finite_2
    empty_iff finite.cases finite.emptyI insert_commute)
qed
*)

(*
proof-
  assume 1: "finite A"
  hence "finite { dl. Dlist.set dl \<subseteq> A \<and> Dlist.length dl \<le> card A }"
    using 1 finite_dlists_length_le by blast
  thus ?thesis using 1
    by (metis (mono_tags, lifting) Collect_cong dlist_limit)
qed
*)

end


(*
  Title:    SD_Efficiency.thy
  Author:   Manuel Eberl, TU München

  Characterisation of SD-efficiency.
*)

theory SD_Efficiency
imports Complex_Main Preference_Profiles Missing_PMF Stochastic_Dominance
begin

(* TODO Move *)
lemma wfE_min':
  "wf R \<Longrightarrow> Q \<noteq> {} \<Longrightarrow> (\<And>z. z \<in> Q \<Longrightarrow> (\<And>y. (y, z) \<in> R \<Longrightarrow> y \<notin> Q) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
  using wfE_min[of R _ Q] by blast

lemma finite_subset_wf:
  assumes "finite A"
  shows   "wf {(X,Y). X \<subset> Y \<and> Y \<subseteq> A}"
proof (intro finite_acyclic_wf)
  have "{(X,Y). X \<subset> Y \<and> Y \<subseteq> A} \<subseteq> Pow A \<times> Pow A" by blast
  thus "finite {(X,Y). X \<subset> Y \<and> Y \<subseteq> A}"
    by (rule finite_subset) (auto simp: assms finite_cartesian_product)
next
  have "{(X, Y). X \<subset> Y \<and> Y \<subseteq> A}\<^sup>+ = {(X, Y). X \<subset> Y \<and> Y \<subseteq> A}"
    by (intro trancl_id transI) blast
  also have " \<forall>x. (x, x) \<notin> \<dots>" by blast
  finally show "acyclic {(X,Y). X \<subset> Y \<and> Y \<subseteq> A}" by (rule acyclicI)
qed

lemma pmf_neq_exists_less:
  assumes "(p :: 'a pmf) \<noteq> q"
  shows   "\<exists>x. pmf p x < pmf q x"
proof (rule ccontr)
  assume "\<not>(\<exists>x. pmf p x < pmf q x)"
  hence ge: "pmf p x \<ge> pmf q x" for x by (auto simp: not_less)
  from assms obtain x where "pmf p x \<noteq> pmf q x" by (auto simp: pmf_eq_iff)
  with ge[of x] have gt: "pmf p x > pmf q x" by simp
  have "1 = measure (measure_pmf q) UNIV" by simp
  also have "\<dots> = measure (measure_pmf q) {x} + measure (measure_pmf q) (UNIV - {x})"
    by (subst measure_pmf.finite_measure_Union [symmetric]) simp_all
  also from gt have "measure (measure_pmf q) {x} < measure (measure_pmf p) {x}"
    by (simp add: measure_pmf_single)
  also have "measure (measure_pmf q) (UNIV - {x}) \<le> measure (measure_pmf p) (UNIV - {x})"
    by (subst (1 2) integral_pmf [symmetric])
       (intro integral_mono integrable_pmf, simp_all add: ge)
  also have "measure (measure_pmf p) {x} + \<dots> = 1"
    by (subst measure_pmf.finite_measure_Union [symmetric]) simp_all
  finally show False by simp_all
qed
(* END TODO *)

(*
  TODO: Perhaps a general concept of "efficiency" can be introduced,
  parametrised over the way in which two lotteries are compared.
*)

subsection \<open>SD-Efficiency and supports\<close>

context pref_profile_wf
begin

text \<open>
  If a lottery is inefficient, all lotteries with a greater support (w.r.t. inclusion)
  are also inefficient.
\<close>
lemma SD_inefficient_support_subset:
  assumes inefficient: "\<not>SD_efficient R p'"
  assumes support: "set_pmf p' \<subseteq> set_pmf p"
  assumes lotteries: "p \<in> lotteries_on alts"
  shows   "\<not>SD_efficient R p"
proof -
  from assms have p'_wf: "p' \<in> lotteries_on alts" by (simp add: lotteries_on_def)
  from inefficient obtain q' i where q': "q' \<in> lotteries_on alts" "i \<in> agents"
    "\<And>i. i \<in> agents \<Longrightarrow> q' \<succeq>[SD(R i)] p'" "q' \<succ>[SD(R i)] p'"
    unfolding SD_efficient_def' by blast

  have subset: "{x. pmf p' x > pmf q' x} \<subseteq> set_pmf p'" by (auto simp: set_pmf_eq)
  also have "\<dots> \<subseteq> set_pmf p" by fact
  also have "\<dots> \<subseteq> alts" using lotteries by (simp add: lotteries_on_def)
  finally have finite: "finite {x. pmf p' x > pmf q' x}"
    using finite_alts by (rule finite_subset)

  def \<epsilon> \<equiv> "Min (insert 1 {pmf p x / (pmf p' x - pmf q' x) |x. pmf p' x > pmf q' x})"
  def supp \<equiv> "set_pmf p \<union> set_pmf q'"
  from lotteries finite_alts q'(1) have finite_supp: "finite supp"
    by (auto simp: lotteries_on_def supp_def dest: finite_subset)
  from support have [simp]: "pmf p x = 0" "pmf p' x = 0" "pmf q' x = 0" if "x \<notin> supp" for x
    using that by (auto simp: supp_def set_pmf_eq)

  from finite support subset have \<epsilon>: "\<epsilon> > 0" unfolding \<epsilon>_def
    by (intro Min_grI) (auto simp: field_simps set_pmf_eq')
  have nonneg: "pmf p x + \<epsilon> * (pmf q' x - pmf p' x) \<ge> 0" for x
  proof (cases "pmf p' x > pmf q' x")
    case True
    with finite have "\<epsilon> \<le> pmf p x / (pmf p' x - pmf q' x)"
      unfolding \<epsilon>_def by (intro Min_le) auto
    with True show ?thesis by (simp add: field_simps)
  next
    case False
    with pmf_nonneg[of p x] \<epsilon> show ?thesis by simp
  qed

  def q \<equiv> "embed_pmf (\<lambda>x. pmf p x + \<epsilon> * (pmf q' x - pmf p' x))"
  have "(\<integral>\<^sup>+ x. ereal (pmf p x + \<epsilon> * (pmf q' x - pmf p' x)) \<partial>count_space UNIV) = 1"
  proof (subst nn_integral_count_space')
    have "(\<Sum>x\<in>supp. ereal (pmf p x + \<epsilon> * (pmf q' x - pmf p' x))) =
            ereal ((\<Sum>x\<in>supp. pmf p x) + \<epsilon> * ((\<Sum>x\<in>supp. pmf q' x) - (\<Sum>x\<in>supp. pmf p' x)))"
      by (simp add: setsum.distrib setsum_right_distrib setsum_subtractf ring_distribs)
    also from finite_supp support have "\<dots> = 1"
      by (subst (1 2 3) setsum_pmf_eq_1) (auto simp: supp_def)
    finally show "(\<Sum>x\<in>supp. ereal (pmf p x + \<epsilon> * (pmf q' x - pmf p' x))) = 1" .
  qed (insert nonneg finite_supp, simp_all)
  with nonneg have pmf_q: "pmf q x = pmf p x + \<epsilon> * (pmf q' x - pmf p' x)" for x
    unfolding q_def by (intro pmf_embed_pmf) simp_all
  with support have support_q: "set_pmf q \<subseteq> supp"
    unfolding supp_def by (auto simp: set_pmf_eq)
  with lotteries support q'(1) have q_wf: "q \<in> lotteries_on alts"
    by (auto simp add: lotteries_on_def supp_def)

  from support_q support have expected_utility:
    "measure_pmf.expectation q u = measure_pmf.expectation p u +
         \<epsilon> * (measure_pmf.expectation q' u - measure_pmf.expectation p' u)" for u
    by (subst (1 2 3 4) integral_measure_pmf[OF finite_supp])
       (auto simp: pmf_q supp_def setsum.distrib setsum_right_distrib
                   setsum_left_distrib setsum_subtractf algebra_simps)

  have "q \<succeq>[SD(R i)] p" if i: "i \<in> agents" for i
  proof -
    from i interpret finite_total_preorder_on alts "R i" by simp
    from i lotteries q'(1) q'(3)[OF i] q_wf p'_wf \<epsilon> show ?thesis
      by (fastforce simp: SD_iff_expected_utilities_le expected_utility)
  qed
  moreover from \<open>i \<in> agents\<close> interpret finite_total_preorder_on alts "R i" by simp
    from lotteries q'(1,4) q_wf p'_wf \<epsilon> have "q \<succ>[SD(R i)] p"
    by (force simp: SD_iff_expected_utilities_le expected_utility not_le strongly_preferred_def)
  ultimately show ?thesis using q_wf \<open>i \<in> agents\<close> unfolding SD_efficient_def' by blast
qed

lemma SD_efficient_support_subset:
  assumes "SD_efficient R p" "set_pmf p' \<subseteq> set_pmf p" "p \<in> lotteries_on alts"
  shows   "SD_efficient R p'"
  using SD_inefficient_support_subset[OF _ assms(2,3)] assms(1) by blast

lemma SD_efficient_same_support:
  assumes "set_pmf p = set_pmf p'" "p \<in> lotteries_on alts"
  shows   "SD_efficient R p \<longleftrightarrow> SD_efficient R p'"
  using SD_inefficient_support_subset[of p p'] SD_inefficient_support_subset[of p' p] assms
  by (auto simp: lotteries_on_def)

lemma SD_efficient_iff:
  assumes "p \<in> lotteries_on alts"
  shows   "SD_efficient R p \<longleftrightarrow> SD_efficient R (pmf_of_set (set_pmf p))"
  using assms finite_alts
  by (intro SD_efficient_same_support)
     (simp, subst set_pmf_of_set,
      auto simp: set_pmf_not_empty lotteries_on_def intro: finite_subset[OF _ finite_alts])

lemma SD_efficient_no_pareto_loser:
  assumes efficient: "SD_efficient R p" and p_wf: "p \<in> lotteries_on alts"
  shows   "set_pmf p \<inter> pareto_losers R = {}"
proof -
  have "x \<notin> pareto_losers R" if x: "x \<in> set_pmf p" for x
  proof -
    from x have "set_pmf (return_pmf x) \<subseteq> set_pmf p" by auto
    from efficient this p_wf have "SD_efficient R (return_pmf x)"
      by (rule SD_efficient_support_subset)
    moreover from assms x have "x \<in> alts" by (auto simp: lotteries_on_def)
    ultimately show "x \<notin> pareto_losers R" by (simp add: SD_efficient_singleton_iff)
  qed
  thus ?thesis by blast
qed

text \<open>
  Given two lotteries with the same support where one is strictly Pareto-SD-preferred to
  the other, one can construct a third lottery that is weakly Pareto-SD-preferred to the
  better lottery (and therefore strictly Pareto-SD-preferred to the worse lottery) and
  whose support is a strict subset of the original supports.
\<close>
lemma improve_lottery_support_subset:
  assumes "p \<in> lotteries_on alts" "q \<in> lotteries_on alts" "q \<succ>[Pareto(SD \<circ> R)] p"
          "set_pmf p = set_pmf q"
  obtains r where "r \<in> lotteries_on alts" "r \<succeq>[Pareto(SD \<circ> R)] q" "set_pmf r \<subset> set_pmf p"
proof -
  have subset: "{x. pmf p x > pmf q x} \<subseteq> set_pmf p" by (auto simp: set_pmf_eq)
  also have "\<dots> \<subseteq> alts" using assms by (simp add: lotteries_on_def)
  finally have finite: "finite {x. pmf p x > pmf q x}"
    using finite_alts by (rule finite_subset)

  from assms have "q \<noteq> p" by (auto simp: strongly_preferred_def)
  hence ex_less: "\<exists>x. pmf p x > pmf q x" by (rule pmf_neq_exists_less)

  def \<epsilon> \<equiv> "Min {pmf p x / (pmf p x - pmf q x) |x. pmf p x > pmf q x}"
  def supp \<equiv> "set_pmf p"
  from assms finite_alts have finite_supp: "finite supp"
    by (auto simp: lotteries_on_def supp_def dest: finite_subset)
  from assms have [simp]: "pmf p x = 0" "pmf q x = 0" if "x \<notin> supp" for x
    using that by (auto simp: supp_def set_pmf_eq)

  from finite subset ex_less have \<epsilon>: "\<epsilon> \<ge> 1" unfolding \<epsilon>_def
    by (intro Min.boundedI) (auto simp: field_simps pmf_nonneg)
  have nonneg: "pmf p x + \<epsilon> * (pmf q x - pmf p x) \<ge> 0" for x
  proof (cases "pmf p x > pmf q x")
    case True
    with finite have "\<epsilon> \<le> pmf p x / (pmf p x - pmf q x)"
      unfolding \<epsilon>_def by (intro Min_le) auto
    with True show ?thesis by (simp add: field_simps)
  next
    case False
    with pmf_nonneg[of p x] \<epsilon> show ?thesis by simp
  qed

  def r \<equiv> "embed_pmf (\<lambda>x. pmf p x + \<epsilon> * (pmf q x - pmf p x))"
  have "(\<integral>\<^sup>+ x. ereal (pmf p x + \<epsilon> * (pmf q x - pmf p x)) \<partial>count_space UNIV) = 1"
  proof (subst nn_integral_count_space')
    have "(\<Sum>x\<in>supp. ereal (pmf p x + \<epsilon> * (pmf q x - pmf p x))) =
            ereal ((\<Sum>x\<in>supp. pmf p x) + \<epsilon> * ((\<Sum>x\<in>supp. pmf q x) - (\<Sum>x\<in>supp. pmf p x)))"
      by (simp add: setsum.distrib setsum_right_distrib setsum_subtractf ring_distribs)
    also from finite_supp  have "\<dots> = 1"
      by (subst (1 2 3) setsum_pmf_eq_1) (auto simp: supp_def assms)
    finally show "(\<Sum>x\<in>supp. ereal (pmf p x + \<epsilon> * (pmf q x - pmf p x))) = 1" .
  qed (insert nonneg finite_supp, simp_all)
  with nonneg have pmf_r: "pmf r x = pmf p x + \<epsilon> * (pmf q x - pmf p x)" for x
    unfolding r_def by (intro pmf_embed_pmf) simp_all

  with assms have "set_pmf r \<subseteq> supp"
    unfolding supp_def by (auto simp: set_pmf_eq)
  from finite ex_less have "\<epsilon> \<in> {pmf p x / (pmf p x - pmf q x) |x. pmf p x > pmf q x}"
     unfolding \<epsilon>_def by (intro Min_in) auto
  then obtain x where "\<epsilon> = pmf p x / (pmf p x - pmf q x)" "pmf p x > pmf q x" by blast
  hence "pmf r x = 0" by (simp add: pmf_r field_simps)
  moreover from \<open>pmf p x > pmf q x\<close> pmf_nonneg[of q x]
    have "pmf p x > 0" by simp
  ultimately have "x \<in> set_pmf p - set_pmf r" by (auto simp: set_pmf_iff)
  with \<open>set_pmf r \<subseteq> supp\<close> have support_r: "set_pmf r \<subset> set_pmf p" unfolding supp_def by blast
  from this assms have r_wf: "r \<in> lotteries_on alts" by (simp add: lotteries_on_def)

  have "r \<succeq>[Pareto(SD\<circ>R)] q" unfolding SD.Pareto_iff unfolding o_def
  proof
    fix i assume i: "i \<in> agents"
    then interpret finite_total_preorder_on alts "R i" by simp
    show "r \<succeq>[SD(R i)] q"
    proof (subst SD_iff_expected_utilities_le; safe?)
      fix u assume u: "is_vnm_utility u"
      from support_r have expected_utility_r:
        "measure_pmf.expectation r u = measure_pmf.expectation p u +
             \<epsilon> * (measure_pmf.expectation q u - measure_pmf.expectation p u)"
        by (subst (1 2 3 4) integral_measure_pmf[OF finite_supp])
           (auto simp: supp_def assms pmf_r setsum.distrib setsum_right_distrib
            setsum_left_distrib setsum_subtractf algebra_simps)
      from assms i have "q \<succeq>[SD(R i)] p" by (simp add: SD.Pareto_strict_iff)
      with assms u have "measure_pmf.expectation q u \<ge> measure_pmf.expectation p u"
        by (simp add: SD_iff_expected_utilities_le r_wf)
      hence "(\<epsilon> - 1) * measure_pmf.expectation p u \<le> (\<epsilon> - 1) * measure_pmf.expectation q u"
        using \<epsilon> by (intro mult_left_mono) simp_all
      thus "measure_pmf.expectation q u \<le> measure_pmf.expectation r u"
        by (simp add: algebra_simps expected_utility_r)
    qed fact+
  qed
  from that[OF r_wf this support_r] show ?thesis .
qed

subsection \<open>Existence of SD-efficient lotteries\<close>

text \<open>
  In this section, we will show that any lottery can be `improved' to an SD-efficient lottery,
  i.e. for any lottery, there exists an SD-efficient lottery that is weakly SD-preferred to
  the original one by all agents.
\<close>

context
  fixes p :: "'alt lottery"
  assumes lott: "p \<in> lotteries_on alts"
begin

private definition improve_lottery :: "'alt lottery \<Rightarrow> 'alt lottery" where
  "improve_lottery q = (let A = {r\<in>lotteries_on alts. r \<succ>[Pareto(SD\<circ>R)] q} in
     (SOME r. r \<in> A \<and> \<not>(\<exists>r'\<in>A. set_pmf r' \<subset> set_pmf r)))"

private lemma improve_lottery:
  assumes "\<not>SD_efficient R q"
  defines "r \<equiv> improve_lottery q"
  shows   "r \<in> lotteries_on alts" "r \<succ>[Pareto(SD\<circ>R)] q"
          "\<And>r'. r' \<in> lotteries_on alts \<Longrightarrow> r' \<succ>[Pareto(SD\<circ>R)] q \<Longrightarrow> \<not>(set_pmf r' \<subset> set_pmf r)"
proof -
  def A \<equiv> "{r\<in>lotteries_on alts. r \<succ>[Pareto(SD\<circ>R)] q}"
  have subset_alts: "X \<subseteq> alts" if "X \<in> set_pmf`A" for X using that
    by (auto simp: A_def lotteries_on_def)
  have r_altdef: "r = (SOME r. r \<in> A \<and> \<not>(\<exists>r'\<in>A. set_pmf r' \<subset> set_pmf r))"
    unfolding r_def improve_lottery_def Let_def A_def by simp
  from assms have nonempty: "A \<noteq> {}" by (auto simp: A_def SD_efficient_def)
  hence nonempty': "set_pmf`A \<noteq> {}" by simp
  have "set_pmf ` A \<subseteq> Pow alts" by (auto simp: A_def lotteries_on_def)

  from finite_alts have wf: "wf {(X,Y). X \<subset> Y \<and> Y \<subseteq> alts}"
    by (rule finite_subset_wf)
  obtain X
    where "X \<in> set_pmf`A" "\<And>Y. Y \<subset> X \<and> X \<subseteq> alts \<Longrightarrow> Y \<notin> set_pmf ` A"
    by (rule wfE_min'[OF wf nonempty']) simp_all
  hence "\<exists>r. r \<in> A \<and> \<not>(\<exists>r'\<in>A. set_pmf r' \<subset> set_pmf r)"
    by (auto simp: subset_alts[of X])
  from someI_ex[OF this, folded r_altdef]
    show "r \<in> lotteries_on alts" "r \<succ>[Pareto(SD\<circ>R)] q"
          "\<And>r'. r' \<in> lotteries_on alts \<Longrightarrow> r' \<succ>[Pareto(SD\<circ>R)] q \<Longrightarrow> \<not>(set_pmf r' \<subset> set_pmf r)"
    unfolding A_def by blast+
qed

private fun sd_chain :: "nat \<Rightarrow> 'alt lottery option" where
  "sd_chain 0 = Some p"
| "sd_chain (Suc n) =
     (case sd_chain n of
        None \<Rightarrow> None
      | Some p \<Rightarrow> if SD_efficient R p then None else Some (improve_lottery p))"

private lemma sd_chain_None_propagate:
  "m \<ge> n \<Longrightarrow> sd_chain n = None \<Longrightarrow> sd_chain m = None"
  by (induction rule: inc_induct) simp_all

private lemma sd_chain_Some_propagate:
  "m \<ge> n \<Longrightarrow> sd_chain m = Some q \<Longrightarrow> \<exists>q'. sd_chain n = Some q'"
  by (cases "sd_chain n") (auto simp: sd_chain_None_propagate)

private lemma sd_chain_NoneD:
  "sd_chain n = None \<Longrightarrow> \<exists>n p. sd_chain n = Some p \<and> SD_efficient R p"
  by (induction n) (auto split: option.splits if_splits)

private lemma sd_chain_lottery: "sd_chain n = Some q \<Longrightarrow> q \<in> lotteries_on alts"
  by (induction n) (insert lott, auto split: option.splits if_splits simp: improve_lottery)

private lemma sd_chain_Suc:
  assumes "sd_chain m = Some q"
  assumes "sd_chain (Suc m) = Some r"
  shows   "q \<prec>[Pareto(SD\<circ>R)] r"
  using assms by (auto split: if_splits simp: improve_lottery)

private lemma sd_chain_strictly_preferred:
  assumes "m < n"
  assumes "sd_chain m = Some q"
  assumes "sd_chain n = Some s"
  shows   "q \<prec>[Pareto(SD\<circ>R)] s"
  using assms
proof (induction arbitrary: q rule: strict_inc_induct)
  case (base k q)
  with sd_chain_Suc[of k q s] show ?case by (simp del: sd_chain.simps add: o_def)
next
  case (step k q)
  from step.hyps have "Suc k \<le> n" by simp
  from sd_chain_Some_propagate[OF this, of s] step.prems obtain r
    where r: "sd_chain (Suc k) = Some r" by (auto simp del: sd_chain.simps)
  with step.prems have "q \<prec>[Pareto (SD \<circ> R)] r" by (intro sd_chain_Suc)
  moreover from r step.prems have "r \<prec>[Pareto (SD \<circ> R)] s" by (intro step.IH) simp_all
  ultimately show ?case by (rule SD.Pareto.strict_trans)
qed

private lemma sd_chain_preferred:
  assumes "m \<le> n"
  assumes "sd_chain m = Some q"
  assumes "sd_chain n = Some s"
  shows   "q \<preceq>[Pareto(SD\<circ>R)] s"
proof (cases "m < n")
  case True
  from sd_chain_strictly_preferred[OF this assms(2,3)] show ?thesis
    by (simp add: strongly_preferred_def)
next
  case False
  with assms show ?thesis by (auto intro: SD.Pareto.refl sd_chain_lottery)
qed

lemma SD_efficient_lottery_exists:
  obtains q where "q \<in> lotteries_on alts" "q \<succeq>[Pareto(SD\<circ>R)] p" "SD_efficient R q"
proof -
  consider "\<exists>n. sd_chain n = None" | "\<forall>n. \<exists>q. sd_chain n = Some q"
    using option.exhaust by metis
  thus ?thesis
  proof cases
    case 1
    def m \<equiv> "LEAST m. sd_chain m = None"
    def k \<equiv> "m - 1"
    from LeastI_ex[OF 1] have m: "sd_chain m = None" by (simp add: m_def)
    from m have nz: "m \<noteq> 0" by (intro notI) simp_all
    from nz have m_altdef: "m = Suc k" by (simp add: k_def)
    from nz Least_le[of "\<lambda>m. sd_chain m = None" "m - 1", folded m_def]
      obtain q where q: "sd_chain k = Some q" by (cases "sd_chain (m - 1)") (auto simp: k_def)
    from sd_chain_preferred[OF _ sd_chain.simps(1) this] have "q \<succeq>[Pareto(SD\<circ>R)] p" by simp
    moreover from q have "q \<in> lotteries_on alts" by (simp add: sd_chain_lottery)
    moreover from q m have "SD_efficient R q" by (auto split: if_splits simp: m_altdef)
    ultimately show ?thesis using that[of q] by blast
  next
    case 2
    have "range (set_pmf \<circ> the \<circ> sd_chain) \<subseteq> Pow alts" unfolding o_def
    proof safe
      fix n x assume A: "x \<in> set_pmf (the (sd_chain n))"
      from 2 obtain q where "sd_chain n = Some q" by auto
      with sd_chain_lottery[of n q] have "set_pmf (the (sd_chain n)) \<subseteq> alts"
        by (simp add: lotteries_on_def)
      with A show "x \<in> alts" by blast
    qed
    hence "finite (range (set_pmf \<circ> the \<circ> sd_chain))" by (rule finite_subset) simp_all
    from pigeonhole_infinite[OF infinite_UNIV_nat this]
      obtain m where "infinite {n. set_pmf (the (sd_chain n)) = set_pmf (the (sd_chain m))}"
      by auto
    hence "infinite ({n. set_pmf (the (sd_chain n)) = set_pmf (the (sd_chain m))} - {k. \<not>(k > m)})"
      by (simp add: not_less)
    hence "({n. set_pmf (the (sd_chain n)) = set_pmf (the (sd_chain m))} - {k. \<not>(k > m)}) \<noteq> {}"
      by (intro notI) simp_all
    then obtain n where mn: "n > m" "set_pmf (the (sd_chain n)) = set_pmf (the (sd_chain m))"
      by blast
    from 2 obtain p q where pq: "sd_chain m = Some p" "sd_chain n = Some q" by blast
    from mn pq have supp_eq: "set_pmf p = set_pmf q" by simp
    from mn(1) pq have less: "p \<prec>[Pareto(SD\<circ>R)] q" by (rule sd_chain_strictly_preferred)

    from \<open>m < n\<close> have "n > 0" by simp
    with \<open>sd_chain n = Some q\<close> sd_chain.simps(2)[of "n - 1"]
      obtain r where r: "\<not>SD_efficient R r" "q = improve_lottery r"
      by (auto simp del: sd_chain.simps split: if_splits option.splits)

    from pq have "p \<in> lotteries_on alts" "q \<in> lotteries_on alts"
      by (simp_all add: sd_chain_lottery)
    from improve_lottery_support_subset[OF this less supp_eq] guess s . note s = this
    from improve_lottery(2)[of r] r s have "s \<succ>[Pareto(SD\<circ>R)] r"
      by (auto intro: SD.Pareto.strict_weak_trans)
    from improve_lottery(3)[OF r(1) s(1) this] supp_eq r
      have "\<not>set_pmf s \<subset> set_pmf p" by simp
    with s(3) show ?thesis by contradiction
  qed
qed

end

lemma
  assumes "p \<in> lotteries_on alts"
  shows   "\<exists>q\<in>lotteries_on alts. q \<succeq>[Pareto(SD\<circ>R)] p \<and> SD_efficient R q"
  using SD_efficient_lottery_exists[OF assms] by blast

end

end


section\<open>\<open>\<Sigma>\<close>-Protocols\<close>

text\<open>\<open>\<Sigma>\<close>-protocols were first introduced as an abstract notion by Cramer \cite{Cramerthesis}.
We point the reader to \cite{sigma_protocols} for a good introduction to the primitive as well as informal proofs
of many of the constructions we formalise in this work. In particular the construction of commitment schemes from
\<open>\<Sigma>\<close>-protocols and the construction of compound AND and OR statements.

In this section we define \<open>\<Sigma>\<close>-protocols then provide a general proof that they can be used to construct commitment schemes.
Defining security for \<open>\<Sigma>\<close>-protocols uses a mixture of the game-based and simulation-based paradigms. The honest verifier
zero knowledge property is considered using simulation-based proof, thus we follow the follow the simulation-based formalisation
of \cite{DBLP:journals/afp/AspinallB19} and \cite{DBLP:conf/itp/Butler0G17}.\<close>

subsection\<open>Defining \<open>\<Sigma>\<close>-protocols\<close>

theory Sigma_Protocols imports
  CryptHOL.CryptHOL
  Commitment_Schemes
begin

type_synonym ('msg', 'challenge', 'response') conv_tuple = "('msg' \<times> 'challenge' \<times> 'response')"

type_synonym ('msg','response') sim_out = "('msg' \<times> 'response')"

type_synonym ('pub_input', 'msg', 'challenge', 'response', 'witness') prover_adversary
                  = "'pub_input' \<Rightarrow> ('msg', 'challenge', 'response') conv_tuple
                        \<Rightarrow> ('msg', 'challenge', 'response') conv_tuple \<Rightarrow> 'witness' spmf"

locale \<Sigma>_protocols_base =
  fixes init :: "'pub_input \<Rightarrow> 'witness \<Rightarrow> ('rand \<times> 'msg) spmf" \<comment> \<open>initial message in \<open>\<Sigma>\<close>-protocol\<close>
    and response :: "'rand \<Rightarrow> 'witness \<Rightarrow> 'challenge  \<Rightarrow> 'response spmf"
    and check :: "'pub_input \<Rightarrow> 'msg \<Rightarrow> 'challenge \<Rightarrow> 'response \<Rightarrow> bool"
    and Rel :: "('pub_input \<times> 'witness) set" \<comment> \<open>The relation the \<open>\<Sigma>\<close> protocol is considered over\<close>
    and S_raw :: "'pub_input \<Rightarrow> 'challenge \<Rightarrow> ('msg, 'response) sim_out spmf" \<comment> \<open>Simulator for the HVZK property\<close>
    and \ss :: "('pub_input, 'msg, 'challenge, 'response, 'witness) prover_adversary" \<comment> \<open>Special soundness adversary\<close>
    and challenge_space :: "'challenge set" \<comment> \<open>The set of valid challenges\<close>
    and valid_pub :: "'pub_input set"
  assumes domain_subset_valid_pub: "Domain Rel \<subseteq> valid_pub"
begin

lemma assumes "x \<in> Domain Rel" shows "\<exists> w. (x,w) \<in> Rel"
  using assms by auto

text\<open>The language defined by the relation is the set of all public inputs such that there exists a witness that satisfies the relation.\<close>

definition "L \<equiv> {x. \<exists> w. (x, w) \<in> Rel}"

text\<open>The first property of \<open>\<Sigma>\<close>-protocols we consider is completeness, we define a probabilistic programme
that runs the components of the protocol and outputs the boolean defined by the check algorithm.\<close>

definition completeness_game :: "'pub_input \<Rightarrow> 'witness \<Rightarrow> 'challenge \<Rightarrow> bool spmf"
  where "completeness_game h w e = do {
    (r, a) \<leftarrow> init h w;
    z \<leftarrow> response r w e;
    return_spmf (check h a e z)}"

text\<open>We define completeness as the probability that the completeness-game returns true for all challenges assuming the relation holds on \<open>h\<close> and \<open>w\<close>.\<close>

definition "completeness \<equiv> (\<forall> h w e . (h,w) \<in> Rel \<longrightarrow> e \<in> challenge_space \<longrightarrow> spmf (completeness_game h w e) True = 1)"

text\<open>Second we consider the honest verifier zero knowledge property (HVZK). To reason about this we construct the real view of the
\<open>\<Sigma>\<close>-protocol given a challenge \<open>e\<close> as input.\<close>

definition R :: "'pub_input \<Rightarrow> 'witness \<Rightarrow> 'challenge \<Rightarrow> ('msg, 'challenge, 'response) conv_tuple spmf"
  where "R h w e = do {
    (r,a) \<leftarrow> init h w;
    z \<leftarrow> response r w e;
    return_spmf (a,e,z)}"

definition S where "S h e = map_spmf (\<lambda> (a, z). (a, e, z)) (S_raw h e)"

lemma lossless_S_raw_imp_lossless_S: "lossless_spmf (S_raw h e) \<longrightarrow> lossless_spmf (S h e)"
  by(simp add: S_def)

text\<open>The HVZK property requires that the simulator's output distribution is equal to the real views output distribution.\<close>

definition "HVZK \<equiv> (\<forall>e \<in> challenge_space.
                      (\<forall>(h, w)\<in>Rel. R h w e = S h e)
                        \<and> (\<forall>h \<in> valid_pub. \<forall>(a, z) \<in> set_spmf (S_raw h e). check h a e z))"

text\<open>The final property to consider is that of special soundness. This says that given two valid transcripts such that the challenges
are not equal there exists an adversary \<open>\ss\<close> that can output the witness.\<close>

definition "special_soundness \<equiv> (\<forall> h e e' a z z'. h \<in> valid_pub \<longrightarrow> e \<in> challenge_space \<longrightarrow> e' \<in> challenge_space \<longrightarrow>  e \<noteq> e'
              \<longrightarrow> check h a e z \<longrightarrow> check h a e' z' \<longrightarrow> (lossless_spmf (\ss h (a,e,z) (a, e', z')) \<and>
                  (\<forall>w'\<in>set_spmf (\ss h (a,e,z) (a,e',z')). (h,w') \<in> Rel)))"

lemma special_soundness_alt:
  "special_soundness \<longleftrightarrow>
      (\<forall> h a e z e' z'. e \<in> challenge_space \<longrightarrow> e' \<in> challenge_space \<longrightarrow> h \<in> valid_pub
          \<longrightarrow> e \<noteq> e' \<longrightarrow> check h a e z \<and> check h a e' z'
              \<longrightarrow> bind_spmf (\ss h (a,e,z) (a,e',z')) (\<lambda> w'. return_spmf ((h,w') \<in> Rel)) = return_spmf True)"
  apply(auto simp add: special_soundness_def map_spmf_conv_bind_spmf[symmetric] map_pmf_eq_return_pmf_iff in_set_spmf lossless_iff_set_pmf_None)
  apply(metis Domain.DomainI in_set_spmf not_Some_eq)
  using Domain.intros by blast +

definition "\<Sigma>_protocol \<equiv> completeness \<and> special_soundness \<and> HVZK"

text\<open>General lemmas\<close>

lemma lossless_complete_game:
  assumes lossless_init: "\<forall> h w. lossless_spmf (init h w)"
    and lossless_response: "\<forall> r w e. lossless_spmf (response r w e)"
  shows "lossless_spmf (completeness_game h w e)"
  by(simp add: completeness_game_def lossless_init lossless_response split_def)

lemma complete_game_return_true:
  assumes "(h,w) \<in> Rel"
    and "completeness"
    and lossless_init: "\<forall> h w. lossless_spmf (init h w)"
    and lossless_response: "\<forall> r w e. lossless_spmf (response r w e)"
    and "e \<in> challenge_space"
  shows "completeness_game h w e = return_spmf True"
proof -
  have "spmf (completeness_game h w e) True = spmf (return_spmf True) True"
    using assms \<Sigma>_protocol_def completeness_def by fastforce
  then have "completeness_game h w e = return_spmf True"
    by (metis (full_types) lossless_complete_game lossless_init lossless_response lossless_return_spmf spmf_False_conv_True spmf_eqI)
  then show ?thesis
    by (simp add: completeness_game_def)
qed

lemma HVZK_unfold1:
  assumes "\<Sigma>_protocol"
  shows "\<forall> h w e. (h,w) \<in> Rel \<longrightarrow> e \<in> challenge_space \<longrightarrow> R h w e = S h e"
  using assms by(auto simp add: \<Sigma>_protocol_def HVZK_def)

lemma HVZK_unfold2:
  assumes "\<Sigma>_protocol"
  shows "\<forall> h e out. e \<in> challenge_space \<longrightarrow> h \<in> valid_pub \<longrightarrow> out \<in> set_spmf (S_raw h e) \<longrightarrow> check h (fst out) e (snd out)"
  using assms by(auto simp add: \<Sigma>_protocol_def HVZK_def split_def)

lemma HVZK_unfold2_alt:
  assumes "\<Sigma>_protocol"
  shows "\<forall> h a e z. e \<in> challenge_space \<longrightarrow> h \<in> valid_pub \<longrightarrow> (a,z) \<in> set_spmf (S_raw h e) \<longrightarrow> check h a e z"
  using assms by(fastforce simp add: \<Sigma>_protocol_def HVZK_def)

end

subsection\<open>Commitments from \<open>\<Sigma>\<close>-protocols\<close>

text\<open>In this section we provide a general proof that \<open>\<Sigma>\<close>-protocols can be used to construct commitment schemes.
We follow  the construction given by Damgard in \cite{sigma_protocols}.\<close>

locale \<Sigma>_protocols_to_commitments = \<Sigma>_protocols_base init response check Rel S_raw \ss challenge_space valid_pub
  for init :: "'pub_input \<Rightarrow> 'witness \<Rightarrow> ('rand \<times> 'msg) spmf"
    and response :: "'rand \<Rightarrow> 'witness \<Rightarrow> 'challenge \<Rightarrow> 'response spmf"
    and check :: "'pub_input \<Rightarrow> 'msg \<Rightarrow> 'challenge \<Rightarrow> 'response \<Rightarrow> bool"
    and Rel :: "('pub_input \<times> 'witness) set"
    and S_raw :: "'pub_input \<Rightarrow> 'challenge \<Rightarrow> ('msg, 'response) sim_out spmf"
    and \ss :: "('pub_input, 'msg, 'challenge, 'response, 'witness) prover_adversary"
    and challenge_space :: "'challenge set"
    and valid_pub :: "'pub_input set"
    and G :: "('pub_input \<times> 'witness) spmf" \<comment> \<open>generates pairs that satisfy the relation\<close>
    +
  assumes \<Sigma>_prot: "\<Sigma>_protocol" \<comment> \<open>assume we have a \<open>\<Sigma>\<close>-protocol\<close>
    and set_spmf_G_rel [simp]: "(h,w) \<in> set_spmf G \<Longrightarrow> (h,w) \<in> Rel" \<comment> \<open>the generator has the desired property\<close>
    and lossless_G: "lossless_spmf G"
    and lossless_init: "lossless_spmf (init h w)"
    and lossless_response: "lossless_spmf (response r w e)"
begin

lemma set_spmf_G_domain_rel [simp]: "(h,w) \<in> set_spmf G \<Longrightarrow> h \<in> Domain Rel"
  using set_spmf_G_rel by fast

lemma set_spmf_G_L [simp]: "(h,w) \<in> set_spmf G \<Longrightarrow> h \<in> L"
  by (metis mem_Collect_eq set_spmf_G_rel L_def)

text\<open>We define the advantage associated with the hard relation, this is used in the proof of the binding property where
we reduce the binding advantage to the relation advantage.\<close>

definition rel_game :: "('pub_input \<Rightarrow> 'witness spmf) \<Rightarrow> bool spmf"
  where "rel_game \ = TRY do {
    (h,w) \<leftarrow> G;
    w' \<leftarrow> \ h;
    return_spmf ((h,w') \<in> Rel)} ELSE return_spmf False"

definition rel_advantage :: "('pub_input \<Rightarrow> 'witness spmf) \<Rightarrow> real"
  where "rel_advantage \ \<equiv> spmf (rel_game \) True"

text\<open>We now define the algorithms that define the commitment scheme constructed from a \<open>\<Sigma>\<close>-protocol.\<close>

definition key_gen :: "('pub_input \<times>  ('pub_input \<times> 'witness)) spmf"
  where
   "key_gen = do {
    (x,w) \<leftarrow> G;
    return_spmf (x, (x,w))}"

definition commit :: "'pub_input \<Rightarrow> 'challenge \<Rightarrow> ('msg \<times>  'response) spmf"
  where
    "commit x e = do {
    (a,e,z) \<leftarrow> S x e;
    return_spmf (a, z)}"

definition verify :: "('pub_input \<times> 'witness) \<Rightarrow> 'challenge \<Rightarrow> 'msg \<Rightarrow>  'response \<Rightarrow> bool"
  where "verify x e a z = (check (fst x) a e z)"

text\<open>We allow the adversary to output any message, so this means the type constraint is enough\<close>

definition "valid_msg m = (m \<in> challenge_space)"

text\<open>Showing the construction of a commitment scheme from a \<open>\<Sigma>\<close>-protocol is a  valid commitment scheme is trivial.\<close>

sublocale abstract_com: abstract_commitment key_gen commit verify valid_msg .

paragraph\<open>Correctness\<close>

lemma commit_correct:
  shows "abstract_com.correct"
  including monad_normalisation
proof-
  have "\<forall> m \<in> challenge_space. abstract_com.correct_game m = return_spmf True"
  proof
    fix m
    assume m: "m \<in> challenge_space"
    show "abstract_com.correct_game m = return_spmf True"
    proof-
    have "abstract_com.correct_game m = do {
      (ck, (vk1,vk2)) \<leftarrow> key_gen;
      (a,e,z) \<leftarrow> S ck m;
      return_spmf (check vk1 a m z)}"
      unfolding abstract_com.correct_game_def
      by(simp add: commit_def verify_def split_def)
    also have "... = do {
      (x,w) \<leftarrow> G;
      let (ck, (vk1,vk2)) = (x,(x,w));
      (a,e,z) \<leftarrow> S ck m;
      return_spmf (check vk1 a m z)}"
      by(simp add: key_gen_def split_def)
    also have "... = do {
      (x,w) \<leftarrow> G;
      (a,e,z) \<leftarrow> S x m;
      return_spmf (check x a m z)}"
      by(simp add: Let_def)
    also have "... = do {
      (x,w) \<leftarrow> G;
      (a, e,z) \<leftarrow> R x w m;
      return_spmf (check x a m z)}"
      using \<Sigma>_prot HVZK_unfold1 m
      by(intro bind_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)
    also have "... = do {
      (x,w) \<leftarrow> G;
      (r, a) \<leftarrow> init x w;
      z \<leftarrow> response r w m;
      return_spmf (check x a m z)}"
      by(simp add: R_def split_def)
    also have "... = do {
      (x,w) \<leftarrow> G;
      return_spmf True}"
      apply(intro bind_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)
      using complete_game_return_true lossless_init lossless_response \<Sigma>_prot \<Sigma>_protocol_def
      by(simp add: split_def completeness_game_def \<Sigma>_protocols_base.\<Sigma>_protocol_def m cong: bind_spmf_cong_simp)
    ultimately show "abstract_com.correct_game m = return_spmf True"
      by(simp add: bind_spmf_const lossless_G lossless_weight_spmfD split_def)
  qed
qed
  thus ?thesis
    using abstract_com.correct_def abstract_com.valid_msg_set_def valid_msg_def by simp
qed

paragraph\<open>The hiding property\<close>

text\<open>We first show we have perfect hiding with respect to the hiding game that allows the adversary to choose
the messages that are committed to, this is akin to the ind-cpa game for encryption schemes.\<close>

lemma perfect_hiding:
  shows "abstract_com.perfect_hiding_ind_cpa \"
  including monad_normalisation
proof-
  obtain \1 \2 where [simp]: "\ = (\1, \2)" by(cases \)
  have "abstract_com.hiding_game_ind_cpa (\1, \2) = TRY do {
    (x,w) \<leftarrow> G;
    ((m0, m1), \<sigma>) \<leftarrow> \1 (x,w);
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    (a,e,z) \<leftarrow> S x (if b then m0 else m1);
    b' \<leftarrow> \2 a \<sigma>;
    return_spmf (b' = b)} ELSE coin_spmf"
    by(simp add: abstract_com.hiding_game_ind_cpa_def commit_def; simp add: key_gen_def split_def)
  also have "... = TRY do {
    (x,w) \<leftarrow> G;
    ((m0, m1), \<sigma>) \<leftarrow> \1 (x,w);
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b :: bool \<leftarrow> coin_spmf;
    (a,e,z) \<leftarrow> R x w (if b then m0 else m1);
    b' :: bool \<leftarrow> \2 a \<sigma>;
    return_spmf (b' = b)} ELSE coin_spmf"
    apply(intro try_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)+
    by(simp add: \<Sigma>_prot  HVZK_unfold1 valid_msg_def)
  also have "... = TRY do {
    (x,w) \<leftarrow> G;
    ((m0, m1), \<sigma>) \<leftarrow> \1 (x,w);
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    (r,a) \<leftarrow> init x w;
    z :: 'response \<leftarrow> response r w (if b then m0 else m1);
    guess :: bool \<leftarrow> \2 a \<sigma>;
    return_spmf(guess = b)} ELSE coin_spmf"
    using \<Sigma>_protocols_base.R_def
    by(simp add: bind_map_spmf o_def R_def split_def)
  also have  "... = TRY do {
    (x,w) \<leftarrow> G;
    ((m0, m1), \<sigma>) \<leftarrow> \1 (x,w);
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    (r,a) \<leftarrow> init x w;
    guess :: bool \<leftarrow> \2 a \<sigma>;
    return_spmf(guess = b)} ELSE coin_spmf"
    by(simp add: bind_spmf_const lossless_response lossless_weight_spmfD)
  also have  "... = TRY do {
    (x,w) \<leftarrow> G;
    ((m0, m1), \<sigma>) \<leftarrow> \1 (x,w);
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    (r,a) \<leftarrow> init x w;
    guess :: bool \<leftarrow> \2 a \<sigma>;
    map_spmf( (=) guess) coin_spmf} ELSE coin_spmf"
    apply(simp add: map_spmf_conv_bind_spmf)
    by(simp add: split_def)
  also have "... = coin_spmf"
    by(auto simp add: map_eq_const_coin_spmf try_bind_spmf_lossless2' Let_def split_def bind_spmf_const scale_bind_spmf weight_spmf_le_1 scale_scale_spmf)
  ultimately have "spmf (abstract_com.hiding_game_ind_cpa \) True = 1/2"
    by(simp add: spmf_of_set)
  thus ?thesis
    by (simp add: abstract_com.perfect_hiding_ind_cpa_def abstract_com.hiding_advantage_ind_cpa_def)
qed

text\<open>We reduce the security of the binding property to the relation advantage. To do this we first construct
an adversary that interacts with the relation game. This adversary succeeds if the binding adversary succeeds.\<close>

definition adversary :: "('pub_input \<Rightarrow> ('msg \<times> 'challenge \<times> 'response \<times> 'challenge \<times> 'response) spmf) \<Rightarrow> 'pub_input \<Rightarrow> 'witness spmf"
  where "adversary \ x = do {
    (c, e, ez, e', ez') \<leftarrow> \ x;
    \ss x (c,e,ez) (c,e',ez')}"

lemma bind_advantage:
  shows "abstract_com.bind_advantage \ \<le> rel_advantage (adversary \)"
proof-
  have "abstract_com.bind_game \ = TRY do {
  (x,w) \<leftarrow> G;
  (c, m, d, m', d') \<leftarrow> \ x;
  _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> m \<in> challenge_space \<and> m' \<in> challenge_space);
  let b = check x c m d;
  let b' = check x c m' d';
  _ :: unit \<leftarrow> assert_spmf (b \<and> b');
  w' \<leftarrow> \ss x (c,m, d) (c,m', d');
  return_spmf ((x,w') \<in> Rel)} ELSE return_spmf False"
    unfolding abstract_com.bind_game_alt_def
    apply(simp add:  key_gen_def verify_def Let_def split_def valid_msg_def)
    apply(intro try_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)+
    using special_soundness_def \<Sigma>_prot \<Sigma>_protocol_def special_soundness_alt special_soundness_def set_spmf_G_rel set_spmf_G_domain_rel
    by (smt basic_trans_rules(31) bind_spmf_cong domain_subset_valid_pub)
  hence "abstract_com.bind_advantage \ \<le> spmf (TRY do {
  (x,w) \<leftarrow> G;
  (c, m, d, m', d') \<leftarrow> \ x;
  w' \<leftarrow> \ss x (c,m, d) (c,m', d');
  return_spmf ((x,w') \<in> Rel)} ELSE return_spmf False) True"
    unfolding abstract_com.bind_advantage_def
    apply(simp add: spmf_try_spmf)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(simp add: assert_spmf_def)
  thus ?thesis
    by(simp add: rel_game_def adversary_def split_def rel_advantage_def)
qed

end

end


theory completeness
    imports Main def
begin

lemma identity: "\<P>(formulaA F \<turnstile>\<^sub>C formula F)"
proof(induction F)
case Truth
then show ?case
  by (simp add: TopR)
next
case Falsity
  then show ?case
    by (simp add: BotL)
next
  case MTruth
  then show ?case
    by (simp add: TopMultL TopMultR)
next
  case (Atom x)
  then show ?case
    by (simp add: id)
next
  case (Neg F)
  then show ?case
  proof-
    have "\<P>(\<sharp>\<^sub>A (formula F) \<turnstile>\<^sub>C \<sharp> (formulaA F))"
      using Neg.IH equiv postulateCL5 by blast
    then have "\<P>(\<sharp>\<^sub>A (formula F) \<turnstile>\<^sub>C (formula (\<not>\<^sub>B F)))"
      by (simp add: notR)
    then have "\<P>((formulaA (\<not>\<^sub>B F)) \<turnstile>\<^sub>C (formula (\<not>\<^sub>B F)))"
      by (simp add: notL)
    then show ?case
      by simp
  qed
next
  case (Con F1 F2)
  then show ?case
  proof-
    note \<open>\<P> (formulaA F1 \<turnstile>\<^sub>C formula F1)\<close>
    then have "\<P>(((formulaA F1) ;\<^sub>A (formulaA F2)) \<turnstile>\<^sub>C formula F1)"
      by (simp add: WkL)
    then have "\<P>((formulaA (F1 \<and>\<^sub>B F2)) \<turnstile>\<^sub>C formula F1)"
      by (simp add: andL)
    note \<open>\<P> (formulaA F2 \<turnstile>\<^sub>C formula F2)\<close>
    then have "\<P>(((formulaA F2) ;\<^sub>A (formulaA F1)) \<turnstile>\<^sub>C formula F2)"
      using WkL by simp
    then have "\<P>(((formulaA F1) ;\<^sub>A (formulaA F2)) \<turnstile>\<^sub>C formula F2)"
      using equiv postulateCL1 postulateCL2 by blast
    then have "\<P>((formulaA (F1 \<and>\<^sub>B F2)) \<turnstile>\<^sub>C formula F2)"
      by (simp add: andL)
    note \<open>\<P>((formulaA (F1 \<and>\<^sub>B F2)) \<turnstile>\<^sub>C formula F1)\<close> \<open>\<P>((formulaA (F1 \<and>\<^sub>B F2)) \<turnstile>\<^sub>C formula F2)\<close>
    then show ?case
      by (simp add: andR)
  qed
next
  case (MCon F1 F2)
  then show ?case
  proof -
    note \<open>\<P> (formulaA F1 \<turnstile>\<^sub>C formula F1)\<close> \<open>\<P> (formulaA F2 \<turnstile>\<^sub>C formula F2)\<close>
    then have "\<P>(((formulaA F1) ,\<^sub>A (formulaA F2)) \<turnstile>\<^sub>C formula (F1 *\<^sub>B F2))"
      using andMultR by blast
    then show ?case
      by (simp add: andMultL)
  qed
next
  case (Dis F1 F2)
  then show ?case
  proof -
    note \<open>\<P> (formulaA F1 \<turnstile>\<^sub>C formula F1)\<close>
    then have "\<P>(formulaA F1 \<turnstile>\<^sub>C ((formula F1) ; (formula F2)))"
      using WkL equiv postulateCL4 by blast
    note \<open>\<P> (formulaA F2 \<turnstile>\<^sub>C formula F2)\<close>
    then have "\<P>(formulaA F2 \<turnstile>\<^sub>C ((formula F1) ; (formula F2)))"
      using WkR by simp
    note\<open>\<P>(formulaA F1 \<turnstile>\<^sub>C ((formula F1) ; (formula F2)))\<close>
        \<open>\<P>(formulaA F2 \<turnstile>\<^sub>C ((formula F1) ; (formula F2)))\<close>
    then show ?case
      by (simp add: orL orR)
  qed
next
  case (Imp F1 F2)
  then show ?case
  proof -
    note\<open>\<P> (formulaA F1 \<turnstile>\<^sub>C formula F1)\<close>\<open>\<P> (formulaA F2 \<turnstile>\<^sub>C formula F2)\<close>
    then have "\<P>(formulaA (F1 \<rightarrow>\<^sub>B F2) \<turnstile>\<^sub>C ((\<sharp> (formulaA F1)) ; (formula F2)))"
      using impL by blast
    then have "\<P>(((formulaA (F1 \<rightarrow>\<^sub>B F2)) ;\<^sub>A (formulaA F1)) \<turnstile>\<^sub>C formula F2)"
      using equiv postulateCL1S by blast
    then show ?case
      by (simp add: impR)
  qed
next
  case (Mimp F1 F2)
  then show ?case
  proof -
    note \<open>\<P> (formulaA F1 \<turnstile>\<^sub>C formula F1)\<close> \<open>\<P> (formulaA F2 \<turnstile>\<^sub>C formula F2)\<close>
    then have "\<P>(formulaA (F1 \<rightarrow>*\<^sub>B F2) \<turnstile>\<^sub>C (((formulaA F1)) \<rightarrow>\<circ> (formula F2)))"
      using impMultL by blast
    then have "\<P>((formulaA (F1 \<rightarrow>*\<^sub>B F2) ,\<^sub>A (formulaA F1)) \<turnstile>\<^sub>C formula F2 )"
      using equiv postulateCL7S by blast
    then show ?case
      by (simp add: impMultR)
  qed
qed

lemma \<Psi>R: "\<P>(X \<turnstile>\<^sub>C formula (\<Psi> X))" and \<Upsilon>L : "\<P>(formulaA (\<Upsilon> Y) \<turnstile>\<^sub>C Y)"
proof(induction X and Y)
case (formulaA x)
  then show ?case
    by (simp add: identity)
next
case AddNilA
  then show ?case
    by (simp add: TopR)
next
case (SharpA x)
  then show ?case
  proof-
    note \<open>\<P> (formulaA (\<Upsilon> x) \<turnstile>\<^sub>C x)\<close>
    then have "\<P> ((\<sharp>\<^sub>A x) \<turnstile>\<^sub>C (\<sharp>(formulaA(\<Upsilon> x))))"
      using equiv postulateCL5 by blast
    then have "\<P> ((\<sharp>\<^sub>A x) \<turnstile>\<^sub>C formula (\<not>\<^sub>B (\<Upsilon> x)))"
      by (simp add: notR)
    then show ?case
      by simp
  qed
next
case (SemiColonA x1 x2)
  then show ?case
  proof -
    note\<open>\<P> (x1 \<turnstile>\<^sub>C formula (\<Psi> x1))\<close>
    then have "\<P> (x1 ;\<^sub>A x2 \<turnstile>\<^sub>C formula (\<Psi> x1))"
      using WkL by blast
    note \<open>\<P> (x2 \<turnstile>\<^sub>C formula (\<Psi> x2))\<close>
    then have "\<P> (x1 ;\<^sub>A x2 \<turnstile>\<^sub>C formula (\<Psi> x2))"
      using WkR equiv postulateCL2 by blast
    note\<open>\<P> (x1 ;\<^sub>A x2 \<turnstile>\<^sub>C formula (\<Psi> x1))\<close> \<open>\<P> (x1 ;\<^sub>A x2 \<turnstile>\<^sub>C formula (\<Psi> x2))\<close>
    then show ?case
      using andR by simp
  qed
next
  case MultNilA
  then show ?case
    by (simp add: TopMultR)
next
  case (CommaA x1 x2)
  then show ?case
  proof -
    note\<open>\<P> (x1 \<turnstile>\<^sub>C formula (\<Psi> x1))\<close> \<open>\<P> (x2 \<turnstile>\<^sub>C formula (\<Psi> x2))\<close>
    then have "\<P>((x1 ,\<^sub>A x2) \<turnstile>\<^sub>C formula ((\<Psi> x1) *\<^sub>B (\<Psi> x2)))"
      by (simp add: andMultR)
    then show ?case
      by simp
  qed
next
  case (formula x)
  then show ?case
    by (simp add: identity)
next
  case AddNil
  then show ?case
    by (simp add: BotL)
next
  case (Sharp x)
  then show ?case
  proof -
    note\<open>\<P> (x \<turnstile>\<^sub>C formula (\<Psi> x))\<close>
    then have "\<P>(\<sharp>\<^sub>A (formula (\<Psi> x)) \<turnstile>\<^sub>C \<sharp> x)"
      using equiv postulateCL5 by blast
    then have "\<P>(formulaA (\<not>\<^sub>B (\<Psi> x)) \<turnstile>\<^sub>C \<sharp> x)"
      using notL by blast
    then show ?case
      by simp
  qed
next
  case (SemiColon x1 x2)
  then show ?case
  proof-
    note \<open>\<P> (formulaA (\<Upsilon> x1) \<turnstile>\<^sub>C x1)\<close>
    then have "\<P> (formulaA (\<Upsilon> x1) \<turnstile>\<^sub>C x1 ; x2)"
      using WkL equiv postulateCL4 by blast
    note \<open>\<P> (formulaA (\<Upsilon> x2) \<turnstile>\<^sub>C x2)\<close>
    then have "\<P> (formulaA (\<Upsilon> x2) \<turnstile>\<^sub>C x1 ; x2)"
      using WkR by simp
    note \<open>\<P> (formulaA (\<Upsilon> x1) \<turnstile>\<^sub>C x1 ; x2)\<close> \<open>\<P> (formulaA (\<Upsilon> x2) \<turnstile>\<^sub>C x1 ; x2)\<close>
    then have "\<P> (formulaA ((\<Upsilon> x1) \<or>\<^sub>B(\<Upsilon> x2)) \<turnstile>\<^sub>C x1 ; x2)"
      by (simp add: orL)
    then show ?case
      by simp
  qed
next
  case (DotArrow x1 x2)
  then show ?case
  proof -
    note \<open>\<P> (x1 \<turnstile>\<^sub>C formula (\<Psi> x1))\<close> \<open>\<P> (formulaA (\<Upsilon> x2) \<turnstile>\<^sub>C x2)\<close>
    then have "\<P>(formulaA ((\<Psi> x1) \<rightarrow>*\<^sub>B (\<Upsilon> x2)) \<turnstile>\<^sub>C x1 \<rightarrow>\<circ> x2)"
      by (simp add: impMultL)
    then show ?case
      by simp
  qed
qed

section "Completeness"

lemma intermediate: "\<Psi> X \<turnstile>\<^sub>B \<Upsilon> Y \<Longrightarrow> \<P>(formulaA (\<Psi> X) \<turnstile>\<^sub>C formula (\<Upsilon> Y))"
proof(induction rule: turnstile_BBI.induct)
case (Ax F)
  then show ?case
    by (simp add: identity)
next
  case (Top F)
  then show ?case using TopR by simp
next
  case (Bot F)
  then show ?case using BotL by simp
next
  case (ImpT F G H)
  then show ?case
  proof-
    note \<open>\<P> (formulaA (F \<and>\<^sub>B G) \<turnstile>\<^sub>C formula H)\<close>
    hence "\<P> (formulaA (\<Psi> (formulaA F ;\<^sub>A formulaA G)) \<turnstile>\<^sub>C formula H)"
      by simp
    hence "\<P> (formulaA F ;\<^sub>A formulaA G \<turnstile>\<^sub>C formula H)" using cut \<Psi>R by blast
    thus ?case
      using impR by blast
  qed
next
  case (ImpB F G H)
  then show ?case
  proof-
    have "\<P>(formulaA (G \<rightarrow>\<^sub>B H) \<turnstile>\<^sub>C \<sharp>(formulaA G) ; formula H)"
      by (simp add: identity impL)
    note\<open>\<P>(formulaA (G \<rightarrow>\<^sub>B H) \<turnstile>\<^sub>C \<sharp>(formulaA G) ; formula H)\<close> \<open>\<P> (formulaA F \<turnstile>\<^sub>C formula (G \<rightarrow>\<^sub>B H))\<close>
    hence "\<P>(formulaA F \<turnstile>\<^sub>C \<sharp>(formulaA G) ; formula H)"
      using cut by blast
    hence "\<P>(formulaA F ;\<^sub>A formulaA G \<turnstile>\<^sub>C formula H)"
      using equiv postulateCL1 postulateCL2 by blast
    thus ?case
      using andL by blast
  qed
next
  case (MP F G H)
  then show ?case using cut by blast
next
  case (Notl F)
  then show ?case
  proof-
    have"\<P>(formulaA F \<turnstile>\<^sub>C formula F)" using identity by simp
    hence"\<P>(\<sharp>\<^sub>A(formula F) \<turnstile>\<^sub>C \<sharp>(formulaA F))"
      using equiv postulateCL5 by blast
    hence "\<P>(\<sharp>\<^sub>A(formula F) \<turnstile>\<^sub>C (formula \<bottom>\<^sub>B) ; \<sharp>(formulaA F))"using WkR by simp
    hence "\<P>(\<sharp>\<^sub>A(formula F) \<turnstile>\<^sub>C  \<sharp>(formulaA F) ; (formula \<bottom>\<^sub>B))"
      using equiv postulateCL3 postulateCL4 by blast
    hence "\<P>(\<sharp>\<^sub>A(formula F) ;\<^sub>A formulaA F \<turnstile>\<^sub>C (formula \<bottom>\<^sub>B))"
      using equiv postulateCL1S by blast
    hence "\<P>(\<sharp>\<^sub>A(formula F) \<turnstile>\<^sub>C formula(F \<rightarrow>\<^sub>B \<bottom>\<^sub>B))"
      by (simp add: impR)
    thus ?case
      by (simp add: notL)
  qed
next
  case (Notr F)
  then show ?case
  proof-
    have "\<P>(formulaA F \<turnstile>\<^sub>C formula F)" using identity by simp
    have "\<P>(formulaA \<bottom>\<^sub>B \<turnstile>\<^sub>C \<sharp>(formulaA F))"
      by (simp add: BotL)
    have "\<P>(formulaA (F \<rightarrow>\<^sub>B \<bottom>\<^sub>B) \<turnstile>\<^sub>C \<sharp>(formulaA F) ; \<sharp>(formulaA F))"
      by (simp add: \<open>\<P> (formulaA F \<turnstile>\<^sub>C formula F)\<close> \<open>\<P> (formulaA \<bottom>\<^sub>B \<turnstile>\<^sub>C \<sharp> (formulaA F))\<close> impL)
    hence "\<P>(formulaA (F \<rightarrow>\<^sub>B \<bottom>\<^sub>B) \<turnstile>\<^sub>C \<sharp>(formulaA F))" using CtrR by blast
    thus ?case
      by (simp add: notR)
  qed
next
  case (Notnot F)
  then show ?case
  proof-
    have "\<P>(formulaA F \<turnstile>\<^sub>C formula F)" using identity by simp
    hence"\<P>(\<sharp>\<^sub>A(formula F) \<turnstile>\<^sub>C \<sharp>(formulaA F))"
      using equiv postulateCL5 by blast
    hence "\<P>(\<sharp>\<^sub>A(formula F) \<turnstile>\<^sub>C formula(\<not>\<^sub>B F))"
      using notR by simp
    hence "\<P>(\<sharp>\<^sub>A(formula F) \<turnstile>\<^sub>C \<sharp>(\<sharp>\<^sub>A(formula(\<not>\<^sub>B F))))"
      using equiv postulateCL5 postulateCL5S postulateCL6S by metis
    hence "\<P>(\<sharp>\<^sub>A(formula (\<not>\<^sub>B F)) \<turnstile>\<^sub>C formula F)"
      using equiv postulateCL5S by blast
    thus ?case
      by (simp add: notL)
  qed
next
  case (ConjI F G H)
  then show ?case using andR by blast
next
  case (DisjE F H G)
  then show ?case using orL by blast
next
  case (ConjE1 F G)
  then show ?case
  proof-
    have "\<P>(formulaA F \<turnstile>\<^sub>C formula F)" using identity by simp
    hence "\<P>((formulaA F) ;\<^sub>A (formulaA G) \<turnstile>\<^sub>C formula F)"
      using WkL by blast
    thus ?case using andL by simp
  qed
next
  case (ConjE2 F G)
  then show ?case
  proof-
    have "\<P>(formulaA G \<turnstile>\<^sub>C formula G)" using identity by simp
    hence "\<P>((formulaA G) ;\<^sub>A (formulaA F) \<turnstile>\<^sub>C formula G)"
      using WkL by blast
    hence "\<P>((formulaA F) ;\<^sub>A (formulaA G) \<turnstile>\<^sub>C formula G)"
      using equiv postulateCL1 postulateCL2 by blast
    thus ?case
      by (simp add: andL)
  qed
next
  case (DisjI1 F G)
  then show ?case
  proof-
    have "\<P>(formulaA F \<turnstile>\<^sub>C formula F)" using identity by simp
    hence "\<P>(formulaA F \<turnstile>\<^sub>C formula G ; formula F)" using WkR by blast
    hence "\<P>(formulaA F \<turnstile>\<^sub>C formula F ; formula G)"
      using equiv postulateCL3 postulateCL4 by blast
    thus ?case
      by (simp add: orR)
  qed
next
  case (DisjI2 G F)
  then show ?case
  proof-
    have "\<P>(formulaA G \<turnstile>\<^sub>C formula G)" using identity by simp
    hence "\<P>(formulaA G \<turnstile>\<^sub>C formula F ; formula G)"
      by (simp add: WkR)
    thus ?case
      by (simp add: orR)
  qed
next
  case (Topl F)
  then show ?case
  proof-
    have "\<P>(formulaA F \<turnstile>\<^sub>C formula F)" using identity by simp
    hence "\<P>(\<oslash> ,\<^sub>A formulaA F \<turnstile>\<^sub>C formula F)"
      using nilMultL_sym by blast
    hence "\<P>(\<oslash> \<turnstile>\<^sub>C formulaA F \<rightarrow>\<circ> formula F)"
      using equiv postulateCL7 by blast
    hence "\<P>(formulaA \<top>\<^sup>*\<^sub>B \<turnstile>\<^sub>C formulaA F \<rightarrow>\<circ> formula F)"
      using TopMultL by blast
    hence "\<P>(formulaA F ,\<^sub>A formulaA \<top>\<^sup>*\<^sub>B \<turnstile>\<^sub>C  formula F)"
      using equiv postulateCL8 by blast
    thus ?case
      by (simp add: andMultL)
  qed
next
  case (Topr F)
  then show ?case
  proof-
    have "\<P>(formulaA F \<turnstile>\<^sub>C formula F)" using identity by simp
    hence "\<P>(formulaA F ,\<^sub>A \<oslash> \<turnstile>\<^sub>C formula (F *\<^sub>B \<top>\<^sup>*\<^sub>B))"
      using TopMultR andMultR by blast
    hence "\<P>(\<oslash> ,\<^sub>A formulaA F \<turnstile>\<^sub>C formula (F *\<^sub>B \<top>\<^sup>*\<^sub>B))"
      using equiv postulateCL7 postulateCL8 by blast
    thus ?case
      using nilMultL by blast
  qed
next
  case (ImpstarT F G H)
  then show ?case
  proof-
    note\<open>\<P> (formulaA (F *\<^sub>B G) \<turnstile>\<^sub>C formula H)\<close>
    hence "\<P> (formulaA (\<Psi> (formulaA F) *\<^sub>B \<Psi> (formulaA G)) \<turnstile>\<^sub>C formula H)"
      by simp
    hence "\<P> (formulaA (\<Psi> (formulaA F ,\<^sub>A formulaA G)) \<turnstile>\<^sub>C formula H)"
      by simp
    hence "\<P> (formulaA F ,\<^sub>A formulaA G \<turnstile>\<^sub>C formula H)"
      using \<Psi>R cut by blast
    thus ?case
      using impMultR by blast
  qed

next
  case (ImpstarB F G H)
  then show ?case
  proof-
    note \<open>\<P> (formulaA F \<turnstile>\<^sub>C formula (G \<rightarrow>*\<^sub>B H))\<close>
    hence "\<P> (formulaA F \<turnstile>\<^sub>C formulaA G \<rightarrow>\<circ> formula H)"
      using cut identity impMultL by blast
    hence "\<P> (formulaA F ,\<^sub>A formulaA G \<turnstile>\<^sub>C formula H)"
      using equiv postulateCL7S by blast
    thus ?case
      by (simp add: andMultL)
  qed
next
  case (Assocl F G H)
  then show ?case
  proof-
    have "\<P>((formulaA F ,\<^sub>A formulaA G) ,\<^sub>A formulaA H \<turnstile>\<^sub>C formula ((F *\<^sub>B G) *\<^sub>B H))"
      by (simp add: andMultR identity)
    hence "\<P>(formulaA F ,\<^sub>A (formulaA G ,\<^sub>A formulaA H) \<turnstile>\<^sub>C formula ((F *\<^sub>B G) *\<^sub>B H))"
      by (simp add: MAL_sym)
    hence "\<P>(formulaA G ,\<^sub>A formulaA H \<turnstile>\<^sub>C formulaA F \<rightarrow>\<circ> formula ((F *\<^sub>B G) *\<^sub>B H))"
      using equiv postulateCL8S by blast
    hence "\<P>(formulaA (G *\<^sub>B H) \<turnstile>\<^sub>C formulaA F \<rightarrow>\<circ> formula ((F *\<^sub>B G) *\<^sub>B H))"
      by (simp add: andMultL)
    hence "\<P>(formulaA F ,\<^sub>A formulaA (G *\<^sub>B H) \<turnstile>\<^sub>C  formula ((F *\<^sub>B G) *\<^sub>B H))"
      using equiv postulateCL8 by blast
    thus ?case
      by (simp add: andMultL)
  qed
next
  case (Assocr F G H)
  then show ?case
  proof-
    have "\<P>(formulaA F ,\<^sub>A (formulaA G ,\<^sub>A formulaA H) \<turnstile>\<^sub>C formula (F *\<^sub>B (G *\<^sub>B H)))"
      by (simp add: andMultR identity)
    hence "\<P>((formulaA F ,\<^sub>A formulaA G) ,\<^sub>A formulaA H \<turnstile>\<^sub>C formula (F *\<^sub>B (G *\<^sub>B H)))"
      by (simp add: MAL)
    hence "\<P>(formulaA F ,\<^sub>A formulaA G  \<turnstile>\<^sub>C formulaA H \<rightarrow>\<circ> formula (F *\<^sub>B (G *\<^sub>B H)))"
      using equiv postulateCL7 by blast
    hence "\<P>(formulaA (F *\<^sub>B G)  \<turnstile>\<^sub>C formulaA H \<rightarrow>\<circ> formula (F *\<^sub>B (G *\<^sub>B H)))"
      by (simp add: andMultL)
    hence "\<P>(formulaA (F *\<^sub>B G) ,\<^sub>A formulaA H \<turnstile>\<^sub>C formula (F *\<^sub>B (G *\<^sub>B H)))"
      using equiv postulateCL7S by blast
    thus ?case
      using andMultL by blast
  qed
next
  case (Comm F G)
  then show ?case
  proof-
    have "\<P>(formulaA G ,\<^sub>A formulaA F \<turnstile>\<^sub>C formula (G *\<^sub>B F))"
      using andMultR identity by simp
    hence "\<P>(formulaA F ,\<^sub>A formulaA G \<turnstile>\<^sub>C formula (G *\<^sub>B F))"
      using equiv postulateCL7 postulateCL8 by blast
    thus ?case
      by (simp add: andMultL)
  qed
next
  case (ConjIstar F1 G1 F2 G2)
  then show ?case
  proof-
    note \<open>\<P> (formulaA F1 \<turnstile>\<^sub>C formula G1)\<close> \<open>\<P> (formulaA F2 \<turnstile>\<^sub>C formula G2)\<close>
    hence  "\<P>(formulaA F1 ,\<^sub>A formulaA F2 \<turnstile>\<^sub>C formula (G1 *\<^sub>B G2))"
      by (simp add: andMultR)
    thus ?case
      by (simp add: andMultL)
  qed
qed

theorem Completeness: "Valid (X \<turnstile>\<^sub>C Y) \<Longrightarrow> \<P>(X \<turnstile>\<^sub>C Y)"
  apply simp
proof-
  assume "\<Psi> X \<turnstile>\<^sub>B \<Upsilon> Y"
  have "\<P>(X \<turnstile>\<^sub>C formula(\<Psi> X))"
    by (simp add: \<Psi>R)
  have "\<P>(formulaA(\<Psi> X) \<turnstile>\<^sub>C Y)"
  proof-
    note\<open>\<Psi> X \<turnstile>\<^sub>B \<Upsilon> Y\<close>
    then have "\<P>(formulaA (\<Psi> X) \<turnstile>\<^sub>C formula (\<Upsilon> Y))"
      by (simp add: intermediate)
    have "\<P>(formulaA (\<Upsilon> Y) \<turnstile>\<^sub>C Y)"
      by (simp add: \<Upsilon>L)
    note \<open>\<P>(formulaA (\<Psi> X) \<turnstile>\<^sub>C formula (\<Upsilon> Y))\<close>\<open>\<P>(formulaA (\<Upsilon> Y) \<turnstile>\<^sub>C Y)\<close>
    thus ?thesis
      using cut by blast
  qed
  note\<open>\<P>(X \<turnstile>\<^sub>C formula(\<Psi> X))\<close> \<open>\<P>(formulaA(\<Psi> X) \<turnstile>\<^sub>C Y)\<close>
  thus ?thesis
    using cut by blast
qed

end