theory MissingRelation
imports Main
begin

lemma range_dom[simp]:
  "f `` Domain f = Range f"
  "converse f `` Range f = Domain f" by auto

lemma Gr_Image_image[simp]:
  shows "BNF_Def.Gr A f `` B = f ` (A \<inter> B)"
  unfolding BNF_Def.Gr_def by auto

definition univalent where "univalent R = (\<forall> x y z. (x,y)\<in> R \<and> (x,z)\<in> R \<longrightarrow> z = y)"

lemma univalent_right_unique[simp]:
  shows "right_unique (\<lambda> x y. (x,y) \<in> R) = univalent R"
        "univalent {(x,y).r x y} = right_unique r"
  unfolding univalent_def right_unique_def by auto

declare univalent_right_unique(1)[pred_set_conv]

lemma univalent_inter[intro]:
  assumes "univalent f_a \<or> univalent f_b"
  shows "univalent (f_a \<inter> f_b)"
  using assms unfolding univalent_def by auto

lemma Gr_domain[simp]:
  shows "Domain (BNF_Def.Gr A f) = A"
    and "Domain (BNF_Def.Gr A id O R) = A \<inter> Domain R" unfolding BNF_Def.Gr_def by auto

lemma in_Gr[simp]:
  shows "(x,y) \<in> BNF_Def.Gr A f \<longleftrightarrow> x \<in> A \<and> f x = y"
  unfolding BNF_Def.Gr_def by auto

lemma Id_on_domain[simp]:
  "Domain (Id_on A O f) = A \<inter> Domain f" by auto

lemma Domain_id_on:
  shows "Domain (R O S) = Domain R \<inter> R\<inverse> `` Domain S"
  by auto

lemma Id_on_int:
  "Id_on A O f = (A \<times> UNIV) \<inter> f" by auto

lemma Domain_int_univ:
  "Domain (A \<times> UNIV \<inter> f) = A \<inter> Domain f" by auto

lemma Domain_O:
  assumes "a \<subseteq> Domain x" "x `` a \<subseteq> Domain y"
  shows "a \<subseteq> Domain (x O y)"
  proof fix xa assume xa:"xa \<in> a" hence "xa \<in> Domain x" using assms by auto
    then obtain w where xaw:"(xa,w) \<in> x" by auto
    with xa have "w \<in> Domain y" using assms by auto
    then obtain v where "(w,v) \<in> y" by auto
    with xaw have "(xa,v) \<in> x O y" by auto
    thus "xa \<in> Domain (x O y)" by auto qed

lemma Gr_range[simp]:
  shows "Range (BNF_Def.Gr A f) = f ` A" unfolding BNF_Def.Gr_def by auto

lemma tuple_disj[simp]:
  shows "{y. y = x \<or> y = z} = {x,z}" by auto

lemma univalent_empty [intro]: "univalent {}" unfolding univalent_def by auto

lemma univalent_char : "univalent R \<longleftrightarrow> converse R O R \<subseteq> Id"
  unfolding univalent_def by auto

lemma univalentD [dest]: "univalent R \<Longrightarrow> (x,y)\<in> R \<Longrightarrow> (x,z)\<in> R \<Longrightarrow> z = y"
  unfolding univalent_def by auto

lemma univalentI: "converse R O R \<subseteq> Id \<Longrightarrow> univalent R"
  unfolding univalent_def by auto

lemma univalent_composes[intro]:assumes "univalent R" "univalent S"
 shows "univalent (R O S)" using assms unfolding univalent_char by auto

lemma id_univalent[intro]:"univalent (Id_on x)" unfolding univalent_char by auto

lemma univalent_insert:
  assumes "\<And> c. (a,c) \<notin> R"
  shows "univalent (insert (a,b) R) \<longleftrightarrow> univalent R"
  using assms unfolding univalent_def by auto

lemma univalent_set_distinctI[intro]: (* not an iff: duplicates of A and B might align *)
  assumes "distinct A"
  shows "univalent (set (zip A B))"
  using assms proof(induct A arbitrary:B)
  case (Cons a A)
  hence univ:"univalent (set (zip A (tl B)))" by auto
  from Cons(2) have "a \<notin> set (take x A)" for x using in_set_takeD by fastforce
  hence "a \<notin> Domain (set (zip A (tl B)))"
    unfolding Domain_fst set_map[symmetric] map_fst_zip_take by auto
  hence "\<And> c. (a,c) \<notin> set (zip A (tl B))" by auto
  from univ univalent_insert[OF this] show ?case by(cases B,auto)
qed auto

lemma set_zip_conv[simp]:
"(set (zip A B))\<inverse> = set (zip B A)" unfolding set_zip by auto

lemma univalent_O_converse[simp]:
  assumes "univalent (converse R)"
  shows "R O converse R = Id_on (Domain R)"
  using assms[unfolded univalent_char] by auto

lemma Image_outside_Domain[simp]:
  assumes "Domain R \<inter> A = {}"
  shows "R `` A = {}"
  using assms by auto

lemma Image_Domain[simp]:
  assumes "Domain R = A"
  shows "R `` A = Range R"
  using assms by auto

lemma Domain_set_zip[simp]:
  assumes "length A = length B"
  shows "Domain (set (zip A B)) = set A"
  unfolding Domain_fst set_map[symmetric] map_fst_zip[OF assms]..

lemma Range_set_zip[simp]:
  assumes "length A = length B"
  shows "Range (set (zip A B)) = set B"
  unfolding Range_snd set_map[symmetric] map_snd_zip[OF assms]..

lemma Gr_univalent[intro]:
  shows "univalent (BNF_Def.Gr A f)"
  unfolding BNF_Def.Gr_def univalent_def by auto

lemma univalent_fn[simp]:
  assumes "univalent R"
  shows "BNF_Def.Gr (Domain R) (\<lambda> x. SOME y. (x,y) \<in> R) = R" (is "?lhs = _")
  unfolding set_eq_iff
proof(clarify,standard)
  fix a b assume a:"(a, b) \<in> R"
  hence "(a,SOME y. (a, y) \<in> R) \<in> R" using someI by metis
  with assms a have [simp]:"(SOME y. (a, y) \<in> R) = b" by auto
  show "(a, b) \<in> ?lhs" using a by auto
next
  fix a b assume a:"(a,b) \<in> ?lhs"
  hence "a \<in> Domain R" "(SOME y. (a, y) \<in> R) = b" by auto
  thus "(a,b) \<in> R" using someI by auto
qed

lemma Gr_not_in[intro]:
  shows "x \<notin> F \<or> f x \<noteq> y \<Longrightarrow> (x,y) \<notin> BNF_Def.Gr F f" by auto

lemma Gr_insert[simp]:
  shows "BNF_Def.Gr (insert x F) f = insert (x,f x) (BNF_Def.Gr F f)"
  unfolding BNF_Def.Gr_def by auto

lemma Gr_empty[simp]:
  shows "BNF_Def.Gr {} f = {}" by auto

lemma Gr_card[simp]:
  shows "card (BNF_Def.Gr A f) = card A"
proof(cases "finite A")
  case True
  hence "finite (BNF_Def.Gr A f)" by (induct A,auto)
  with True show ?thesis by (induct A,auto)
next
  have [simp]: "infinite (Domain (A - {x})) = infinite (Domain (A::('a \<times> 'b) set))"
    for A x
    using Diff_infinite_finite Domain_Diff_subset finite.emptyI
              finite.insertI finite_Domain finite_subset Diff_subset Domain_mono
    by metis
  have "infinite (Domain A) \<Longrightarrow> \<exists> a. a \<in> fst ` A" for A::"('a \<times> 'b) set"
    using finite.simps unfolding Domain_fst by fastforce
  hence [intro]:"infinite (Domain A) \<Longrightarrow> \<exists> a b. (a,b) \<in> A" for A::"('a \<times> 'b) set"
    by fast
  let ?Gr = "BNF_Def.Gr A f"
  case False
  hence "infinite ?Gr"
    by(intro infinite_coinduct[of "infinite o Domain"],auto)
  with False show ?thesis by (auto simp:BNF_Def.Gr_def)
qed

lemma univalent_finite[simp]:
  assumes "univalent R"
  shows "card (Domain R) = card R"
        "finite (Domain R) \<longleftrightarrow> finite R"
proof -
  let ?R = "BNF_Def.Gr (Domain R) (\<lambda> x. SOME y. (x,y) \<in> R)"
  have "card (Domain ?R) = card ?R" by auto
  thus "card (Domain  R) = card  R"
    unfolding univalent_fn[OF assms].
  thus "finite (Domain R) \<longleftrightarrow> finite R"
    by (metis Domain_empty_iff card_0_eq card_infinite finite.emptyI)
qed

lemma trancl_power_least:
  "p \<in> R\<^sup>+ \<longleftrightarrow> (\<exists>n. p \<in> R ^^ Suc n \<and> (p \<in> R ^^ n \<longrightarrow> n = 0))"
proof
  assume "p \<in> R\<^sup>+"
  from this[unfolded trancl_power] obtain n where p:"n>0" "p \<in> R ^^ n" by auto
  define n' where "n' = n - 1"
  with p have "Suc n' = n" by auto
  with p have "p \<in> R ^^ Suc n'" by auto
  thus "\<exists>n. p \<in> R ^^ Suc n \<and> (p \<in> R ^^ n \<longrightarrow> n = 0)" proof (induct n')
    case 0 hence "p \<in> R ^^ 0 O R \<and> (p \<in> R ^^ 0 \<longrightarrow> 0 = 0)" by auto
    then show ?case by force
  next
    case (Suc n)
    show ?case proof(cases "p \<in> R ^^ Suc n")
      case False with Suc show ?thesis by blast
    qed (rule Suc)
  qed next
  assume "\<exists>n. p \<in> R ^^ Suc n \<and> (p \<in> R ^^ n \<longrightarrow> n = 0)"
  with zero_less_Suc have "\<exists>n>0. p \<in> R ^^ n" by blast
  thus "p \<in> R\<^sup>+" unfolding trancl_power.
qed

lemma refl_on_tranclI :
  assumes "refl_on A r"
  shows "refl_on A (trancl r)"
  proof
    show "r\<^sup>+ \<subseteq> A \<times> A"
      by( rule trancl_subset_Sigma
        , auto simp: assms[THEN refl_onD1] assms[THEN refl_onD2])
    show "x \<in> A \<Longrightarrow> (x, x) \<in> r\<^sup>+" for x
      using assms[THEN refl_onD] by auto
  qed

definition idempotent where
  "idempotent r \<equiv> r O r = r"

lemma trans_def: "trans r = ((Id \<union> r) O r = r)" "trans r = (r O (Id \<union> r) = r)"
  by(auto simp:trans_def)

lemma idempotent_impl_trans: "idempotent r \<Longrightarrow> trans r"
  by(auto simp:trans_def idempotent_def)

lemma refl_trans_impl_idempotent[intro]: "refl_on A r \<Longrightarrow> trans r \<Longrightarrow> idempotent r"
  by(auto simp:refl_on_def trans_def idempotent_def)

lemma idempotent_subset:
  assumes "idempotent R" "S \<subseteq> R"
  shows "S O R \<subseteq> R" "R O S \<subseteq> R" "S O R O S \<subseteq> R"
  using assms by (auto simp:idempotent_def)

(* not really about relations, but I need it in GraphRewriting.thy.
   Renaming the entire file to 'preliminaries' just because this is here would be too much. *)
lemma list_sorted_max[simp]:
  shows "sorted list \<Longrightarrow> list = (x#xs) \<Longrightarrow> fold max xs x = (last list)"
proof (induct list arbitrary:x xs)
  case (Cons a list)
  hence "xs = y # ys \<Longrightarrow> fold max ys y = last xs" "sorted (x # xs)" "sorted xs" for y ys
    using Cons.prems(1,2) by auto
  hence "xs \<noteq> [] \<Longrightarrow> fold max xs x = last xs"
    by (metis (full_types) fold_simps(2) max.orderE sorted.elims(2) sorted2)
  thus ?case unfolding Cons by auto
qed auto

end


section \<open>\isaheader{Set Interface}\<close>
theory Intf_Set
imports Refine_Monadic.Refine_Monadic
begin
consts i_set :: "interface \<Rightarrow> interface"
lemmas [autoref_rel_intf] = REL_INTFI[of set_rel i_set]

definition [simp]: "op_set_delete x s \<equiv> s - {x}"
definition [simp]: "op_set_isEmpty s \<equiv> s = {}"
definition [simp]: "op_set_isSng s \<equiv> card s = 1"
definition [simp]: "op_set_size_abort m s \<equiv> min m (card s)"
definition [simp]: "op_set_disjoint a b \<equiv> a\<inter>b={}"
definition [simp]: "op_set_filter P s \<equiv> {x\<in>s. P x}"
definition [simp]: "op_set_sel P s \<equiv> SPEC (\<lambda>x. x\<in>s \<and> P x)"
definition [simp]: "op_set_pick s \<equiv> SPEC (\<lambda>x. x\<in>s)"
definition [simp]: "op_set_to_sorted_list ordR s
  \<equiv> SPEC (\<lambda>l. set l = s \<and> distinct l \<and> sorted_wrt ordR l)"
definition [simp]: "op_set_to_list s \<equiv> SPEC (\<lambda>l. set l = s \<and> distinct l)"
definition [simp]: "op_set_cart x y \<equiv> x \<times> y"

(* TODO: Do op_set_pick_remove (like op_map_pick_remove) *)

context begin interpretation autoref_syn .

  "s = {} \<equiv> op_set_isEmpty$s"
  "{}=s \<equiv> op_set_isEmpty$s"

  "card s = 1 \<equiv> op_set_isSng$s"
  "\<exists>x. s={x} \<equiv> op_set_isSng$s"
  "\<exists>x. {x}=s \<equiv> op_set_isSng$s"

  "min m (card s) \<equiv> op_set_size_abort$m$s"
  "min (card s) m \<equiv> op_set_size_abort$m$s"

  "a\<inter>b={} \<equiv> op_set_disjoint$a$b"

  "{x\<in>s. P x} \<equiv> op_set_filter$P$s"

  "SPEC (\<lambda>x. x\<in>s \<and> P x) \<equiv> op_set_sel$P$s"
  "SPEC (\<lambda>x. P x \<and> x\<in>s) \<equiv> op_set_sel$P$s"

  "SPEC (\<lambda>x. x\<in>s) \<equiv> op_set_pick$s"
  by (auto intro!: eq_reflection simp: card_Suc_eq)

lemma [autoref_op_pat]:
  "a \<times> b \<equiv> op_set_cart a b"
  by (auto intro!: eq_reflection simp: card_Suc_eq)

lemma [autoref_op_pat]:
  "SPEC (\<lambda>(u,v). (u,v)\<in>s) \<equiv> op_set_pick$s"
  "SPEC (\<lambda>(u,v). P u v \<and> (u,v)\<in>s) \<equiv> op_set_sel$(case_prod P)$s"
  "SPEC (\<lambda>(u,v). (u,v)\<in>s \<and> P u v) \<equiv> op_set_sel$(case_prod P)$s"
  by (auto intro!: eq_reflection)

  lemma [autoref_op_pat]:
    "SPEC (\<lambda>l. set l = s \<and> distinct l \<and> sorted_wrt ordR l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. set l = s \<and> sorted_wrt ordR l \<and> distinct l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. distinct l \<and> set l = s \<and> sorted_wrt ordR l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. distinct l \<and> sorted_wrt ordR l \<and> set l = s)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. sorted_wrt ordR l \<and> distinct l \<and> set l = s)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. sorted_wrt ordR l \<and> set l = s \<and> distinct l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"

    "SPEC (\<lambda>l. s = set l \<and> distinct l \<and> sorted_wrt ordR l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. s = set l \<and> sorted_wrt ordR l \<and> distinct l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. distinct l \<and> s = set l \<and> sorted_wrt ordR l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. distinct l \<and> sorted_wrt ordR l \<and> s = set l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. sorted_wrt ordR l \<and> distinct l \<and> s = set l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"
    "SPEC (\<lambda>l. sorted_wrt ordR l \<and> s = set l \<and> distinct l)
    \<equiv> OP (op_set_to_sorted_list ordR)$s"

    "SPEC (\<lambda>l. set l = s \<and> distinct l) \<equiv> op_set_to_list$s"
    "SPEC (\<lambda>l. distinct l \<and> set l = s) \<equiv> op_set_to_list$s"

    "SPEC (\<lambda>l. s = set l \<and> distinct l) \<equiv> op_set_to_list$s"
    "SPEC (\<lambda>l. distinct l \<and> s = set l) \<equiv> op_set_to_list$s"
    by (auto intro!: eq_reflection)

end

lemma [autoref_itype]:
  "{} ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "insert ::\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "op_set_delete ::\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "(\<in>) ::\<^sub>i I \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "op_set_isEmpty ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "op_set_isSng ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "(\<union>) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "(\<inter>) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "((-) :: 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "((=) :: 'a set \<Rightarrow> 'a set \<Rightarrow> bool) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "(\<subseteq>) ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "op_set_disjoint ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_bool"
  "Ball ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i (I \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i i_bool"
  "Bex ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i (I \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i i_bool"
  "op_set_filter ::\<^sub>i (I \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "card ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_nat"
  "op_set_size_abort ::\<^sub>i i_nat \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i i_nat"
  "set ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_list \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "op_set_sel ::\<^sub>i (I \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_nres"
  "op_set_pick ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_nres"
  "Sigma ::\<^sub>i \<langle>Ia\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i (Ia \<rightarrow>\<^sub>i \<langle>Ib\<rangle>\<^sub>ii_set) \<rightarrow>\<^sub>i \<langle>\<langle>Ia,Ib\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_set"
  "(`) ::\<^sub>i (Ia\<rightarrow>\<^sub>iIb) \<rightarrow>\<^sub>i \<langle>Ia\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>Ib\<rangle>\<^sub>ii_set"
  "op_set_cart ::\<^sub>i \<langle>Ix\<rangle>\<^sub>iIsx \<rightarrow>\<^sub>i \<langle>Iy\<rangle>\<^sub>iIsy \<rightarrow>\<^sub>i \<langle>\<langle>Ix, Iy\<rangle>\<^sub>ii_prod\<rangle>\<^sub>iIsp"
  "Union ::\<^sub>i \<langle>\<langle>I\<rangle>\<^sub>ii_set\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_set"
  "atLeastLessThan ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_nat \<rightarrow>\<^sub>i \<langle>i_nat\<rangle>\<^sub>ii_set"
  by simp_all

lemma hom_set1[autoref_hom]:
  "CONSTRAINT {} (\<langle>R\<rangle>Rs)"
  "CONSTRAINT insert (R\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT (\<in>) (R\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT (\<union>) (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT (\<inter>) (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT (-) (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT (=) (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT (\<subseteq>) (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT Ball (\<langle>R\<rangle>Rs\<rightarrow>(R\<rightarrow>Id)\<rightarrow>Id)"
  "CONSTRAINT Bex (\<langle>R\<rangle>Rs\<rightarrow>(R\<rightarrow>Id)\<rightarrow>Id)"
  "CONSTRAINT card (\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT set (\<langle>R\<rangle>Rl\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT (`) ((Ra\<rightarrow>Rb) \<rightarrow> \<langle>Ra\<rangle>Rs\<rightarrow>\<langle>Rb\<rangle>Rs)"
  "CONSTRAINT Union (\<langle>\<langle>R\<rangle>Ri\<rangle>Ro \<rightarrow> \<langle>R\<rangle>Ri)"
  by simp_all

lemma hom_set2[autoref_hom]:
  "CONSTRAINT op_set_delete (R\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT op_set_isEmpty (\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op_set_isSng (\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op_set_size_abort (Id\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op_set_disjoint (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>Id)"
  "CONSTRAINT op_set_filter ((R\<rightarrow>Id)\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rs)"
  "CONSTRAINT op_set_sel ((R \<rightarrow> Id)\<rightarrow>\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rn)"
  "CONSTRAINT op_set_pick (\<langle>R\<rangle>Rs\<rightarrow>\<langle>R\<rangle>Rn)"
  by simp_all

lemma hom_set_Sigma[autoref_hom]:
  "CONSTRAINT Sigma (\<langle>Ra\<rangle>Rs \<rightarrow> (Ra \<rightarrow> \<langle>Rb\<rangle>Rs) \<rightarrow> \<langle>\<langle>Ra,Rb\<rangle>prod_rel\<rangle>Rs2)"
  by simp_all

definition "finite_set_rel R \<equiv> Range R \<subseteq> Collect (finite)"

lemma finite_set_rel_trigger: "finite_set_rel R \<Longrightarrow> finite_set_rel R" .

declaration \<open>Tagged_Solver.add_triggers
  "Relators.relator_props_solver" @{thms finite_set_rel_trigger}\<close>

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Accumulator
imports
  HOLCF
  LList
  WorkerWrapperNew
begin
(*>*)

section\<open>Naive reverse becomes accumulator-reverse.\<close>

text\<open>\label{sec:accum}\<close>

subsection\<open>Hughes lists, naive reverse, worker-wrapper optimisation.\<close>

text\<open>The ``Hughes'' list type.\<close>

type_synonym 'a H = "'a llist \<rightarrow> 'a llist"

definition
  list2H :: "'a llist \<rightarrow> 'a H" where
  "list2H \<equiv> lappend"

lemma acc_c2a_strict[simp]: "list2H\<cdot>\<bottom> = \<bottom>"
  by (rule cfun_eqI, simp add: list2H_def)

definition
  H2list :: "'a H \<rightarrow> 'a llist" where
  "H2list \<equiv> \<Lambda> f . f\<cdot>lnil"

text\<open>The paper only claims the homomorphism holds for finite lists,
but in fact it holds for all lazy lists in HOLCF. They are trying to
dodge an explicit appeal to the equation @{thm "inst_cfun_pcpo"},
which does not hold in Haskell.\<close>

lemma H_llist_hom_append: "list2H\<cdot>(xs :++ ys) = list2H\<cdot>xs oo list2H\<cdot>ys" (is "?lhs = ?rhs")
proof(rule cfun_eqI)
  fix zs
  have "?lhs\<cdot>zs = (xs :++ ys) :++ zs" by (simp add: list2H_def)
  also have "\<dots> = xs :++ (ys :++ zs)" by (rule lappend_assoc)
  also have "\<dots> = list2H\<cdot>xs\<cdot>(ys :++ zs)" by (simp add: list2H_def)
  also have "\<dots> = list2H\<cdot>xs\<cdot>(list2H\<cdot>ys\<cdot>zs)" by (simp add: list2H_def)
  also have "\<dots> = (list2H\<cdot>xs oo list2H\<cdot>ys)\<cdot>zs" by simp
  finally show "?lhs\<cdot>zs = (list2H\<cdot>xs oo list2H\<cdot>ys)\<cdot>zs" .
qed

lemma H_llist_hom_id: "list2H\<cdot>lnil = ID" by (simp add: list2H_def)

lemma H2list_list2H_inv: "H2list oo list2H = ID"
  by (rule cfun_eqI, simp add: H2list_def list2H_def)

text\<open>\citet[\S4.2]{GillHutton:2009} define the naive reverse
function as follows.\<close>

fixrec lrev :: "'a llist \<rightarrow> 'a llist"
where
  "lrev\<cdot>lnil = lnil"
| "lrev\<cdot>(x :@ xs) = lrev\<cdot>xs :++ (x :@ lnil)"

text\<open>Note ``body'' is the generator of @{term "lrev_def"}.\<close>

lemma lrev_strict[simp]: "lrev\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

fixrec lrev_body :: "('a llist \<rightarrow> 'a llist) \<rightarrow> 'a llist \<rightarrow> 'a llist"
where
  "lrev_body\<cdot>r\<cdot>lnil = lnil"
| "lrev_body\<cdot>r\<cdot>(x :@ xs) = r\<cdot>xs :++ (x :@ lnil)"

lemma lrev_body_strict[simp]: "lrev_body\<cdot>r\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

text\<open>This is trivial but syntactically a bit touchy. Would be nicer
to define @{term "lrev_body"} as the generator of the fixpoint
definition of @{term "lrev"} directly.\<close>

lemma lrev_lrev_body_eq: "lrev = fix\<cdot>lrev_body"
  by (rule cfun_eqI, subst lrev_def, subst lrev_body.unfold, simp)

text\<open>Wrap / unwrap functions.\<close>

definition
  unwrapH :: "('a llist \<rightarrow> 'a llist) \<rightarrow> 'a llist \<rightarrow> 'a H" where
  "unwrapH \<equiv> \<Lambda> f xs . list2H\<cdot>(f\<cdot>xs)"

lemma unwrapH_strict[simp]: "unwrapH\<cdot>\<bottom> = \<bottom>"
  unfolding unwrapH_def by (rule cfun_eqI, simp)

definition
  wrapH :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a llist" where
  "wrapH \<equiv> \<Lambda> f xs . H2list\<cdot>(f\<cdot>xs)"

lemma wrapH_unwrapH_id: "wrapH oo unwrapH = ID" (is "?lhs = ?rhs")
proof(rule cfun_eqI)+
  fix f xs
  have "?lhs\<cdot>f\<cdot>xs = H2list\<cdot>(list2H\<cdot>(f\<cdot>xs))" by (simp add: wrapH_def unwrapH_def)
  also have "\<dots> = (H2list oo list2H)\<cdot>(f\<cdot>xs)" by simp
  also have "\<dots> = ID\<cdot>(f\<cdot>xs)" by (simp only: H2list_list2H_inv)
  also have "\<dots> = ?rhs\<cdot>f\<cdot>xs" by simp
  finally show "?lhs\<cdot>f\<cdot>xs = ?rhs\<cdot>f\<cdot>xs" .
qed

subsection\<open>Gill/Hutton-style worker/wrapper.\<close>

definition
  lrev_work :: "'a llist \<rightarrow> 'a H" where
  "lrev_work \<equiv> fix\<cdot>(unwrapH oo lrev_body oo wrapH)"

definition
  lrev_wrap :: "'a llist \<rightarrow> 'a llist" where
  "lrev_wrap \<equiv> wrapH\<cdot>lrev_work"

lemma lrev_lrev_ww_eq: "lrev = lrev_wrap"
  using worker_wrapper_id[OF wrapH_unwrapH_id lrev_lrev_body_eq]
  by (simp add: lrev_wrap_def lrev_work_def)

subsection\<open>Optimise worker/wrapper.\<close>

text\<open>Intermediate worker.\<close>

fixrec lrev_body1 :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a H"
where
  "lrev_body1\<cdot>r\<cdot>lnil = list2H\<cdot>lnil"
| "lrev_body1\<cdot>r\<cdot>(x :@ xs) = list2H\<cdot>(wrapH\<cdot>r\<cdot>xs :++ (x :@ lnil))"

definition
  lrev_work1 :: "'a llist \<rightarrow> 'a H" where
  "lrev_work1 \<equiv> fix\<cdot>lrev_body1"

lemma lrev_body_lrev_body1_eq: "lrev_body1 = unwrapH oo lrev_body oo wrapH"
  apply (rule cfun_eqI)+
  apply (subst lrev_body.unfold)
  apply (subst lrev_body1.unfold)
  apply (case_tac xa)
  apply (simp_all add: list2H_def wrapH_def unwrapH_def)
  done

lemma lrev_work1_lrev_work_eq: "lrev_work1 = lrev_work"
  by (unfold lrev_work_def lrev_work1_def,
      rule cfun_arg_cong[OF lrev_body_lrev_body1_eq])

text\<open>Now use the homomorphism.\<close>

fixrec lrev_body2 :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a H"
where
  "lrev_body2\<cdot>r\<cdot>lnil = ID"
| "lrev_body2\<cdot>r\<cdot>(x :@ xs) = list2H\<cdot>(wrapH\<cdot>r\<cdot>xs) oo list2H\<cdot>(x :@ lnil)"

lemma lrev_body2_strict[simp]: "lrev_body2\<cdot>r\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

definition
  lrev_work2 :: "'a llist \<rightarrow> 'a H" where
  "lrev_work2 \<equiv> fix\<cdot>lrev_body2"

lemma lrev_work2_strict[simp]: "lrev_work2\<cdot>\<bottom> = \<bottom>"
  unfolding lrev_work2_def
  by (subst fix_eq) simp

lemma lrev_body2_lrev_body1_eq: "lrev_body2 = lrev_body1"
  by ((rule cfun_eqI)+
     , (subst lrev_body1.unfold, subst lrev_body2.unfold)
     , (simp add: H_llist_hom_append[symmetric] H_llist_hom_id))

lemma lrev_work2_lrev_work1_eq: "lrev_work2 = lrev_work1"
  by (unfold lrev_work2_def lrev_work1_def
     , rule cfun_arg_cong[OF lrev_body2_lrev_body1_eq])

text \<open>Simplify.\<close>

fixrec lrev_body3 :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a H"
where
  "lrev_body3\<cdot>r\<cdot>lnil = ID"
| "lrev_body3\<cdot>r\<cdot>(x :@ xs) = r\<cdot>xs oo list2H\<cdot>(x :@ lnil)"

lemma lrev_body3_strict[simp]: "lrev_body3\<cdot>r\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

definition
  lrev_work3 :: "'a llist \<rightarrow> 'a H" where
  "lrev_work3 \<equiv> fix\<cdot>lrev_body3"

lemma lrev_wwfusion: "list2H\<cdot>((wrapH\<cdot>lrev_work2)\<cdot>xs) = lrev_work2\<cdot>xs"
proof -
  {
    have "list2H oo wrapH\<cdot>lrev_work2 = unwrapH\<cdot>(wrapH\<cdot>lrev_work2)"
      by (rule cfun_eqI, simp add: unwrapH_def)
    also have "\<dots> = (unwrapH oo wrapH)\<cdot>lrev_work2" by simp
    also have "\<dots> = lrev_work2"
      apply -
      apply (rule worker_wrapper_fusion[OF wrapH_unwrapH_id, where body="lrev_body"])
      apply (auto iff: lrev_body2_lrev_body1_eq lrev_body_lrev_body1_eq lrev_work2_def lrev_work1_def)
      done
    finally have "list2H oo wrapH\<cdot>lrev_work2 = lrev_work2" .
  }
  thus ?thesis using cfun_eq_iff[where f="list2H oo wrapH\<cdot>lrev_work2" and g="lrev_work2"] by auto
qed

text\<open>If we use this result directly, we only get a partially-correct
program transformation, see \citet{Tullsen:PhDThesis} for details.\<close>

lemma "lrev_work3 \<sqsubseteq> lrev_work2"
  unfolding lrev_work3_def
proof(rule fix_least)
  {
    fix xs have "lrev_body3\<cdot>lrev_work2\<cdot>xs = lrev_work2\<cdot>xs"
    proof(cases xs)
      case bottom thus ?thesis by simp
    next
      case lnil thus ?thesis
        unfolding lrev_work2_def
        by (subst fix_eq[where F="lrev_body2"], simp)
    next
      case (lcons y ys)
      hence "lrev_body3\<cdot>lrev_work2\<cdot>xs = lrev_work2\<cdot>ys oo list2H\<cdot>(y :@ lnil)" by simp
      also have "\<dots> = list2H\<cdot>((wrapH\<cdot>lrev_work2)\<cdot>ys) oo list2H\<cdot>(y :@ lnil)"
        using lrev_wwfusion[where xs=ys] by simp
      also from lcons have "\<dots> = lrev_body2\<cdot>lrev_work2\<cdot>xs" by simp
      also have "\<dots> = lrev_work2\<cdot>xs"
        unfolding lrev_work2_def by (simp only: fix_eq[symmetric])
      finally show ?thesis by simp
    qed
  }
  thus "lrev_body3\<cdot>lrev_work2 = lrev_work2" by (rule cfun_eqI)
qed

text\<open>We can't show the reverse inclusion in the same way as the
fusion law doesn't hold for the optimised definition. (Intuitively we
haven't established that it is equal to the original @{term "lrev"}
definition.) We could show termination of the optimised definition
though, as it operates on finite lists. Alternatively we can use
induction (over the list argument) to show total equivalence.

The following lemma shows that the fusion Gill/Hutton want to do is
completely sound in this context, by appealing to the lazy list
induction principle.\<close>

lemma lrev_work3_lrev_work2_eq: "lrev_work3 = lrev_work2" (is "?lhs = ?rhs")
proof(rule cfun_eqI)
  fix x
  show "?lhs\<cdot>x = ?rhs\<cdot>x"
  proof(induct x)
    show "lrev_work3\<cdot>\<bottom> = lrev_work2\<cdot>\<bottom>"
      apply (unfold lrev_work3_def lrev_work2_def)
      apply (subst fix_eq[where F="lrev_body2"])
      apply (subst fix_eq[where F="lrev_body3"])
      by (simp add: lrev_body3.unfold lrev_body2.unfold)
  next
    show "lrev_work3\<cdot>lnil = lrev_work2\<cdot>lnil"
      apply (unfold lrev_work3_def lrev_work2_def)
      apply (subst fix_eq[where F="lrev_body2"])
      apply (subst fix_eq[where F="lrev_body3"])
      by (simp add: lrev_body3.unfold lrev_body2.unfold)
  next
    fix a l assume "lrev_work3\<cdot>l = lrev_work2\<cdot>l"
    thus "lrev_work3\<cdot>(a :@ l) = lrev_work2\<cdot>(a :@ l)"
      apply (unfold lrev_work3_def lrev_work2_def)
      apply (subst fix_eq[where F="lrev_body2"])
      apply (subst fix_eq[where F="lrev_body3"])
      apply (fold lrev_work3_def lrev_work2_def)
      apply (simp add: lrev_body3.unfold lrev_body2.unfold lrev_wwfusion)
      done
  qed simp_all
qed

text\<open>Use the combined worker/wrapper-fusion rule. Note we get a weaker lemma.\<close>

lemma lrev3_2_syntactic: "lrev_body3 oo (unwrapH oo wrapH) = lrev_body2"
  apply (subst lrev_body2.unfold, subst lrev_body3.unfold)
  apply (rule cfun_eqI)+
  apply (case_tac xa)
    apply (simp_all add: unwrapH_def)
  done

lemma lrev_work3_lrev_work2_eq': "lrev = wrapH\<cdot>lrev_work3"
proof -
  from lrev_lrev_body_eq
  have "lrev = fix\<cdot>lrev_body" .
  also from wrapH_unwrapH_id unwrapH_strict
  have "\<dots> = wrapH\<cdot>(fix\<cdot>lrev_body3)"
    by (rule worker_wrapper_fusion_new
       , simp add: lrev3_2_syntactic lrev_body2_lrev_body1_eq lrev_body_lrev_body1_eq)
  finally show ?thesis unfolding lrev_work3_def by simp
qed

text\<open>Final syntactic tidy-up.\<close>

fixrec lrev_body_final :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a H"
where
  "lrev_body_final\<cdot>r\<cdot>lnil\<cdot>ys = ys"
| "lrev_body_final\<cdot>r\<cdot>(x :@ xs)\<cdot>ys = r\<cdot>xs\<cdot>(x :@ ys)"

definition
  lrev_work_final :: "'a llist \<rightarrow> 'a H" where
  "lrev_work_final \<equiv> fix\<cdot>lrev_body_final"

definition
  lrev_final :: "'a llist \<rightarrow> 'a llist" where
  "lrev_final \<equiv> \<Lambda> xs. lrev_work_final\<cdot>xs\<cdot>lnil"

lemma lrev_body_final_lrev_body3_eq': "lrev_body_final\<cdot>r\<cdot>xs = lrev_body3\<cdot>r\<cdot>xs"
  apply (subst lrev_body_final.unfold)
  apply (subst lrev_body3.unfold)
  apply (cases xs)
  apply (simp_all add: list2H_def ID_def cfun_eqI)
  done

lemma lrev_body_final_lrev_body3_eq: "lrev_body_final = lrev_body3"
  by (simp only: lrev_body_final_lrev_body3_eq' cfun_eqI)

lemma lrev_final_lrev_eq: "lrev = lrev_final" (is "?lhs = ?rhs")
proof -
  have "?lhs = lrev_wrap" by (rule lrev_lrev_ww_eq)
  also have "\<dots> = wrapH\<cdot>lrev_work" by (simp only: lrev_wrap_def)
  also have "\<dots> = wrapH\<cdot>lrev_work1" by (simp only: lrev_work1_lrev_work_eq)
  also have "\<dots> = wrapH\<cdot>lrev_work2" by (simp only: lrev_work2_lrev_work1_eq)
  also have "\<dots> = wrapH\<cdot>lrev_work3" by (simp only: lrev_work3_lrev_work2_eq)
  also have "\<dots> = wrapH\<cdot>lrev_work_final" by (simp only: lrev_work3_def lrev_work_final_def lrev_body_final_lrev_body3_eq)
  also have "\<dots> = lrev_final" by (simp add: lrev_final_def cfun_eqI H2list_def wrapH_def)
  finally show ?thesis .
qed

(*<*)
end
(*>*)


(*  File:       Electoral_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>

chapter \<open>Component Types\<close>

section \<open>Electoral Module\<close>

theory Electoral_Module
  imports "Social_Choice_Types/Profile"
          "Social_Choice_Types/Result"
begin

text \<open>
  Electoral modules are the principal component type of the composable modules
  voting framework, as they are a generalization of voting rules in the sense
  of social choice functions.
  These are only the types used for electoral modules. Further restrictions are
  encompassed by the electoral-module predicate.

  An electoral module does not need to make final decisions for all
  alternatives, but can instead defer the decision for some or all of them to
  other modules. Hence, electoral modules partition the received (possibly
  empty) set of alternatives into elected, rejected and deferred alternatives.
  In particular, any of those sets, e.g., the set of winning (elected)
  alternatives, may also be left empty, as long as they collectively still hold
  all the received alternatives. Just like a voting rule, an electoral module
  also receives a profile which holds the voters’ preferences, which, unlike a
  voting rule, consider only the (sub-)set of alternatives that the module
  receives.
\<close>

subsection \<open>Definition\<close>

text \<open>
  An electoral module maps a set of alternatives and a profile to a result.
\<close>

type_synonym 'a Electoral_Module = "'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Result"

subsection \<open>Auxiliary Definitions\<close>

text \<open>
  Electoral modules partition a given set of alternatives A into a set of
  elected alternatives e, a set of rejected alternatives r, and a set of
  deferred alternatives d, using a profile.
  e, r, and d partition A.
  Electoral modules can be used as voting rules. They can also be composed
  in multiple structures to create more complex electoral modules.
\<close>

definition electoral_module :: " 'a Electoral_Module \<Rightarrow> bool" where
  "electoral_module m \<equiv> \<forall> A p. finite_profile A p \<longrightarrow> well_formed A (m A p)"

lemma electoral_modI:
  "((\<And> A p. \<lbrakk> finite_profile A p \<rbrakk> \<Longrightarrow> well_formed A (m A p)) \<Longrightarrow>
       electoral_module m)"
  unfolding electoral_module_def
  by auto

text \<open>
  The next three functions take an electoral module and turn it into a
  function only outputting the elect, reject, or defer set respectively.
\<close>

abbreviation elect ::
  "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a set" where
  "elect m A p \<equiv> elect_r (m A p)"

abbreviation reject ::
  "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a set" where
  "reject m A p \<equiv> reject_r (m A p)"

abbreviation "defer" ::
  "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a set" where
  "defer m A p \<equiv> defer_r (m A p)"

text \<open>
  "defers n" is true for all electoral modules that defer exactly
  n alternatives, whenever there are n or more alternatives.
\<close>

definition defers :: "nat \<Rightarrow> 'a Electoral_Module \<Rightarrow> bool" where
  "defers n m \<equiv>
    electoral_module m \<and>
      (\<forall> A p. (card A \<ge> n \<and> finite_profile A p) \<longrightarrow>
          card (defer m A p) = n)"

text \<open>
  "rejects n" is true for all electoral modules that reject exactly
  n alternatives, whenever there are n or more alternatives.
\<close>

definition rejects :: "nat \<Rightarrow> 'a Electoral_Module \<Rightarrow> bool" where
  "rejects n m \<equiv>
    electoral_module m \<and>
      (\<forall> A p. (card A \<ge> n \<and> finite_profile A p) \<longrightarrow> card (reject m A p) = n)"

text \<open>
  As opposed to "rejects", "eliminates" allows to stop rejecting if no
  alternatives were to remain.
\<close>

definition eliminates :: "nat \<Rightarrow> 'a Electoral_Module \<Rightarrow> bool" where
  "eliminates n m \<equiv>
    electoral_module m \<and>
      (\<forall> A p. (card A > n \<and> finite_profile A p) \<longrightarrow> card (reject m A p) = n)"

text \<open>
  "elects n" is true for all electoral modules that
  elect exactly n alternatives, whenever there are n or more alternatives.
\<close>

definition elects :: "nat \<Rightarrow> 'a Electoral_Module \<Rightarrow> bool" where
  "elects n m \<equiv>
    electoral_module m \<and>
      (\<forall> A p. (card A \<ge> n \<and> finite_profile A p) \<longrightarrow> card (elect m A p) = n)"

text \<open>
  An electoral module is independent of an alternative a iff
  a's ranking does not influence the outcome.
\<close>

definition indep_of_alt :: "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> bool" where
  "indep_of_alt m A a \<equiv>
    electoral_module m \<and> (\<forall> p q. equiv_prof_except_a A p q a \<longrightarrow> m A p = m A q)"

definition unique_winner_if_profile_non_empty :: "'a Electoral_Module \<Rightarrow> bool" where
  "unique_winner_if_profile_non_empty m \<equiv>
    electoral_module m \<and>
    (\<forall> A p. (A \<noteq> {} \<and> p \<noteq> [] \<and> finite_profile A p) \<longrightarrow>
              (\<exists> a \<in> A. m A p = ({a}, A - {a}, {})))"

subsection \<open>Equivalence Definitions\<close>

definition prof_contains_result :: "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow>
                                       'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "prof_contains_result m A p q a \<equiv>
    electoral_module m \<and> finite_profile A p \<and> finite_profile A q \<and> a \<in> A \<and>
    (a \<in> elect m A p \<longrightarrow> a \<in> elect m A q) \<and>
    (a \<in> reject m A p \<longrightarrow> a \<in> reject m A q) \<and>
    (a \<in> defer m A p \<longrightarrow> a \<in> defer m A q)"

definition prof_leq_result :: "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow>
                                  'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "prof_leq_result m A p q a \<equiv>
    electoral_module m \<and> finite_profile A p \<and> finite_profile A q \<and> a \<in> A \<and>
    (a \<in> reject m A p \<longrightarrow> a \<in> reject m A q) \<and>
    (a \<in> defer m A p \<longrightarrow> a \<notin> elect m A q)"

definition prof_geq_result :: "'a Electoral_Module \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow>
                                  'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "prof_geq_result m A p q a \<equiv>
    electoral_module m \<and> finite_profile A p \<and> finite_profile A q \<and> a \<in> A \<and>
    (a \<in> elect m A p \<longrightarrow> a \<in> elect m A q) \<and>
    (a \<in> defer m A p \<longrightarrow> a \<notin> reject m A q)"

definition mod_contains_result :: "'a Electoral_Module \<Rightarrow> 'a Electoral_Module \<Rightarrow>
                                      'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a \<Rightarrow> bool" where
  "mod_contains_result m n A p a \<equiv>
    electoral_module m \<and> electoral_module n \<and> finite_profile A p \<and> a \<in> A \<and>
    (a \<in> elect m A p \<longrightarrow> a \<in> elect n A p) \<and>
    (a \<in> reject m A p \<longrightarrow> a \<in> reject n A p) \<and>
    (a \<in> defer m A p \<longrightarrow> a \<in> defer n A p)"

subsection \<open>Auxiliary Lemmata\<close>

lemma combine_ele_rej_def:
  assumes
    ele: "elect m A p = e" and
    rej: "reject m A p = r" and
    def: "defer m A p = d"
  shows "m A p = (e, r, d)"
  using def ele rej
  by auto

lemma par_comp_result_sound:
  assumes
    mod_m: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "well_formed A (m A p)"
  using mod_m f_prof
  unfolding electoral_module_def
  by simp

lemma result_presv_alts:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "(elect m A p) \<union> (reject m A p) \<union> (defer m A p) = A"
proof (safe)
  fix x :: "'a"
  assume elec_x: "x \<in> elect m A p"
  have partit:
    "\<forall> A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists> A' elec rej def. A = A' \<and> p = (elec, rej, def) \<and> elec \<union> rej \<union> def = A')"
    by simp
  from e_mod f_prof have set_partit:
    "set_equals_partition A (m A p)"
    unfolding electoral_module_def
    by simp
  thus "x \<in> A"
    using UnI1 elec_x fstI set_partit partit
    by (metis (no_types))
next
  fix x :: "'a"
  assume rej_x: "x \<in> reject m A p"
  have partit:
    "\<forall> A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists> A' elec rej def. A = A' \<and> p = (elec, rej, def) \<and> elec \<union> rej \<union> def = A')"
    by simp
  from e_mod f_prof have set_partit:
    "set_equals_partition A (m A p)"
    unfolding electoral_module_def
    by simp
  thus "x \<in> A"
    using UnI1 rej_x fstI set_partit partit
          sndI subsetD sup_ge2
    by metis
next
  fix x :: "'a"
  assume def_x: "x \<in> defer m A p"
  have partit:
    "\<forall> A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists> A' elec rej def. A = A' \<and> p = (elec, rej, def) \<and> elec \<union> rej \<union> def = A')"
    by simp
  from e_mod f_prof have set_partit:
    "set_equals_partition A (m A p)"
    unfolding electoral_module_def
    by simp
  thus "x \<in> A"
    using def_x set_partit partit sndI subsetD sup_ge2
    by metis
next
  fix x :: "'a"
  assume
    x_in_A: "x \<in> A" and
    not_def_x: "x \<notin> defer m A p" and
    not_rej_x: "x \<notin> reject m A p"
  have partit:
    "\<forall> A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists> A' elec rej def. A = A' \<and> p = (elec, rej, def) \<and> elec \<union> rej \<union> def = A')"
    by simp
  from e_mod f_prof have set_partit:
    "set_equals_partition A (m A p)"
    unfolding electoral_module_def
    by simp
  show "x \<in> elect m A p"
    using x_in_A not_def_x not_rej_x fst_conv partit
          set_partit snd_conv Un_iff
    by metis
qed

lemma result_disj:
  assumes
    module: "electoral_module m" and
    profile: "finite_profile A p"
  shows
    "(elect m A p) \<inter> (reject m A p) = {} \<and>
        (elect m A p) \<inter> (defer m A p) = {} \<and>
        (reject m A p) \<inter> (defer m A p) = {}"
proof (safe, simp_all)
  fix x :: "'a"
  assume
    elect_x: "x \<in> elect m A p" and
    reject_x: "x \<in> reject m A p"
  have partit:
    "\<forall> A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists> B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from module profile have set_partit:
    "set_equals_partition A (m A p)"
    unfolding electoral_module_def
    by simp
  from profile have prof_p:
    "finite A \<and> profile A p"
    by simp
  from module prof_p have wf_A_m:
    "well_formed A (m A p)"
    unfolding electoral_module_def
    by metis
  show False
    using prod.exhaust_sel DiffE UnCI elect_x reject_x
          module profile result_imp_rej wf_A_m
          prof_p set_partit partit
    by (metis (no_types))
next
  fix x :: "'a"
  assume
    elect_x: "x \<in> elect m A p" and
    defer_x: "x \<in> defer m A p"
  have partit:
    "\<forall> A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists> B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  have disj:
    "\<forall> p. \<not> disjoint3 p \<or>
      (\<exists> B C D. p = (B::'a set, C, D) \<and>
        B \<inter> C = {} \<and> B \<inter> D = {} \<and> C \<inter> D = {})"
    by simp
  from profile have prof_p:
    "finite A \<and> profile A p"
    by simp
  from module prof_p have wf_A_m:
    "well_formed A (m A p)"
    unfolding electoral_module_def
    by metis
  hence wf_A_m_0:
    "disjoint3 (m A p) \<and> set_equals_partition A (m A p)"
    by simp
  hence disj3:
    "disjoint3 (m A p)"
    by simp
  have set_partit:
    "set_equals_partition A (m A p)"
    using wf_A_m_0
    by simp
  from disj3 obtain
    elec :: "'a Result \<Rightarrow> 'a set" and
    rej :: "'a Result \<Rightarrow> 'a set" and
    def :: "'a Result \<Rightarrow> 'a set"
    where
    "m A p =
      (elec (m A p), rej (m A p), def (m A p)) \<and>
        elec (m A p) \<inter> rej (m A p) = {} \<and>
        elec (m A p) \<inter> def (m A p) = {} \<and>
        rej (m A p) \<inter> def (m A p) = {}"
    using elect_x defer_x disj
    by metis
  hence "((elect m A p) \<inter> (reject m A p) = {}) \<and>
          ((elect m A p) \<inter> (defer m A p) = {}) \<and>
          ((reject m A p) \<inter> (defer m A p) = {})"
    using disj3 eq_snd_iff fstI
    by metis
  thus False
    using elect_x defer_x module profile wf_A_m prof_p
          set_partit partit disjoint_iff_not_equal
    by (metis (no_types))
next
  fix x :: "'a"
  assume
    reject_x: "x \<in> reject m A p" and
    defer_x: "x \<in> defer m A p"
  have partit:
    "\<forall> A p.
      \<not> set_equals_partition (A::'a set) p \<or>
        (\<exists> B C D E. A = B \<and> p = (C, D, E) \<and> C \<union> D \<union> E = B)"
    by simp
  from module profile have set_partit:
    "set_equals_partition A (m A p)"
    unfolding electoral_module_def
    by simp
  from profile have prof_p:
    "finite A \<and> profile A p"
    by simp
  from module prof_p have wf_A_m:
    "well_formed A (m A p)"
    unfolding electoral_module_def
    by simp
  show False
    using prod.exhaust_sel DiffE UnCI reject_x defer_x
          module profile result_imp_rej wf_A_m
          prof_p set_partit partit
    by (metis (no_types))
qed

lemma elect_in_alts:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "elect m A p \<subseteq> A"
  using le_supI1 e_mod f_prof result_presv_alts sup_ge1
  by metis

lemma reject_in_alts:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "reject m A p \<subseteq> A"
  using le_supI1 e_mod f_prof result_presv_alts sup_ge2
  by fastforce

lemma defer_in_alts:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "defer m A p \<subseteq> A"
  using e_mod f_prof result_presv_alts
  by auto

lemma def_presv_fin_prof:
  assumes
    module:  "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "let new_A = defer m A p in finite_profile new_A (limit_profile new_A p)"
  using defer_in_alts infinite_super limit_profile_sound module f_prof
  by metis

text \<open>
  An electoral module can never reject, defer or elect more than
  |A| alternatives.
\<close>

lemma upper_card_bounds_for_result:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows
    "card (elect m A p) \<le> card A \<and>
      card (reject m A p) \<le> card A \<and>
      card (defer m A p) \<le> card A "
  using e_mod f_prof
  by (simp add: card_mono defer_in_alts elect_in_alts reject_in_alts)

lemma reject_not_elec_or_def:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "reject m A p = A - (elect m A p) - (defer m A p)"
proof -
  from e_mod f_prof
  have 0: "well_formed A (m A p)"
    unfolding electoral_module_def
    by simp
  with e_mod f_prof
    have "(elect m A p) \<union> (reject m A p) \<union> (defer m A p) = A"
      using result_presv_alts
      by simp
    moreover from 0
    have
      "(elect m A p) \<inter> (reject m A p) = {} \<and>
          (reject m A p) \<inter> (defer m A p) = {}"
    using e_mod f_prof result_disj
    by blast
  ultimately show ?thesis
    by blast
qed

lemma elec_and_def_not_rej:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "elect m A p \<union> defer m A p = A - (reject m A p)"
proof -
  from e_mod f_prof
  have 0: "well_formed A (m A p)"
    unfolding electoral_module_def
    by simp
  hence
    "disjoint3 (m A p) \<and> set_equals_partition A (m A p)"
    by simp
  with e_mod f_prof
  have "(elect m A p) \<union> (reject m A p) \<union> (defer m A p) = A"
    using e_mod f_prof result_presv_alts
    by blast
  moreover from 0 have
    "(elect m A p) \<inter> (reject m A p) = {} \<and>
        (reject m A p) \<inter> (defer m A p) = {}"
    using e_mod f_prof result_disj
    by blast
  ultimately show ?thesis
    by blast
qed

lemma defer_not_elec_or_rej:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p"
  shows "defer m A p = A - (elect m A p) - (reject m A p)"
proof -
  from e_mod f_prof
  have 0: "well_formed A (m A p)"
    unfolding electoral_module_def
    by simp
  hence "(elect m A p) \<union> (reject m A p) \<union> (defer m A p) = A"
    using e_mod f_prof result_presv_alts
    by simp
  moreover from 0 have
    "(elect m A p) \<inter> (defer m A p) = {} \<and>
        (reject m A p) \<inter> (defer m A p) = {}"
    using e_mod f_prof result_disj
    by blast
  ultimately show ?thesis
    by blast
qed

lemma electoral_mod_defer_elem:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    alternative: "x \<in> A" and
    not_elected: "x \<notin> elect m A p" and
    not_rejected: "x \<notin> reject m A p"
  shows "x \<in> defer m A p"
  using DiffI e_mod f_prof alternative
        not_elected not_rejected
        reject_not_elec_or_def
  by metis

lemma mod_contains_result_comm:
  assumes "mod_contains_result m n A p a"
  shows "mod_contains_result n m A p a"
proof (unfold mod_contains_result_def, safe)
  from assms
  show "electoral_module n"
    unfolding mod_contains_result_def
    by simp
next
  from assms
  show "electoral_module m"
    unfolding mod_contains_result_def
    by simp
next
  from assms
  show "finite A"
    unfolding mod_contains_result_def
    by simp
next
  from assms
  show "profile A p"
    unfolding mod_contains_result_def
    by simp
next
  from assms
  show "a \<in> A"
    unfolding mod_contains_result_def
    by simp
next
  assume "a \<in> elect n A p"
  thus "a \<in> elect m A p"
    using IntI assms electoral_mod_defer_elem empty_iff
          mod_contains_result_def result_disj
    by (metis (mono_tags, lifting))
next
  assume "a \<in> reject n A p"
  thus "a \<in> reject m A p"
    using IntI assms electoral_mod_defer_elem empty_iff
          mod_contains_result_def result_disj
    by (metis (mono_tags, lifting))
next
  assume "a \<in> defer n A p"
  thus "a \<in> defer m A p"
    using IntI assms electoral_mod_defer_elem empty_iff
          mod_contains_result_def result_disj
    by (metis (mono_tags, lifting))
qed

lemma not_rej_imp_elec_or_def:
  assumes
    e_mod: "electoral_module m" and
    f_prof: "finite_profile A p" and
    alternative: "x \<in> A" and
    not_rejected: "x \<notin> reject m A p"
  shows "x \<in> elect m A p \<or> x \<in> defer m A p"
  using alternative electoral_mod_defer_elem
        e_mod not_rejected f_prof
  by metis

lemma single_elim_imp_red_def_set:
  assumes
    eliminating: "eliminates 1 m" and
    leftover_alternatives: "card A > 1" and
    f_prof: "finite_profile A p"
  shows "defer m A p \<subset> A"
  using Diff_eq_empty_iff Diff_subset card_eq_0_iff defer_in_alts
        eliminates_def eliminating eq_iff leftover_alternatives
        not_one_le_zero f_prof psubsetI reject_not_elec_or_def
  by metis

lemma eq_alts_in_profs_imp_eq_results:
  assumes
    eq: "\<forall> a \<in> A. prof_contains_result m A p p' a" and
    input: "electoral_module m \<and> finite_profile A p \<and> finite_profile A p'"
  shows "m A p = m A p'"
proof -
  have "\<forall> a \<in> elect m A p. a \<in> elect m A p'"
    using elect_in_alts eq prof_contains_result_def input in_mono
    by metis
  moreover have "\<forall> a \<in> elect m A p'. a \<in> elect m A p"
  proof -
    fix a :: 'a
    have "\<forall> A A'. (A'::'a set) \<inter> A = {} \<or> A' \<noteq> {}"
      by blast
    moreover have elect_diff: "elect m A p' - A = {}"
      using Diff_eq_empty_iff elect_in_alts input
      by metis
    moreover have def_elec_disj: "defer m A p' \<inter> elect m A p' = {}"
      using disjoint_iff_not_equal input result_disj
      by (metis (no_types))
    moreover have rej_elec_disj: "reject m A p' \<inter> elect m A p' = {}"
      using disjoint_iff_not_equal input result_disj
      by (metis (no_types))
    ultimately have
      "(\<exists> A'. A' \<inter> elect m A p' = {} \<and> a \<in> A') \<or>
          a \<notin> elect m A p' \<or> a \<in> elect m A p"
      using DiffI electoral_mod_defer_elem eq
      unfolding prof_contains_result_def
      by (metis (no_types))
    from elect_diff def_elec_disj rej_elec_disj
    show ?thesis
      using Diff_iff Int_iff empty_iff eq not_rej_imp_elec_or_def
      unfolding prof_contains_result_def
      by metis
  qed
  moreover have
    "\<forall> a \<in> reject m A p. a \<in> reject m A p'"
    using reject_in_alts eq prof_contains_result_def input in_mono
    by fastforce
  moreover have
    "\<forall> a \<in> reject m A p'. a \<in> reject m A p"
  proof -
    {
      fix a' :: 'a
      have rej_set:
        "\<forall> f. electoral_module f \<longrightarrow> reject f A p' \<subseteq> A"
        using input reject_in_alts
        by metis
      have rej_def_disj:
        "\<forall> f. electoral_module f \<longrightarrow> reject f A p' \<inter> defer f A p' = {}"
        using input result_disj
        by metis
      have "electoral_module m \<and> profile A p \<and> finite_profile A p'"
        using input
        by blast
      hence
        "elect m A p' \<inter> reject m A p' = {} \<and> elect m A p' \<inter> defer m A p' = {} \<and>
          reject m A p' \<inter> defer m A p' = {}"
        by (simp add: result_disj)
      hence
        "a' \<in> elect m A p' \<longrightarrow> a' \<notin> reject m A p' \<or> a' \<in> reject m A p"
        using disjoint_iff_not_equal
        by metis
      hence "a' \<notin> reject m A p' \<or> a' \<in> reject m A p"
        using rej_def_disj rej_set electoral_mod_defer_elem eq input
        unfolding prof_contains_result_def
        by fastforce
    }
    thus ?thesis
      by metis
  qed
  moreover have "\<forall> a \<in> defer m A p. a \<in> defer m A p'"
    using defer_in_alts eq prof_contains_result_def input in_mono
    by fastforce
  moreover have "\<forall> a \<in> defer m A p'. a \<in> defer m A p"
    using calculation defer_not_elec_or_rej
          input subsetI subset_antisym
    by metis
  ultimately show ?thesis
    using prod.collapse subsetI subset_antisym
    by metis
qed

lemma eq_def_and_elect_imp_eq:
  assumes
    mod_m: "electoral_module m" and
    mod_n: "electoral_module n" and
    fin_p: "finite_profile A p" and
    fin_q: "finite_profile A q" and
    elec_eq: "elect m A p = elect n A q" and
    def_eq: "defer m A p = defer n A q"
  shows "m A p = n A q"
proof -
  have disj_m:
    "disjoint3 (m A p)"
    using mod_m fin_p
    unfolding electoral_module_def
    by auto
  have disj_n:
    "disjoint3 (n A q)"
    using mod_n fin_q
    unfolding electoral_module_def
    by auto
  have set_partit_m:
    "set_equals_partition A ((elect m A p), (reject m A p), (defer m A p))"
    using mod_m fin_p
    unfolding electoral_module_def
    by auto
  moreover have
    "disjoint3 ((elect m A p),(reject m A p),(defer m A p))"
    using disj_m prod.collapse
    by metis
  have set_partit_n:
    "set_equals_partition A ((elect n A q), (reject n A q), (defer n A q))"
    using mod_n fin_q
    unfolding electoral_module_def
    by auto
  moreover have
    "disjoint3 ((elect n A q),(reject n A q),(defer n A q))"
    using disj_n prod.collapse
    by metis
  have reject_p:
    "reject m A p = A - ((elect m A p) \<union> (defer m A p))"
    using mod_m fin_p combine_ele_rej_def result_imp_rej
    unfolding electoral_module_def
    by metis
  have reject_q:
    "reject n A q = A - ((elect n A q) \<union> (defer n A q))"
    using mod_n fin_q combine_ele_rej_def result_imp_rej
    unfolding electoral_module_def
    by metis
  from reject_p reject_q
  show ?thesis
    using elec_eq def_eq prod_eqI
    by metis
qed

subsection \<open>Non-Blocking\<close>

text \<open>
  An electoral module is non-blocking iff
  this module never rejects all alternatives.
\<close>

definition non_blocking :: "'a Electoral_Module \<Rightarrow> bool" where
  "non_blocking m \<equiv>
    electoral_module m \<and>
      (\<forall> A p.
          ((A \<noteq> {} \<and> finite_profile A p) \<longrightarrow> reject m A p \<noteq> A))"

subsection \<open>Electing\<close>

text \<open>
  An electoral module is electing iff
  it always elects at least one alternative.
\<close>

definition electing :: "'a Electoral_Module \<Rightarrow> bool" where
  "electing m \<equiv>
    electoral_module m \<and>
      (\<forall> A p. (A \<noteq> {} \<and> finite_profile A p) \<longrightarrow> elect m A p \<noteq> {})"

lemma electing_for_only_alt:
  assumes
    one_alt: "card A = 1" and
    electing: "electing m" and
    f_prof: "finite_profile A p"
  shows "elect m A p = A"
proof (safe)
  fix x :: "'a"
  assume electX: "x \<in> elect m A p"
  have
    "\<not> electoral_module m \<or> elect m A p \<subseteq> A"
    using elect_in_alts f_prof
    by (simp add: elect_in_alts)
  with electing have "elect m A p \<subseteq> A"
    unfolding electing_def
    by metis
  with electX show "x \<in> A"
    by auto
next
  fix x :: "'a"
  assume "x \<in> A"
  with electing f_prof one_alt
  show "x \<in> elect m A p"
    unfolding electing_def
    using One_nat_def Suc_leI card_seteq
          card_gt_0_iff elect_in_alts
          infinite_super
    by metis
qed

theorem electing_imp_non_blocking:
  assumes "electing m"
  shows "non_blocking m"
proof (unfold non_blocking_def, safe)
  from assms
  show "electoral_module m"
    unfolding electing_def
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    x :: "'a"
  assume
    finA: "finite A" and
    profA: "profile A p" and
    rejA: "reject m A p = A" and
    xInA: "x \<in> A"
  from assms have
    "electoral_module m \<and>
      (\<forall> A rs. A = {} \<or> infinite A \<or>
        \<not> profile A rs \<or> elect m A rs \<noteq> {})"
    unfolding electing_def
    by metis
  hence f1: "A = {}"
    using Diff_cancel Un_empty
          elec_and_def_not_rej
          finA profA rejA
    by (metis (no_types))
  from  xInA
  have "x \<in> A"
    by metis
  with f1 show "x \<in> {}"
    by metis
qed

subsection \<open>Properties\<close>

text \<open>
  An electoral module is non-electing iff
  it never elects an alternative.
\<close>

definition non_electing :: "'a Electoral_Module \<Rightarrow> bool" where
  "non_electing m \<equiv>
    electoral_module m \<and> (\<forall> A p. finite_profile A p \<longrightarrow> elect m A p = {})"

lemma single_elim_decr_def_card:
  assumes
    rejecting: "rejects 1 m" and
    not_empty: "A \<noteq> {}" and
    non_electing: "non_electing m" and
    f_prof: "finite_profile A p"
  shows "card (defer m A p) = card A - 1"
proof -
  have "rejects 1 m"
    using One_nat_def rejecting
    by metis
  moreover have
    "electoral_module m \<and>
      (\<forall> A rs. infinite A \<or> \<not> profile A rs \<or> elect m A rs = {})"
    using non_electing
    unfolding non_electing_def
    by metis
  moreover from this have
    "reject m A p \<subseteq> A"
    using f_prof reject_in_alts
    by metis
  ultimately show ?thesis
    using f_prof not_empty
    by (simp add: Suc_leI card_Diff_subset card_gt_0_iff
                  defer_not_elec_or_rej finite_subset
                  rejects_def)
qed

lemma single_elim_decr_def_card2:
  assumes
    eliminating: "eliminates 1 m" and
    not_empty: "card A > 1" and
    non_electing: "non_electing m" and
    f_prof: "finite_profile A p"
  shows "card (defer m A p) = card A - 1"
proof -
  have
    "\<forall> f. (non_electing f \<or>
            (\<exists> A rs. ({}::'a set) \<noteq> elect f A rs \<and> profile A rs \<and> finite A) \<or>
            \<not> electoral_module f) \<and>
          ((\<forall> A rs. {} = elect f A rs \<or> \<not> profile A rs \<or> infinite A) \<and>
            electoral_module f \<or> \<not> non_electing f)"
    using non_electing_def
    by metis
  moreover from this have
    "electoral_module m \<and>
      (\<forall> A rs. infinite A \<or> \<not> profile A rs \<or> elect m A rs = {})"
    using non_electing
    by (metis (no_types))
  moreover from this have
    "reject m A p \<subseteq> A"
    using f_prof reject_in_alts
    by metis
  moreover have "1 < card A"
    using not_empty
    by presburger
  moreover have "eliminates 1 m"
    using One_nat_def eliminating
    by presburger
  moreover have "eliminates 1 m"
    using eliminating
    by force
  ultimately show ?thesis
    using f_prof
    by (simp add: card_Diff_subset defer_not_elec_or_rej
                  eliminates_def finite_subset)
qed

text \<open>
  An electoral module is defer-deciding iff
  this module chooses exactly 1 alternative to defer and
  rejects any other alternative.
  Note that `rejects n-1 m` can be omitted due to the
  well-formedness property.
\<close>

definition defer_deciding :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_deciding m \<equiv>
    electoral_module m \<and> non_electing m \<and> defers 1 m"

text \<open>
  An electoral module decrements iff
  this module rejects at least one alternative whenever possible (|A| > 1).
\<close>

definition decrementing :: "'a Electoral_Module \<Rightarrow> bool" where
  "decrementing m \<equiv>
    electoral_module m \<and> (
      \<forall> A p . finite_profile A p \<longrightarrow>
          (card A > 1 \<longrightarrow> card (reject m A p) \<ge> 1))"

definition defer_condorcet_consistency :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_condorcet_consistency m \<equiv>
    electoral_module m \<and>
    (\<forall> A p w. condorcet_winner A p w \<and> finite A \<longrightarrow>
      (m A p =
        ({},
        A - (defer m A p),
        {d \<in> A. condorcet_winner A p d})))"

definition condorcet_compatibility :: "'a Electoral_Module \<Rightarrow> bool" where
  "condorcet_compatibility m \<equiv>
    electoral_module m \<and>
    (\<forall> A p w. condorcet_winner A p w \<and> finite A \<longrightarrow>
      (w \<notin> reject m A p \<and>
        (\<forall> l. \<not>condorcet_winner A p l \<longrightarrow> l \<notin> elect m A p) \<and>
          (w \<in> elect m A p \<longrightarrow>
            (\<forall> l. \<not>condorcet_winner A p l \<longrightarrow> l \<in> reject m A p))))"

text \<open>
  An electoral module is defer-monotone iff,
  when a deferred alternative is lifted, this alternative remains deferred.
\<close>

definition defer_monotonicity :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_monotonicity m \<equiv>
    electoral_module m \<and>
      (\<forall> A p q w.
          (finite A \<and> w \<in> defer m A p \<and> lifted A p q w) \<longrightarrow> w \<in> defer m A q)"

text \<open>
  An electoral module is defer-lift-invariant iff
  lifting a deferred alternative does not affect the outcome.
\<close>

definition defer_lift_invariance :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_lift_invariance m \<equiv>
    electoral_module m \<and>
      (\<forall> A p q a.
          (a \<in> (defer m A p) \<and> lifted A p q a) \<longrightarrow> m A p = m A q)"

text \<open>
  Two electoral modules are disjoint-compatible if they only make decisions
  over disjoint sets of alternatives. Electoral modules reject alternatives
  for which they make no decision.
\<close>

definition disjoint_compatibility :: "'a Electoral_Module \<Rightarrow>
                                         'a Electoral_Module \<Rightarrow> bool" where
  "disjoint_compatibility m n \<equiv>
    electoral_module m \<and> electoral_module n \<and>
        (\<forall> S. finite S \<longrightarrow>
          (\<exists> A \<subseteq> S.
            (\<forall> a \<in> A. indep_of_alt m S a \<and>
              (\<forall> p. finite_profile S p \<longrightarrow> a \<in> reject m S p)) \<and>
            (\<forall> a \<in> S - A. indep_of_alt n S a \<and>
              (\<forall> p. finite_profile S p \<longrightarrow> a \<in> reject n S p))))"

text \<open>
  Lifting an elected alternative a from an invariant-monotone
  electoral module either does not change the elect set, or
  makes a the only elected alternative.
\<close>

definition invariant_monotonicity :: "'a Electoral_Module \<Rightarrow> bool" where
  "invariant_monotonicity m \<equiv>
    electoral_module m \<and>
        (\<forall> A p q a. (a \<in> elect m A p \<and> lifted A p q a) \<longrightarrow>
          (elect m A q = elect m A p \<or> elect m A q = {a}))"

text \<open>
  Lifting a deferred alternative a from a defer-invariant-monotone
  electoral module either does not change the defer set, or
  makes a the only deferred alternative.
\<close>

definition defer_invariant_monotonicity :: "'a Electoral_Module \<Rightarrow> bool" where
  "defer_invariant_monotonicity m \<equiv>
    electoral_module m \<and> non_electing m \<and>
        (\<forall> A p q a. (a \<in> defer m A p \<and> lifted A p q a) \<longrightarrow>
          (defer m A q = defer m A p \<or> defer m A q = {a}))"

subsection \<open>Inference Rules\<close>

lemma ccomp_and_dd_imp_def_only_winner:
  assumes ccomp: "condorcet_compatibility m" and
          dd: "defer_deciding m" and
          winner: "condorcet_winner A p w"
  shows "defer m A p = {w}"
proof (rule ccontr)
  assume not_w: "defer m A p \<noteq> {w}"
  from dd have def_1:
    "defers 1 m"
    unfolding defer_deciding_def
    by metis
  hence c_win:
    "finite_profile A p \<and>  w \<in> A \<and> (\<forall>x \<in> A - {w} . wins w p x)"
    using winner
    by simp
  hence "card (defer m A p) = 1"
    using Suc_leI card_gt_0_iff def_1 equals0D
    unfolding One_nat_def defers_def
    by metis
  hence 0: "\<exists> x \<in> A . defer m A p = {x}"
    using card_1_singletonE dd defer_in_alts insert_subset c_win
    unfolding defer_deciding_def
    by metis
  with not_w have "\<exists> l \<in> A . l \<noteq> w \<and> defer m A p = {l}"
    by metis
  hence not_in_defer: "w \<notin> defer m A p"
    by auto
  have "non_electing m"
    using dd
    unfolding defer_deciding_def
    by simp
  hence not_in_elect: "w \<notin> elect m A p"
    using c_win equals0D
    unfolding non_electing_def
    by simp
  from not_in_defer not_in_elect
  have one_side:
    "w \<in> reject m A p"
    using ccomp c_win electoral_mod_defer_elem
    unfolding condorcet_compatibility_def
    by metis
  from ccomp
  have other_side: "w \<notin> reject m A p"
    using c_win winner
    unfolding condorcet_compatibility_def
    by simp
  thus False
    by (simp add: one_side)
qed

theorem ccomp_and_dd_imp_dcc[simp]:
  assumes
    ccomp: "condorcet_compatibility m" and
    dd: "defer_deciding m"
  shows "defer_condorcet_consistency m"
proof (unfold defer_condorcet_consistency_def, auto)
  from dd
  show "electoral_module m"
    unfolding defer_deciding_def
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a"
  assume
    prof_A: "profile A p" and
    w_in_A: "w \<in> A" and
    finiteness: "finite A" and
    assm: "\<forall> x \<in> A - {w}.
          card {i. i < length p \<and> (w, x) \<in> (p!i)} <
            card {i. i < length p \<and> (x, w) \<in> (p!i)}"
  have winner: "condorcet_winner A p w"
    using assm finiteness prof_A w_in_A
    by simp
  hence
    "m A p =
      ({},
        A - defer m A p,
        {d \<in> A. condorcet_winner A p d})"
  proof -
    from dd have 0: "elect m A p = {}"
      using winner
      unfolding defer_deciding_def non_electing_def
      by simp
    from dd ccomp have 1: "defer m A p = {w}"
      using ccomp_and_dd_imp_def_only_winner winner
      by simp
    from 0 1 have 2: "reject m A p = A - defer m A p"
      using Diff_empty dd reject_not_elec_or_def winner
      unfolding defer_deciding_def
      by fastforce
    from 0 1 2 have 3: "m A p = ({}, A - defer m A p, {w})"
      using combine_ele_rej_def
      by metis
    have "{w} = {d \<in> A. condorcet_winner A p d}"
      using cond_winner_unique3 winner
      by metis
    thus ?thesis
      using 3
      by auto
  qed
  hence
    "m A p =
      ({},
        A - defer m A p,
        {d \<in> A. \<forall> x \<in> A - {d}. wins d p x})"
    using finiteness prof_A winner Collect_cong
    by auto
  hence
    "m A p =
        ({},
          A - defer m A p,
          {d \<in> A. \<forall> x \<in> A - {d}.
            prefer_count p x d < prefer_count p d x})"
    by simp
  hence
    "m A p =
        ({},
          A - defer m A p,
          {d \<in> A. \<forall> x \<in> A - {d}.
            card {i. i < length p \<and> (let r = (p!i) in (d \<preceq>\<^sub>r x))} <
                card {i. i < length p \<and> (let r = (p!i) in (x \<preceq>\<^sub>r d))}})"
    by simp
  thus
    "m A p =
        ({},
          A - defer m A p,
          {d \<in> A. \<forall> x \<in> A - {d}.
            card {i. i < length p \<and> (d, x) \<in> (p!i)} <
              card {i. i < length p \<and> (x, d) \<in> (p!i)}})"
    by simp
qed

text \<open>
  If m and n are disjoint compatible, so are n and m.
\<close>

theorem disj_compat_comm[simp]:
  assumes "disjoint_compatibility m n"
  shows "disjoint_compatibility n m"
proof (unfold disjoint_compatibility_def, safe)
  show "electoral_module m"
    using assms
    unfolding disjoint_compatibility_def
    by simp
next
  show "electoral_module n"
    using assms
    unfolding disjoint_compatibility_def
    by simp
next
  fix S :: "'a set"
  assume fin_S: "finite S"
  obtain A where
    old_A:
      "(A \<subseteq> S \<and>
        (\<forall> a \<in> A. indep_of_alt m S a \<and>
          (\<forall> p. finite_profile S p \<longrightarrow> a \<in> reject m S p)) \<and>
        (\<forall> a \<in> S - A. indep_of_alt n S a \<and>
          (\<forall> p. finite_profile S p \<longrightarrow> a \<in> reject n S p)))"
    using assms fin_S
    unfolding disjoint_compatibility_def
    by metis
  hence
    "(\<exists> A \<subseteq> S.
      (\<forall> a \<in> S - A. indep_of_alt n S a \<and>
        (\<forall> p. finite_profile S p \<longrightarrow> a \<in> reject n S p)) \<and>
      (\<forall> a \<in> A. indep_of_alt m S a \<and>
        (\<forall> p. finite_profile S p \<longrightarrow> a \<in> reject m S p)))"
    by auto
  hence
    "(\<exists> A \<subseteq> S.
      (\<forall> a \<in> S - A. indep_of_alt n S a \<and>
        (\<forall> p. finite_profile S p \<longrightarrow> a \<in> reject n S p)) \<and>
      (\<forall> a \<in> S - (S - A). indep_of_alt m S a \<and>
        (\<forall> p. finite_profile S p \<longrightarrow> a \<in> reject m S p)))"
    using double_diff order_refl
    by metis
  thus
    "(\<exists> A \<subseteq> S.
        (\<forall> a \<in> A. indep_of_alt n S a \<and>
          (\<forall>p. finite_profile S p \<longrightarrow> a \<in> reject n S p)) \<and>
        (\<forall> a \<in> S - A. indep_of_alt m S a \<and>
          (\<forall> p. finite_profile S p \<longrightarrow> a \<in> reject m S p)))"
    by fastforce
qed

text \<open>
  Every electoral module which is defer-lift-invariant is
  also defer-monotone.
\<close>

theorem dl_inv_imp_def_mono[simp]:
  assumes "defer_lift_invariance m"
  shows "defer_monotonicity m"
  using assms
  unfolding defer_monotonicity_def defer_lift_invariance_def
  by metis

subsection \<open>Social Choice Properties\<close>

subsubsection \<open>Condorcet Consistency\<close>

definition condorcet_consistency :: "'a Electoral_Module \<Rightarrow> bool" where
  "condorcet_consistency m \<equiv>
    electoral_module m \<and>
    (\<forall> A p w. condorcet_winner A p w \<longrightarrow>
      (m A p =
        ({e \<in> A. condorcet_winner A p e},
          A - (elect m A p),
          {})))"

lemma condorcet_consistency2:
  "condorcet_consistency m \<longleftrightarrow>
      electoral_module m \<and>
        (\<forall> A p w. condorcet_winner A p w \<longrightarrow>
            (m A p =
              ({w}, A - (elect m A p), {})))"
proof (safe)
  assume "condorcet_consistency m"
  thus "electoral_module m"
    unfolding condorcet_consistency_def
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    w :: "'a"
  assume
    cc: "condorcet_consistency m" and
    cwin: "condorcet_winner A p w"
  show
    "m A p = ({w}, A - elect m A p, {})"
    using cond_winner_unique3 cc cwin
    unfolding condorcet_consistency_def
    by (metis (mono_tags, lifting))
next
  assume
    e_mod: "electoral_module m" and
    cwin:
    "\<forall> A p w. condorcet_winner A p w \<longrightarrow>
      m A p = ({w}, A - elect m A p, {})"
  have
    "\<forall> f. condorcet_consistency f =
      (electoral_module f \<and>
        (\<forall> A rs a. \<not> condorcet_winner A rs (a::'a) \<or>
          f A rs = ({a \<in> A. condorcet_winner A rs a},
                    A - elect f A rs, {})))"
    unfolding condorcet_consistency_def
    by blast
  moreover have
    "\<forall> A rs a. \<not> condorcet_winner A rs (a::'a) \<or>
        {a \<in> A. condorcet_winner A rs a} = {a}"
    using cond_winner_unique3
    by (metis (full_types))
  ultimately show "condorcet_consistency m"
    unfolding condorcet_consistency_def
    using cond_winner_unique3 e_mod cwin
    by presburger
qed

subsubsection \<open>(Weak) Monotonicity\<close>

text \<open>
  An electoral module is monotone iff
  when an elected alternative is lifted, this alternative remains elected.
\<close>

definition monotonicity :: "'a Electoral_Module \<Rightarrow> bool" where
  "monotonicity m \<equiv>
    electoral_module m \<and>
      (\<forall> A p q w.
          (finite A \<and> w \<in> elect m A p \<and> lifted A p q w) \<longrightarrow> w \<in> elect m A q)"

subsubsection \<open>Homogeneity\<close>

fun times :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "times n l = concat (replicate n l)"

definition homogeneity :: "'a Electoral_Module \<Rightarrow> bool" where
  "homogeneity m \<equiv>
    electoral_module m \<and>
      (\<forall> A p n.
        (finite_profile A p \<and> n > 0 \<longrightarrow>
          (m A p = m A (times n p))))"

end


theory quasimax imports Main       (* Quasi-maximality: C. Benzmüller & X. Parent, 2020 *)

(* Quasi-maximality, Deb 1977, means maximal wrt transitive closure of the betterness relation restricted to the menu *)
(* Quasi-maximality: ideally the transitive closure should be paramatrized by a context.
It is restricted to the set of antecedent-worlds. The transitive closure should be recalculated each time
each time the set of worlds in which the antecedent is true changes  *)

begin
typedecl i (*Possible worlds.*) type_synonym \<sigma> = "(i\<Rightarrow>bool)"

consts aw::i (*Actual world.*)
abbreviation etrue  :: "\<sigma>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation efalse :: "\<sigma>" ("\<^bold>\<bottom>")  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation enot :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53)  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
abbreviation eand :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
abbreviation eor  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
abbreviation eimp :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
abbreviation eequ :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"

(*Possibilist--constant domain--quantification.*)
abbreviation eforall ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
abbreviation eforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation eexists ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
abbreviation eexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

abbreviation ebox :: "\<sigma>\<Rightarrow>\<sigma>" ("\<box>") where "\<box> \<equiv> \<lambda>\<phi> w.  \<forall>v. \<phi>(v)"

(* Some useful relations for constraining accessibility relations*)
type_synonym \<alpha> = "i\<Rightarrow>\<sigma>" (*Type of betterness relation between worlds.*)

definition transitive :: "\<alpha>\<Rightarrow>bool" where "transitive R \<equiv> \<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z"
definition sub_rel :: "\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" where "sub_rel R Q \<equiv> \<forall>u v. R u v \<longrightarrow> Q u v"
definition inverse_rel :: "\<alpha>\<Rightarrow>\<alpha>" where "inverse_rel R \<equiv> \<lambda>u v. R v u"
(*In HOL the transitive closure of a relation can be defined in a single line.*)
definition tc :: "\<alpha>\<Rightarrow>\<alpha>" where "tc R \<equiv> \<lambda>x y.\<forall>Q. transitive Q \<longrightarrow> (sub_rel R Q \<longrightarrow> Q x y)"

consts R :: "i\<Rightarrow>\<sigma>" (infixr "R" 70) (*Betterness relation, cf. def. of \<circle><_|_>.*)

abbreviation max  :: "\<sigma>\<Rightarrow>\<sigma>" ("max<_>")
  where "max<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x)\<and> x R v  \<longrightarrow>  v  R x))) )"

abbreviation tmax  :: "\<sigma>\<Rightarrow>\<sigma>" ("tmax<_>")
  where "tmax<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x)\<and> x tc R v  \<longrightarrow>  v  tc R x))) )"

abbreviation esubset :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infix "\<^bold>\<subseteq>" 53)
  where "\<phi> \<^bold>\<subseteq> \<psi> \<equiv> \<forall>x. \<phi> x \<longrightarrow> \<psi> x"
abbreviation econd  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<circle><_|_>")
  where "\<circle><\<psi>|\<phi>> \<equiv>  \<lambda>w. max<\<phi>> \<^bold>\<subseteq> \<psi>"
abbreviation euncobl :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circle><_>")
  where "\<^bold>\<circle><\<phi>> \<equiv> \<circle><\<phi>|\<^bold>\<top>>"

abbreviation evalid :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]109)  (*Global validity.*)
  where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"
abbreviation ecjactual :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) (*Local validity — in world aw.*)
  where "\<lfloor>p\<rfloor>\<^sub>l \<equiv> p(aw)"

lemma True nitpick [satisfy,user_axioms,expect=genuine] oops (*Consistency conf.*)

(*Correspondence theory.*)
lemma assumes "\<forall>x y z. x R y \<and> y R z \<longrightarrow> x R z"
      shows "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
  using assms by blast oops

lemma assumes "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
      shows "\<forall>x y z. x R y \<and> y R z \<longrightarrow> x R z"
  nitpick [show_all,format=2] oops (*Countermodel presented by Nitpick.*)
end


theory ConnectionBase
  imports ModelTypes
begin

locale ConnectionBase = opening lifting_syntax +
  fixes Abs :: \<open>('a :: ModelBase') \<Rightarrow> 'b\<close>
    and Rep :: \<open>'b \<Rightarrow> 'a\<close>
    and rel :: \<open>'a \<Rightarrow> 'b \<Rightarrow> bool\<close> (infix \<open>\<simeq>\<close> 50)
    and mdefault :: \<open>'a\<close>
  assumes tydef   : \<open>type_definition Rep Abs (Set.Collect (\<lambda>x. x : M))\<close>
      and rel_def : \<open>rel x y = (x = Rep y)\<close>
      and mdefault_m : "mdefault : M"
begin

interpretation c : type_definition \<open>Rep :: 'b \<Rightarrow> 'a\<close> \<open>Abs :: 'a \<Rightarrow> 'b\<close> \<open>(Set.Collect (\<lambda>x. x : M))\<close>
  by (rule tydef)

lemma M_abs_inverse :
  assumes b:"b : M"
  shows "Rep (Abs b) = b"
  using c.Abs_inverse b by auto

lemma M_rep :
  "Rep b : M"
  using c.Rep by auto

lemmas isom [simp] =  M_abs_inverse M_rep c.Rep_inverse

lemma ceqD1 [dest] : "x \<simeq> y \<Longrightarrow> Abs x = y"
  unfolding rel_def by auto

lemma ceqD2 [dest] : "x \<simeq> y \<Longrightarrow> x = Rep y"
  unfolding rel_def by auto

lemma ceq_rep_refl [simp] : "(Rep x) \<simeq> x"
  unfolding rel_def by auto

lemma ceq_abs_refl [simp] :
  assumes "x : M"
    shows "x \<simeq> (Abs x)"
  unfolding rel_def
  using assms by auto

subsection \<open>Transfer rules for soft typing\<close>

lemma typing_transfer [transfer_rule]: "(R ===> (R ===> iff) ===> iff) (:) (:)"
  unfolding rel_fun_def has_ty_def by auto

lemma int_transfer [transfer_rule]: "((R ===> iff) ===> (R ===> iff) ===> (R ===> iff)) (\<triangle>) (\<triangle>)"
  unfolding rel_fun_def inter_ty_def by auto

lemma un_transfer [transfer_rule]: "((R ===> iff) ===> (R ===> iff) ===> (R ===> iff)) (\<mho>) (\<mho>)"
  unfolding rel_fun_def union_ty_def has_ty_def by auto

lemma pred_ty_eq :
  "P = Q \<longleftrightarrow> (\<forall>x. x : P \<longleftrightarrow> x : Q)"
  unfolding has_ty_def by auto

lemma subtyp_eq :
  "P << Q \<longleftrightarrow> (\<forall>x. x : P \<longrightarrow> x : Q)"
  unfolding has_ty_def subtyp_def by auto

subsection \<open>Transfer rules for logical constants\<close>

lemma eq_transfer [transfer_rule] :
  "((\<simeq>) ===> (\<simeq>) ===> (\<longleftrightarrow>)) (=) (=)"
  by auto

(* lemma higher_order_eq_transfer [transfer_rule] :
  "(((\<simeq>) ===> iff) ===> ((\<simeq>) ===> iff) ===> (\<longleftrightarrow>)) (\<lambda>P Q. m\<forall>x. P x \<longleftrightarrow> Q x) (=)"
   sorry*)

lemma all_transfer [transfer_rule] :
  "(((\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) (mall) (All)"
proof (rule)
  fix P Q assume "((\<simeq>) ===> iff) P Q"
  hence x:"\<And>x x'. x \<simeq> x' \<Longrightarrow> P x \<longleftrightarrow> Q x'" by (auto dest: rel_funD)
  show "mall P \<longleftrightarrow> All Q"
    unfolding mall_def
    using x[OF ceq_rep_refl] x[OF ceq_abs_refl] M_rep
    by blast
qed

lemma ex_transfer [transfer_rule] :
  "(((\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) (mex) (Ex)"
proof (rule)
  fix P Q assume "((\<simeq>) ===> iff) P Q"
  hence x:"\<And>x x'. x \<simeq> x' \<Longrightarrow> P x \<longleftrightarrow> Q x'" by (auto dest: rel_funD)
  show "mex P \<longleftrightarrow> Ex Q"
    unfolding mex_def
    using x[OF ceq_rep_refl] x[OF ceq_abs_refl] M_rep
    by blast
qed

lemma ex1_transfer [transfer_rule] :
  "(((\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) (mex1) (Ex1)"
proof (rule)
  fix P Q assume "((\<simeq>) ===> iff) P Q"
  hence x:"\<And>x x'. x \<simeq> x' \<Longrightarrow> P x \<longleftrightarrow> Q x'" by (auto dest: rel_funD)
  show "mex1 P \<longleftrightarrow> Ex1 Q"
  proof
    assume P:"mex1 P" show "Ex1 Q"
    proof (insert P, unfold mex1_def tex1_def, erule ex1E, rule ex1I)
      fix x assume
        "x : M \<and> P x" and uniq:"\<forall>y. y : M \<and> P y \<longrightarrow> y = x"
      thus "Q (Abs x)" "\<And>y. Q y \<Longrightarrow> y = (Abs x)"
      proof (metis x[OF ceq_abs_refl])
        fix y assume "Q y"
        hence "(Rep y) = x" using uniq x[OF ceq_rep_refl] by auto
        thus "y = Abs x" using c.Rep_inverse by auto
      qed
    qed
  next
    assume Q:"Ex1 Q" show "mex1 P"
      unfolding mex1_def tex1_def
    proof (rule ex1E[OF Q], rule ex1I)
      fix y assume "Q y" and uniq:"\<forall>z. Q z \<longrightarrow> z = y"
      thus "Rep y : M \<and> P (Rep y)" using M_rep[of y] x[OF ceq_rep_refl, of y] by metis
      fix y' assume y': "y' : M \<and> P y'"
      hence "Abs y' = y" using uniq x[OF ceq_abs_refl, of y'] by auto
      thus "y' = Rep y" using M_abs_inverse y' by auto
    qed
  qed
qed

lemma uniq_transfer [transfer_rule] :
  "(((\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) (muniq) (Uniq)"
proof (rule)
  fix P Q assume "((\<simeq>) ===> iff) P Q"
  hence x:"\<And>x x'. x \<simeq> x' \<Longrightarrow> P x \<longleftrightarrow> Q x'" by (auto dest: rel_funD)
  show "muniq P \<longleftrightarrow> Uniq Q"
  proof
    assume P:"muniq P" show "Uniq Q"
    proof (rule)
      fix x y assume "Q x" "Q y"
      hence "P (Rep x)" "P (Rep y)" using x[OF ceq_rep_refl] by auto
      hence "Rep x = Rep y" using P
        unfolding muniq_def tuniq_def Uniq_def by auto
      thus "x = y" using c.Rep_inject by auto
     qed
  next
    assume Q:"Uniq Q" show "muniq P"
      unfolding muniq_def tuniq_def
    proof (rule, auto)
      fix x y assume "x : M" "P x" "y : M" "P y"
      hence "Q (Abs x)" "Q (Abs y)" using x[OF ceq_abs_refl] by auto
      hence "Abs x = Abs y" using Q unfolding Uniq_def by auto
      thus "x = y" using c.Abs_inject \<open>x : M\<close> \<open>y : M\<close> by auto
    qed
  qed
qed

lemma unary_pred_all_transfer [transfer_rule] :
  "((((\<simeq>) ===> iff) ===> iff) ===> iff) All All"
proof
  fix U :: "('a \<Rightarrow> bool) \<Rightarrow> bool" and V
  assume "(((\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) U V"
  hence pq:"\<And>P Q. (\<And>a a' b b'. a \<simeq> a' \<Longrightarrow> P a \<longleftrightarrow> Q a') \<Longrightarrow> U P \<longleftrightarrow> V Q"
    unfolding rel_fun_def by auto
  show "All U = All V"
  proof
    assume U:"All U"
    show "All V"
    proof
      fix Q :: "'b \<Rightarrow> bool"
      let ?P = "\<lambda>a. Q (Abs a)"
      have "\<And>a a'. a \<simeq> a' \<Longrightarrow> ?P a \<longleftrightarrow> Q a'" by auto
      hence "U ?P \<longleftrightarrow> V Q" by (rule pq)
      thus "V Q" using U by simp
    qed
  next
    assume V: "All V"
    show "All U"
    proof
      fix P :: "'a \<Rightarrow> bool"
      let ?Q = "\<lambda>a'. P (Rep a')"
      have "\<And>a a'. a \<simeq> a' \<Longrightarrow> P a \<longleftrightarrow> ?Q a'" by auto
      hence "U P \<longleftrightarrow> V ?Q" by (rule pq)
      thus "U P" using V by simp
    qed
  qed
qed

lemma binary_pred_all_transfer [transfer_rule] :
  "((((\<simeq>) ===> (\<simeq>) ===> iff) ===> iff) ===> iff) All All"
proof
  fix U :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" and V
  assume "(((\<simeq>) ===> (\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) U V"
  hence pq:"\<And>P Q. (\<And>a a' b b'. a \<simeq> a' \<Longrightarrow> b \<simeq> b' \<Longrightarrow> P a b \<longleftrightarrow> Q a' b') \<Longrightarrow> U P \<longleftrightarrow> V Q"
    unfolding rel_fun_def by auto
  show "All U = All V"
  proof
    assume U:"All U"
    show "All V"
    proof
      fix Q :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
      let ?P = "\<lambda>a b. Q (Abs a) (Abs b)"
      have "\<And>a a' b b'. a \<simeq> a' \<Longrightarrow> b \<simeq> b' \<Longrightarrow> ?P a b \<longleftrightarrow> Q a' b'" by auto
      hence "U ?P \<longleftrightarrow> V Q" by (rule pq)
      thus "V Q" using U by simp
    qed
  next
    assume V: "All V"
    show "All U"
    proof
      fix P :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
      let ?Q = "\<lambda>a' b'. P (Rep a') (Rep b')"
      have "\<And>a a' b b'. a \<simeq> a' \<Longrightarrow> b \<simeq> b' \<Longrightarrow> P a b \<longleftrightarrow> ?Q a' b'" by auto
      hence "U P \<longleftrightarrow> V ?Q" by (rule pq)
      thus "U P" using V by simp
    qed
  qed
qed

lemma binary_fun_all_transfer [transfer_rule] :
  "((((\<simeq>) ===> (\<simeq>) ===> (\<simeq>)) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>))
      (\<lambda>P. \<forall>F : M \<rightarrow> M \<rightarrow> M. P F) (\<lambda>P. \<forall>F. P F)"
proof
  fix P Q assume "(((\<simeq>) ===> (\<simeq>) ===> (\<simeq>)) ===> (\<longleftrightarrow>)) P Q"
  hence FG: "\<And>F G. (\<And>x x' y y'. x \<simeq> x' \<Longrightarrow> y \<simeq> y' \<Longrightarrow> F x y = Rep (G x' y')) \<Longrightarrow> P F \<longleftrightarrow> Q G"
    unfolding rel_fun_def by auto
  show "(\<forall>F : M \<rightarrow> M \<rightarrow> M. P F) \<longleftrightarrow> (\<forall>F. Q F)"
  proof (rule)
    assume P:"\<forall>F : M \<rightarrow> M \<rightarrow> M. P F"
    show "\<forall>G. Q G"
    proof
      fix G
      let ?F = "\<lambda>x y. Rep (G (Abs x) (Abs y))"
      have F_typ:"?F : M \<rightarrow> M \<rightarrow> M" by (rule funI, rule funI, auto)
      have "\<And>x x' y y'. x \<simeq> x' \<Longrightarrow> y \<simeq> y' \<Longrightarrow> ?F x y = Rep (G x' y')" by (auto)
      hence "P ?F \<longleftrightarrow> Q G" using FG by auto
      thus "Q G" using P F_typ by auto
    qed
  next
    assume Q:"All Q"
    show "\<forall>F : M \<rightarrow> M \<rightarrow> M. P F"
    proof (rule)
      fix F :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
      assume F_typ:"F : M \<rightarrow> M \<rightarrow> M"
      let ?G = "\<lambda>x y. Abs (F (Rep x) (Rep y))"
      have "\<And>x x' y y'. x \<simeq> x' \<Longrightarrow> y \<simeq> y' \<Longrightarrow> F x y = Rep (?G x' y')"
        using funE[OF funE[OF F_typ]] by auto
      hence "P F \<longleftrightarrow> Q ?G" using FG by auto
      thus "P F" using Q by auto
    qed
  qed
qed

lemma limfun_all_transfer [transfer_rule] :
  "((((\<simeq>) ===> ((\<simeq>) ===> (\<simeq>)) ===> (\<simeq>)) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>))
      (\<lambda>P. \<forall>G : LimFun. P G) (\<lambda>P. \<forall>G. P G)"
proof
  fix P Q assume "(((\<simeq>) ===> ((\<simeq>) ===> (\<simeq>)) ===> (\<simeq>)) ===> (\<longleftrightarrow>)) P Q"
  hence FG:
    "\<And>G G'. (\<And>x x'. x \<simeq> x' \<Longrightarrow> (\<And>f f'. ((\<simeq>) ===> (\<simeq>)) f f'
      \<Longrightarrow> G x f = Rep (G' x' f'))) \<Longrightarrow> P G \<longleftrightarrow> Q G'"
    unfolding rel_fun_def rel_def by blast
  show "(\<forall>G : LimFun. P G) \<longleftrightarrow> (\<forall>G. Q G)"
  proof (rule)
    assume P:"\<forall>G : LimFun. P G"
    show "\<forall>G'. Q G'"
    proof
      fix G'
      let ?G = "\<lambda>x f. Rep (G' (Abs x) (\<lambda>y. Abs (f (Rep y))))"
      have G_typ:"?G : LimFun"
        unfolding LimFun_def
        by (rule intI, rule funI, rule funI, auto,
            rule tyI, use forceM_eq[OF M_rep] in auto)
      have "\<And>x x' f f'. x \<simeq> x' \<Longrightarrow> ((\<simeq>) ===> (\<simeq>)) f f'
              \<Longrightarrow> ?G x f = Rep (G' x' f')"
        unfolding rel_fun_def rel_def by (auto)
      hence "P ?G \<longleftrightarrow> Q G'" using FG by auto
      thus "Q G'" using P G_typ by auto
    qed
  next
    assume Q:"All Q"
    show "\<forall>G : LimFun. P G"
    proof (rule)
      fix G :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a"
      assume G_typ:"G : LimFun"
      let ?G' = "\<lambda>x f. Abs (G (Rep x) (\<lambda>y. Rep (f (Abs (forceM y)))))"
      have "\<And>x x' f f'. x \<simeq> x' \<Longrightarrow> ((\<simeq>) ===> (\<simeq>)) f f'  \<Longrightarrow> G x f = Rep (?G' x' f')"
        unfolding rel_fun_def rel_def
      proof -
        fix x x' f f' assume
          x_eq : "x = Rep x'" and
          f_eq : "\<forall>x y. x = Rep y \<longrightarrow> f x = Rep (f' y)"
        hence
          "\<forall>a. f (forceM a) = Rep (f' (Abs (forceM a)))"
          by (metis forceM_m M_abs_inverse)
        hence
          "G x (\<lambda>a. f (forceM a)) = Rep (?G' x' f')"
          using x_eq funE[OF funE[OF limfunD1[OF G_typ]] funI] by auto
        moreover have "f : M \<rightarrow> M"
        proof (rule funI)
          fix x :: \<open>'a\<close> assume "x : M"
          hence "x = Rep (Abs x)" by auto
          hence "f x = Rep (f' (Abs x))" using f_eq by blast
          thus "f x : M" using M_rep by auto
        qed
        ultimately show
          "G x f = Rep (?G' x' f')"
          using limfunD2[OF G_typ] x_eq M_rep funI[OF ] by auto
      qed
      hence "P G \<longleftrightarrow> Q ?G'" using FG by auto
      thus "P G" using Q by auto
    qed
  qed
qed

subsection \<open>Transfer rules for type-bounded quantifiers\<close>

lemma tall_transfer [transfer_rule] :
  "(((\<simeq>) ===> (\<longleftrightarrow>)) ===> ((\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) (mtall) (tall)"
  unfolding mtall_def tall_def
  by (transfer_prover)

lemma tall_binpred_transfer [transfer_rule] :
  "((((\<simeq>) ===> (\<simeq>) ===> iff) ===> iff) ===> (((\<simeq>) ===> (\<simeq>) ===> iff) ===> iff) ===> iff) tall tall"
  unfolding mtall_def tall_def
  by (transfer_prover)

lemma tex_transfer [transfer_rule] :
  "(((\<simeq>) ===> (\<longleftrightarrow>)) ===> ((\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) (mtex) (tex)"
  unfolding mtex_def tex_def
  by (transfer_prover)

lemma tuniq_transfer [transfer_rule] :
  "(((\<simeq>) ===> (\<longleftrightarrow>)) ===> ((\<simeq>) ===> (\<longleftrightarrow>)) ===> (\<longleftrightarrow>)) (mtuniq) (tuniq)"
  unfolding mtuniq_def tuniq_def
  by (transfer_prover)

subsection \<open>Transfer rules for definite descriptions\<close>

lemma defdes_transfer [transfer_rule] :
  "(rel ===> (rel ===> (\<longleftrightarrow>)) ===> rel) (\<lambda>d P. mdefdes P d) the_default"
proof (rule, rule)
  fix d d' P P'
  assume d:"d \<simeq> d'" and "(rel ===> iff) P P'"
  hence P_iff :"\<And>b b'. b \<simeq> b' \<Longrightarrow> P b \<longleftrightarrow> P' b'" by (auto dest: rel_funD)
  show "(mdefdes P d) \<simeq> (\<iota>' d' P')"
    unfolding rel_def mdefdes_def typ_defdes_def
  proof (cases \<open>\<exists>!x. P' x\<close>, rule the_def_eq')
    case ex1:True
    hence "P' (\<iota>' d' P')"
      using the_defI' by simp
    moreover have rel:"(Rep \<iota>' d' P') \<simeq> \<iota>' d' P'" by auto
    ultimately show "Rep \<iota>' d' P' : M \<and> P (Rep \<iota>' d' P')"
      using P_iff[OF rel] M_rep by auto

    from ex1 obtain b' where "P' b'" and c':"\<And>c'. P' c' \<Longrightarrow> c' = b'" by auto
    hence "P (Rep b')" "\<And>c. c : M \<and> P c \<Longrightarrow> c = Rep b'"
    proof (metis P_iff[of \<open>Rep b'\<close> \<open>b'\<close>, OF ceq_rep_refl])
      fix c assume c:"c : M \<and> P c"
      hence "P' (Abs c)"
        using P_iff[OF ceq_abs_refl] by auto
      hence "Abs c = b'" using c' by simp
      thus "c = Rep b'" using c by auto
    qed
    thus "\<exists>!x'. x' : M \<and> P x'"
      using ex1I[of \<open>\<lambda>x'. x' : M \<and> P x'\<close> \<open>Rep b'\<close>] by auto
  next
    case nex1P: False
    hence nex1P':"\<not> (\<exists>!x. x : M \<and> P x)" using P_iff
      by (metis M_rep c.Rep_inverse ceq_abs_refl)
    have "(\<iota> x. x : M \<and> P x else d) = d"
     and "\<iota>' d' P' = d'"
    using the_def_default[OF nex1P] the_def_default[OF nex1P'] by auto
    then show "(\<iota> x. x : M \<and> P x else d) = Rep \<iota>' d' P'"
      using d by auto
  qed
qed

lemma typ_defdes_transfer [transfer_rule] :
  "((rel ===> (\<longleftrightarrow>)) ===> (rel ===> (\<longleftrightarrow>)) ===> rel ===> rel) mtdefdes typ_defdes"
  unfolding mtdefdes_def typ_defdes_def
  by (transfer_prover)

end
end