/[gentoo-src]/votify/Votify.pm
Gentoo

Contents of /votify/Votify.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations) (download) (as text)
Mon May 16 23:58:09 2005 UTC (9 years, 7 months ago) by agriffis
Branch: MAIN
CVS Tags: HEAD
Changes since 1.4: +8 -2 lines
File MIME type: text/x-perl
change wording

1 # $Id: Votify.pm,v 1.4 2005/05/16 18:40:07 agriffis Exp $
2 #
3 # Copyright 2005 Gentoo Foundation
4 # Distributed under the terms of the GNU General Public License v2
5 #
6 # votify.pm: common classes for votify and countify
7 #
8
9 package Votify;
10
11 use POSIX;
12 use List::Util;
13 use strict;
14
15 our ($datadir) = '/home/agriffis/elections';
16 (our $zero = $0) =~ s,.*/,,;
17
18 sub import {
19 my ($class, $mode) = @_;
20 $Votify::mode = $mode;
21 }
22
23 ######################################################################
24 # OfficialList
25 ######################################################################
26
27 package OfficialList;
28
29 sub new {
30 my ($class, $election) = @_;
31 my ($self) = {
32 election => $election,
33 officials => [],
34 };
35
36 # no point in waiting to load
37 open(F, "<$Votify::datadir/officials-$election")
38 or die("failed to open officials file");
39 chomp(@{$self->{'officials'}} = <F>);
40 close(F);
41
42 bless $self, $class;
43 return $self;
44 }
45
46 sub officials {
47 my ($self) = @_;
48 @{$self->{'officials'}};
49 }
50
51 ######################################################################
52 # VoterList
53 ######################################################################
54
55 package VoterList;
56
57 sub new {
58 my ($class, $election) = @_;
59 my (@voterlist, $r);
60 my ($self) = {
61 election => $election,
62 default_filename => "$Votify::datadir/confs-$election",
63 filename => '',
64 voters => {}, # confnum => voter
65 confs => {}, # voter => confnum
66 };
67
68 # no point in waiting to load
69 open(F, "<$Votify::datadir/voters-$election")
70 or die("failed to open voters file");
71 chomp(@voterlist = <F>);
72 close(F);
73
74 # assign confirmation numbers randomly
75 for my $v (@voterlist) {
76 do { $r = int rand 0xffff } while exists $self->{'voters'}{$r};
77 $self->{'voters'}{$r} = $v;
78 $self->{'confs'}{$v} = $r;
79 }
80
81 unless (keys %{$self->{'voters'}} == keys %{$self->{'confs'}}) {
82 die("discrepancy deteced in VoterList");
83 }
84
85 bless $self, $class;
86 return $self;
87 }
88
89 sub confs {
90 my ($self) = @_;
91 sort keys %{$self->{'voters'}};
92 }
93
94 sub voters {
95 my ($self) = @_;
96 sort keys %{$self->{'confs'}};
97 }
98
99 sub getvoter {
100 my ($self, $conf) = @_;
101 return $self->{'voters'}{$conf};
102 }
103
104 sub getconf {
105 my ($self, $voter) = @_;
106 return $self->{'confs'}{$voter};
107 }
108
109 sub write {
110 my ($self, $filename) = @_;
111
112 $filename ||= $self->{'default_filename'};
113 $self->{'filename'} = $filename;
114
115 if (-f $filename) {
116 die "$filename already exists; please remove it first";
117 }
118
119 open(F, ">$filename") or die("can't write to $filename");
120 for my $c ($self->confs) {
121 printf F "%04x %s\n", $c, $self->getvoter($c);
122 }
123 close F;
124 }
125
126 ######################################################################
127 # MasterBallot
128 ######################################################################
129
130 package MasterBallot;
131
132 use Data::Dumper;
133
134 sub new {
135 my ($class, $election, $vl) = @_;
136 my ($self) = {
137 election => $election,
138 default_filename => "$Votify::datadir/master-$election",
139 filename => '',
140 voterlist => $vl,
141 ballots => {}, # indexed by conf num
142 candidates => undef, # indexed by long name
143 table => undef, # indexed by row+column
144 };
145
146 bless $self, $class;
147 return $self;
148 }
149
150 sub collect {
151 my ($self, @voters) = @_;
152 my ($c, $v, $home, @pwentry);
153
154 for my $v (@voters) {
155 unless (defined ($c = $self->{'voterlist'}->getconf($v))) {
156 die "$v does not correspond to any confirmation number";
157 }
158
159 @pwentry = getpwnam($v);
160 unless (@pwentry) {
161 print STDERR "Warning: unknown user: $v\n";
162 next;
163 }
164
165 $home = $pwentry[7];
166 unless (-d $home) {
167 print STDERR "Warning: no directory: $home\n";
168 next;
169 }
170
171 if (-f "$home/.ballot-$self->{election}-submitted") {
172 my ($b) = Ballot->new($self->{'election'});
173 $b->read("$home/.ballot-$self->{election}-submitted");
174 if ($b->verify) {
175 print STDERR "Errors found in ballot: $v\n";
176 next;
177 }
178 $self->{'ballots'}{$c} = $b;
179 }
180 elsif (-f "$home/.ballot-$self->{election}") {
181 print STDERR "Warning: $v did not submit their ballot\n";
182 }
183 }
184 }
185
186 sub write {
187 my ($self, $filename) = @_;
188
189 $filename ||= $self->{'default_filename'};
190 $self->{'filename'} = $filename;
191
192 if (-f $filename) {
193 die "$filename already exists; please remove it first";
194 }
195
196 open(F, ">$filename") or die("can't write to $filename");
197 for my $c (sort keys %{$self->{'ballots'}}) {
198 printf F "--------- confirmation %04x ---------\n", $c;
199 print F $self->{'ballots'}{$c}->to_s
200 }
201 close F;
202 }
203
204 sub read {
205 my ($self, $filename) = @_;
206 my ($election, $entries) = $self->{'election'};
207
208 $filename ||= $self->{'default_filename'};
209 $self->{'filename'} = $filename;
210
211 open(F, "<$filename") or die("can't read $filename");
212 { local $/ = undef; $entries = <F>; }
213 for my $e (split /^--------- confirmation /m, $entries) {
214 next unless $e; # skip the first zero-length record
215 unless ($e =~ /^([[:xdigit:]]{4}) ---------\n(.*)$/s) {
216 die "error parsing entry:\n$e";
217 }
218 my ($c, $s, $b) = ($1, $2, Ballot->new($election));
219 $b->from_s($s);
220 $self->{'ballots'}{hex($c)} = $b;
221 }
222 }
223
224 sub generate_candidates {
225 my ($self) = @_;
226 my ($B, @C, $s);
227
228 # nb: would need to scan all the ballots to support write-ins
229 $B = Ballot->new($self->{'election'});
230 $B->populate;
231 @C = sort map $_->[0], @{$B->choices};
232 for my $c (@C) {
233 $s = $c; # in case $c is shorter than 5 chars
234 for (my $i=5; $i<=length($c); $i++) {
235 $s = substr $c, 0, $i;
236 print join(" ", grep(/^$s/, @C)), "\n";
237 last unless grep(/^$s/, @C) > 1;
238 }
239 $self->{'candidates'}{$c} = $s;
240 }
241 }
242
243 sub tabulate {
244 my ($self) = @_;
245 my (@candidates); # full candidate list
246 my (%table); # resulting table, row.colum where row defeats column
247 $self->{'table'} = \%table;
248
249 $self->generate_candidates unless $self->{'candidates'};
250 @candidates = keys %{$self->{'candidates'}};
251 for my $c1 (@candidates) {
252 for my $c2 (@candidates) {
253 $table{"$c1+$c2"} = 0;
254 }
255 $table{"$c1+$c1"} = '***';
256 }
257
258 # generate the table first;
259 # walk through the ballots, tallying the rankings expressed by each ballot
260 for my $b (values %{$self->{'ballots'}}) {
261 my (@choices, %ranks);
262
263 #print "looking at ballot:\n", $b->to_s, "\n";
264
265 # first determine the ranking of each candidate. default ranking is
266 # scalar @candidates.
267 @choices = @{$b->choices};
268 @ranks{@candidates} = (scalar @candidates) x @candidates;
269 #print "ranks before determining:\n", Dumper(\%ranks);
270 for (my $i = 0; $i < @choices; $i++) {
271 @ranks{@{$choices[$i]}} = ($i) x @{$choices[$i]};
272 }
273 #print "ranks after determining:\n", Dumper(\%ranks);
274
275 # second add the results of all the pairwise races into our table
276 for my $c1 (@candidates) {
277 for my $c2 (@candidates) {
278 next if $c1 eq $c2;
279 $table{"$c1+$c2"}++ if $ranks{$c1} < $ranks{$c2};
280 }
281 }
282 #print "table after adding:\n";
283 #$self->display_table;
284 }
285 }
286
287 sub display_table {
288 my ($self) = @_;
289 my (@longnames, @shortnames);
290 my ($minlen, $maxlen, $formatstr) = (0, 4, '');
291
292 $self->generate_candidates unless $self->{'candidates'};
293 @longnames = sort keys %{$self->{'candidates'}};
294 @shortnames = sort values %{$self->{'candidates'}};
295 $minlen = length scalar keys %{$self->{'ballots'}};
296 $minlen = 5 if $minlen < 5;
297
298 # build the format string
299 for my $s (@shortnames) {
300 if (length($s) > $minlen) {
301 $formatstr .= " %" . length($s) . "s";
302 } else {
303 $formatstr .= " %${minlen}s";
304 }
305 }
306 map { $maxlen = length($_) if length($_) > $maxlen } @longnames;
307
308 # prepend the row header; append newline
309 $formatstr = "%${maxlen}s" . $formatstr . "\n";
310
311 # column headers
312 printf $formatstr, '', @shortnames;
313
314 # rows
315 for my $l (@longnames) {
316 printf $formatstr, $l, @{$self->{'table'}}{map "$l+$_", @longnames};
317 }
318 }
319
320 # utility for cssd
321 sub defeats {
322 my ($self, $o1, $o2) = @_;
323 return 0 if $o1 eq $o2;
324 $self->{'table'}{"$o1+$o2"} > $self->{'table'}{"$o2+$o1"};
325 }
326
327 # utility for cssd
328 sub is_weaker_defeat {
329 my ($self, $A, $X, $B, $Y) = @_;
330 die unless $self->defeats($A, $X);
331 die unless $self->defeats($B, $Y);
332 return (
333 $self->{'table'}{"$A+$X"} < $self->{'table'}{"$B+$Y"} or
334 (
335 $self->{'table'}{"$A+$X"} == $self->{'table'}{"$B+$Y"} and
336 $self->{'table'}{"$X+$A"} > $self->{'table'}{"$Y+$B"}
337 )
338 );
339 }
340
341 sub cssd {
342 my ($self) = @_;
343 my (@candidates);
344
345 @candidates = sort keys %{$self->{'candidates'}};
346
347 while (1) {
348 my (%transitive_defeats);
349 my (@active, @plist);
350
351 ######################################################################
352 # 5. From the list of [undropped] pairwise defeats, we generate a
353 # set of transitive defeats.
354 # 1. An option A transitively defeats an option C if A
355 # defeats C or if there is some other option B where A
356 # defeats B AND B transitively defeats C.
357 for my $o1 (@candidates) {
358 for my $o2 (@candidates) {
359 $transitive_defeats{"$o1+$o2"} = 1 if $self->defeats($o1, $o2);
360 }
361 }
362 for my $i (@candidates) {
363 for my $j (@candidates) {
364 for my $k (@candidates) {
365 if (exists $transitive_defeats{"$j+$i"} and
366 exists $transitive_defeats{"$i+$k"})
367 {
368 $transitive_defeats{"$j+$k"} = 1;
369 }
370 }
371 }
372 }
373
374 ######################################################################
375 # 6. We construct the Schwartz set from the set of transitive
376 # defeats.
377 # 1. An option A is in the Schwartz set if for all options B,
378 # either A transitively defeats B, or B does not
379 # transitively defeat A.
380 print "\n";
381 A: for my $A (@candidates) {
382 for my $B (@candidates) {
383 next if $transitive_defeats{"$A+$B"} or not $transitive_defeats{"$B+$A"};
384 # countify marks entries +++ instead of *** when they've already
385 # been ranked.
386 if ($self->{'table'}{"$A+$A"} eq '***') {
387 print "option $A is eliminated ($B trans-defeats $A, and $A does not trans-defeat $B)\n";
388 }
389 next A;
390 }
391 push @active, $A;
392 }
393 print "the Schwartz set is {", join(", ", @active), "}\n";
394 @candidates = @active;
395
396 ######################################################################
397 # 7. If there are defeats between options in the Schwartz set, we
398 # drop the weakest such defeats from the list of pairwise
399 # defeats, and return to step 5.
400 # 1. A defeat (A,X) is weaker than a defeat (B,Y) if V(A,X)
401 # is less than V(B,Y). Also, (A,X) is weaker than (B,Y) if
402 # V(A,X) is equal to V(B,Y) and V(X,A) is greater than V
403 # (Y,B).
404 # 2. A weakest defeat is a defeat that has no other defeat
405 # weaker than it. There may be more than one such defeat.
406 for my $o1 (@candidates) {
407 for my $o2 (@candidates) {
408 push @plist, [ $o1, $o2 ] if $self->defeats($o1, $o2);
409 }
410 }
411 last unless @plist;
412 @plist = sort {
413 return -1 if $self->is_weaker_defeat(@$a, @$b);
414 return +1 if $self->is_weaker_defeat(@$b, @$a);
415 return 0;
416 } @plist;
417 for my $dx (@plist) {
418 my ($o1, $o2) = @$dx;
419 print("$o1+$o2 ",
420 $self->{'table'}{"$o1+$o2"}, " $o2+$o1 ",
421 $self->{'table'}{"$o2+$o1"}, "\n");
422 }
423 my ($o1, $o2) = @{$plist[0]};
424 $self->{'table'}{"$o1+$o2"} = 0;
425 $self->{'table'}{"$o2+$o1"} = 0;
426 }
427
428 ######################################################################
429 # 8. If there are no defeats within the Schwartz set, then the
430 # winner is chosen from the options in the Schwartz set. If
431 # there is only one such option, it is the winner. If there
432 # are multiple options, the elector with the casting vote
433 # chooses which of those options wins.
434 print "\n";
435 if (@candidates > 1) {
436 print "result: tie between options ", join(", ", @candidates), "\n";
437 } else {
438 print "result: option @candidates wins\n";
439 }
440
441 return @candidates;
442 }
443
444 ######################################################################
445 # Ballot
446 ######################################################################
447
448 package Ballot;
449
450 sub new {
451 my ($class, $election) = @_;
452 my ($self) = {
453 election => $election,
454 filename => '',
455 default_filename => $ENV{'HOME'}."/.ballot-$election",
456 choices => [],
457 };
458
459 # Bless me, I'm a ballot!
460 bless $self, $class;
461 return $self;
462 }
463
464 sub from_s {
465 my ($self, $s) = @_;
466 my (@choices);
467
468 for (split "\n", $s) {
469 s/#.*//;
470 next unless /\S/;
471 push @choices, [ split(' ', $_) ];
472 }
473 die("No data in string") unless @choices;
474
475 $self->{'choices'} = \@choices;
476 }
477
478 sub read {
479 my ($self, $filename) = @_;
480
481 $filename ||= $self->{'default_filename'};
482 $self->{'filename'} = $filename;
483
484 # Load the data file
485 open(F, "<$filename") or die("couldn't open $filename");
486 { local $/ = undef; $self->from_s(<F>); }
487 close(F);
488 }
489
490 sub populate {
491 my ($self) = @_;
492 $self->read("$Votify::datadir/ballot-$self->{election}");
493 @{$self->{'choices'}} = List::Util::shuffle(@{$self->{'choices'}});
494 }
495
496 sub choices {
497 my ($self) = @_;
498 $self->{'choices'};
499 }
500
501 sub write {
502 my ($self, $filename) = @_;
503
504 if ($Votify::mode ne 'user') {
505 die("we don't write ballots in official mode");
506 }
507
508 $filename ||= $self->{'default_filename'};
509 $self->{'filename'} = $filename;
510
511 # Don't ever overwrite a ballot
512 die("File already exists; please remove $filename\n") if -e $filename;
513
514 # Write the user's ballot
515 open(F, ">$filename") or die "Failed writing $filename";
516 print F <<EOT;
517 # This is a ballot for the $self->{election} election.
518 # Please rank your choices in order; first choice at the top and last choice at
519 # the bottom. You can put choices on the same line to indicate no preference
520 # between them. Any choices you omit from this file are implicitly added at the
521 # end.
522 #
523 # When you're finished editing this, the next step is to verify your ballot
524 # with:
525 #
526 # $Votify::zero --verify $self->{election}
527 #
528 # When that passes and you're satisfied, the final step is to submit your vote:
529 #
530 # $Votify::zero --submit $self->{election}
531 #
532
533 EOT
534 for (@{$self->{'choices'}}) { print F "@$_\n"; }
535 close(F);
536 }
537
538 sub verify {
539 my ($self) = @_;
540 my (%h, $master, %mh);
541 my (@dups, @missing, @extra);
542 my ($errors_found);
543
544 # Load %h from the user's ballot
545 for my $line (@{$self->{'choices'}}) {
546 for my $entry (@$line) {
547 $h{$entry}++;
548 }
549 }
550
551 # Load the master ballot into another hash and compare them.
552 # The master ballots always do one entry per line, making this a little
553 # easier.
554 $master = Ballot->new($self->{'election'});
555 $master->populate;
556 %mh = map(($_->[0] => 1), @{$master->{'choices'}});
557
558 # Check for extra entries (write-ins should be supported in the future)
559 for (keys %h) {
560 push @extra, $_ unless exists $mh{$_};
561 }
562
563 # Check for duplicate entries
564 @dups = grep { $h{$_} > 1 } keys %h;
565
566 # Check for missing entries (not necessarily an error)
567 for (keys %mh) {
568 push @missing, $_ unless exists $h{$_};
569 }
570
571 # Report errors and warnings
572 if (@extra) {
573 if ($Votify::mode eq 'user') {
574 print <<EOT;
575 Your ballot has some extra entries that are not part of this election. Sorry,
576 but write-ins are not (yet) supported. Please remove these from your ballot:
577
578 EOT
579 print map "\t$_\n", @extra;
580 print "\n";
581 }
582 $errors_found++;
583 }
584 if (@dups) {
585 if ($Votify::mode eq 'user') {
586 print <<EOT;
587 Your ballot has some duplicate entries. Please resolve these to a single entry
588 to avoid ambiguities:
589
590 EOT
591 print map "\t$_\n", @dups;
592 print "\n";
593 }
594 $errors_found++;
595 }
596 if (@{$self->{'choices'}} == 0) {
597 if ($Votify::mode eq 'user') {
598 print <<EOT;
599 Your ballot doesn't contain any entries. You can start over by first removing
600 the existing ballot, then using --new to generate a new ballot. See --help for
601 more information.
602
603 EOT
604 }
605 $errors_found++;
606 }
607 elsif (@missing and $Votify::mode eq 'user') {
608 print <<EOT;
609 Your ballot is missing some entries. This is not an error, but note that these
610 will be implied as a final line, with no preference between them, like this:
611
612 EOT
613 print "\t", join(" ", @missing), "\n";
614 print "\n";
615 }
616 if ($Votify::mode eq 'user' and !$errors_found and
617 @{$self->{'choices'}} == 1 and
618 scalar(keys %h) == scalar(keys %mh))
619 {
620 print <<EOT;
621 Your ballot contains all the candidates on a single line! This means you have
622 no preference between the candidates. This is not an error, but note that this
623 is a meaningless ballot that will have no effect on the election.
624
625 EOT
626 }
627
628 # Stop if there were errors
629 if ($Votify::mode eq 'user' and $errors_found) {
630 print("There were errors found in your ballot.\n");
631 die("Please correct them and try again.\n\n");
632 }
633 return $errors_found;
634 }
635
636 sub to_s {
637 my ($self) = @_;
638 join '', map "@$_\n", @{$self->{'choices'}};
639 }
640
641 1;
642
643 __END__
644
645 $Log: Votify.pm,v $
646 Revision 1.4 2005/05/16 18:40:07 agriffis
647 fix shortname calculation
648
649 Revision 1.3 2005/05/16 18:10:46 agriffis
650 ranking works completely now, even if it needs badly to be refactored
651
652 Revision 1.2 2005/05/16 04:03:46 agriffis
653 add first pass at countify --rank
654
655
656 __END__
657
658 $Log: Votify.pm,v $
659 Revision 1.4 2005/05/16 18:40:07 agriffis
660 fix shortname calculation
661
662 Revision 1.3 2005/05/16 18:10:46 agriffis
663 ranking works completely now, even if it needs badly to be refactored
664
665 Revision 1.2 2005/05/16 04:03:46 agriffis
666 add first pass at countify --rank
667
668 Revision 1.3 2005/05/09 23:12:02 agriffis
669 Add support for registered voters
670
671 Revision 1.2 2005/05/05 23:03:46 agriffis
672 Fix indentation (and some output as well)
673
674 Revision 1.1 2005/05/05 22:05:34 agriffis
675 first pass at Gentoo Foundation voting program
676
677 # vim:sw=4 et

  ViewVC Help
Powered by ViewVC 1.1.20