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