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;
187 # header been output?
188 my $header_output = 0;
190 # This is where we get our input data from
191 while (defined ($_ = $params{tally_fh}->getline)) {
195 if (m/^V:\s+(\S+)\s+(\S)/) { # standard devotee syntax
198 } elsif (m/^(.+) # the voter, can have spaces
199 \s*:\s+ # needs a colon and a space
200 ((?:[$valid_options] # the vote
201 \s*(?:,|=|>)?\s*)*) # allow > and , or =
202 \s*$/x # useless trailing spaces
206 # now, because this format has the options ranked instead of
207 # the rank of the option, figure out the rank of the option,
208 # and give that to devotee
209 my $current_rank = 1;
211 while ($vote =~ /([$valid_options]) # the vote
212 \s*((?:,|=|>)?)\s*/xg) {
213 my ($option,$relationship) = ($1,$2);
214 $option_rank{$option} = $current_rank;
215 if ($relationship ne '=') {
220 for my $opt (@options) {
221 $vote .= exists $option_rank{$opt->{key}} ? $number_to_option{$option_rank{$opt->{key}}} : '-';
223 if (not $header_output) {
224 print {$RESULTS} "/--".join("",map {$_->{key}} @options)."\n";
227 print {$RESULTS} "V: $vote $voter\n";
230 print STDERR "ignoring line '$_'; this is probably wrong!\n";
234 # my @rank = unpack "a" x $max_choices, $vote;
236 foreach my $rank (split //, uc $vote) {
241 push(@rank,encode_base64($rank));
244 foreach my $i (0..($max_choices - 1)) {
245 foreach my $j (($i + 1)..($max_choices - 1)) {
246 if ($rank[$i] eq '-' && $rank[$j] eq '-') {
247 next; # Both unranked
248 } elsif ($rank[$i] eq '-' && $rank[$j] ne '-') {
249 $Beat_Matrix[$j][$i]++;
250 } elsif ($rank[$i] ne '-' && $rank[$j] eq '-') {
251 $Beat_Matrix[$i][$j]++;
252 } elsif ($rank[$i] < $rank[$j]) {
253 $Beat_Matrix[$i][$j]++;
254 } elsif ($rank[$i] > $rank[$j]) {
255 $Beat_Matrix[$j][$i]++;
257 next; # Equally ranked
262 for my $opt (0..($max_choices - 1)) {
263 print {$RESULTS} "Option ", $order_to_options{$opt+1}{key}, " \"",
264 $order_to_options{$opt+1}{name},
267 print {$RESULTS} <<EOF;
269 In the following table, tally[row x][col y] represents the votes that
270 option x received over option y.
275 print {$RESULTS} " " x18, "Option\n";
276 print {$RESULTS} " " x10;
277 for my $col (0..($max_choices - 1)) {
278 printf {$RESULTS} " % 4s ", $order_to_options{$col + 1}{key};
281 print {$RESULTS} "\n";
282 print {$RESULTS} " " x10, " === " x $max_choices, "\n";
284 for my $row (0..($max_choices - 1)) {
285 printf {$RESULTS} "Option %s ", $order_to_options{$row + 1}{key};
286 for my $col (0..($max_choices - 1)) {
288 print {$RESULTS} " ";
290 printf {$RESULTS} " % 4d ", $Beat_Matrix[$row][$col];
293 print {$RESULTS} "\n";
295 print {$RESULTS} "\n\n";
297 print {$RESULTS} <<EOM;
299 Looking at row 2, column 1, $order_to_options{2}{key}
300 received $Beat_Matrix[1][0] votes over $order_to_options{1}{key}
302 Looking at row 1, column 2, $order_to_options{1}{key}
303 received $Beat_Matrix[0][1] votes over $order_to_options{2}{key}.
310 if ($params{default_option}) {
311 foreach my $i (0..($max_choices - 2)) {
312 if ($K > $Beat_Matrix[$i][$max_choices - 1]) {
314 print {$RESULTS} "Dropping Option ", $order_to_options{$i + 1}{key},
315 " \"", $order_to_options{$i + 1}{name},
316 "\" because of Quorum ($K > $Beat_Matrix[$i][$max_choices - 1])\n";
318 print {$RESULTS} "Option ", $order_to_options{$i + 1}{key},
319 " Reached quorum: $Beat_Matrix[$i][$max_choices - 1] >= $K\n";
322 print {$RESULTS} "\n\n";
329 # 2. An option A defeats the default option D by a majority ratio N,
330 # if V(A,D) is strictly greater than N * V(D,A).
331 # 3. If a supermajority of S:1 is required for A, its majority ratio
332 # is S; otherwise, its majority ratio is 1.
333 # Any (non-default) option which does not defeat the default option
334 # by its required majority ratio is dropped from consideration.
335 foreach my $i (0..($max_choices - 2)) {
336 next unless $Beat_Matrix[$max_choices - 1][$i];
339 my $ratio = 1.0 * $Beat_Matrix[$i][$max_choices - 1] /
340 $Beat_Matrix[$max_choices - 1][$i];
341 $Ratio{$i} = sprintf("%.2f", $ratio);
342 if ($ratio < $order_to_options{$i + 1}{majority}) {
343 # If the next line is commented out, we get a more verbose set of results
345 print {$RESULTS} "Dropping Option ", $order_to_options{$i + 1}{key},
346 " because of Majority. ($ratio)";
347 printf {$RESULTS} " %6.3f (%d/%d) < %d\n",
348 $ratio, $Beat_Matrix[$i][$max_choices - 1],
349 $Beat_Matrix[$max_choices - 1][$i],
350 $order_to_options{$i + 1}{majority};
352 print {$RESULTS} "Option ", $order_to_options{$i + 1}{key}, " passes Majority.";
353 print {$RESULTS} " ";
354 printf {$RESULTS} " %6.3f (%d/%d) >= %d\n",
355 $ratio, $Beat_Matrix[$i][$max_choices - 1],
356 $Beat_Matrix[$max_choices - 1][$i],
357 $order_to_options{$i + 1}{majority};
360 print {$RESULTS} "\n\n";
364 # Initialize the Defeats matrix
365 foreach my $i (0..($max_choices - 1)) {
367 foreach my $j (($i + 1)..($max_choices - 1)) {
369 if ($Beat_Matrix[$i][$j] > $Beat_Matrix[$j][$i]) {
371 $Defeats{$i}{$j}{for} = $Beat_Matrix[$i][$j];
372 $Defeats{$i}{$j}{against} = $Beat_Matrix[$j][$i];
374 print {$RESULTS} " Option ", $order_to_options{$i + 1}{key}, " defeats Option ",
375 $order_to_options{$j + 1}{key},
376 sprintf(" by (% 4d - % 4d) = %4d votes.\n",
377 $Beat_Matrix[$i][$j], $Beat_Matrix[$j][$i],
378 $Beat_Matrix[$i][$j] - $Beat_Matrix[$j][$i]);
379 } elsif ($Beat_Matrix[$i][$j] < $Beat_Matrix[$j][$i]) {
381 $Defeats{$j}{$i}{for} = $Beat_Matrix[$j][$i];
382 $Defeats{$j}{$i}{against} = $Beat_Matrix[$i][$j];
384 print {$RESULTS} " Option ", $order_to_options{$j + 1}{key}, " defeats Option ",
385 $order_to_options{$i + 1}{key},
386 sprintf(" by (% 4d - % 4d) = %4d votes.\n",
387 $Beat_Matrix[$j][$i], $Beat_Matrix[$i][$j],
388 $Beat_Matrix[$j][$i] - $Beat_Matrix[$i][$j]);
392 print {$RESULTS} "\n\n";
395 # Ok, here is what we are here for.
398 # From the list of [undropped] pairwise defeats, we generate a set of
399 # transitive defeats.
401 # Initialize the Beatpath
403 foreach my $i (0..($max_choices - 1)) {
405 foreach my $j (0..($max_choices - 1)) {
407 $BeatPath{$i}{$j}{for} = $Defeats{$i}{$j}{for};
408 $BeatPath{$i}{$j}{against} = $Defeats{$i}{$j}{against};
412 # 1. An option A transitively defeats an option C if A defeats C or
413 # if there is some other option B where A defeats B AND B
414 # transitively defeats C.
417 foreach my $i (0..($max_choices - 1)) {
419 foreach my $j (0..($max_choices - 1)) {
422 foreach my $k (0..($max_choices - 1)) {
426 if (!$BeatPath{$i}{$j}{for}) {
427 if ($BeatPath{$i}{$k}{for} && $BeatPath{$k}{$j}{for} ) {
428 if ($BeatPath{$i}{$k}{for} == $BeatPath{$k}{$j}{for}) {
429 $BeatPath{$i}{$j}{for} = ($BeatPath{$i}{$k}{against} >
430 $BeatPath{$k}{$j}{against}) ?
431 $BeatPath{$i}{$k}{for}:$BeatPath{$k}{$j}{for};
432 $BeatPath{$i}{$j}{against} = ($BeatPath{$i}{$k}{against} >
433 $BeatPath{$k}{$j}{against}) ?
434 $BeatPath{$i}{$k}{against} :
435 $BeatPath{$k}{$j}{against};
437 $BeatPath{$i}{$j}{for} = ($BeatPath{$i}{$k}{for} <
438 $BeatPath{$k}{$j}{for}) ?
439 $BeatPath{$i}{$k}{for} :
440 $BeatPath{$k}{$j}{for};
441 $BeatPath{$i}{$j}{against} = ($BeatPath{$i}{$k}{for} <
442 $BeatPath{$k}{$j}{for}) ?
443 $BeatPath{$i}{$k}{against} :
444 $BeatPath{$k}{$j}{against};
455 # We construct the Schwartz set from the set of transitive defeats.
456 foreach my $i (0..($max_choices - 1)) {
464 foreach my $i (0..($max_choices - 1)) {
465 foreach my $j (0..($max_choices - 1)) {
467 # An option A is in the Schwartz set if for all options B, either
468 # A transitively defeats B, or B does not transitively defeat A
469 # Here, we throw out any option $i that does not meet the above
471 if (! ($BeatPath{$i}{$j}{for} || ! $BeatPath{$j}{$i}{for})) {
476 print {$RESULTS} "The Schwartz Set contains:\n";
477 foreach my $i (0 ..$#Schwartz) {
478 next unless $Schwartz[$i];
479 print {$RESULTS} "\t Option ", $order_to_options{$i + 1}{key}, " \"",
480 $order_to_options{$i + 1}{name}, "\"\n";
482 print {$RESULTS} "\n\n";
484 # If there are defeats between options in the Schwartz set, we drop
485 # the weakest such defeats from the list of pairwise defeats, and
488 # 1. A defeat (A,X) is weaker than a defeat (B,Y) if V(A,X) is
489 # less than V(B,Y). Also, (A,X) is weaker than (B,Y) if V(A,X) is
490 # equal to V(B,Y) and V(X,A) is greater than V(Y,B).
492 # 2. A weakest defeat is a defeat that has no other defeat weaker
493 # than it. There may be more than one such defeat.
495 # Check to see if there is anything in the Schwartz set that has no
499 foreach my $i (0 ..$#Schwartz) {
500 next unless $Schwartz[$i];
501 foreach my $j (0..$#Schwartz) {
502 next unless $Schwartz[$j];
504 if (defined $Defeats{$i}{$j}{'for'}) {
506 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{for};
507 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{against};
508 $Weakest{$weak_count}{'Winner'} = $i;
509 $Weakest{$weak_count}{'Loser'} = $j;
511 } elsif ($Weakest{0}{'for'} > $Defeats{$i}{$j}{for}) {
514 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{for};
515 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{against};
516 $Weakest{$weak_count}{'Winner'} = $i;
517 $Weakest{$weak_count}{'Loser'} = $j;
519 } elsif ($Weakest{0}{'for'} == $Defeats{$i}{$j}{'for'}) {
520 if ($Weakest{0}{'against'} < $Defeats{$i}{$j}{against}) {
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;
529 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{'for'};
530 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{'against'};
531 $Weakest{$weak_count}{'Winner'} = $i;
532 $Weakest{$weak_count}{'Loser'} = $j;
537 if (defined $Defeats{$j}{$i}{'for'}) {
539 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
540 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
541 $Weakest{$weak_count}{'Winner'} = $j;
542 $Weakest{$weak_count}{'Loser'} = $i;
544 } elsif ($Weakest{0}{'for'} > $Defeats{$j}{$i}{'for'}) {
547 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
548 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
549 $Weakest{$weak_count}{'Winner'} = $j;
550 $Weakest{$weak_count}{'Loser'} = $i;
552 } elsif ($Weakest{0}{'Low'} == $Defeats{$j}{$i}{'for'}) {
553 if ($Weakest{0}{'against'} < $Defeats{$j}{$i}{'against'}) {
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;
562 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
563 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
564 $Weakest{$weak_count}{'Winner'} = $j;
565 $Weakest{$weak_count}{'Loser'} = $i;
573 print {$RESULTS} "\n", "-=" x 35, "\n";
574 print {$RESULTS} "-=" x 35, "\n\n";
575 print {$RESULTS} "The winners are:\n";
576 foreach my $i (0 ..$#Schwartz) {
577 next unless $Schwartz[$i];
578 print {$RESULTS} "\t Option ", $order_to_options{$i + 1}{key}, " \"",
579 $order_to_options{$i + 1}{name}, "\"\n";
581 print {$RESULTS} "\n", "-=" x 35, "\n";
582 print {$RESULTS} "-=" x 35, "\n\n";
585 print {$RESULTS} "Weakest Defeat(s): \n";
586 foreach my $k (sort keys %Weakest) {
587 print {$RESULTS} "\tOption ", $order_to_options{$Weakest{$k}{'Winner'} + 1}{key},
588 " beats Option ", $order_to_options{$Weakest{$k}{'Loser'} + 1}{key}, " by ",
589 " ($Beat_Matrix[$Weakest{$k}{'Winner'}][$Weakest{$k}{'Loser'}] - ",
590 "$Beat_Matrix[$Weakest{$k}{'Loser'}][$Weakest{$k}{'Winner'}])\t",
591 "= ", $Weakest{$k}{'for'} - $Weakest{$k}{'against'}, " votes\n";
593 print {$RESULTS} "Deleting weakest defeat(s)\n\n";
594 foreach my $k (sort keys %Weakest) {
595 delete $Defeats{$Weakest{$k}{'Winner'}}{$Weakest{$k}{'Loser'}};
610 This is very inchoate, at the moment, and needs testing.
622 Manoj Srivastava <srivasta@debian.org>
624 =head1 COPYRIGHT AND LICENSE
626 This script is a part of the Devotee package, and is
628 Copyright (c) 2002, 2003, 2004, 2005 Manoj Srivastava <srivasta@debian.org>
630 This program is free software; you can redistribute it and/or modify
631 it under the terms of the GNU General Public License as published by
632 the Free Software Foundation; either version 2 of the License, or
633 (at your option) any later version.
635 This program is distributed in the hope that it will be useful,
636 but WITHOUT ANY WARRANTY; without even the implied warranty of
637 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
638 GNU General Public License for more details.
640 You should have received a copy of the GNU General Public License
641 along with this program; if not, write to the Free Software
642 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA