4 # Author : Manoj Srivastava ( srivasta@glaurung.green-gryphon.com )
5 # Created On : Thu Oct 16 12:08:43 2003
6 # Created On Node : glaurung.green-gryphon.com
7 # Last Modified By : Manoj Srivastava
8 # Last Modified On : Sat Mar 10 09:42:54 2007
9 # Last Machine Used: glaurung.internal.golden-gryphon.com
11 # Status : Unknown, Use with caution!
14 # arch-tag: 1a48504a-0668-4790-aa72-d4359a3c41e2
16 # This program is free software; you can redistribute it and/or modify
17 # it under the terms of the GNU General Public License as published by
18 # the Free Software Foundation; either version 2 of the License, or
19 # (at your option) any later version.
21 # This program is distributed in the hope that it will be useful,
22 # but WITHOUT ANY WARRANTY; without even the implied warranty of
23 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 # GNU General Public License for more details.
26 # You should have received a copy of the GNU General Public License
27 # along with this program; if not, write to the Free Software
28 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
36 use Carp qw(carp croak);
37 use Params::Validate qw(validate_with :types);
39 #use Math::BigInt ':constant';
44 pocket_devotee - Given a tally sheet, calculate the Condorcet winner
50 pocket_devotee --option 'A:foo' --option 'B:bar' < tally_sheet
51 pocket_devotee --num-options 3 < tally_sheet
57 Produce the results, taking into consideration the tally, quorum
58 requirements, and the per option majority requirements, if any.
59 This routine is the heart of the voting system. It takes into account
60 quorum requirements (reading the output file produced by dvt-quorum),
61 and also the configured majority requirements, if any.
63 It reads the tally sheet produced by dvt-tally, and creates the
64 initial beat matrix; and the pairwise defeat list, and finally the
65 schwartz set. If there are defeats between the members of the schwartz
66 set, it drops the weakest defeat and repeats, until there is a winner.
68 It puts the results in the configured output file.
72 =head2 Internal Implementation
76 This is the workhorse routine.
77 This routine pays attention to the configuration variables
78 Quorum_File, Tally_File, Max_Choices, and Results.
85 our %option_to_number;
86 our %number_to_option;
90 @number_to_option{((0..9),(10..35))} = (('0'..'9'),('A'..'Z'));
91 %option_to_number = reverse %number_to_option;
102 if (not exists $options{option} or not ref($options{option}) or
103 @{$options{option}} < 2
105 die "you must give at least two options in a --option argument";
108 for my $option (@{$options{option}}) {
109 my ($key,$name,$majority) = split /:/,$option;
111 push @options,{key => $key,
113 majority => $majority,
116 winner(options=>\@options);
120 return map {$option_to_number{$_}} @_;
124 return map {$number_to_option{$_}} @_;
128 my %params = validate_with(params => \@_,
129 spec => {quorum => {default => 5,
132 options => {type => ARRAYREF,
134 tally_fh => {type => HANDLE,
139 # options is an array to keep it ordered
140 my @options = @{$params{options}};
142 my %order_to_options;
145 my $valid_options = '';
146 for my $option (@options) {
147 $options{$option->{key}} =
148 {key => $option->{key},
149 name => $option->{name},
150 majority => $option->{majority} // 1,
153 $order_to_options{$order} = $options{$option->{key}};
154 $valid_options .= $option->{key};
155 $max_choices = $order;
159 # The constitution defines the maximum value of K to be 5
160 my $K = 5; # Math::BigFloat->new($params{quorum});
162 # 1. Given two options A and B, V(A,B) is the number of voters who
163 # prefer option A over option B.
164 my @Beat_Matrix = ();
165 for my $row (0..$max_choices) {
166 for my $col (0..$max_choices) {
167 $Beat_Matrix[$row][$col] = 0; #Math::BigFloat->bzero();
171 my $RESULTS = \*STDOUT;
173 my $now_string = gmtime;
174 print {$RESULTS} "Starting results calculation at $now_string\n\n";
176 if (not defined $params{tally_fh}) {
177 $params{tally_fh} = \*STDIN;
180 # This is where we get our input data from
181 while (defined ($_ = $params{tally_fh}->getline)) {
185 if (m/^V:\s+(\S+)\s+(\S)/) { # standard devotee syntax
188 } elsif (m/^(.+) # the voter, can have spaces
189 \s*:\s+ # needs a colon and a space
190 ((?:[$valid_options] # the vote
191 \s*(?:,|=|<)?\s*)*) # allow < and , or =
192 \s*$/x # useless trailing spaces
196 # now, because this format has the options ranked instead of
197 # the rank of the option, figure out the rank of the option,
198 # and give that to devotee
199 my $current_rank = 1;
201 while ($vote =~ /([$valid_options]) # the vote
202 \s*((?:,|=|<)?)\s*/xg) {
203 my ($option,$relationship) = ($1,$2);
204 $option_rank{$option} = $current_rank;
205 if ($relationship ne '=') {
210 for my $opt (@options) {
211 $vote .= exists $option_rank{$opt->{key}} ? $option_rank{$opt->{key}} : '-';
213 print {$RESULTS} "V: $vote $voter\n";
216 print STDERR "ignoring line '$_'; this is probably wrong!";
220 # my @rank = unpack "a" x $max_choices, $vote;
222 foreach my $rank (split //, uc $vote) {
227 push(@rank,encode_base64($rank));
230 foreach my $i (0..($max_choices - 1)) {
231 foreach my $j (($i + 1)..($max_choices - 1)) {
232 if ($rank[$i] eq '-' && $rank[$j] eq '-') {
233 next; # Both unranked
234 } elsif ($rank[$i] eq '-' && $rank[$j] ne '-') {
235 $Beat_Matrix[$j][$i]++;
236 } elsif ($rank[$i] ne '-' && $rank[$j] eq '-') {
237 $Beat_Matrix[$i][$j]++;
238 } elsif ($rank[$i] < $rank[$j]) {
239 $Beat_Matrix[$i][$j]++;
240 } elsif ($rank[$i] > $rank[$j]) {
241 $Beat_Matrix[$j][$i]++;
243 next; # Equally ranked
248 for my $opt (0..($max_choices - 1)) {
249 print {$RESULTS} "Option ", $order_to_options{$opt+1}{key}, " \"",
250 $order_to_options{$opt+1}{name},
253 print {$RESULTS} <<EOF;
255 In the following table, tally[row x][col y] represents the votes that
256 option x received over option y.
261 print {$RESULTS} " " x18, "Option\n";
262 print {$RESULTS} " " x10;
263 for my $col (0..($max_choices - 1)) {
264 printf {$RESULTS} " % 4s ", $order_to_options{$col + 1}{key};
267 print {$RESULTS} "\n";
268 print {$RESULTS} " " x10, " === " x $max_choices, "\n";
270 for my $row (0..($max_choices - 1)) {
271 printf {$RESULTS} "Option %s ", $order_to_options{$row + 1}{key};
272 for my $col (0..($max_choices - 1)) {
274 printf {$RESULTS} " ", $Beat_Matrix[$row][$col];
276 printf {$RESULTS} " % 4d ", $Beat_Matrix[$row][$col];
279 print {$RESULTS} "\n";
281 print {$RESULTS} "\n\n";
283 print {$RESULTS} <<EOM;
285 Looking at row 2, column 1, $order_to_options{2}{key}
286 received $Beat_Matrix[1][0] votes over $order_to_options{1}{key}
288 Looking at row 1, column 2, $order_to_options{1}{key}
289 received $Beat_Matrix[0][1] votes over $order_to_options{2}{key}.
296 foreach my $i (0..($max_choices - 2)) {
297 if ($K > $Beat_Matrix[$i][$max_choices - 1]) {
299 print {$RESULTS} "Dropping Option", $order_to_options{$i + 1}{key},
300 " \"", $order_to_options{$i + 1}{name},
301 "\" because of Quorum\n";
303 print {$RESULTS} "Option ", $order_to_options{$i + 1}{key},
304 " Reached quorum: $Beat_Matrix[$i][$max_choices - 1] > $K\n";
307 print {$RESULTS} "\n\n";
313 # 2. An option A defeats the default option D by a majority ratio N,
314 # if V(A,D) is strictly greater than N * V(D,A).
315 # 3. If a supermajority of S:1 is required for A, its majority ratio
316 # is S; otherwise, its majority ratio is 1.
317 # Any (non-default) option which does not defeat the default option
318 # by its required majority ratio is dropped from consideration.
319 foreach my $i (0..($max_choices - 2)) {
320 next unless $Beat_Matrix[$max_choices - 1][$i];
323 my $ratio = 1.0 * $Beat_Matrix[$i][$max_choices - 1] /
324 $Beat_Matrix[$max_choices - 1][$i];
325 $Ratio{$i} = sprintf("%.2f", $ratio);
326 if ($ratio < $order_to_options{$i + 1}{majority}) {
327 # If the next line is commented out, we get a more verbose set of results
329 print {$RESULTS} "Dropping Option ", $order_to_options{$i + 1}{key},
330 " because of Majority. ($ratio)";
331 printf {$RESULTS} " %6.3f (%d/%d) < %d\n",
332 $ratio, $Beat_Matrix[$i][$max_choices - 1],
333 $Beat_Matrix[$max_choices - 1][$i],
334 $order_to_options{$i + 1}{majority};
336 print {$RESULTS} "Option ", $order_to_options{$i + 1}{key}, " passes Majority.";
337 print {$RESULTS} " ";
338 printf {$RESULTS} " %6.3f (%d/%d) >= %d\n",
339 $ratio, $Beat_Matrix[$i][$max_choices - 1],
340 $Beat_Matrix[$max_choices - 1][$i],
341 $order_to_options{$i + 1}{majority};
344 print {$RESULTS} "\n\n";
348 # Initialize the Defeats matrix
349 foreach my $i (0..($max_choices - 1)) {
351 foreach my $j (($i + 1)..($max_choices - 1)) {
353 if ($Beat_Matrix[$i][$j] > $Beat_Matrix[$j][$i]) {
355 $Defeats{$i}{$j}{for} = $Beat_Matrix[$i][$j];
356 $Defeats{$i}{$j}{against} = $Beat_Matrix[$j][$i];
358 print {$RESULTS} " Option ", $order_to_options{$i + 1}{key}, " defeats Option ",
359 $order_to_options{$j + 1}{key},
360 sprintf(" by (% 4d - % 4d) = %4d votes.\n",
361 $Beat_Matrix[$i][$j], $Beat_Matrix[$j][$i],
362 $Beat_Matrix[$i][$j] - $Beat_Matrix[$j][$i]);
363 } elsif ($Beat_Matrix[$i][$j] < $Beat_Matrix[$j][$i]) {
365 $Defeats{$j}{$i}{for} = $Beat_Matrix[$j][$i];
366 $Defeats{$j}{$i}{against} = $Beat_Matrix[$i][$j];
368 print {$RESULTS} " Option ", $order_to_options{$j + 1}{key}, " defeats Option ",
369 $order_to_options{$i + 1}{key},
370 sprintf(" by (% 4d - % 4d) = %4d votes.\n",
371 $Beat_Matrix[$j][$i], $Beat_Matrix[$i][$j],
372 $Beat_Matrix[$j][$i] - $Beat_Matrix[$i][$j]);
376 print {$RESULTS} "\n\n";
379 # Ok, here is what we are here for.
382 # From the list of [undropped] pairwise defeats, we generate a set of
383 # transitive defeats.
385 # Initialize the Beatpath
387 foreach my $i (0..($max_choices - 1)) {
389 foreach my $j (0..($max_choices - 1)) {
391 $BeatPath{$i}{$j}{for} = $Defeats{$i}{$j}{for};
392 $BeatPath{$i}{$j}{against} = $Defeats{$i}{$j}{against};
396 # 1. An option A transitively defeats an option C if A defeats C or
397 # if there is some other option B where A defeats B AND B
398 # transitively defeats C.
401 foreach my $i (0..($max_choices - 1)) {
403 foreach my $j (0..($max_choices - 1)) {
406 foreach my $k (0..($max_choices - 1)) {
410 if (!$BeatPath{$i}{$j}{for}) {
411 if ($BeatPath{$i}{$k}{for} && $BeatPath{$k}{$j}{for} ) {
412 if ($BeatPath{$i}{$k}{for} == $BeatPath{$k}{$j}{for}) {
413 $BeatPath{$i}{$j}{for} = ($BeatPath{$i}{$k}{against} >
414 $BeatPath{$k}{$j}{against}) ?
415 $BeatPath{$i}{$k}{for}:$BeatPath{$k}{$j}{for};
416 $BeatPath{$i}{$j}{against} = ($BeatPath{$i}{$k}{against} >
417 $BeatPath{$k}{$j}{against}) ?
418 $BeatPath{$i}{$k}{against} :
419 $BeatPath{$k}{$j}{against};
421 $BeatPath{$i}{$j}{for} = ($BeatPath{$i}{$k}{for} <
422 $BeatPath{$k}{$j}{for}) ?
423 $BeatPath{$i}{$k}{for} :
424 $BeatPath{$k}{$j}{for};
425 $BeatPath{$i}{$j}{against} = ($BeatPath{$i}{$k}{for} <
426 $BeatPath{$k}{$j}{for}) ?
427 $BeatPath{$i}{$k}{against} :
428 $BeatPath{$k}{$j}{against};
439 # We construct the Schwartz set from the set of transitive defeats.
440 foreach my $i (0..($max_choices - 1)) {
448 foreach my $i (0..($max_choices - 1)) {
449 foreach my $j (0..($max_choices - 1)) {
451 # An option A is in the Schwartz set if for all options B, either
452 # A transitively defeats B, or B does not transitively defeat A
453 # Here, we throw out any option $i that does not meet the above
455 if (! ($BeatPath{$i}{$j}{for} || ! $BeatPath{$j}{$i}{for})) {
460 print {$RESULTS} "The Schwartz Set contains:\n";
461 foreach my $i (0 ..$#Schwartz) {
462 next unless $Schwartz[$i];
463 print {$RESULTS} "\t Option ", $order_to_options{$i + 1}{key}, " \"",
464 $order_to_options{$i + 1}{name}, "\"\n";
466 print {$RESULTS} "\n\n";
468 # If there are defeats between options in the Schwartz set, we drop
469 # the weakest such defeats from the list of pairwise defeats, and
472 # 1. A defeat (A,X) is weaker than a defeat (B,Y) if V(A,X) is
473 # less than V(B,Y). Also, (A,X) is weaker than (B,Y) if V(A,X) is
474 # equal to V(B,Y) and V(X,A) is greater than V(Y,B).
476 # 2. A weakest defeat is a defeat that has no other defeat weaker
477 # than it. There may be more than one such defeat.
479 # Check to see if there is anything in the Schwartz set that has no
483 foreach my $i (0 ..$#Schwartz) {
484 next unless $Schwartz[$i];
485 foreach my $j (0..$#Schwartz) {
486 next unless $Schwartz[$j];
488 if (defined $Defeats{$i}{$j}{'for'}) {
490 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{for};
491 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{against};
492 $Weakest{$weak_count}{'Winner'} = $i;
493 $Weakest{$weak_count}{'Loser'} = $j;
495 } elsif ($Weakest{0}{'for'} > $Defeats{$i}{$j}{for}) {
498 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{for};
499 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{against};
500 $Weakest{$weak_count}{'Winner'} = $i;
501 $Weakest{$weak_count}{'Loser'} = $j;
503 } elsif ($Weakest{0}{'for'} == $Defeats{$i}{$j}{'for'}) {
504 if ($Weakest{0}{'against'} < $Defeats{$i}{$j}{against}) {
507 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{for};
508 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{against};
509 $Weakest{$weak_count}{'Winner'} = $i;
510 $Weakest{$weak_count}{'Loser'} = $j;
513 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{'for'};
514 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{'against'};
515 $Weakest{$weak_count}{'Winner'} = $i;
516 $Weakest{$weak_count}{'Loser'} = $j;
521 if (defined $Defeats{$j}{$i}{'for'}) {
523 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
524 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
525 $Weakest{$weak_count}{'Winner'} = $j;
526 $Weakest{$weak_count}{'Loser'} = $i;
528 } elsif ($Weakest{0}{'for'} > $Defeats{$j}{$i}{'for'}) {
531 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
532 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
533 $Weakest{$weak_count}{'Winner'} = $j;
534 $Weakest{$weak_count}{'Loser'} = $i;
536 } elsif ($Weakest{0}{'Low'} == $Defeats{$j}{$i}{'for'}) {
537 if ($Weakest{0}{'against'} < $Defeats{$j}{$i}{'against'}) {
540 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
541 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
542 $Weakest{$weak_count}{'Winner'} = $j;
543 $Weakest{$weak_count}{'Loser'} = $i;
546 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
547 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
548 $Weakest{$weak_count}{'Winner'} = $j;
549 $Weakest{$weak_count}{'Loser'} = $i;
557 print {$RESULTS} "\n", "-=" x 35, "\n";
558 print {$RESULTS} "-=" x 35, "\n\n";
559 print {$RESULTS} "The winners are:\n";
560 foreach my $i (0 ..$#Schwartz) {
561 next unless $Schwartz[$i];
562 print {$RESULTS} "\t Option ", $order_to_options{$i + 1}{key}, " \"",
563 $order_to_options{$i + 1}{name}, "\"\n";
565 print {$RESULTS} "\n", "-=" x 35, "\n";
566 print {$RESULTS} "-=" x 35, "\n\n";
569 print {$RESULTS} "Weakest Defeat(s): \n";
570 foreach my $k (sort keys %Weakest) {
571 print {$RESULTS} "\tOption ", $order_to_options{$Weakest{$k}{'Winner'} + 1}{key},
572 " beats Option ", $order_to_options{$Weakest{$k}{'Loser'} + 1}{key}, " by ",
573 " ($Beat_Matrix[$Weakest{$k}{'Winner'}][$Weakest{$k}{'Loser'}] - ",
574 "$Beat_Matrix[$Weakest{$k}{'Loser'}][$Weakest{$k}{'Winner'}])\t",
575 "= ", $Weakest{$k}{'for'} - $Weakest{$k}{'against'}, " votes\n";
577 print {$RESULTS} "Deleting weakest defeat(s)\n\n";
578 foreach my $k (sort keys %Weakest) {
579 delete $Defeats{$Weakest{$k}{'Winner'}}{$Weakest{$k}{'Loser'}};
594 This is very inchoate, at the moment, and needs testing.
606 Manoj Srivastava <srivasta@debian.org>
608 =head1 COPYRIGHT AND LICENSE
610 This script is a part of the Devotee package, and is
612 Copyright (c) 2002, 2003, 2004, 2005 Manoj Srivastava <srivasta@debian.org>
614 This program is free software; you can redistribute it and/or modify
615 it under the terms of the GNU General Public License as published by
616 the Free Software Foundation; either version 2 of the License, or
617 (at your option) any later version.
619 This program is distributed in the hope that it will be useful,
620 but WITHOUT ANY WARRANTY; without even the implied warranty of
621 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
622 GNU General Public License for more details.
624 You should have received a copy of the GNU General Public License
625 along with this program; if not, write to the Free Software
626 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA