4 # The Scottish Local Government Elections Order 2007
16 # Prefs => [ [ CAND, ...], ... ],
18 # We edit Prefs as we go
24 # $cands{CAND}{NonCont} # undef, or Elected or Eliminated
29 our @non_transferable;
35 open DEBUG, ">.compute.log" or die $!;
39 print DEBUG Dumper(\%tie,
46 $SIG{__WARN__} = sub {
47 $SIG{__DIE__} = undef;
59 if ($opt =~ m/^[A-Z]/) {
60 die "unknown option $_ for $what";
61 } elsif ($opt =~ m/^[a-z]/) {
62 print STDERR "warning (line $.): unknown option $_ for $what\n";
69 foreach $_ (split / /, $') {
70 if (m/^_?[Ss]eats=(\d+)/) {
72 } elsif (m/^_?[Tt]ie=(.*)\>(.*)$/) {
73 my @more = split /\,/, $1;
74 my @less = split /\,/, $2;
75 my @all = join ',', sort (@more, @less);
76 $tie{"@all"}{Win} = $more[0] if @more == 1;
77 $tie{"@all"}{Lose} = $less[0] if @less == 1;
79 unkopt "election", $_;
82 } elsif (m/^(\w+) = (\S*) \|/) {
83 my ($cand,$desc) = ($1,$2);
84 unkopt "candidate $cand", $_ foreach split / /, $';
85 $cands{$cand}{Desc} = $desc;
86 } elsif (m/^(\w*) :\s*(.*)\s*\|(.*)/) {
87 my ($voter,$prefs,$opts) = ($1,$2,$3);
88 my $v = { Voter => $voter, Prefs => [ ] };
89 push @{ $v->{Prefs} }, [ $_ =~ m/\w+/g ]
90 foreach split /\s+/, $prefs;
91 foreach $_ (split / /, $opts) {
92 if (m/^_?[Ww]eight=(\d+)\/(\d+)$/) {
93 $v->{Weight} = $1 / $2;
94 } elsif (m/^_?[Ww]eight=([0-9.]+)$/) {
95 $v->{Weight} = new Math::BigRat $1;
97 unkopt "voter $v->{Voter}", $_;
108 $cands{$_}{Cand} = $_ foreach keys %cands;
109 $_->{Weight} //= 1/1 foreach @allvotes;
110 $_->{TransferredSurplus} //= [ ] foreach @allvotes;
111 $_->{OrigPrefs} //= [ @{ $_->{Prefs} } ] foreach @allvotes;
115 push @{ $vote->{Log} }, "stage $stage: $m";
119 sub sortballots (@) {
120 # Takes each argument, which should be a ballot, sorts
121 # it into $cand{CAND}{Votes} according to first preference.
122 # Strips that first preference from the ballot.
123 # If the first preference has been eliminated, strips it
124 # and looks for further preferences.
125 print DEBUG "sortballots ".(scalar @_)."...\n";
127 my $firstprefs = shift @{ $v->{Prefs} };
128 my $w = $v->{Weight};
129 if (!$firstprefs || !@$firstprefs) {
130 votelog $v, "no more preferences, non transferable";
131 push @non_transferable, $v;
134 if (@$firstprefs > 1) {
135 votelog $v, "splitting due to several equal first preferences";
136 foreach my $fpref (@$firstprefs) {
139 Weight => $w / @$firstprefs,
140 Prefs => [ [ $fpref ], @{ $v->{Prefs} } ],
142 votelog $v, "split for $fpref";
146 my $fp = $firstprefs->[0];
148 my $noncont = $c->{NonCont};
150 votelog $v, "dropping pref $fp, $noncont";
154 votelog $v, "sorted into pile for candidate $fp weight $w";
155 push @{ $c->{Votes} }, $v;
161 printf "stage %d: ".$fmt, $stage, @_;
164 sub countballots () {
165 foreach my $c (values %cands) {
166 next if $c->{NonCont};
168 $c->{Total} += $_->{Weight} foreach @{ $c->{Votes} };
169 print DEBUG "counted $c->{Cand} $c->{Total}\n";
170 $c->{History}[$stage-1] = $c->{Total};
173 foreach my $c (reverse sort total_history_cmp
174 grep { !$_->{NonCont} } values %cands) {
175 prf "candidate %-10s: %10s votes\n", $c->{Cand}, $c->{Total};
179 sub computequota () {
180 my $totalvalid = 0/1;
181 $totalvalid += $_->{Total} foreach values %cands;
182 $quota = ($totalvalid / (1 + $seats)) -> bfloor();
183 prf "quota %10s\n", $quota;
186 sub total_history_cmp () {
187 my $ha = $a->{History};
188 my $hb = $b->{History};
189 my $m = "stage $stage history cmp $a->{Cand} $b->{Cand}";
190 print DEBUG "$m...\n";
191 foreach my $s (reverse 0 .. $stage-1) {
192 my $d = $ha->[$s] <=> $hb->[$s];
194 print DEBUG "$m => $d (#$s $ha->[$s] $hb->[$s])\n";
197 print DEBUG "$m => 0\n";
202 grep { !$_->{NonCont} } values %cands;
205 sub select_best_worst ($$$$) {
206 my ($wantcand, $wanttiebreak, $signum, $what) = @_;
207 # $wantcand->($c) = boolish
208 # $wanttiebreak->($total) = boolish
209 # Firstly candidates not meeting $wantcand are ignored
210 # Then we pick the best (worst) candiate by Total (or vote history).
211 # (SLGEO 49(2) and 51(2).
212 # If this does not help then totals are equal and we call wanttiebreak.
213 # If it returns 0 we return alphabetically first CAND. Otherwise
216 my @maybe = grep { $wantcand->($_) } continuing();
217 @maybe = sort total_history_cmp @maybe;
218 @maybe = reverse @maybe if $signum > 0;
220 return undef unless @maybe;
225 my $nextc = $maybe[$nequal];
228 # Only interested in those who compare equal according to the
229 # history (SLGEO 49(2)); NB our history includes the current
232 last if $signum*($a = $maybe[0], $b = $nextc, total_history_cmp) > 0;
236 if ($nequal > 1 && !$wanttiebreak->($maybe[0]{Total})) {
237 # ... if equal for election we can do them one by one, since
238 # order does not matter (SLGEO 49 talks about `two or more
245 my @all = map { $_->{Cand} } @maybe[0 .. $nequal-1];
246 my $tiekey = $signum > 0 ? 'Win' : 'Lose';
247 $selectcand = $tie{"@all"}{$tiekey};
248 die "need tie break, want $tiekey from @all"
249 unless defined $selectcand;
250 prf "$what %s due to tie break amongst %s\n",
253 $selectcand = $maybe[0]{Cand};
254 prf "$what %s\n", $selectcand;
257 return $cands{$selectcand};
262 prf "*** ELECT %s \`%s' ***\n", $c->{Cand}, $c->{Desc};
263 $c->{NonCont} = 'Elected';
271 sortballots @allvotes if $stage == 1;
273 my $seats_remain = $seats
274 - grep { ($_->{NonCont} // '') eq 'Elected' } values %cands;
275 if (continuing() <= $seats_remain) {
276 foreach my $c (continuing()) {
277 prf "electing %s to fill remaining place(s)\n", $c->{Cand};
285 computequota if $stage == 1;
287 my $c = select_best_worst
288 sub { $_->{Total} >= $quota },
294 votelog $_, "helped elect $c->{Cand}" foreach @{ $c->{Votes} };
297 my $surplus = $c->{Total} - $quota;
299 if ($surplus <= 0/1) {
307 prf "surplus %10s\n", $surplus;
309 foreach my $v (@{ $c->{Votes} }) {
310 my $previously = $v->{TransferredSurplus};
311 push @$previously, $c->{Cand};
313 my $A = $surplus * $v->{Weight};
315 my $xfervalue = ((($A * $F) / $B) -> bfloor() ) / $F;
316 # SLGEO 48(3): we do arithmetic to 5 d3ecimal places,
317 # but always rounding down
318 votelog $v, "transferring with value $xfervalue (A=$A B=$B)";
319 $v->{Weight} = $xfervalue;
321 if (defined $tspr{"@$previously"}) {
322 die unless $tspr{"@$previously"} == $xfervalue;
324 $tspr{"@$previously"} = $xfervalue;
325 prf "transfer value of ballots %s: %10s\n",
326 "@$previously", $xfervalue;
329 sortballots @{ $c->{Votes} };
331 $c->{Votes} = { }; # will crash if we access it again
335 # No-one to elect, must eliminate
336 $c = select_best_worst
342 prf "=== eliminating %s \`%s' ===\n", $c->{Cand}, $c->{Desc};
343 $c->{NonCont} = 'Eliminated';
345 sortballots @{ $c->{Votes} };