(*  Title:      HOL/Proofs/Extraction/Warshall.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section \<open>Warshall's algorithm\<close>

theory Warshall
imports Old_Datatype
begin

text \<open>
  Derivation of Warshall's algorithm using program extraction,
  based on Berger, Schwichtenberg and Seisenberger @{cite "Berger-JAR-2001"}.
\<close>

datatype b = T | F

primrec is_path' :: "('a \<Rightarrow> 'a \<Rightarrow> b) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool"
where
  "is_path' r x [] z \<longleftrightarrow> r x z = T"
| "is_path' r x (y # ys) z \<longleftrightarrow> r x y = T \<and> is_path' r y ys z"

definition is_path :: "(nat \<Rightarrow> nat \<Rightarrow> b) \<Rightarrow> (nat * nat list * nat) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  where "is_path r p i j k \<longleftrightarrow>
    fst p = j \<and> snd (snd p) = k \<and>
    list_all (\<lambda>x. x < i) (fst (snd p)) \<and>
    is_path' r (fst p) (fst (snd p)) (snd (snd p))"

definition conc :: "'a \<times> 'a list \<times> 'a \<Rightarrow> 'a \<times> 'a list \<times> 'a \<Rightarrow> 'a \<times> 'a list * 'a"
  where "conc p q = (fst p, fst (snd p) @ fst q # fst (snd q), snd (snd q))"

theorem is_path'_snoc [simp]: "\<And>x. is_path' r x (ys @ [y]) z = (is_path' r x ys y \<and> r y z = T)"
  by (induct ys) simp+

theorem list_all_scoc [simp]: "list_all P (xs @ [x]) \<longleftrightarrow> P x \<and> list_all P xs"
  by (induct xs) (simp+, iprover)

theorem list_all_lemma: "list_all P xs \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> list_all Q xs"
proof -
  assume PQ: "\<And>x. P x \<Longrightarrow> Q x"
  show "list_all P xs \<Longrightarrow> list_all Q xs"
  proof (induct xs)
    case Nil
    show ?case by simp
  next
    case (Cons y ys)
    then have Py: "P y" by simp
    from Cons have Pys: "list_all P ys" by simp
    show ?case
      by simp (rule conjI PQ Py Cons Pys)+
  qed
qed

theorem lemma1: "\<And>p. is_path r p i j k \<Longrightarrow> is_path r p (Suc i) j k"
  unfolding is_path_def
  apply (simp cong add: conj_cong add: split_paired_all)
  apply (erule conjE)+
  apply (erule list_all_lemma)
  apply simp
  done

theorem lemma2: "\<And>p. is_path r p 0 j k \<Longrightarrow> r j k = T"
  unfolding is_path_def
  apply (simp cong add: conj_cong add: split_paired_all)
  apply (case_tac "aa")
  apply simp+
  done

theorem is_path'_conc: "is_path' r j xs i \<Longrightarrow> is_path' r i ys k \<Longrightarrow>
  is_path' r j (xs @ i # ys) k"
proof -
  assume pys: "is_path' r i ys k"
  show "\<And>j. is_path' r j xs i \<Longrightarrow> is_path' r j (xs @ i # ys) k"
  proof (induct xs)
    case (Nil j)
    then have "r j i = T" by simp
    with pys show ?case by simp
  next
    case (Cons z zs j)
    then have jzr: "r j z = T" by simp
    from Cons have pzs: "is_path' r z zs i" by simp
    show ?case
      by simp (rule conjI jzr Cons pzs)+
  qed
qed

theorem lemma3:
  "\<And>p q. is_path r p i j i \<Longrightarrow> is_path r q i i k \<Longrightarrow>
    is_path r (conc p q) (Suc i) j k"
  apply (unfold is_path_def conc_def)
  apply (simp cong add: conj_cong add: split_paired_all)
  apply (erule conjE)+
  apply (rule conjI)
  apply (erule list_all_lemma)
  apply simp
  apply (rule conjI)
  apply (erule list_all_lemma)
  apply simp
  apply (rule is_path'_conc)
  apply assumption+
  done

theorem lemma5:
  "\<And>p. is_path r p (Suc i) j k \<Longrightarrow> \<not> is_path r p i j k \<Longrightarrow>
    (\<exists>q. is_path r q i j i) \<and> (\<exists>q'. is_path r q' i i k)"
proof (simp cong add: conj_cong add: split_paired_all is_path_def, (erule conjE)+)
  fix xs
  assume asms:
    "list_all (\<lambda>x. x < Suc i) xs"
    "is_path' r j xs k"
    "\<not> list_all (\<lambda>x. x < i) xs"
  show "(\<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r j ys i) \<and>
    (\<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r i ys k)"
  proof
    have "\<And>j. list_all (\<lambda>x. x < Suc i) xs \<Longrightarrow> is_path' r j xs k \<Longrightarrow>
      \<not> list_all (\<lambda>x. x < i) xs \<Longrightarrow>
    \<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r j ys i" (is "PROP ?ih xs")
    proof (induct xs)
      case Nil
      then show ?case by simp
    next
      case (Cons a as j)
      show ?case
      proof (cases "a=i")
        case True
        show ?thesis
        proof
          from True and Cons have "r j i = T" by simp
          then show "list_all (\<lambda>x. x < i) [] \<and> is_path' r j [] i" by simp
        qed
      next
        case False
        have "PROP ?ih as" by (rule Cons)
        then obtain ys where ys: "list_all (\<lambda>x. x < i) ys \<and> is_path' r a ys i"
        proof
          from Cons show "list_all (\<lambda>x. x < Suc i) as" by simp
          from Cons show "is_path' r a as k" by simp
          from Cons and False show "\<not> list_all (\<lambda>x. x < i) as" by (simp)
        qed
        show ?thesis
        proof
          from Cons False ys
          show "list_all (\<lambda>x. x<i) (a#ys) \<and> is_path' r j (a#ys) i" by simp
        qed
      qed
    qed
    from this asms show "\<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r j ys i" .
    have "\<And>k. list_all (\<lambda>x. x < Suc i) xs \<Longrightarrow> is_path' r j xs k \<Longrightarrow>
      \<not> list_all (\<lambda>x. x < i) xs \<Longrightarrow>
      \<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r i ys k" (is "PROP ?ih xs")
    proof (induct xs rule: rev_induct)
      case Nil
      then show ?case by simp
    next
      case (snoc a as k)
      show ?case
      proof (cases "a=i")
        case True
        show ?thesis
        proof
          from True and snoc have "r i k = T" by simp
          then show "list_all (\<lambda>x. x < i) [] \<and> is_path' r i [] k" by simp
        qed
      next
        case False
        have "PROP ?ih as" by (rule snoc)
        then obtain ys where ys: "list_all (\<lambda>x. x < i) ys \<and> is_path' r i ys a"
        proof
          from snoc show "list_all (\<lambda>x. x < Suc i) as" by simp
          from snoc show "is_path' r j as a" by simp
          from snoc and False show "\<not> list_all (\<lambda>x. x < i) as" by simp
        qed
        show ?thesis
        proof
          from snoc False ys
          show "list_all (\<lambda>x. x < i) (ys @ [a]) \<and> is_path' r i (ys @ [a]) k"
            by simp
        qed
      qed
    qed
    from this asms show "\<exists>ys. list_all (\<lambda>x. x < i) ys \<and> is_path' r i ys k" .
  qed
qed

theorem lemma5':
  "\<And>p. is_path r p (Suc i) j k \<Longrightarrow> \<not> is_path r p i j k \<Longrightarrow>
    \<not> (\<forall>q. \<not> is_path r q i j i) \<and> \<not> (\<forall>q'. \<not> is_path r q' i i k)"
  by (iprover dest: lemma5)

theorem warshall: "\<And>j k. \<not> (\<exists>p. is_path r p i j k) \<or> (\<exists>p. is_path r p i j k)"
proof (induct i)
  case (0 j k)
  show ?case
  proof (cases "r j k")
    assume "r j k = T"
    then have "is_path r (j, [], k) 0 j k"
      by (simp add: is_path_def)
    then have "\<exists>p. is_path r p 0 j k" ..
    then show ?thesis ..
  next
    assume "r j k = F"
    then have "r j k \<noteq> T" by simp
    then have "\<not> (\<exists>p. is_path r p 0 j k)"
      by (iprover dest: lemma2)
    then show ?thesis ..
  qed
next
  case (Suc i j k)
  then show ?case
  proof
    assume h1: "\<not> (\<exists>p. is_path r p i j k)"
    from Suc show ?case
    proof
      assume "\<not> (\<exists>p. is_path r p i j i)"
      with h1 have "\<not> (\<exists>p. is_path r p (Suc i) j k)"
        by (iprover dest: lemma5')
      then show ?case ..
    next
      assume "\<exists>p. is_path r p i j i"
      then obtain p where h2: "is_path r p i j i" ..
      from Suc show ?case
      proof
        assume "\<not> (\<exists>p. is_path r p i i k)"
        with h1 have "\<not> (\<exists>p. is_path r p (Suc i) j k)"
          by (iprover dest: lemma5')
        then show ?case ..
      next
        assume "\<exists>q. is_path r q i i k"
        then obtain q where "is_path r q i i k" ..
        with h2 have "is_path r (conc p q) (Suc i) j k"
          by (rule lemma3)
        then have "\<exists>pq. is_path r pq (Suc i) j k" ..
        then show ?case ..
      qed
    qed
  next
    assume "\<exists>p. is_path r p i j k"
    then have "\<exists>p. is_path r p (Suc i) j k"
      by (iprover intro: lemma1)
    then show ?case ..
  qed
qed

extract warshall

text \<open>
  The program extracted from the above proof looks as follows
  @{thm [display, eta_contract=false] warshall_def [no_vars]}
  The corresponding correctness theorem is
  @{thm [display] warshall_correctness [no_vars]}
\<close>

ML_val "@{code warshall}"

end


(*  Title:      HOL/Library/Fraction_Field.thy
    Author:     Amine Chaieb, University of Cambridge
*)

section{* A formalization of the fraction field of any integral domain;
         generalization of theory Rat from int to any integral domain *}

theory Fraction_Field
imports Main
begin

subsection {* General fractions construction *}

subsubsection {* Construction of the type of fractions *}

definition fractrel :: "(('a::idom * 'a ) * ('a * 'a)) set" where
  "fractrel = {(x, y). snd x \<noteq> 0 \<and> snd y \<noteq> 0 \<and> fst x * snd y = fst y * snd x}"

lemma fractrel_iff [simp]:
  "(x, y) \<in> fractrel \<longleftrightarrow> snd x \<noteq> 0 \<and> snd y \<noteq> 0 \<and> fst x * snd y = fst y * snd x"
  by (simp add: fractrel_def)

lemma refl_fractrel: "refl_on {x. snd x \<noteq> 0} fractrel"
  by (auto simp add: refl_on_def fractrel_def)

lemma sym_fractrel: "sym fractrel"
  by (simp add: fractrel_def sym_def)

lemma trans_fractrel: "trans fractrel"
proof (rule transI, unfold split_paired_all)
  fix a b a' b' a'' b'' :: 'a
  assume A: "((a, b), (a', b')) \<in> fractrel"
  assume B: "((a', b'), (a'', b'')) \<in> fractrel"
  have "b' * (a * b'') = b'' * (a * b')" by (simp add: ac_simps)
  also from A have "a * b' = a' * b" by auto
  also have "b'' * (a' * b) = b * (a' * b'')" by (simp add: ac_simps)
  also from B have "a' * b'' = a'' * b'" by auto
  also have "b * (a'' * b') = b' * (a'' * b)" by (simp add: ac_simps)
  finally have "b' * (a * b'') = b' * (a'' * b)" .
  moreover from B have "b' \<noteq> 0" by auto
  ultimately have "a * b'' = a'' * b" by simp
  with A B show "((a, b), (a'', b'')) \<in> fractrel" by auto
qed

lemma equiv_fractrel: "equiv {x. snd x \<noteq> 0} fractrel"
  by (rule equivI [OF refl_fractrel sym_fractrel trans_fractrel])

lemmas UN_fractrel = UN_equiv_class [OF equiv_fractrel]
lemmas UN_fractrel2 = UN_equiv_class2 [OF equiv_fractrel equiv_fractrel]

lemma equiv_fractrel_iff [iff]:
  assumes "snd x \<noteq> 0" and "snd y \<noteq> 0"
  shows "fractrel `` {x} = fractrel `` {y} \<longleftrightarrow> (x, y) \<in> fractrel"
  by (rule eq_equiv_class_iff, rule equiv_fractrel) (auto simp add: assms)

definition "fract = {(x::'a\<times>'a). snd x \<noteq> (0::'a::idom)} // fractrel"

typedef 'a fract = "fract :: ('a * 'a::idom) set set"
  unfolding fract_def
proof
  have "(0::'a, 1::'a) \<in> {x. snd x \<noteq> 0}" by simp
  then show "fractrel `` {(0::'a, 1)} \<in> {x. snd x \<noteq> 0} // fractrel"
    by (rule quotientI)
qed

lemma fractrel_in_fract [simp]: "snd x \<noteq> 0 \<Longrightarrow> fractrel `` {x} \<in> fract"
  by (simp add: fract_def quotientI)

declare Abs_fract_inject [simp] Abs_fract_inverse [simp]

subsubsection {* Representation and basic operations *}

definition Fract :: "'a::idom \<Rightarrow> 'a \<Rightarrow> 'a fract"
  where "Fract a b = Abs_fract (fractrel `` {if b = 0 then (0, 1) else (a, b)})"

code_datatype Fract

lemma Fract_cases [cases type: fract]:
  obtains (Fract) a b where "q = Fract a b" "b \<noteq> 0"
  by (cases q) (clarsimp simp add: Fract_def fract_def quotient_def)

lemma Fract_induct [case_names Fract, induct type: fract]:
  "(\<And>a b. b \<noteq> 0 \<Longrightarrow> P (Fract a b)) \<Longrightarrow> P q"
  by (cases q) simp

lemma eq_fract:
  shows "\<And>a b c d. b \<noteq> 0 \<Longrightarrow> d \<noteq> 0 \<Longrightarrow> Fract a b = Fract c d \<longleftrightarrow> a * d = c * b"
    and "\<And>a. Fract a 0 = Fract 0 1"
    and "\<And>a c. Fract 0 a = Fract 0 c"
  by (simp_all add: Fract_def)

instantiation fract :: (idom) "{comm_ring_1,power}"
begin

definition Zero_fract_def [code_unfold]: "0 = Fract 0 1"

definition One_fract_def [code_unfold]: "1 = Fract 1 1"

definition add_fract_def:
  "q + r = Abs_fract (\<Union>x \<in> Rep_fract q. \<Union>y \<in> Rep_fract r.
    fractrel `` {(fst x * snd y + fst y * snd x, snd x * snd y)})"

lemma add_fract [simp]:
  assumes "b \<noteq> (0::'a::idom)"
    and "d \<noteq> 0"
  shows "Fract a b + Fract c d = Fract (a * d + c * b) (b * d)"
proof -
  have "(\<lambda>x y. fractrel``{(fst x * snd y + fst y * snd x, snd x * snd y :: 'a)}) respects2 fractrel"
    by (rule equiv_fractrel [THEN congruent2_commuteI]) (simp_all add: algebra_simps)
  with assms show ?thesis by (simp add: Fract_def add_fract_def UN_fractrel2)
qed

definition minus_fract_def:
  "- q = Abs_fract (\<Union>x \<in> Rep_fract q. fractrel `` {(- fst x, snd x)})"

lemma minus_fract [simp, code]:
  fixes a b :: "'a::idom"
  shows "- Fract a b = Fract (- a) b"
proof -
  have "(\<lambda>x. fractrel `` {(- fst x, snd x :: 'a)}) respects fractrel"
    by (simp add: congruent_def split_paired_all)
  then show ?thesis by (simp add: Fract_def minus_fract_def UN_fractrel)
qed

lemma minus_fract_cancel [simp]: "Fract (- a) (- b) = Fract a b"
  by (cases "b = 0") (simp_all add: eq_fract)

definition diff_fract_def: "q - r = q + - (r::'a fract)"

lemma diff_fract [simp]:
  assumes "b \<noteq> 0"
    and "d \<noteq> 0"
  shows "Fract a b - Fract c d = Fract (a * d - c * b) (b * d)"
  using assms by (simp add: diff_fract_def)

definition mult_fract_def:
  "q * r = Abs_fract (\<Union>x \<in> Rep_fract q. \<Union>y \<in> Rep_fract r.
    fractrel``{(fst x * fst y, snd x * snd y)})"

lemma mult_fract [simp]: "Fract (a::'a::idom) b * Fract c d = Fract (a * c) (b * d)"
proof -
  have "(\<lambda>x y. fractrel `` {(fst x * fst y, snd x * snd y :: 'a)}) respects2 fractrel"
    by (rule equiv_fractrel [THEN congruent2_commuteI]) (simp_all add: algebra_simps)
  then show ?thesis by (simp add: Fract_def mult_fract_def UN_fractrel2)
qed

lemma mult_fract_cancel:
  assumes "c \<noteq> (0::'a)"
  shows "Fract (c * a) (c * b) = Fract a b"
proof -
  from assms have "Fract c c = Fract 1 1"
    by (simp add: Fract_def)
  then show ?thesis
    by (simp add: mult_fract [symmetric])
qed

instance
proof
  fix q r s :: "'a fract"
  show "(q * r) * s = q * (r * s)"
    by (cases q, cases r, cases s) (simp add: eq_fract algebra_simps)
  show "q * r = r * q"
    by (cases q, cases r) (simp add: eq_fract algebra_simps)
  show "1 * q = q"
    by (cases q) (simp add: One_fract_def eq_fract)
  show "(q + r) + s = q + (r + s)"
    by (cases q, cases r, cases s) (simp add: eq_fract algebra_simps)
  show "q + r = r + q"
    by (cases q, cases r) (simp add: eq_fract algebra_simps)
  show "0 + q = q"
    by (cases q) (simp add: Zero_fract_def eq_fract)
  show "- q + q = 0"
    by (cases q) (simp add: Zero_fract_def eq_fract)
  show "q - r = q + - r"
    by (cases q, cases r) (simp add: eq_fract)
  show "(q + r) * s = q * s + r * s"
    by (cases q, cases r, cases s) (simp add: eq_fract algebra_simps)
  show "(0::'a fract) \<noteq> 1"
    by (simp add: Zero_fract_def One_fract_def eq_fract)
qed

end

lemma of_nat_fract: "of_nat k = Fract (of_nat k) 1"
  by (induct k) (simp_all add: Zero_fract_def One_fract_def)

lemma Fract_of_nat_eq: "Fract (of_nat k) 1 = of_nat k"
  by (rule of_nat_fract [symmetric])

lemma fract_collapse [code_post]:
  "Fract 0 k = 0"
  "Fract 1 1 = 1"
  "Fract k 0 = 0"
  by (cases "k = 0")
    (simp_all add: Zero_fract_def One_fract_def eq_fract Fract_def)

lemma fract_expand [code_unfold]:
  "0 = Fract 0 1"
  "1 = Fract 1 1"
  by (simp_all add: fract_collapse)

lemma Fract_cases_nonzero:
  obtains (Fract) a b where "q = Fract a b" and "b \<noteq> 0" and "a \<noteq> 0"
    | (0) "q = 0"
proof (cases "q = 0")
  case True
  then show thesis using 0 by auto
next
  case False
  then obtain a b where "q = Fract a b" and "b \<noteq> 0" by (cases q) auto
  with False have "0 \<noteq> Fract a b" by simp
  with `b \<noteq> 0` have "a \<noteq> 0" by (simp add: Zero_fract_def eq_fract)
  with Fract `q = Fract a b` `b \<noteq> 0` show thesis by auto
qed

subsubsection {* The field of rational numbers *}

context idom
begin

subclass ring_no_zero_divisors ..

end

instantiation fract :: (idom) field_inverse_zero
begin

definition inverse_fract_def:
  "inverse q = Abs_fract (\<Union>x \<in> Rep_fract q.
     fractrel `` {if fst x = 0 then (0, 1) else (snd x, fst x)})"

lemma inverse_fract [simp]: "inverse (Fract a b) = Fract (b::'a::idom) a"
proof -
  have *: "\<And>x. (0::'a) = x \<longleftrightarrow> x = 0"
    by auto
  have "(\<lambda>x. fractrel `` {if fst x = 0 then (0, 1) else (snd x, fst x :: 'a)}) respects fractrel"
    by (auto simp add: congruent_def * algebra_simps)
  then show ?thesis
    by (simp add: Fract_def inverse_fract_def UN_fractrel)
qed

definition divide_fract_def: "q / r = q * inverse (r:: 'a fract)"

lemma divide_fract [simp]: "Fract a b / Fract c d = Fract (a * d) (b * c)"
  by (simp add: divide_fract_def)

instance
proof
  fix q :: "'a fract"
  assume "q \<noteq> 0"
  then show "inverse q * q = 1"
    by (cases q rule: Fract_cases_nonzero)
      (simp_all add: fract_expand eq_fract mult.commute)
next
  fix q r :: "'a fract"
  show "q / r = q * inverse r" by (simp add: divide_fract_def)
next
  show "inverse 0 = (0:: 'a fract)"
    by (simp add: fract_expand) (simp add: fract_collapse)
qed

end

subsubsection {* The ordered field of fractions over an ordered idom *}

lemma le_congruent2:
  "(\<lambda>x y::'a \<times> 'a::linordered_idom.
    {(fst x * snd y)*(snd x * snd y) \<le> (fst y * snd x)*(snd x * snd y)})
    respects2 fractrel"
proof (clarsimp simp add: congruent2_def)
  fix a b a' b' c d c' d' :: 'a
  assume neq: "b \<noteq> 0"  "b' \<noteq> 0"  "d \<noteq> 0"  "d' \<noteq> 0"
  assume eq1: "a * b' = a' * b"
  assume eq2: "c * d' = c' * d"

  let ?le = "\<lambda>a b c d. ((a * d) * (b * d) \<le> (c * b) * (b * d))"
  {
    fix a b c d x :: 'a
    assume x: "x \<noteq> 0"
    have "?le a b c d = ?le (a * x) (b * x) c d"
    proof -
      from x have "0 < x * x"
        by (auto simp add: zero_less_mult_iff)
      then have "?le a b c d =
          ((a * d) * (b * d) * (x * x) \<le> (c * b) * (b * d) * (x * x))"
        by (simp add: mult_le_cancel_right)
      also have "... = ?le (a * x) (b * x) c d"
        by (simp add: ac_simps)
      finally show ?thesis .
    qed
  } note le_factor = this

  let ?D = "b * d" and ?D' = "b' * d'"
  from neq have D: "?D \<noteq> 0" by simp
  from neq have "?D' \<noteq> 0" by simp
  then have "?le a b c d = ?le (a * ?D') (b * ?D') c d"
    by (rule le_factor)
  also have "... = ((a * b') * ?D * ?D' * d * d' \<le> (c * d') * ?D * ?D' * b * b')"
    by (simp add: ac_simps)
  also have "... = ((a' * b) * ?D * ?D' * d * d' \<le> (c' * d) * ?D * ?D' * b * b')"
    by (simp only: eq1 eq2)
  also have "... = ?le (a' * ?D) (b' * ?D) c' d'"
    by (simp add: ac_simps)
  also from D have "... = ?le a' b' c' d'"
    by (rule le_factor [symmetric])
  finally show "?le a b c d = ?le a' b' c' d'" .
qed

instantiation fract :: (linordered_idom) linorder
begin

definition le_fract_def:
  "q \<le> r \<longleftrightarrow> the_elem (\<Union>x \<in> Rep_fract q. \<Union>y \<in> Rep_fract r.
    {(fst x * snd y) * (snd x * snd y) \<le> (fst y * snd x) * (snd x * snd y)})"

definition less_fract_def: "z < (w::'a fract) \<longleftrightarrow> z \<le> w \<and> \<not> w \<le> z"

lemma le_fract [simp]:
  assumes "b \<noteq> 0"
    and "d \<noteq> 0"
  shows "Fract a b \<le> Fract c d \<longleftrightarrow> (a * d) * (b * d) \<le> (c * b) * (b * d)"
  by (simp add: Fract_def le_fract_def le_congruent2 UN_fractrel2 assms)

lemma less_fract [simp]:
  assumes "b \<noteq> 0"
    and "d \<noteq> 0"
  shows "Fract a b < Fract c d \<longleftrightarrow> (a * d) * (b * d) < (c * b) * (b * d)"
  by (simp add: less_fract_def less_le_not_le ac_simps assms)

instance
proof
  fix q r s :: "'a fract"
  assume "q \<le> r" and "r \<le> s"
  then show "q \<le> s"
  proof (induct q, induct r, induct s)
    fix a b c d e f :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
    assume 1: "Fract a b \<le> Fract c d"
    assume 2: "Fract c d \<le> Fract e f"
    show "Fract a b \<le> Fract e f"
    proof -
      from neq obtain bb: "0 < b * b" and dd: "0 < d * d" and ff: "0 < f * f"
        by (auto simp add: zero_less_mult_iff linorder_neq_iff)
      have "(a * d) * (b * d) * (f * f) \<le> (c * b) * (b * d) * (f * f)"
      proof -
        from neq 1 have "(a * d) * (b * d) \<le> (c * b) * (b * d)"
          by simp
        with ff show ?thesis by (simp add: mult_le_cancel_right)
      qed
      also have "... = (c * f) * (d * f) * (b * b)"
        by (simp only: ac_simps)
      also have "... \<le> (e * d) * (d * f) * (b * b)"
      proof -
        from neq 2 have "(c * f) * (d * f) \<le> (e * d) * (d * f)"
          by simp
        with bb show ?thesis by (simp add: mult_le_cancel_right)
      qed
      finally have "(a * f) * (b * f) * (d * d) \<le> e * b * (b * f) * (d * d)"
        by (simp only: ac_simps)
      with dd have "(a * f) * (b * f) \<le> (e * b) * (b * f)"
        by (simp add: mult_le_cancel_right)
      with neq show ?thesis by simp
    qed
  qed
next
  fix q r :: "'a fract"
  assume "q \<le> r" and "r \<le> q"
  then show "q = r"
  proof (induct q, induct r)
    fix a b c d :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0"
    assume 1: "Fract a b \<le> Fract c d"
    assume 2: "Fract c d \<le> Fract a b"
    show "Fract a b = Fract c d"
    proof -
      from neq 1 have "(a * d) * (b * d) \<le> (c * b) * (b * d)"
        by simp
      also have "... \<le> (a * d) * (b * d)"
      proof -
        from neq 2 have "(c * b) * (d * b) \<le> (a * d) * (d * b)"
          by simp
        then show ?thesis by (simp only: ac_simps)
      qed
      finally have "(a * d) * (b * d) = (c * b) * (b * d)" .
      moreover from neq have "b * d \<noteq> 0" by simp
      ultimately have "a * d = c * b" by simp
      with neq show ?thesis by (simp add: eq_fract)
    qed
  qed
next
  fix q r :: "'a fract"
  show "q \<le> q"
    by (induct q) simp
  show "(q < r) = (q \<le> r \<and> \<not> r \<le> q)"
    by (simp only: less_fract_def)
  show "q \<le> r \<or> r \<le> q"
    by (induct q, induct r)
       (simp add: mult.commute, rule linorder_linear)
qed

end

instantiation fract :: (linordered_idom) "{distrib_lattice,abs_if,sgn_if}"
begin

definition abs_fract_def: "\<bar>q\<bar> = (if q < 0 then -q else (q::'a fract))"

definition sgn_fract_def:
  "sgn (q::'a fract) = (if q = 0 then 0 else if 0 < q then 1 else - 1)"

theorem abs_fract [simp]: "\<bar>Fract a b\<bar> = Fract \<bar>a\<bar> \<bar>b\<bar>"
  by (auto simp add: abs_fract_def Zero_fract_def le_less
      eq_fract zero_less_mult_iff mult_less_0_iff split: abs_split)

definition inf_fract_def:
  "(inf \<Colon> 'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract) = min"

definition sup_fract_def:
  "(sup \<Colon> 'a fract \<Rightarrow> 'a fract \<Rightarrow> 'a fract) = max"

instance
  by intro_classes
    (auto simp add: abs_fract_def sgn_fract_def
      max_min_distrib2 inf_fract_def sup_fract_def)

end

instance fract :: (linordered_idom) linordered_field_inverse_zero
proof
  fix q r s :: "'a fract"
  assume "q \<le> r"
  then show "s + q \<le> s + r"
  proof (induct q, induct r, induct s)
    fix a b c d e f :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
    assume le: "Fract a b \<le> Fract c d"
    show "Fract e f + Fract a b \<le> Fract e f + Fract c d"
    proof -
      let ?F = "f * f" from neq have F: "0 < ?F"
        by (auto simp add: zero_less_mult_iff)
      from neq le have "(a * d) * (b * d) \<le> (c * b) * (b * d)"
        by simp
      with F have "(a * d) * (b * d) * ?F * ?F \<le> (c * b) * (b * d) * ?F * ?F"
        by (simp add: mult_le_cancel_right)
      with neq show ?thesis by (simp add: field_simps)
    qed
  qed
next
  fix q r s :: "'a fract"
  assume "q < r" and "0 < s"
  then show "s * q < s * r"
  proof (induct q, induct r, induct s)
    fix a b c d e f :: 'a
    assume neq: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
    assume le: "Fract a b < Fract c d"
    assume gt: "0 < Fract e f"
    show "Fract e f * Fract a b < Fract e f * Fract c d"
    proof -
      let ?E = "e * f" and ?F = "f * f"
      from neq gt have "0 < ?E"
        by (auto simp add: Zero_fract_def order_less_le eq_fract)
      moreover from neq have "0 < ?F"
        by (auto simp add: zero_less_mult_iff)
      moreover from neq le have "(a * d) * (b * d) < (c * b) * (b * d)"
        by simp
      ultimately have "(a * d) * (b * d) * ?E * ?F < (c * b) * (b * d) * ?E * ?F"
        by (simp add: mult_less_cancel_right)
      with neq show ?thesis
        by (simp add: ac_simps)
    qed
  qed
qed

lemma fract_induct_pos [case_names Fract]:
  fixes P :: "'a::linordered_idom fract \<Rightarrow> bool"
  assumes step: "\<And>a b. 0 < b \<Longrightarrow> P (Fract a b)"
  shows "P q"
proof (cases q)
  case (Fract a b)
  {
    fix a b :: 'a
    assume b: "b < 0"
    have "P (Fract a b)"
    proof -
      from b have "0 < - b" by simp
      then have "P (Fract (- a) (- b))"
        by (rule step)
      then show "P (Fract a b)"
        by (simp add: order_less_imp_not_eq [OF b])
    qed
  }
  with Fract show "P q"
    by (auto simp add: linorder_neq_iff step)
qed

lemma zero_less_Fract_iff: "0 < b \<Longrightarrow> 0 < Fract a b \<longleftrightarrow> 0 < a"
  by (auto simp add: Zero_fract_def zero_less_mult_iff)

lemma Fract_less_zero_iff: "0 < b \<Longrightarrow> Fract a b < 0 \<longleftrightarrow> a < 0"
  by (auto simp add: Zero_fract_def mult_less_0_iff)

lemma zero_le_Fract_iff: "0 < b \<Longrightarrow> 0 \<le> Fract a b \<longleftrightarrow> 0 \<le> a"
  by (auto simp add: Zero_fract_def zero_le_mult_iff)

lemma Fract_le_zero_iff: "0 < b \<Longrightarrow> Fract a b \<le> 0 \<longleftrightarrow> a \<le> 0"
  by (auto simp add: Zero_fract_def mult_le_0_iff)

lemma one_less_Fract_iff: "0 < b \<Longrightarrow> 1 < Fract a b \<longleftrightarrow> b < a"
  by (auto simp add: One_fract_def mult_less_cancel_right_disj)

lemma Fract_less_one_iff: "0 < b \<Longrightarrow> Fract a b < 1 \<longleftrightarrow> a < b"
  by (auto simp add: One_fract_def mult_less_cancel_right_disj)

lemma one_le_Fract_iff: "0 < b \<Longrightarrow> 1 \<le> Fract a b \<longleftrightarrow> b \<le> a"
  by (auto simp add: One_fract_def mult_le_cancel_right)

lemma Fract_le_one_iff: "0 < b \<Longrightarrow> Fract a b \<le> 1 \<longleftrightarrow> a \<le> b"
  by (auto simp add: One_fract_def mult_le_cancel_right)

end


(*
 * May's Theorem, following Sen.
 * (C)opyright Peter Gammie, peteg42 at gmail.com, commenced October 2008.
 * License: BSD
 *)

(*<*)
theory May

imports SCFs

begin
(*>*)

section\<open>May's Theorem\<close>

text \<open>May's Theorem \<^cite>\<open>"May:1952"\<close> provides a characterisation of
majority voting in terms of four conditions that appear quite natural for
\emph{a priori} unbiased social choice scenarios. It can be seen as a
refinement of some earlier work by Arrow \<^cite>\<open>\<open>Chapter V.1\<close> in "Arrow:1963"\<close>.

The following is a mechanisation of Sen's generalisation
\<^cite>\<open>\<open>Chapter~5*\<close> in "Sen:70a"\<close>; originally Arrow and May consider only two
alternatives, whereas Sen's model maps profiles of full RPRs to a possibly
intransitive relation that does at least generate a choice set that
satisfies May's conditions.\<close>

subsection\<open>May's Conditions\<close>

text \<open>The condition of \emph{anonymity} asserts that the individuals'
identities are not considered by the choice rule. Rather than talk about
permutations we just assert the result of the SCF is the same when the
profile is composed with an arbitrary bijection on the set of
individuals.\<close>

definition anonymous :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> bool" where
  "anonymous scf A Is \<equiv>
    (\<forall>P f x y. profile A Is P \<and> bij_betw f Is Is \<and> x \<in> A \<and> y \<in> A
      \<longrightarrow> (x \<^bsub>(scf P)\<^esub>\<preceq> y) = (x \<^bsub>(scf (P \<circ> f))\<^esub>\<preceq> y))"

lemma anonymousI[intro]:
  "(\<And>P f x y. \<lbrakk> profile A Is P; bij_betw f Is Is;
                  x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> (x \<^bsub>(scf P)\<^esub>\<preceq> y) = (x \<^bsub>(scf (P \<circ> f))\<^esub>\<preceq> y))
  \<Longrightarrow> anonymous scf A Is"
  unfolding anonymous_def by simp

lemma anonymousD:
  "\<lbrakk> anonymous scf A Is; profile A Is P; bij_betw f Is Is; x \<in> A; y \<in> A \<rbrakk>
  \<Longrightarrow> (x \<^bsub>(scf P)\<^esub>\<preceq> y) = (x \<^bsub>(scf (P \<circ> f))\<^esub>\<preceq> y)"
  unfolding anonymous_def by simp

text \<open>Similarly, an SCF is \emph{neutral} if it is insensitive to the
identity of the alternatives. This is Sen's characterisation
\<^cite>\<open>\<open>p72\<close> in "Sen:70a"\<close>.\<close>

definition neutral :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> bool" where
  "neutral scf A Is \<equiv>
    (\<forall>P P' x y z w. profile A Is P \<and> profile A Is P' \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A \<and> w \<in> A
      \<and> (\<forall>i \<in> Is. x \<^bsub>(P i)\<^esub>\<preceq> y \<longleftrightarrow> z \<^bsub>(P' i)\<^esub>\<preceq> w) \<and> (\<forall>i \<in> Is. y \<^bsub>(P i)\<^esub>\<preceq> x \<longleftrightarrow> w \<^bsub>(P' i)\<^esub>\<preceq> z)
   \<longrightarrow> ((x \<^bsub>(scf P)\<^esub>\<preceq> y \<longleftrightarrow> z \<^bsub>(scf P')\<^esub>\<preceq> w) \<and> (y \<^bsub>(scf P)\<^esub>\<preceq> x \<longleftrightarrow> w \<^bsub>(scf P')\<^esub>\<preceq> z)))"

lemma neutralI[intro]:
  "(\<And>P P' x y z w.
    \<lbrakk> profile A Is P; profile A Is P'; {x,y,z,w} \<subseteq> A;
      \<And>i. i \<in> Is \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<preceq> y \<longleftrightarrow> z \<^bsub>(P' i)\<^esub>\<preceq> w;
      \<And>i. i \<in> Is \<Longrightarrow> y \<^bsub>(P i)\<^esub>\<preceq> x \<longleftrightarrow> w \<^bsub>(P' i)\<^esub>\<preceq> z \<rbrakk>
     \<Longrightarrow> ((x \<^bsub>(scf P)\<^esub>\<preceq> y \<longleftrightarrow> z \<^bsub>(scf P')\<^esub>\<preceq> w) \<and> (y \<^bsub>(scf P)\<^esub>\<preceq> x \<longleftrightarrow> w \<^bsub>(scf P')\<^esub>\<preceq> z)))
  \<Longrightarrow> neutral scf A Is"
  unfolding neutral_def by simp

lemma neutralD:
  "\<lbrakk> neutral scf A Is;
     profile A Is P; profile A Is P'; {x,y,z,w} \<subseteq> A;
     \<And>i. i \<in> Is \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<preceq> y \<longleftrightarrow> z \<^bsub>(P' i)\<^esub>\<preceq> w;
     \<And>i. i \<in> Is \<Longrightarrow> y \<^bsub>(P i)\<^esub>\<preceq> x \<longleftrightarrow> w \<^bsub>(P' i)\<^esub>\<preceq> z \<rbrakk>
  \<Longrightarrow> (x \<^bsub>(scf P)\<^esub>\<preceq> y \<longleftrightarrow> z \<^bsub>(scf P')\<^esub>\<preceq> w) \<and> (y \<^bsub>(scf P)\<^esub>\<preceq> x \<longleftrightarrow> w \<^bsub>(scf P')\<^esub>\<preceq> z)"
  unfolding neutral_def by simp

text \<open>Neutrality implies independence of irrelevant alternatives.\<close>

lemma neutral_iia: "neutral scf A Is \<Longrightarrow> iia scf A Is"
  unfolding neutral_def by (rule, auto)

text \<open>\emph{Positive responsiveness} is a bit like non-manipulability: if
one individual improves their opinion of $x$, then the result should shift
in favour of $x$.\<close>

definition positively_responsive :: "('a, 'i) SCF \<Rightarrow> 'a set \<Rightarrow> 'i set \<Rightarrow> bool" where
  "positively_responsive scf A Is \<equiv>
    (\<forall>P P' x y. profile A Is P \<and> profile A Is P' \<and> x \<in> A \<and> y \<in> A
      \<and> (\<forall>i \<in> Is. (x \<^bsub>(P i)\<^esub>\<prec> y \<longrightarrow> x \<^bsub>(P' i)\<^esub>\<prec> y) \<and> (x \<^bsub>(P i)\<^esub>\<approx> y \<longrightarrow> x \<^bsub>(P' i)\<^esub>\<preceq> y))
      \<and> (\<exists>k \<in> Is. (x \<^bsub>(P k)\<^esub>\<approx> y \<and> x \<^bsub>(P' k)\<^esub>\<prec> y) \<or> (y \<^bsub>(P k)\<^esub>\<prec> x \<and> x \<^bsub>(P' k)\<^esub>\<preceq> y))
      \<longrightarrow> x \<^bsub>(scf P)\<^esub>\<preceq> y \<longrightarrow> x \<^bsub>(scf P')\<^esub>\<prec> y)"

lemma positively_responsiveI[intro]:
  assumes I: "\<And>P P' x y.
    \<lbrakk> profile A Is P; profile A Is P'; x \<in> A; y \<in> A;
      \<And>i. \<lbrakk> i \<in> Is; x \<^bsub>(P i)\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> x \<^bsub>(P' i)\<^esub>\<prec> y;
      \<And>i. \<lbrakk> i \<in> Is; x \<^bsub>(P i)\<^esub>\<approx> y \<rbrakk> \<Longrightarrow> x \<^bsub>(P' i)\<^esub>\<preceq> y;
      \<exists>k \<in> Is. (x \<^bsub>(P k)\<^esub>\<approx> y \<and> x \<^bsub>(P' k)\<^esub>\<prec> y) \<or> (y \<^bsub>(P k)\<^esub>\<prec> x \<and> x \<^bsub>(P' k)\<^esub>\<preceq> y);
      x \<^bsub>(scf P)\<^esub>\<preceq> y \<rbrakk>
     \<Longrightarrow> x \<^bsub>(scf P')\<^esub>\<prec> y"
  shows "positively_responsive scf A Is"
  unfolding positively_responsive_def
  by (blast intro: I)

lemma positively_responsiveD:
  "\<lbrakk> positively_responsive scf A Is;
     profile A Is P; profile A Is P'; x \<in> A; y \<in> A;
     \<And>i. \<lbrakk> i \<in> Is; x \<^bsub>(P i)\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> x \<^bsub>(P' i)\<^esub>\<prec> y;
     \<And>i. \<lbrakk> i \<in> Is; x \<^bsub>(P i)\<^esub>\<approx> y \<rbrakk> \<Longrightarrow> x \<^bsub>(P' i)\<^esub>\<preceq> y;
     \<exists>k \<in> Is. (x \<^bsub>(P k)\<^esub>\<approx> y \<and> x \<^bsub>(P' k)\<^esub>\<prec> y) \<or> (y \<^bsub>(P k)\<^esub>\<prec> x \<and> x \<^bsub>(P' k)\<^esub>\<preceq> y);
     x \<^bsub>(scf P)\<^esub>\<preceq> y \<rbrakk>
       \<Longrightarrow> x \<^bsub>(scf P')\<^esub>\<prec> y"
  unfolding positively_responsive_def
  apply clarsimp
  apply (erule allE[where x=P])
  apply (erule allE[where x=P'])
  apply (erule allE[where x=x])
  apply (erule allE[where x=y])
  by auto

subsection\<open>The Method of Majority Decision satisfies May's conditions\<close>

text \<open>The \emph{method of majority decision} (MMD) says that if the number
of individuals who strictly prefer $x$ to $y$ is larger than or equal to
those who strictly prefer the converse, then $x\ R\ y$. Note that this
definition only makes sense for a finite population.\<close>

definition MMD :: "'i set \<Rightarrow> ('a, 'i) SCF" where
  "MMD Is P \<equiv> { (x, y) . card { i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y } \<ge> card { i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x } }"

text \<open>The first part of May's Theorem establishes that the conditions are
consistent, by showing that they are satisfied by MMD.\<close>

lemma MMD_l2r:
  fixes A :: "'a set"
    and Is :: "'i set"
  assumes finiteIs: "finite Is"
  shows "SCF (MMD Is) A Is universal_domain"
    and "anonymous (MMD Is) A Is"
    and "neutral (MMD Is) A Is"
    and "positively_responsive (MMD Is) A Is"
proof -
  show "SCF (MMD Is) A Is universal_domain"
  proof
    fix P show "complete A (MMD Is P)"
      by (rule completeI, unfold MMD_def, simp, arith)
  qed
  show "anonymous (MMD Is) A Is"
  proof
    fix P
    fix x y :: "'a"
    fix f assume bijf: "bij_betw f Is Is"
    show "(x \<^bsub>(MMD Is P)\<^esub>\<preceq> y) = (x \<^bsub>(MMD Is (P \<circ> f))\<^esub>\<preceq> y)"
      using card_compose_bij[OF bijf, where P="\<lambda>i. x \<^bsub>(P i)\<^esub>\<prec> y"]
            card_compose_bij[OF bijf, where P="\<lambda>i. y \<^bsub>(P i)\<^esub>\<prec> x"]
      unfolding MMD_def by simp
  qed
next
  show "neutral (MMD Is) A Is"
  proof
    fix P P'
    fix x y z w assume xyzwA: "{x,y,z,w} \<subseteq> A"
    assume xyzw: "\<And>i. i \<in> Is \<Longrightarrow> (x \<^bsub>(P i)\<^esub>\<preceq> y) = (z \<^bsub>(P' i)\<^esub>\<preceq> w)"
       and yxwz: "\<And>i. i \<in> Is \<Longrightarrow> (y \<^bsub>(P i)\<^esub>\<preceq> x) = (w \<^bsub>(P' i)\<^esub>\<preceq> z)"
    from xyzwA xyzw yxwz
    have "{ i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y } = { i \<in> Is. z \<^bsub>(P' i)\<^esub>\<prec> w }"
     and "{ i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x } = { i \<in> Is. w \<^bsub>(P' i)\<^esub>\<prec> z }"
      unfolding strict_pref_def by auto
    thus "(x \<^bsub>(MMD Is P)\<^esub>\<preceq> y) = (z \<^bsub>(MMD Is P')\<^esub>\<preceq> w) \<and>
          (y \<^bsub>(MMD Is P)\<^esub>\<preceq> x) = (w \<^bsub>(MMD Is P')\<^esub>\<preceq> z)"
      unfolding MMD_def by simp
  qed
next
  show "positively_responsive (MMD Is) A Is"
  proof
    fix P P' assume profileP: "profile A Is P"
    fix x y assume xyA: "x \<in> A" "y \<in> A"
    assume xPy: "\<And>i. \<lbrakk>i \<in> Is; x \<^bsub>(P i)\<^esub>\<prec> y\<rbrakk> \<Longrightarrow> x \<^bsub>(P' i)\<^esub>\<prec> y"
       and xIy: "\<And>i. \<lbrakk>i \<in> Is; x \<^bsub>(P i)\<^esub>\<approx> y\<rbrakk> \<Longrightarrow> x \<^bsub>(P' i)\<^esub>\<preceq> y"
       and k: "\<exists>k\<in>Is. x \<^bsub>(P k)\<^esub>\<approx> y \<and> x \<^bsub>(P' k)\<^esub>\<prec> y \<or> y \<^bsub>(P k)\<^esub>\<prec> x \<and> x \<^bsub>(P' k)\<^esub>\<preceq> y"
       and xRSCFy: "x \<^bsub>(MMD Is P)\<^esub>\<preceq> y"
    from k obtain k
      where kIs: "k \<in> Is"
        and kcond: "(x \<^bsub>(P k)\<^esub>\<approx> y \<and> x \<^bsub>(P' k)\<^esub>\<prec> y) \<or> (y \<^bsub>(P k)\<^esub>\<prec> x \<and> x \<^bsub>(P' k)\<^esub>\<preceq> y)"
      by blast
    let ?xPy = "{ i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y }"
    let ?xP'y = "{ i \<in> Is. x \<^bsub>(P' i)\<^esub>\<prec> y }"
    let ?yPx = "{ i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x }"
    let ?yP'x = "{ i \<in> Is. y \<^bsub>(P' i)\<^esub>\<prec> x }"
    from profileP xyA xPy xIy have yP'xyPx: "?yP'x \<subseteq> ?yPx"
      unfolding strict_pref_def indifferent_pref_def
      by (blast dest: rpr_complete)
    with finiteIs have yP'xyPxC: "card ?yP'x \<le> card ?yPx"
      by (blast intro: card_mono finite_subset)
    from finiteIs xPy have xPyxP'yC: "card ?xPy \<le> card ?xP'y"
      by (blast intro: card_mono finite_subset)
    show "x \<^bsub>(MMD Is P')\<^esub>\<prec> y"
    proof
      from xRSCFy xPyxP'yC yP'xyPxC show "x \<^bsub>(MMD Is P')\<^esub>\<preceq> y"
        unfolding MMD_def by auto
    next
      {
        assume xIky: "x \<^bsub>(P k)\<^esub>\<approx> y" and xP'ky: "x \<^bsub>(P' k)\<^esub>\<prec> y"
        have "card ?xPy < card ?xP'y"
        proof -
          from xIky have knP: "k \<notin> ?xPy"
            unfolding indifferent_pref_def strict_pref_def by blast
          from kIs xP'ky have kP': "k \<in> ?xP'y" by simp
          from finiteIs xPy knP kP' show ?thesis
            by (blast intro: psubset_card_mono finite_subset)
        qed
        with xRSCFy yP'xyPxC have "card ?yP'x < card ?xP'y"
          unfolding MMD_def by auto
      }
      moreover
      {
        assume yPkx: "y \<^bsub>(P k)\<^esub>\<prec> x" and xR'ky: "x \<^bsub>(P' k)\<^esub>\<preceq> y"
        have "card ?yP'x < card ?yPx"
        proof -
          from kIs yPkx have kP: "k \<in> ?yPx" by simp
          from kIs xR'ky have knP': "k \<notin> ?yP'x"
            unfolding strict_pref_def by blast
          from yP'xyPx kP knP' have "?yP'x \<subset> ?yPx" by blast
          with finiteIs show ?thesis
            by (blast intro: psubset_card_mono finite_subset)
        qed
        with xRSCFy xPyxP'yC have "card ?yP'x < card ?xP'y"
          unfolding MMD_def by auto
      }
      moreover note kcond
      ultimately show "\<not>(y \<^bsub>(MMD Is P')\<^esub>\<preceq> x)"
        unfolding MMD_def by auto
    qed
  qed
qed

subsection\<open>Everything satisfying May's conditions is the Method of Majority Decision\<close>

text\<open>Now show that MMD is the only SCF that satisfies these conditions.\<close>

text \<open>Firstly develop some theory about exchanging alternatives $x$ and
$y$ in profile $P$.\<close>

definition swapAlts :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "swapAlts a b u \<equiv> if u = a then b else if u = b then a else u"

lemma swapAlts_in_set_iff: "{a, b} \<subseteq> A \<Longrightarrow> swapAlts a b u \<in> A \<longleftrightarrow> u \<in> A"
  unfolding swapAlts_def by (simp split: if_split)

definition swapAltsP :: "('a, 'i) Profile \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a, 'i) Profile" where
  "swapAltsP P a b \<equiv> (\<lambda>i. { (u, v) . (swapAlts a b u, swapAlts a b v) \<in> P i })"

lemma swapAltsP_ab: "a \<^bsub>(P i)\<^esub>\<preceq> b \<longleftrightarrow> b \<^bsub>(swapAltsP P a b i)\<^esub>\<preceq> a" "b \<^bsub>(P i)\<^esub>\<preceq> a \<longleftrightarrow> a \<^bsub>(swapAltsP P a b i)\<^esub>\<preceq> b"
  unfolding swapAltsP_def swapAlts_def by simp_all

lemma profile_swapAltsP:
  assumes profileP: "profile A Is P"
      and abA: "{a,b} \<subseteq> A"
  shows "profile A Is (swapAltsP P a b)"
proof(rule profileI)
  from profileP show "Is \<noteq> {}" by (rule profile_non_empty)
next
  fix i assume iIs: "i \<in> Is"
  show "rpr A (swapAltsP P a b i)"
  proof(rule rprI)
    show "refl_on A (swapAltsP P a b i)"
    proof(rule refl_onI)
      from profileP iIs abA show "swapAltsP P a b i \<subseteq> A \<times> A"
        unfolding swapAltsP_def by (blast dest: swapAlts_in_set_iff)
      from profileP iIs abA show "\<And>x. x \<in> A \<Longrightarrow> x \<^bsub>(swapAltsP P a b i)\<^esub>\<preceq> x"
        unfolding swapAltsP_def swapAlts_def by auto
    qed
  next
    from profileP iIs abA show "complete A (swapAltsP P a b i)"
      unfolding swapAltsP_def
      by - (rule completeI, simp, rule rpr_complete[where A=A],
            auto iff: swapAlts_in_set_iff)
  next
    from profileP iIs show "trans (swapAltsP P a b i)"
      unfolding swapAltsP_def by (blast dest: rpr_le_trans intro: transI)
  qed
qed

lemma profile_bij_profile:
  assumes profileP: "profile A Is P"
      and bijf: "bij_betw f Is Is"
  shows "profile A Is (P \<circ> f)"
  using bij_betw_onto[OF bijf] profileP
  by - (rule, auto dest: profile_non_empty)

text\<open>The locale keeps the conditions in scope for the next few
lemmas. Note how weak the constraints on the sets of alternatives and
individuals are; clearly there needs to be at least two alternatives and two
individuals for conflict to occur, but it is pleasant that the proof
uniformly handles the degenerate cases.\<close>

locale May =
  fixes A :: "'a set"

  fixes Is :: "'i set"
  assumes finiteIs: "finite Is"

  fixes scf :: "('a, 'i) SCF"
  assumes SCF: "SCF scf A Is universal_domain"
      and anonymous: "anonymous scf A Is"
      and neutral: "neutral scf A Is"
      and positively_responsive: "positively_responsive scf A Is"
begin

text\<open>Anonymity implies that, for any pair of alternatives, the social
choice rule can only depend on the number of individuals who express any
given preference between them. Note we also need @{term "iia"}, implied by
neutrality, to restrict attention to alternatives $x$ and $y$.\<close>

lemma anonymous_card:
  assumes profileP: "profile A Is P"
      and profileP': "profile A Is P'"
      and xyA: "hasw [x,y] A"
      and xytally: "card { i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y } = card { i \<in> Is. x \<^bsub>(P' i)\<^esub>\<prec> y }"
      and yxtally: "card { i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x } = card { i \<in> Is. y \<^bsub>(P' i)\<^esub>\<prec> x }"
  shows "x \<^bsub>(scf P)\<^esub>\<preceq> y \<longleftrightarrow> x \<^bsub>(scf P')\<^esub>\<preceq> y"
proof -
  let ?xPy = "{ i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y }"
  let ?xP'y = "{ i \<in> Is. x \<^bsub>(P' i)\<^esub>\<prec> y }"
  let ?yPx = "{ i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x }"
  let ?yP'x = "{ i \<in> Is. y \<^bsub>(P' i)\<^esub>\<prec> x }"
  have disjPxy: "(?xPy \<union> ?yPx) - ?xPy = ?yPx"
    unfolding strict_pref_def by blast
  have disjP'xy: "(?xP'y \<union> ?yP'x) - ?xP'y = ?yP'x"
    unfolding strict_pref_def by blast
  from finiteIs xytally
  obtain f where bijf: "bij_betw f ?xPy ?xP'y"
    by - (drule card_eq_bij, auto)
  from finiteIs yxtally
  obtain g where bijg: "bij_betw g ?yPx ?yP'x"
    by - (drule card_eq_bij, auto)
  from bijf bijg disjPxy disjP'xy
  obtain h
    where bijh: "bij_betw h (?xPy \<union> ?yPx) (?xP'y \<union> ?yP'x)"
      and hf: "\<And>j. j \<in> ?xPy \<Longrightarrow> h j = f j"
      and hg: "\<And>j. j \<in> (?xPy \<union> ?yPx) - ?xPy \<Longrightarrow> h j = g j"
    using bij_combine[where f=f and g=g and A="?xPy" and B ="?xPy \<union> ?yPx" and C="?xP'y" and D="?xP'y \<union> ?yP'x"]
    by auto
  from bijh finiteIs
  obtain h' where bijh': "bij_betw h' Is Is"
              and hh': "\<And>j. j \<in> (?xPy \<union> ?yPx) \<Longrightarrow> h' j = h j"
              and hrest: "\<And>j. j \<in> Is - (?xPy \<union> ?yPx) \<Longrightarrow> h' j \<in> Is - (?xP'y \<union> ?yP'x)"
    by - (drule bij_complete, auto)
  from neutral_iia[OF neutral]
  have "x \<^bsub>(scf (P' \<circ> h'))\<^esub>\<preceq> y \<longleftrightarrow> x \<^bsub>(scf P)\<^esub>\<preceq> y"
  proof(rule iiaE)
    from xyA show "{x, y} \<subseteq> A" by simp
  next
    fix i assume iIs: "i \<in> Is"
    fix a b assume ab: "a \<in> {x, y}" "b \<in> {x, y}"
    from profileP iIs have completePi: "complete A (P i)" by (auto dest: rprD)
    from completePi xyA
    show "(a \<^bsub>(P i)\<^esub>\<preceq> b) \<longleftrightarrow> (a \<^bsub>((P' \<circ> h') i)\<^esub>\<preceq> b)"
    proof(cases rule: complete_exh)
      case xPy with profileP profileP' xyA iIs ab hh' hf bijf show ?thesis
        unfolding strict_pref_def bij_betw_def by (simp, blast)
    next
      case yPx with profileP profileP' xyA iIs ab hh' hg bijg show ?thesis
        unfolding strict_pref_def bij_betw_def by (simp, blast)
    next
      case xIy with profileP profileP' xyA iIs ab hrest[where j=i] show ?thesis
        unfolding indifferent_pref_def strict_pref_def bij_betw_def
        by (simp, blast dest: rpr_complete)
    qed
  qed (simp_all add: profileP profile_bij_profile[OF profileP' bijh'])
  moreover
  from anonymousD[OF anonymous profileP' bijh'] xyA
  have "x \<^bsub>(scf P')\<^esub>\<preceq> y \<longleftrightarrow> x \<^bsub>(scf (P' \<circ> h'))\<^esub>\<preceq> y" by simp
  ultimately show ?thesis by simp
qed

text \<open>Using the previous result and neutrality, it must be the case that
if the tallies are tied for alternatives $x$ and $y$ then the social choice
function is indifferent between those two alternatives.\<close>

lemma anonymous_neutral_indifference:
  assumes profileP: "profile A Is P"
      and xyA: "hasw [x,y] A"
      and tallyP: "card { i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y } = card { i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x }"
  shows "x \<^bsub>(scf P)\<^esub>\<approx> y"
proof -
    \<comment> \<open>Neutrality insists the results for @{term "P"} are symmetrical to those for @{term "swapAltsP P"}.\<close>
  from xyA
  have symPP': "(x \<^bsub>(scf P)\<^esub>\<preceq> y \<longleftrightarrow> y \<^bsub>(scf (swapAltsP P x y))\<^esub>\<preceq> x)
              \<and> (y \<^bsub>(scf P)\<^esub>\<preceq> x \<longleftrightarrow> x \<^bsub>(scf (swapAltsP P x y))\<^esub>\<preceq> y)"
    by - (rule neutralD[OF neutral profileP profile_swapAltsP[OF profileP]],
          simp_all, (rule swapAltsP_ab)+)
      \<comment> \<open>Anonymity and neutrality insist the results for @{term "P"} are identical to those for @{term "swapAltsP P"}.\<close>
  from xyA tallyP have "card {i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y} = card { i \<in> Is. x \<^bsub>(swapAltsP P x y i)\<^esub>\<prec> y }"
                   and "card {i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x} = card { i \<in> Is. y \<^bsub>(swapAltsP P x y i)\<^esub>\<prec> x }"
    unfolding swapAltsP_def swapAlts_def strict_pref_def by simp_all
  with profileP xyA have idPP': "x \<^bsub>(scf P)\<^esub>\<preceq> y \<longleftrightarrow> x \<^bsub>(scf (swapAltsP P x y))\<^esub>\<preceq> y"
                            and "y \<^bsub>(scf P)\<^esub>\<preceq> x \<longleftrightarrow> y \<^bsub>(scf (swapAltsP P x y))\<^esub>\<preceq> x"
    by - (rule anonymous_card[OF profileP profile_swapAltsP], clarsimp+)+
  from xyA SCF_completeD[OF SCF] profileP symPP' idPP' show "x \<^bsub>(scf P)\<^esub>\<approx> y" by (simp, blast)
qed

text\<open>Finally, if the tallies are not equal then the social choice function
must lean towards the one with the higher count due to positive
responsiveness.\<close>

lemma positively_responsive_prefer_witness:
  assumes profileP: "profile A Is P"
      and xyA: "hasw [x,y] A"
      and tallyP: "card { i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y } > card { i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x }"
  obtains P' k
    where "profile A Is P'"
      and "\<And>i. \<lbrakk>i \<in> Is; x \<^bsub>(P' i)\<^esub>\<prec> y\<rbrakk> \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<prec> y"
      and "\<And>i. \<lbrakk>i \<in> Is; x \<^bsub>(P' i)\<^esub>\<approx> y\<rbrakk> \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<preceq> y"
      and "k \<in> Is \<and> x \<^bsub>(P' k)\<^esub>\<approx> y \<and> x \<^bsub>(P k)\<^esub>\<prec> y"
      and "card { i \<in> Is. x \<^bsub>(P' i)\<^esub>\<prec> y } = card { i \<in> Is. y \<^bsub>(P' i)\<^esub>\<prec> x }"
proof -
  from tallyP obtain C
    where tallyP': "card ({ i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y } - C) = card { i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x }"
      and C: "C \<noteq> {}" "C \<subseteq> Is"
      and CxPy: "C \<subseteq> { i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y }"
    by - (drule card_greater[OF finiteIs], auto)
      \<comment> \<open>Add $(b, a)$ and close under transitivity.\<close>
  let ?P' = "\<lambda>i. if i \<in> C
                   then P i \<union> { (y, x) }
                            \<union> { (y, u) |u. x \<^bsub>(P i)\<^esub>\<preceq> u }
                            \<union> { (u, x) |u. u \<^bsub>(P i)\<^esub>\<preceq> y }
                            \<union> { (v, u) |u v. x \<^bsub>(P i)\<^esub>\<preceq> u \<and> v \<^bsub>(P i)\<^esub>\<preceq> y }
                   else P i"
  have "profile A Is ?P'"
  proof
    fix i assume iIs: "i \<in> Is"
    show "rpr A (?P' i)"
    proof
      from profileP iIs show "complete A (?P' i)"
        unfolding complete_def by (simp, blast dest: rpr_complete)
      from profileP iIs xyA show "refl_on A (?P' i)"
        by - (rule refl_onI, auto)
      show "trans (?P' i)"
      proof(cases "i \<in> C")
        case False with profileP iIs show ?thesis
          by (simp, blast dest: rpr_le_trans intro: transI)
      next
        case True with profileP iIs C CxPy xyA show ?thesis
          unfolding strict_pref_def
          by - (rule transI, simp, blast dest: rpr_le_trans rpr_complete)
      qed
    qed
  next
    from C show "Is \<noteq> {}" by blast
  qed
  moreover
  have "\<And>i. \<lbrakk> i \<in> Is; x \<^bsub>(?P' i)\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<prec> y"
    unfolding strict_pref_def by (simp split: if_split_asm)
  moreover
  from profileP C xyA
  have "\<And>i. \<lbrakk>i \<in> Is; x \<^bsub>(?P' i)\<^esub>\<approx> y\<rbrakk> \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<preceq> y"
    unfolding indifferent_pref_def by (simp split: if_split_asm)
  moreover
  from C CxPy obtain k where kC: "k \<in> C" and xPky: "x \<^bsub>(P k)\<^esub>\<prec> y" by blast
  hence "x \<^bsub>(?P' k)\<^esub>\<approx> y" by auto
  with C kC xPky have "k \<in> Is \<and> x \<^bsub>(?P' k)\<^esub>\<approx> y \<and> x \<^bsub>(P k)\<^esub>\<prec> y" by blast
  moreover
  have "card { i \<in> Is. x \<^bsub>(?P' i)\<^esub>\<prec> y } = card { i \<in> Is. y \<^bsub>(?P' i)\<^esub>\<prec> x }"
  proof -
    have "{ i \<in> Is. x \<^bsub>(?P' i)\<^esub>\<prec> y } = { i \<in> Is. x \<^bsub>(?P' i)\<^esub>\<prec> y } - C"
    proof -
      from C have "\<And>i. \<lbrakk> i \<in> Is; x \<^bsub>(?P' i)\<^esub>\<prec> y \<rbrakk> \<Longrightarrow> i \<in> Is - C"
        unfolding indifferent_pref_def strict_pref_def by auto
      thus ?thesis by blast
    qed
    also have "\<dots> = { i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y } - C" by auto
    finally have "card { i \<in> Is. x \<^bsub>(?P' i)\<^esub>\<prec> y } = card ({ i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y } - C)"
      by simp
    with tallyP' have "card { i \<in> Is. x \<^bsub>(?P' i)\<^esub>\<prec> y } = card { i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x }"
      by simp
    also have "\<dots> = card { i \<in> Is. y \<^bsub>(?P' i)\<^esub>\<prec> x }" (is "card ?lhs = card ?rhs")
    proof -
      from profileP xyA have "\<And>i. \<lbrakk> i \<in> Is; y \<^bsub>(?P' i)\<^esub>\<prec> x \<rbrakk> \<Longrightarrow> y \<^bsub>(P i)\<^esub>\<prec> x"
        unfolding strict_pref_def by (simp split: if_split_asm, blast dest: rpr_complete)
      hence "?rhs \<subseteq> ?lhs" by blast
      moreover
      from profileP xyA have "\<And>i. \<lbrakk> i \<in> Is; y \<^bsub>(P i)\<^esub>\<prec> x \<rbrakk> \<Longrightarrow> y \<^bsub>(?P' i)\<^esub>\<prec> x"
        unfolding strict_pref_def by simp
      hence "?lhs \<subseteq> ?rhs" by blast
      ultimately show ?thesis by simp
    qed
    finally show ?thesis .
  qed
  ultimately show thesis ..
qed

lemma positively_responsive_prefer:
  assumes profileP: "profile A Is P"
      and xyA: "hasw [x,y] A"
      and tallyP: "card { i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y } > card { i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x }"
  shows "x \<^bsub>(scf P)\<^esub>\<prec> y"
proof -
  from assms obtain P' k
    where profileP': "profile A Is P'"
      and F: "\<And>i. \<lbrakk>i \<in> Is; x \<^bsub>(P' i)\<^esub>\<prec> y\<rbrakk> \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<prec> y"
      and G: "\<And>i. \<lbrakk>i \<in> Is; x \<^bsub>(P' i)\<^esub>\<approx> y\<rbrakk> \<Longrightarrow> x \<^bsub>(P i)\<^esub>\<preceq> y"
      and pivot: "k \<in> Is \<and> x \<^bsub>(P' k)\<^esub>\<approx> y \<and> x \<^bsub>(P k)\<^esub>\<prec> y"
      and cardP': "card { i \<in> Is. x \<^bsub>(P' i)\<^esub>\<prec> y } = card { i \<in> Is. y \<^bsub>(P' i)\<^esub>\<prec> x }"
    by - (drule positively_responsive_prefer_witness, auto)
  from profileP' xyA cardP' have "x \<^bsub>(scf P')\<^esub>\<approx> y"
    by - (rule anonymous_neutral_indifference, auto)
  with xyA F G pivot show ?thesis
    by - (rule positively_responsiveD[OF positively_responsive profileP' profileP], auto)
qed

lemma MMD_r2l:
  assumes profileP: "profile A Is P"
      and xyA: "hasw [x,y] A"
  shows "x \<^bsub>(scf P)\<^esub>\<preceq> y \<longleftrightarrow> x \<^bsub>(MMD Is P)\<^esub>\<preceq> y"
proof(cases rule: linorder_cases)
  assume "card { i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y } = card { i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x }"
  with profileP xyA show ?thesis
    using anonymous_neutral_indifference
    unfolding indifferent_pref_def MMD_def by simp
next
  assume "card { i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y } > card { i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x }"
  with profileP xyA show ?thesis
    using positively_responsive_prefer
    unfolding strict_pref_def MMD_def by simp
next
  assume "card { i \<in> Is. x \<^bsub>(P i)\<^esub>\<prec> y } < card { i \<in> Is. y \<^bsub>(P i)\<^esub>\<prec> x }"
  with profileP xyA show ?thesis
    using positively_responsive_prefer
    unfolding strict_pref_def MMD_def by clarsimp
qed

end

text\<open>May's original paper \<^cite>\<open>"May:1952"\<close> goes on to show that the
conditions are independent by exhibiting choice rules that differ from
@{term "MMD"} and satisfy the conditions remaining after any particular one
is removed. I leave this to future work.

May also wrote a later article \<^cite>\<open>"May:1953"\<close> where he shows that the
conditions are completely independent, i.e. for every partition of the
conditions into two sets, there is a voting rule that satisfies one and not
the other.

There are many later papers that characterise MMD with different sets of
conditions.

\<close>

subsection\<open>The Plurality Rule\<close>

text\<open>Goodin and List \<^cite>\<open>"GoodinList:2006"\<close> show that May's original
result can be generalised to characterise plurality voting. The following
shows that this result is a short step from Sen's much earlier
generalisation.

\emph{Plurality voting} is a choice function that returns the alternative
that receives the most votes, or the set of such alternatives in the case of
a tie. Profiles are restricted to those where each individual casts a vote
in favour of a single alternative.\<close>

type_synonym ('a, 'i) SVProfile = "'i \<Rightarrow> 'a"

definition svprofile :: "'a set \<Rightarrow> 'i set \<Rightarrow> ('a, 'i) SVProfile \<Rightarrow> bool" where
  "svprofile A Is F \<equiv> Is \<noteq> {} \<and> F ` Is \<subseteq> A"

definition plurality_rule :: "'a set \<Rightarrow> 'i set \<Rightarrow> ('a, 'i) SVProfile \<Rightarrow> 'a set" where
  "plurality_rule A Is F
     \<equiv> { x \<in> A . \<forall>y \<in> A. card { i \<in> Is . F i = x } \<ge> card { i \<in> Is . F i = y } }"

text\<open>By translating single-vote profiles into RPRs in the obvious way, the
choice function arising from @{term "MMD"} coincides with traditional
plurality voting.\<close>

definition MMD_plurality_rule :: "'a set \<Rightarrow> 'i set \<Rightarrow> ('a, 'i) Profile \<Rightarrow> 'a set" where
  "MMD_plurality_rule A Is P \<equiv> choiceSet A (MMD Is P)"

definition single_vote_to_RPR :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a RPR" where
  "single_vote_to_RPR A a \<equiv> { (a, x) |x. x \<in> A } \<union> (A - {a}) \<times> (A - {a})"

lemma single_vote_to_RPR_iff:
  "\<lbrakk> a \<in> A; x \<in> A; a \<noteq> x \<rbrakk> \<Longrightarrow> (a \<^bsub>(single_vote_to_RPR A b)\<^esub>\<prec> x) \<longleftrightarrow> (b = a)"
  unfolding single_vote_to_RPR_def strict_pref_def by auto

lemma plurality_rule_equiv:
  "plurality_rule A Is F = MMD_plurality_rule A Is (single_vote_to_RPR A \<circ> F)"
proof -
  {
    fix x y
    have "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow>
      (card {i \<in> Is. F i = y} \<le> card {i \<in> Is. F i = x}) =
      (card {i \<in> Is. y \<^bsub>(single_vote_to_RPR A (F i))\<^esub>\<prec> x}
        \<le> card {i \<in> Is. x \<^bsub>(single_vote_to_RPR A (F i))\<^esub>\<prec> y})"
      by (cases "x=y", auto iff: single_vote_to_RPR_iff)
  }
  thus ?thesis
    unfolding plurality_rule_def MMD_plurality_rule_def choiceSet_def MMD_def
    by auto
qed

text\<open>Thus it is clear that Sen's generalisation of May's result applies to
this case as well.

Their paper goes on to show how strengthening the anonymity condition gives
rise to a characterisation of approval voting that strictly generalises
May's original theorem. As this requires some rearrangement of the proof I
leave it to future work.\<close>

(*<*)
end
(*>*)