chiark / gitweb /
compute-scottish-stv: wip, test produces undefs
[appendix-a6.git] / compute-scottish-stv
1 #!/usr/bin/perl -w
2
3 # Reference:
4 # The Scottish Local Government Elections Order 2007
5
6 use strict;
7 use bigrat;
8
9 # Data structures:
10 #
11 # vote is
12 #   { Voter => opaque,
13 #     Prefs => [ [ CAND, ...], ... ],
14 #     Weight => 1.0 }
15 # We edit Prefs as we go
16
17 # $cands{CAND}{Cand}
18 # $cands{CAND}{Desc}
19 # $cands{CAND}{Votes}
20 # $cands{CAND}{Total}
21 # $cands{CAND}{NonCont} # undef, or Elected or Eliminated
22
23 our $seats=0;
24
25 our @allvotes;
26 our @non_transferable;
27 our %cands;
28 our $stage=0;
29 our $quota;
30 our %tie;
31
32 sub unkopt ($$) {
33     my ($what,$opt) = @_;
34     if ($opt =~ m/^[A-Z]/) {
35         die "unknown option $_ for $what";
36     } elsif ($opt =~ m/^[a-z]/) {
37         print STDERR "warning (line $.): unknown option $_ for $what\n";
38     }
39 }
40
41 for (;;) {
42     $_ = <>;
43     if (m/^\| /) {
44         foreach $_ (split / /, $') {
45             if (m/^_?[Ss]eats=(\d+)/) {
46                 $seats = $1;
47             } elsif (m/^_?[Tt]ie=(.*)\>(.*)$/) {
48                 my @more = split /\,/, $1;
49                 my @less = split /\,/, $2;
50                 my @all = join ',', sort (@more, @less);
51                 $tie{"@all"}{Win}  = $more[0] if @more == 1;
52                 $tie{"@all"}{Lose} = $less[0] if @less == 1;
53             } else {
54                 unkopt "election", $_;
55             }
56         }
57     } elsif (m/^(\w+) = (\S*) \|/) {
58         my ($cand,$desc) = @_;
59         unkopt "candidate $cand", $_ foreach split / /, $';
60         $cands{$cand}{Desc} = $desc;
61     } elsif (m/^(\w*) :\s*(.*)\s*\|(.*)/) {
62         my ($voter,$prefs,$opts) = ($1,$2,$3);
63         my $v = { Voter => $voter };
64         push @{ $v->{Prefs} }, [ $_ =~ m/\w+/g ]
65             foreach split /\s+/, $prefs;
66         foreach $_ (split / /, $opts) {
67             if (m/^_?[Ww]eight=(\d+)\/(\d+)$/) {
68                 $v->{Weight} = $1 / $2;
69             } elsif (m/^_?[Ww]eight=([0-9.]+)$/) {
70                 $v->{Weight} = new Math::BigRat $1;
71             } else {
72                 unkopt "voter $v->{Voter}", $_;
73             }
74         }
75         push @allvotes, $v;
76     } elsif (m/^\.$/) {
77         last;
78     } else {
79         die "$_ ?";
80     }
81 }
82
83 $cands{$_}{Cand} = $_ foreach keys %cands;
84
85 sub votelog ($$) {
86     my ($vote,$m) = @_;
87     push @{ $vote->{Log} }, "stage $stage: $m";
88 }
89
90 sub sortballots (@) {
91     # Takes each argument, which should be a ballot, sorts
92     # it into $cand{CAND}{Votes} according to first preference.
93     # Strips that first preference from the ballot.
94     # If the first preference has been eliminated, strips it
95     # and looks for further preferences.
96     foreach my $v (@_) {
97         my $firstprefs = shift @{ $v->{Prefs} };
98         my $w = $v->{Weight};
99         if (!$firstprefs || !@$firstprefs) {
100             votelog $v, "no more preferences, non transferable";
101             push @non_transferable, $v;
102             next;
103         }
104         if (@$firstprefs > 1) {
105             votelog $v, "splitting due to several equal first preferences";
106             foreach my $fpref (@$firstprefs) {
107                 my $v2 = {
108                     %$v,
109                     Weight => $w / @$firstprefs,
110                     Prefs => [ [ $fpref ], @{ $v->{Prefs} } ],
111                 };
112                 votelog $v, "split for $fpref";
113             }
114             next;
115         }
116         my $fp = $firstprefs->[0];
117         my $c = $cands{$fp};
118         my $noncont = $c->{NonCont};
119         if ($noncont) {
120             votelog $v, "dropping pref $fp, $noncont";
121             sortvallots $v;
122             next;
123         }
124         votelog $v, "sorted into pile for candidate $fp weight $w";
125         push @{ $c->{Votes} }, $v;
126     }
127 }
128
129 sub prf {
130     my $fmt = shift;
131     printf "stage %d: ".$_, $stage, @_;
132 }
133
134 sub countballots () {
135     foreach my $cand (sort keys %cands) {
136         my $c = $cands{$cand};
137         next if $c->{NonCont};
138         $c->{Total} = 0;
139         $c->{Total} += $_->{Weight} foreach @{ $c->{Voters} };
140         prf "cand %s: %s votes\n", $stage, $cand, $c->{Total};
141         $c->{History}[$stage-1] = $c->{Total};
142     }
143 }
144
145 sub computequota () {
146     my $totalvalid = 0;
147     $totalvalid += $_->{Total} foreach keys %cands;
148     $quota = floor($totalvalid / (1 + $seats));
149 }
150
151 sub total_history_cmp () {
152     my $ha = $a->{History};
153     my $hb = $b->{History};
154     foreach my $s (reverse 1 .. $stage) {
155         my $d = $ha->[$s] <=> $hb->[$s];
156         next unless $d;
157         print DEBUG "history cmp $a->{Cand} $b->{Cand}".
158             " => $d (#$s $ha->[$s] $hb->[$s])\n";
159         return $d;
160     }
161     return 0;
162 }
163
164 sub continuing () {
165     grep { !$_->{NonCont} } values %cands;
166 }
167
168 sub select_best_worst ($$$$) {
169     my ($wantcand, $wanttiebreak, $signum, $what) = @_;
170     # $wantcand->($c) = boolish
171     # $wanttiebreak->($total) = boolish
172     # Firstly candidates not meeting $wantcand are ignored
173     # Then we pick the best (worst) candiate by Total (or vote history).
174     # (SLGEO 49(2) and 51(2).
175     # If this does not help then totals are equal and we call wanttiebreak.
176     # If it returns 0 we return alphabetically first CAND.  Otherwise
177     # we tie break.
178
179     my @maybe = grep { $wantcand->($_) } continuing();
180     @maybe = sort total_history_cmp @maybe;
181     @maybe = reverse @maybe if $signum > 0;
182
183     return undef unless @maybe;
184
185     my $nequal = 1;
186
187     for (;;) {
188         my $nextc = $maybe[$nequal];
189
190         # Only interested in those who compare equal according to the
191         # history (SLGEO 49(2)); NB our history includes the current
192         # round.
193         
194         last if $signum*($a = $maybe[0], $b = $nextc, total_history_cmp) > 0;
195         $nextc++;
196     }
197
198     if ($nequal > 1 && !$wanttiebreak->($maybe[0]{Total})) {
199         # ... if equal for election we can do them one by one, since
200         # order does not matter (SLGEO 49 talks about `two or more
201         # ... exceeds').
202         $nequal = 1;
203     }
204
205     my $selectcand;
206     if ($nequal > 1) {
207         my @all = map { $_->{Cand} } @maybe[0 .. $nequal-1];
208         my $tiekey = $signum > 0 ? 'Win' : 'Lose';
209         my $win = $tie{"@all"}{$tiekey};
210         die "need tie break, want $tiekey from @all" unless defined $win;
211         prf "$what %s due to tie break amongst %s\n",
212             $selectcand, "@all";
213     } else {
214         $selectcand = $maybe[0];
215         prf "$what %s\n";
216     }
217
218     return $cands{$selectcand};
219 }
220
221 sub elect_core ($) {
222     my ($c) = @_;
223     prf "*** ELECT %s \`%s' ***\n", $c->{Cand}, $c->{Desc};
224     $c->{NonCont} = 'Elected';
225 }
226
227 sortballots @allvotes;
228
229 for (;;) {
230     $stage++;
231
232     my $seats_remain = $seats
233         - grep { $_->{NonCont} eq 'Elected' } values %cands;
234     if (continuing() <= $seats_remain) {
235         foreach my $c (continuing()) {
236             prf "electing %s to fill remaining place(s)\n", $c->{Cand};
237             elect_core $c;
238         }
239         last;
240     }
241
242     countballots();
243
244     my $c = select_best_worst
245         sub { $_->{Total} >= $quota },
246         sub { $_ > $quota },
247         +1, 'electing';
248
249     if ($c) {
250         elect_core $c;
251         votelog $_, "helped elect $c->{Cand}" foreach @{ $c->{Votes} };
252         
253         # SLGEO 48
254         my $surplus = $c->{Total} - $quota;
255
256         if ($surplus <= 0) {
257             prf "no surplus\n";
258             next;
259         }
260
261         my $B = $c->{Weight};
262
263         foreach my $v (@{ $c->{Votes} }) {
264             my $A = $surplus * $v->{Weight};
265             my $F = 100000;
266             my $xfervalue = floor(($A * $F) / $B) / $F;
267             # SLGEO 48(3): we do arithmetic to 5 d3ecimal places,
268             # but always rounding down
269             votelog $v, "transferring with value $xfervalue (A=$A B=$B)";
270             $v->{Weight} = $xfervalue;
271             sortballots $v;
272         }
273         $c->{Votes} = { }; # will crash if we access it again
274         next;
275     }
276
277     # No-one to elect, must eliminate
278     $c = select_best_worst
279         sub { 1; },
280         sub { 1; },
281         -1, 'eliminating';
282
283     if ($c) {
284         prf "=== eliminating %s (%s) ===\n", $c->{Cand}, $c->{Desc};
285         $c->{NonCont} = 'Eliminated';
286         next;
287     }
288
289     die;
290 }
291
292 print "done.\n";