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

Contents of /votify/Votify.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (hide annotations) (download) (as text)
Mon May 16 18:40:07 2005 UTC (13 years, 7 months ago) by agriffis
Branch: MAIN
Changes since 1.3: +12 -4 lines
File MIME type: text/x-perl
fix shortname calculation

1 agriffis 1.4 # $Id: Votify.pm,v 1.3 2005/05/16 18:10:46 agriffis Exp $
2 agriffis 1.1 #
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 agriffis 1.2 my ($class, $mode) = @_;
20     $Votify::mode = $mode;
21 agriffis 1.1 }
22    
23     ######################################################################
24     # OfficialList
25     ######################################################################
26    
27     package OfficialList;
28    
29     sub new {
30 agriffis 1.2 my ($class, $election) = @_;
31     my ($self) = {
32     election => $election,
33     officials => [],
34     };
35 agriffis 1.1
36 agriffis 1.2 # 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 agriffis 1.1 }
45    
46     sub officials {
47 agriffis 1.2 my ($self) = @_;
48     @{$self->{'officials'}};
49 agriffis 1.1 }
50    
51     ######################################################################
52     # VoterList
53     ######################################################################
54    
55     package VoterList;
56    
57     sub new {
58 agriffis 1.2 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 agriffis 1.1
74 agriffis 1.2 # 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 agriffis 1.1 }
88    
89     sub confs {
90 agriffis 1.2 my ($self) = @_;
91     sort keys %{$self->{'voters'}};
92 agriffis 1.1 }
93    
94     sub voters {
95 agriffis 1.2 my ($self) = @_;
96     sort keys %{$self->{'confs'}};
97 agriffis 1.1 }
98    
99     sub getvoter {
100 agriffis 1.2 my ($self, $conf) = @_;
101     return $self->{'voters'}{$conf};
102 agriffis 1.1 }
103    
104     sub getconf {
105 agriffis 1.2 my ($self, $voter) = @_;
106     return $self->{'confs'}{$voter};
107 agriffis 1.1 }
108    
109     sub write {
110 agriffis 1.2 my ($self, $filename) = @_;
111 agriffis 1.1
112 agriffis 1.2 $filename ||= $self->{'default_filename'};
113     $self->{'filename'} = $filename;
114 agriffis 1.1
115 agriffis 1.2 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 agriffis 1.1 }
125    
126     ######################################################################
127     # MasterBallot
128     ######################################################################
129    
130     package MasterBallot;
131    
132 agriffis 1.2 use Data::Dumper;
133    
134 agriffis 1.1 sub new {
135 agriffis 1.2 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 agriffis 1.1
146 agriffis 1.2 bless $self, $class;
147     return $self;
148 agriffis 1.1 }
149    
150     sub collect {
151 agriffis 1.2 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 agriffis 1.1
159 agriffis 1.2 @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 agriffis 1.1 }
185    
186     sub write {
187 agriffis 1.2 my ($self, $filename) = @_;
188    
189     $filename ||= $self->{'default_filename'};
190     $self->{'filename'} = $filename;
191 agriffis 1.1
192 agriffis 1.2 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 agriffis 1.1
204 agriffis 1.2 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 agriffis 1.4 @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 agriffis 1.2 $s = substr $c, 0, $i;
236 agriffis 1.4 print join(" ", grep(/^$s/, @C)), "\n";
237 agriffis 1.2 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 agriffis 1.3 $table{"$c1+$c1"} = '***';
256 agriffis 1.2 }
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 agriffis 1.3 # 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 ($A does not beat $B and $B beats $A)\n";
388     }
389 agriffis 1.2 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 agriffis 1.3 print("$o1+$o2 ",
420     $self->{'table'}{"$o1+$o2"}, " $o2+$o1 ",
421 agriffis 1.2 $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 agriffis 1.3
441     return @candidates;
442 agriffis 1.1 }
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 agriffis 1.2 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 agriffis 1.1 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 agriffis 1.2 { local $/ = undef; $self->from_s(<F>); }
487 agriffis 1.1 close(F);
488     }
489    
490     sub populate {
491     my ($self) = @_;
492 agriffis 1.2 $self->read("$Votify::datadir/ballot-$self->{election}");
493 agriffis 1.1 @{$self->{'choices'}} = List::Util::shuffle(@{$self->{'choices'}});
494     }
495    
496     sub choices {
497 agriffis 1.2 my ($self) = @_;
498     $self->{'choices'};
499 agriffis 1.1 }
500    
501     sub write {
502     my ($self, $filename) = @_;
503    
504 agriffis 1.2 if ($Votify::mode ne 'user') {
505     die("we don't write ballots in official mode");
506     }
507 agriffis 1.1
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 agriffis 1.2 sub to_s {
637     my ($self) = @_;
638     join '', map "@$_\n", @{$self->{'choices'}};
639     }
640    
641 agriffis 1.1 1;
642    
643     __END__
644    
645 agriffis 1.3 $Log: Votify.pm,v $
646 agriffis 1.4 Revision 1.3 2005/05/16 18:10:46 agriffis
647     ranking works completely now, even if it needs badly to be refactored
648    
649 agriffis 1.3 Revision 1.2 2005/05/16 04:03:46 agriffis
650     add first pass at countify --rank
651    
652 agriffis 1.1
653     __END__
654    
655 agriffis 1.3 $Log: Votify.pm,v $
656 agriffis 1.4 Revision 1.3 2005/05/16 18:10:46 agriffis
657     ranking works completely now, even if it needs badly to be refactored
658    
659 agriffis 1.3 Revision 1.2 2005/05/16 04:03:46 agriffis
660     add first pass at countify --rank
661    
662 agriffis 1.1 Revision 1.3 2005/05/09 23:12:02 agriffis
663     Add support for registered voters
664    
665     Revision 1.2 2005/05/05 23:03:46 agriffis
666     Fix indentation (and some output as well)
667    
668     Revision 1.1 2005/05/05 22:05:34 agriffis
669     first pass at Gentoo Foundation voting program
670    
671 agriffis 1.2 # vim:sw=4 et

  ViewVC Help
Powered by ViewVC 1.1.20