subsection \<open>Gauss Formula\label{sec:card_irred}\<close>

theory Card_Irreducible_Polynomials
  imports
    Dirichlet_Series.Moebius_Mu
    Card_Irreducible_Polynomials_Aux
begin

hide_const "Polynomial.order"

text \<open>The following theorem is a slightly generalized form of the formula discovered by
Gauss for the number of monic irreducible polynomials over a finite field. He originally verified
the result for the case when @{term "R"} is a simple prime field.
The version of the formula here for the case where @{term "R"} may be an arbitrary finite field can
be found in Chebolu and Min{\'a}{\v{c}}~\cite{chebolu2010}.\<close>

theorem (in finite_field) card_irred:
  assumes "n > 0"
  shows "n * card {f. monic_irreducible_poly R f \<and> degree f = n} =
    (\<Sum>d | d dvd n. moebius_mu d * (order R^(n div d)))"
    (is "?lhs = ?rhs")
proof -
  have "?lhs = dirichlet_prod moebius_mu (\<lambda>x. int (order R) ^ x) n"
    using card_irred_aux
    by (intro moebius_inversion assms) (simp flip:of_nat_power)
  also have "... = ?rhs"
    by (simp add:dirichlet_prod_def)
  finally show ?thesis by simp
qed

text \<open>In the following an explicit analytic lower bound for the cardinality of monic irreducible
polynomials is shown, with which existence follows. This part deviates from the classic approach,
where existence is verified using a divisibility argument. The reason for the deviation is that an
analytic bound can also be used to estimate the runtime of a randomized algorithm selecting an
irreducible polynomial, by randomly sampling monic polynomials.\<close>

lemma (in finite_field) card_irred_1:
  "card {f. monic_irreducible_poly R f \<and> degree f = 1} = order R"
proof -
  have "int (1 * card {f. monic_irreducible_poly R f \<and> degree f = 1})
    = int (order R)"
    by (subst card_irred, auto)
  thus ?thesis by simp
qed

lemma (in finite_field) card_irred_2:
  "real (card {f. monic_irreducible_poly R f \<and> degree f = 2}) =
    (real (order R)^2 - order R) / 2"
proof -
  have "x dvd 2 \<Longrightarrow> x = 1 \<or> x = 2" for x :: nat
    using nat_dvd_not_less[where m="2"]
    by (metis One_nat_def even_zero gcd_nat.strict_trans2
        less_2_cases nat_neq_iff pos2)
  hence a: "{d. d dvd 2} = {1,2::nat}"
    by (auto simp add:set_eq_iff)

  have "2*real (card {f. monic_irreducible_poly R f \<and> degree f = 2})
    = of_int (2* card {f. monic_irreducible_poly R f \<and> degree f = 2})"
    by simp
  also have "... =
    of_int (\<Sum>d | d dvd 2. moebius_mu d * int (order R) ^ (2 div d))"
    by (subst card_irred, auto)
  also have "... = order R^2 - int (order R)"
    by (subst a, simp)
  also have "... = real (order R)^2 - order R"
    by simp
  finally have
    "2 * real (card {f. monic_irreducible_poly R f \<and> degree f = 2}) =
    real (order R)^2 - order R"
    by simp
  thus ?thesis by simp
qed

lemma (in finite_field) card_irred_gt_2:
  assumes "n > 2"
  shows "real (order R)^n / (2*real n) \<le>
    card {f. monic_irreducible_poly R f \<and> degree f = n}"
    (is "?lhs \<le> ?rhs")
proof -
  let ?m = "real (order R)"
  have a:"?m \<ge> 2"
    using finite_field_min_order by simp

  have b:"moebius_mu n \<ge> -(1::real)" for n :: nat
    using abs_moebius_mu_le[where n="n"]
    unfolding abs_le_iff by auto

  have c: "n > 0" using assms by simp
  have d: "x < n - 1" if d_assms: "x dvd n" "x \<noteq> n" for x :: nat
  proof -
    have "x < n"
      using d_assms dvd_nat_bounds c by auto
    moreover have "\<not>(n-1 dvd n)" using assms
      by (metis One_nat_def Suc_diff_Suc c diff_zero
          dvd_add_triv_right_iff nat_dvd_1_iff_1
          nat_neq_iff numeral_2_eq_2 plus_1_eq_Suc)
    hence "x \<noteq> n-1" using d_assms by auto
    ultimately show "x < n-1"  by simp
  qed

  have "?m^n / 2 = ?m^n - ?m^n/2" by simp
  also have "... \<le> ?m^n - ?m^n/?m^1"
    using a by (intro diff_mono divide_left_mono, simp_all)
  also have "... \<le> ?m^n - ?m^(n-1)"
    using a c by (subst power_diff, simp_all)
  also have "... \<le> ?m^n - (?m^(n-1) - 1)/1" by simp
  also have "... \<le> ?m^n - (?m^(n-1)-1)/(?m-1)"
    using a by (intro diff_left_mono divide_left_mono, simp_all)
  also have "... = ?m^n - (\<Sum>i \<in> {..<n-1}. ?m^i)"
    using a by (subst geometric_sum, simp_all)
  also have "... \<le> ?m^n - (\<Sum>i \<in> {k. k dvd n \<and> k \<noteq> n}. ?m^i)"
    using d
    by (intro diff_mono sum_mono2 subsetI, auto simp add:not_less)
  also have "... = ?m^n + (\<Sum>i \<in> {k. k dvd n \<and> k \<noteq> n}. (-1) * ?m^i)"
    by (subst sum_distrib_left[symmetric], simp)
  also have "... \<le> moebius_mu 1 * ?m^n +
    (\<Sum>i \<in> {k. k dvd n \<and> k \<noteq> n}. moebius_mu (n div i) * ?m^i)"
    using b
    by (intro add_mono sum_mono mult_right_mono)
      (simp_all add:not_less)
  also have "... =  (\<Sum>i \<in> insert n {k. k dvd n \<and> k \<noteq> n}.
    moebius_mu (n div i) * ?m^i)"
    using c by (subst sum.insert, auto)
  also have "... = (\<Sum>i \<in> {k. k dvd n}. moebius_mu (n div i) * ?m^i)"
    by (intro sum.cong, auto simp add:set_eq_iff)
  also have "... = dirichlet_prod (\<lambda>i. ?m^i) moebius_mu n"
    unfolding dirichlet_prod_def by (intro sum.cong, auto)
  also have "... = dirichlet_prod moebius_mu (\<lambda>i. ?m^i) n"
    using dirichlet_prod_moebius_commute by metis
  also have "... =
    of_int (\<Sum>d | d dvd n. moebius_mu d * order R^(n div d))"
    unfolding dirichlet_prod_def by simp
  also have "... = of_int (n *
    card {f. monic_irreducible_poly R f \<and> length f - 1 = n})"
    using card_irred[OF c] by simp
  also have "... = n * ?rhs" by simp
  finally have "?m^n / 2 \<le> n * ?rhs" by simp
  hence "?m ^ n \<le> 2 * n * ?rhs" by simp
  hence "?m^n/(2*real n) \<le> ?rhs"
    using c by (subst pos_divide_le_eq, simp_all add:algebra_simps)
  thus ?thesis by simp
qed

lemma (in finite_field) exist_irred:
  assumes "n > 0"
  obtains f where "monic_irreducible_poly R f" "degree f = n"
proof -
  consider (i) "n = 1" | (ii) "n = 2" | (iii) "n>2"
    using assms by linarith
  then have
    "card {f. monic_irreducible_poly R f \<and> degree f = n} > 0"
    (is "card ?A > 0")
  proof (cases)
    case i
    hence "card ?A = order R"
      using card_irred_1 by simp
    also have "... > 0"
       using finite_field_min_order by simp
    finally show ?thesis by simp
  next
    case ii
    have "0 < (real (order R) * (real (order R) - 1)) / 2"
      using finite_field_min_order by simp
    also have "... = (real (order R)^2 - order R) / 2"
      by (simp add:power2_eq_square algebra_simps)
    also have "... = real (card ?A)"
      using ii by (subst card_irred_2[symmetric], simp)
    finally have " 0 < real (card ?A)" by simp
    then show ?thesis by simp
  next
    case iii
    have "0 < real (order R)^n / (2*real n)"
      using finite_field_min_order assms by simp
    also have "... \<le> real (card ?A)"
      using iii card_irred_gt_2 by simp
    finally have "0 < real (card ?A)" by simp
    then show ?thesis by simp
  qed
  hence "?A \<noteq> {}"
    by (metis card.empty nless_le)
  then obtain f where "monic_irreducible_poly R f" "degree f = n"
    by auto
  thus ?thesis using that by simp
qed

theorem existence:
  assumes "n > 0"
  assumes "Factorial_Ring.prime p"
  shows "\<exists>(F:: int set list set ring). finite_field F \<and> order F = p^n"
proof -
  interpret zf: finite_field "ZFact (int p)"
    using zfact_prime_is_finite_field assms by simp

  interpret zfp: polynomial_ring "ZFact p" "carrier (ZFact p)"
    unfolding polynomial_ring_def polynomial_ring_axioms_def
    using zf.field_axioms zf.carrier_is_subfield by simp

  have p_gt_0: "p > 0" using prime_gt_0_nat assms(2) by simp

  obtain f where f_def:
    "monic_irreducible_poly (ZFact (int p)) f"
    "degree f = n"
    using zf.exist_irred assms by auto

  let ?F  = "Rupt\<^bsub>(ZFact p)\<^esub> (carrier (ZFact p)) f"
  have "f \<in> carrier (poly_ring (ZFact (int p)))"
    using f_def(1) zf.monic_poly_carr
    unfolding monic_irreducible_poly_def
    by simp
  moreover have "degree f > 0"
    using assms(1) f_def by simp
  ultimately have "order ?F =  card (carrier (ZFact p))^degree f"
    by (intro zf.rupture_order[OF zf.carrier_is_subfield]) auto
  hence a:"order ?F = p^n"
    unfolding f_def(2) card_zfact_carr[OF p_gt_0] by simp

  have "field ?F"
    using f_def(1) zf.monic_poly_carr monic_irreducible_poly_def
    by (subst zfp.rupture_is_field_iff_pirreducible) auto
  moreover have "order ?F > 0"
    unfolding a using assms(1,2) p_gt_0 by simp
  ultimately have b:"finite_field ?F"
    using card_ge_0_finite
    by (intro finite_fieldI, auto simp add:Coset.order_def)

  show ?thesis
    using a b
    by (intro exI[where x="?F"], simp)
qed

end


(*
  File:     Anonymous_PAPP.thy
  Author:   Manuel Eberl, University of Innsbruck
*)
section \<open>Anonymous Party Approval Rules\<close>
theory Anonymous_PAPP
  imports Complex_Main "Randomised_Social_Choice.Order_Predicates" PAPP_Multiset_Extras
begin

text \<open>
  In this section we will define (anonymous) P-APP rules and some basic desirable properties
  of P-APP rules.
\<close>

subsection \<open>Definition of the General Setting\<close>

text \<open>
  The following locale encapsulates an anonymous \<^emph>\<open>party approval election\<close>; that is:

    \<^item> a number of voters

    \<^item> a set of parties

    \<^item> the size of the desired committee

  The number of parties and voters is assumed to be finite and non-zero.
  As a modelling choice, we do not distinguish the voters at all; there is no explicit set
  of voters. We only care about their number.
\<close>
locale anon_papp_election =
  fixes n_voters :: nat and parties :: "'a set" and committee_size :: nat
  assumes finite_parties [simp, intro]: "finite parties"
  assumes n_voters_pos: "n_voters > 0"
  assumes nonempty_parties [simp]: "parties \<noteq> {}"
begin

text \<open>
  The result of a P-APP election is a committee, i.e.\ a multiset of parties with
  the desired size.
\<close>
definition is_committee :: "'a multiset \<Rightarrow> bool" where
  "is_committee W \<longleftrightarrow> set_mset W \<subseteq> parties \<and> size W = committee_size"

end

text \<open>
  A \<^emph>\<open>preference profile\<close> for a P-APP collection consists of one approval list (i.e.\ a set of
  approved parties) for each voter. Since we are in an anonymous setting, this means that
  we have a \<^emph>\<open>multiset\<close> consisting of \<open>n\<close> sets of parties (where \<open>n\<close> is the number of voters).

  Moreover, we make the usual assumption that the approval lists must be non-empty.
\<close>
locale anon_papp_profile = anon_papp_election +
  fixes A :: "'a set multiset"
  assumes A_subset: "\<And>X. X \<in># A \<Longrightarrow> X \<subseteq> parties"
  assumes A_nonempty: "{} \<notin># A"
  assumes size_A: "size A = n_voters"
begin

lemma A_nonempty': "A \<noteq> {#}"
  using size_A n_voters_pos by auto

end

context anon_papp_election
begin

abbreviation
  is_pref_profile where "is_pref_profile \<equiv> anon_papp_profile n_voters parties"

lemma is_pref_profile_iff:
  "is_pref_profile A \<longleftrightarrow> set_mset A \<subseteq> Pow parties - {{}} \<and> size A = n_voters"
  unfolding anon_papp_profile_def anon_papp_profile_axioms_def
  using anon_papp_election_axioms by auto

lemma not_is_pref_profile_empty [simp]: "\<not>is_pref_profile {#}"
  using anon_papp_profile.A_nonempty'[of n_voters]
  by auto

text \<open>
  The following relation is a key definition: it takes an approval list \<open>A\<close> and turns it
  into a preference relation on committees. A committee is to be at least as good as another
  if the number of approved parties in it is at least as big.

  This relation is a reflexive, transitive, and total.
\<close>
definition committee_preference :: "'a set \<Rightarrow> 'a multiset relation" ("Comm") where
  "W1 \<preceq>[Comm(A)] W2 \<longleftrightarrow> size {# x\<in>#W1. x \<in> A #} \<le> size {# x\<in>#W2. x \<in> A #}"

lemma not_strict_Comm [simp]: "\<not>(W1 \<prec>[Comm(A)] W2) \<longleftrightarrow> W1 \<succeq>[Comm(A)] W2"
  by (auto simp: committee_preference_def strongly_preferred_def)

lemma not_weak_Comm [simp]: "\<not>(W1 \<preceq>[Comm(A)] W2) \<longleftrightarrow> W1 \<succ>[Comm(A)] W2"
  by (auto simp: committee_preference_def strongly_preferred_def)

sublocale Comm: preorder "Comm(A)" "\<lambda>x y. x \<prec>[Comm(A)] y"
  by standard (auto simp: committee_preference_def strongly_preferred_def)

lemma strong_committee_preference_iff:
  "W1 \<prec>[Comm(A)] W2 \<longleftrightarrow> size {# x\<in>#W1. x \<in> A #} < size {# x\<in>#W2. x \<in> A #}"
  by (auto simp: committee_preference_def strongly_preferred_def)

text \<open>
  We also define the Pareto ordering on parties induced by a given preference profile:
  One party is at least as good (in the Pareto relation) as another if all voters agree that
  it is at least as good. That is, $y \succeq x$ in the Pareto ordering if all voters who
  approve $x$ also approve $y$.

  This relation is also reflexive and transitive.
\<close>
definition Pareto :: "'a set multiset \<Rightarrow> 'a relation" where
  "x \<preceq>[Pareto(A)] y \<longleftrightarrow> x \<in> parties \<and> y \<in> parties \<and> (\<forall>X\<in>#A. x \<in> X \<longrightarrow> y \<in> X)"

sublocale Pareto: preorder_on parties "Pareto A"
  by standard (auto simp: Pareto_def)

text \<open>
  Pareto losers are parties that are (strictly) Pareto-dominated, i.e.\ there
  exists some other party that all voters consider to be at least as good and at least
  one voter considers it to be strictly better.
\<close>
definition pareto_losers :: "'a set multiset \<Rightarrow> 'a set" where
  "pareto_losers A = {x. \<exists>y. y \<succ>[Pareto(A)] x}"

end

subsection \<open>P-APP rules and Desirable Properties\<close>

text \<open>
  The following locale describes a P-APP rule. This is simply a function that maps every
  preference profile to a committee of the desired size.

  Note that in our setting, a P-APP rule has a fixed number of voters, a fixed set of parties,
  and a fixed desired committee size.
\<close>
locale anon_papp = anon_papp_election +
  fixes r :: "'a set multiset \<Rightarrow> 'a multiset"
  assumes rule_wf: "is_pref_profile A \<Longrightarrow> is_committee (r A)"

subsection \<open>Efficiency\<close>

text \<open>
  Efficiency is a common notion in Social Choice Theory. The idea is that if a party is
  ``obviously bad'', then it should not be chosen. What ``obviously bad'' means depends on the
  precise notion of Efficiency that is used. We will talk about two notions: Weak Efficiency and
  Pareto Efficiency.

  A P-APP rule is \<^emph>\<open>weakly efficient\<close> if a party that is approved by no one is never
  part of the output committee.

  Note that approval lists must be non-empty, so there is always at least one party that
  is approved by at least one voter.
\<close>
locale weakly_efficient_anon_papp = anon_papp +
  assumes weakly_efficient: "is_pref_profile A \<Longrightarrow> \<forall>X\<in>#A. x \<notin> X \<Longrightarrow> x \<notin># r A"

text \<open>
  A P-APP rule is \<^emph>\<open>Pareto-efficient\<close> if a Pareto-dominated party is never part of
  the output committee.
\<close>
locale pareto_optimal_anon_papp = anon_papp +
  assumes pareto_optimal: "is_pref_profile A \<Longrightarrow> x \<in> pareto_losers A \<Longrightarrow> x \<notin># r A"
begin

text \<open>
  Pareto-efficiency implies weak efficiency:
\<close>
sublocale weakly_efficient_anon_papp
proof
  fix A x
  assume A: "is_pref_profile A" and x: "\<forall>X\<in>#A. x \<notin> X"
  interpret anon_papp_profile n_voters parties committee_size A
    by fact
  have "A \<noteq> {#}"
    using A_nonempty' .
  then obtain X where X: "X \<in># A"
    by auto
  with A_nonempty have "X \<noteq> {}"
    by auto
  then obtain y where y: "y \<in> X"
    by auto
  show "x \<notin># r A"
  proof (cases "x \<in> parties")
    case False
    thus ?thesis
      using rule_wf[OF A] by (auto simp: is_committee_def)
  next
    case True
    have "y \<succ>[Pareto(A)] x"
      unfolding Pareto_def using X x y True A_subset[of X]
      by (auto simp: strongly_preferred_def)
    hence "x \<in> pareto_losers A"
      by (auto simp: pareto_losers_def)
    thus ?thesis
      using pareto_optimal[OF A] by auto
  qed
qed

end

subsection \<open>Strategyproofness\<close>

text \<open>
  Strategyproofness is another common notion in Social Choice Theory that generally encapsulates
  the notion that an voter should not be able to manipulate the outcome of an election in their
  favour by (unilaterally) submitting fake preferences; i.e.\ reporting one's preferences
  truthfully should always be the optimal choice.

  A P-APP rule is called \<^emph>\<open>cardinality-strategyproof\<close> if an voter cannot obtain a better committee
  (i.e.\ one that contains strictly more of their approved parties) by submitting an approval
  list that is different from their real approval list.
\<close>

text \<open>
  To make the definition simpler, we first define the notion of \<^emph>\<open>manipulability\<close>: in the context
  of a particular P-APP rule \<open>r\<close>, a preference profile \<open>A\<close> is said to be manipulable by the voter
  \<open>i\<close> with the fake preference list \<open>Y\<close> if \<open>r(A(i := Y))\<close> contains strictly more parties
  approved by \<open>i\<close> than \<open>r(A)\<close>.

  Since we have anonymous profiles and do not talk about particular voters, we replace \<open>i\<close> with
  their approval list \<open>X\<close>. Since \<open>A\<close> is a multiset, the definition of manipulability
  becomes $r(A-\{X\}+\{Y\}) \succ_{X} r(A)$.
\<close>
definition (in anon_papp) card_manipulable where
  "card_manipulable A X Y \<longleftrightarrow>
     is_pref_profile A \<and> X \<in># A \<and> Y \<noteq> {} \<and> Y \<subseteq> parties \<and> r (A - {#X#} + {#Y#}) \<succ>[Comm(X)] r A"

text \<open>
  A technical (and fairly obvious) lemma: replacing an voter's approval list with a different
  approval list again yields a valid preference profile.
\<close>
lemma (in anon_papp) is_pref_profile_replace:
  assumes "is_pref_profile A" and "X \<in># A" and "Y \<noteq> {}" and "Y \<subseteq> parties"
  shows   "is_pref_profile (A - {#X#} + {#Y#})"
proof -
  interpret anon_papp_profile n_voters parties committee_size A
    by fact
  show ?thesis
    using assms A_subset A_nonempty unfolding is_pref_profile_iff
    by (auto dest: in_diffD simp: size_Suc_Diff1)
qed

locale card_stratproof_anon_papp = anon_papp +
  assumes not_manipulable: "\<not>card_manipulable A X Y"
begin

text \<open>
  The two following alternative versions of non-manipulability are somewhat nicer to use
  in practice.
\<close>
lemma not_manipulable':
  assumes "is_pref_profile A" "is_pref_profile A'" "A + {#Y#} = A' + {#X#}"
  shows   "\<not>(r A' \<succ>[Comm(X)] r A)"
proof (cases "X = Y")
  case True
  thus ?thesis
    using assms by (simp add: strongly_preferred_def)
next
  case False
  interpret A: anon_papp_profile n_voters parties committee_size A
    by fact
  interpret A': anon_papp_profile n_voters parties committee_size A'
    by fact
  from assms(3) False have *: "Y \<in># A'" "X \<in># A"
    by (metis add_mset_add_single insert_noteq_member)+

  have "\<not>card_manipulable A X Y"
    by (intro not_manipulable)
  hence "\<not>r (A - {#X#} + {#Y#}) \<succ>[Comm(X)] r A"
    using assms * A.A_subset A'.A_subset A.A_nonempty A'.A_nonempty
    by (auto simp: card_manipulable_def)
  also have "A - {#X#} + {#Y#} = A'"
    using assms(3) False by (metis add_eq_conv_diff add_mset_add_single)
  finally show ?thesis .
qed

lemma not_manipulable'':
  assumes "is_pref_profile A" "is_pref_profile A'" "A + {#Y#} = A' + {#X#}"
  shows   "r A' \<preceq>[Comm(X)] r A"
  using not_manipulable'[OF assms] by simp

end

subsection \<open>Representation\<close>

text \<open>
  \<^emph>\<open>Representation\<close> properties are in a sense the opposite of Efficiency properties: if a
  sufficiently high voters agree that certain parties are good, then these should, to some
  extent, be present in the result. For instance, if we have 20 voters and 5 of them approve
  parties \<open>A\<close> and \<open>B\<close>, then if the output committee has size 4, we would expect either
  \<open>A\<close> or \<open>B\<close> to be in the committee to ensure that these voters' preferences are represented fairly.

  Weak representation is a particularly weak variant of this that states that if at least one $k$-th
  of the voters (where $k$ is the size of the output committee) approve only a single
  party \<open>x\<close>, then \<open>x\<close> should be in the committee at least once:
\<close>

locale weak_rep_anon_papp =
  anon_papp n_voters parties committee_size r
  for n_voters and parties :: "'alt set" and committee_size :: nat and r +
  assumes weak_representation:
    "is_pref_profile A \<Longrightarrow> committee_size * count A {x} \<ge> n_voters \<Longrightarrow> x \<in># r A"

text \<open>
  The following alternative definition of Weak Representation is a bit closer to the definition
  given in the paper.
\<close>
lemma weak_rep_anon_papp_altdef:
  "weak_rep_anon_papp n_voters parties committee_size r \<longleftrightarrow>
     anon_papp n_voters parties committee_size r \<and> (committee_size = 0 \<or>
     (\<forall>A x. anon_papp_profile n_voters parties A \<longrightarrow>
              count A {x} \<ge> n_voters / committee_size \<longrightarrow> x \<in># r A))"
  by (cases "committee_size = 0")
     (auto simp: field_simps weak_rep_anon_papp_def
                 weak_rep_anon_papp_axioms_def
                 anon_papp_def anon_papp_axioms_def anon_papp_election_def
           simp flip: of_nat_mult)

text \<open>
  \<^emph>\<open>Justified Representation\<close> is a stronger notion which demands that if there is a subgroup of
  voters that comprises at least one $k$-th of all voters and for which the intersection of their
  approval lists is some nonempty set \<open>X\<close>, then at least one of the parties approved by at least
  one voter in that subgroup must be in the result committee.
\<close>
locale justified_rep_anon_papp =
  anon_papp n_voters parties committee_size r
  for n_voters and parties :: "'alt set" and committee_size :: nat and r +
  assumes justified_representation:
    "is_pref_profile A \<Longrightarrow> G \<subseteq># A \<Longrightarrow> committee_size * size G \<ge> n_voters \<Longrightarrow>
       (\<Inter>X\<in>set_mset G. X) \<noteq> {} \<Longrightarrow> \<exists>X x. X \<in># G \<and> x \<in> X \<and> x \<in># r A"
begin

text \<open>
  Any rule that satisfies Justified Representation also satisfies Weak Representation
\<close>
sublocale weak_rep_anon_papp
proof
  fix A x
  assume *: "is_pref_profile A" "n_voters \<le> committee_size * count A {x}"
  define G where "G = replicate_mset (count A {x}) {x}"
  have [simp]: "size G = count A {x}"
    by (auto simp: G_def)
  have **: "set_mset G \<subseteq> {{x}}"
    by (auto simp: G_def)
  have ***: "G \<subseteq># A"
    unfolding G_def by (meson count_le_replicate_mset_subset_eq order_refl)
  have "\<exists>X x. X \<in># G \<and> x \<in> X \<and> x \<in># r A"
    by (rule justified_representation) (use * ** *** in auto)
  thus "x \<in># r A"
    using ** by auto
qed

end

locale card_stratproof_weak_rep_anon_papp =
  card_stratproof_anon_papp + weak_rep_anon_papp

subsection \<open>Proportional Representation\<close>

text \<open>
  The notions of Representation we have seen so far are fairly week in that they only demand
  that certain parties be in the committee at least once if enough voters approve them. Notions of
  Proportional Representation strengthen this by demanding that if a sufficiently large subgroup of
  voters approve some parties, then these voters must be represented in the result committe not
  just once, but to a degree proportional to the size of that subgroup of voters.

  For Weak Representation, the proportional generalization is fairly simple: if a fraction of
  at least $\frac{ln}{k}$ of the voters uniquely approve a party \<open>x\<close>, then \<open>x\<close> must be in the
  committee at least \<open>l\<close> times.
\<close>

locale weak_prop_rep_anon_papp =
  anon_papp n_voters parties committee_size r
  for n_voters and parties :: "'alt set" and committee_size :: nat and r +
  assumes weak_proportional_representation:
    "is_pref_profile A \<Longrightarrow> committee_size * count A {x} \<ge> l * n_voters \<Longrightarrow> count (r A) x \<ge> l"
begin

sublocale weak_rep_anon_papp
proof
  fix A x
  assume "is_pref_profile A" "n_voters \<le> committee_size * count A {x}"
  thus "x \<in># r A"
    using weak_proportional_representation[of A 1] by auto
qed

end

text \<open>
  Similarly, Justified \<^emph>\<open>Proportional\<close> Representation demands that if the approval lists of
  a subgroup of at least $\frac{ln}{k}$ voters have a non-empty intersection, then at least \<open>l\<close>
  parties in the result committee are each approved by at least one of the voters in the subgroup.
\<close>
locale justified_prop_rep_anon_papp =
  anon_papp n_voters parties committee_size r
  for n_voters and parties :: "'alt set" and committee_size :: nat and r +
  assumes justified_proportional_representation:
    "is_pref_profile A \<Longrightarrow> G \<subseteq># A \<Longrightarrow> committee_size * size G \<ge> l * n_voters \<Longrightarrow>
       (\<Inter>X\<in>set_mset G. X) \<noteq> {} \<Longrightarrow> size {# x \<in># r A. x \<in> (\<Union>X\<in>set_mset G. X) #} \<ge> l"
begin

sublocale justified_rep_anon_papp
proof
  fix A G
  assume "is_pref_profile A" "G \<subseteq># A" "n_voters \<le> committee_size * size G"
         "(\<Inter>X\<in>set_mset G. X) \<noteq> {}"
  hence "size {#x \<in># r A. \<exists>X\<in>#G. x \<in> X#} \<ge> 1"
    using justified_proportional_representation[of A G 1] by auto
  hence "{#x \<in># r A. \<exists>X\<in>#G. x \<in> X#} \<noteq> {#}"
    by auto
  thus "\<exists>X x. X \<in># G \<and> x \<in> X \<and> x \<in># r A"
    by fastforce
qed

sublocale weak_prop_rep_anon_papp
proof
  fix A l x
  assume *: "is_pref_profile A" "l * n_voters \<le> committee_size * count A {x}"
  define G where "G = replicate_mset (count A {x}) {x}"
  from * have "size {#x \<in># r A. x \<in> (\<Union>X\<in>set_mset G. X)#} \<ge> l"
    by (intro justified_proportional_representation)
       (auto simp: G_def simp flip: count_le_replicate_mset_subset_eq)
  also have "size {#x \<in># r A. x \<in> (\<Union>X\<in>set_mset G. X)#} \<le> count (r A) x"
    by (auto simp: G_def)
  finally show "count (r A) x \<ge> l" .
qed

end

locale card_stratproof_weak_prop_rep_anon_papp =
  card_stratproof_anon_papp + weak_prop_rep_anon_papp

end


(*  Title:      HOL/Proofs/Lambda/Lambda.thy
    Author:     Tobias Nipkow
    Copyright   1995 TU Muenchen
*)

section \<open>Basic definitions of Lambda-calculus\<close>

theory Lambda
imports Main
begin

declare [[syntax_ambiguity_warning = false]]

subsection \<open>Lambda-terms in de Bruijn notation and substitution\<close>

datatype dB =
    Var nat
  | App dB dB (infixl "\<degree>" 200)
  | Abs dB

primrec
  lift :: "[dB, nat] => dB"
where
    "lift (Var i) k = (if i < k then Var i else Var (i + 1))"
  | "lift (s \<degree> t) k = lift s k \<degree> lift t k"
  | "lift (Abs s) k = Abs (lift s (k + 1))"

primrec
  subst :: "[dB, dB, nat] => dB"  ("_[_'/_]" [300, 0, 0] 300)
where (* FIXME base names *)
    subst_Var: "(Var i)[s/k] =
      (if k < i then Var (i - 1) else if i = k then s else Var i)"
  | subst_App: "(t \<degree> u)[s/k] = t[s/k] \<degree> u[s/k]"
  | subst_Abs: "(Abs t)[s/k] = Abs (t[lift s 0 / k+1])"

declare subst_Var [simp del]

text \<open>Optimized versions of @{term subst} and @{term lift}.\<close>

primrec
  liftn :: "[nat, dB, nat] => dB"
where
    "liftn n (Var i) k = (if i < k then Var i else Var (i + n))"
  | "liftn n (s \<degree> t) k = liftn n s k \<degree> liftn n t k"
  | "liftn n (Abs s) k = Abs (liftn n s (k + 1))"

primrec
  substn :: "[dB, dB, nat] => dB"
where
    "substn (Var i) s k =
      (if k < i then Var (i - 1) else if i = k then liftn k s 0 else Var i)"
  | "substn (t \<degree> u) s k = substn t s k \<degree> substn u s k"
  | "substn (Abs t) s k = Abs (substn t s (k + 1))"

subsection \<open>Beta-reduction\<close>

inductive beta :: "[dB, dB] => bool"  (infixl "\<rightarrow>\<^sub>\<beta>" 50)
  where
    beta [simp, intro!]: "Abs s \<degree> t \<rightarrow>\<^sub>\<beta> s[t/0]"
  | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
  | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
  | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> Abs s \<rightarrow>\<^sub>\<beta> Abs t"

abbreviation
  beta_reds :: "[dB, dB] => bool"  (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50) where
  "s \<rightarrow>\<^sub>\<beta>\<^sup>* t == beta^** s t"

inductive_cases beta_cases [elim!]:
  "Var i \<rightarrow>\<^sub>\<beta> t"
  "Abs r \<rightarrow>\<^sub>\<beta> s"
  "s \<degree> t \<rightarrow>\<^sub>\<beta> u"

declare if_not_P [simp] not_less_eq [simp]
  \<comment> \<open>don't add \<open>r_into_rtrancl[intro!]\<close>\<close>

subsection \<open>Congruence rules\<close>

lemma rtrancl_beta_Abs [intro!]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' ==> Abs s \<rightarrow>\<^sub>\<beta>\<^sup>* Abs s'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppL:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppR:
    "t \<rightarrow>\<^sub>\<beta>\<^sup>* t' ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s \<degree> t'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_App [intro]:
    "[| s \<rightarrow>\<^sub>\<beta>\<^sup>* s'; t \<rightarrow>\<^sub>\<beta>\<^sup>* t' |] ==> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t'"
  by (blast intro!: rtrancl_beta_AppL rtrancl_beta_AppR intro: rtranclp_trans)

subsection \<open>Substitution-lemmas\<close>

lemma subst_eq [simp]: "(Var k)[u/k] = u"
  by (simp add: subst_Var)

lemma subst_gt [simp]: "i < j ==> (Var j)[u/i] = Var (j - 1)"
  by (simp add: subst_Var)

lemma subst_lt [simp]: "j < i ==> (Var j)[u/i] = Var j"
  by (simp add: subst_Var)

lemma lift_lift:
    "i < k + 1 \<Longrightarrow> lift (lift t i) (Suc k) = lift (lift t k) i"
  by (induct t arbitrary: i k) auto

lemma lift_subst [simp]:
    "j < i + 1 \<Longrightarrow> lift (t[s/j]) i = (lift t (i + 1)) [lift s i / j]"
  by (induct t arbitrary: i j s)
    (simp_all add: diff_Suc subst_Var lift_lift split: nat.split)

lemma lift_subst_lt:
    "i < j + 1 \<Longrightarrow> lift (t[s/j]) i = (lift t i) [lift s i / j + 1]"
  by (induct t arbitrary: i j s) (simp_all add: subst_Var lift_lift)

lemma subst_lift [simp]:
    "(lift t k)[s/k] = t"
  by (induct t arbitrary: k s) simp_all

lemma subst_subst:
    "i < j + 1 \<Longrightarrow> t[lift v i / Suc j][u[v/j]/i] = t[u/i][v/j]"
  by (induct t arbitrary: i j u v)
    (simp_all add: diff_Suc subst_Var lift_lift [symmetric] lift_subst_lt
      split: nat.split)

subsection \<open>Equivalence proof for optimized substitution\<close>

lemma liftn_0 [simp]: "liftn 0 t k = t"
  by (induct t arbitrary: k) (simp_all add: subst_Var)

lemma liftn_lift [simp]: "liftn (Suc n) t k = lift (liftn n t k) k"
  by (induct t arbitrary: k) (simp_all add: subst_Var)

lemma substn_subst_n [simp]: "substn t s n = t[liftn n s 0 / n]"
  by (induct t arbitrary: n) (simp_all add: subst_Var)

theorem substn_subst_0: "substn t s 0 = t[s/0]"
  by simp

subsection \<open>Preservation theorems\<close>

text \<open>Not used in Church-Rosser proof, but in Strong
  Normalization. \medskip\<close>

theorem subst_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s ==> r[t/i] \<rightarrow>\<^sub>\<beta> s[t/i]"
  by (induct arbitrary: t i set: beta) (simp_all add: subst_subst [symmetric])

theorem subst_preserves_beta': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> r[t/i] \<rightarrow>\<^sub>\<beta>\<^sup>* s[t/i]"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp.rtrancl_into_rtrancl)
  apply (erule subst_preserves_beta)
  done

theorem lift_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s ==> lift r i \<rightarrow>\<^sub>\<beta> lift s i"
  by (induct arbitrary: i set: beta) auto

theorem lift_preserves_beta': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> lift r i \<rightarrow>\<^sub>\<beta>\<^sup>* lift s i"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp.rtrancl_into_rtrancl)
  apply (erule lift_preserves_beta)
  done

theorem subst_preserves_beta2 [simp]: "r \<rightarrow>\<^sub>\<beta> s ==> t[r/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t[s/i]"
  apply (induct t arbitrary: r s i)
    apply (simp add: subst_Var r_into_rtranclp)
   apply (simp add: rtrancl_beta_App)
  apply (simp add: rtrancl_beta_Abs)
  done

theorem subst_preserves_beta2': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s ==> t[r/i] \<rightarrow>\<^sub>\<beta>\<^sup>* t[s/i]"
  apply (induct set: rtranclp)
   apply (rule rtranclp.rtrancl_refl)
  apply (erule rtranclp_trans)
  apply (erule subst_preserves_beta2)
  done

end