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;
101 'default_option|default-option!',
104 if (not exists $options{option} or not ref($options{option}) or
105 @{$options{option}} < 2
107 die "you must give at least two options in a --option argument";
110 for my $option (@{$options{option}}) {
111 my ($key,$name,$majority) = $option =~ /^\s*([^:]+)\s*:\s*(.+)\s*(?::(\d+))?$/;
113 push @options,{key => $key,
115 majority => $majority,
118 winner(options=>\@options,
119 default_option => exists $options{default_option} ? $options{default_option} : 1,
120 quorum => exists $options{quorum} ? $options{quorum} : 2,
125 return map {$option_to_number{$_}} @_;
129 return map {$number_to_option{$_}} @_;
133 my %params = validate_with(params => \@_,
134 spec => {quorum => {default => 5,
137 options => {type => ARRAYREF,
139 tally_fh => {type => HANDLE,
142 default_option => {default => 1,
147 # options is an array to keep it ordered
148 my @options = @{$params{options}};
150 my %order_to_options;
153 my $valid_options = '';
154 for my $option (@options) {
155 $options{$option->{key}} =
156 {key => $option->{key},
157 name => $option->{name},
158 majority => $option->{majority} // 1,
161 $order_to_options{$order} = $options{$option->{key}};
162 $valid_options .= $option->{key};
163 $max_choices = $order;
167 # The constitution defines the maximum value of K to be 5
168 my $K = $params{quorum};
170 # 1. Given two options A and B, V(A,B) is the number of voters who
171 # prefer option A over option B.
172 my @Beat_Matrix = ();
173 for my $row (0..$max_choices) {
174 for my $col (0..$max_choices) {
175 $Beat_Matrix[$row][$col] = 0; #Math::BigFloat->bzero();
179 my $RESULTS = \*STDOUT;
181 my $now_string = gmtime;
182 print {$RESULTS} "Starting results calculation at $now_string\n\n";
184 if (not defined $params{tally_fh}) {
185 $params{tally_fh} = \*STDIN;
188 # This is where we get our input data from
189 while (defined ($_ = $params{tally_fh}->getline)) {
193 if (m/^V:\s+(\S+)\s+(\S)/) { # standard devotee syntax
196 } elsif (m/^(.+) # the voter, can have spaces
197 \s*:\s+ # needs a colon and a space
198 ((?:[$valid_options] # the vote
199 \s*(?:,|=|>)?\s*)*) # allow > and , or =
200 \s*$/x # useless trailing spaces
204 # now, because this format has the options ranked instead of
205 # the rank of the option, figure out the rank of the option,
206 # and give that to devotee
207 my $current_rank = 1;
209 while ($vote =~ /([$valid_options]) # the vote
210 \s*((?:,|=|>)?)\s*/xg) {
211 my ($option,$relationship) = ($1,$2);
212 $option_rank{$option} = $current_rank;
213 if ($relationship ne '=') {
218 for my $opt (@options) {
219 $vote .= exists $option_rank{$opt->{key}} ? $number_to_option{$option_rank{$opt->{key}}} : '-';
221 print {$RESULTS} "V: $vote $voter\n";
224 print STDERR "ignoring line '$_'; this is probably wrong!\n";
228 # my @rank = unpack "a" x $max_choices, $vote;
230 foreach my $rank (split //, uc $vote) {
235 push(@rank,encode_base64($rank));
238 foreach my $i (0..($max_choices - 1)) {
239 foreach my $j (($i + 1)..($max_choices - 1)) {
240 if ($rank[$i] eq '-' && $rank[$j] eq '-') {
241 next; # Both unranked
242 } elsif ($rank[$i] eq '-' && $rank[$j] ne '-') {
243 $Beat_Matrix[$j][$i]++;
244 } elsif ($rank[$i] ne '-' && $rank[$j] eq '-') {
245 $Beat_Matrix[$i][$j]++;
246 } elsif ($rank[$i] < $rank[$j]) {
247 $Beat_Matrix[$i][$j]++;
248 } elsif ($rank[$i] > $rank[$j]) {
249 $Beat_Matrix[$j][$i]++;
251 next; # Equally ranked
256 for my $opt (0..($max_choices - 1)) {
257 print {$RESULTS} "Option ", $order_to_options{$opt+1}{key}, " \"",
258 $order_to_options{$opt+1}{name},
261 print {$RESULTS} <<EOF;
263 In the following table, tally[row x][col y] represents the votes that
264 option x received over option y.
269 print {$RESULTS} " " x18, "Option\n";
270 print {$RESULTS} " " x10;
271 for my $col (0..($max_choices - 1)) {
272 printf {$RESULTS} " % 4s ", $order_to_options{$col + 1}{key};
275 print {$RESULTS} "\n";
276 print {$RESULTS} " " x10, " === " x $max_choices, "\n";
278 for my $row (0..($max_choices - 1)) {
279 printf {$RESULTS} "Option %s ", $order_to_options{$row + 1}{key};
280 for my $col (0..($max_choices - 1)) {
282 printf {$RESULTS} " ", $Beat_Matrix[$row][$col];
284 printf {$RESULTS} " % 4d ", $Beat_Matrix[$row][$col];
287 print {$RESULTS} "\n";
289 print {$RESULTS} "\n\n";
291 print {$RESULTS} <<EOM;
293 Looking at row 2, column 1, $order_to_options{2}{key}
294 received $Beat_Matrix[1][0] votes over $order_to_options{1}{key}
296 Looking at row 1, column 2, $order_to_options{1}{key}
297 received $Beat_Matrix[0][1] votes over $order_to_options{2}{key}.
304 if ($params{default_option}) {
305 foreach my $i (0..($max_choices - 2)) {
306 if ($K > $Beat_Matrix[$i][$max_choices - 1]) {
308 print {$RESULTS} "Dropping Option ", $order_to_options{$i + 1}{key},
309 " \"", $order_to_options{$i + 1}{name},
310 "\" because of Quorum ($K > $Beat_Matrix[$i][$max_choices - 1])\n";
312 print {$RESULTS} "Option ", $order_to_options{$i + 1}{key},
313 " Reached quorum: $Beat_Matrix[$i][$max_choices - 1] >= $K\n";
316 print {$RESULTS} "\n\n";
323 # 2. An option A defeats the default option D by a majority ratio N,
324 # if V(A,D) is strictly greater than N * V(D,A).
325 # 3. If a supermajority of S:1 is required for A, its majority ratio
326 # is S; otherwise, its majority ratio is 1.
327 # Any (non-default) option which does not defeat the default option
328 # by its required majority ratio is dropped from consideration.
329 foreach my $i (0..($max_choices - 2)) {
330 next unless $Beat_Matrix[$max_choices - 1][$i];
333 my $ratio = 1.0 * $Beat_Matrix[$i][$max_choices - 1] /
334 $Beat_Matrix[$max_choices - 1][$i];
335 $Ratio{$i} = sprintf("%.2f", $ratio);
336 if ($ratio < $order_to_options{$i + 1}{majority}) {
337 # If the next line is commented out, we get a more verbose set of results
339 print {$RESULTS} "Dropping Option ", $order_to_options{$i + 1}{key},
340 " because of Majority. ($ratio)";
341 printf {$RESULTS} " %6.3f (%d/%d) < %d\n",
342 $ratio, $Beat_Matrix[$i][$max_choices - 1],
343 $Beat_Matrix[$max_choices - 1][$i],
344 $order_to_options{$i + 1}{majority};
346 print {$RESULTS} "Option ", $order_to_options{$i + 1}{key}, " passes Majority.";
347 print {$RESULTS} " ";
348 printf {$RESULTS} " %6.3f (%d/%d) >= %d\n",
349 $ratio, $Beat_Matrix[$i][$max_choices - 1],
350 $Beat_Matrix[$max_choices - 1][$i],
351 $order_to_options{$i + 1}{majority};
354 print {$RESULTS} "\n\n";
358 # Initialize the Defeats matrix
359 foreach my $i (0..($max_choices - 1)) {
361 foreach my $j (($i + 1)..($max_choices - 1)) {
363 if ($Beat_Matrix[$i][$j] > $Beat_Matrix[$j][$i]) {
365 $Defeats{$i}{$j}{for} = $Beat_Matrix[$i][$j];
366 $Defeats{$i}{$j}{against} = $Beat_Matrix[$j][$i];
368 print {$RESULTS} " Option ", $order_to_options{$i + 1}{key}, " defeats Option ",
369 $order_to_options{$j + 1}{key},
370 sprintf(" by (% 4d - % 4d) = %4d votes.\n",
371 $Beat_Matrix[$i][$j], $Beat_Matrix[$j][$i],
372 $Beat_Matrix[$i][$j] - $Beat_Matrix[$j][$i]);
373 } elsif ($Beat_Matrix[$i][$j] < $Beat_Matrix[$j][$i]) {
375 $Defeats{$j}{$i}{for} = $Beat_Matrix[$j][$i];
376 $Defeats{$j}{$i}{against} = $Beat_Matrix[$i][$j];
378 print {$RESULTS} " Option ", $order_to_options{$j + 1}{key}, " defeats Option ",
379 $order_to_options{$i + 1}{key},
380 sprintf(" by (% 4d - % 4d) = %4d votes.\n",
381 $Beat_Matrix[$j][$i], $Beat_Matrix[$i][$j],
382 $Beat_Matrix[$j][$i] - $Beat_Matrix[$i][$j]);
386 print {$RESULTS} "\n\n";
389 # Ok, here is what we are here for.
392 # From the list of [undropped] pairwise defeats, we generate a set of
393 # transitive defeats.
395 # Initialize the Beatpath
397 foreach my $i (0..($max_choices - 1)) {
399 foreach my $j (0..($max_choices - 1)) {
401 $BeatPath{$i}{$j}{for} = $Defeats{$i}{$j}{for};
402 $BeatPath{$i}{$j}{against} = $Defeats{$i}{$j}{against};
406 # 1. An option A transitively defeats an option C if A defeats C or
407 # if there is some other option B where A defeats B AND B
408 # transitively defeats C.
411 foreach my $i (0..($max_choices - 1)) {
413 foreach my $j (0..($max_choices - 1)) {
416 foreach my $k (0..($max_choices - 1)) {
420 if (!$BeatPath{$i}{$j}{for}) {
421 if ($BeatPath{$i}{$k}{for} && $BeatPath{$k}{$j}{for} ) {
422 if ($BeatPath{$i}{$k}{for} == $BeatPath{$k}{$j}{for}) {
423 $BeatPath{$i}{$j}{for} = ($BeatPath{$i}{$k}{against} >
424 $BeatPath{$k}{$j}{against}) ?
425 $BeatPath{$i}{$k}{for}:$BeatPath{$k}{$j}{for};
426 $BeatPath{$i}{$j}{against} = ($BeatPath{$i}{$k}{against} >
427 $BeatPath{$k}{$j}{against}) ?
428 $BeatPath{$i}{$k}{against} :
429 $BeatPath{$k}{$j}{against};
431 $BeatPath{$i}{$j}{for} = ($BeatPath{$i}{$k}{for} <
432 $BeatPath{$k}{$j}{for}) ?
433 $BeatPath{$i}{$k}{for} :
434 $BeatPath{$k}{$j}{for};
435 $BeatPath{$i}{$j}{against} = ($BeatPath{$i}{$k}{for} <
436 $BeatPath{$k}{$j}{for}) ?
437 $BeatPath{$i}{$k}{against} :
438 $BeatPath{$k}{$j}{against};
449 # We construct the Schwartz set from the set of transitive defeats.
450 foreach my $i (0..($max_choices - 1)) {
458 foreach my $i (0..($max_choices - 1)) {
459 foreach my $j (0..($max_choices - 1)) {
461 # An option A is in the Schwartz set if for all options B, either
462 # A transitively defeats B, or B does not transitively defeat A
463 # Here, we throw out any option $i that does not meet the above
465 if (! ($BeatPath{$i}{$j}{for} || ! $BeatPath{$j}{$i}{for})) {
470 print {$RESULTS} "The Schwartz Set contains:\n";
471 foreach my $i (0 ..$#Schwartz) {
472 next unless $Schwartz[$i];
473 print {$RESULTS} "\t Option ", $order_to_options{$i + 1}{key}, " \"",
474 $order_to_options{$i + 1}{name}, "\"\n";
476 print {$RESULTS} "\n\n";
478 # If there are defeats between options in the Schwartz set, we drop
479 # the weakest such defeats from the list of pairwise defeats, and
482 # 1. A defeat (A,X) is weaker than a defeat (B,Y) if V(A,X) is
483 # less than V(B,Y). Also, (A,X) is weaker than (B,Y) if V(A,X) is
484 # equal to V(B,Y) and V(X,A) is greater than V(Y,B).
486 # 2. A weakest defeat is a defeat that has no other defeat weaker
487 # than it. There may be more than one such defeat.
489 # Check to see if there is anything in the Schwartz set that has no
493 foreach my $i (0 ..$#Schwartz) {
494 next unless $Schwartz[$i];
495 foreach my $j (0..$#Schwartz) {
496 next unless $Schwartz[$j];
498 if (defined $Defeats{$i}{$j}{'for'}) {
500 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{for};
501 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{against};
502 $Weakest{$weak_count}{'Winner'} = $i;
503 $Weakest{$weak_count}{'Loser'} = $j;
505 } elsif ($Weakest{0}{'for'} > $Defeats{$i}{$j}{for}) {
508 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{for};
509 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{against};
510 $Weakest{$weak_count}{'Winner'} = $i;
511 $Weakest{$weak_count}{'Loser'} = $j;
513 } elsif ($Weakest{0}{'for'} == $Defeats{$i}{$j}{'for'}) {
514 if ($Weakest{0}{'against'} < $Defeats{$i}{$j}{against}) {
517 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{for};
518 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{against};
519 $Weakest{$weak_count}{'Winner'} = $i;
520 $Weakest{$weak_count}{'Loser'} = $j;
523 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{'for'};
524 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{'against'};
525 $Weakest{$weak_count}{'Winner'} = $i;
526 $Weakest{$weak_count}{'Loser'} = $j;
531 if (defined $Defeats{$j}{$i}{'for'}) {
533 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
534 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
535 $Weakest{$weak_count}{'Winner'} = $j;
536 $Weakest{$weak_count}{'Loser'} = $i;
538 } elsif ($Weakest{0}{'for'} > $Defeats{$j}{$i}{'for'}) {
541 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
542 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
543 $Weakest{$weak_count}{'Winner'} = $j;
544 $Weakest{$weak_count}{'Loser'} = $i;
546 } elsif ($Weakest{0}{'Low'} == $Defeats{$j}{$i}{'for'}) {
547 if ($Weakest{0}{'against'} < $Defeats{$j}{$i}{'against'}) {
550 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
551 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
552 $Weakest{$weak_count}{'Winner'} = $j;
553 $Weakest{$weak_count}{'Loser'} = $i;
556 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
557 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
558 $Weakest{$weak_count}{'Winner'} = $j;
559 $Weakest{$weak_count}{'Loser'} = $i;
567 print {$RESULTS} "\n", "-=" x 35, "\n";
568 print {$RESULTS} "-=" x 35, "\n\n";
569 print {$RESULTS} "The winners are:\n";
570 foreach my $i (0 ..$#Schwartz) {
571 next unless $Schwartz[$i];
572 print {$RESULTS} "\t Option ", $order_to_options{$i + 1}{key}, " \"",
573 $order_to_options{$i + 1}{name}, "\"\n";
575 print {$RESULTS} "\n", "-=" x 35, "\n";
576 print {$RESULTS} "-=" x 35, "\n\n";
579 print {$RESULTS} "Weakest Defeat(s): \n";
580 foreach my $k (sort keys %Weakest) {
581 print {$RESULTS} "\tOption ", $order_to_options{$Weakest{$k}{'Winner'} + 1}{key},
582 " beats Option ", $order_to_options{$Weakest{$k}{'Loser'} + 1}{key}, " by ",
583 " ($Beat_Matrix[$Weakest{$k}{'Winner'}][$Weakest{$k}{'Loser'}] - ",
584 "$Beat_Matrix[$Weakest{$k}{'Loser'}][$Weakest{$k}{'Winner'}])\t",
585 "= ", $Weakest{$k}{'for'} - $Weakest{$k}{'against'}, " votes\n";
587 print {$RESULTS} "Deleting weakest defeat(s)\n\n";
588 foreach my $k (sort keys %Weakest) {
589 delete $Defeats{$Weakest{$k}{'Winner'}}{$Weakest{$k}{'Loser'}};
604 This is very inchoate, at the moment, and needs testing.
616 Manoj Srivastava <srivasta@debian.org>
618 =head1 COPYRIGHT AND LICENSE
620 This script is a part of the Devotee package, and is
622 Copyright (c) 2002, 2003, 2004, 2005 Manoj Srivastava <srivasta@debian.org>
624 This program is free software; you can redistribute it and/or modify
625 it under the terms of the GNU General Public License as published by
626 the Free Software Foundation; either version 2 of the License, or
627 (at your option) any later version.
629 This program is distributed in the hope that it will be useful,
630 but WITHOUT ANY WARRANTY; without even the implied warranty of
631 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
632 GNU General Public License for more details.
634 You should have received a copy of the GNU General Public License
635 along with this program; if not, write to the Free Software
636 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA