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 greater or equal to N * V(D,A) and V(A,D) is strictly
331 # greater than V(D,A).
332 # 3. If a supermajority of S:1 is required for A, its majority ratio
333 # is S; otherwise, its majority ratio is 1.
334 # Any (non-default) option which does not defeat the default option
335 # by its required majority ratio is dropped from consideration.
336 foreach my $i (0..($max_choices - 2)) {
337 next unless $Beat_Matrix[$max_choices - 1][$i];
340 my $ratio = 1.0 * $Beat_Matrix[$i][$max_choices - 1] /
341 $Beat_Matrix[$max_choices - 1][$i];
342 $Ratio{$i} = sprintf("%.2f", $ratio);
343 if ($ratio < $order_to_options{$i + 1}{majority} or $ratio <= 1) {
344 # If the next line is commented out, we get a more verbose set of results
346 print {$RESULTS} "Dropping Option ", $order_to_options{$i + 1}{key},
347 " because of Majority. ($ratio)";
348 my $comparison_sign = $order_to_options{$i + 1}{majority} == 1 ? '<=' : '<';
349 printf {$RESULTS} " %6.3f (%d/%d) $comparison_sign %d\n",
350 $ratio, $Beat_Matrix[$i][$max_choices - 1],
351 $Beat_Matrix[$max_choices - 1][$i],
352 $order_to_options{$i + 1}{majority};
354 print {$RESULTS} "Option ", $order_to_options{$i + 1}{key}, " passes Majority.";
355 print {$RESULTS} " ";
356 my $comparison_sign = $order_to_options{$i + 1}{majority} == 1 ? '>' : '>=';
357 printf {$RESULTS} " %6.3f (%d/%d) $comparison_sign %d\n",
358 $ratio, $Beat_Matrix[$i][$max_choices - 1],
359 $Beat_Matrix[$max_choices - 1][$i],
360 $order_to_options{$i + 1}{majority};
363 print {$RESULTS} "\n\n";
367 # Initialize the Defeats matrix
368 foreach my $i (0..($max_choices - 1)) {
370 foreach my $j (($i + 1)..($max_choices - 1)) {
372 if ($Beat_Matrix[$i][$j] > $Beat_Matrix[$j][$i]) {
374 $Defeats{$i}{$j}{for} = $Beat_Matrix[$i][$j];
375 $Defeats{$i}{$j}{against} = $Beat_Matrix[$j][$i];
377 print {$RESULTS} " Option ", $order_to_options{$i + 1}{key}, " defeats Option ",
378 $order_to_options{$j + 1}{key},
379 sprintf(" by (% 4d - % 4d) = %4d votes.\n",
380 $Beat_Matrix[$i][$j], $Beat_Matrix[$j][$i],
381 $Beat_Matrix[$i][$j] - $Beat_Matrix[$j][$i]);
382 } elsif ($Beat_Matrix[$i][$j] < $Beat_Matrix[$j][$i]) {
384 $Defeats{$j}{$i}{for} = $Beat_Matrix[$j][$i];
385 $Defeats{$j}{$i}{against} = $Beat_Matrix[$i][$j];
387 print {$RESULTS} " Option ", $order_to_options{$j + 1}{key}, " defeats Option ",
388 $order_to_options{$i + 1}{key},
389 sprintf(" by (% 4d - % 4d) = %4d votes.\n",
390 $Beat_Matrix[$j][$i], $Beat_Matrix[$i][$j],
391 $Beat_Matrix[$j][$i] - $Beat_Matrix[$i][$j]);
395 print {$RESULTS} "\n\n";
398 # Ok, here is what we are here for.
401 # From the list of [undropped] pairwise defeats, we generate a set of
402 # transitive defeats.
404 # Initialize the Beatpath
406 foreach my $i (0..($max_choices - 1)) {
408 foreach my $j (0..($max_choices - 1)) {
410 $BeatPath{$i}{$j}{for} = $Defeats{$i}{$j}{for};
411 $BeatPath{$i}{$j}{against} = $Defeats{$i}{$j}{against};
415 # 1. An option A transitively defeats an option C if A defeats C or
416 # if there is some other option B where A defeats B AND B
417 # transitively defeats C.
420 foreach my $i (0..($max_choices - 1)) {
422 foreach my $j (0..($max_choices - 1)) {
425 foreach my $k (0..($max_choices - 1)) {
429 if (!$BeatPath{$i}{$j}{for}) {
430 if ($BeatPath{$i}{$k}{for} && $BeatPath{$k}{$j}{for} ) {
431 if ($BeatPath{$i}{$k}{for} == $BeatPath{$k}{$j}{for}) {
432 $BeatPath{$i}{$j}{for} = ($BeatPath{$i}{$k}{against} >
433 $BeatPath{$k}{$j}{against}) ?
434 $BeatPath{$i}{$k}{for}:$BeatPath{$k}{$j}{for};
435 $BeatPath{$i}{$j}{against} = ($BeatPath{$i}{$k}{against} >
436 $BeatPath{$k}{$j}{against}) ?
437 $BeatPath{$i}{$k}{against} :
438 $BeatPath{$k}{$j}{against};
440 $BeatPath{$i}{$j}{for} = ($BeatPath{$i}{$k}{for} <
441 $BeatPath{$k}{$j}{for}) ?
442 $BeatPath{$i}{$k}{for} :
443 $BeatPath{$k}{$j}{for};
444 $BeatPath{$i}{$j}{against} = ($BeatPath{$i}{$k}{for} <
445 $BeatPath{$k}{$j}{for}) ?
446 $BeatPath{$i}{$k}{against} :
447 $BeatPath{$k}{$j}{against};
458 # We construct the Schwartz set from the set of transitive defeats.
459 foreach my $i (0..($max_choices - 1)) {
467 foreach my $i (0..($max_choices - 1)) {
468 foreach my $j (0..($max_choices - 1)) {
470 # An option A is in the Schwartz set if for all options B, either
471 # A transitively defeats B, or B does not transitively defeat A
472 # Here, we throw out any option $i that does not meet the above
474 if (! ($BeatPath{$i}{$j}{for} || ! $BeatPath{$j}{$i}{for})) {
479 print {$RESULTS} "The Schwartz Set contains:\n";
480 foreach my $i (0 ..$#Schwartz) {
481 next unless $Schwartz[$i];
482 print {$RESULTS} "\t Option ", $order_to_options{$i + 1}{key}, " \"",
483 $order_to_options{$i + 1}{name}, "\"\n";
485 print {$RESULTS} "\n\n";
487 # If there are defeats between options in the Schwartz set, we drop
488 # the weakest such defeats from the list of pairwise defeats, and
491 # 1. A defeat (A,X) is weaker than a defeat (B,Y) if V(A,X) is
492 # less than V(B,Y). Also, (A,X) is weaker than (B,Y) if V(A,X) is
493 # equal to V(B,Y) and V(X,A) is greater than V(Y,B).
495 # 2. A weakest defeat is a defeat that has no other defeat weaker
496 # than it. There may be more than one such defeat.
498 # Check to see if there is anything in the Schwartz set that has no
502 foreach my $i (0 ..$#Schwartz) {
503 next unless $Schwartz[$i];
504 foreach my $j (0..$#Schwartz) {
505 next unless $Schwartz[$j];
507 if (defined $Defeats{$i}{$j}{'for'}) {
509 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{for};
510 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{against};
511 $Weakest{$weak_count}{'Winner'} = $i;
512 $Weakest{$weak_count}{'Loser'} = $j;
514 } elsif ($Weakest{0}{'for'} > $Defeats{$i}{$j}{for}) {
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;
522 } elsif ($Weakest{0}{'for'} == $Defeats{$i}{$j}{'for'}) {
523 if ($Weakest{0}{'against'} < $Defeats{$i}{$j}{against}) {
526 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{for};
527 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{against};
528 $Weakest{$weak_count}{'Winner'} = $i;
529 $Weakest{$weak_count}{'Loser'} = $j;
532 $Weakest{$weak_count}{'for'} = $Defeats{$i}{$j}{'for'};
533 $Weakest{$weak_count}{'against'} = $Defeats{$i}{$j}{'against'};
534 $Weakest{$weak_count}{'Winner'} = $i;
535 $Weakest{$weak_count}{'Loser'} = $j;
540 if (defined $Defeats{$j}{$i}{'for'}) {
542 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
543 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
544 $Weakest{$weak_count}{'Winner'} = $j;
545 $Weakest{$weak_count}{'Loser'} = $i;
547 } elsif ($Weakest{0}{'for'} > $Defeats{$j}{$i}{'for'}) {
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;
555 } elsif ($Weakest{0}{'Low'} == $Defeats{$j}{$i}{'for'}) {
556 if ($Weakest{0}{'against'} < $Defeats{$j}{$i}{'against'}) {
559 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
560 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
561 $Weakest{$weak_count}{'Winner'} = $j;
562 $Weakest{$weak_count}{'Loser'} = $i;
565 $Weakest{$weak_count}{'for'} = $Defeats{$j}{$i}{'for'};
566 $Weakest{$weak_count}{'against'} = $Defeats{$j}{$i}{'against'};
567 $Weakest{$weak_count}{'Winner'} = $j;
568 $Weakest{$weak_count}{'Loser'} = $i;
576 print {$RESULTS} "\n", "-=" x 35, "\n";
577 print {$RESULTS} "-=" x 35, "\n\n";
578 print {$RESULTS} "The winners are:\n";
579 foreach my $i (0 ..$#Schwartz) {
580 next unless $Schwartz[$i];
581 print {$RESULTS} "\t Option ", $order_to_options{$i + 1}{key}, " \"",
582 $order_to_options{$i + 1}{name}, "\"\n";
584 print {$RESULTS} "\n", "-=" x 35, "\n";
585 print {$RESULTS} "-=" x 35, "\n\n";
588 print {$RESULTS} "Weakest Defeat(s): \n";
589 foreach my $k (sort keys %Weakest) {
590 print {$RESULTS} "\tOption ", $order_to_options{$Weakest{$k}{'Winner'} + 1}{key},
591 " beats Option ", $order_to_options{$Weakest{$k}{'Loser'} + 1}{key}, " by ",
592 " ($Beat_Matrix[$Weakest{$k}{'Winner'}][$Weakest{$k}{'Loser'}] - ",
593 "$Beat_Matrix[$Weakest{$k}{'Loser'}][$Weakest{$k}{'Winner'}])\t",
594 "= ", $Weakest{$k}{'for'} - $Weakest{$k}{'against'}, " votes\n";
596 print {$RESULTS} "Deleting weakest defeat(s)\n\n";
597 foreach my $k (sort keys %Weakest) {
598 delete $Defeats{$Weakest{$k}{'Winner'}}{$Weakest{$k}{'Loser'}};
613 This is very inchoate, at the moment, and needs testing.
625 Manoj Srivastava <srivasta@debian.org>
627 =head1 COPYRIGHT AND LICENSE
629 This script is a part of the Devotee package, and is
631 Copyright (c) 2002, 2003, 2004, 2005 Manoj Srivastava <srivasta@debian.org>
633 This program is free software; you can redistribute it and/or modify
634 it under the terms of the GNU General Public License as published by
635 the Free Software Foundation; either version 2 of the License, or
636 (at your option) any later version.
638 This program is distributed in the hope that it will be useful,
639 but WITHOUT ANY WARRANTY; without even the implied warranty of
640 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
641 GNU General Public License for more details.
643 You should have received a copy of the GNU General Public License
644 along with this program; if not, write to the Free Software
645 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA