chiark / gitweb /
stv: wip, delay transfer
[appendix-a6.git] / stv
1 #!/usr/bin/perl -w
2 #
3 # Does STV according to
4 #  http://www.rosenstiel.co.uk/stvrules/av/index.htm
5
6 use strict;
7 use utf8;
8 use autodie;
9 use bigrat;
10 use List::MoreUtils qw(nsort_by);
11
12 # vote is
13 #  { Voter => opaque,
14 #    Prefs => [ list ],
15 #    Weight => 1.0 }
16
17 our $stage=0;
18 our @allvotes;
19
20 our $places = shift @ARGV;
21 die unless $places eq ($places + 0);
22
23 while (<>) {
24     next if m/^\w+$/;
25     m/^(\w+) ([A-Z]+)$/ or die "$_ ?";
26     my $prefs = $1;
27     my $vote = {
28         Voter => $1,
29         Weight => 1.0,
30         Prefs => [ split //, $prefs ],
31     };
32     push @allvotes, $vote;
33 }
34
35 sub pr ($) {
36     my ($f) = @_;
37     return sprintf "%10.6f=%-10s", $f, $f;
38 }
39
40 sub votelog ($$) {
41     my ($vote,$m) = @_;
42     push @{ $vote->{Log} }, "stage $stage: $m";
43 }
44
45 sub filterout ($$) {
46     my ($cand, $why) = @_;
47     foreach my $vote (@allvotes) {
48         my $oldprefs = $vote->{Prefs};
49         my @prefs = grep { $_ ne $cand } $oldprefs;
50         next if @prefs == @$oldprefs;
51         votelog $vote, "crossed out candidate $cand: $why";
52     }
53 }
54
55 our @elected; # $elected[] = $candidate
56
57 our @unsorted = @allvotes;
58
59 our %sorted;
60 # $sorted{$firstpref}{Votes} = [ $vote, ... ]
61 # $sorted{$firstpref}{Cand} = $firstpref
62 # $sorted{$firstpref}{Total} = $totalweight
63 our @sorted; # values same as %sorted
64 our @surpluses; # values same as %sorted
65
66 our @exhausted; # votes
67
68 our %continuing; # $continuing{$candidate}=1
69
70 our @stagerecord; # $stagerecord[]{$candidate} = $total
71
72 foreach my $vote (@allvotes) {
73     $continuing{$_}=1 foreach @{ $vote->{Prefs} };
74 }
75
76 sub equalpiles ($@) {
77     my ($how, @sorted) = @_;
78     return () unless @sorted;
79     my $s = $sorted[0];
80     my $eqtotal = $s->{Total};
81     my $count = 0;
82     while ($count < @$sorted && $sorted[$count]{Total} == $eqtotal) {
83         printf "%7s %10s\n", $how, $sorted[$count]{Cand};
84         $count++;
85     }
86     
87
88 for (;;) {
89     $stage++;
90
91     while (my $vote = shift @unsorted) {
92         my ($firstpref) = grep { $continuing{$_} } @{ $vote->{Prefs} };
93         if (!defined $firstpref) {
94             votelog $vote, "ballot exhausted";
95             push @exhausted, $vote;
96         } else {
97             push @{ $sorted{$firstpref}{Votes} }, $vote;
98         }
99     }
100     $sorted{$_}{Cand} = $_ foreach keys %sorted;
101     foreach my $firstpref (sort keys %sorted) {
102         foreach my $vote (@{ $sorted{$firstpref}{Votes} }) {
103             votelog $vote, "counted $vote->{Weight} for $firstpref";
104             $sorted{$firstpref}{Total} += $vote->{Weight};
105         }
106     }
107     my @sorted;
108     my $sort_update = sub {
109         @sorted = nsort_by { -$_->{Total} } values %sorted;
110     };
111     $sort_update->();
112
113     push @stagerecord, { map { ($_->{Cand}, $_->{Total}) } @sorted };
114
115     my $totalvalid = 0;
116     my $countvalid = sub {
117         my ($l, $what) = @_;
118         foreach my $s (@$l) {
119             printf "%-7s %10s %s\n", $what, $s->{Cand}, pr $s->{Total};
120             $totalvalid += $s->{Total};
121         }
122     };
123     $countvalid->(\@sorted,    '1stpref');
124     $countvalid->(\@surpluses, 'surplus');
125
126     printf "%7s %10s %s\n", 'TOTAL', '', pr $totalvalid;
127
128     unless ($totalvalid > 0) {
129         printf "No more votes!\n";
130         last;
131     }
132
133     my $placesremain = $places - @elected;
134
135     unless ($placesremain > 0) {
136         printf "Complete.\n";
137         last;
138     }
139
140     my $quota = $totalvalid / ($placesremain + 1);
141     printf "%7s %10s %s\n", '', 'quota', pr $quota;
142
143     my $need_to_transfer_surplus = 1;
144
145     # Look for people to elect.
146     # We elect as many as we can, rather than recomputing the (lower) quota
147     # (ERS rules 5.4.9)
148     for (;;) {
149         my $s = $sorted[0];
150         my $topvoters = $s->{Weight};
151         my $surplus = $topvoters - $quota;
152         last unless $surplus > 0;
153
154         printf "%7s %10s\n", 'ELECTED', $s->{Cand};
155         push @elected, $s->{Cand};
156
157         my $derate = $topvoters / $surplus;
158         printf "%7s %10s\n", 'derate', $s->{Cand}, pr $derate;
159
160         foreach my $vote (@{ $s->{Votes} }) {
161             votelog $vote, "elected $s->{Cand}, derated $weightmult";
162             $vote->{Weight} /= $derate;
163         }
164         push @surpluses, $s;
165         delete %sorted{ $s->{Cand} };
166         delete $continuing{ $s->{Cand} };
167
168         $sort_update->();
169         $need_to_transfer_surplus = 0;
170         # before actually transferring a surplus, we will consider
171         # eliminating, and then reconsider with a lower quota
172     }
173
174     my $deferredsurplus = sum map { $_->{Total} } @surpluses;
175     printf "%7s %10s %s\n", 'def.srp', 'total', pr $deferredsurplus;
176
177     # Look for people to eliminate
178     # We eliminate before trying to transfer surpluses
179     # ERS 5.2.5
180     for (;;) {
181         last unless @sorted;
182
183         my @elim = equalpiles 'elim?', reverse @sorted;
184         my $elimvote = sum map { $_->{Total} } @elim;
185         my $elimvotetotal = $elimvote * scalar @elim;
186
187         if (@surpluses and $elimvotetotal > $deferredsurplus) {
188             printf "no-elim, un-defer\n";
189             last;
190         }
191
192         if ((scalar keys %continuing) - (scalar @elim) < $placesremain) {
193             # eliminate only one then, and try again
194             printf "elim-tie!\n";
195             @elim = historically_prefer -1, @elim;
196         }
197
198         foreach my $s (@elim) {
199             my $c = $s->{Cand};
200             printf "%7s %10s\n", 'ELIM', $c;
201             my $votes = $s->{Votes};
202             votelog $_, "failed to stop $c elimination" foreach @$votes;
203             delete %continuing{$c};
204             delete %sorted{$c};
205             push @unsorted, @$votes;
206         }
207         
208         $sort_update->();
209         $need_to_transfer_surplus = 0;
210     }
211     
212     next unless $need_to_transfer_surplus;
213
214     @surpluses = nsort_by { $_->{Total} }, @surpluses;
215     my @surplusxfer = equalpiles 'xfer?', @surpluses;
216     die unless @surplusxfer;
217
218     if (@surplusxfer > 1) {
219         @surplusxfer = historically_prefer +1, @surplusxfer;
220     }
221
222     my $s = $surplusxfer[0];
223     my $c = $s->{Cand};
224     printf "%7s %10s\n", 'xfer', $c;
225     my $votes = $s->{Votes};
226     votelog $_, "surplus transferred" foreach @$votes;
227     @surpluses = grep { $_->{Cand} ne $c } @surpluses;
228     push @unsorted, @$votes;
229 }
230
231 print "done.\n";