(*  Title:      HOL/UNITY/Transformers.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2003  University of Cambridge

Predicate Transformers.  From

    David Meier and Beverly Sanders,
    Composing Leads-to Properties
    Theoretical Computer Science 243:1-2 (2000), 339-361.

    David Meier,
    Progress Properties in Program Refinement and Parallel Composition
    Swiss Federal Institute of Technology Zurich (1997)
*)

section\<open>Predicate Transformers\<close>

theory Transformers imports Comp begin

subsection\<open>Defining the Predicate Transformers @{term wp},
   @{term awp} and  @{term wens}\<close>

definition wp :: "[('a*'a) set, 'a set] => 'a set" where
    \<comment>\<open>Dijkstra's weakest-precondition operator (for an individual command)\<close>
    "wp act B == - (act^-1 `` (-B))"

definition awp :: "['a program, 'a set] => 'a set" where
    \<comment>\<open>Dijkstra's weakest-precondition operator (for a program)\<close>
    "awp F B == (\<Inter>act \<in> Acts F. wp act B)"

definition wens :: "['a program, ('a*'a) set, 'a set] => 'a set" where
    \<comment>\<open>The weakest-ensures transformer\<close>
    "wens F act B == gfp(\<lambda>X. (wp act B \<inter> awp F (B \<union> X)) \<union> B)"

text\<open>The fundamental theorem for wp\<close>
theorem wp_iff: "(A <= wp act B) = (act `` A <= B)"
by (force simp add: wp_def)

text\<open>This lemma is a good deal more intuitive than the definition!\<close>
lemma in_wp_iff: "(a \<in> wp act B) = (\<forall>x. (a,x) \<in> act --> x \<in> B)"
by (simp add: wp_def, blast)

lemma Compl_Domain_subset_wp: "- (Domain act) \<subseteq> wp act B"
by (force simp add: wp_def)

lemma wp_empty [simp]: "wp act {} = - (Domain act)"
by (force simp add: wp_def)

text\<open>The identity relation is the skip action\<close>
lemma wp_Id [simp]: "wp Id B = B"
by (simp add: wp_def)

lemma wp_totalize_act:
     "wp (totalize_act act) B = (wp act B \<inter> Domain act) \<union> (B - Domain act)"
by (simp add: wp_def totalize_act_def, blast)

lemma awp_subset: "(awp F A \<subseteq> A)"
by (force simp add: awp_def wp_def)

lemma awp_Int_eq: "awp F (A\<inter>B) = awp F A \<inter> awp F B"
by (simp add: awp_def wp_def, blast)

text\<open>The fundamental theorem for awp\<close>
theorem awp_iff_constrains: "(A <= awp F B) = (F \<in> A co B)"
by (simp add: awp_def constrains_def wp_iff INT_subset_iff)

lemma awp_iff_stable: "(A \<subseteq> awp F A) = (F \<in> stable A)"
by (simp add: awp_iff_constrains stable_def)

lemma stable_imp_awp_ident: "F \<in> stable A ==> awp F A = A"
apply (rule equalityI [OF awp_subset])
apply (simp add: awp_iff_stable)
done

lemma wp_mono: "(A \<subseteq> B) ==> wp act A \<subseteq> wp act B"
by (simp add: wp_def, blast)

lemma awp_mono: "(A \<subseteq> B) ==> awp F A \<subseteq> awp F B"
by (simp add: awp_def wp_def, blast)

lemma wens_unfold:
     "wens F act B = (wp act B \<inter> awp F (B \<union> wens F act B)) \<union> B"
apply (simp add: wens_def)
apply (rule gfp_unfold)
apply (simp add: mono_def wp_def awp_def, blast)
done

lemma wens_Id [simp]: "wens F Id B = B"
by (simp add: wens_def gfp_def wp_def awp_def, blast)

text\<open>These two theorems justify the claim that @{term wens} returns the
weakest assertion satisfying the ensures property\<close>
lemma ensures_imp_wens: "F \<in> A ensures B ==> \<exists>act \<in> Acts F. A \<subseteq> wens F act B"
apply (simp add: wens_def ensures_def transient_def, clarify)
apply (rule rev_bexI, assumption)
apply (rule gfp_upperbound)
apply (simp add: constrains_def awp_def wp_def, blast)
done

lemma wens_ensures: "act \<in> Acts F ==> F \<in> (wens F act B) ensures B"
by (simp add: wens_def gfp_def constrains_def awp_def wp_def
              ensures_def transient_def, blast)

text\<open>These two results constitute assertion (4.13) of the thesis\<close>
lemma wens_mono: "(A \<subseteq> B) ==> wens F act A \<subseteq> wens F act B"
apply (simp add: wens_def wp_def awp_def)
apply (rule gfp_mono, blast)
done

lemma wens_weakening: "B \<subseteq> wens F act B"
by (simp add: wens_def gfp_def, blast)

text\<open>Assertion (6), or 4.16 in the thesis\<close>
lemma subset_wens: "A-B \<subseteq> wp act B \<inter> awp F (B \<union> A) ==> A \<subseteq> wens F act B"
apply (simp add: wens_def wp_def awp_def)
apply (rule gfp_upperbound, blast)
done

text\<open>Assertion 4.17 in the thesis\<close>
lemma Diff_wens_constrains: "F \<in> (wens F act A - A) co wens F act A"
by (simp add: wens_def gfp_def wp_def awp_def constrains_def, blast)
  \<comment>\<open>Proved instantly, yet remarkably fragile. If \<open>Un_subset_iff\<close>
      is declared as an iff-rule, then it's almost impossible to prove.
      One proof is via \<open>meson\<close> after expanding all definitions, but it's
      slow!\<close>

text\<open>Assertion (7): 4.18 in the thesis.  NOTE that many of these results
hold for an arbitrary action.  We often do not require @{term "act \<in> Acts F"}\<close>
lemma stable_wens: "F \<in> stable A ==> F \<in> stable (wens F act A)"
apply (simp add: stable_def)
apply (drule constrains_Un [OF Diff_wens_constrains [of F act A]])
apply (simp add: Un_Int_distrib2 Compl_partition2)
apply (erule constrains_weaken, blast)
apply (simp add: wens_weakening)
done

text\<open>Assertion 4.20 in the thesis.\<close>
lemma wens_Int_eq_lemma:
      "[|T-B \<subseteq> awp F T; act \<in> Acts F|]
       ==> T \<inter> wens F act B \<subseteq> wens F act (T\<inter>B)"
apply (rule subset_wens)
apply (rule_tac P="\<lambda>x. f x \<subseteq> b" for f b in ssubst [OF wens_unfold])
apply (simp add: wp_def awp_def, blast)
done

text\<open>Assertion (8): 4.21 in the thesis. Here we indeed require
      @{term "act \<in> Acts F"}\<close>
lemma wens_Int_eq:
      "[|T-B \<subseteq> awp F T; act \<in> Acts F|]
       ==> T \<inter> wens F act B = T \<inter> wens F act (T\<inter>B)"
apply (rule equalityI)
 apply (simp_all add: Int_lower1)
 apply (rule wens_Int_eq_lemma, assumption+)
apply (rule subset_trans [OF _ wens_mono [of "T\<inter>B" B]], auto)
done

subsection\<open>Defining the Weakest Ensures Set\<close>

inductive_set
  wens_set :: "['a program, 'a set] => 'a set set"
  for F :: "'a program" and B :: "'a set"
where

  Basis: "B \<in> wens_set F B"

| Wens:  "[|X \<in> wens_set F B; act \<in> Acts F|] ==> wens F act X \<in> wens_set F B"

| Union: "W \<noteq> {} ==> \<forall>U \<in> W. U \<in> wens_set F B ==> \<Union>W \<in> wens_set F B"

lemma wens_set_imp_co: "A \<in> wens_set F B ==> F \<in> (A-B) co A"
apply (erule wens_set.induct)
  apply (simp add: constrains_def)
 apply (drule_tac act1=act and A1=X
        in constrains_Un [OF Diff_wens_constrains])
 apply (erule constrains_weaken, blast)
 apply (simp add: wens_weakening)
apply (rule constrains_weaken)
apply (rule_tac I=W and A="\<lambda>v. v-B" and A'="\<lambda>v. v" in constrains_UN, blast+)
done

lemma wens_set_imp_leadsTo: "A \<in> wens_set F B ==> F \<in> A leadsTo B"
apply (erule wens_set.induct)
  apply (rule leadsTo_refl)
 apply (blast intro: wens_ensures leadsTo_Trans)
apply (blast intro: leadsTo_Union)
done

lemma leadsTo_imp_wens_set: "F \<in> A leadsTo B ==> \<exists>C \<in> wens_set F B. A \<subseteq> C"
apply (erule leadsTo_induct_pre)
  apply (blast dest!: ensures_imp_wens intro: wens_set.Basis wens_set.Wens)
 apply (clarify, drule ensures_weaken_R, assumption)
 apply (blast dest!: ensures_imp_wens intro: wens_set.Wens)
apply (case_tac "S={}")
 apply (simp, blast intro: wens_set.Basis)
apply (clarsimp dest!: bchoice simp: ball_conj_distrib Bex_def)
apply (rule_tac x = "\<Union>{Z. \<exists>U\<in>S. Z = f U}" in exI)
apply (blast intro: wens_set.Union)
done

text\<open>Assertion (9): 4.27 in the thesis.\<close>
lemma leadsTo_iff_wens_set: "(F \<in> A leadsTo B) = (\<exists>C \<in> wens_set F B. A \<subseteq> C)"
by (blast intro: leadsTo_imp_wens_set leadsTo_weaken_L wens_set_imp_leadsTo)

text\<open>This is the result that requires the definition of @{term wens_set} to
  require @{term W} to be non-empty in the Unio case, for otherwise we should
  always have @{term "{} \<in> wens_set F B"}.\<close>
lemma wens_set_imp_subset: "A \<in> wens_set F B ==> B \<subseteq> A"
apply (erule wens_set.induct)
  apply (blast intro: wens_weakening [THEN subsetD])+
done

subsection\<open>Properties Involving Program Union\<close>

text\<open>Assertion (4.30) of thesis, reoriented\<close>
lemma awp_Join_eq: "awp (F\<squnion>G) B = awp F B \<inter> awp G B"
by (simp add: awp_def wp_def, blast)

lemma wens_subset: "wens F act B - B \<subseteq> wp act B \<inter> awp F (B \<union> wens F act B)"
by (subst wens_unfold, fast)

text\<open>Assertion (4.31)\<close>
lemma subset_wens_Join:
      "[|A = T \<inter> wens F act B;  T-B \<subseteq> awp F T; A-B \<subseteq> awp G (A \<union> B)|]
       ==> A \<subseteq> wens (F\<squnion>G) act B"
apply (subgoal_tac "(T \<inter> wens F act B) - B \<subseteq>
                    wp act B \<inter> awp F (B \<union> wens F act B) \<inter> awp F T")
 apply (rule subset_wens)
 apply (simp add: awp_Join_eq awp_Int_eq Un_commute)
 apply (simp add: awp_def wp_def, blast)
apply (insert wens_subset [of F act B], blast)
done

text\<open>Assertion (4.32)\<close>
lemma wens_Join_subset: "wens (F\<squnion>G) act B \<subseteq> wens F act B"
apply (simp add: wens_def)
apply (rule gfp_mono)
apply (auto simp add: awp_Join_eq)
done

text\<open>Lemma, because the inductive step is just too messy.\<close>
lemma wens_Union_inductive_step:
  assumes awpF: "T-B \<subseteq> awp F T"
      and awpG: "!!X. X \<in> wens_set F B ==> (T\<inter>X) - B \<subseteq> awp G (T\<inter>X)"
  shows "[|X \<in> wens_set F B; act \<in> Acts F; Y \<subseteq> X; T\<inter>X = T\<inter>Y|]
         ==> wens (F\<squnion>G) act Y \<subseteq> wens F act X \<and>
             T \<inter> wens F act X = T \<inter> wens (F\<squnion>G) act Y"
apply (subgoal_tac "wens (F\<squnion>G) act Y \<subseteq> wens F act X")
 prefer 2
 apply (blast dest: wens_mono intro: wens_Join_subset [THEN subsetD], simp)
apply (rule equalityI)
 prefer 2 apply blast
apply (simp add: Int_lower1)
apply (frule wens_set_imp_subset)
apply (subgoal_tac "T-X \<subseteq> awp F T")
 prefer 2 apply (blast intro: awpF [THEN subsetD])
apply (rule_tac B = "wens (F\<squnion>G) act (T\<inter>X)" in subset_trans)
 prefer 2 apply (blast intro!: wens_mono)
apply (subst wens_Int_eq, assumption+)
apply (rule subset_wens_Join [of _ T], simp, blast)
apply (subgoal_tac "T \<inter> wens F act (T\<inter>X) \<union> T\<inter>X = T \<inter> wens F act X")
 prefer 2
 apply (subst wens_Int_eq [symmetric], assumption+)
 apply (blast intro: wens_weakening [THEN subsetD], simp)
apply (blast intro: awpG [THEN subsetD] wens_set.Wens)
done

theorem wens_Union:
  assumes awpF: "T-B \<subseteq> awp F T"
      and awpG: "!!X. X \<in> wens_set F B ==> (T\<inter>X) - B \<subseteq> awp G (T\<inter>X)"
      and major: "X \<in> wens_set F B"
  shows "\<exists>Y \<in> wens_set (F\<squnion>G) B. Y \<subseteq> X & T\<inter>X = T\<inter>Y"
apply (rule wens_set.induct [OF major])
  txt\<open>Basis: trivial\<close>
  apply (blast intro: wens_set.Basis)
 txt\<open>Inductive step\<close>
 apply clarify
 apply (rule_tac x = "wens (F\<squnion>G) act Y" in rev_bexI)
  apply (force intro: wens_set.Wens)
 apply (simp add: wens_Union_inductive_step [OF awpF awpG])
txt\<open>Union: by Axiom of Choice\<close>
apply (simp add: ball_conj_distrib Bex_def)
apply (clarify dest!: bchoice)
apply (rule_tac x = "\<Union>{Z. \<exists>U\<in>W. Z = f U}" in exI)
apply (blast intro: wens_set.Union)
done

theorem leadsTo_Join:
  assumes leadsTo: "F \<in> A leadsTo B"
      and awpF: "T-B \<subseteq> awp F T"
      and awpG: "!!X. X \<in> wens_set F B ==> (T\<inter>X) - B \<subseteq> awp G (T\<inter>X)"
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B"
apply (rule leadsTo [THEN leadsTo_imp_wens_set, THEN bexE])
apply (rule wens_Union [THEN bexE])
   apply (rule awpF)
  apply (erule awpG, assumption)
apply (blast intro: wens_set_imp_leadsTo [THEN leadsTo_weaken_L])
done

subsection \<open>The Set @{term "wens_set F B"} for a Single-Assignment Program\<close>
text\<open>Thesis Section 4.3.3\<close>

text\<open>We start by proving laws about single-assignment programs\<close>
lemma awp_single_eq [simp]:
     "awp (mk_program (init, {act}, allowed)) B = B \<inter> wp act B"
by (force simp add: awp_def wp_def)

lemma wp_Un_subset: "wp act A \<union> wp act B \<subseteq> wp act (A \<union> B)"
by (force simp add: wp_def)

lemma wp_Un_eq: "single_valued act ==> wp act (A \<union> B) = wp act A \<union> wp act B"
apply (rule equalityI)
 apply (force simp add: wp_def single_valued_def)
apply (rule wp_Un_subset)
done

lemma wp_UN_subset: "(\<Union>i\<in>I. wp act (A i)) \<subseteq> wp act (\<Union>i\<in>I. A i)"
by (force simp add: wp_def)

lemma wp_UN_eq:
     "[|single_valued act; I\<noteq>{}|]
      ==> wp act (\<Union>i\<in>I. A i) = (\<Union>i\<in>I. wp act (A i))"
apply (rule equalityI)
 prefer 2 apply (rule wp_UN_subset)
 apply (simp add: wp_def Image_INT_eq)
done

lemma wens_single_eq:
     "wens (mk_program (init, {act}, allowed)) act B = B \<union> wp act B"
by (simp add: wens_def gfp_def wp_def, blast)

text\<open>Next, we express the @{term "wens_set"} for single-assignment programs\<close>

definition wens_single_finite :: "[('a*'a) set, 'a set, nat] => 'a set" where
    "wens_single_finite act B k == \<Union>i \<in> atMost k. (wp act ^^ i) B"

definition wens_single :: "[('a*'a) set, 'a set] => 'a set" where
    "wens_single act B == \<Union>i. (wp act ^^ i) B"

lemma wens_single_Un_eq:
      "single_valued act
       ==> wens_single act B \<union> wp act (wens_single act B) = wens_single act B"
apply (rule equalityI)
 apply (simp_all add: Un_upper1)
apply (simp add: wens_single_def wp_UN_eq, clarify)
apply (rule_tac a="Suc xa" in UN_I, auto)
done

lemma atMost_nat_nonempty: "atMost (k::nat) \<noteq> {}"
by force

lemma wens_single_finite_0 [simp]: "wens_single_finite act B 0 = B"
by (simp add: wens_single_finite_def)

lemma wens_single_finite_Suc:
      "single_valued act
       ==> wens_single_finite act B (Suc k) =
           wens_single_finite act B k \<union> wp act (wens_single_finite act B k)"
apply (simp add: wens_single_finite_def image_def
                 wp_UN_eq [OF _ atMost_nat_nonempty])
apply (force elim!: le_SucE)
done

lemma wens_single_finite_Suc_eq_wens:
     "single_valued act
       ==> wens_single_finite act B (Suc k) =
           wens (mk_program (init, {act}, allowed)) act
                (wens_single_finite act B k)"
by (simp add: wens_single_finite_Suc wens_single_eq)

lemma def_wens_single_finite_Suc_eq_wens:
     "[|F = mk_program (init, {act}, allowed); single_valued act|]
       ==> wens_single_finite act B (Suc k) =
           wens F act (wens_single_finite act B k)"
by (simp add: wens_single_finite_Suc_eq_wens)

lemma wens_single_finite_Un_eq:
      "single_valued act
       ==> wens_single_finite act B k \<union> wp act (wens_single_finite act B k)
           \<in> range (wens_single_finite act B)"
by (simp add: wens_single_finite_Suc [symmetric])

lemma wens_single_eq_Union:
      "wens_single act B = \<Union>range (wens_single_finite act B)"
by (simp add: wens_single_finite_def wens_single_def, blast)

lemma wens_single_finite_eq_Union:
     "wens_single_finite act B n = (\<Union>k\<in>atMost n. wens_single_finite act B k)"
apply (auto simp add: wens_single_finite_def)
apply (blast intro: le_trans)
done

lemma wens_single_finite_mono:
     "m \<le> n ==> wens_single_finite act B m \<subseteq> wens_single_finite act B n"
by (force simp add:  wens_single_finite_eq_Union [of act B n])

lemma wens_single_finite_subset_wens_single:
      "wens_single_finite act B k \<subseteq> wens_single act B"
by (simp add: wens_single_eq_Union, blast)

lemma subset_wens_single_finite:
      "[|W \<subseteq> wens_single_finite act B ` (atMost k); single_valued act; W\<noteq>{}|]
       ==> \<exists>m. \<Union>W = wens_single_finite act B m"
apply (induct k)
 apply (rule_tac x=0 in exI, simp, blast)
apply (auto simp add: atMost_Suc)
apply (case_tac "wens_single_finite act B (Suc k) \<in> W")
 prefer 2 apply blast
apply (drule_tac x="Suc k" in spec)
apply (erule notE, rule equalityI)
 prefer 2 apply blast
apply (subst wens_single_finite_eq_Union)
apply (simp add: atMost_Suc, blast)
done

text\<open>lemma for Union case\<close>
lemma Union_eq_wens_single:
      "\<lbrakk>\<forall>k. \<not> W \<subseteq> wens_single_finite act B ` {..k};
        W \<subseteq> insert (wens_single act B)
            (range (wens_single_finite act B))\<rbrakk>
       \<Longrightarrow> \<Union>W = wens_single act B"
apply (cases "wens_single act B \<in> W")
 apply (blast dest: wens_single_finite_subset_wens_single [THEN subsetD])
apply (simp add: wens_single_eq_Union)
apply (rule equalityI, blast)
apply (simp add: UN_subset_iff, clarify)
apply (subgoal_tac "\<exists>y\<in>W. \<exists>n. y = wens_single_finite act B n & i\<le>n")
 apply (blast intro: wens_single_finite_mono [THEN subsetD])
apply (drule_tac x=i in spec)
apply (force simp add: atMost_def)
done

lemma wens_set_subset_single:
      "single_valued act
       ==> wens_set (mk_program (init, {act}, allowed)) B \<subseteq>
           insert (wens_single act B) (range (wens_single_finite act B))"
apply (rule subsetI)
apply (erule wens_set.induct)
  txt\<open>Basis\<close>
  apply (fastforce simp add: wens_single_finite_def)
 txt\<open>Wens inductive step\<close>
 apply (case_tac "acta = Id", simp)
 apply (simp add: wens_single_eq)
 apply (elim disjE)
 apply (simp add: wens_single_Un_eq)
 apply (force simp add: wens_single_finite_Un_eq)
txt\<open>Union inductive step\<close>
apply (case_tac "\<exists>k. W \<subseteq> wens_single_finite act B ` (atMost k)")
 apply (blast dest!: subset_wens_single_finite, simp)
apply (rule disjI1 [OF Union_eq_wens_single], blast+)
done

lemma wens_single_finite_in_wens_set:
      "single_valued act \<Longrightarrow>
         wens_single_finite act B k
         \<in> wens_set (mk_program (init, {act}, allowed)) B"
apply (induct_tac k)
 apply (simp add: wens_single_finite_def wens_set.Basis)
apply (simp add: wens_set.Wens
                 wens_single_finite_Suc_eq_wens [of act B _ init allowed])
done

lemma single_subset_wens_set:
      "single_valued act
       ==> insert (wens_single act B) (range (wens_single_finite act B)) \<subseteq>
           wens_set (mk_program (init, {act}, allowed)) B"
apply (simp add: image_def wens_single_eq_Union)
apply (blast intro: wens_set.Union wens_single_finite_in_wens_set)
done

text\<open>Theorem (4.29)\<close>
theorem wens_set_single_eq:
     "[|F = mk_program (init, {act}, allowed); single_valued act|]
      ==> wens_set F B =
          insert (wens_single act B) (range (wens_single_finite act B))"
apply (rule equalityI)
 apply (simp add: wens_set_subset_single)
apply (erule ssubst, erule single_subset_wens_set)
done

text\<open>Generalizing Misra's Fixed Point Union Theorem (4.41)\<close>

lemma fp_leadsTo_Join:
    "[|T-B \<subseteq> awp F T; T-B \<subseteq> FP G; F \<in> A leadsTo B|] ==> F\<squnion>G \<in> T\<inter>A leadsTo B"
apply (rule leadsTo_Join, assumption, blast)
apply (simp add: FP_def awp_iff_constrains stable_def constrains_def, blast)
done

end


(*  Authors:  Klaus Aehlig, Tobias Nipkow *)

section {* Testing implementation of normalization by evaluation *}

theory Normalization_by_Evaluation
imports Complex_Main
begin

lemma "True" by normalization
lemma "p \<longrightarrow> True" by normalization
declare disj_assoc [code nbe]
lemma "((P | Q) | R) = (P | (Q | R))" by normalization
lemma "0 + (n::nat) = n" by normalization
lemma "0 + Suc n = Suc n" by normalization
lemma "Suc n + Suc m = n + Suc (Suc m)" by normalization
lemma "~((0::nat) < (0::nat))" by normalization

datatype n = Z | S n

primrec add :: "n \<Rightarrow> n \<Rightarrow> n" where
   "add Z = id"
 | "add (S m) = S o add m"

primrec add2 :: "n \<Rightarrow> n \<Rightarrow> n" where
   "add2 Z n = n"
 | "add2 (S m) n = S(add2 m n)"

declare add2.simps [code]
lemma [code nbe]: "add2 (add2 n m) k = add2 n (add2 m k)"
  by (induct n) auto

lemma "add2 (add2 n m) k = add2 n (add2 m k)" by normalization
lemma "add2 (add2 (S n) (S m)) (S k) = S(S(S(add2 n (add2 m k))))" by normalization
lemma "add2 (add2 (S n) (add2 (S m) Z)) (S k) = S(S(S(add2 n (add2 m k))))" by normalization

primrec mul :: "n \<Rightarrow> n \<Rightarrow> n" where
   "mul Z = (%n. Z)"
 | "mul (S m) = (%n. add (mul m n) n)"

primrec mul2 :: "n \<Rightarrow> n \<Rightarrow> n" where
   "mul2 Z n = Z"
 | "mul2 (S m) n = add2 n (mul2 m n)"

primrec exp :: "n \<Rightarrow> n \<Rightarrow> n" where
   "exp m Z = S Z"
 | "exp m (S n) = mul (exp m n) m"

lemma "mul2 (S(S(S(S(S Z))))) (S(S(S Z))) = S(S(S(S(S(S(S(S(S(S(S(S(S(S(S Z))))))))))))))" by normalization
lemma "mul (S(S(S(S(S Z))))) (S(S(S Z))) = S(S(S(S(S(S(S(S(S(S(S(S(S(S(S Z))))))))))))))" by normalization
lemma "exp (S(S Z)) (S(S(S(S Z)))) = exp (S(S(S(S Z)))) (S(S Z))" by normalization

lemma "(let ((x,y),(u,v)) = ((Z,Z),(Z,Z)) in add (add x y) (add u v)) = Z" by normalization
lemma "split (%x y. x) (a, b) = a" by normalization
lemma "(%((x,y),(u,v)). add (add x y) (add u v)) ((Z,Z),(Z,Z)) = Z" by normalization

lemma "case Z of Z \<Rightarrow> True | S x \<Rightarrow> False" by normalization

lemma "[] @ [] = []" by normalization
lemma "map f [x,y,z::'x] = [f x, f y, f z]" by normalization
lemma "[a, b, c] @ xs = a # b # c # xs" by normalization
lemma "[] @ xs = xs" by normalization
lemma "map (%f. f True) [id, g, Not] = [True, g True, False]" by normalization

lemma "map (%f. f True) ([id, g, Not] @ fs) = [True, g True, False] @ map (%f. f True) fs"
  by normalization rule
lemma "rev [a, b, c] = [c, b, a]" by normalization
value "rev (a#b#cs) = rev cs @ [b, a]"
value "map (%F. F [a,b,c::'x]) (map map [f,g,h])"
value "map (%F. F ([a,b,c] @ ds)) (map map ([f,g,h]@fs))"
value "map (%F. F [Z,S Z,S(S Z)]) (map map [S,add (S Z),mul (S(S Z)),id])"
lemma "map (%x. case x of None \<Rightarrow> False | Some y \<Rightarrow> True) [None, Some ()] = [False, True]"
  by normalization
value "case xs of [] \<Rightarrow> True | x#xs \<Rightarrow> False"
value "map (%x. case x of None \<Rightarrow> False | Some y \<Rightarrow> True) xs = P"
lemma "let x = y in [x, x] = [y, y]" by normalization
lemma "Let y (%x. [x,x]) = [y, y]" by normalization
value "case n of Z \<Rightarrow> True | S x \<Rightarrow> False"
lemma "(%(x,y). add x y) (S z,S z) = S (add z (S z))" by normalization
value "filter (%x. x) ([True,False,x]@xs)"
value "filter Not ([True,False,x]@xs)"

lemma "[x,y,z] @ [a,b,c] = [x, y, z, a, b, c]" by normalization
lemma "(%(xs, ys). xs @ ys) ([a, b, c], [d, e, f]) = [a, b, c, d, e, f]" by normalization
lemma "map (%x. case x of None \<Rightarrow> False | Some y \<Rightarrow> True) [None, Some ()] = [False, True]" by normalization

lemma "last [a, b, c] = c" by normalization
lemma "last ([a, b, c] @ xs) = last (c # xs)" by normalization

lemma "(2::int) + 3 - 1 + (- k) * 2 = 4 + - k * 2" by normalization
lemma "(-4::int) * 2 = -8" by normalization
lemma "abs ((-4::int) + 2 * 1) = 2" by normalization
lemma "(2::int) + 3 = 5" by normalization
lemma "(2::int) + 3 * (- 4) * (- 1) = 14" by normalization
lemma "(2::int) + 3 * (- 4) * 1 + 0 = -10" by normalization
lemma "(2::int) < 3" by normalization
lemma "(2::int) <= 3" by normalization
lemma "abs ((-4::int) + 2 * 1) = 2" by normalization
lemma "4 - 42 * abs (3 + (-7\<Colon>int)) = -164" by normalization
lemma "(if (0\<Colon>nat) \<le> (x\<Colon>nat) then 0\<Colon>nat else x) = 0" by normalization
lemma "4 = Suc (Suc (Suc (Suc 0)))" by normalization
lemma "nat 4 = Suc (Suc (Suc (Suc 0)))" by normalization
lemma "[Suc 0, 0] = [Suc 0, 0]" by normalization
lemma "max (Suc 0) 0 = Suc 0" by normalization
lemma "(42::rat) / 1704 = 1 / 284 + 3 / 142" by normalization
value "Suc 0 \<in> set ms"

(* non-left-linear patterns, equality by extensionality *)

lemma "f = f" by normalization
lemma "f x = f x" by normalization
lemma "(f o g) x = f (g x)" by normalization
lemma "(f o id) x = f x" by normalization
lemma "(id :: bool \<Rightarrow> bool) = id" by normalization
value "(\<lambda>x. x)"

(* Church numerals: *)

value "(%m n f x. m f (n f x)) (%f x. f(f(f(x)))) (%f x. f(f(f(x))))"
value "(%m n f x. m (n f) x) (%f x. f(f(f(x)))) (%f x. f(f(f(x))))"
value "(%m n. n m) (%f x. f(f(f(x)))) (%f x. f(f(f(x))))"

(* handling of type classes in connection with equality *)

lemma "map f [x, y] = [f x, f y]" by normalization
lemma "(map f [x, y], w) = ([f x, f y], w)" by normalization
lemma "map f [x, y] = [f x \<Colon> 'a\<Colon>semigroup_add, f y]" by normalization
lemma "map f [x \<Colon> 'a\<Colon>semigroup_add, y] = [f x, f y]" by normalization
lemma "(map f [x \<Colon> 'a\<Colon>semigroup_add, y], w \<Colon> 'b\<Colon>finite) = ([f x, f y], w)" by normalization

end


(*  Title:      HOL/Library/Product_Lexorder.thy
    Author:     Norbert Voelker
*)

section \<open>Lexicographic order on product types\<close>

theory Product_Lexorder
imports MainRLT
begin

instantiation prod :: (ord, ord) ord
begin

definition
  "x \<le> y \<longleftrightarrow> fst x < fst y \<or> fst x \<le> fst y \<and> snd x \<le> snd y"

definition
  "x < y \<longleftrightarrow> fst x < fst y \<or> fst x \<le> fst y \<and> snd x < snd y"

instance ..

end

lemma less_eq_prod_simp [simp, code]:
  "(x1, y1) \<le> (x2, y2) \<longleftrightarrow> x1 < x2 \<or> x1 \<le> x2 \<and> y1 \<le> y2"
  by (simp add: less_eq_prod_def)

lemma less_prod_simp [simp, code]:
  "(x1, y1) < (x2, y2) \<longleftrightarrow> x1 < x2 \<or> x1 \<le> x2 \<and> y1 < y2"
  by (simp add: less_prod_def)

text \<open>A stronger version for partial orders.\<close>

lemma less_prod_def':
  fixes x y :: "'a::order \<times> 'b::ord"
  shows "x < y \<longleftrightarrow> fst x < fst y \<or> fst x = fst y \<and> snd x < snd y"
  by (auto simp add: less_prod_def le_less)

instance prod :: (preorder, preorder) preorder
  by standard (auto simp: less_eq_prod_def less_prod_def less_le_not_le intro: order_trans)

instance prod :: (order, order) order
  by standard (auto simp add: less_eq_prod_def)

instance prod :: (linorder, linorder) linorder
  by standard (auto simp: less_eq_prod_def)

instantiation prod :: (linorder, linorder) distrib_lattice
begin

definition
  "(inf :: 'a \<times> 'b \<Rightarrow> _ \<Rightarrow> _) = min"

definition
  "(sup :: 'a \<times> 'b \<Rightarrow> _ \<Rightarrow> _) = max"

instance
  by standard (auto simp add: inf_prod_def sup_prod_def max_min_distrib2)

end

instantiation prod :: (bot, bot) bot
begin

definition
  "bot = (bot, bot)"

instance ..

end

instance prod :: (order_bot, order_bot) order_bot
  by standard (auto simp add: bot_prod_def)

instantiation prod :: (top, top) top
begin

definition
  "top = (top, top)"

instance ..

end

instance prod :: (order_top, order_top) order_top
  by standard (auto simp add: top_prod_def)

instance prod :: (wellorder, wellorder) wellorder
proof
  fix P :: "'a \<times> 'b \<Rightarrow> bool" and z :: "'a \<times> 'b"
  assume P: "\<And>x. (\<And>y. y < x \<Longrightarrow> P y) \<Longrightarrow> P x"
  show "P z"
  proof (induct z)
    case (Pair a b)
    show "P (a, b)"
    proof (induct a arbitrary: b rule: less_induct)
      case (less a\<^sub>1) note a\<^sub>1 = this
      show "P (a\<^sub>1, b)"
      proof (induct b rule: less_induct)
        case (less b\<^sub>1) note b\<^sub>1 = this
        show "P (a\<^sub>1, b\<^sub>1)"
        proof (rule P)
          fix p assume p: "p < (a\<^sub>1, b\<^sub>1)"
          show "P p"
          proof (cases "fst p < a\<^sub>1")
            case True
            then have "P (fst p, snd p)" by (rule a\<^sub>1)
            then show ?thesis by simp
          next
            case False
            with p have 1: "a\<^sub>1 = fst p" and 2: "snd p < b\<^sub>1"
              by (simp_all add: less_prod_def')
            from 2 have "P (a\<^sub>1, snd p)" by (rule b\<^sub>1)
            with 1 show ?thesis by simp
          qed
        qed
      qed
    qed
  qed
qed

text \<open>Legacy lemma bindings\<close>

lemmas prod_le_def = less_eq_prod_def
lemmas prod_less_def = less_prod_def
lemmas prod_less_eq = less_prod_def'

end


(* Author: Tobias Nipkow *)

section \<open>Queue Implementation via 2 Lists\<close>

theory Queue_2Lists
imports
  Queue_Spec
  Reverse
begin

text \<open>Definitions:\<close>

type_synonym 'a queue = "'a list \<times> 'a list"

fun norm :: "'a queue \<Rightarrow> 'a queue" where
"norm (fs,rs) = (if fs = [] then (itrev rs [], []) else (fs,rs))"

fun enq :: "'a \<Rightarrow> 'a queue \<Rightarrow> 'a queue" where
"enq a (fs,rs) = norm(fs, a # rs)"

fun deq :: "'a queue \<Rightarrow> 'a queue" where
"deq (fs,rs) = (if fs = [] then (fs,rs) else norm(tl fs,rs))"

fun first :: "'a queue \<Rightarrow> 'a" where
"first (a # fs,rs) = a"

fun is_empty :: "'a queue \<Rightarrow> bool" where
"is_empty (fs,rs) = (fs = [])"

fun list :: "'a queue \<Rightarrow> 'a list" where
"list (fs,rs) = fs @ rev rs"

fun invar :: "'a queue \<Rightarrow> bool" where
"invar (fs,rs) = (fs = [] \<longrightarrow> rs = [])"

text \<open>Implementation correctness:\<close>

interpretation Queue
where empty = "([],[])" and enq = enq and deq = deq and first = first
and is_empty = is_empty and list = list and invar = invar
proof (standard, goal_cases)
  case 1 show ?case by (simp)
next
  case (2 q) thus ?case by(cases q) (simp)
next
  case (3 q) thus ?case by(cases q) (simp add: itrev_Nil)
next
  case (4 q) thus ?case by(cases q) (auto simp: neq_Nil_conv)
next
  case (5 q) thus ?case by(cases q) (auto)
next
  case 6 show ?case by(simp)
next
  case (7 q) thus ?case by(cases q) (simp)
next
  case (8 q) thus ?case by(cases q) (simp)
qed

text \<open>Running times:\<close>

fun T_norm :: "'a queue \<Rightarrow> nat" where
"T_norm (fs,rs) = (if fs = [] then T_itrev rs [] else 0) + 1"

fun T_enq :: "'a \<Rightarrow> 'a queue \<Rightarrow> nat" where
"T_enq a (fs,rs) = T_norm(fs, a # rs) + 1"

fun T_deq :: "'a queue \<Rightarrow> nat" where
"T_deq (fs,rs) = (if fs = [] then 0 else T_norm(tl fs,rs)) + 1"

fun T_first :: "'a queue \<Rightarrow> nat" where
"T_first (a # fs,rs) = 1"

fun T_is_empty :: "'a queue \<Rightarrow> nat" where
"T_is_empty (fs,rs) = 1"

text \<open>Amortized running times:\<close>

fun \<Phi> :: "'a queue \<Rightarrow> nat" where
"\<Phi>(fs,rs) = length rs"

lemma a_enq: "T_enq a (fs,rs) + \<Phi>(enq a (fs,rs)) - \<Phi>(fs,rs) \<le> 4"
by(auto simp: T_itrev)

lemma a_deq: "T_deq (fs,rs) + \<Phi>(deq (fs,rs)) - \<Phi>(fs,rs) \<le> 3"
by(auto simp: T_itrev)

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{May:1952} 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[Chapter V.1]{Arrow:1963}.

The following is a mechanisation of Sen's generalisation
\cite[Chapter~5*]{Sen:70a}; 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[p72]{Sen:70a}.\<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{May:1952} 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{May:1953} 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{GoodinList:2006} 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
(*>*)


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

section {* Quotient infrastructure for the set type *}

theory Quotient_Set
imports Main Quotient_Syntax
begin

subsection {* Contravariant set map (vimage) and set relator, rules for the Quotient package *}

definition "rel_vset R xs ys \<equiv> \<forall>x y. R x y \<longrightarrow> x \<in> xs \<longleftrightarrow> y \<in> ys"

lemma rel_vset_eq [id_simps]:
  "rel_vset op = = op ="
  by (subst fun_eq_iff, subst fun_eq_iff) (simp add: set_eq_iff rel_vset_def)

lemma rel_vset_equivp:
  assumes e: "equivp R"
  shows "rel_vset R xs ys \<longleftrightarrow> xs = ys \<and> (\<forall>x y. x \<in> xs \<longrightarrow> R x y \<longrightarrow> y \<in> xs)"
  unfolding rel_vset_def
  using equivp_reflp[OF e]
  by auto (metis, metis equivp_symp[OF e])

lemma set_quotient [quot_thm]:
  assumes "Quotient3 R Abs Rep"
  shows "Quotient3 (rel_vset R) (vimage Rep) (vimage Abs)"
proof (rule Quotient3I)
  from assms have "\<And>x. Abs (Rep x) = x" by (rule Quotient3_abs_rep)
  then show "\<And>xs. Rep -` (Abs -` xs) = xs"
    unfolding vimage_def by auto
next
  show "\<And>xs. rel_vset R (Abs -` xs) (Abs -` xs)"
    unfolding rel_vset_def vimage_def
    by auto (metis Quotient3_rel_abs[OF assms])+
next
  fix r s
  show "rel_vset R r s = (rel_vset R r r \<and> rel_vset R s s \<and> Rep -` r = Rep -` s)"
    unfolding rel_vset_def vimage_def set_eq_iff
    by auto (metis rep_abs_rsp[OF assms] assms[simplified Quotient3_def])+
qed

declare [[mapQ3 set = (rel_vset, set_quotient)]]

lemma empty_set_rsp[quot_respect]:
  "rel_vset R {} {}"
  unfolding rel_vset_def by simp

lemma collect_rsp[quot_respect]:
  assumes "Quotient3 R Abs Rep"
  shows "((R ===> op =) ===> rel_vset R) Collect Collect"
  by (intro rel_funI) (simp add: rel_fun_def rel_vset_def)

lemma collect_prs[quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "((Abs ---> id) ---> op -` Rep) Collect = Collect"
  unfolding fun_eq_iff
  by (simp add: Quotient3_abs_rep[OF assms])

lemma union_rsp[quot_respect]:
  assumes "Quotient3 R Abs Rep"
  shows "(rel_vset R ===> rel_vset R ===> rel_vset R) op \<union> op \<union>"
  by (intro rel_funI) (simp add: rel_vset_def)

lemma union_prs[quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "(op -` Abs ---> op -` Abs ---> op -` Rep) op \<union> = op \<union>"
  unfolding fun_eq_iff
  by (simp add: Quotient3_abs_rep[OF set_quotient[OF assms]])

lemma diff_rsp[quot_respect]:
  assumes "Quotient3 R Abs Rep"
  shows "(rel_vset R ===> rel_vset R ===> rel_vset R) op - op -"
  by (intro rel_funI) (simp add: rel_vset_def)

lemma diff_prs[quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "(op -` Abs ---> op -` Abs ---> op -` Rep) op - = op -"
  unfolding fun_eq_iff
  by (simp add: Quotient3_abs_rep[OF set_quotient[OF assms]] vimage_Diff)

lemma inter_rsp[quot_respect]:
  assumes "Quotient3 R Abs Rep"
  shows "(rel_vset R ===> rel_vset R ===> rel_vset R) op \<inter> op \<inter>"
  by (intro rel_funI) (auto simp add: rel_vset_def)

lemma inter_prs[quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "(op -` Abs ---> op -` Abs ---> op -` Rep) op \<inter> = op \<inter>"
  unfolding fun_eq_iff
  by (simp add: Quotient3_abs_rep[OF set_quotient[OF assms]])

lemma mem_prs[quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "(Rep ---> op -` Abs ---> id) op \<in> = op \<in>"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF assms])

lemma mem_rsp[quot_respect]:
  shows "(R ===> rel_vset R ===> op =) op \<in> op \<in>"
  by (intro rel_funI) (simp add: rel_vset_def)

end


(* Title:      Big Sum over Finite Sets in Abelian Semigroups
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

(*  Title:      HOL/Groups_Big.thy
    Author:     Tobias Nipkow
    Author:     Lawrence C Paulson
    Author:     Markus Wenzel
    Author:     Jeremy Avigad
*)

section \<open>Big Sum over Finite Sets in Abelian Semigroups\<close>

theory Semigroups_Big
  imports Main
begin

text \<open>
This theory is based on Isabelle/HOL's \<open>Groups_Big.thy\<close> written by T. Nipkow, L. C. Paulson, M. Wenzel and J. Avigad.
We have generalised a selection of its results from Abelian monoids to Abelian semigroups with an element that is a unit on the image of the semigroup operation.
\<close>

subsection \<open>Generic Abelian semigroup operation over a set\<close>

locale abel_semigroup_set = abel_semigroup +
  fixes z :: 'a ("\<^bold>1")
  assumes z_neutral [simp]: "x \<^bold>* y \<^bold>* \<^bold>1 = x \<^bold>* y"
  assumes z_idem [simp]: "\<^bold>1 \<^bold>* \<^bold>1 = \<^bold>1"
begin

interpretation comp_fun_commute f
  by standard (simp add: fun_eq_iff left_commute)

interpretation comp?: comp_fun_commute "f \<circ> g"
  by (fact comp_comp_fun_commute)

definition F :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> 'a"
  where eq_fold: "F g A = Finite_Set.fold (f \<circ> g) \<^bold>1 A"

lemma infinite [simp]: "\<not> finite A \<Longrightarrow> F g A = \<^bold>1"
  by (simp add: eq_fold)

lemma empty [simp]: "F g {} = \<^bold>1"
  by (simp add: eq_fold)

lemma insert [simp]: "finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> F g (insert x A) = g x \<^bold>* F g A"
  by (simp add: eq_fold)

lemma remove:
  assumes "finite A" and "x \<in> A"
  shows "F g A = g x \<^bold>* F g (A - {x})"
proof -
  from \<open>x \<in> A\<close> obtain B where B: "A = insert x B" and "x \<notin> B"
    by (auto dest: mk_disjoint_insert)
  moreover from \<open>finite A\<close> B have "finite B" by simp
  ultimately show ?thesis by simp
qed

lemma insert_remove: "finite A \<Longrightarrow> F g (insert x A) = g x \<^bold>* F g (A - {x})"
  by (cases "x \<in> A") (simp_all add: remove insert_absorb)

lemma insert_if: "finite A \<Longrightarrow> F g (insert x A) = (if x \<in> A then F g A else g x \<^bold>* F g A)"
  by (cases "x \<in> A") (simp_all add: insert_absorb)

lemma neutral: "\<forall>x\<in>A. g x = \<^bold>1 \<Longrightarrow> F g A = \<^bold>1"
  by (induct A rule: infinite_finite_induct) simp_all

lemma neutral_const [simp]: "F (\<lambda>_. \<^bold>1) A = \<^bold>1"
  by (simp add: neutral)

lemma F_one [simp]: "F g A \<^bold>* \<^bold>1 = F g A"
proof -
  have "\<And>f b B. F f (insert (b::'b) B) \<^bold>* \<^bold>1 = F f (insert b B) \<or> infinite B"
    using insert_remove by fastforce
  then show ?thesis
    by (metis (no_types) all_not_in_conv empty z_idem infinite insert_if)
qed

lemma one_F [simp]: "\<^bold>1 \<^bold>* F g A = F g A"
  using F_one commute by auto

lemma F_g_one [simp]: "F (\<lambda>x . g x \<^bold>* \<^bold>1) A = F g A"
  apply (induct A rule: infinite_finite_induct)
  apply simp
  apply simp
  by (metis one_F assoc insert)

lemma union_inter:
  assumes "finite A" and "finite B"
  shows "F g (A \<union> B) \<^bold>* F g (A \<inter> B) = F g A \<^bold>* F g B"
  \<comment> \<open>The reversed orientation looks more natural, but LOOPS as a simprule!\<close>
  using assms
proof (induct A)
  case empty
  then show ?case by simp
next
  case (insert x A)
  then show ?case
    by (auto simp: insert_absorb Int_insert_left commute [of _ "g x"] assoc left_commute)
qed

corollary union_inter_neutral:
  assumes "finite A" and "finite B"
    and "\<forall>x \<in> A \<inter> B. g x = \<^bold>1"
  shows "F g (A \<union> B) = F g A \<^bold>* F g B"
  using assms by (simp add: union_inter [symmetric] neutral)

corollary union_disjoint:
  assumes "finite A" and "finite B"
  assumes "A \<inter> B = {}"
  shows "F g (A \<union> B) = F g A \<^bold>* F g B"
  using assms by (simp add: union_inter_neutral)

lemma union_diff2:
  assumes "finite A" and "finite B"
  shows "F g (A \<union> B) = F g (A - B) \<^bold>* F g (B - A) \<^bold>* F g (A \<inter> B)"
proof -
  have "A \<union> B = A - B \<union> (B - A) \<union> A \<inter> B"
    by auto
  with assms show ?thesis
    by simp (subst union_disjoint, auto)+
qed

lemma subset_diff:
  assumes "B \<subseteq> A" and "finite A"
  shows "F g A = F g (A - B) \<^bold>* F g B"
proof -
  from assms have "finite (A - B)" by auto
  moreover from assms have "finite B" by (rule finite_subset)
  moreover from assms have "(A - B) \<inter> B = {}" by auto
  ultimately have "F g (A - B \<union> B) = F g (A - B) \<^bold>* F g B" by (rule union_disjoint)
  moreover from assms have "A \<union> B = A" by auto
  ultimately show ?thesis by simp
qed

lemma setdiff_irrelevant:
  assumes "finite A"
  shows "F g (A - {x. g x = z}) = F g A"
  using assms by (induct A) (simp_all add: insert_Diff_if)

lemma not_neutral_contains_not_neutral:
  assumes "F g A \<noteq> \<^bold>1"
  obtains a where "a \<in> A" and "g a \<noteq> \<^bold>1"
proof -
  from assms have "\<exists>a\<in>A. g a \<noteq> \<^bold>1"
  proof (induct A rule: infinite_finite_induct)
    case infinite
    then show ?case by simp
  next
    case empty
    then show ?case by simp
  next
    case (insert a A)
    then show ?case by fastforce
  qed
  with that show thesis by blast
qed

lemma cong [fundef_cong]:
  assumes "A = B"
  assumes g_h: "\<And>x. x \<in> B \<Longrightarrow> g x = h x"
  shows "F g A = F h B"
  using g_h unfolding \<open>A = B\<close>
  by (induct B rule: infinite_finite_induct) auto

lemma strong_cong [cong]:
  assumes "A = B" "\<And>x. x \<in> B =simp=> g x = h x"
  shows "F (\<lambda>x. g x) A = F (\<lambda>x. h x) B"
  by (rule cong) (use assms in \<open>simp_all add: simp_implies_def\<close>)

lemma reindex_cong:
  assumes "inj_on l B"
  assumes "A = l ` B"
  assumes "\<And>x. x \<in> B \<Longrightarrow> g (l x) = h x"
  shows "F g A = F h B"
  using assms by (simp add: reindex)

lemma UNION_disjoint:
  assumes "finite I" and "\<forall>i\<in>I. finite (A i)"
    and "\<forall>i\<in>I. \<forall>j\<in>I. i \<noteq> j \<longrightarrow> A i \<inter> A j = {}"
  shows "F g (\<Union>(A ` I)) = F (\<lambda>x. F g (A x)) I"
  apply (insert assms)
  apply (induct rule: finite_induct)
   apply simp
  apply atomize
  apply (subgoal_tac "\<forall>i\<in>Fa. x \<noteq> i")
   prefer 2 apply blast
  apply (subgoal_tac "A x \<inter> \<Union>(A ` Fa) = {}")
   prefer 2 apply blast
  apply (simp add: union_disjoint)
  done

lemma Union_disjoint:
  assumes "\<forall>A\<in>C. finite A" "\<forall>A\<in>C. \<forall>B\<in>C. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
  shows "F g (\<Union>C) = (F \<circ> F) g C"
proof (cases "finite C")
  case True
  from UNION_disjoint [OF this assms] show ?thesis by simp
next
  case False
  then show ?thesis by (auto dest: finite_UnionD intro: infinite)
qed

lemma distrib: "F (\<lambda>x. g x \<^bold>* h x) A = F g A \<^bold>* F h A"
  by (induct A rule: infinite_finite_induct) (simp_all add: assoc commute left_commute)

lemma Sigma:
  "finite A \<Longrightarrow> \<forall>x\<in>A. finite (B x) \<Longrightarrow> F (\<lambda>x. F (g x) (B x)) A = F (case_prod g) (SIGMA x:A. B x)"
  apply (subst Sigma_def)
  apply (subst UNION_disjoint)
     apply assumption
    apply simp
   apply blast
  apply (rule cong)
   apply rule
  apply (simp add: fun_eq_iff)
  apply (subst UNION_disjoint)
     apply simp
    apply simp
   apply blast
  apply (simp add: comp_def)
  done

lemma related:
  assumes Re: "R \<^bold>1 \<^bold>1"
    and Rop: "\<forall>x1 y1 x2 y2. R x1 x2 \<and> R y1 y2 \<longrightarrow> R (x1 \<^bold>* y1) (x2 \<^bold>* y2)"
    and fin: "finite S"
    and R_h_g: "\<forall>x\<in>S. R (h x) (g x)"
  shows "R (F h S) (F g S)"
  using fin by (rule finite_subset_induct) (use assms in auto)

lemma mono_neutral_cong_left:
  assumes "finite T"
    and "S \<subseteq> T"
    and "\<forall>i \<in> T - S. h i = \<^bold>1"
    and "\<And>x. x \<in> S \<Longrightarrow> g x = h x"
  shows "F g S = F h T"
proof-
  have eq: "T = S \<union> (T - S)" using \<open>S \<subseteq> T\<close> by blast
  have d: "S \<inter> (T - S) = {}" using \<open>S \<subseteq> T\<close> by blast
  from \<open>finite T\<close> \<open>S \<subseteq> T\<close> have f: "finite S" "finite (T - S)"
    by (auto intro: finite_subset)
  show ?thesis using assms(4)
    by (simp add: union_disjoint [OF f d, unfolded eq [symmetric]] neutral [OF assms(3)])
qed

lemma mono_neutral_cong_right:
  "finite T \<Longrightarrow> S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> g x = h x) \<Longrightarrow>
    F g T = F h S"
  by (auto intro!: mono_neutral_cong_left [symmetric])

lemma mono_neutral_left: "finite T \<Longrightarrow> S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> F g S = F g T"
  by (blast intro: mono_neutral_cong_left)

lemma mono_neutral_right: "finite T \<Longrightarrow> S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> F g T = F g S"
  by (blast intro!: mono_neutral_left [symmetric])

lemma mono_neutral_cong:
  assumes [simp]: "finite T" "finite S"
    and *: "\<And>i. i \<in> T - S \<Longrightarrow> h i = \<^bold>1" "\<And>i. i \<in> S - T \<Longrightarrow> g i = \<^bold>1"
    and gh: "\<And>x. x \<in> S \<inter> T \<Longrightarrow> g x = h x"
 shows "F g S = F h T"
proof-
  have "F g S = F g (S \<inter> T)"
    by(rule mono_neutral_right)(auto intro: *)
  also have "\<dots> = F h (S \<inter> T)" using refl gh by(rule cong)
  also have "\<dots> = F h T"
    by(rule mono_neutral_left)(auto intro: *)
  finally show ?thesis .
qed

lemma reindex_bij_betw: "bij_betw h S T \<Longrightarrow> F (\<lambda>x. g (h x)) S = F g T"
  by (auto simp: bij_betw_def reindex)

lemma reindex_bij_witness:
  assumes witness:
    "\<And>a. a \<in> S \<Longrightarrow> i (j a) = a"
    "\<And>a. a \<in> S \<Longrightarrow> j a \<in> T"
    "\<And>b. b \<in> T \<Longrightarrow> j (i b) = b"
    "\<And>b. b \<in> T \<Longrightarrow> i b \<in> S"
  assumes eq:
    "\<And>a. a \<in> S \<Longrightarrow> h (j a) = g a"
  shows "F g S = F h T"
proof -
  have "bij_betw j S T"
    using bij_betw_byWitness[where A=S and f=j and f'=i and A'=T] witness by auto
  moreover have "F g S = F (\<lambda>x. h (j x)) S"
    by (intro cong) (auto simp: eq)
  ultimately show ?thesis
    by (simp add: reindex_bij_betw)
qed

lemma reindex_bij_betw_not_neutral:
  assumes fin: "finite S'" "finite T'"
  assumes bij: "bij_betw h (S - S') (T - T')"
  assumes nn:
    "\<And>a. a \<in> S' \<Longrightarrow> g (h a) = z"
    "\<And>b. b \<in> T' \<Longrightarrow> g b = z"
  shows "F (\<lambda>x. g (h x)) S = F g T"
proof -
  have [simp]: "finite S \<longleftrightarrow> finite T"
    using bij_betw_finite[OF bij] fin by auto
  show ?thesis
  proof (cases "finite S")
    case True
    with nn have "F (\<lambda>x. g (h x)) S = F (\<lambda>x. g (h x)) (S - S')"
      by (intro mono_neutral_cong_right) auto
    also have "\<dots> = F g (T - T')"
      using bij by (rule reindex_bij_betw)
    also have "\<dots> = F g T"
      using nn \<open>finite S\<close> by (intro mono_neutral_cong_left) auto
    finally show ?thesis .
  next
    case False
    then show ?thesis by simp
  qed
qed

lemma reindex_nontrivial:
  assumes "finite A"
    and nz: "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<noteq> y \<Longrightarrow> h x = h y \<Longrightarrow> g (h x) = \<^bold>1"
  shows "F g (h ` A) = F (g \<circ> h) A"
proof (subst reindex_bij_betw_not_neutral [symmetric])
  show "bij_betw h (A - {x \<in> A. (g \<circ> h) x = \<^bold>1}) (h ` A - h ` {x \<in> A. (g \<circ> h) x = \<^bold>1})"
    using nz by (auto intro!: inj_onI simp: bij_betw_def)
qed (use \<open>finite A\<close> in auto)

lemma reindex_bij_witness_not_neutral:
  assumes fin: "finite S'" "finite T'"
  assumes witness:
    "\<And>a. a \<in> S - S' \<Longrightarrow> i (j a) = a"
    "\<And>a. a \<in> S - S' \<Longrightarrow> j a \<in> T - T'"
    "\<And>b. b \<in> T - T' \<Longrightarrow> j (i b) = b"
    "\<And>b. b \<in> T - T' \<Longrightarrow> i b \<in> S - S'"
  assumes nn:
    "\<And>a. a \<in> S' \<Longrightarrow> g a = z"
    "\<And>b. b \<in> T' \<Longrightarrow> h b = z"
  assumes eq:
    "\<And>a. a \<in> S \<Longrightarrow> h (j a) = g a"
  shows "F g S = F h T"
proof -
  have bij: "bij_betw j (S - (S' \<inter> S)) (T - (T' \<inter> T))"
    using witness by (intro bij_betw_byWitness[where f'=i]) auto
  have F_eq: "F g S = F (\<lambda>x. h (j x)) S"
    by (intro cong) (auto simp: eq)
  show ?thesis
    unfolding F_eq using fin nn eq
    by (intro reindex_bij_betw_not_neutral[OF _ _ bij]) auto
qed

lemma delta_remove:
  assumes fS: "finite S"
  shows "F (\<lambda>k. if k = a then b k else c k) S = (if a \<in> S then b a \<^bold>* F c (S-{a}) else F c (S-{a}))"
proof -
  let ?f = "(\<lambda>k. if k = a then b k else c k)"
  show ?thesis
  proof (cases "a \<in> S")
    case False
    then have "\<forall>k\<in>S. ?f k = c k" by simp
    with False show ?thesis by simp
  next
    case True
    let ?A = "S - {a}"
    let ?B = "{a}"
    from True have eq: "S = ?A \<union> ?B" by blast
    have dj: "?A \<inter> ?B = {}" by simp
    from fS have fAB: "finite ?A" "finite ?B" by auto
    have "F ?f S = F ?f ?A \<^bold>* F ?f ?B"
      using union_disjoint [OF fAB dj, of ?f, unfolded eq [symmetric]] by simp
    with True show ?thesis
      using abel_semigroup_set.remove abel_semigroup_set_axioms fS by fastforce
  qed
qed

lemma delta [simp]:
  assumes fS: "finite S"
  shows "F (\<lambda>k. if k = a then b k else \<^bold>1) S = (if a \<in> S then b a \<^bold>* \<^bold>1 else \<^bold>1)"
  by (simp add: delta_remove [OF assms])

lemma delta' [simp]:
  assumes fin: "finite S"
  shows "F (\<lambda>k. if a = k then b k else \<^bold>1) S = (if a \<in> S then b a \<^bold>* \<^bold>1 else \<^bold>1)"
  using delta [OF fin, of a b, symmetric] by (auto intro: cong)

lemma If_cases:
  fixes P :: "'b \<Rightarrow> bool" and g h :: "'b \<Rightarrow> 'a"
  assumes fin: "finite A"
  shows "F (\<lambda>x. if P x then h x else g x) A = F h (A \<inter> {x. P x}) \<^bold>* F g (A \<inter> - {x. P x})"
proof -
  have a: "A = A \<inter> {x. P x} \<union> A \<inter> -{x. P x}" "(A \<inter> {x. P x}) \<inter> (A \<inter> -{x. P x}) = {}"
    by blast+
  from fin have f: "finite (A \<inter> {x. P x})" "finite (A \<inter> -{x. P x})" by auto
  let ?g = "\<lambda>x. if P x then h x else g x"
  from union_disjoint [OF f a(2), of ?g] a(1) show ?thesis
    by (subst (1 2) cong) simp_all
qed

lemma cartesian_product: "F (\<lambda>x. F (g x) B) A = F (case_prod g) (A \<times> B)"
  apply (rule sym)
  apply (cases "finite A")
   apply (cases "finite B")
    apply (simp add: Sigma)
   apply (cases "A = {}")
    apply simp
   apply simp
   apply (auto intro: infinite dest: finite_cartesian_productD2)
  apply (cases "B = {}")
   apply (auto intro: infinite dest: finite_cartesian_productD1)
  done

lemma inter_restrict:
  assumes "finite A"
  shows "F g (A \<inter> B) = F (\<lambda>x. if x \<in> B then g x else \<^bold>1) A"
proof -
  let ?g = "\<lambda>x. if x \<in> A \<inter> B then g x else \<^bold>1"
  have "\<forall>i\<in>A - A \<inter> B. (if i \<in> A \<inter> B then g i else \<^bold>1) = \<^bold>1" by simp
  moreover have "A \<inter> B \<subseteq> A" by blast
  ultimately have "F ?g (A \<inter> B) = F ?g A"
    using \<open>finite A\<close> by (intro mono_neutral_left) auto
  then show ?thesis by simp
qed

lemma inter_filter:
  "finite A \<Longrightarrow> F g {x \<in> A. P x} = F (\<lambda>x. if P x then g x else \<^bold>1) A"
  by (simp add: inter_restrict [symmetric, of A "{x. P x}" g, simplified mem_Collect_eq] Int_def)

lemma Union_comp:
  assumes "\<forall>A \<in> B. finite A"
    and "\<And>A1 A2 x. A1 \<in> B \<Longrightarrow> A2 \<in> B \<Longrightarrow> A1 \<noteq> A2 \<Longrightarrow> x \<in> A1 \<Longrightarrow> x \<in> A2 \<Longrightarrow> g x = \<^bold>1"
  shows "F g (\<Union>B) = (F \<circ> F) g B"
  using assms
proof (induct B rule: infinite_finite_induct)
  case (infinite A)
  then have "\<not> finite (\<Union>A)" by (blast dest: finite_UnionD)
  with infinite show ?case by simp
next
  case empty
  then show ?case by simp
next
  case (insert A B)
  then have "finite A" "finite B" "finite (\<Union>B)" "A \<notin> B"
    and "\<forall>x\<in>A \<inter> \<Union>B. g x = \<^bold>1"
    and H: "F g (\<Union>B) = (F \<circ> F) g B" by auto
  then have "F g (A \<union> \<Union>B) = F g A \<^bold>* F g (\<Union>B)"
    by (simp add: union_inter_neutral)
  with \<open>finite B\<close> \<open>A \<notin> B\<close> show ?case
    by (simp add: H)
qed

lemma swap: "F (\<lambda>i. F (g i) B) A = F (\<lambda>j. F (\<lambda>i. g i j) A) B"
  unfolding cartesian_product
  by (rule reindex_bij_witness [where i = "\<lambda>(i, j). (j, i)" and j = "\<lambda>(i, j). (j, i)"]) auto

lemma swap_restrict:
  "finite A \<Longrightarrow> finite B \<Longrightarrow>
    F (\<lambda>x. F (g x) {y. y \<in> B \<and> R x y}) A = F (\<lambda>y. F (\<lambda>x. g x y) {x. x \<in> A \<and> R x y}) B"
  by (simp add: inter_filter) (rule swap)

lemma Plus:
  fixes A :: "'b set" and B :: "'c set"
  assumes fin: "finite A" "finite B"
  shows "F g (A <+> B) = F (g \<circ> Inl) A \<^bold>* F (g \<circ> Inr) B"
proof -
  have "A <+> B = Inl ` A \<union> Inr ` B" by auto
  moreover from fin have "finite (Inl ` A)" "finite (Inr ` B)" by auto
  moreover have "Inl ` A \<inter> Inr ` B = {}" by auto
  moreover have "inj_on Inl A" "inj_on Inr B" by (auto intro: inj_onI)
  ultimately show ?thesis
    using fin by (simp add: union_disjoint reindex)
qed

lemma same_carrier:
  assumes "finite C"
  assumes subset: "A \<subseteq> C" "B \<subseteq> C"
  assumes trivial: "\<And>a. a \<in> C - A \<Longrightarrow> g a = \<^bold>1" "\<And>b. b \<in> C - B \<Longrightarrow> h b = \<^bold>1"
  shows "F g A = F h B \<longleftrightarrow> F g C = F h C"
proof -
  have "finite A" and "finite B" and "finite (C - A)" and "finite (C - B)"
    using \<open>finite C\<close> subset by (auto elim: finite_subset)
  from subset have [simp]: "A - (C - A) = A" by auto
  from subset have [simp]: "B - (C - B) = B" by auto
  from subset have "C = A \<union> (C - A)" by auto
  then have "F g C = F g (A \<union> (C - A))" by simp
  also have "\<dots> = F g (A - (C - A)) \<^bold>* F g (C - A - A) \<^bold>* F g (A \<inter> (C - A))"
    using \<open>finite A\<close> \<open>finite (C - A)\<close> by (simp only: union_diff2)
  finally have *: "F g C = F g A" using trivial by simp
  from subset have "C = B \<union> (C - B)" by auto
  then have "F h C = F h (B \<union> (C - B))" by simp
  also have "\<dots> = F h (B - (C - B)) \<^bold>* F h (C - B - B) \<^bold>* F h (B \<inter> (C - B))"
    using \<open>finite B\<close> \<open>finite (C - B)\<close> by (simp only: union_diff2)
  finally have "F h C = F h B"
    using trivial by simp
  with * show ?thesis by simp
qed

lemma same_carrierI:
  assumes "finite C"
  assumes subset: "A \<subseteq> C" "B \<subseteq> C"
  assumes trivial: "\<And>a. a \<in> C - A \<Longrightarrow> g a = \<^bold>1" "\<And>b. b \<in> C - B \<Longrightarrow> h b = \<^bold>1"
  assumes "F g C = F h C"
  shows "F g A = F h B"
  using assms same_carrier [of C A B] by simp

end

subsection \<open>Generalized summation over a set\<close>

no_notation Sum ("\<Sum>")

class ab_semigroup_add_0 = zero + ab_semigroup_add +
  assumes zero_neutral [simp]: "x + y + 0 = x + y"
  assumes zero_idem [simp]: "0 + 0 = 0"
begin

sublocale sum_0: abel_semigroup_set plus 0
  defines sum_0 = sum_0.F
  by unfold_locales simp_all

abbreviation Sum_0 ("\<Sum>")
  where "\<Sum> \<equiv> sum_0 (\<lambda>x. x)"

end

context comm_monoid_add
begin

subclass ab_semigroup_add_0
  by unfold_locales simp_all

end

text \<open>Now: lots of fancy syntax. First, @{term "sum_0 (\<lambda>x. e) A"} is written \<open>\<Sum>x\<in>A. e\<close>.\<close>

syntax (ASCII)
  "_sum" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add"  ("(3SUM (_/:_)./ _)" [0, 51, 10] 10)
syntax
  "_sum" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add"  ("(2\<Sum>(_/\<in>_)./ _)" [0, 51, 10] 10)
translations \<comment> \<open>Beware of argument permutation!\<close>
  "\<Sum>i\<in>A. b" \<rightleftharpoons> "CONST sum_0 (\<lambda>i. b) A"

text \<open>Instead of @{term"\<Sum>x\<in>{x. P}. e"} we introduce the shorter \<open>\<Sum>x|P. e\<close>.\<close>

syntax (ASCII)
  "_qsum" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(3SUM _ |/ _./ _)" [0, 0, 10] 10)
syntax
  "_qsum" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(2\<Sum>_ | (_)./ _)" [0, 0, 10] 10)
translations
  "\<Sum>x|P. t" => "CONST sum_0 (\<lambda>x. t) {x. P}"

print_translation \<open>
let
  fun sum_tr' [Abs (x, Tx, t), Const (@{const_syntax Collect}, _) $ Abs (y, Ty, P)] =
        if x <> y then raise Match
        else
          let
            val x' = Syntax_Trans.mark_bound_body (x, Tx);
            val t' = subst_bound (x', t);
            val P' = subst_bound (x', P);
          in
            Syntax.const @{syntax_const "_qsum"} $ Syntax_Trans.mark_bound_abs (x, Tx) $ P' $ t'
          end
    | sum_tr' _ = raise Match;
in [(@{const_syntax sum_0}, K sum_tr')] end
\<close>

lemma (in ab_semigroup_add_0) sum_image_gen_0:
  assumes fin: "finite S"
  shows "sum_0 g S = sum_0 (\<lambda>y. sum_0 g {x. x \<in> S \<and> f x = y}) (f ` S)"
proof -
  have "{y. y\<in> f`S \<and> f x = y} = {f x}" if "x \<in> S" for x
    using that by auto
  then have "sum_0 g S = sum_0 (\<lambda>x. sum_0 (\<lambda>y. g x) {y. y\<in> f`S \<and> f x = y}) S"
    by simp
  also have "\<dots> = sum_0 (\<lambda>y. sum_0 g {x. x \<in> S \<and> f x = y}) (f ` S)"
    by (rule sum_0.swap_restrict [OF fin finite_imageI [OF fin]])
  finally show ?thesis .
qed

subsubsection \<open>Properties in more restricted classes of structures\<close>

lemma sum_Un2:
  assumes "finite (A \<union> B)"
  shows "sum_0 f (A \<union> B) = sum_0 f (A - B) + sum_0 f (B - A) + sum_0 f (A \<inter> B)"
proof -
  have "A \<union> B = A - B \<union> (B - A) \<union> A \<inter> B"
    by auto
  with assms show ?thesis
    by simp (subst sum_0.union_disjoint, auto)+
qed

class ordered_ab_semigroup_add_0 = ab_semigroup_add_0 + ordered_ab_semigroup_add
begin

lemma add_nonneg_nonneg [simp]: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> a + b"
  using add_mono[of 0 a 0 b] by simp

lemma add_nonpos_nonpos: "a \<le> 0 \<Longrightarrow> b \<le> 0 \<Longrightarrow> a + b \<le> 0"
  using add_mono[of a 0 b 0] by simp

end

lemma (in ordered_ab_semigroup_add_0) sum_mono:
  "(\<And>i. i\<in>K \<Longrightarrow> f i \<le> g i) \<Longrightarrow> (\<Sum>i\<in>K. f i) \<le> (\<Sum>i\<in>K. g i)"
  by (induct K rule: infinite_finite_induct) (use add_mono in auto)

lemma (in ordered_ab_semigroup_add_0) sum_mono_00:
  "(\<And>i. i\<in>K \<Longrightarrow> f i + 0 \<le> g i + 0) \<Longrightarrow> (\<Sum>i\<in>K. f i) \<le> (\<Sum>i\<in>K. g i)"
proof (induct K rule: infinite_finite_induct)
  case (infinite A)
  then show ?case by simp
next
  case empty
  then show ?case by simp
next
  case (insert x F)
  then show ?case
  proof -
    fix x :: 'b and F :: "'b set"
    assume a1: "finite F"
    assume a2: "x \<notin> F"
    assume a3: "(\<And>i. i \<in> F \<Longrightarrow> f i + 0 \<le> g i + 0) \<Longrightarrow> sum_0 f F \<le> sum_0 g F"
    assume a4: "\<And>i. i \<in> insert x F \<Longrightarrow> f i + 0 \<le> g i + 0"
    obtain bb :: 'b where
      f5: "bb \<in> F \<and> \<not> f bb + 0 \<le> g bb + 0 \<or> sum_0 f F \<le> sum_0 g F"
      using a3 by blast
    have "\<forall>b. x \<noteq> b \<or> f b + 0 \<le> g b + 0"
      using a4 by simp
    then have "\<forall>a aa. f x + 0 + a \<le> g x + 0 + aa \<or> \<not> a \<le> aa"
      using add_mono by blast
    then show "sum_0 f (insert x F) \<le> sum_0 g (insert x F)"
      using f5 a4 a2 a1 by (metis (no_types) add_assoc insert_iff sum_0.insert sum_0.one_F)
  qed
qed

lemma (in ordered_ab_semigroup_add_0) sum_mono_0:
  "(\<And>i. i\<in>K \<Longrightarrow> f i + 0 \<le> g i) \<Longrightarrow> (\<Sum>i\<in>K. f i) \<le> (\<Sum>i\<in>K. g i)"
  apply (rule sum_mono_00)
  by (metis add_right_mono zero_neutral)

context ordered_ab_semigroup_add_0
begin

lemma sum_nonneg: "(\<And>x. x \<in> A \<Longrightarrow> 0 \<le> f x) \<Longrightarrow> 0 \<le> sum_0 f A"
proof (induct A rule: infinite_finite_induct)
  case infinite
  then show ?case by simp
next
  case empty
  then show ?case by simp
next
  case (insert x F)
  then have "0 + 0 \<le> f x + sum_0 f F" by (blast intro: add_mono)
  with insert show ?case by simp
qed

lemma sum_nonpos: "(\<And>x. x \<in> A \<Longrightarrow> f x \<le> 0) \<Longrightarrow> sum_0 f A \<le> 0"
proof (induct A rule: infinite_finite_induct)
  case infinite
  then show ?case by simp
next
  case empty
  then show ?case by simp
next
  case (insert x F)
  then have "f x + sum_0 f F \<le> 0 + 0" by (blast intro: add_mono)
  with insert show ?case by simp
qed

lemma sum_mono2:
  assumes fin: "finite B"
    and sub: "A \<subseteq> B"
    and nn: "\<And>b. b \<in> B-A \<Longrightarrow> 0 \<le> f b"
  shows "sum_0 f A \<le> sum_0 f B"
proof -
  have "sum_0 f A \<le> sum_0 f A + sum_0 f (B-A)"
    by (metis add_left_mono sum_0.F_one nn sum_nonneg)
  also from fin finite_subset[OF sub fin] have "\<dots> = sum_0 f (A \<union> (B-A))"
    by (simp add: sum_0.union_disjoint del: Un_Diff_cancel)
  also from sub have "A \<union> (B-A) = B" by blast
  finally show ?thesis .
qed

lemma sum_le_included:
  assumes "finite s" "finite t"
  and "\<forall>y\<in>t. 0 \<le> g y" "(\<forall>x\<in>s. \<exists>y\<in>t. i y = x \<and> f x \<le> g y)"
  shows "sum_0 f s \<le> sum_0 g t"
proof -
  have "sum_0 f s \<le> sum_0 (\<lambda>y. sum_0 g {x. x\<in>t \<and> i x = y}) s"
  proof (rule sum_mono_0)
    fix y
    assume "y \<in> s"
    with assms obtain z where z: "z \<in> t" "y = i z" "f y \<le> g z" by auto
    hence "f y + 0 \<le> sum_0 g {z}"
      by (metis Diff_eq_empty_iff add_commute finite.simps add_left_mono sum_0.empty sum_0.insert_remove subset_insertI)
    also have "... \<le> sum_0 g {x \<in> t. i x = y}"
      apply (rule sum_mono2)
      using assms z by simp_all
    finally show "f y + 0 \<le> sum_0 g {x \<in> t. i x = y}" .
  qed
  also have "\<dots> \<le> sum_0 (\<lambda>y. sum_0 g {x. x\<in>t \<and> i x = y}) (i ` t)"
    using assms(2-4) by (auto intro!: sum_mono2 sum_nonneg)
  also have "\<dots> \<le> sum_0 g t"
    using assms by (auto simp: sum_image_gen_0[symmetric])
  finally show ?thesis .
qed

end

lemma sum_comp_morphism:
  "h 0 = 0 \<Longrightarrow> (\<And>x y. h (x + y) = h x + h y) \<Longrightarrow> sum_0 (h \<circ> g) A = h (sum_0 g A)"
  by (induct A rule: infinite_finite_induct) simp_all

lemma sum_cong_Suc:
  assumes "0 \<notin> A" "\<And>x. Suc x \<in> A \<Longrightarrow> f (Suc x) = g (Suc x)"
  shows "sum_0 f A = sum_0 g A"
proof (rule sum_0.cong)
  fix x
  assume "x \<in> A"
  with assms(1) show "f x = g x"
    by (cases x) (auto intro!: assms(2))
qed simp_all

end