src/HOL/ex/Ballot.thy
 author wenzelm Mon Aug 31 21:28:08 2015 +0200 (2015-08-31) changeset 61070 b72a990adfe2 parent 60604 dd4253d5dd82 child 61343 5b5656a63bd6 permissions -rw-r--r--
prefer symbols;
```     1 (*   Title: HOL/ex/Ballot.thy
```
```     2      Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com>
```
```     3      Author: Johannes Hölzl <hoelzl@in.tum.de>
```
```     4 *)
```
```     5
```
```     6 section {* Bertrand's Ballot Theorem *}
```
```     7
```
```     8 theory Ballot
```
```     9 imports
```
```    10   Complex_Main
```
```    11   "~~/src/HOL/Library/FuncSet"
```
```    12 begin
```
```    13
```
```    14 subsection {* Preliminaries *}
```
```    15
```
```    16 lemma card_bij':
```
```    17   assumes "f \<in> A \<rightarrow> B" "\<And>x. x \<in> A \<Longrightarrow> g (f x) = x"
```
```    18     and "g \<in> B \<rightarrow> A" "\<And>x. x \<in> B \<Longrightarrow> f (g x) = x"
```
```    19   shows "card A = card B"
```
```    20   apply (rule bij_betw_same_card)
```
```    21   apply (rule bij_betwI)
```
```    22   apply fact+
```
```    23   done
```
```    24
```
```    25 subsection {* Formalization of Problem Statement *}
```
```    26
```
```    27 subsubsection {* Basic Definitions *}
```
```    28
```
```    29 datatype vote = A | B
```
```    30
```
```    31 definition
```
```    32   "all_countings a b = card {f \<in> {1 .. a + b} \<rightarrow>\<^sub>E {A, B}.
```
```    33       card {x \<in> {1 .. a + b}. f x = A} = a \<and> card {x \<in> {1 .. a + b}. f x = B} = b}"
```
```    34
```
```    35 definition
```
```    36   "valid_countings a b =
```
```    37     card {f\<in>{1..a+b} \<rightarrow>\<^sub>E {A, B}.
```
```    38       card {x\<in>{1..a+b}. f x = A} = a \<and> card {x\<in>{1..a+b}. f x = B} = b \<and>
```
```    39       (\<forall>m\<in>{1..a+b}. card {x\<in>{1..m}. f x = A} > card {x\<in>{1..m}. f x = B})}"
```
```    40
```
```    41 subsubsection {* Equivalence with Set Cardinality *}
```
```    42
```
```    43 lemma Collect_on_transfer:
```
```    44   assumes "rel_set R X Y"
```
```    45   shows "rel_fun (rel_fun R op =) (rel_set R) (\<lambda>P. {x\<in>X. P x}) (\<lambda>P. {y\<in>Y. P y})"
```
```    46   using assms unfolding rel_fun_def rel_set_def by fast
```
```    47
```
```    48 lemma rel_fun_trans:
```
```    49   "rel_fun P Q g g' \<Longrightarrow> rel_fun R P f f' \<Longrightarrow> rel_fun R Q (\<lambda>x. g (f x)) (\<lambda>y. g' (f' y))"
```
```    50   by (auto simp: rel_fun_def)
```
```    51
```
```    52 lemma rel_fun_trans2:
```
```    53   "rel_fun P1 (rel_fun P2 Q) g g' \<Longrightarrow> rel_fun R P1 f1 f1' \<Longrightarrow> rel_fun R P2 f2 f2' \<Longrightarrow>
```
```    54     rel_fun R Q (\<lambda>x. g (f1 x) (f2 x)) (\<lambda>y. g' (f1' y) (f2' y))"
```
```    55   by (auto simp: rel_fun_def)
```
```    56
```
```    57 lemma rel_fun_trans2':
```
```    58   "rel_fun R (op =) f1 f1' \<Longrightarrow> rel_fun R (op =) f2 f2' \<Longrightarrow>
```
```    59     rel_fun R (op =) (\<lambda>x. g (f1 x) (f2 x)) (\<lambda>y. g (f1' y) (f2' y))"
```
```    60   by (auto simp: rel_fun_def)
```
```    61
```
```    62 lemma rel_fun_const: "rel_fun R (op =) (\<lambda>x. a) (\<lambda>y. a)"
```
```    63   by auto
```
```    64
```
```    65 lemma rel_fun_conj:
```
```    66   "rel_fun R (op =) f f' \<Longrightarrow> rel_fun R (op =) g g' \<Longrightarrow> rel_fun R (op =) (\<lambda>x. f x \<and> g x) (\<lambda>y. f' y \<and> g' y)"
```
```    67   by (auto simp: rel_fun_def)
```
```    68
```
```    69 lemma rel_fun_ball:
```
```    70   "(\<And>i. i \<in> I \<Longrightarrow> rel_fun R (op =) (f i) (f' i)) \<Longrightarrow> rel_fun R (op =) (\<lambda>x. \<forall>i\<in>I. f i x) (\<lambda>y. \<forall>i\<in>I. f' i y)"
```
```    71   by (auto simp: rel_fun_def rel_set_def)
```
```    72
```
```    73 lemma
```
```    74   shows all_countings_set: "all_countings a b = card {V\<in>Pow {0..<a+b}. card V = a}"
```
```    75       (is "_ = card ?A")
```
```    76     and valid_countings_set: "valid_countings a b =
```
```    77       card {V\<in>Pow {0..<a+b}. card V = a \<and> (\<forall>m\<in>{1..a+b}. card ({0..<m} \<inter> V) > m - card ({0..<m} \<inter> V))}"
```
```    78       (is "_ = card ?V")
```
```    79 proof -
```
```    80   def P \<equiv> "\<lambda>j i. i < a + b \<and> j = Suc i"
```
```    81   have unique_P: "bi_unique P" and total_P: "\<And>m. m \<le> a + b \<Longrightarrow> rel_set P {1..m} {0..<m}"
```
```    82     by (auto simp add: bi_unique_def rel_set_def P_def Suc_le_eq gr0_conv_Suc)
```
```    83   have rel_fun_P: "\<And>R f g. (\<And>i. i < a+b \<Longrightarrow> R (f  (Suc i)) (g i)) \<Longrightarrow> rel_fun P R f g"
```
```    84     by (simp add: rel_fun_def P_def)
```
```    85
```
```    86   def R \<equiv> "\<lambda>f V. V \<subseteq> {0..<a+b} \<and> f \<in> extensional {1..a+b} \<and> (\<forall>i<a+b. i \<in> V \<longleftrightarrow> f (Suc i) = A)"
```
```    87   { fix f g :: "nat \<Rightarrow> vote" assume "f \<in> extensional {1..a + b}" "g \<in> extensional {1..a + b}"
```
```    88     moreover assume "\<forall>i<a + b. (f (Suc i) = A) = (g (Suc i) = A)"
```
```    89     then have "\<forall>i<a + b. f (Suc i) = g (Suc i)"
```
```    90       by (metis vote.nchotomy)
```
```    91     ultimately have "f i = g i" for i
```
```    92       by (cases "i \<in> {1..a+b}") (auto simp: extensional_def Suc_le_eq gr0_conv_Suc) }
```
```    93   then have unique_R: "bi_unique R"
```
```    94     by (auto simp: bi_unique_def R_def)
```
```    95
```
```    96   have "f \<in> extensional {1..a + b} \<Longrightarrow> \<exists>V\<in>Pow {0..<a + b}. R f V" for f
```
```    97     by (intro bexI[of _ "{i. i < a+b \<and> f (Suc i) = A}"]) (auto simp add: R_def PiE_def)
```
```    98   moreover have "V \<in> Pow {0..<a + b} \<Longrightarrow> \<exists>f\<in>extensional {1..a+b}. R f V" for V
```
```    99     by (intro bexI[of _ "\<lambda>i\<in>{1..a+b}. if i - 1 \<in> V then A else B"]) (auto simp add: R_def PiE_def)
```
```   100   ultimately have total_R: "rel_set R (extensional {1..a+b}) (Pow {0..<a+b})"
```
```   101     by (auto simp: rel_set_def)
```
```   102
```
```   103   have P: "rel_fun R (rel_fun P op =) (\<lambda>f x. f x = A) (\<lambda>V y. y \<in> V)"
```
```   104     by (auto simp: P_def R_def Suc_le_eq gr0_conv_Suc rel_fun_def)
```
```   105
```
```   106   have eq_B: "x = B \<longleftrightarrow> x \<noteq> A" for x
```
```   107     by (cases x; simp)
```
```   108
```
```   109   { fix f and m :: nat
```
```   110     have "card {x\<in>{1..m}. f x = B} = card ({1..m} - {x\<in>{1..m}. f x = A})"
```
```   111       by (simp add: eq_B set_diff_eq cong: conj_cong)
```
```   112     also have "\<dots> = m - card {x\<in>{1..m}. f x = A}"
```
```   113       by (subst card_Diff_subset) auto
```
```   114     finally have "card {x\<in>{1..m}. f x = B} = m - card {x\<in>{1..m}. f x = A}" . }
```
```   115   note card_B = this
```
```   116
```
```   117   note transfers = rel_fun_const card_transfer[THEN rel_funD, OF unique_R] rel_fun_conj rel_fun_ball
```
```   118     Collect_on_transfer[THEN rel_funD, OF total_R] Collect_on_transfer[THEN rel_funD, OF total_P]
```
```   119     rel_fun_trans[OF card_transfer, OF unique_P] rel_fun_trans[OF Collect_on_transfer[OF total_P]]
```
```   120     rel_fun_trans2'[where g="op ="] rel_fun_trans2'[where g="op <"] rel_fun_trans2'[where g="op -"]
```
```   121
```
```   122   have "all_countings a b = card {f \<in> extensional {1..a + b}. card {x \<in> {1..a + b}. f x = A} = a}"
```
```   123     using card_B by (simp add: all_countings_def PiE_iff vote.nchotomy cong: conj_cong)
```
```   124   also have "\<dots> = card {V\<in>Pow {0..<a+b}. card ({x\<in>{0 ..< a + b}. x \<in> V}) = a}"
```
```   125     by (intro P order_refl transfers)
```
```   126   finally show "all_countings a b = card ?A"
```
```   127     unfolding Int_def[symmetric] by (simp add: Int_absorb1 cong: conj_cong)
```
```   128
```
```   129   have "valid_countings a b = card {f\<in>extensional {1..a+b}.
```
```   130       card {x\<in>{1..a+b}. f x = A} = a \<and> (\<forall>m\<in>{1..a+b}. card {x\<in>{1..m}. f x = A} > m - card {x\<in>{1..m}. f x = A})}"
```
```   131     using card_B by (simp add: valid_countings_def PiE_iff vote.nchotomy cong: conj_cong)
```
```   132   also have "\<dots> = card {V\<in>Pow {0..<a+b}. card {x\<in>{0..<a+b}. x\<in>V} = a \<and>
```
```   133     (\<forall>m\<in>{1..a+b}. card {x\<in>{0..<m}. x\<in>V} > m - card {x\<in>{0..<m}. x\<in>V})}"
```
```   134     by (intro P order_refl transfers) auto
```
```   135   finally show "valid_countings a b = card ?V"
```
```   136     unfolding Int_def[symmetric] by (simp add: Int_absorb1 cong: conj_cong)
```
```   137 qed
```
```   138
```
```   139 lemma all_countings: "all_countings a b = (a + b) choose a"
```
```   140   unfolding all_countings_set by (simp add: n_subsets)
```
```   141
```
```   142 subsection {* Facts About @{term valid_countings} *}
```
```   143
```
```   144 subsubsection {* Non-Recursive Cases *}
```
```   145
```
```   146 lemma card_V_eq_a: "V \<subseteq> {0..<a} \<Longrightarrow> card V = a \<longleftrightarrow> V = {0..<a}"
```
```   147   using card_subset_eq[of "{0..<a}" V] by auto
```
```   148
```
```   149 lemma valid_countings_a_0: "valid_countings a 0 = 1"
```
```   150   by (simp add: valid_countings_set card_V_eq_a cong: conj_cong)
```
```   151
```
```   152 lemma valid_countings_eq_zero:
```
```   153   "a \<le> b \<Longrightarrow> 0 < b \<Longrightarrow> valid_countings a b = 0"
```
```   154   by (auto simp add: valid_countings_set Int_absorb1 intro!: bexI[of _ "a + b"])
```
```   155
```
```   156 lemma Ico_subset_finite: "i \<subseteq> {a ..< b::nat} \<Longrightarrow> finite i"
```
```   157   by (auto dest: finite_subset)
```
```   158
```
```   159 lemma Icc_Suc2: "a \<le> b \<Longrightarrow> {a..Suc b} = insert (Suc b) {a..b}"
```
```   160   by auto
```
```   161
```
```   162 lemma Ico_Suc2: "a \<le> b \<Longrightarrow> {a..<Suc b} = insert b {a..<b}"
```
```   163   by auto
```
```   164
```
```   165 lemma valid_countings_Suc_Suc:
```
```   166   assumes "b < a"
```
```   167   shows "valid_countings (Suc a) (Suc b) = valid_countings a (Suc b) + valid_countings (Suc a) b"
```
```   168 proof -
```
```   169   let ?l = "Suc (a + b)"
```
```   170   let ?Q = "\<lambda>V c. \<forall>m\<in>{1..c}. m - card ({0..<m} \<inter> V) < card ({0..<m} \<inter> V)"
```
```   171   let ?V = "\<lambda>P. {V. (V \<in> Pow {0..<Suc ?l} \<and> P V) \<and> card V = Suc a \<and> ?Q V (Suc ?l)}"
```
```   172   have "valid_countings (Suc a) (Suc b) = card (?V (\<lambda>V. ?l \<notin> V)) + card (?V (\<lambda>V. ?l \<in> V))"
```
```   173     unfolding valid_countings_set
```
```   174     by (subst card_Un_disjoint[symmetric]) (auto simp add: set_eq_iff intro!: arg_cong[where f=card])
```
```   175   also have "card (?V (\<lambda>V. ?l \<in> V)) = valid_countings a (Suc b)"
```
```   176     unfolding valid_countings_set
```
```   177   proof (rule card_bij'[where f="\<lambda>V. V - {?l}" and g="insert ?l"])
```
```   178     have *: "\<And>m V. m \<in> {1..a + Suc b} \<Longrightarrow> {0..<m} \<inter> (V - {?l}) = {0..<m} \<inter> V"
```
```   179       by auto
```
```   180     show "(\<lambda>V. V - {?l}) \<in> ?V (\<lambda>V. ?l \<in> V) \<rightarrow> {V \<in> Pow {0..<a + Suc b}. card V = a \<and> ?Q V (a + Suc b)}"
```
```   181       by (auto simp: Ico_subset_finite *)
```
```   182     { fix V assume "V \<subseteq> {0..<?l}"
```
```   183       moreover then have "finite V" "?l \<notin> V" "{0..<Suc ?l} \<inter> V = V"
```
```   184         by (auto dest: finite_subset)
```
```   185       ultimately have "card (insert ?l V) = Suc (card V)"
```
```   186         "card ({0..<m} \<inter> insert ?l V) = (if m = Suc ?l then Suc (card V) else card ({0..<m} \<inter> V))"
```
```   187         if "m \<le> Suc ?l" for m
```
```   188         using that by auto }
```
```   189     then show "insert ?l \<in> {V \<in> Pow {0..<a + Suc b}. card V = a \<and> ?Q V (a + Suc b)} \<rightarrow> ?V (\<lambda>V. ?l \<in> V)"
```
```   190       using `b < a` by auto
```
```   191   qed auto
```
```   192   also have "card (?V (\<lambda>V. ?l \<notin> V)) = valid_countings (Suc a) b"
```
```   193     unfolding valid_countings_set
```
```   194   proof (intro arg_cong[where f="\<lambda>P. card {x. P x}"] ext conj_cong)
```
```   195     fix V assume "V \<in> Pow {0..<Suc a + b}" and [simp]: "card V = Suc a"
```
```   196     then have [simp]: "V \<subseteq> {0..<Suc ?l}"
```
```   197       by auto
```
```   198     show "?Q V (Suc ?l) = ?Q V (Suc a + b)"
```
```   199       using `b<a` by (simp add: Int_absorb1 Icc_Suc2)
```
```   200   qed (auto simp: subset_eq less_Suc_eq)
```
```   201   finally show ?thesis
```
```   202     by simp
```
```   203 qed
```
```   204
```
```   205 lemma valid_countings:
```
```   206   "(a + b) * valid_countings a b = (a - b) * ((a + b) choose a)"
```
```   207 proof (induct a arbitrary: b)
```
```   208   case 0 show ?case
```
```   209     by (cases b) (simp_all add: valid_countings_eq_zero)
```
```   210 next
```
```   211   case (Suc a) note Suc_a = this
```
```   212   show ?case
```
```   213   proof (induct b)
```
```   214     case (Suc b) note Suc_b = this
```
```   215     show ?case
```
```   216     proof cases
```
```   217       assume "a \<le> b" then show ?thesis
```
```   218         by (simp add: valid_countings_eq_zero)
```
```   219     next
```
```   220       assume "\<not> a \<le> b"
```
```   221       then have "b < a" by simp
```
```   222
```
```   223       have "Suc a * (a - Suc b) + (Suc a - b) * Suc b =
```
```   224         (Suc a * a - Suc a * Suc b) + (Suc a * Suc b - Suc b * b)"
```
```   225         by (simp add: sign_simps)
```
```   226       also have "\<dots> = (Suc a * a + (Suc a * Suc b - Suc b * b)) - Suc a * Suc b"
```
```   227         using `b<a` by (intro add_diff_assoc2 mult_mono) auto
```
```   228       also have "\<dots> = (Suc a * a + Suc a * Suc b) - Suc b * b - Suc a * Suc b"
```
```   229         using `b<a` by (intro arg_cong2[where f="op -"] add_diff_assoc mult_mono) auto
```
```   230       also have "\<dots> = (Suc a * Suc (a + b)) - (Suc b * Suc (a + b))"
```
```   231         by (simp add: sign_simps)
```
```   232       finally have rearrange: "Suc a * (a - Suc b) + (Suc a - b) * Suc b = (Suc a - Suc b) * Suc (a + b)"
```
```   233         unfolding diff_mult_distrib by simp
```
```   234
```
```   235       have "(Suc a * Suc (a + b)) * ((Suc a + Suc b) * valid_countings (Suc a) (Suc b)) =
```
```   236         (Suc a + Suc b) * Suc a * ((a + Suc b) * valid_countings a (Suc b) + (Suc a + b) * valid_countings (Suc a) b)"
```
```   237         unfolding valid_countings_Suc_Suc[OF `b < a`] by (simp add: field_simps)
```
```   238       also have "... = (Suc a + Suc b) * ((a - Suc b) * (Suc a * (Suc (a + b) choose a)) +
```
```   239         (Suc a - b) * (Suc a * (Suc (a + b) choose Suc a)))"
```
```   240         unfolding Suc_a Suc_b by (simp add: field_simps)
```
```   241       also have "... = (Suc a * (a - Suc b) + (Suc a - b) * Suc b) * (Suc (Suc a + b) * (Suc a + b choose a))"
```
```   242         unfolding Suc_times_binomial_add by (simp add: field_simps)
```
```   243       also have "... = Suc a * (Suc a * (a - Suc b) + (Suc a - b) * Suc b) * (Suc a + Suc b choose Suc a)"
```
```   244         unfolding Suc_times_binomial_eq by (simp add: field_simps)
```
```   245       also have "... = (Suc a * Suc (a + b)) * ((Suc a - Suc b) * (Suc a + Suc b choose Suc a))"
```
```   246         unfolding rearrange by (simp only: mult_ac)
```
```   247       finally show ?thesis
```
```   248         unfolding mult_cancel1 by simp
```
```   249     qed
```
```   250   qed (simp add: valid_countings_a_0)
```
```   251 qed
```
```   252
```
```   253 lemma valid_countings_eq[code]:
```
```   254   "valid_countings a b = (if a + b = 0 then 1 else ((a - b) * ((a + b) choose a)) div (a + b))"
```
```   255   by (simp add: valid_countings[symmetric] valid_countings_a_0)
```
```   256
```
```   257 subsection {* Relation Between @{term valid_countings} and @{term all_countings} *}
```
```   258
```
```   259 lemma main_nat: "(a + b) * valid_countings a b = (a - b) * all_countings a b"
```
```   260   unfolding valid_countings all_countings ..
```
```   261
```
```   262 lemma main_real:
```
```   263   assumes "b < a"
```
```   264   shows "valid_countings a b = (a - b) / (a + b) * all_countings a b"
```
```   265 using assms
```
```   266 proof -
```
```   267   from main_nat[of a b] `b < a` have
```
```   268     "(real a + real b) * real (valid_countings a b) = (real a - real b) * real (all_countings a b)"
```
```   269     by (simp only: real_of_nat_add[symmetric] real_of_nat_mult[symmetric]) auto
```
```   270   from this `b < a` show ?thesis
```
```   271     by (subst mult_left_cancel[of "real a + real b", symmetric]) auto
```
```   272 qed
```
```   273
```
```   274 lemma
```
```   275   "valid_countings a b = (if a \<le> b then (if b = 0 then 1 else 0) else (a - b) / (a + b) * all_countings a b)"
```
```   276 proof (cases "a \<le> b")
```
```   277   case False
```
```   278     from this show ?thesis by (simp add: main_real)
```
```   279 next
```
```   280   case True
```
```   281     from this show ?thesis
```
```   282       by (auto simp add: valid_countings_a_0 all_countings valid_countings_eq_zero)
```
```   283 qed
```
```   284
```
```   285 subsubsection {* Executable Definition *}
```
```   286
```
```   287 declare all_countings_def [code del]
```
```   288 declare all_countings[code]
```
```   289
```
```   290 value "all_countings 1 0"
```
```   291 value "all_countings 0 1"
```
```   292 value "all_countings 1 1"
```
```   293 value "all_countings 2 1"
```
```   294 value "all_countings 1 2"
```
```   295 value "all_countings 2 4"
```
```   296 value "all_countings 4 2"
```
```   297
```
```   298 subsubsection {* Executable Definition *}
```
```   299
```
```   300 declare valid_countings_def [code del]
```
```   301
```
```   302 value "valid_countings 1 0"
```
```   303 value "valid_countings 0 1"
```
```   304 value "valid_countings 1 1"
```
```   305 value "valid_countings 2 1"
```
```   306 value "valid_countings 1 2"
```
```   307 value "valid_countings 2 4"
```
```   308 value "valid_countings 4 2"
```
```   309
```
```   310 end
```