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

Diff of /votify/Votify.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

Revision 1.1 Revision 1.2
1# $Id: Votify.pm,v 1.1 2005/05/15 03:25:41 agriffis Exp $ 1# $Id: Votify.pm,v 1.2 2005/05/16 04:03:46 agriffis Exp $
2# 2#
3# Copyright 2005 Gentoo Foundation 3# Copyright 2005 Gentoo Foundation
4# Distributed under the terms of the GNU General Public License v2 4# Distributed under the terms of the GNU General Public License v2
5# 5#
6# votify.pm: common classes for votify and countify 6# votify.pm: common classes for votify and countify
14 14
15our ($datadir) = '/home/agriffis/elections'; 15our ($datadir) = '/home/agriffis/elections';
16(our $zero = $0) =~ s,.*/,,; 16(our $zero = $0) =~ s,.*/,,;
17 17
18sub import { 18sub import {
19 my ($class, $mode) = @_; 19 my ($class, $mode) = @_;
20 $Votify::mode = $mode; 20 $Votify::mode = $mode;
21} 21}
22 22
23###################################################################### 23######################################################################
24# OfficialList 24# OfficialList
25###################################################################### 25######################################################################
26 26
27package OfficialList; 27package OfficialList;
28 28
29sub new { 29sub new {
30 my ($class, $election) = @_; 30 my ($class, $election) = @_;
31 my ($self) = { 31 my ($self) = {
32 election => $election, 32 election => $election,
33 officials => [], 33 officials => [],
34 }; 34 };
35 35
36 # no point in waiting to load 36 # no point in waiting to load
37 open(F, "<$Votify::datadir/officials-$election") 37 open(F, "<$Votify::datadir/officials-$election")
38 or die("failed to open officials file"); 38 or die("failed to open officials file");
39 chomp(@{$self->{'officials'}} = <F>); 39 chomp(@{$self->{'officials'}} = <F>);
40 close(F); 40 close(F);
41 41
42 bless $self, $class; 42 bless $self, $class;
43 return $self; 43 return $self;
44} 44}
45 45
46sub officials { 46sub officials {
47 my ($self) = @_; 47 my ($self) = @_;
48 @{$self->{'officials'}}; 48 @{$self->{'officials'}};
49} 49}
50 50
51###################################################################### 51######################################################################
52# VoterList 52# VoterList
53###################################################################### 53######################################################################
54 54
55package VoterList; 55package VoterList;
56 56
57sub new { 57sub new {
58 my ($class, $election) = @_; 58 my ($class, $election) = @_;
59 my (@voterlist, $r); 59 my (@voterlist, $r);
60 my ($self) = { 60 my ($self) = {
61 election => $election, 61 election => $election,
62 default_filename => "$Votify::datadir/confs-$election", 62 default_filename => "$Votify::datadir/confs-$election",
63 filename => '', 63 filename => '',
64 voters => {}, # confnum => voter 64 voters => {}, # confnum => voter
65 confs => {}, # voter => confnum 65 confs => {}, # voter => confnum
66 }; 66 };
67 67
68 # no point in waiting to load 68 # no point in waiting to load
69 open(F, "<$Votify::datadir/voters-$election") 69 open(F, "<$Votify::datadir/voters-$election")
70 or die("failed to open voters file"); 70 or die("failed to open voters file");
71 chomp(@voterlist = <F>); 71 chomp(@voterlist = <F>);
72 close(F); 72 close(F);
73 73
74 # assign confirmation numbers randomly 74 # assign confirmation numbers randomly
75 for my $v (@voterlist) { 75 for my $v (@voterlist) {
76 do { $r = int rand 0xffff } while exists $self->{'voters'}{$r}; 76 do { $r = int rand 0xffff } while exists $self->{'voters'}{$r};
77 $self->{'voters'}{$r} = $v; 77 $self->{'voters'}{$r} = $v;
78 $self->{'confs'}{$v} = $r; 78 $self->{'confs'}{$v} = $r;
79 } 79 }
80 80
81 unless (keys %{$self->{'voters'}} == keys %{$self->{'confs'}}) { 81 unless (keys %{$self->{'voters'}} == keys %{$self->{'confs'}}) {
82 die("discrepancy deteced in VoterList"); 82 die("discrepancy deteced in VoterList");
83 } 83 }
84 84
85 bless $self, $class; 85 bless $self, $class;
86 return $self; 86 return $self;
87} 87}
88 88
89sub confs { 89sub confs {
90 my ($self) = @_; 90 my ($self) = @_;
91 sort keys %{$self->{'voters'}}; 91 sort keys %{$self->{'voters'}};
92} 92}
93 93
94sub voters { 94sub voters {
95 my ($self) = @_; 95 my ($self) = @_;
96 sort keys %{$self->{'confs'}}; 96 sort keys %{$self->{'confs'}};
97} 97}
98 98
99sub getvoter { 99sub getvoter {
100 my ($self, $conf) = @_; 100 my ($self, $conf) = @_;
101 return $self->{'voters'}{$conf}; 101 return $self->{'voters'}{$conf};
102} 102}
103 103
104sub getconf { 104sub getconf {
105 my ($self, $voter) = @_; 105 my ($self, $voter) = @_;
106 return $self->{'confs'}{$voter}; 106 return $self->{'confs'}{$voter};
107} 107}
108 108
109sub write { 109sub write {
110 my ($self, $filename) = @_; 110 my ($self, $filename) = @_;
111 111
112 $filename ||= $self->{'default_filename'}; 112 $filename ||= $self->{'default_filename'};
113 $self->{'filename'} = $filename; 113 $self->{'filename'} = $filename;
114 114
115 if (-f $filename) { 115 if (-f $filename) {
116 die "$filename already exists; please remove it first"; 116 die "$filename already exists; please remove it first";
117 } 117 }
118 118
119 open(F, ">$filename") or die("can't write to $filename"); 119 open(F, ">$filename") or die("can't write to $filename");
120 for my $c ($self->confs) { 120 for my $c ($self->confs) {
121 printf F "%04x %s\n", $c, $self->getvoter($c); 121 printf F "%04x %s\n", $c, $self->getvoter($c);
122 } 122 }
123 close F; 123 close F;
124} 124}
125 125
126###################################################################### 126######################################################################
127# MasterBallot 127# MasterBallot
128###################################################################### 128######################################################################
129 129
130package MasterBallot; 130package MasterBallot;
131 131
132use Data::Dumper;
133
132sub new { 134sub new {
133 my ($class, $election, $vl) = @_; 135 my ($class, $election, $vl) = @_;
134 my ($self) = { 136 my ($self) = {
135 election => $election, 137 election => $election,
136 default_filename => "$Votify::datadir/master-$election", 138 default_filename => "$Votify::datadir/master-$election",
137 filename => '', 139 filename => '',
138 voterlist => $vl, 140 voterlist => $vl,
139 full => {}, # indexed by conf num 141 ballots => {}, # indexed by conf num
140 }; 142 candidates => undef, # indexed by long name
143 table => undef, # indexed by row+column
144 };
141 145
142 bless $self, $class; 146 bless $self, $class;
143 return $self; 147 return $self;
144} 148}
145 149
146sub collect { 150sub collect {
147 my ($self, @voters) = @_; 151 my ($self, @voters) = @_;
148 my ($c, $v, $home, @pwentry); 152 my ($c, $v, $home, @pwentry);
149 153
150 for my $v (@voters) { 154 for my $v (@voters) {
151 unless (defined ($c = $self->{'voterlist'}->getconf($v))) { 155 unless (defined ($c = $self->{'voterlist'}->getconf($v))) {
152 die "$v does not correspond to any confirmation number"; 156 die "$v does not correspond to any confirmation number";
153 } 157 }
154 158
155 @pwentry = getpwnam($v); 159 @pwentry = getpwnam($v);
156 unless (@pwentry) { 160 unless (@pwentry) {
157 print STDERR "Warning: unknown user: $v\n"; 161 print STDERR "Warning: unknown user: $v\n";
158 next; 162 next;
159 } 163 }
160 164
161 $home = $pwentry[7]; 165 $home = $pwentry[7];
162 unless (-d $home) { 166 unless (-d $home) {
163 print STDERR "Warning: no directory: $home\n"; 167 print STDERR "Warning: no directory: $home\n";
164 next; 168 next;
165 } 169 }
166 170
167 if (-f "$home/.ballot-$self->{election}-submitted") { 171 if (-f "$home/.ballot-$self->{election}-submitted") {
168 my ($b) = Ballot->new($self->{'election'}); 172 my ($b) = Ballot->new($self->{'election'});
169 $b->load("$home/.ballot-$self->{election}-submitted"); 173 $b->read("$home/.ballot-$self->{election}-submitted");
170 if ($b->verify) { 174 if ($b->verify) {
171 print STDERR "Errors found in ballot: $v\n"; 175 print STDERR "Errors found in ballot: $v\n";
172 next; 176 next;
173 } 177 }
174 $self->{'full'}{$c} = $b->choices; 178 $self->{'ballots'}{$c} = $b;
175 } 179 }
176 elsif (-f "$home/.ballot-$self->{election}") { 180 elsif (-f "$home/.ballot-$self->{election}") {
177 print STDERR "Warning: $v did not submit their ballot\n"; 181 print STDERR "Warning: $v did not submit their ballot\n";
178 } 182 }
179 } 183 }
180} 184}
181 185
182sub write { 186sub write {
183 my ($self, $filename) = @_; 187 my ($self, $filename) = @_;
184 188
185 $filename ||= $self->{'default_filename'}; 189 $filename ||= $self->{'default_filename'};
186 $self->{'filename'} = $filename; 190 $self->{'filename'} = $filename;
187 191
188 if (-f $filename) { 192 if (-f $filename) {
189 die "$filename already exists; please remove it first"; 193 die "$filename already exists; please remove it first";
190 } 194 }
191 195
192 open(F, ">$filename") or die("can't write to $filename"); 196 open(F, ">$filename") or die("can't write to $filename");
193 for my $c (sort keys %{$self->{'full'}}) { 197 for my $c (sort keys %{$self->{'ballots'}}) {
194 printf F "--------- confirmation %04x ---------\n", $c; 198 printf F "--------- confirmation %04x ---------\n", $c;
195 for my $line (@{$self->{'full'}{$c}}) { 199 print F $self->{'ballots'}{$c}->to_s
196 print F "@$line\n"; 200 }
197 }
198 }
199 close F; 201 close F;
202}
203
204sub 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
224sub 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 @{$B->choices};
232 for my $c (map $_->[0], @C) {
233 for (my $i=1; $i<=length($c); $i++) {
234 $s = substr $c, 0, $i;
235 last unless grep(/^$s/, @C) > 1;
236 }
237 $self->{'candidates'}{$c} = $s;
238 }
239}
240
241sub tabulate {
242 my ($self) = @_;
243 my (@candidates); # full candidate list
244 my (%table); # resulting table, row.colum where row defeats column
245 $self->{'table'} = \%table;
246
247 $self->generate_candidates unless $self->{'candidates'};
248 @candidates = keys %{$self->{'candidates'}};
249 for my $c1 (@candidates) {
250 for my $c2 (@candidates) {
251 $table{"$c1+$c2"} = 0;
252 }
253 $table{"$c1+$c1"} = '-';
254 }
255
256 # generate the table first;
257 # walk through the ballots, tallying the rankings expressed by each ballot
258 for my $b (values %{$self->{'ballots'}}) {
259 my (@choices, %ranks);
260
261 #print "looking at ballot:\n", $b->to_s, "\n";
262
263 # first determine the ranking of each candidate. default ranking is
264 # scalar @candidates.
265 @choices = @{$b->choices};
266 @ranks{@candidates} = (scalar @candidates) x @candidates;
267 #print "ranks before determining:\n", Dumper(\%ranks);
268 for (my $i = 0; $i < @choices; $i++) {
269 @ranks{@{$choices[$i]}} = ($i) x @{$choices[$i]};
270 }
271 #print "ranks after determining:\n", Dumper(\%ranks);
272
273 # second add the results of all the pairwise races into our table
274 for my $c1 (@candidates) {
275 for my $c2 (@candidates) {
276 next if $c1 eq $c2;
277 $table{"$c1+$c2"}++ if $ranks{$c1} < $ranks{$c2};
278 }
279 }
280 #print "table after adding:\n";
281 #$self->display_table;
282 }
283
284 # now display the table
285 $self->display_table;
286}
287
288sub display_table {
289 my ($self) = @_;
290 my (@longnames, @shortnames);
291 my ($minlen, $maxlen, $formatstr) = (0, 4, '');
292
293 $self->generate_candidates unless $self->{'candidates'};
294 @longnames = sort keys %{$self->{'candidates'}};
295 @shortnames = sort values %{$self->{'candidates'}};
296 $minlen = length scalar keys %{$self->{'ballots'}};
297 $minlen = 5 if $minlen < 5;
298
299 # build the format string
300 for my $s (@shortnames) {
301 if (length($s) > $minlen) {
302 $formatstr .= " %" . length($s) . "s";
303 } else {
304 $formatstr .= " %${minlen}s";
305 }
306 }
307 map { $maxlen = length($_) if length($_) > $maxlen } @longnames;
308
309 # prepend the row header; append newline
310 $formatstr = "%${maxlen}s" . $formatstr . "\n";
311
312 # column headers
313 printf $formatstr, '', @shortnames;
314
315 # rows
316 for my $l (@longnames) {
317 printf $formatstr, $l, @{$self->{'table'}}{map "$l+$_", @longnames};
318 }
319}
320
321# utility for cssd
322sub defeats {
323 my ($self, $o1, $o2) = @_;
324 return 0 if $o1 eq $o2;
325 $self->{'table'}{"$o1+$o2"} > $self->{'table'}{"$o2+$o1"};
326}
327
328# utility for cssd
329sub is_weaker_defeat {
330 my ($self, $A, $X, $B, $Y) = @_;
331 die unless $self->defeats($A, $X);
332 die unless $self->defeats($B, $Y);
333 return (
334 $self->{'table'}{"$A+$X"} < $self->{'table'}{"$B+$Y"} or
335 (
336 $self->{'table'}{"$A+$X"} == $self->{'table'}{"$B+$Y"} and
337 $self->{'table'}{"$X+$A"} > $self->{'table'}{"$Y+$B"}
338 )
339 );
340}
341
342sub cssd {
343 my ($self) = @_;
344 my (@candidates);
345
346 @candidates = sort keys %{$self->{'candidates'}};
347
348 while (1) {
349 my (%transitive_defeats);
350 my (@active, @plist);
351
352 ######################################################################
353 # 5. From the list of [undropped] pairwise defeats, we generate a
354 # set of transitive defeats.
355 # 1. An option A transitively defeats an option C if A
356 # defeats C or if there is some other option B where A
357 # defeats B AND B transitively defeats C.
358 for my $o1 (@candidates) {
359 for my $o2 (@candidates) {
360 $transitive_defeats{"$o1+$o2"} = 1 if $self->defeats($o1, $o2);
361 }
362 }
363 for my $i (@candidates) {
364 for my $j (@candidates) {
365 for my $k (@candidates) {
366 if (exists $transitive_defeats{"$j+$i"} and
367 exists $transitive_defeats{"$i+$k"})
368 {
369 $transitive_defeats{"$j+$k"} = 1;
370 }
371 }
372 }
373 }
374
375 ######################################################################
376 # 6. We construct the Schwartz set from the set of transitive
377 # defeats.
378 # 1. An option A is in the Schwartz set if for all options B,
379 # either A transitively defeats B, or B does not
380 # transitively defeat A.
381 print "\n";
382 A: for my $A (@candidates) {
383 for my $B (@candidates) {
384 next if $transitive_defeats{"$A+$B"} or not $transitive_defeats{"$B+$A"};
385 print "option $A is eliminated ($A does not beat $B and $B beats $A)\n";
386 next A;
387 }
388 push @active, $A;
389 }
390 print "the Schwartz set is {", join(", ", @active), "}\n";
391 @candidates = @active;
392
393 ######################################################################
394 # 7. If there are defeats between options in the Schwartz set, we
395 # drop the weakest such defeats from the list of pairwise
396 # defeats, and return to step 5.
397 # 1. A defeat (A,X) is weaker than a defeat (B,Y) if V(A,X)
398 # is less than V(B,Y). Also, (A,X) is weaker than (B,Y) if
399 # V(A,X) is equal to V(B,Y) and V(X,A) is greater than V
400 # (Y,B).
401 # 2. A weakest defeat is a defeat that has no other defeat
402 # weaker than it. There may be more than one such defeat.
403 for my $o1 (@candidates) {
404 for my $o2 (@candidates) {
405 push @plist, [ $o1, $o2 ] if $self->defeats($o1, $o2);
406 }
407 }
408 last unless @plist;
409 @plist = sort {
410 return -1 if $self->is_weaker_defeat(@$a, @$b);
411 return +1 if $self->is_weaker_defeat(@$b, @$a);
412 return 0;
413 } @plist;
414 for my $dx (@plist) {
415 my ($o1, $o2) = @$dx;
416 print(@$dx, " ",
417 $self->{'table'}{"$o1+$o2"}, " ",
418 $self->{'table'}{"$o2+$o1"}, "\n");
419 }
420 my ($o1, $o2) = @{$plist[0]};
421 $self->{'table'}{"$o1+$o2"} = 0;
422 $self->{'table'}{"$o2+$o1"} = 0;
423 }
424
425 ######################################################################
426 # 8. If there are no defeats within the Schwartz set, then the
427 # winner is chosen from the options in the Schwartz set. If
428 # there is only one such option, it is the winner. If there
429 # are multiple options, the elector with the casting vote
430 # chooses which of those options wins.
431 print "\n";
432 if (@candidates > 1) {
433 print "result: tie between options ", join(", ", @candidates), "\n";
434 } else {
435 print "result: option @candidates wins\n";
436 }
200} 437}
201 438
202###################################################################### 439######################################################################
203# Ballot 440# Ballot
204###################################################################### 441######################################################################
217 # Bless me, I'm a ballot! 454 # Bless me, I'm a ballot!
218 bless $self, $class; 455 bless $self, $class;
219 return $self; 456 return $self;
220} 457}
221 458
459sub from_s {
460 my ($self, $s) = @_;
461 my (@choices);
462
463 for (split "\n", $s) {
464 s/#.*//;
465 next unless /\S/;
466 push @choices, [ split(' ', $_) ];
467 }
468 die("No data in string") unless @choices;
469
470 $self->{'choices'} = \@choices;
471}
472
222sub load { 473sub read {
223 my ($self, $filename) = @_; 474 my ($self, $filename) = @_;
224 475
225 $filename ||= $self->{'default_filename'}; 476 $filename ||= $self->{'default_filename'};
226 $self->{'filename'} = $filename; 477 $self->{'filename'} = $filename;
227 478
228 # Load the data file 479 # Load the data file
229 $self->{'choices'} = []; # make sure it's empty
230 open(F, "<$filename") or die("couldn't open $filename"); 480 open(F, "<$filename") or die("couldn't open $filename");
231 while(<F>) { 481 { local $/ = undef; $self->from_s(<F>); }
232 s/#.*//;
233 next unless /\S/;
234 push @{$self->{'choices'}}, [ split(' ', $_) ];
235 }
236 close(F); 482 close(F);
237 die("No data in file") unless @{$self->{'choices'}};
238} 483}
239 484
240sub populate { 485sub populate {
241 my ($self) = @_; 486 my ($self) = @_;
242 $self->load("$Votify::datadir/ballot-$self->{election}"); 487 $self->read("$Votify::datadir/ballot-$self->{election}");
243 @{$self->{'choices'}} = List::Util::shuffle(@{$self->{'choices'}}); 488 @{$self->{'choices'}} = List::Util::shuffle(@{$self->{'choices'}});
244} 489}
245 490
246sub choices { 491sub choices {
247 my ($self) = @_; 492 my ($self) = @_;
248 $self->{'choices'}; 493 $self->{'choices'};
249} 494}
250 495
251sub write { 496sub write {
252 my ($self, $filename) = @_; 497 my ($self, $filename) = @_;
253 498
254 if ($Votify::mode ne 'user') { 499 if ($Votify::mode ne 'user') {
255 die("we don't write ballots in official mode"); 500 die("we don't write ballots in official mode");
256 } 501 }
257 502
258 $filename ||= $self->{'default_filename'}; 503 $filename ||= $self->{'default_filename'};
259 $self->{'filename'} = $filename; 504 $self->{'filename'} = $filename;
260 505
261 # Don't ever overwrite a ballot 506 # Don't ever overwrite a ballot
381 die("Please correct them and try again.\n\n"); 626 die("Please correct them and try again.\n\n");
382 } 627 }
383 return $errors_found; 628 return $errors_found;
384} 629}
385 630
631sub to_s {
632 my ($self) = @_;
633 join '', map "@$_\n", @{$self->{'choices'}};
634}
635
3861; 6361;
387 637
388__END__ 638__END__
389 639
390$Log: Votify.pm,v $ 640$Log: Votify.pm,v $
391Revision 1.1 2005/05/15 03:25:41 agriffis 641Revision 1.2 2005/05/16 04:03:46 agriffis
392add Votify.pm and first cut at countify 642add first pass at countify --rank
393 643
394 644
395__END__ 645__END__
396 646
397$Log: Votify.pm,v $ 647$Log: Votify.pm,v $
398Revision 1.1 2005/05/15 03:25:41 agriffis 648Revision 1.2 2005/05/16 04:03:46 agriffis
399add Votify.pm and first cut at countify 649add first pass at countify --rank
400 650
401Revision 1.3 2005/05/09 23:12:02 agriffis 651Revision 1.3 2005/05/09 23:12:02 agriffis
402Add support for registered voters 652Add support for registered voters
403 653
404Revision 1.2 2005/05/05 23:03:46 agriffis 654Revision 1.2 2005/05/05 23:03:46 agriffis
405Fix indentation (and some output as well) 655Fix indentation (and some output as well)
406 656
407Revision 1.1 2005/05/05 22:05:34 agriffis 657Revision 1.1 2005/05/05 22:05:34 agriffis
408first pass at Gentoo Foundation voting program 658first pass at Gentoo Foundation voting program
409 659
410# vim:sw=4 noet 660# vim:sw=4 et

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.20